From fc77a8b8103817a0ae37fc62a887bd2cd2efb94d Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 12 Apr 2019 15:38:33 +0200 Subject: [PATCH 001/578] removed references to TPU in photosynthesis code --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 42 +--------------------- 1 file changed, 1 insertion(+), 41 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 09840da049..cc1343d4ec 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -149,8 +149,6 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! (umol co2/m**2/s) real(r8) :: jmax_z ! leaf layer maximum electron transport rate ! (umol electrons/m**2/s) - real(r8) :: tpu_z ! leaf layer triose phosphate utilization rate - ! (umol CO2/m**2/s) real(r8) :: kp_z ! leaf layer initial slope of CO2 response ! curve (C4 plants) real(r8) :: c13disc_z(nclmax,maxpft,nlevleaf) ! carbon 13 in newly assimilated carbon at leaf level @@ -488,14 +486,12 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ft, & ! in currentCohort%vcmax25top, & ! in currentCohort%jmax25top, & ! in - currentCohort%tpu25top, & ! in currentCohort%kp25top, & ! in nscaler, & ! in bc_in(s)%t_veg_pa(ifp), & ! in btran_eff, & ! in vcmax_z, & ! out jmax_z, & ! out - tpu_z, & ! out kp_z ) ! out ! Part IX: This call calculates the actual photosynthesis for the @@ -510,7 +506,6 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ft, & ! in vcmax_z, & ! in jmax_z, & ! in - tpu_z, & ! in kp_z, & ! in bc_in(s)%t_veg_pa(ifp), & ! in bc_in(s)%esat_tv_pa(ifp), & ! in @@ -812,7 +807,6 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ft, & ! in vcmax, & ! in jmax, & ! in - tpu, & ! in co2_rcurve_islope, & ! in veg_tempk, & ! in veg_esat, & ! in @@ -855,7 +849,6 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in integer, intent(in) :: ft ! (plant) Functional Type Index real(r8), intent(in) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) real(r8), intent(in) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) - real(r8), intent(in) :: tpu ! triose phosphate utilization rate (umol CO2/m**2/s) real(r8), intent(in) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) real(r8), intent(in) :: veg_tempk ! vegetation temperature real(r8), intent(in) :: veg_esat ! saturation vapor pressure at veg_tempk (Pa) @@ -1030,9 +1023,6 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in aj = je * max(co2_inter_c-co2_cpoint, 0._r8) / & (4._r8*co2_inter_c+8._r8*co2_cpoint) - ! C3: Product-limited photosynthesis - ap = 3._r8 * tpu - else ! C4: Rubisco-limited photosynthesis @@ -1053,22 +1043,13 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in aj = aj / (laisha_lsl * canopy_area_lsl) end if - ! C4: PEP carboxylase-limited (CO2-limited) - ap = co2_rcurve_islope * max(co2_inter_c, 0._r8) / can_press - end if - ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap + ! Gross photosynthesis smoothing calculations. aquad = theta_cj(c3c4_path_index) bquad = -(ac + aj) cquad = ac * aj call quadratic_f (aquad, bquad, cquad, r1, r2) - ai = min(r1,r2) - - aquad = theta_ip - bquad = -(ai + ap) - cquad = ai * ap - call quadratic_f (aquad, bquad, cquad, r1, r2) agross = min(r1,r2) ! Net carbon assimilation. Exit iteration if an < 0 @@ -1633,7 +1614,6 @@ subroutine GetCanopyGasParameters(can_press, & ! Activation energy, from: ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 - ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 real(r8), parameter :: kcha = 79430._r8 ! activation energy for kc (J/mol) real(r8), parameter :: koha = 36380._r8 ! activation energy for ko (J/mol) @@ -1754,14 +1734,12 @@ subroutine LeafLayerBiophysicalRates( parsun_lsl, & ft, & vcmax25top_ft, & jmax25top_ft, & - tpu25top_ft, & co2_rcurve_islope25top_ft, & nscaler, & veg_tempk, & btran, & vcmax, & jmax, & - tpu, & co2_rcurve_islope ) ! --------------------------------------------------------------------------------- @@ -1774,7 +1752,6 @@ subroutine LeafLayerBiophysicalRates( parsun_lsl, & ! The output biophysical rates are: ! vcmax: maximum rate of carboxilation, ! jmax: maximum electron transport rate, - ! tpu: triose phosphate utilization rate and ! co2_rcurve_islope: initial slope of CO2 response curve (C4 plants) ! --------------------------------------------------------------------------------- @@ -1791,8 +1768,6 @@ subroutine LeafLayerBiophysicalRates( parsun_lsl, & ! for this pft (umol CO2/m**2/s) real(r8), intent(in) :: jmax25top_ft ! canopy top maximum electron transport rate at 25C ! for this pft (umol electrons/m**2/s) - real(r8), intent(in) :: tpu25top_ft ! canopy top triose phosphate utilization rate at 25C - ! for this pft (umol CO2/m**2/s) real(r8), intent(in) :: co2_rcurve_islope25top_ft ! initial slope of CO2 response curve ! (C4 plants) at 25C, canopy top, this pft real(r8), intent(in) :: veg_tempk ! vegetation temperature @@ -1801,8 +1776,6 @@ subroutine LeafLayerBiophysicalRates( parsun_lsl, & real(r8), intent(out) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) real(r8), intent(out) :: jmax ! maximum electron transport rate ! (umol electrons/m**2/s) - real(r8), intent(out) :: tpu ! triose phosphate utilization rate - ! (umol CO2/m**2/s) real(r8), intent(out) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) ! Locals @@ -1811,8 +1784,6 @@ subroutine LeafLayerBiophysicalRates( parsun_lsl, & ! (umol CO2/m**2/s) real(r8) :: jmax25 ! leaf layer: maximum electron transport rate at 25C ! (umol electrons/m**2/s) - real(r8) :: tpu25 ! leaf layer: triose phosphate utilization rate at 25C - ! (umol CO2/m**2/s) real(r8) :: co2_rcurve_islope25 ! leaf layer: Initial slope of CO2 response curve ! (C4 plants) at 25C @@ -1821,50 +1792,39 @@ subroutine LeafLayerBiophysicalRates( parsun_lsl, & ! --------------------------------------------------------------------------------- real(r8) :: vcmaxha ! activation energy for vcmax (J/mol) real(r8) :: jmaxha ! activation energy for jmax (J/mol) - real(r8) :: tpuha ! activation energy for tpu (J/mol) real(r8) :: vcmaxhd ! deactivation energy for vcmax (J/mol) real(r8) :: jmaxhd ! deactivation energy for jmax (J/mol) - real(r8) :: tpuhd ! deactivation energy for tpu (J/mol) real(r8) :: vcmaxse ! entropy term for vcmax (J/mol/K) real(r8) :: jmaxse ! entropy term for jmax (J/mol/K) - real(r8) :: tpuse ! entropy term for tpu (J/mol/K) real(r8) :: vcmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) real(r8) :: jmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) - real(r8) :: tpuc ! scaling factor for high temperature inhibition (25 C = 1.0) vcmaxha = EDPftvarcon_inst%vcmaxha(FT) jmaxha = EDPftvarcon_inst%jmaxha(FT) - tpuha = EDPftvarcon_inst%tpuha(FT) vcmaxhd = EDPftvarcon_inst%vcmaxhd(FT) jmaxhd = EDPftvarcon_inst%jmaxhd(FT) - tpuhd = EDPftvarcon_inst%tpuhd(FT) vcmaxse = EDPftvarcon_inst%vcmaxse(FT) jmaxse = EDPftvarcon_inst%jmaxse(FT) - tpuse = EDPftvarcon_inst%tpuse(FT) vcmaxc = fth25_f(vcmaxhd, vcmaxse) jmaxc = fth25_f(jmaxhd, jmaxse) - tpuc = fth25_f(tpuhd, tpuse) if ( parsun_lsl <= 0._r8) then ! night time vcmax = 0._r8 jmax = 0._r8 - tpu = 0._r8 co2_rcurve_islope = 0._r8 else ! day time ! Vcmax25top was already calculated to derive the nscaler function vcmax25 = vcmax25top_ft * nscaler jmax25 = jmax25top_ft * nscaler - tpu25 = tpu25top_ft * nscaler co2_rcurve_islope25 = co2_rcurve_islope25top_ft * nscaler ! Adjust for temperature vcmax = vcmax25 * ft1_f(veg_tempk, vcmaxha) * fth_f(veg_tempk, vcmaxhd, vcmaxse, vcmaxc) jmax = jmax25 * ft1_f(veg_tempk, jmaxha) * fth_f(veg_tempk, jmaxhd, jmaxse, jmaxc) - tpu = tpu25 * ft1_f(veg_tempk, tpuha) * fth_f(veg_tempk, tpuhd, tpuse, tpuc) if (nint(EDPftvarcon_inst%c3psn(ft)) /= 1) then vcmax = vcmax25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) From d9f2ca0a6fa77ce9666c4e8c0617159ab4ac3736 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 30 Apr 2020 02:22:45 -0600 Subject: [PATCH 002/578] roll back snow burial change --- biogeochem/EDCanopyStructureMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 4bdb462b04..acf7a9edd0 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1592,7 +1592,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) if(snow_depth_avg>= minh(iv).and.snow_depth_avg <= maxh(iv))then !only partly hidden... fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_avg-minh(iv))/dh))) endif - ! fraction_exposed = 1.0_r8 + fraction_exposed = 1.0_r8 ! no m2 of leaf per m2 of ground in each height class ! FIX(SPM,032414) these should be uncommented this and double check From 3fc6a942ee3e9934f5f562acb27b47e6176f1ec1 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 30 Apr 2020 03:59:14 -0600 Subject: [PATCH 003/578] initial set of nocomp changes. doesn't work yet --- biogeochem/EDPatchDynamicsMod.F90 | 31 ++++++++++++++++++++++++++----- main/EDInitMod.F90 | 17 +++++++++++++++-- main/EDTypesMod.F90 | 2 +- main/FatesRestartInterfaceMod.F90 | 9 +++++++++ 4 files changed, 51 insertions(+), 8 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index c57b8b3d6a..5016891812 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -42,6 +42,7 @@ module EDPatchDynamicsMod use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : hlm_days_per_year use FatesInterfaceMod , only : numpft + use FatesInterfaceMod , only : hlm_use_nocomp use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse @@ -395,6 +396,7 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: site_areadis_primary ! total area disturbed (to primary forest) in m2 per site per day real(r8) :: site_areadis_secondary ! total area disturbed (to secondary forest) in m2 per site per day real(r8) :: patch_site_areadis ! total area disturbed in m2 per patch per day + real(r8) :: site_areadis_pft(numpft) ! total area disturbed per PFT class when nocomp mode is on. m2 per patch per day real(r8) :: age ! notional age of this patch in years integer :: el ! element loop index integer :: tnull ! is there a tallest cohort? @@ -409,6 +411,7 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: leaf_burn_frac ! fraction of leaves burned in fire ! for both woody and grass species real(r8) :: leaf_m ! leaf mass during partial burn calculations + integer :: nocomp_pft ! where nocomp mode is on, PFT label !--------------------------------------------------------------------- storesmallcohort => null() ! storage of the smallest cohort for insertion routine @@ -419,6 +422,7 @@ subroutine spawn_patches( currentSite, bc_in) site_areadis_primary = 0.0_r8 site_areadis_secondary = 0.0_r8 + site_areadis_pft(1:numpft)=0.0_r8 do while(associated(currentPatch)) @@ -448,7 +452,12 @@ subroutine spawn_patches( currentSite, bc_in) else site_areadis_secondary = site_areadis_secondary + currentPatch%area * currentPatch%disturbance_rate endif - + + ! accumulate PFT specific disturbance rates in nocomp mode + if(hlm_use_nocomp.eq.itrue)then + site_areadis_pft(currentPatch%nocomp_pft_label) = site_areadis_pft(currentPatch%nocomp_pft_label) & + + currentPatch%area * currentPatch%disturbance_rate + end if end if currentPatch => currentPatch%older @@ -465,7 +474,7 @@ subroutine spawn_patches( currentSite, bc_in) allocate(new_patch_primary) call create_patch(currentSite, new_patch_primary, age, & - site_areadis_primary, primaryforest) + site_areadis_primary, primaryforest,nocomp_pft) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -488,7 +497,7 @@ subroutine spawn_patches( currentSite, bc_in) if ( site_areadis_secondary .gt. nearzero) then allocate(new_patch_secondary) call create_patch(currentSite, new_patch_secondary, age, & - site_areadis_secondary, secondaryforest) + site_areadis_secondary, secondaryforest,nocomp_pft) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -1821,7 +1830,7 @@ end subroutine mortality_litter_fluxes ! ============================================================================ - subroutine create_patch(currentSite, new_patch, age, areap, label) + subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) ! ! !DESCRIPTION: @@ -1835,7 +1844,7 @@ subroutine create_patch(currentSite, new_patch, age, areap, label) real(r8), intent(in) :: age ! notional age of this patch in years real(r8), intent(in) :: areap ! initial area of this patch in m2. integer, intent(in) :: label ! anthropogenic disturbance label - + integer, intent(in) :: nocomp_pft ! sets PFT of patch only where nocomp is active ! !LOCAL VARIABLES: !--------------------------------------------------------------------- integer :: el ! element loop index @@ -1881,6 +1890,10 @@ subroutine create_patch(currentSite, new_patch, age, areap, label) ! assign anthropgenic disturbance category and label new_patch%anthro_disturbance_label = label + + ! where nocomp is active, set PFT of patch + new_patch%nocomp_pft_label = nocomp_pft + if (label .eq. secondaryforest) then new_patch%age_since_anthro_disturbance = age else @@ -2023,6 +2036,9 @@ subroutine zero_patch(cp_p) currentPatch%gnd_alb_dir(:) = nan currentPatch%gnd_alb_dif(:) = nan + ! special modes + currentPatch%nocomp_pft_label = fates_unset_int + end subroutine zero_patch ! ============================================================================ @@ -2183,6 +2199,11 @@ subroutine fuse_patches( csite, bc_in ) endif ! sum(biomass(:,:) .gt. force_patchfuse_min_biomass endif ! maxage + ! Do not fuse patches that have different PFT labels in nocomp mode + if(hlm_use_nocomp.eq.itrue.and. & + tpp%nocomp_pft_label.ne.currentPatch%nocomp_pft_label)then + fuse_flag = 0 + end if !-------------------------------------------------------------------------! ! Call the patch fusion routine if there is not a meaningful difference ! ! any of the pft x height categories ! diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index d820181c78..c2a20ec36a 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -39,6 +39,7 @@ module EDInitMod use FatesInterfaceMod , only : hlm_use_planthydro use FatesInterfaceMod , only : hlm_use_inventory_init use FatesInterfaceMod , only : hlm_use_fixed_biogeog + use FatesInterfaceMod , only : hlm_use_nocomp use FatesInterfaceMod , only : numpft use FatesInterfaceMod , only : nleafage use FatesInterfaceMod , only : nlevsclass @@ -391,6 +392,14 @@ subroutine init_patches( nsites, sites, bc_in) ! have smaller spread factors than bare ground (they are crowded) sites(s)%spread = init_spread_near_bare_ground + if(hlm_use_nocomp.eq.itrue)then + no_new_patches = numpft + else + no_new_patches = 1 + end if + + do n = 1, no_new_patches + allocate(newp) newp%patchno = 1 @@ -403,7 +412,7 @@ subroutine init_patches( nsites, sites, bc_in) ! make new patch... - call create_patch(sites(s), newp, age, area, primaryforest) + call create_patch(sites(s), newp, age, area, primaryforest, nocomp_pft) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -419,6 +428,8 @@ subroutine init_patches( nsites, sites, bc_in) sitep => sites(s) call init_cohorts(sitep, newp, bc_in(s)) + + end do !no new patches ! For carbon balance checks, we need to initialize the ! total carbon stock @@ -426,7 +437,9 @@ subroutine init_patches( nsites, sites, bc_in) call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & biomass_stock,litter_stock,seed_stock) end do - enddo + + + enddo !s end if diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 819fadd830..5902b47be0 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -386,7 +386,7 @@ module EDTypesMod integer :: ncl_p ! Number of occupied canopy layers integer :: anthro_disturbance_label ! patch label for anthropogenic disturbance classification real(r8) :: age_since_anthro_disturbance ! average age for secondary forest since last anthropogenic disturbance - + integer :: nocomp_pft_label ! where nocomp is active, use this label for patch ID. ! LEAF ORGANIZATION real(r8) :: pft_agb_profile(maxpft,n_dbh_bins) ! binned above ground biomass, for patch fusion: KgC/m2 real(r8) :: canopy_layer_tlai(nclmax) ! total leaf area index of each canopy layer diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 5ea5c615a9..0f677ed9c6 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -143,6 +143,7 @@ module FatesRestartInterfaceMod integer :: ir_area_pa integer :: ir_agesinceanthrodist_pa integer :: ir_patchdistturbcat_pa + integer :: ir_nocomp_pft_label_pa ! Site level @@ -824,6 +825,10 @@ subroutine define_restart_vars(this, initialize_variables) long_name='Disturbance label of patch', units='yr', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_patchdistturbcat_pa ) + call this%set_restart_var(vname='fates_nocomp_pft_label', vtype=cohort_int, & + long_name='PFT label of patch in nocomp mode', units='none', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_nocomp_pft_label_pa ) + call this%set_restart_var(vname='fates_area', vtype=cohort_r8, & long_name='are of the ED patch', units='m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_area_pa ) @@ -1540,6 +1545,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_age_pa => this%rvars(ir_age_pa)%r81d, & rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & + rio_nocomp_pft_label_pa => this%rvars(ir_nocomp_pft_label_pa)%int1d, & rio_area_pa => this%rvars(ir_area_pa)%r81d, & rio_watermem_siwm => this%rvars(ir_watermem_siwm)%r81d, & rio_vegtempmem_sitm => this%rvars(ir_vegtempmem_sitm)%r81d, & @@ -1778,6 +1784,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_age_pa(io_idx_co_1st) = cpatch%age rio_patchdistturbcat_pa(io_idx_co_1st) = cpatch%anthro_disturbance_label rio_agesinceanthrodist_pa(io_idx_co_1st) = cpatch%age_since_anthro_disturbance + rio_nocomp_pft_label_pa(io_idx_co_1st)= cpatch%nocomp_pft_label rio_area_pa(io_idx_co_1st) = cpatch%area ! set cohorts per patch for IO @@ -2288,6 +2295,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_age_pa => this%rvars(ir_age_pa)%r81d, & rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & + rio_nocomp_pft_label_pa => this%rvars(ir_nocomp_pft_label_pa)%int1d, & rio_area_pa => this%rvars(ir_area_pa)%r81d, & rio_watermem_siwm => this%rvars(ir_watermem_siwm)%r81d, & rio_vegtempmem_sitm => this%rvars(ir_vegtempmem_sitm)%r81d, & @@ -2510,6 +2518,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) cpatch%age = rio_age_pa(io_idx_co_1st) cpatch%anthro_disturbance_label = rio_patchdistturbcat_pa(io_idx_co_1st) cpatch%age_since_anthro_disturbance = rio_agesinceanthrodist_pa(io_idx_co_1st) + cpatch%nocomp_pft_label = rio_nocomp_pft_label_pa(io_idx_co_1st) cpatch%area = rio_area_pa(io_idx_co_1st) cpatch%age_class = get_age_class_index(cpatch%age) From a08cbcd5068bc8392712746308eba81743b3f4e3 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 1 May 2020 04:02:07 -0600 Subject: [PATCH 004/578] phase 2 of nocomp mods --- biogeochem/EDPatchDynamicsMod.F90 | 139 +++++++++++++++++++----------- main/EDInitMod.F90 | 11 ++- main/FatesInventoryInitMod.F90 | 4 +- 3 files changed, 98 insertions(+), 56 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 5016891812..eef81f6705 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -389,14 +389,17 @@ subroutine spawn_patches( currentSite, bc_in) type (ed_patch_type) , pointer :: new_patch_primary type (ed_patch_type) , pointer :: new_patch_secondary type (ed_patch_type) , pointer :: currentPatch + type (ed_patch_type) , pointer :: new_patch_primary_pft(:) + type (ed_patch_type) , pointer :: new_patch_secondary_pft(:) type (ed_cohort_type), pointer :: currentCohort type (ed_cohort_type), pointer :: nc type (ed_cohort_type), pointer :: storesmallcohort type (ed_cohort_type), pointer :: storebigcohort real(r8) :: site_areadis_primary ! total area disturbed (to primary forest) in m2 per site per day real(r8) :: site_areadis_secondary ! total area disturbed (to secondary forest) in m2 per site per day - real(r8) :: patch_site_areadis ! total area disturbed in m2 per patch per day - real(r8) :: site_areadis_pft(numpft) ! total area disturbed per PFT class when nocomp mode is on. m2 per patch per day + real(r8) :: site_areadis_primary_pft(numpft) ! primary area disturbed per PFT in nocomp mode. m2/patch/day + real(r8) :: site_areadis_secondary_pft(numpft) ! secondary area disturbed per PFT in nocomp mode. m2/patch/day + real(r8) :: patch_site_areadis ! total area disturbed in m2 per patch per day real(r8) :: age ! notional age of this patch in years integer :: el ! element loop index integer :: tnull ! is there a tallest cohort? @@ -411,7 +414,9 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: leaf_burn_frac ! fraction of leaves burned in fire ! for both woody and grass species real(r8) :: leaf_m ! leaf mass during partial burn calculations + integer :: rec_type ! records type of disturbance while in patch loop integer :: nocomp_pft ! where nocomp mode is on, PFT label + !--------------------------------------------------------------------- storesmallcohort => null() ! storage of the smallest cohort for insertion routine @@ -422,10 +427,10 @@ subroutine spawn_patches( currentSite, bc_in) site_areadis_primary = 0.0_r8 site_areadis_secondary = 0.0_r8 - site_areadis_pft(1:numpft)=0.0_r8 + site_areadis_primary_pft(1:numpft) = 0.0_r8 + site_areadis_secondary_pft(1:numpft) = 0.0_r8 do while(associated(currentPatch)) - if(currentPatch%disturbance_rate>1.0_r8) then write(fates_log(),*) 'patch disturbance rate > 1 ?',currentPatch%disturbance_rate @@ -449,19 +454,28 @@ subroutine spawn_patches( currentSite, bc_in) (currentPatch%disturbance_mode .ne. dtype_ilog) ) then site_areadis_primary = site_areadis_primary + currentPatch%area * currentPatch%disturbance_rate + rec_type = primaryforest else site_areadis_secondary = site_areadis_secondary + currentPatch%area * currentPatch%disturbance_rate - endif + rec_type = secondaryforest + end if ! accumulate PFT specific disturbance rates in nocomp mode - if(hlm_use_nocomp.eq.itrue)then - site_areadis_pft(currentPatch%nocomp_pft_label) = site_areadis_pft(currentPatch%nocomp_pft_label) & + if(hlm_use_nocomp.eq.itrue)then + if(rec_type.eq.primaryforest)then + nocomp_pft = currentPatch%nocomp_pft_label + site_areadis_primary_pft(nocomp_pft) = site_areadis_primary_pft(nocomp_pft) & + + currentPatch%area * currentPatch%disturbance_rate + else + site_areadis_secondary_pft(nocomp_pft) = site_areadis_secondary_pft(nocomp_pft) & + currentPatch%area * currentPatch%disturbance_rate - end if - end if + end if !rectype + end if !nocomp + end if !area currentPatch => currentPatch%older - enddo ! end loop over patches. sum area disturbed for all patches. + + end do ! end loop over patches. sum area disturbed for all patches. ! It is possible that no disturbance area was generated if ( (site_areadis_primary + site_areadis_secondary) > nearzero) then @@ -471,49 +485,68 @@ subroutine spawn_patches( currentSite, bc_in) ! create two empty patches, to absorb newly disturbed primary and secondary forest area ! first create patch to receive primary forest area if ( site_areadis_primary .gt. nearzero ) then - allocate(new_patch_primary) - - call create_patch(currentSite, new_patch_primary, age, & + if(hlm_use_nocomp.eq.ifalse)then + allocate(new_patch_primary) + call create_patch(currentSite, new_patch_primary, age, & site_areadis_primary, primaryforest,nocomp_pft) - - ! Initialize the litter pools to zero, these - ! pools will be populated by looping over the existing patches - ! and transfering in mass - do el=1,num_elements - call new_patch_primary%litter(el)%InitConditions(init_leaf_fines=0._r8, & - init_root_fines=0._r8, & - init_ag_cwd=0._r8, & - init_bg_cwd=0._r8, & - init_seed=0._r8, & - init_seed_germ=0._r8) - end do - new_patch_primary%tallest => null() - new_patch_primary%shortest => null() - - endif - + ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches + ! and transfering in mass + do el=1,num_elements + call new_patch_primary%litter(el)%InitConditions(& + init_leaf_fines=0._r8, init_root_fines=0._r8, init_ag_cwd=0._r8, & + init_bg_cwd =0._r8, init_seed =0._r8, init_seed_germ=0._r8) + end do + new_patch_primary%tallest => null() + new_patch_primary%shortest => null() + + else !nocomp + do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. + allocate(new_patch_primary) + if( site_areadis_primary_pft(nocomp_pft) .gt. nearzero ) then + call create_patch(currentSite, new_patch_primary, age, & + site_areadis_primary_pft(nocomp_pft), primaryforest,nocomp_pft) + ! Initialize the litter pools to zero + do el=1,num_elements + call new_patch_primary%litter(el)%InitConditions(& + init_leaf_fines=0._r8, init_root_fines=0._r8, init_ag_cwd=0._r8, & + init_bg_cwd =0._r8, init_seed =0._r8, init_seed_germ=0._r8) + end do + new_patch_primary%tallest => null() + new_patch_primary%shortest => null() + end if !area + end do !pft + endif !nocomp + end if !primary ! next create patch to receive secondary forest area if ( site_areadis_secondary .gt. nearzero) then - allocate(new_patch_secondary) - call create_patch(currentSite, new_patch_secondary, age, & + if(hlm_use_nocomp.eq.ifalse)then + allocate(new_patch_secondary) + call create_patch(currentSite, new_patch_secondary, age, & site_areadis_secondary, secondaryforest,nocomp_pft) - - ! Initialize the litter pools to zero, these - ! pools will be populated by looping over the existing patches - ! and transfering in mass - do el=1,num_elements - call new_patch_secondary%litter(el)%InitConditions(init_leaf_fines=0._r8, & - init_root_fines=0._r8, & - init_ag_cwd=0._r8, & - init_bg_cwd=0._r8, & - init_seed=0._r8, & - init_seed_germ=0._r8) - end do - new_patch_secondary%tallest => null() - new_patch_secondary%shortest => null() - - endif + do el=1,num_elements + call new_patch_secondary%litter(el)%InitConditions(& + init_leaf_fines=0._r8, init_root_fines=0._r8, init_ag_cwd=0._r8, & + init_bg_cwd =0._r8, init_seed =0._r8, init_seed_germ=0._r8) + end do + new_patch_secondary%tallest => null() + new_patch_secondary%shortest => null() + else !nocomp + do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. allocate(new_patch_secondary) + if( site_areadis_secondary_pft(nocomp_pft) .gt. nearzero ) then + call create_patch(currentSite, new_patch_secondary, age, & + site_areadis_secondary_pft(nocomp_pft), secondaryforest,nocomp_pft) + do el=1,num_elements + call new_patch_secondary%litter(el)%InitConditions(& + init_leaf_fines=0._r8, init_root_fines=0._r8, init_ag_cwd=0._r8, & + init_bg_cwd =0._r8, init_seed =0._r8, init_seed_germ=0._r8) + end do + new_patch_secondary%tallest => null() + new_patch_secondary%shortest => null() + end if !area + end do !pft + endif !nocomp + endif !secondary ! loop round all the patches that contribute surviving indivduals and litter ! pools to the new patch. We only loop the pre-existing patches, so @@ -533,11 +566,13 @@ subroutine spawn_patches( currentSite, bc_in) ! will be primary or secondary land receiver patch is primary forest ! only if both the donor patch is primary forest and the dominant ! disturbance type is not logging - if (currentPatch%anthro_disturbance_label .eq. primaryforest .and. & + if(hlm_use_nocomp.eq.ifalse)then + if (currentPatch%anthro_disturbance_label .eq. primaryforest .and. & (currentPatch%disturbance_mode .ne. dtype_ilog)) then - new_patch => new_patch_primary - else - new_patch => new_patch_secondary + new_patch => new_patch_primary + else + new_patch => new_patch_secondary + endif endif if(.not.associated(new_patch))then diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index c2a20ec36a..9d07d89a1f 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -348,7 +348,9 @@ subroutine init_patches( nsites, sites, bc_in) real(r8) :: biomass_stock real(r8) :: litter_stock real(r8) :: seed_stock - + integer :: n + integer :: no_new_patches + integer :: nocomp_pft type(ed_site_type), pointer :: sitep type(ed_patch_type), pointer :: newp @@ -411,7 +413,12 @@ subroutine init_patches( nsites, sites, bc_in) sites(s)%oldest_patch => newp ! make new patch... - + if(hlm_use_nocomp.eq.itrue)then + nocomp_pft = n + else + nocomp_pft = fates_unset_int + end if + call create_patch(sites(s), newp, age, area, primaryforest, nocomp_pft) ! Initialize the litter pools to zero, these diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 830ee7d099..5924f7c845 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -61,7 +61,7 @@ module FatesInventoryInitMod use PRTGenericMod, only : phosphorus_element use PRTGenericMod, only : SetState use FatesConstantsMod, only : primaryforest - + use FatesConstantsMod , only : fates_unset_int implicit none private @@ -275,7 +275,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) age_init = 0.0_r8 area_init = 0.0_r8 - call create_patch(sites(s), newpatch, age_init, area_init, primaryforest ) + call create_patch(sites(s), newpatch, age_init, area_init, primaryforest, fates_unset_int ) if( inv_format_list(invsite) == 1 ) then From 3f92ed8dcc9e612d70c6db2b06e2780925a9f171 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 1 May 2020 11:46:07 -0600 Subject: [PATCH 005/578] first pass through spawn_patches --- biogeochem/EDPatchDynamicsMod.F90 | 104 +++++++++++++++++++++++------- main/FatesRestartInterfaceMod.F90 | 8 +-- 2 files changed, 84 insertions(+), 28 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index eef81f6705..36fbb29ff8 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -419,6 +419,10 @@ subroutine spawn_patches( currentSite, bc_in) !--------------------------------------------------------------------- + ! Allocate PFT arrays of patches to form the new patches in nocomp mode. + allocate(new_patch_primary_pft(numpft)) + allocate(new_patch_secondary_pft(numpft)) + storesmallcohort => null() ! storage of the smallest cohort for insertion routine storebigcohort => null() ! storage of the largest cohort for insertion routine @@ -501,9 +505,9 @@ subroutine spawn_patches( currentSite, bc_in) else !nocomp do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. - allocate(new_patch_primary) +! allocate(new_patch_primary_pft(nocompt_pft)) if( site_areadis_primary_pft(nocomp_pft) .gt. nearzero ) then - call create_patch(currentSite, new_patch_primary, age, & + call create_patch(currentSite, new_patch_primary_pft(nocomp_pft), age, & site_areadis_primary_pft(nocomp_pft), primaryforest,nocomp_pft) ! Initialize the litter pools to zero do el=1,num_elements @@ -534,7 +538,7 @@ subroutine spawn_patches( currentSite, bc_in) else !nocomp do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. allocate(new_patch_secondary) if( site_areadis_secondary_pft(nocomp_pft) .gt. nearzero ) then - call create_patch(currentSite, new_patch_secondary, age, & + call create_patch(currentSite, new_patch_secondary_pft(nocomp_pft), age, & site_areadis_secondary_pft(nocomp_pft), secondaryforest,nocomp_pft) do el=1,num_elements call new_patch_secondary%litter(el)%InitConditions(& @@ -566,14 +570,24 @@ subroutine spawn_patches( currentSite, bc_in) ! will be primary or secondary land receiver patch is primary forest ! only if both the donor patch is primary forest and the dominant ! disturbance type is not logging - if(hlm_use_nocomp.eq.ifalse)then if (currentPatch%anthro_disturbance_label .eq. primaryforest .and. & (currentPatch%disturbance_mode .ne. dtype_ilog)) then new_patch => new_patch_primary + rec_type = primaryforest else new_patch => new_patch_secondary + rec_type = secondaryforest endif - endif + + if(hlm_use_nocomp.eq.itrue)then !nocomp case + if(rec_type.eq.primaryforest)then + new_patch => new_patch_primary_pft(currentPatch%nocomp_pft_label) + else + new_patch => new_patch_secondary_pft(currentPatch%nocomp_pft_label) + endif + endif + + if(.not.associated(new_patch))then write(fates_log(),*) 'Patch spawning has attempted to point to' @@ -1047,42 +1061,84 @@ subroutine spawn_patches( currentSite, bc_in) !*************************/ !** INSERT NEW PATCH(ES) INTO LINKED LIST !**********`***************/ - - if ( site_areadis_primary .gt. nearzero) then + + ! currentPatch is the youngest of the pre-existing patches. + !newpatch_primary_pft and newpatch_secondary_pft need to be added into the mix + + if(hlm_use_nocomp.eq.ifalse)then + if ( site_areadis_primary .gt. nearzero) then currentPatch => currentSite%youngest_patch new_patch_primary%older => currentPatch new_patch_primary%younger => null() currentPatch%younger => new_patch_primary currentSite%youngest_patch => new_patch_primary - endif + endif - if ( site_areadis_secondary .gt. nearzero) then + if ( site_areadis_secondary .gt. nearzero) then currentPatch => currentSite%youngest_patch new_patch_secondary%older => currentPatch new_patch_secondary%younger=> null() currentPatch%younger => new_patch_secondary currentSite%youngest_patch => new_patch_secondary - endif - + endif + else !nocomp case with one new patch for each PFT + do nocomp_pft=1,numpft + if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then + currentPatch => currentSite%youngest_patch + new_patch_primary_pft(nocomp_pft)%older => currentPatch + new_patch_primary_pft(nocomp_pft)%younger => null() + currentPatch%younger => new_patch_primary_pft(nocomp_pft) + currentSite%youngest_patch => new_patch_primary_pft(nocomp_pft) + endif + + if ( site_areadis_secondary .gt. nearzero) then + currentPatch => currentSite%youngest_patch + new_patch_secondary_pft(nocomp_pft)%older => currentPatch + new_patch_secondary_pft(nocomp_pft)%younger=> null() + currentPatch%younger => new_patch_secondary_pft(nocomp_pft) + currentSite%youngest_patch => new_patch_secondary_pft(nocomp_pft) + endif + enddo !pft + endif !nocomp + + + + ! sort out the cohorts, since some of them may be so small as to need removing. ! the first call to terminate cohorts removes sparse number densities, ! the second call removes for all other reasons (sparse culling must happen ! before fusion) - - if ( site_areadis_primary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_primary, 1,17) - call fuse_cohorts(currentSite,new_patch_primary, bc_in) - call terminate_cohorts(currentSite, new_patch_primary, 2,17) - call sort_cohorts(new_patch_primary) - endif + if(hlm_use_nocomp.eq.ifalse)then + if ( site_areadis_primary .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_primary, 1,17) + call fuse_cohorts(currentSite,new_patch_primary, bc_in) + call terminate_cohorts(currentSite, new_patch_primary, 2,17) + call sort_cohorts(new_patch_primary) + endif - if ( site_areadis_secondary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_secondary, 1,18) - call fuse_cohorts(currentSite,new_patch_secondary, bc_in) - call terminate_cohorts(currentSite, new_patch_secondary, 2,18) - call sort_cohorts(new_patch_secondary) - endif + if ( site_areadis_secondary .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_secondary, 1,18) + call fuse_cohorts(currentSite,new_patch_secondary, bc_in) + call terminate_cohorts(currentSite, new_patch_secondary, 2,18) + call sort_cohorts(new_patch_secondary) + endif + else !nocomp case + do nocomp_pft=1,numpft + if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_primary_pft(nocomp_pft), 1,17) + call fuse_cohorts(currentSite,new_patch_primary_pft(nocomp_pft), bc_in) + call terminate_cohorts(currentSite, new_patch_primary_pft(nocomp_pft), 2,17) + call sort_cohorts(new_patch_primary_pft(nocomp_pft)) + endif + if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), 1,18) + call fuse_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), bc_in) + call terminate_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), 2,18) + call sort_cohorts(new_patch_secondary_pft(nocomp_pft)) + endif + enddo !pft + endif !nocomp endif !end new_patch area diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 0f677ed9c6..2fb57bd6fb 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -7,7 +7,7 @@ module FatesRestartInterfaceMod use FatesConstantsMod, only : fates_long_string_length use FatesConstantsMod, only : itrue use FatesConstantsMod, only : ifalse - use FatesConstantsMod, only : fates_unset_r8 + use FatesConstantsMod, only : fates_unset_r8, fates_unset_int use FatesConstantsMod, only : primaryforest use FatesGlobals, only : fates_log use FatesGlobals, only : endrun => fates_endrun @@ -2018,7 +2018,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) integer :: ft integer :: el ! element loop counter integer, parameter :: recruitstatus = 0 - + integer :: nocomp_pft ! PFT patch label for nocomp mode ! ---------------------------------------------------------------------------------- ! We really only need the counts for the number of patches per site ! and the number of cohorts per patch. These values tell us how much @@ -2055,9 +2055,9 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! create patch allocate(newp) - + nocomp_pft = fates_unset_int ! make new patch - call create_patch(sites(s), newp, fates_unset_r8, fates_unset_r8, primaryforest ) + call create_patch(sites(s), newp, fates_unset_r8, fates_unset_r8, primaryforest, nocomp_pft ) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches From db960fd6f5c1a6290c81cdee5545d0d2dfe7a655 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 4 May 2020 02:53:07 -0600 Subject: [PATCH 006/578] added initialization mods --- main/EDInitMod.F90 | 27 ++++++++++++++++++++++----- 1 file changed, 22 insertions(+), 5 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 9d07d89a1f..07c2e3f117 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -351,6 +351,8 @@ subroutine init_patches( nsites, sites, bc_in) integer :: n integer :: no_new_patches integer :: nocomp_pft + real(r8) :: newparea + type(ed_site_type), pointer :: sitep type(ed_patch_type), pointer :: newp @@ -398,6 +400,7 @@ subroutine init_patches( nsites, sites, bc_in) no_new_patches = numpft else no_new_patches = 1 + newparea = area end if do n = 1, no_new_patches @@ -412,15 +415,29 @@ subroutine init_patches( nsites, sites, bc_in) sites(s)%youngest_patch => newp sites(s)%oldest_patch => newp - ! make new patch... + ! set the PFT index for patches if in nocomp mode. if(hlm_use_nocomp.eq.itrue)then nocomp_pft = n else - nocomp_pft = fates_unset_int + nocomp_pft = 999 end if - - call create_patch(sites(s), newp, age, area, primaryforest, nocomp_pft) - + + if(hlm_use_nocomp.eq.itrue)then + ! In no competition mode, if we are using the fixed_biogeog filter + ! then each PFT has the area dictated by the surface dataset. + ! If not, each PFT gets the same area. + if(hlm_use_fixed_biogeog.eq.itrue)then + newparea = area * sites(s)%area_pft(nocomp_pft) + else + newparea = area / numpft + end if + else ! The default case is initialized w/ one patch with the area of the whole site. + newparea = area + end if + + if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode + call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) + end if ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches ! and transfering in mass From 782b61a005d7d3a8b37460303e8254ad267904a5 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 4 May 2020 03:01:33 -0600 Subject: [PATCH 007/578] debug in EPD. will need rolling back --- biogeochem/EDPatchDynamicsMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 36fbb29ff8..9085405fa3 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -102,7 +102,7 @@ module EDPatchDynamicsMod character(len=*), parameter, private :: sourcefile = & __FILE__ - logical, parameter :: debug = .false. + logical, parameter :: debug = .true. ! When creating new patches from other patches, we need to send some of the ! litter from the old patch to the new patch. Likewise, when plants die @@ -1198,7 +1198,7 @@ subroutine check_patch_area( currentSite ) end if if(debug) then - write(fates_log(),*) 'Total patch area precision being fixed, adjusting' + write(fates_log(),*) 'Total patch area precision being fixed, adjusting',areatot-area_site write(fates_log(),*) 'largest patch. This may have slight impacts on carbon balance.' end if @@ -2293,7 +2293,7 @@ subroutine fuse_patches( csite, bc_in ) ! Do not fuse patches that have different PFT labels in nocomp mode if(hlm_use_nocomp.eq.itrue.and. & tpp%nocomp_pft_label.ne.currentPatch%nocomp_pft_label)then - fuse_flag = 0 + fuse_flag = 0 end if !-------------------------------------------------------------------------! ! Call the patch fusion routine if there is not a meaningful difference ! From ff0cf19f5d0c3ace455bb09396e5cb9b76911661 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 6 May 2020 10:26:28 -0600 Subject: [PATCH 008/578] init fixes. gets out of init loop --- main/EDInitMod.F90 | 102 ++++++++++++++++++++++++++++++--------------- 1 file changed, 68 insertions(+), 34 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 07c2e3f117..b81f7103a8 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -17,6 +17,7 @@ module EDInitMod use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts use EDCohortDynamicsMod , only : InitPRTObject use EDPatchDynamicsMod , only : create_patch + use EDPatchDynamicsMod , only : set_patchno use ChecksBalancesMod , only : SiteMassStock use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDTypesMod , only : numWaterMem @@ -250,6 +251,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) integer :: dleafoff ! DOY for drought-decid leaf-off, initial guess integer :: dleafon ! DOY for drought-decid leaf-on, initial guess integer :: ft ! PFT loop + real(r8) :: sumarea ! area of PFTs in nocomp mode. !---------------------------------------------------------------------- @@ -298,6 +300,13 @@ subroutine set_site_properties( nsites, sites,bc_in ) do ft = 1,numpft sites(s)%area_pft(ft) = bc_in(s)%pft_areafrac(ft) end do + ! re-normalize PFT area to ensure it sums to one. + ! note that in areas of 'bare ground' (PFT 0 in CLM/ELM) + ! the bare ground will no longer be proscribed and should emerge from FATES + sumarea = sum(sites(s)%area_pft(1:numpft)) + do ft = 1,numpft + sites(s)%area_pft(ft) = sites(s)%area_pft(ft)/sumarea + end do end if do ft = 1,numpft @@ -352,9 +361,11 @@ subroutine init_patches( nsites, sites, bc_in) integer :: no_new_patches integer :: nocomp_pft real(r8) :: newparea + real(r8) :: tota !check on area type(ed_site_type), pointer :: sitep type(ed_patch_type), pointer :: newp + type(ed_patch_type), pointer :: recall_younger_patch ! List out some nominal patch values that are used for Near Bear Ground initializations ! as well as initializing inventory @@ -388,14 +399,14 @@ subroutine init_patches( nsites, sites, bc_in) else - !FIX(SPM,032414) clean this up...inits out of this loop - do s = 1, nsites + do s = 1, nsites + write(*,*) 'areapft',sites(s)%area_pft(1:3) ! Initialize the site-level crown area spread factor (0-1) ! It is likely that closed canopy forest inventories ! have smaller spread factors than bare ground (they are crowded) sites(s)%spread = init_spread_near_bare_ground - + if(hlm_use_nocomp.eq.itrue)then no_new_patches = numpft else @@ -405,16 +416,6 @@ subroutine init_patches( nsites, sites, bc_in) do n = 1, no_new_patches - allocate(newp) - - newp%patchno = 1 - newp%younger => null() - newp%older => null() - - sites(s)%youngest_patch => newp - sites(s)%youngest_patch => newp - sites(s)%oldest_patch => newp - ! set the PFT index for patches if in nocomp mode. if(hlm_use_nocomp.eq.itrue)then nocomp_pft = n @@ -434,37 +435,70 @@ subroutine init_patches( nsites, sites, bc_in) else ! The default case is initialized w/ one patch with the area of the whole site. newparea = area end if - + if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode - call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) - end if - ! Initialize the litter pools to zero, these - ! pools will be populated by looping over the existing patches - ! and transfering in mass - do el=1,num_elements - call newp%litter(el)%InitConditions(init_leaf_fines=0._r8, & + allocate(newp) + + call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) + + if(.not.associated(recall_younger_patch))then !is this the first patch? + newp%patchno = 1 + newp%younger => null() + newp%older => null() + + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp + allocate(recall_younger_patch) + else ! the new patch is the 'oldest' one, arbitrarily. + newp%patchno = nocomp_pft + newp%younger => recall_younger_patch + newp%older => null() + recall_younger_patch%older => newp + sites(s)%oldest_patch => newp + write(*,*) 'links',s,nocomp_pft,newp%younger%nocomp_pft_label + end if + recall_younger_patch => newp ! remember this patch for the next one to point at. + + + ! Initialize the litter pools to zero, these + ! pools will be populated by looping over the existing patches + ! and transfering in mass + do el=1,num_elements + call newp%litter(el)%InitConditions(init_leaf_fines=0._r8, & init_root_fines=0._r8, & init_ag_cwd=0._r8, & init_bg_cwd=0._r8, & init_seed=0._r8, & init_seed_germ=0._r8) - end do - - sitep => sites(s) - call init_cohorts(sitep, newp, bc_in(s)) - + end do + write(*,*) 'litt', newp%litter(1)%ag_cwd(1) + sitep => sites(s) + call init_cohorts(sitep, newp, bc_in(s)) + end if end do !no new patches - - ! For carbon balance checks, we need to initialize the - ! total carbon stock - do el=1,num_elements - call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & - biomass_stock,litter_stock,seed_stock) - end do + tota=0.0_r8 + newp=> sites(s)%oldest_patch + do while (associated(newp)) + tota=tota+newp%area + write(*,*)'test links1',s,newp%nocomp_pft_label,tota + newp=>newp%younger + end do + if(tota.lt.area)then + write(*,*) 'error in assigning areas in init patch',s,tota + endif + ! For carbon balance checks, we need to initialize the + ! total carbon stock + do el=1,num_elements + call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & + biomass_stock,litter_stock,seed_stock) + end do + + call set_patchno(sites(s)) + deallocate(recall_younger_patch) enddo !s - +write(*,*)'end init' end if ! This sets the rhizosphere shells based on the plant initialization From 92f547aef0397c679cf35277909d991dc682ab1f Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 7 May 2020 01:55:17 -0600 Subject: [PATCH 009/578] rolling back changes in EDPatchdynamics to allow debugging of EDInit first --- biogeochem/EDPatchDynamicsMod.F90 | 268 +++++++++--------------------- 1 file changed, 82 insertions(+), 186 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 9085405fa3..3d718df9fd 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -42,7 +42,7 @@ module EDPatchDynamicsMod use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : hlm_days_per_year use FatesInterfaceMod , only : numpft - use FatesInterfaceMod , only : hlm_use_nocomp + use FatesInterfaceMod , only : hlm_use_nocomp use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse @@ -102,7 +102,7 @@ module EDPatchDynamicsMod character(len=*), parameter, private :: sourcefile = & __FILE__ - logical, parameter :: debug = .true. + logical, parameter :: debug = .false. ! When creating new patches from other patches, we need to send some of the ! litter from the old patch to the new patch. Likewise, when plants die @@ -389,17 +389,13 @@ subroutine spawn_patches( currentSite, bc_in) type (ed_patch_type) , pointer :: new_patch_primary type (ed_patch_type) , pointer :: new_patch_secondary type (ed_patch_type) , pointer :: currentPatch - type (ed_patch_type) , pointer :: new_patch_primary_pft(:) - type (ed_patch_type) , pointer :: new_patch_secondary_pft(:) type (ed_cohort_type), pointer :: currentCohort type (ed_cohort_type), pointer :: nc type (ed_cohort_type), pointer :: storesmallcohort type (ed_cohort_type), pointer :: storebigcohort real(r8) :: site_areadis_primary ! total area disturbed (to primary forest) in m2 per site per day real(r8) :: site_areadis_secondary ! total area disturbed (to secondary forest) in m2 per site per day - real(r8) :: site_areadis_primary_pft(numpft) ! primary area disturbed per PFT in nocomp mode. m2/patch/day - real(r8) :: site_areadis_secondary_pft(numpft) ! secondary area disturbed per PFT in nocomp mode. m2/patch/day - real(r8) :: patch_site_areadis ! total area disturbed in m2 per patch per day + real(r8) :: patch_site_areadis ! total area disturbed in m2 per patch per day real(r8) :: age ! notional age of this patch in years integer :: el ! element loop index integer :: tnull ! is there a tallest cohort? @@ -414,15 +410,8 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: leaf_burn_frac ! fraction of leaves burned in fire ! for both woody and grass species real(r8) :: leaf_m ! leaf mass during partial burn calculations - integer :: rec_type ! records type of disturbance while in patch loop - integer :: nocomp_pft ! where nocomp mode is on, PFT label - !--------------------------------------------------------------------- - ! Allocate PFT arrays of patches to form the new patches in nocomp mode. - allocate(new_patch_primary_pft(numpft)) - allocate(new_patch_secondary_pft(numpft)) - storesmallcohort => null() ! storage of the smallest cohort for insertion routine storebigcohort => null() ! storage of the largest cohort for insertion routine @@ -431,10 +420,9 @@ subroutine spawn_patches( currentSite, bc_in) site_areadis_primary = 0.0_r8 site_areadis_secondary = 0.0_r8 - site_areadis_primary_pft(1:numpft) = 0.0_r8 - site_areadis_secondary_pft(1:numpft) = 0.0_r8 do while(associated(currentPatch)) + if(currentPatch%disturbance_rate>1.0_r8) then write(fates_log(),*) 'patch disturbance rate > 1 ?',currentPatch%disturbance_rate @@ -458,28 +446,14 @@ subroutine spawn_patches( currentSite, bc_in) (currentPatch%disturbance_mode .ne. dtype_ilog) ) then site_areadis_primary = site_areadis_primary + currentPatch%area * currentPatch%disturbance_rate - rec_type = primaryforest else site_areadis_secondary = site_areadis_secondary + currentPatch%area * currentPatch%disturbance_rate - rec_type = secondaryforest - end if - - ! accumulate PFT specific disturbance rates in nocomp mode - if(hlm_use_nocomp.eq.itrue)then - if(rec_type.eq.primaryforest)then - nocomp_pft = currentPatch%nocomp_pft_label - site_areadis_primary_pft(nocomp_pft) = site_areadis_primary_pft(nocomp_pft) & - + currentPatch%area * currentPatch%disturbance_rate - else - site_areadis_secondary_pft(nocomp_pft) = site_areadis_secondary_pft(nocomp_pft) & - + currentPatch%area * currentPatch%disturbance_rate - end if !rectype - end if !nocomp + endif + + end if - end if !area currentPatch => currentPatch%older - - end do ! end loop over patches. sum area disturbed for all patches. + enddo ! end loop over patches. sum area disturbed for all patches. ! It is possible that no disturbance area was generated if ( (site_areadis_primary + site_areadis_secondary) > nearzero) then @@ -489,68 +463,49 @@ subroutine spawn_patches( currentSite, bc_in) ! create two empty patches, to absorb newly disturbed primary and secondary forest area ! first create patch to receive primary forest area if ( site_areadis_primary .gt. nearzero ) then - if(hlm_use_nocomp.eq.ifalse)then - allocate(new_patch_primary) - call create_patch(currentSite, new_patch_primary, age, & - site_areadis_primary, primaryforest,nocomp_pft) - ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches - ! and transfering in mass - do el=1,num_elements - call new_patch_primary%litter(el)%InitConditions(& - init_leaf_fines=0._r8, init_root_fines=0._r8, init_ag_cwd=0._r8, & - init_bg_cwd =0._r8, init_seed =0._r8, init_seed_germ=0._r8) - end do - new_patch_primary%tallest => null() - new_patch_primary%shortest => null() - - else !nocomp - do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. -! allocate(new_patch_primary_pft(nocompt_pft)) - if( site_areadis_primary_pft(nocomp_pft) .gt. nearzero ) then - call create_patch(currentSite, new_patch_primary_pft(nocomp_pft), age, & - site_areadis_primary_pft(nocomp_pft), primaryforest,nocomp_pft) - ! Initialize the litter pools to zero - do el=1,num_elements - call new_patch_primary%litter(el)%InitConditions(& - init_leaf_fines=0._r8, init_root_fines=0._r8, init_ag_cwd=0._r8, & - init_bg_cwd =0._r8, init_seed =0._r8, init_seed_germ=0._r8) - end do - new_patch_primary%tallest => null() - new_patch_primary%shortest => null() - end if !area - end do !pft - endif !nocomp - end if !primary + allocate(new_patch_primary) + + call create_patch(currentSite, new_patch_primary, age, & + site_areadis_primary, primaryforest,1) + + ! Initialize the litter pools to zero, these + ! pools will be populated by looping over the existing patches + ! and transfering in mass + do el=1,num_elements + call new_patch_primary%litter(el)%InitConditions(init_leaf_fines=0._r8, & + init_root_fines=0._r8, & + init_ag_cwd=0._r8, & + init_bg_cwd=0._r8, & + init_seed=0._r8, & + init_seed_germ=0._r8) + end do + new_patch_primary%tallest => null() + new_patch_primary%shortest => null() + + endif + ! next create patch to receive secondary forest area if ( site_areadis_secondary .gt. nearzero) then - if(hlm_use_nocomp.eq.ifalse)then - allocate(new_patch_secondary) - call create_patch(currentSite, new_patch_secondary, age, & - site_areadis_secondary, secondaryforest,nocomp_pft) - do el=1,num_elements - call new_patch_secondary%litter(el)%InitConditions(& - init_leaf_fines=0._r8, init_root_fines=0._r8, init_ag_cwd=0._r8, & - init_bg_cwd =0._r8, init_seed =0._r8, init_seed_germ=0._r8) - end do - new_patch_secondary%tallest => null() - new_patch_secondary%shortest => null() - else !nocomp - do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. allocate(new_patch_secondary) - if( site_areadis_secondary_pft(nocomp_pft) .gt. nearzero ) then - call create_patch(currentSite, new_patch_secondary_pft(nocomp_pft), age, & - site_areadis_secondary_pft(nocomp_pft), secondaryforest,nocomp_pft) - do el=1,num_elements - call new_patch_secondary%litter(el)%InitConditions(& - init_leaf_fines=0._r8, init_root_fines=0._r8, init_ag_cwd=0._r8, & - init_bg_cwd =0._r8, init_seed =0._r8, init_seed_germ=0._r8) - end do - new_patch_secondary%tallest => null() - new_patch_secondary%shortest => null() - end if !area - end do !pft - endif !nocomp - endif !secondary + allocate(new_patch_secondary) + call create_patch(currentSite, new_patch_secondary, age, & + site_areadis_secondary, secondaryforest,1) + + ! Initialize the litter pools to zero, these + ! pools will be populated by looping over the existing patches + ! and transfering in mass + do el=1,num_elements + call new_patch_secondary%litter(el)%InitConditions(init_leaf_fines=0._r8, & + init_root_fines=0._r8, & + init_ag_cwd=0._r8, & + init_bg_cwd=0._r8, & + init_seed=0._r8, & + init_seed_germ=0._r8) + end do + new_patch_secondary%tallest => null() + new_patch_secondary%shortest => null() + + endif ! loop round all the patches that contribute surviving indivduals and litter ! pools to the new patch. We only loop the pre-existing patches, so @@ -570,24 +525,12 @@ subroutine spawn_patches( currentSite, bc_in) ! will be primary or secondary land receiver patch is primary forest ! only if both the donor patch is primary forest and the dominant ! disturbance type is not logging - if (currentPatch%anthro_disturbance_label .eq. primaryforest .and. & + if (currentPatch%anthro_disturbance_label .eq. primaryforest .and. & (currentPatch%disturbance_mode .ne. dtype_ilog)) then - new_patch => new_patch_primary - rec_type = primaryforest - else - new_patch => new_patch_secondary - rec_type = secondaryforest - endif - - if(hlm_use_nocomp.eq.itrue)then !nocomp case - if(rec_type.eq.primaryforest)then - new_patch => new_patch_primary_pft(currentPatch%nocomp_pft_label) - else - new_patch => new_patch_secondary_pft(currentPatch%nocomp_pft_label) - endif - endif - - + new_patch => new_patch_primary + else + new_patch => new_patch_secondary + endif if(.not.associated(new_patch))then write(fates_log(),*) 'Patch spawning has attempted to point to' @@ -1061,84 +1004,42 @@ subroutine spawn_patches( currentSite, bc_in) !*************************/ !** INSERT NEW PATCH(ES) INTO LINKED LIST !**********`***************/ - - ! currentPatch is the youngest of the pre-existing patches. - !newpatch_primary_pft and newpatch_secondary_pft need to be added into the mix - - if(hlm_use_nocomp.eq.ifalse)then - if ( site_areadis_primary .gt. nearzero) then + + if ( site_areadis_primary .gt. nearzero) then currentPatch => currentSite%youngest_patch new_patch_primary%older => currentPatch new_patch_primary%younger => null() currentPatch%younger => new_patch_primary currentSite%youngest_patch => new_patch_primary - endif + endif - if ( site_areadis_secondary .gt. nearzero) then + if ( site_areadis_secondary .gt. nearzero) then currentPatch => currentSite%youngest_patch new_patch_secondary%older => currentPatch new_patch_secondary%younger=> null() currentPatch%younger => new_patch_secondary currentSite%youngest_patch => new_patch_secondary - endif - else !nocomp case with one new patch for each PFT - do nocomp_pft=1,numpft - if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then - currentPatch => currentSite%youngest_patch - new_patch_primary_pft(nocomp_pft)%older => currentPatch - new_patch_primary_pft(nocomp_pft)%younger => null() - currentPatch%younger => new_patch_primary_pft(nocomp_pft) - currentSite%youngest_patch => new_patch_primary_pft(nocomp_pft) - endif - - if ( site_areadis_secondary .gt. nearzero) then - currentPatch => currentSite%youngest_patch - new_patch_secondary_pft(nocomp_pft)%older => currentPatch - new_patch_secondary_pft(nocomp_pft)%younger=> null() - currentPatch%younger => new_patch_secondary_pft(nocomp_pft) - currentSite%youngest_patch => new_patch_secondary_pft(nocomp_pft) - endif - enddo !pft - endif !nocomp - - - - + endif + ! sort out the cohorts, since some of them may be so small as to need removing. ! the first call to terminate cohorts removes sparse number densities, ! the second call removes for all other reasons (sparse culling must happen ! before fusion) - if(hlm_use_nocomp.eq.ifalse)then - if ( site_areadis_primary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_primary, 1,17) - call fuse_cohorts(currentSite,new_patch_primary, bc_in) - call terminate_cohorts(currentSite, new_patch_primary, 2,17) - call sort_cohorts(new_patch_primary) - endif + + if ( site_areadis_primary .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_primary, 1,17) + call fuse_cohorts(currentSite,new_patch_primary, bc_in) + call terminate_cohorts(currentSite, new_patch_primary, 2,17) + call sort_cohorts(new_patch_primary) + endif - if ( site_areadis_secondary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_secondary, 1,18) - call fuse_cohorts(currentSite,new_patch_secondary, bc_in) - call terminate_cohorts(currentSite, new_patch_secondary, 2,18) - call sort_cohorts(new_patch_secondary) - endif - else !nocomp case - do nocomp_pft=1,numpft - if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_primary_pft(nocomp_pft), 1,17) - call fuse_cohorts(currentSite,new_patch_primary_pft(nocomp_pft), bc_in) - call terminate_cohorts(currentSite, new_patch_primary_pft(nocomp_pft), 2,17) - call sort_cohorts(new_patch_primary_pft(nocomp_pft)) - endif - if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), 1,18) - call fuse_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), bc_in) - call terminate_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), 2,18) - call sort_cohorts(new_patch_secondary_pft(nocomp_pft)) - endif - enddo !pft - endif !nocomp + if ( site_areadis_secondary .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_secondary, 1,18) + call fuse_cohorts(currentSite,new_patch_secondary, bc_in) + call terminate_cohorts(currentSite, new_patch_secondary, 2,18) + call sort_cohorts(new_patch_secondary) + endif endif !end new_patch area @@ -1198,7 +1099,7 @@ subroutine check_patch_area( currentSite ) end if if(debug) then - write(fates_log(),*) 'Total patch area precision being fixed, adjusting',areatot-area_site + write(fates_log(),*) 'Total patch area precision being fixed, adjusting' write(fates_log(),*) 'largest patch. This may have slight impacts on carbon balance.' end if @@ -1935,7 +1836,7 @@ subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) real(r8), intent(in) :: age ! notional age of this patch in years real(r8), intent(in) :: areap ! initial area of this patch in m2. integer, intent(in) :: label ! anthropogenic disturbance label - integer, intent(in) :: nocomp_pft ! sets PFT of patch only where nocomp is active + integer, intent(in) :: nocomp_pft ! !LOCAL VARIABLES: !--------------------------------------------------------------------- integer :: el ! element loop index @@ -1981,15 +1882,12 @@ subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) ! assign anthropgenic disturbance category and label new_patch%anthro_disturbance_label = label - - ! where nocomp is active, set PFT of patch - new_patch%nocomp_pft_label = nocomp_pft - if (label .eq. secondaryforest) then new_patch%age_since_anthro_disturbance = age else new_patch%age_since_anthro_disturbance = -1._r8 ! replace with fates_unset_r8 when possible endif + new_patch%nocomp_pft_label = nocomp_pft ! This new value will be generated when the calculate disturbance ! rates routine is called. This does not need to be remembered or in the restart file. @@ -2127,9 +2025,6 @@ subroutine zero_patch(cp_p) currentPatch%gnd_alb_dir(:) = nan currentPatch%gnd_alb_dif(:) = nan - ! special modes - currentPatch%nocomp_pft_label = fates_unset_int - end subroutine zero_patch ! ============================================================================ @@ -2290,11 +2185,12 @@ subroutine fuse_patches( csite, bc_in ) endif ! sum(biomass(:,:) .gt. force_patchfuse_min_biomass endif ! maxage - ! Do not fuse patches that have different PFT labels in nocomp mode - if(hlm_use_nocomp.eq.itrue.and. & - tpp%nocomp_pft_label.ne.currentPatch%nocomp_pft_label)then - fuse_flag = 0 - end if + + ! Do not fuse patches that have different PFT labels in nocomp mode + if(hlm_use_nocomp.eq.itrue.and. & + tpp%nocomp_pft_label.ne.currentPatch%nocomp_pft_label)then + fuse_flag = 0 + end if !-------------------------------------------------------------------------! ! Call the patch fusion routine if there is not a meaningful difference ! ! any of the pft x height categories ! @@ -2302,7 +2198,7 @@ subroutine fuse_patches( csite, bc_in ) !-------------------------------------------------------------------------! if(fuse_flag == 1)then - + !-----------------------! ! fuse the two patches ! !-----------------------! From ca1a60b5dee17609a0ab6bbee3178529ead5c353 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 7 May 2020 03:37:00 -0600 Subject: [PATCH 010/578] this version of edinit works. committing before cleaning up --- main/EDInitMod.F90 | 75 +++++++++++++++++++++++++++++----------------- 1 file changed, 47 insertions(+), 28 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index b81f7103a8..edc577bf96 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -9,6 +9,7 @@ module EDInitMod use FatesConstantsMod , only : itrue use FatesConstantsMod , only : fates_unset_int use FatesConstantsMod , only : primaryforest + use FatesConstantsMod , only : nearzero use FatesGlobals , only : endrun => fates_endrun use EDTypesMod , only : nclmax use FatesGlobals , only : fates_log @@ -362,10 +363,12 @@ subroutine init_patches( nsites, sites, bc_in) integer :: nocomp_pft real(r8) :: newparea real(r8) :: tota !check on area + integer :: is_first_patch type(ed_site_type), pointer :: sitep + type(ed_patch_type), pointer :: newppft(:) type(ed_patch_type), pointer :: newp - type(ed_patch_type), pointer :: recall_younger_patch + type(ed_patch_type), pointer :: recall_older_patch ! List out some nominal patch values that are used for Near Bear Ground initializations ! as well as initializing inventory @@ -399,21 +402,20 @@ subroutine init_patches( nsites, sites, bc_in) else - + allocate(recall_older_patch) do s = 1, nsites - write(*,*) 'areapft',sites(s)%area_pft(1:3) ! Initialize the site-level crown area spread factor (0-1) ! It is likely that closed canopy forest inventories ! have smaller spread factors than bare ground (they are crowded) sites(s)%spread = init_spread_near_bare_ground - if(hlm_use_nocomp.eq.itrue)then no_new_patches = numpft + allocate(newppft(numpft)) else no_new_patches = 1 newparea = area end if - + is_first_patch = 1 do n = 1, no_new_patches ! set the PFT index for patches if in nocomp mode. @@ -438,27 +440,31 @@ subroutine init_patches( nsites, sites, bc_in) if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode allocate(newp) + if(hlm_use_nocomp.eq.itrue)then + newp => newppft(nocomp_pft) + endif call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) - if(.not.associated(recall_younger_patch))then !is this the first patch? + if(is_first_patch.eq.1)then !is this the first patch? + ! set poointers for first patch (or only patch, if nocomp is false) newp%patchno = 1 newp%younger => null() newp%older => null() - sites(s)%youngest_patch => newp sites(s)%oldest_patch => newp - allocate(recall_younger_patch) + is_first_patch = 0 else ! the new patch is the 'oldest' one, arbitrarily. + ! Set pointers for N>1 patches. Note this only happens when nocomp mode s on. + ! The new patch is the 'youngest' one, arbitrarily. newp%patchno = nocomp_pft - newp%younger => recall_younger_patch - newp%older => null() - recall_younger_patch%older => newp - sites(s)%oldest_patch => newp - write(*,*) 'links',s,nocomp_pft,newp%younger%nocomp_pft_label + newp%older => recall_older_patch + newp%younger => null() + recall_older_patch%younger => newp + sites(s)%youngest_patch => newp end if - recall_younger_patch => newp ! remember this patch for the next one to point at. - + recall_older_patch => newp ! remember this patch for the next one to point at. + write(*,*) 'ed init litter01',s,sites(s)%oldest_patch%area ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -471,34 +477,46 @@ subroutine init_patches( nsites, sites, bc_in) init_seed=0._r8, & init_seed_germ=0._r8) end do - write(*,*) 'litt', newp%litter(1)%ag_cwd(1) + write(*,*) 'ed init litter02',s,sites(s)%oldest_patch%area + write(*,*) 'ed init litter03',s,sites(s)%oldest_patch%litter(1)%ag_cwd(1) +! write(*,*) 'ed init litter04',s,sites(1)%oldest_patch%litter(1)%ag_cwd(1) + sitep => sites(s) call init_cohorts(sitep, newp, bc_in(s)) end if end do !no new patches - - tota=0.0_r8 - newp=> sites(s)%oldest_patch + + !check if the total area adds to the same as site area + tota = 0.0_r8 + newp => sites(s)%oldest_patch do while (associated(newp)) tota=tota+newp%area - write(*,*)'test links1',s,newp%nocomp_pft_label,tota - newp=>newp%younger - end do - if(tota.lt.area)then - write(*,*) 'error in assigning areas in init patch',s,tota - endif + write(*,*) 'test links',s,newp%nocomp_pft_label,tota + newp=>newp%younger + end do + if(abs(tota-area).gt.nearzero)then + write(*,*) 'error in assigning areas in init patch',s,tota-area + endif + ! For carbon balance checks, we need to initialize the ! total carbon stock + write(*,*) 'calling sitemassstock',s do el=1,num_elements call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & biomass_stock,litter_stock,seed_stock) end do - + write(*,*) 'ed init litter05',s,sites(s)%oldest_patch%area + write(*,*) 'call set_patchno',s call set_patchno(sites(s)) - deallocate(recall_younger_patch) + write(*,*) 'after set_patchno',s +! deallocate(recall_older_patch) + write(*,*) 'ed init litter06', s,sites(s)%oldest_patch%area +! write(*,*) 'ed init litter15',s,sites(1)%oldest_patch%area +! write(*,*) 'ed init litter2', s,sites(s)%oldest_patch%litter(1)%ag_cwd(1) +! write(*,*) 'ed init litter25',s,sites(1)%oldest_patch%litter(1)%ag_cwd(1) enddo !s -write(*,*)'end init' + write(*,*)'end init' end if ! This sets the rhizosphere shells based on the plant initialization @@ -509,6 +527,7 @@ subroutine init_patches( nsites, sites, bc_in) sitep => sites(s) call updateSizeDepRhizHydProps(sitep, bc_in(s)) end do + deallocate(recall_older_patch) end if return From ed08bf1eb7ea3c7c9aa559c7f34c7f172f88a78d Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 14 May 2020 09:16:16 -0600 Subject: [PATCH 011/578] modify number of patches and patch initialization --- main/EDInitMod.F90 | 4 ++-- main/EDTypesMod.F90 | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index edc577bf96..3d5ee7e30a 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -410,7 +410,7 @@ subroutine init_patches( nsites, sites, bc_in) sites(s)%spread = init_spread_near_bare_ground if(hlm_use_nocomp.eq.itrue)then no_new_patches = numpft - allocate(newppft(numpft)) +! allocate(newppft(numpft)) else no_new_patches = 1 newparea = area @@ -441,7 +441,7 @@ subroutine init_patches( nsites, sites, bc_in) if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode allocate(newp) if(hlm_use_nocomp.eq.itrue)then - newp => newppft(nocomp_pft) + ! newp => newppft(nocomp_pft) endif call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 5902b47be0..b23c492f70 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -22,7 +22,7 @@ module EDTypesMod integer, parameter, public :: maxPatchesPerSite = 14 ! maximum number of patches to live on a site integer, parameter, public :: maxPatchesPerSite_by_disttype(n_anthro_disturbance_categories) = & - (/ 10, 4 /) !!! MUST SUM TO maxPatchesPerSite !!! + (/ 13, 1 /) !!! MUST SUM TO maxPatchesPerSite !!! integer, parameter, public :: maxCohortsPerPatch = 100 ! maximum number of cohorts per patch integer, parameter, public :: nclmax = 2 ! Maximum number of canopy layers From 8ed597aec1c232a972f9ddadd6665c129a5e338c Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 15 May 2020 07:41:32 -0600 Subject: [PATCH 012/578] make disturbance arrays in EPD --- biogeochem/EDPatchDynamicsMod.F90 | 35 ++++++++++++++++++++++++------- 1 file changed, 28 insertions(+), 7 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 3d718df9fd..9d30fd7bce 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -42,7 +42,7 @@ module EDPatchDynamicsMod use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : hlm_days_per_year use FatesInterfaceMod , only : numpft - use FatesInterfaceMod , only : hlm_use_nocomp + use FatesInterfaceMod , only : hlm_use_nocomp use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse @@ -388,6 +388,8 @@ subroutine spawn_patches( currentSite, bc_in) type (ed_patch_type) , pointer :: new_patch type (ed_patch_type) , pointer :: new_patch_primary type (ed_patch_type) , pointer :: new_patch_secondary + type (ed_patch_type) , pointer :: new_patch_primary_pft(:) + type (ed_patch_type) , pointer :: new_patch_secondary_pft(:) type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type), pointer :: currentCohort type (ed_cohort_type), pointer :: nc @@ -396,6 +398,8 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: site_areadis_primary ! total area disturbed (to primary forest) in m2 per site per day real(r8) :: site_areadis_secondary ! total area disturbed (to secondary forest) in m2 per site per day real(r8) :: patch_site_areadis ! total area disturbed in m2 per patch per day + real(r8) :: site_areadis_primary_pft(numpft) ! primary area disturbed per PFT in nocomp mode. m2/patch/day + real(r8) :: site_areadis_secondary_pft(numpft) ! secondary area disturbed per PFT in nocomp mode. m2/patch/day real(r8) :: age ! notional age of this patch in years integer :: el ! element loop index integer :: tnull ! is there a tallest cohort? @@ -410,7 +414,11 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: leaf_burn_frac ! fraction of leaves burned in fire ! for both woody and grass species real(r8) :: leaf_m ! leaf mass during partial burn calculations + integer :: rec_type ! records type of disturbance while in patch loop + integer :: nocomp_pft ! where nocomp mode is on, PFT label + !--------------------------------------------------------------------- + ! Allocate PFT arrays of patches to form the new patches in nocomp mode. storesmallcohort => null() ! storage of the smallest cohort for insertion routine storebigcohort => null() ! storage of the largest cohort for insertion routine @@ -420,6 +428,8 @@ subroutine spawn_patches( currentSite, bc_in) site_areadis_primary = 0.0_r8 site_areadis_secondary = 0.0_r8 + site_areadis_primary_pft(1:numpft) = 0.0_r8 + site_areadis_secondary_pft(1:numpft) = 0.0_r8 do while(associated(currentPatch)) @@ -444,18 +454,29 @@ subroutine spawn_patches( currentSite, bc_in) ! donor patch is primary forest and the dominant disturbance type is not logging if ( currentPatch%anthro_disturbance_label .eq. primaryforest .and. & (currentPatch%disturbance_mode .ne. dtype_ilog) ) then - - site_areadis_primary = site_areadis_primary + currentPatch%area * currentPatch%disturbance_rate + site_areadis_primary = site_areadis_primary + currentPatch%area * currentPatch%disturbance_rate + rec_type = primaryforest else - site_areadis_secondary = site_areadis_secondary + currentPatch%area * currentPatch%disturbance_rate + site_areadis_secondary = site_areadis_secondary + currentPatch%area * currentPatch%disturbance_rate + rec_type = secondaryforest endif - - end if + ! accumulate PFT specific disturbance rates in nocomp mode + if(hlm_use_nocomp.eq.itrue)then + if(rec_type.eq.primaryforest)then + nocomp_pft = currentPatch%nocomp_pft_label + site_areadis_primary_pft(nocomp_pft) = site_areadis_primary_pft(nocomp_pft) & + + currentPatch%area * currentPatch%disturbance_rate + else + site_areadis_secondary_pft(nocomp_pft) = site_areadis_secondary_pft(nocomp_pft) & + + currentPatch%area * currentPatch%disturbance_rate + end if !rectype + end if !nocomp + end if !area currentPatch => currentPatch%older enddo ! end loop over patches. sum area disturbed for all patches. - ! It is possible that no disturbance area was generated + ! It is possible that no disturbance area was generated if ( (site_areadis_primary + site_areadis_secondary) > nearzero) then age = 0.0_r8 From 7e77c3d9e147bf6c1c5bddcd2ad9cc1aec37e0d3 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 15 May 2020 08:18:52 -0600 Subject: [PATCH 013/578] modifications to spawn patches for PFT array disturbance --- biogeochem/EDPatchDynamicsMod.F90 | 41 ++++++++++++++++++++++++++++--- 1 file changed, 38 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 9d30fd7bce..40d0476c12 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -419,6 +419,8 @@ subroutine spawn_patches( currentSite, bc_in) !--------------------------------------------------------------------- ! Allocate PFT arrays of patches to form the new patches in nocomp mode. + allocate(new_patch_primary_pft(numpft)) + allocate(new_patch_secondary_pft(numpft)) storesmallcohort => null() ! storage of the smallest cohort for insertion routine storebigcohort => null() ! storage of the largest cohort for insertion routine @@ -484,8 +486,8 @@ subroutine spawn_patches( currentSite, bc_in) ! create two empty patches, to absorb newly disturbed primary and secondary forest area ! first create patch to receive primary forest area if ( site_areadis_primary .gt. nearzero ) then + if(hlm_use_nocomp.eq.ifalse)then allocate(new_patch_primary) - call create_patch(currentSite, new_patch_primary, age, & site_areadis_primary, primaryforest,1) @@ -503,11 +505,29 @@ subroutine spawn_patches( currentSite, bc_in) new_patch_primary%tallest => null() new_patch_primary%shortest => null() - endif + else !nocomp + do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. +! allocate(new_patch_primary_pft(nocompt_pft)) + if( site_areadis_primary_pft(nocomp_pft) .gt. nearzero ) then + call create_patch(currentSite, new_patch_primary_pft(nocomp_pft), age, & + site_areadis_primary_pft(nocomp_pft), primaryforest,nocomp_pft) + ! Initialize the litter pools to zero + do el=1,num_elements + call new_patch_primary%litter(el)%InitConditions(& + init_leaf_fines=0._r8, init_root_fines=0._r8, init_ag_cwd=0._r8, & + init_bg_cwd =0._r8, init_seed =0._r8, init_seed_germ=0._r8) + end do + new_patch_primary%tallest => null() + new_patch_primary%shortest => null() + end if !area + end do !pft + endif !nocomp + end if !primary ! next create patch to receive secondary forest area if ( site_areadis_secondary .gt. nearzero) then + if(hlm_use_nocomp.eq.ifalse)then allocate(new_patch_secondary) call create_patch(currentSite, new_patch_secondary, age, & site_areadis_secondary, secondaryforest,1) @@ -526,7 +546,22 @@ subroutine spawn_patches( currentSite, bc_in) new_patch_secondary%tallest => null() new_patch_secondary%shortest => null() - endif +else !nocomp + do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. allocate(new_patch_secondary) + if( site_areadis_secondary_pft(nocomp_pft) .gt. nearzero ) then + call create_patch(currentSite, new_patch_secondary_pft(nocomp_pft), age, & + site_areadis_secondary_pft(nocomp_pft), secondaryforest,nocomp_pft) + do el=1,num_elements + call new_patch_secondary%litter(el)%InitConditions(& + init_leaf_fines=0._r8, init_root_fines=0._r8, init_ag_cwd=0._r8, & + init_bg_cwd =0._r8, init_seed =0._r8, init_seed_germ=0._r8) + end do + new_patch_secondary%tallest => null() + new_patch_secondary%shortest => null() + end if !area + end do !pft + endif !nocomp + endif !secondary ! loop round all the patches that contribute surviving indivduals and litter ! pools to the new patch. We only loop the pre-existing patches, so From b48de6a9ac573292064337628d01feadd268b090 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 19 May 2020 07:32:09 -0600 Subject: [PATCH 014/578] modifications to terminate_patches for PFT loops --- biogeochem/EDPatchDynamicsMod.F90 | 199 +++++++++++++++++++++++++----- 1 file changed, 165 insertions(+), 34 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 40d0476c12..7ea71751d7 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -43,6 +43,7 @@ module EDPatchDynamicsMod use FatesInterfaceMod , only : hlm_days_per_year use FatesInterfaceMod , only : numpft use FatesInterfaceMod , only : hlm_use_nocomp + use FatesInterfaceMod , only : hlm_use_fixed_biogeog use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse @@ -102,7 +103,7 @@ module EDPatchDynamicsMod character(len=*), parameter, private :: sourcefile = & __FILE__ - logical, parameter :: debug = .false. + logical, parameter :: debug = .true. ! When creating new patches from other patches, we need to send some of the ! litter from the old patch to the new patch. Likewise, when plants die @@ -478,6 +479,7 @@ subroutine spawn_patches( currentSite, bc_in) currentPatch => currentPatch%older enddo ! end loop over patches. sum area disturbed for all patches. + write(*,*) 'areadis', site_areadis_primary_pft(1:12) ! It is possible that no disturbance area was generated if ( (site_areadis_primary + site_areadis_secondary) > nearzero) then @@ -513,12 +515,12 @@ subroutine spawn_patches( currentSite, bc_in) site_areadis_primary_pft(nocomp_pft), primaryforest,nocomp_pft) ! Initialize the litter pools to zero do el=1,num_elements - call new_patch_primary%litter(el)%InitConditions(& + call new_patch_primary_pft(nocomp_pft)%litter(el)%InitConditions(& init_leaf_fines=0._r8, init_root_fines=0._r8, init_ag_cwd=0._r8, & init_bg_cwd =0._r8, init_seed =0._r8, init_seed_germ=0._r8) end do - new_patch_primary%tallest => null() - new_patch_primary%shortest => null() + new_patch_primary_pft(nocomp_pft)%tallest => null() + new_patch_primary_pft(nocomp_pft)%shortest => null() end if !area end do !pft endif !nocomp @@ -552,12 +554,12 @@ subroutine spawn_patches( currentSite, bc_in) call create_patch(currentSite, new_patch_secondary_pft(nocomp_pft), age, & site_areadis_secondary_pft(nocomp_pft), secondaryforest,nocomp_pft) do el=1,num_elements - call new_patch_secondary%litter(el)%InitConditions(& + call new_patch_secondary_pft(nocomp_pft)%litter(el)%InitConditions(& init_leaf_fines=0._r8, init_root_fines=0._r8, init_ag_cwd=0._r8, & init_bg_cwd =0._r8, init_seed =0._r8, init_seed_germ=0._r8) end do - new_patch_secondary%tallest => null() - new_patch_secondary%shortest => null() + new_patch_secondary_pft(nocomp_pft)%tallest => null() + new_patch_secondary_pft(nocomp_pft)%shortest => null() end if !area end do !pft endif !nocomp @@ -584,10 +586,20 @@ subroutine spawn_patches( currentSite, bc_in) if (currentPatch%anthro_disturbance_label .eq. primaryforest .and. & (currentPatch%disturbance_mode .ne. dtype_ilog)) then new_patch => new_patch_primary + rec_type = primaryforest else new_patch => new_patch_secondary + rec_type = secondaryforest endif + if(hlm_use_nocomp.eq.itrue)then !nocomp case + if(rec_type.eq.primaryforest)then + new_patch => new_patch_primary_pft(currentPatch%nocomp_pft_label) + else + new_patch => new_patch_secondary_pft(currentPatch%nocomp_pft_label) + endif + endif + if(.not.associated(new_patch))then write(fates_log(),*) 'Patch spawning has attempted to point to' write(fates_log(),*) 'an un-allocated patch' @@ -1061,41 +1073,81 @@ subroutine spawn_patches( currentSite, bc_in) !** INSERT NEW PATCH(ES) INTO LINKED LIST !**********`***************/ - if ( site_areadis_primary .gt. nearzero) then + ! currentPatch is the youngest of the pre-existing patches. + !newpatch_primary_pft and newpatch_secondary_pft need to be added into the mix + + if(hlm_use_nocomp.eq.ifalse)then + if ( site_areadis_primary .gt. nearzero) then currentPatch => currentSite%youngest_patch new_patch_primary%older => currentPatch new_patch_primary%younger => null() currentPatch%younger => new_patch_primary currentSite%youngest_patch => new_patch_primary - endif + endif - if ( site_areadis_secondary .gt. nearzero) then + if ( site_areadis_secondary .gt. nearzero) then currentPatch => currentSite%youngest_patch new_patch_secondary%older => currentPatch new_patch_secondary%younger=> null() currentPatch%younger => new_patch_secondary currentSite%youngest_patch => new_patch_secondary - endif - + endif + else !nocomp case with one new patch for each PFT + do nocomp_pft=1,numpft + if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then + currentPatch => currentSite%youngest_patch + new_patch_primary_pft(nocomp_pft)%older => currentPatch + new_patch_primary_pft(nocomp_pft)%younger => null() + currentPatch%younger => new_patch_primary_pft(nocomp_pft) + currentSite%youngest_patch => new_patch_primary_pft(nocomp_pft) + endif + + if ( site_areadis_secondary .gt. nearzero) then + currentPatch => currentSite%youngest_patch + new_patch_secondary_pft(nocomp_pft)%older => currentPatch + new_patch_secondary_pft(nocomp_pft)%younger=> null() + currentPatch%younger => new_patch_secondary_pft(nocomp_pft) + currentSite%youngest_patch => new_patch_secondary_pft(nocomp_pft) + endif + enddo !pft + endif !nocomp ! sort out the cohorts, since some of them may be so small as to need removing. ! the first call to terminate cohorts removes sparse number densities, ! the second call removes for all other reasons (sparse culling must happen ! before fusion) - if ( site_areadis_primary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_primary, 1,17) - call fuse_cohorts(currentSite,new_patch_primary, bc_in) - call terminate_cohorts(currentSite, new_patch_primary, 2,17) - call sort_cohorts(new_patch_primary) - endif - - if ( site_areadis_secondary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_secondary, 1,18) - call fuse_cohorts(currentSite,new_patch_secondary, bc_in) - call terminate_cohorts(currentSite, new_patch_secondary, 2,18) - call sort_cohorts(new_patch_secondary) - endif + if(hlm_use_nocomp.eq.ifalse)then + if ( site_areadis_primary .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_primary, 1,17) + call fuse_cohorts(currentSite,new_patch_primary, bc_in) + call terminate_cohorts(currentSite, new_patch_primary, 2,17) + call sort_cohorts(new_patch_primary) + endif + + if ( site_areadis_secondary .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_secondary, 1,18) + call fuse_cohorts(currentSite,new_patch_secondary, bc_in) + call terminate_cohorts(currentSite, new_patch_secondary, 2,18) + call sort_cohorts(new_patch_secondary) + endif + + else !nocomp case + do nocomp_pft=1,numpft + if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_primary_pft(nocomp_pft), 1,17) + call fuse_cohorts(currentSite,new_patch_primary_pft(nocomp_pft), bc_in) + call terminate_cohorts(currentSite, new_patch_primary_pft(nocomp_pft), 2,17) + call sort_cohorts(new_patch_primary_pft(nocomp_pft)) + endif + if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), 1,18) + call fuse_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), bc_in) + call terminate_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), 2,18) + call sort_cohorts(new_patch_secondary_pft(nocomp_pft)) + endif + enddo !pft + endif !nocomp endif !end new_patch area @@ -1155,7 +1207,7 @@ subroutine check_patch_area( currentSite ) end if if(debug) then - write(fates_log(),*) 'Total patch area precision being fixed, adjusting' + write(fates_log(),*) 'Total patch area precision being fixed, adjusting',(areatot-area_site) write(fates_log(),*) 'largest patch. This may have slight impacts on carbon balance.' end if @@ -2455,8 +2507,10 @@ subroutine fuse_2_patches(csite, dp, rp) end if ! We have no need for the dp pointer anymore, we have passed on it's legacy + write(*,*) 'deallocating' ,dp%nocomp_pft_label, rp%nocomp_pft_label call dealloc_patch(dp) - deallocate(dp) + +! deallocate(dp) if(associated(youngerp))then @@ -2500,9 +2554,13 @@ subroutine terminate_patches(currentSite) type(ed_patch_type), pointer :: currentPatch type(ed_patch_type), pointer :: olderPatch type(ed_patch_type), pointer :: youngerPatch + type(ed_patch_type), pointer :: fusingPatch integer, parameter :: max_cycles = 10 ! After 10 loops through ! You should had fused integer :: count_cycles + integer :: is_youngest + integer :: is_oldest + integer :: found_fusion_patch real(r8) areatot ! variable for checking whether the total patch area is wrong. !--------------------------------------------------------------------- @@ -2513,13 +2571,17 @@ subroutine terminate_patches(currentSite) do while(associated(currentPatch)) if(currentPatch%area <= min_patch_area)then - + + if(hlm_use_fixed_biogeog.eq.ifalse)then !just fuse to older or younger cohort. + ! Even if the patch area is small, avoid fusing it into its neighbor ! if it is the youngest of all patches. We do this in attempts to maintain ! a discrete patch for very young patches ! However, if the patch to be fused is excessivlely small, then fuse ! at all costs. If it is not fused, it will make + ! the current patch is NOT the youngest. Or is it very very small. + ! so, skip merging if it is the youngest, unless the youngest is tiny. if ( .not.associated(currentPatch,currentSite%youngest_patch) .or. & currentPatch%area <= min_patch_area_forced ) then @@ -2553,10 +2615,71 @@ subroutine terminate_patches(currentSite) ! The fusion process has updated the "younger" pointer on currentPatch - endif - endif - endif + endif ! older or younder patch + endif ! very small area + + else !nocomp. We cannot fuse to patches with a different PFT identity in no competition mode. + + ! Each patch has a PFT identity, and so cannot simply fuse to the older or younger patch + ! For each small current patch, we must first search older patch candidates, and then younger + ! patch candidates. + ! need to think about the youngest of PFT logic later. + + is_youngest = itrue !try and find a younger same-PFT patch + ! discover if this is the youngest patch of its PFT + fusingPatch => currentPatch%younger !if it's the youngest overall then it's defacto youngest of PFT + do while(associated(fusingPatch).and.is_youngest.eq.itrue) + if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then + is_youngest = ifalse ! we found a yonger patch, so this isn't the youngest one. + endif ! PFT + fusingPatch => fusingPatch%younger + enddo !fusing patch + + is_oldest = itrue !try and find a younger same-PFT patch + ! discover if this is the youngest patch of its PFT + fusingPatch => currentPatch%older !if it's the youngest overall then it's defacto youngest of PFT + do while(associated(fusingPatch).and.is_oldest.eq.itrue) + if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then + is_oldest = ifalse ! we found a yonger patch, so this isn't the youngest one. + endif ! PFT + fusingPatch => fusingPatch%older + enddo !fusing patch + + if (is_youngest.eq.itrue .or. currentPatch%area <= min_patch_area_forced ) then + + found_fusion_patch = ifalse + + fusingPatch => currentPatch%older + do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) + if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then + if(debug) & + write(fates_log(),*) 'fusing to older patch of same PFT - this one is too small',& + currentPatch%area, fusingPatch%area, & + currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label + call fuse_2_patches(currentSite, fusingPatch, currentPatch) + found_fusion_patch=itrue + endif ! PFT + fusingPatch => fusingPatch%older + enddo !fusing patch + + ! if no older patches, search younger ones. + fusingPatch => currentPatch%younger + do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) + if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then + if(debug) & + write(fates_log(),*) 'fusing to younger patch of same PFT - this one is too small',& + currentPatch%area, fusingPatch%area , & + currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label + call fuse_2_patches(currentSite, fusingPatch, currentPatch) + found_fusion_patch=itrue + endif ! PFT + fusingPatch => fusingPatch%younger + enddo !fusing patch + endif ! not youngest, or is very small patch + endif !nocomp + endif ! small area + ! It is possible that an incredibly small patch just fused into another incredibly ! small patch, resulting in an incredibly small patch. It is also possible that this ! resulting incredibly small patch is the oldest patch. If this was true than @@ -2570,8 +2693,12 @@ subroutine terminate_patches(currentSite) else count_cycles = count_cycles + 1 end if - + if(count_cycles > max_cycles) then + if(is_oldest.eq.itrue.and.is_youngest.eq.itrue.and.hlm_use_fixed_biogeog)then + write(fates_log(),*) 'this is the only patch of this PFT' + currentPatch => currentPatch%older + else !not the only patch write(fates_log(),*) 'FATES is having difficulties fusing very small patches.' write(fates_log(),*) 'It is possible that a either a secondary or primary' write(fates_log(),*) 'patch has become the only patch of its kind, and it is' @@ -2579,6 +2706,9 @@ subroutine terminate_patches(currentSite) write(fates_log(),*) 'disabling the endrun statement following this message.' write(fates_log(),*) 'FATES may or may not continue to operate within error' write(fates_log(),*) 'tolerances, but will generate another fail if it does not.' + + write(fates_log(),*) 'cp pft',currentPatch%nocomp_pft_label,currentPatch%area + call endrun(msg=errMsg(sourcefile, __LINE__)) ! Note to user. If you DO decide to remove the end-run above this line @@ -2586,9 +2716,10 @@ subroutine terminate_patches(currentSite) ! an infinite loop. currentPatch => currentPatch%older count_cycles = 0 - end if + end if !only patch + end if !count cycles - enddo + enddo !patch loop !check area is not exceeded call check_patch_area( currentSite ) From 8e8e91fa5ef047637a3a4735946965017ef1c595 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 20 May 2020 06:09:02 -0600 Subject: [PATCH 015/578] reformatting the PFT loop in spawn patches --- biogeochem/EDPatchDynamicsMod.F90 | 192 ++++++++++++++---------------- 1 file changed, 87 insertions(+), 105 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 7ea71751d7..70815cb779 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -417,12 +417,16 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: leaf_m ! leaf mass during partial burn calculations integer :: rec_type ! records type of disturbance while in patch loop integer :: nocomp_pft ! where nocomp mode is on, PFT label + integer :: numiter + real(r8) :: areadis_primary + real(r8) :: areadis_secondary !--------------------------------------------------------------------- ! Allocate PFT arrays of patches to form the new patches in nocomp mode. - allocate(new_patch_primary_pft(numpft)) - allocate(new_patch_secondary_pft(numpft)) - + if(hlm_use_nocomp.eq.itrue)then + allocate(new_patch_primary_pft(numpft)) + allocate(new_patch_secondary_pft(numpft)) + endif storesmallcohort => null() ! storage of the smallest cohort for insertion routine storebigcohort => null() ! storage of the largest cohort for insertion routine @@ -482,17 +486,35 @@ subroutine spawn_patches( currentSite, bc_in) write(*,*) 'areadis', site_areadis_primary_pft(1:12) ! It is possible that no disturbance area was generated if ( (site_areadis_primary + site_areadis_secondary) > nearzero) then - + + ! Do the entire patch creation loop around a PFT loop. + numiter = 1 + if(hlm_use_nocomp.eq.itrue)then + numiter = numpft + endif + + do nocomp_pft = 1,numiter age = 0.0_r8 ! create two empty patches, to absorb newly disturbed primary and secondary forest area ! first create patch to receive primary forest area + if(hlm_use_nocomp.eq.ifalse)then + areadis_primary = site_areadis_primary + areadis_secondary = site_areadis_secondary + else + areadis_primary = site_areadis_primary_pft(nocomp_pft) + areadis_secondary = site_areadis_secondary_pft(nocomp_pft) + endif + if ( site_areadis_primary .gt. nearzero ) then - if(hlm_use_nocomp.eq.ifalse)then allocate(new_patch_primary) + if(hlm_use_nocomp.eq.ifalse)then call create_patch(currentSite, new_patch_primary, age, & - site_areadis_primary, primaryforest,1) - + areadis_primary, primaryforest,1) + else + call create_patch(currentSite, new_patch_primary, age, & + areadis_primary, primaryforest,nocomp_pft) + endif ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches ! and transfering in mass @@ -506,34 +528,19 @@ subroutine spawn_patches( currentSite, bc_in) end do new_patch_primary%tallest => null() new_patch_primary%shortest => null() - - else !nocomp - do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. -! allocate(new_patch_primary_pft(nocompt_pft)) - if( site_areadis_primary_pft(nocomp_pft) .gt. nearzero ) then - call create_patch(currentSite, new_patch_primary_pft(nocomp_pft), age, & - site_areadis_primary_pft(nocomp_pft), primaryforest,nocomp_pft) - ! Initialize the litter pools to zero - do el=1,num_elements - call new_patch_primary_pft(nocomp_pft)%litter(el)%InitConditions(& - init_leaf_fines=0._r8, init_root_fines=0._r8, init_ag_cwd=0._r8, & - init_bg_cwd =0._r8, init_seed =0._r8, init_seed_germ=0._r8) - end do - new_patch_primary_pft(nocomp_pft)%tallest => null() - new_patch_primary_pft(nocomp_pft)%shortest => null() - end if !area - end do !pft - endif !nocomp end if !primary ! next create patch to receive secondary forest area if ( site_areadis_secondary .gt. nearzero) then - if(hlm_use_nocomp.eq.ifalse)then allocate(new_patch_secondary) + if(hlm_use_nocomp.eq.ifalse)then call create_patch(currentSite, new_patch_secondary, age, & - site_areadis_secondary, secondaryforest,1) - + areadis_secondary, secondaryforest,1) + else + call create_patch(currentSite, new_patch_secondary, age, & + areadis_secondary, secondaryforest,nocomp_pft) + endif ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches ! and transfering in mass @@ -547,22 +554,6 @@ subroutine spawn_patches( currentSite, bc_in) end do new_patch_secondary%tallest => null() new_patch_secondary%shortest => null() - -else !nocomp - do nocomp_pft=1,numpft ! looping round a new patch for each present PFT. allocate(new_patch_secondary) - if( site_areadis_secondary_pft(nocomp_pft) .gt. nearzero ) then - call create_patch(currentSite, new_patch_secondary_pft(nocomp_pft), age, & - site_areadis_secondary_pft(nocomp_pft), secondaryforest,nocomp_pft) - do el=1,num_elements - call new_patch_secondary_pft(nocomp_pft)%litter(el)%InitConditions(& - init_leaf_fines=0._r8, init_root_fines=0._r8, init_ag_cwd=0._r8, & - init_bg_cwd =0._r8, init_seed =0._r8, init_seed_germ=0._r8) - end do - new_patch_secondary_pft(nocomp_pft)%tallest => null() - new_patch_secondary_pft(nocomp_pft)%shortest => null() - end if !area - end do !pft - endif !nocomp endif !secondary ! loop round all the patches that contribute surviving indivduals and litter @@ -592,14 +583,6 @@ subroutine spawn_patches( currentSite, bc_in) rec_type = secondaryforest endif - if(hlm_use_nocomp.eq.itrue)then !nocomp case - if(rec_type.eq.primaryforest)then - new_patch => new_patch_primary_pft(currentPatch%nocomp_pft_label) - else - new_patch => new_patch_secondary_pft(currentPatch%nocomp_pft_label) - endif - endif - if(.not.associated(new_patch))then write(fates_log(),*) 'Patch spawning has attempted to point to' write(fates_log(),*) 'an un-allocated patch' @@ -1076,8 +1059,8 @@ subroutine spawn_patches( currentSite, bc_in) ! currentPatch is the youngest of the pre-existing patches. !newpatch_primary_pft and newpatch_secondary_pft need to be added into the mix - if(hlm_use_nocomp.eq.ifalse)then - if ( site_areadis_primary .gt. nearzero) then + + if ( areadis_primary .gt. nearzero) then currentPatch => currentSite%youngest_patch new_patch_primary%older => currentPatch new_patch_primary%younger => null() @@ -1085,76 +1068,49 @@ subroutine spawn_patches( currentSite, bc_in) currentSite%youngest_patch => new_patch_primary endif - if ( site_areadis_secondary .gt. nearzero) then + if ( areadis_secondary .gt. nearzero) then currentPatch => currentSite%youngest_patch new_patch_secondary%older => currentPatch new_patch_secondary%younger=> null() currentPatch%younger => new_patch_secondary currentSite%youngest_patch => new_patch_secondary endif - else !nocomp case with one new patch for each PFT - do nocomp_pft=1,numpft - if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then - currentPatch => currentSite%youngest_patch - new_patch_primary_pft(nocomp_pft)%older => currentPatch - new_patch_primary_pft(nocomp_pft)%younger => null() - currentPatch%younger => new_patch_primary_pft(nocomp_pft) - currentSite%youngest_patch => new_patch_primary_pft(nocomp_pft) - endif - - if ( site_areadis_secondary .gt. nearzero) then - currentPatch => currentSite%youngest_patch - new_patch_secondary_pft(nocomp_pft)%older => currentPatch - new_patch_secondary_pft(nocomp_pft)%younger=> null() - currentPatch%younger => new_patch_secondary_pft(nocomp_pft) - currentSite%youngest_patch => new_patch_secondary_pft(nocomp_pft) - endif - enddo !pft - endif !nocomp - + ! sort out the cohorts, since some of them may be so small as to need removing. ! the first call to terminate cohorts removes sparse number densities, ! the second call removes for all other reasons (sparse culling must happen ! before fusion) - if(hlm_use_nocomp.eq.ifalse)then - if ( site_areadis_primary .gt. nearzero) then + if ( areadis_primary .gt. nearzero) then call terminate_cohorts(currentSite, new_patch_primary, 1,17) call fuse_cohorts(currentSite,new_patch_primary, bc_in) call terminate_cohorts(currentSite, new_patch_primary, 2,17) call sort_cohorts(new_patch_primary) endif - if ( site_areadis_secondary .gt. nearzero) then + if ( areadis_secondary .gt. nearzero) then call terminate_cohorts(currentSite, new_patch_secondary, 1,18) call fuse_cohorts(currentSite,new_patch_secondary, bc_in) call terminate_cohorts(currentSite, new_patch_secondary, 2,18) call sort_cohorts(new_patch_secondary) endif - else !nocomp case - do nocomp_pft=1,numpft - if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_primary_pft(nocomp_pft), 1,17) - call fuse_cohorts(currentSite,new_patch_primary_pft(nocomp_pft), bc_in) - call terminate_cohorts(currentSite, new_patch_primary_pft(nocomp_pft), 2,17) - call sort_cohorts(new_patch_primary_pft(nocomp_pft)) - endif - if ( site_areadis_primary_pft(nocomp_pft) .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), 1,18) - call fuse_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), bc_in) - call terminate_cohorts(currentSite, new_patch_secondary_pft(nocomp_pft), 2,18) - call sort_cohorts(new_patch_secondary_pft(nocomp_pft)) - endif - enddo !pft - endif !nocomp - + end do ! PFT loop for nocomp endif !end new_patch area - call check_patch_area(currentSite) call set_patchno(currentSite) + currentpatch => currentSite%youngest_patch + do while(associated(currentpatch)) + write(*,*) 'sp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label + if(associated(currentpatch%younger))then + write(*,*) 'sp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label + endif + currentpatch => currentpatch%older + + enddo + return end subroutine spawn_patches @@ -2373,7 +2329,16 @@ subroutine fuse_patches( csite, bc_in ) enddo !do while nopatches>maxPatchesPerSite end do ! i_disttype loop - + + currentpatch => currentSite%youngest_patch + do while(associated(currentpatch)) + write(*,*) 'fp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label + if(associated(currentpatch%younger))then + write(*,*) 'fp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label + endif + currentpatch => currentpatch%older + enddo + end subroutine fuse_patches ! ============================================================================ @@ -2470,7 +2435,7 @@ subroutine fuse_2_patches(csite, dp, rp) else snull = 1 rp%shortest => currentCohort - endif + Endif call insert_cohort(currentCohort, rp%tallest, rp%shortest, tnull, snull, storebigcohort, storesmallcohort) @@ -2507,10 +2472,10 @@ subroutine fuse_2_patches(csite, dp, rp) end if ! We have no need for the dp pointer anymore, we have passed on it's legacy - write(*,*) 'deallocating' ,dp%nocomp_pft_label, rp%nocomp_pft_label call dealloc_patch(dp) + write(*,*) 'deallocating2' ,dp%nocomp_pft_label, rp%nocomp_pft_label, dp%patchno, rp%patchno -! deallocate(dp) + deallocate(dp) if(associated(youngerp))then @@ -2566,6 +2531,18 @@ subroutine terminate_patches(currentSite) !--------------------------------------------------------------------- count_cycles = 0 +write(*,*) 'start terminate patches',currentSite%lat,currentSite%lon + + currentpatch => currentSite%youngest_patch + do while(associated(currentpatch)) + write(*,*) 'tp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label + if(associated(currentpatch%younger))then + write(*,*) 'tp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label + endif + currentpatch => currentpatch%older + + enddo + currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) @@ -2651,29 +2628,33 @@ subroutine terminate_patches(currentSite) fusingPatch => currentPatch%older do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) + olderPatch => fusingPatch%older if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then if(debug) & write(fates_log(),*) 'fusing to older patch of same PFT - this one is too small',& currentPatch%area, fusingPatch%area, & - currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label + currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label, & + currentPatch%patchno, fusingPatch%patchno call fuse_2_patches(currentSite, fusingPatch, currentPatch) found_fusion_patch=itrue endif ! PFT - fusingPatch => fusingPatch%older + fusingPatch => olderPatch enddo !fusing patch ! if no older patches, search younger ones. fusingPatch => currentPatch%younger do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) + olderPatch => fusingPatch%older if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then if(debug) & write(fates_log(),*) 'fusing to younger patch of same PFT - this one is too small',& currentPatch%area, fusingPatch%area , & - currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label + currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label, & + currentPatch%patchno, fusingPatch%patchno call fuse_2_patches(currentSite, fusingPatch, currentPatch) found_fusion_patch=itrue endif ! PFT - fusingPatch => fusingPatch%younger + fusingPatch => olderPatch enddo !fusing patch endif ! not youngest, or is very small patch endif !nocomp @@ -2698,6 +2679,7 @@ subroutine terminate_patches(currentSite) if(is_oldest.eq.itrue.and.is_youngest.eq.itrue.and.hlm_use_fixed_biogeog)then write(fates_log(),*) 'this is the only patch of this PFT' currentPatch => currentPatch%older + count_cycles = 0 else !not the only patch write(fates_log(),*) 'FATES is having difficulties fusing very small patches.' write(fates_log(),*) 'It is possible that a either a secondary or primary' @@ -2723,7 +2705,7 @@ subroutine terminate_patches(currentSite) !check area is not exceeded call check_patch_area( currentSite ) - + write(*,*) 'leaving terminate patches',currentSite%lat,currentSite%lon return end subroutine terminate_patches From 2b08a8d228061bc08dade9b3e4531749229cd796 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 20 May 2020 06:09:29 -0600 Subject: [PATCH 016/578] removing write statements from EDInit --- main/EDInitMod.F90 | 15 +-------------- 1 file changed, 1 insertion(+), 14 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 3d5ee7e30a..b1efc0d3d4 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -440,9 +440,6 @@ subroutine init_patches( nsites, sites, bc_in) if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode allocate(newp) - if(hlm_use_nocomp.eq.itrue)then - ! newp => newppft(nocomp_pft) - endif call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) @@ -464,7 +461,6 @@ subroutine init_patches( nsites, sites, bc_in) sites(s)%youngest_patch => newp end if recall_older_patch => newp ! remember this patch for the next one to point at. - write(*,*) 'ed init litter01',s,sites(s)%oldest_patch%area ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -477,9 +473,6 @@ subroutine init_patches( nsites, sites, bc_in) init_seed=0._r8, & init_seed_germ=0._r8) end do - write(*,*) 'ed init litter02',s,sites(s)%oldest_patch%area - write(*,*) 'ed init litter03',s,sites(s)%oldest_patch%litter(1)%ag_cwd(1) -! write(*,*) 'ed init litter04',s,sites(1)%oldest_patch%litter(1)%ag_cwd(1) sitep => sites(s) call init_cohorts(sitep, newp, bc_in(s)) @@ -505,16 +498,10 @@ subroutine init_patches( nsites, sites, bc_in) call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & biomass_stock,litter_stock,seed_stock) end do - write(*,*) 'ed init litter05',s,sites(s)%oldest_patch%area - write(*,*) 'call set_patchno',s + call set_patchno(sites(s)) - write(*,*) 'after set_patchno',s ! deallocate(recall_older_patch) - write(*,*) 'ed init litter06', s,sites(s)%oldest_patch%area -! write(*,*) 'ed init litter15',s,sites(1)%oldest_patch%area -! write(*,*) 'ed init litter2', s,sites(s)%oldest_patch%litter(1)%ag_cwd(1) -! write(*,*) 'ed init litter25',s,sites(1)%oldest_patch%litter(1)%ag_cwd(1) enddo !s write(*,*)'end init' end if From 30659c9bcb938a546d6833d50b1b1016aae00872 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 20 May 2020 08:45:43 -0600 Subject: [PATCH 017/578] fixing issues with area in spawn patches2667 --- biogeochem/EDPatchDynamicsMod.F90 | 73 +++++++++++++++++++++++-------- 1 file changed, 54 insertions(+), 19 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 70815cb779..338ed262f1 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -565,9 +565,18 @@ subroutine spawn_patches( currentSite, bc_in) do while(associated(currentPatch)) ! This is the amount of patch area that is disturbed, and donated by the donor + if(hlm_use_nocomp.eq.ifalse)then patch_site_areadis = currentPatch%area * currentPatch%disturbance_rate + else + if(currentPatch%nocomp_pft_label.eq.nocomp_pft)then + patch_site_areadis = currentPatch%area * currentPatch%disturbance_rate + else + patch_site_areadis = 0.0_r8 + endif + endif + write(*,*) 'patch donor pft loop' ,currentPatch%nocomp_pft_label,nocomp_pft,& + patch_site_areadis,currentpatch%patchno,currentPatch%disturbance_rate - if ( patch_site_areadis > nearzero ) then ! figure out whether the receiver patch for disturbance from this patch @@ -610,7 +619,7 @@ subroutine spawn_patches( currentSite, bc_in) if(currentPatch%disturbance_mode .ne. dtype_ifire) then currentPatch%burnt_frac_litter(:) = 0._r8 end if - + write(*,*) 'patch site areadis',patch_site_areadis,new_patch%area,nocomp_pft,currentPatch%disturbance_rate call TransLitterNewPatch( currentSite, currentPatch, new_patch, patch_site_areadis) ! Transfer in litter fluxes from plants in various contexts of death and destruction @@ -1043,11 +1052,6 @@ subroutine spawn_patches( currentSite, bc_in) end if ! if ( new_patch%area > nearzero ) then - !zero disturbance rate trackers - currentPatch%disturbance_rate = 0._r8 - currentPatch%disturbance_rates = 0._r8 - currentPatch%fract_ldist_not_harvested = 0._r8 - currentPatch => currentPatch%younger enddo ! currentPatch patch loop. @@ -1094,19 +1098,31 @@ subroutine spawn_patches( currentSite, bc_in) call terminate_cohorts(currentSite, new_patch_secondary, 2,18) call sort_cohorts(new_patch_secondary) endif + write(*,*) 'pft loop', nocomp_pft + end do ! PFT loop for nocomp endif !end new_patch area + currentpatch => currentSite%youngest_patch + do while(associated(currentpatch)) + !zero disturbance rate trackers + currentPatch%disturbance_rate = 0._r8 + currentPatch%disturbance_rates = 0._r8 + currentPatch%fract_ldist_not_harvested = 0._r8 + currentpatch => currentpatch%older + end do + call check_patch_area(currentSite) call set_patchno(currentSite) currentpatch => currentSite%youngest_patch do while(associated(currentpatch)) - write(*,*) 'sp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label if(associated(currentpatch%younger))then - write(*,*) 'sp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label +! write(*,*) 'sp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label,& +!currentpatch%younger%area endif +! write(*,*) 'sp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label,currentpatch%area currentpatch => currentpatch%older enddo @@ -2332,10 +2348,11 @@ subroutine fuse_patches( csite, bc_in ) currentpatch => currentSite%youngest_patch do while(associated(currentpatch)) - write(*,*) 'fp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label if(associated(currentpatch%younger))then - write(*,*) 'fp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label +! write(*,*) 'fp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label,& +!currentpatch%younger%area endif +! write(*,*) 'fp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label,currentpatch%area currentpatch => currentpatch%older enddo @@ -2535,15 +2552,20 @@ subroutine terminate_patches(currentSite) currentpatch => currentSite%youngest_patch do while(associated(currentpatch)) - write(*,*) 'tp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label - if(associated(currentpatch%younger))then - write(*,*) 'tp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label - endif +! write(*,*) 'tp o-y patch list',currentpatch%patchno,currentpatch%nocomp_pft_label,currentpatch%area currentpatch => currentpatch%older + enddo + currentpatch => currentSite%oldest_patch + do while(associated(currentpatch)) + write(*,*) 'tp y-o patch list',currentpatch%patchno,currentpatch%nocomp_pft_label,currentpatch%area + currentpatch => currentpatch%younger enddo + + + currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) @@ -2622,7 +2644,7 @@ subroutine terminate_patches(currentSite) fusingPatch => fusingPatch%older enddo !fusing patch - if (is_youngest.eq.itrue .or. currentPatch%area <= min_patch_area_forced ) then + if (is_youngest.eq.ifalse .or. currentPatch%area <= min_patch_area_forced ) then found_fusion_patch = ifalse @@ -2635,7 +2657,7 @@ subroutine terminate_patches(currentSite) currentPatch%area, fusingPatch%area, & currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label, & currentPatch%patchno, fusingPatch%patchno - call fuse_2_patches(currentSite, fusingPatch, currentPatch) + call fuse_2_patches(currentSite, currentPatch, fusingPatch) found_fusion_patch=itrue endif ! PFT fusingPatch => olderPatch @@ -2644,14 +2666,19 @@ subroutine terminate_patches(currentSite) ! if no older patches, search younger ones. fusingPatch => currentPatch%younger do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) + + if(fusingPatch%patchno.eq.currentPatch%younger%patchno)then + write(*,*) 'something weird with younger pointer here',fusingPatch%patchno,currentPatch%younger%patchno + end if olderPatch => fusingPatch%older if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then if(debug) & write(fates_log(),*) 'fusing to younger patch of same PFT - this one is too small',& currentPatch%area, fusingPatch%area , & currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label, & - currentPatch%patchno, fusingPatch%patchno - call fuse_2_patches(currentSite, fusingPatch, currentPatch) + currentPatch%patchno, fusingPatch%patchno,& + is_youngest,is_oldest + call fuse_2_patches(currentSite, currentPatch, fusingPatch) found_fusion_patch=itrue endif ! PFT fusingPatch => olderPatch @@ -2700,6 +2727,14 @@ subroutine terminate_patches(currentSite) count_cycles = 0 end if !only patch end if !count cycles + call set_patchno(currentSite) + + fusingpatch => currentSite%oldest_patch + write(*,*) 'tp end list' + do while(associated(fusingpatch)) + write(*,*) 'tp end y-o patch list',fusingpatch%patchno,fusingpatch%nocomp_pft_label,fusingpatch%area + fusingpatch => fusingpatch%younger + enddo enddo !patch loop From 02db378f560eeb3746f43960be748df499efd042 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 20 May 2020 09:12:04 -0600 Subject: [PATCH 018/578] fixed references to currentPatch in terminate patches --- biogeochem/EDPatchDynamicsMod.F90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 338ed262f1..cda1b0077f 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -574,7 +574,6 @@ subroutine spawn_patches( currentSite, bc_in) patch_site_areadis = 0.0_r8 endif endif - write(*,*) 'patch donor pft loop' ,currentPatch%nocomp_pft_label,nocomp_pft,& patch_site_areadis,currentpatch%patchno,currentPatch%disturbance_rate if ( patch_site_areadis > nearzero ) then @@ -1098,8 +1097,6 @@ subroutine spawn_patches( currentSite, bc_in) call terminate_cohorts(currentSite, new_patch_secondary, 2,18) call sort_cohorts(new_patch_secondary) endif - write(*,*) 'pft loop', nocomp_pft - end do ! PFT loop for nocomp endif !end new_patch area @@ -2663,6 +2660,7 @@ subroutine terminate_patches(currentSite) fusingPatch => olderPatch enddo !fusing patch + if(associated(currentPatch).and.found_fusion_patch.eq.ifalse)then ! if no older patches, search younger ones. fusingPatch => currentPatch%younger do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) @@ -2683,6 +2681,11 @@ subroutine terminate_patches(currentSite) endif ! PFT fusingPatch => olderPatch enddo !fusing patch + endif !current patch exists. + if(found_fusion_patch.eq.itrue)then + currentPatch => fusingPatch + endif + endif ! not youngest, or is very small patch endif !nocomp endif ! small area @@ -2695,6 +2698,7 @@ subroutine terminate_patches(currentSite) ! Think this is impossible? No, this really happens, especially when we have fires. ! So, we don't move forward until we have merged enough area into this thing. + if(currentPatch%area > min_patch_area_forced)then currentPatch => currentPatch%older count_cycles = 0 From 34f3532202cc00537115d085fae4ffc43fe86a54 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 20 May 2020 14:42:22 -0600 Subject: [PATCH 019/578] added olderp ref to cp loop in terminate patches --- biogeochem/EDPatchDynamicsMod.F90 | 47 +++++++++++++++++++++++-------- 1 file changed, 35 insertions(+), 12 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index cda1b0077f..5e67307d24 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -574,7 +574,6 @@ subroutine spawn_patches( currentSite, bc_in) patch_site_areadis = 0.0_r8 endif endif - patch_site_areadis,currentpatch%patchno,currentPatch%disturbance_rate if ( patch_site_areadis > nearzero ) then @@ -2474,6 +2473,7 @@ subroutine fuse_2_patches(csite, dp, rp) ! Define some aliases for the donor patches younger and older neighbors ! which may or may not exist. After we set them, we will remove the donor ! And then we will go about re-setting the map. + if(associated(dp%older))then olderp => dp%older else @@ -2485,6 +2485,9 @@ subroutine fuse_2_patches(csite, dp, rp) youngerp => null() end if + + + ! We have no need for the dp pointer anymore, we have passed on it's legacy call dealloc_patch(dp) write(*,*) 'deallocating2' ,dp%nocomp_pft_label, rp%nocomp_pft_label, dp%patchno, rp%patchno @@ -2532,6 +2535,7 @@ subroutine terminate_patches(currentSite) ! !LOCAL VARIABLES: type(ed_patch_type), pointer :: currentPatch type(ed_patch_type), pointer :: olderPatch + type(ed_patch_type), pointer :: oldercPatch type(ed_patch_type), pointer :: youngerPatch type(ed_patch_type), pointer :: fusingPatch integer, parameter :: max_cycles = 10 ! After 10 loops through @@ -2565,7 +2569,8 @@ subroutine terminate_patches(currentSite) currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - + write(*,*) 'currentPatch1',currentPatch%patchno,currentPatch%nocomp_pft_label + oldercpatch => currentPatch%older if(currentPatch%area <= min_patch_area)then if(hlm_use_fixed_biogeog.eq.ifalse)then !just fuse to older or younger cohort. @@ -2628,6 +2633,11 @@ subroutine terminate_patches(currentSite) if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then is_youngest = ifalse ! we found a yonger patch, so this isn't the youngest one. endif ! PFT + if(associated(fusingpatch%younger))then + if(fusingpatch%patchno.eq.fusingpatch%younger%patchno)then + write(*,*) 'is_youngest patch list error',fusingpatch%patchno,fusingpatch%younger%patchno + endif + endif fusingPatch => fusingPatch%younger enddo !fusing patch @@ -2648,7 +2658,12 @@ subroutine terminate_patches(currentSite) fusingPatch => currentPatch%older do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) olderPatch => fusingPatch%older - if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then + if(associated(fusingpatch%younger))then + if(fusingpatch%patchno.eq.fusingpatch%younger%patchno)then + write(*,*) 'fuse older patch list error',fusingpatch%patchno,fusingpatch%younger%patchno + endif + endif + if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then if(debug) & write(fates_log(),*) 'fusing to older patch of same PFT - this one is too small',& currentPatch%area, fusingPatch%area, & @@ -2665,9 +2680,9 @@ subroutine terminate_patches(currentSite) fusingPatch => currentPatch%younger do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) - if(fusingPatch%patchno.eq.currentPatch%younger%patchno)then - write(*,*) 'something weird with younger pointer here',fusingPatch%patchno,currentPatch%younger%patchno - end if + if(fusingPatch%patchno.eq.currentPatch%younger%patchno)then + write(*,*) 'something weird with younger pointer here',fusingPatch%patchno,currentPatch%younger%patchno + end if olderPatch => fusingPatch%older if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then if(debug) & @@ -2700,12 +2715,13 @@ subroutine terminate_patches(currentSite) if(currentPatch%area > min_patch_area_forced)then - currentPatch => currentPatch%older + currentPatch => oldercPatch count_cycles = 0 else count_cycles = count_cycles + 1 end if - +! write(*,*) 'currentPatch2',currentPatch%patchno,currentPatch%nocomp_pft_label + if(count_cycles > max_cycles) then if(is_oldest.eq.itrue.and.is_youngest.eq.itrue.and.hlm_use_fixed_biogeog)then write(fates_log(),*) 'this is the only patch of this PFT' @@ -2727,20 +2743,27 @@ subroutine terminate_patches(currentSite) ! Note to user. If you DO decide to remove the end-run above this line ! Make sure that you keep the pointer below this line, or you will get ! an infinite loop. - currentPatch => currentPatch%older + currentPatch => oldercPatch count_cycles = 0 end if !only patch end if !count cycles - call set_patchno(currentSite) + call set_patchno(currentSite) !redo patch numbering for every potential termination. + !n.b. could put filter in here for actual terminations to save time. fusingpatch => currentSite%oldest_patch write(*,*) 'tp end list' do while(associated(fusingpatch)) write(*,*) 'tp end y-o patch list',fusingpatch%patchno,fusingpatch%nocomp_pft_label,fusingpatch%area - fusingpatch => fusingpatch%younger + + if(associated(fusingpatch%younger))then + if(fusingpatch%patchno.eq.fusingpatch%younger%patchno)then + write(*,*) 'patch list error',fusingpatch%patchno,fusingpatch%younger%patchno + endif + endif + fusingpatch => fusingpatch%younger enddo - enddo !patch loop + enddo ! current patch loop !check area is not exceeded call check_patch_area( currentSite ) From ce71fda10a9ce0d35a415f705f1ca0e8f04efbc7 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 20 May 2020 15:46:49 -0600 Subject: [PATCH 020/578] located error in the small size tolerances. Eraase <1% patches to fix --- biogeochem/EDPatchDynamicsMod.F90 | 20 +++++++++++++------- main/EDInitMod.F90 | 15 ++++++++++++++- 2 files changed, 27 insertions(+), 8 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 5e67307d24..146c5a30fa 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2652,7 +2652,7 @@ subroutine terminate_patches(currentSite) enddo !fusing patch if (is_youngest.eq.ifalse .or. currentPatch%area <= min_patch_area_forced ) then - + write(*,*) 'current patch is termination candidate',currentPatch%area found_fusion_patch = ifalse fusingPatch => currentPatch%older @@ -2670,6 +2670,8 @@ subroutine terminate_patches(currentSite) currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label, & currentPatch%patchno, fusingPatch%patchno call fuse_2_patches(currentSite, currentPatch, fusingPatch) + currentPatch => fusingPatch !redirect rest of main loop back to this cp + write(*,*) 'reverting curent patch to ', currentPatch%patchno found_fusion_patch=itrue endif ! PFT fusingPatch => olderPatch @@ -2681,9 +2683,10 @@ subroutine terminate_patches(currentSite) do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) if(fusingPatch%patchno.eq.currentPatch%younger%patchno)then - write(*,*) 'something weird with younger pointer here',fusingPatch%patchno,currentPatch%younger%patchno + write(*,*) 'something weird with younger pointer here',fusingPatch%patchno,fusingPatch%nocomp_pft_label end if olderPatch => fusingPatch%older + if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then if(debug) & write(fates_log(),*) 'fusing to younger patch of same PFT - this one is too small',& @@ -2692,14 +2695,13 @@ subroutine terminate_patches(currentSite) currentPatch%patchno, fusingPatch%patchno,& is_youngest,is_oldest call fuse_2_patches(currentSite, currentPatch, fusingPatch) + currentPatch => fusingPatch found_fusion_patch=itrue endif ! PFT fusingPatch => olderPatch enddo !fusing patch endif !current patch exists. - if(found_fusion_patch.eq.itrue)then - currentPatch => fusingPatch - endif + endif ! not youngest, or is very small patch endif !nocomp @@ -2716,15 +2718,19 @@ subroutine terminate_patches(currentSite) if(currentPatch%area > min_patch_area_forced)then currentPatch => oldercPatch + count_cycles = 0 else count_cycles = count_cycles + 1 + write(*,*) 'iterate count cycles',count_cycles end if -! write(*,*) 'currentPatch2',currentPatch%patchno,currentPatch%nocomp_pft_label + if(associated(oldercPatch))then + write(*,*) 'currentPatch2',currentPatch%patchno,oldercPatch%patchno + endif if(count_cycles > max_cycles) then if(is_oldest.eq.itrue.and.is_youngest.eq.itrue.and.hlm_use_fixed_biogeog)then - write(fates_log(),*) 'this is the only patch of this PFT' + write(fates_log(),*) 'this is the only patch of this PFT',currentPatch%area currentPatch => currentPatch%older count_cycles = 0 else !not the only patch diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index b1efc0d3d4..2a4af75290 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -304,10 +304,23 @@ subroutine set_site_properties( nsites, sites,bc_in ) ! re-normalize PFT area to ensure it sums to one. ! note that in areas of 'bare ground' (PFT 0 in CLM/ELM) ! the bare ground will no longer be proscribed and should emerge from FATES + + do ft = 1,numpft + if(sites(s)%area_pft(ft).lt.0.01_r8)then + sites(s)%area_pft(ft)=0.0_r8 !remove tiny patches to prevent numerical errors. +! write(*,*) 'removing small pft patches',s,sites(s)%area_pft(1:12) + endif + end do + sumarea = sum(sites(s)%area_pft(1:numpft)) do ft = 1,numpft + if(sumarea.gt.0._r8)then sites(s)%area_pft(ft) = sites(s)%area_pft(ft)/sumarea - end do + else + sites(s)%area_pft(ft)= 1.0_r8/numpft + write(*,*) 'setting totally bare patch to all pfts.',s,sumarea,sites(s)%area_pft(ft) + end if + end do !ft end if do ft = 1,numpft From 9ad82a7ed1fa64687a288b0aa0f7c77a6ab0c994 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 22 May 2020 08:06:10 -0600 Subject: [PATCH 021/578] added filter to init cohorts --- biogeochem/EDPatchDynamicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 146c5a30fa..b4ee32e379 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2573,7 +2573,7 @@ subroutine terminate_patches(currentSite) oldercpatch => currentPatch%older if(currentPatch%area <= min_patch_area)then - if(hlm_use_fixed_biogeog.eq.ifalse)then !just fuse to older or younger cohort. + if(hlm_use_nocomp.eq.ifalse)then !just fuse to older or younger patch ! Even if the patch area is small, avoid fusing it into its neighbor ! if it is the youngest of all patches. We do this in attempts to maintain From ba0aca67b21f0be99b2f9650215616f9f24345c2 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 25 May 2020 08:04:14 -0600 Subject: [PATCH 022/578] fixed memory leak. removed write statements --- biogeochem/EDPatchDynamicsMod.F90 | 80 +++---------------------------- 1 file changed, 7 insertions(+), 73 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index b4ee32e379..d77791d218 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -103,7 +103,7 @@ module EDPatchDynamicsMod character(len=*), parameter, private :: sourcefile = & __FILE__ - logical, parameter :: debug = .true. + logical, parameter :: debug = .false. ! When creating new patches from other patches, we need to send some of the ! litter from the old patch to the new patch. Likewise, when plants die @@ -399,8 +399,6 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: site_areadis_primary ! total area disturbed (to primary forest) in m2 per site per day real(r8) :: site_areadis_secondary ! total area disturbed (to secondary forest) in m2 per site per day real(r8) :: patch_site_areadis ! total area disturbed in m2 per patch per day - real(r8) :: site_areadis_primary_pft(numpft) ! primary area disturbed per PFT in nocomp mode. m2/patch/day - real(r8) :: site_areadis_secondary_pft(numpft) ! secondary area disturbed per PFT in nocomp mode. m2/patch/day real(r8) :: age ! notional age of this patch in years integer :: el ! element loop index integer :: tnull ! is there a tallest cohort? @@ -422,11 +420,7 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: areadis_secondary !--------------------------------------------------------------------- - ! Allocate PFT arrays of patches to form the new patches in nocomp mode. - if(hlm_use_nocomp.eq.itrue)then - allocate(new_patch_primary_pft(numpft)) - allocate(new_patch_secondary_pft(numpft)) - endif + storesmallcohort => null() ! storage of the smallest cohort for insertion routine storebigcohort => null() ! storage of the largest cohort for insertion routine @@ -483,7 +477,6 @@ subroutine spawn_patches( currentSite, bc_in) currentPatch => currentPatch%older enddo ! end loop over patches. sum area disturbed for all patches. - write(*,*) 'areadis', site_areadis_primary_pft(1:12) ! It is possible that no disturbance area was generated if ( (site_areadis_primary + site_areadis_secondary) > nearzero) then @@ -617,7 +610,7 @@ subroutine spawn_patches( currentSite, bc_in) if(currentPatch%disturbance_mode .ne. dtype_ifire) then currentPatch%burnt_frac_litter(:) = 0._r8 end if - write(*,*) 'patch site areadis',patch_site_areadis,new_patch%area,nocomp_pft,currentPatch%disturbance_rate + call TransLitterNewPatch( currentSite, currentPatch, new_patch, patch_site_areadis) ! Transfer in litter fluxes from plants in various contexts of death and destruction @@ -1112,17 +1105,7 @@ subroutine spawn_patches( currentSite, bc_in) call check_patch_area(currentSite) call set_patchno(currentSite) - currentpatch => currentSite%youngest_patch - do while(associated(currentpatch)) - if(associated(currentpatch%younger))then -! write(*,*) 'sp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label,& -!currentpatch%younger%area - endif -! write(*,*) 'sp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label,currentpatch%area - currentpatch => currentpatch%older - - enddo - +! write(*,*) 'end spawn patches',currentsite%lat, currentSite%lon return end subroutine spawn_patches @@ -2342,16 +2325,6 @@ subroutine fuse_patches( csite, bc_in ) end do ! i_disttype loop - currentpatch => currentSite%youngest_patch - do while(associated(currentpatch)) - if(associated(currentpatch%younger))then -! write(*,*) 'fp check cpy',currentpatch%younger%patchno,currentpatch%younger%nocomp_pft_label,& -!currentpatch%younger%area - endif -! write(*,*) 'fp patch list',currentpatch%patchno,currentpatch%nocomp_pft_label,currentpatch%area - currentpatch => currentpatch%older - enddo - end subroutine fuse_patches ! ============================================================================ @@ -2490,7 +2463,6 @@ subroutine fuse_2_patches(csite, dp, rp) ! We have no need for the dp pointer anymore, we have passed on it's legacy call dealloc_patch(dp) - write(*,*) 'deallocating2' ,dp%nocomp_pft_label, rp%nocomp_pft_label, dp%patchno, rp%patchno deallocate(dp) @@ -2549,27 +2521,10 @@ subroutine terminate_patches(currentSite) !--------------------------------------------------------------------- count_cycles = 0 -write(*,*) 'start terminate patches',currentSite%lat,currentSite%lon - - currentpatch => currentSite%youngest_patch - do while(associated(currentpatch)) -! write(*,*) 'tp o-y patch list',currentpatch%patchno,currentpatch%nocomp_pft_label,currentpatch%area - currentpatch => currentpatch%older - enddo - - currentpatch => currentSite%oldest_patch - do while(associated(currentpatch)) - write(*,*) 'tp y-o patch list',currentpatch%patchno,currentpatch%nocomp_pft_label,currentpatch%area - currentpatch => currentpatch%younger - enddo - - - - +!write(*,*) 'start terminate patches',currentSite%lat,currentSite%lon currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - write(*,*) 'currentPatch1',currentPatch%patchno,currentPatch%nocomp_pft_label oldercpatch => currentPatch%older if(currentPatch%area <= min_patch_area)then @@ -2652,7 +2607,6 @@ subroutine terminate_patches(currentSite) enddo !fusing patch if (is_youngest.eq.ifalse .or. currentPatch%area <= min_patch_area_forced ) then - write(*,*) 'current patch is termination candidate',currentPatch%area found_fusion_patch = ifalse fusingPatch => currentPatch%older @@ -2671,8 +2625,7 @@ subroutine terminate_patches(currentSite) currentPatch%patchno, fusingPatch%patchno call fuse_2_patches(currentSite, currentPatch, fusingPatch) currentPatch => fusingPatch !redirect rest of main loop back to this cp - write(*,*) 'reverting curent patch to ', currentPatch%patchno - found_fusion_patch=itrue + found_fusion_patch=itrue endif ! PFT fusingPatch => olderPatch enddo !fusing patch @@ -2681,10 +2634,6 @@ subroutine terminate_patches(currentSite) ! if no older patches, search younger ones. fusingPatch => currentPatch%younger do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) - - if(fusingPatch%patchno.eq.currentPatch%younger%patchno)then - write(*,*) 'something weird with younger pointer here',fusingPatch%patchno,fusingPatch%nocomp_pft_label - end if olderPatch => fusingPatch%older if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then @@ -2722,11 +2671,7 @@ subroutine terminate_patches(currentSite) count_cycles = 0 else count_cycles = count_cycles + 1 - write(*,*) 'iterate count cycles',count_cycles end if - if(associated(oldercPatch))then - write(*,*) 'currentPatch2',currentPatch%patchno,oldercPatch%patchno - endif if(count_cycles > max_cycles) then if(is_oldest.eq.itrue.and.is_youngest.eq.itrue.and.hlm_use_fixed_biogeog)then @@ -2757,23 +2702,12 @@ subroutine terminate_patches(currentSite) !n.b. could put filter in here for actual terminations to save time. fusingpatch => currentSite%oldest_patch - write(*,*) 'tp end list' - do while(associated(fusingpatch)) - write(*,*) 'tp end y-o patch list',fusingpatch%patchno,fusingpatch%nocomp_pft_label,fusingpatch%area - - if(associated(fusingpatch%younger))then - if(fusingpatch%patchno.eq.fusingpatch%younger%patchno)then - write(*,*) 'patch list error',fusingpatch%patchno,fusingpatch%younger%patchno - endif - endif - fusingpatch => fusingpatch%younger - enddo enddo ! current patch loop !check area is not exceeded call check_patch_area( currentSite ) - write(*,*) 'leaving terminate patches',currentSite%lat,currentSite%lon +! write(*,*) 'leaving terminate patches',currentSite%lat,currentSite%lon return end subroutine terminate_patches From 7dda68f86cd745f91ab017d166129084196e95b1 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 25 May 2020 08:05:45 -0600 Subject: [PATCH 023/578] changes to make one pft per patch --- main/EDInitMod.F90 | 32 ++++++++++++++++++++++++++++++-- 1 file changed, 30 insertions(+), 2 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 2a4af75290..9ef3e0327a 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -554,6 +554,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) integer :: iage ! index for leaf age loop integer :: el ! index for element loop integer :: element_id ! element index consistent with defs in PRTGeneric + integer :: use_pft_local(numpft) ! determine whether this PFT is used for this patch and site. real(r8) :: c_agw ! biomass above ground (non-leaf) [kgC] real(r8) :: c_bgw ! biomass below ground (non-fineroot) [kgC] real(r8) :: c_leaf ! biomass in leaves [kgC] @@ -576,9 +577,36 @@ subroutine init_cohorts( site_in, patch_in, bc_in) patch_in%tallest => null() patch_in%shortest => null() - + + ! Manage interactions of ixed biogeg (site level filter) and + ! nocomp (patch level filter) + ! Need to cover all potential biogeog x nocomp combinations + ! 1. biogeog = false. nocomp = false: all PFTs on (DEFAULT) + ! 2. biogeog = true. nocomp = false: site level filter + ! 3. biogeog = false. nocomp = true : patch level filter + ! 4. biogeog = true. nocomp = true : patch and site level filter + ! in principle this could be a patch level variable. + do pft = 1,numpft + ! Turn every PFT ON, unless we are in a special case. + use_pft_local(pft) = itrue ! Case 1 + if(hlm_use_fixed_biogeog.eq.itrue)then !filter geographically + use_pft_local(pft) = site_in%use_this_pft(pft) ! Case 2 + if(hlm_use_nocomp.eq.itrue.and.pft.ne.patch_in%nocomp_pft_label)then + ! Having set the biogeog filter as on or off, turn off all patches + ! whose identiy does not correspond to this PFT. + use_pft_local(pft) = ifalse ! Case 3 + endif + else + if(hlm_use_nocomp.eq.itrue.and.pft.ne.patch_in%nocomp_pft_label)then + ! This case has all PFTs on their own patch everywhere. + use_pft_local(pft) = ifalse ! Case 4 + endif + endif + + end do + do pft = 1,numpft - if(site_in%use_this_pft(pft).eq.itrue)then + if(use_pft_local(pft).eq.itrue)then if(EDPftvarcon_inst%initd(pft)>1.0E-7) then allocate(temp_cohort) ! temporary cohort From 5dcef9f01cf2cb8a5711a2ffd54faf96009e1d3a Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 26 May 2020 03:15:31 -0600 Subject: [PATCH 024/578] turning off patch dynamics allows nocomp to run --- main/EDMainMod.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 1b520e56c3..41bd085d85 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -1,4 +1,3 @@ - module EDMainMod ! =========================================================================== @@ -19,6 +18,7 @@ module EDMainMod use FatesInterfaceMod , only : hlm_reference_date use FatesInterfaceMod , only : hlm_use_ed_prescribed_phys use FatesInterfaceMod , only : hlm_use_ed_st3 + use FatesInterfaceMod , only : hlm_use_nocomp use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : hlm_masterproc use FatesInterfaceMod , only : numpft @@ -241,14 +241,14 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) !********************************************************************************* ! make new patches from disturbed land - if ( hlm_use_ed_st3.eq.ifalse ) then + if ( hlm_use_ed_st3.eq.ifalse.or.hlm_use_nocomp.eq.ifalse) then call spawn_patches(currentSite, bc_in) end if call TotalBalanceCheck(currentSite,3) ! fuse on the spawned patches. - if ( hlm_use_ed_st3.eq.ifalse ) then + if ( hlm_use_ed_st3.eq.ifalse.or.hlm_use_nocomp.eq.ifalse ) then call fuse_patches(currentSite, bc_in ) ! If using BC FATES hydraulics, update the rhizosphere geometry @@ -268,7 +268,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call TotalBalanceCheck(currentSite,4) ! kill patches that are too small - if ( hlm_use_ed_st3.eq.ifalse ) then + if ( hlm_use_ed_st3.eq.ifalse .or.hlm_use_nocomp.eq.ifalse) then call terminate_patches(currentSite) end if From 1e1f013b247dcc157be945bd07c192318db9e5e0 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 26 May 2020 03:16:18 -0600 Subject: [PATCH 025/578] fixing error in spawn_patches --- biogeochem/EDPatchDynamicsMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index d77791d218..fc9791ee8c 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -389,8 +389,6 @@ subroutine spawn_patches( currentSite, bc_in) type (ed_patch_type) , pointer :: new_patch type (ed_patch_type) , pointer :: new_patch_primary type (ed_patch_type) , pointer :: new_patch_secondary - type (ed_patch_type) , pointer :: new_patch_primary_pft(:) - type (ed_patch_type) , pointer :: new_patch_secondary_pft(:) type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type), pointer :: currentCohort type (ed_cohort_type), pointer :: nc @@ -398,6 +396,8 @@ subroutine spawn_patches( currentSite, bc_in) type (ed_cohort_type), pointer :: storebigcohort real(r8) :: site_areadis_primary ! total area disturbed (to primary forest) in m2 per site per day real(r8) :: site_areadis_secondary ! total area disturbed (to secondary forest) in m2 per site per day + real(r8) :: site_areadis_primary_pft(numpft) + real(r8) :: site_areadis_secondary_pft(numpft) real(r8) :: patch_site_areadis ! total area disturbed in m2 per patch per day real(r8) :: age ! notional age of this patch in years integer :: el ! element loop index From 630d571fa7a39c759418dca994281ad5434082cc Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 26 May 2020 04:45:38 -0600 Subject: [PATCH 026/578] initial go at converstion matrix. Hard wired, e dimensional --- main/EDInitMod.F90 | 40 +++++++++++++++++++++++++++++++++------- 1 file changed, 33 insertions(+), 7 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 9ef3e0327a..7d09c7c240 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -253,6 +253,9 @@ subroutine set_site_properties( nsites, sites,bc_in ) integer :: dleafon ! DOY for drought-decid leaf-on, initial guess integer :: ft ! PFT loop real(r8) :: sumarea ! area of PFTs in nocomp mode. + real(r8) :: hlm_to_fates_pft_map(12) !this should ultimately come from the HLM? + integer :: hlm_pft ! used in fixed biogeog mode + integer :: fates_pft ! used in fixed biogeog mode !---------------------------------------------------------------------- @@ -296,19 +299,42 @@ subroutine set_site_properties( nsites, sites,bc_in ) sites(s)%NF = 0.0_r8 sites(s)%frac_burnt = 0.0_r8 - ! PLACEHOLDER FOR PFT AREA DATA MOVED ACROSS INTERFACE - if(hlm_use_fixed_biogeog.eq.itrue)then - do ft = 1,numpft - sites(s)%area_pft(ft) = bc_in(s)%pft_areafrac(ft) - end do + + if(hlm_use_fixed_biogeog.eq.itrue)then + ! MAPPING OF FATES PFTs on to HLM_PFTs + ! in this first instance, we assume that there & + ! are fewer FATES PFTs than HLM PFTs + + ! PLACEHOLDER FOR NEW FATES PARAMETER. This will always have to be 12 digits long. + hlm_to_fates_pft_map(1) = 1 + hlm_to_fates_pft_map(2) = 1 + hlm_to_fates_pft_map(3) = 2 + hlm_to_fates_pft_map(4) = 2 + hlm_to_fates_pft_map(5) = 3 + hlm_to_fates_pft_map(6) = 3 + hlm_to_fates_pft_map(7) = 4 + hlm_to_fates_pft_map(8) = 4 + hlm_to_fates_pft_map(9) = 5 + hlm_to_fates_pft_map(10) = 5 + hlm_to_fates_pft_map(11) = 6 + hlm_to_fates_pft_map(12) = 6 + + ! assuming here there are 12 pfts on the surface dataset and 6 on fates pft file + ! add up the area associated with each FATES PFT + sites(s)%area_pft(1:numpft) = 0._r8 + do hlm_pft = 1,12 + fates_pft = hlm_to_fates_pft_map(hlm_pft) + sites(s)%area_pft(fates_pft) = sites(s)%area_pft(fates_pft) + bc_in(s)%pft_areafrac(hlm_pft) + end do !hlm_pft + ! re-normalize PFT area to ensure it sums to one. ! note that in areas of 'bare ground' (PFT 0 in CLM/ELM) ! the bare ground will no longer be proscribed and should emerge from FATES do ft = 1,numpft if(sites(s)%area_pft(ft).lt.0.01_r8)then - sites(s)%area_pft(ft)=0.0_r8 !remove tiny patches to prevent numerical errors. -! write(*,*) 'removing small pft patches',s,sites(s)%area_pft(1:12) + sites(s)%area_pft(ft)=0.0_r8 !remove tiny patches to prevent numerical errors in terminate patches + write(*,*) 'removing small pft patches',sites(s)%lon,sites(s)%lat,ft,sites(s)%area_pft(ft) endif end do From 1e4d30c0bf75efd6389b5236950b24f8dd3149df Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 26 May 2020 07:01:11 -0600 Subject: [PATCH 027/578] fixing patch dynamics bug in EDmain --- main/EDMainMod.F90 | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 41bd085d85..b8c0c6b8f2 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -130,7 +130,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! !LOCAL VARIABLES: type(ed_patch_type), pointer :: currentPatch integer :: el ! Loop counter for elements - + integer :: do_patch_dynamics ! for some modes, we turn off patch dynamics !----------------------------------------------------------------------- if ( hlm_masterproc==itrue ) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& @@ -240,15 +240,22 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! Patch dynamics sub-routines: fusion, new patch creation (spwaning), termination. !********************************************************************************* + do_patch_dynamics = itrue + if(hlm_use_ed_st3.eq.ifalse)then + do_patch_dynamics = ifalse + end if + if(hlm_use_nocomp.eq.itrue)then + do_patch_dynamics = ifalse + end if ! make new patches from disturbed land - if ( hlm_use_ed_st3.eq.ifalse.or.hlm_use_nocomp.eq.ifalse) then + if (do_patch_dynamics.eq.itrue ) then call spawn_patches(currentSite, bc_in) end if call TotalBalanceCheck(currentSite,3) ! fuse on the spawned patches. - if ( hlm_use_ed_st3.eq.ifalse.or.hlm_use_nocomp.eq.ifalse ) then + if ( do_patch_dynamics.eq.itrue ) then call fuse_patches(currentSite, bc_in ) ! If using BC FATES hydraulics, update the rhizosphere geometry @@ -268,7 +275,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call TotalBalanceCheck(currentSite,4) ! kill patches that are too small - if ( hlm_use_ed_st3.eq.ifalse .or.hlm_use_nocomp.eq.ifalse) then + if ( do_patch_dynamics.eq.itrue ) then call terminate_patches(currentSite) end if From 2ee7316d54ef0dc25a6b9cd3d8f3a85abdb90a43 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 27 May 2020 02:49:14 -0600 Subject: [PATCH 028/578] fixing erroneous error check --- biogeochem/EDPatchDynamicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index fc9791ee8c..7a8282eda1 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2674,7 +2674,7 @@ subroutine terminate_patches(currentSite) end if if(count_cycles > max_cycles) then - if(is_oldest.eq.itrue.and.is_youngest.eq.itrue.and.hlm_use_fixed_biogeog)then + if(is_oldest.eq.itrue.and.is_youngest.eq.itrue.and.hlm_use_nocomp)then write(fates_log(),*) 'this is the only patch of this PFT',currentPatch%area currentPatch => currentPatch%older count_cycles = 0 From aa620f91139ea757bae38395c27315148315564b Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 27 May 2020 02:55:51 -0600 Subject: [PATCH 029/578] 2D pft mapping array --- main/EDInitMod.F90 | 46 ++++++++++++++++++++++++++++++---------------- 1 file changed, 30 insertions(+), 16 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 7d09c7c240..cc736fac2b 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -253,7 +253,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) integer :: dleafon ! DOY for drought-decid leaf-on, initial guess integer :: ft ! PFT loop real(r8) :: sumarea ! area of PFTs in nocomp mode. - real(r8) :: hlm_to_fates_pft_map(12) !this should ultimately come from the HLM? + real(r8) :: hlm_to_fates_pft_map(12,numpft) !this should ultimately come from the HLM? integer :: hlm_pft ! used in fixed biogeog mode integer :: fates_pft ! used in fixed biogeog mode !---------------------------------------------------------------------- @@ -306,25 +306,31 @@ subroutine set_site_properties( nsites, sites,bc_in ) ! are fewer FATES PFTs than HLM PFTs ! PLACEHOLDER FOR NEW FATES PARAMETER. This will always have to be 12 digits long. - hlm_to_fates_pft_map(1) = 1 - hlm_to_fates_pft_map(2) = 1 - hlm_to_fates_pft_map(3) = 2 - hlm_to_fates_pft_map(4) = 2 - hlm_to_fates_pft_map(5) = 3 - hlm_to_fates_pft_map(6) = 3 - hlm_to_fates_pft_map(7) = 4 - hlm_to_fates_pft_map(8) = 4 - hlm_to_fates_pft_map(9) = 5 - hlm_to_fates_pft_map(10) = 5 - hlm_to_fates_pft_map(11) = 6 - hlm_to_fates_pft_map(12) = 6 + ! protocol is (hlm_pft,fates_pft) + hlm_to_fates_pft_map(1:12,1:numpft)=0._r8 + !this is the fraction that is associated with each fates pft of a given hlm area + !each HLM row neds to sum to one... + hlm_to_fates_pft_map(1,1) = 1 + hlm_to_fates_pft_map(2,1) = 1 + hlm_to_fates_pft_map(3,2) = 1 + hlm_to_fates_pft_map(4,2) = 1 + hlm_to_fates_pft_map(5,3) = 1 + hlm_to_fates_pft_map(6,3) = 1 + hlm_to_fates_pft_map(7,4) = 1 + hlm_to_fates_pft_map(8,4) = 1 + hlm_to_fates_pft_map(9,5) = 1 + hlm_to_fates_pft_map(10,5) = 1 + hlm_to_fates_pft_map(11,6) = 1 + hlm_to_fates_pft_map(12,6) = 1 ! assuming here there are 12 pfts on the surface dataset and 6 on fates pft file ! add up the area associated with each FATES PFT sites(s)%area_pft(1:numpft) = 0._r8 - do hlm_pft = 1,12 - fates_pft = hlm_to_fates_pft_map(hlm_pft) - sites(s)%area_pft(fates_pft) = sites(s)%area_pft(fates_pft) + bc_in(s)%pft_areafrac(hlm_pft) + do hlm_pft = 1,12 + do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts + sites(s)%area_pft(fates_pft) = sites(s)%area_pft(fates_pft) + & + hlm_to_fates_pft_map(hlm_pft,fates_pft) * bc_in(s)%pft_areafrac(hlm_pft) + end do end do !hlm_pft ! re-normalize PFT area to ensure it sums to one. @@ -639,6 +645,14 @@ subroutine init_cohorts( site_in, patch_in, bc_in) temp_cohort%pft = pft temp_cohort%n = EDPftvarcon_inst%initd(pft) * patch_in%area + if(hlm_use_nocomp.eq.itrue)then !in nocomp mode we only have one PFT per patch + ! as opposed to numpft's. So we should up the initial density + ! to compensate (otherwise runs are very hard to compare) + ! this multiplies it by the number of PFTs there would have been in + ! the single shared patch in competition mode. + temp_cohort%n = temp_cohort%n * sum(site_in%use_this_pft) + endif + temp_cohort%hite = EDPftvarcon_inst%hgt_min(pft) From a69ac89051a57b55f453d079a01550f3ea661d76 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 27 May 2020 07:53:43 -0600 Subject: [PATCH 030/578] implement new hlm_pft_map 2D parameter --- main/EDPftvarcon.F90 | 26 ++++++++++++++++++++++---- main/FatesParametersInterface.F90 | 1 + 2 files changed, 23 insertions(+), 4 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index b4654f2c13..b6c74ffb8d 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -293,7 +293,10 @@ module EDPftvarcon real(r8), allocatable :: hydr_fcap_node(:,:) ! fraction of (1-resid_node) that is capillary in source real(r8), allocatable :: hydr_pinot_node(:,:) ! osmotic potential at full turgor real(r8), allocatable :: hydr_kmax_node(:,:) ! maximum xylem conductivity per unit conducting xylem area - + + ! fixed biogeog mode parameter(s) + real(r8), allocatable :: hlm_pft_map(:,:) ! Mapping from HLM PFTs to FATES PFTs in fixed biogeog mode. + contains procedure, public :: Init => EDpftconInit procedure, public :: Register @@ -352,7 +355,7 @@ subroutine Register(this, fates_params) call this%Register_PFT_hydr_organs(fates_params) call this%Register_PFT_prt_organs(fates_params) call this%Register_PFT_leafage(fates_params) - + end subroutine Register !----------------------------------------------------------------------- @@ -379,6 +382,7 @@ subroutine Register_PFT(this, fates_params) use FatesParametersInterface, only : fates_parameters_type, param_string_length use FatesParametersInterface, only : dimension_name_pft, dimension_shape_1d + use FatesParametersInterface, only : dimension_name_hlm_pftno, dimension_shape_2d implicit none @@ -386,6 +390,7 @@ subroutine Register_PFT(this, fates_params) class(fates_parameters_type), intent(inout) :: fates_params character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_pft/) + character(len=param_string_length) :: pftmap_dim_names(2) integer, parameter :: dim_lower_bound(1) = (/ lower_bound_pft /) @@ -893,7 +898,13 @@ subroutine Register_PFT(this, fates_params) name = 'fates_prescribed_puptake' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + + pftmap_dim_names(1) = dimension_name_pft + pftmap_dim_names(2) = dimension_name_hlm_pftno + + name = 'fates_hlm_pft_map' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=pftmap_dim_names, lower_bounds=dim_lower_bound) + end subroutine Register_PFT !----------------------------------------------------------------------- @@ -1417,6 +1428,9 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%prescribed_puptake) + name = 'fates_hlm_pft_map' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hlm_pft_map) end subroutine Receive_PFT @@ -1670,6 +1684,9 @@ subroutine Register_PFT_leafage(this, fates_params) return end subroutine Register_PFT_leafage + + + ! ===================================================================================== subroutine Receive_PFT_leafage(this, fates_params) @@ -2055,7 +2072,6 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'hydr_pinot_node = ',EDPftvarcon_inst%hydr_pinot_node write(fates_log(),fmt0) 'hydr_kmax_node = ',EDPftvarcon_inst%hydr_kmax_node - write(fates_log(),fmt0) 'prt_nitr_stoich_p1 = ',EDPftvarcon_inst%prt_nitr_stoich_p1 write(fates_log(),fmt0) 'prt_nitr_stoich_p2 = ',EDPftvarcon_inst%prt_nitr_stoich_p2 write(fates_log(),fmt0) 'prt_phos_stoich_p1 = ',EDPftvarcon_inst%prt_phos_stoich_p1 @@ -2067,6 +2083,8 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'turnover_nitr_retrans = ',EDPftvarcon_inst%turnover_nitr_retrans write(fates_log(),fmt0) 'turnover_phos_retrans = ',EDPftvarcon_inst%turnover_phos_retrans + write(fates_log(),fmt0) 'hlm_pft_map = ', EDPftvarcon_inst%hlm_pft_map + write(fates_log(),*) '-------------------------------------------------' end if diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 index ebaad3fa7c..f69d4ef5bf 100644 --- a/main/FatesParametersInterface.F90 +++ b/main/FatesParametersInterface.F90 @@ -35,6 +35,7 @@ module FatesParametersInterface character(len=*), parameter, public :: dimension_name_history_age_bins = 'fates_history_age_bins' character(len=*), parameter, public :: dimension_name_history_height_bins = 'fates_history_height_bins' character(len=*), parameter, public :: dimension_name_history_coage_bins = 'fates_history_coage_bins' + character(len=*), parameter, public :: dimension_name_hlm_pftno = 'fates_hlm_pftno' ! Dimensions in the host namespace: character(len=*), parameter, public :: dimension_name_host_allpfts = 'allpfts' From 6927dec561b6d9b639854155ca7c6e5c98131800 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 27 May 2020 08:34:25 -0600 Subject: [PATCH 031/578] adding usage of hlm_pft_map --- main/EDInitMod.F90 | 25 +------------------------ 1 file changed, 1 insertion(+), 24 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index cc736fac2b..e48127d2fb 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -253,7 +253,6 @@ subroutine set_site_properties( nsites, sites,bc_in ) integer :: dleafon ! DOY for drought-decid leaf-on, initial guess integer :: ft ! PFT loop real(r8) :: sumarea ! area of PFTs in nocomp mode. - real(r8) :: hlm_to_fates_pft_map(12,numpft) !this should ultimately come from the HLM? integer :: hlm_pft ! used in fixed biogeog mode integer :: fates_pft ! used in fixed biogeog mode !---------------------------------------------------------------------- @@ -302,34 +301,12 @@ subroutine set_site_properties( nsites, sites,bc_in ) if(hlm_use_fixed_biogeog.eq.itrue)then ! MAPPING OF FATES PFTs on to HLM_PFTs - ! in this first instance, we assume that there & - ! are fewer FATES PFTs than HLM PFTs - - ! PLACEHOLDER FOR NEW FATES PARAMETER. This will always have to be 12 digits long. - ! protocol is (hlm_pft,fates_pft) - hlm_to_fates_pft_map(1:12,1:numpft)=0._r8 - !this is the fraction that is associated with each fates pft of a given hlm area - !each HLM row neds to sum to one... - hlm_to_fates_pft_map(1,1) = 1 - hlm_to_fates_pft_map(2,1) = 1 - hlm_to_fates_pft_map(3,2) = 1 - hlm_to_fates_pft_map(4,2) = 1 - hlm_to_fates_pft_map(5,3) = 1 - hlm_to_fates_pft_map(6,3) = 1 - hlm_to_fates_pft_map(7,4) = 1 - hlm_to_fates_pft_map(8,4) = 1 - hlm_to_fates_pft_map(9,5) = 1 - hlm_to_fates_pft_map(10,5) = 1 - hlm_to_fates_pft_map(11,6) = 1 - hlm_to_fates_pft_map(12,6) = 1 - - ! assuming here there are 12 pfts on the surface dataset and 6 on fates pft file ! add up the area associated with each FATES PFT sites(s)%area_pft(1:numpft) = 0._r8 do hlm_pft = 1,12 do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts sites(s)%area_pft(fates_pft) = sites(s)%area_pft(fates_pft) + & - hlm_to_fates_pft_map(hlm_pft,fates_pft) * bc_in(s)%pft_areafrac(hlm_pft) + EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) end do end do !hlm_pft From f0170fd2834a1db26d83df0b9d0e3b0c9e3adcb5 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 27 May 2020 09:05:14 -0600 Subject: [PATCH 032/578] added default values for hlm_pft_map to the parameter file --- parameter_files/fates_params_default.cdl | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 067ca4155f..be4d4aed7c 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -12,6 +12,8 @@ dimensions: fates_prt_organs = 6 ; fates_string_length = 60 ; fates_variants = 2 ; + fates_hlm_pftno = 12 ; + variables: double fates_history_ageclass_bin_edges(fates_history_age_bins) ; fates_history_ageclass_bin_edges:units = "yr" ; @@ -495,6 +497,9 @@ variables: double fates_z0mr(fates_pft) ; fates_z0mr:units = "unitless" ; fates_z0mr:long_name = "Ratio of momentum roughness length to canopy top height" ; + double fates_hlm_pft_map(fates_hlm_pftno, fates_pft) ; + fates_hlm_pft_map:units = "area fraction" ; + fates_hlm_pft_map:long_name = "In fixed biogeog mode, fraction of HLM area associated with each FATES PFT" ; double fates_fire_FBD(fates_litterclass) ; fates_fire_FBD:units = "NA" ; fates_fire_FBD:long_name = "spitfire parameter related to fuel bulk density, see SFMain.F90" ; @@ -1206,6 +1211,22 @@ data: fates_z0mr = 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055 ; + fates_hlm_pft_map = + 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1; + + + fates_fire_FBD = 15.4, 16.8, 19.6, 999, 4, 4 ; fates_fire_low_moisture_Coeff = 1.12, 1.09, 0.98, 0.8, 1.15, 1.15 ; From ea3c635d00e7b3863b69d75ffb555c7617eb8f93 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 3 Jun 2020 07:44:03 -0600 Subject: [PATCH 033/578] modify EDINIT to allow HLM_pftno from parameter file to dictate initialization pft number and remove hardwiring --- main/EDInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index e48127d2fb..41606efd0c 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -303,7 +303,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) ! MAPPING OF FATES PFTs on to HLM_PFTs ! add up the area associated with each FATES PFT sites(s)%area_pft(1:numpft) = 0._r8 - do hlm_pft = 1,12 + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts sites(s)%area_pft(fates_pft) = sites(s)%area_pft(fates_pft) + & EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) From f7e876dd06c153d3254bbd0a33cc17a0983af02c Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 10 Jul 2020 03:37:30 -0600 Subject: [PATCH 034/578] reverting spawn patches back to master and therefore removing all the changes that enable multiple patches but cause memory leak --- biogeochem/EDPatchDynamicsMod.F90 | 148 +++++++++--------------------- 1 file changed, 45 insertions(+), 103 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 7a8282eda1..4b4edd5344 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -358,8 +358,8 @@ subroutine disturbance_rates( site_in, bc_in) enddo !patch loop end subroutine disturbance_rates - - ! ============================================================================ + + ! ============================================================================ subroutine spawn_patches( currentSite, bc_in) ! ! !DESCRIPTION: @@ -396,8 +396,6 @@ subroutine spawn_patches( currentSite, bc_in) type (ed_cohort_type), pointer :: storebigcohort real(r8) :: site_areadis_primary ! total area disturbed (to primary forest) in m2 per site per day real(r8) :: site_areadis_secondary ! total area disturbed (to secondary forest) in m2 per site per day - real(r8) :: site_areadis_primary_pft(numpft) - real(r8) :: site_areadis_secondary_pft(numpft) real(r8) :: patch_site_areadis ! total area disturbed in m2 per patch per day real(r8) :: age ! notional age of this patch in years integer :: el ! element loop index @@ -413,12 +411,6 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: leaf_burn_frac ! fraction of leaves burned in fire ! for both woody and grass species real(r8) :: leaf_m ! leaf mass during partial burn calculations - integer :: rec_type ! records type of disturbance while in patch loop - integer :: nocomp_pft ! where nocomp mode is on, PFT label - integer :: numiter - real(r8) :: areadis_primary - real(r8) :: areadis_secondary - !--------------------------------------------------------------------- storesmallcohort => null() ! storage of the smallest cohort for insertion routine @@ -429,8 +421,6 @@ subroutine spawn_patches( currentSite, bc_in) site_areadis_primary = 0.0_r8 site_areadis_secondary = 0.0_r8 - site_areadis_primary_pft(1:numpft) = 0.0_r8 - site_areadis_secondary_pft(1:numpft) = 0.0_r8 do while(associated(currentPatch)) @@ -455,59 +445,30 @@ subroutine spawn_patches( currentSite, bc_in) ! donor patch is primary forest and the dominant disturbance type is not logging if ( currentPatch%anthro_disturbance_label .eq. primaryforest .and. & (currentPatch%disturbance_mode .ne. dtype_ilog) ) then - site_areadis_primary = site_areadis_primary + currentPatch%area * currentPatch%disturbance_rate - rec_type = primaryforest + + site_areadis_primary = site_areadis_primary + currentPatch%area * currentPatch%disturbance_rate else - site_areadis_secondary = site_areadis_secondary + currentPatch%area * currentPatch%disturbance_rate - rec_type = secondaryforest + site_areadis_secondary = site_areadis_secondary + currentPatch%area * currentPatch%disturbance_rate endif + + end if - ! accumulate PFT specific disturbance rates in nocomp mode - if(hlm_use_nocomp.eq.itrue)then - if(rec_type.eq.primaryforest)then - nocomp_pft = currentPatch%nocomp_pft_label - site_areadis_primary_pft(nocomp_pft) = site_areadis_primary_pft(nocomp_pft) & - + currentPatch%area * currentPatch%disturbance_rate - else - site_areadis_secondary_pft(nocomp_pft) = site_areadis_secondary_pft(nocomp_pft) & - + currentPatch%area * currentPatch%disturbance_rate - end if !rectype - end if !nocomp - end if !area currentPatch => currentPatch%older enddo ! end loop over patches. sum area disturbed for all patches. - ! It is possible that no disturbance area was generated + ! It is possible that no disturbance area was generated if ( (site_areadis_primary + site_areadis_secondary) > nearzero) then - - ! Do the entire patch creation loop around a PFT loop. - numiter = 1 - if(hlm_use_nocomp.eq.itrue)then - numiter = numpft - endif - - do nocomp_pft = 1,numiter + age = 0.0_r8 ! create two empty patches, to absorb newly disturbed primary and secondary forest area ! first create patch to receive primary forest area - if(hlm_use_nocomp.eq.ifalse)then - areadis_primary = site_areadis_primary - areadis_secondary = site_areadis_secondary - else - areadis_primary = site_areadis_primary_pft(nocomp_pft) - areadis_secondary = site_areadis_secondary_pft(nocomp_pft) - endif - if ( site_areadis_primary .gt. nearzero ) then allocate(new_patch_primary) - if(hlm_use_nocomp.eq.ifalse)then + call create_patch(currentSite, new_patch_primary, age, & - areadis_primary, primaryforest,1) - else - call create_patch(currentSite, new_patch_primary, age, & - areadis_primary, primaryforest,nocomp_pft) - endif + site_areadis_primary, primaryforest) + ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches ! and transfering in mass @@ -521,19 +482,16 @@ subroutine spawn_patches( currentSite, bc_in) end do new_patch_primary%tallest => null() new_patch_primary%shortest => null() - end if !primary + + endif ! next create patch to receive secondary forest area if ( site_areadis_secondary .gt. nearzero) then allocate(new_patch_secondary) - if(hlm_use_nocomp.eq.ifalse)then - call create_patch(currentSite, new_patch_secondary, age, & - areadis_secondary, secondaryforest,1) - else call create_patch(currentSite, new_patch_secondary, age, & - areadis_secondary, secondaryforest,nocomp_pft) - endif + site_areadis_secondary, secondaryforest) + ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches ! and transfering in mass @@ -547,7 +505,8 @@ subroutine spawn_patches( currentSite, bc_in) end do new_patch_secondary%tallest => null() new_patch_secondary%shortest => null() - endif !secondary + + endif ! loop round all the patches that contribute surviving indivduals and litter ! pools to the new patch. We only loop the pre-existing patches, so @@ -558,16 +517,9 @@ subroutine spawn_patches( currentSite, bc_in) do while(associated(currentPatch)) ! This is the amount of patch area that is disturbed, and donated by the donor - if(hlm_use_nocomp.eq.ifalse)then patch_site_areadis = currentPatch%area * currentPatch%disturbance_rate - else - if(currentPatch%nocomp_pft_label.eq.nocomp_pft)then - patch_site_areadis = currentPatch%area * currentPatch%disturbance_rate - else - patch_site_areadis = 0.0_r8 - endif - endif + if ( patch_site_areadis > nearzero ) then ! figure out whether the receiver patch for disturbance from this patch @@ -577,10 +529,8 @@ subroutine spawn_patches( currentSite, bc_in) if (currentPatch%anthro_disturbance_label .eq. primaryforest .and. & (currentPatch%disturbance_mode .ne. dtype_ilog)) then new_patch => new_patch_primary - rec_type = primaryforest else new_patch => new_patch_secondary - rec_type = secondaryforest endif if(.not.associated(new_patch))then @@ -1043,6 +993,11 @@ subroutine spawn_patches( currentSite, bc_in) end if ! if ( new_patch%area > nearzero ) then + !zero disturbance rate trackers + currentPatch%disturbance_rate = 0._r8 + currentPatch%disturbance_rates = 0._r8 + currentPatch%fract_ldist_not_harvested = 0._r8 + currentPatch => currentPatch%younger enddo ! currentPatch patch loop. @@ -1051,61 +1006,48 @@ subroutine spawn_patches( currentSite, bc_in) !** INSERT NEW PATCH(ES) INTO LINKED LIST !**********`***************/ - ! currentPatch is the youngest of the pre-existing patches. - !newpatch_primary_pft and newpatch_secondary_pft need to be added into the mix - - - if ( areadis_primary .gt. nearzero) then + if ( site_areadis_primary .gt. nearzero) then currentPatch => currentSite%youngest_patch new_patch_primary%older => currentPatch new_patch_primary%younger => null() currentPatch%younger => new_patch_primary currentSite%youngest_patch => new_patch_primary - endif + endif - if ( areadis_secondary .gt. nearzero) then + if ( site_areadis_secondary .gt. nearzero) then currentPatch => currentSite%youngest_patch new_patch_secondary%older => currentPatch new_patch_secondary%younger=> null() currentPatch%younger => new_patch_secondary currentSite%youngest_patch => new_patch_secondary - endif - + endif + + ! sort out the cohorts, since some of them may be so small as to need removing. ! the first call to terminate cohorts removes sparse number densities, ! the second call removes for all other reasons (sparse culling must happen ! before fusion) - if ( areadis_primary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_primary, 1,17) - call fuse_cohorts(currentSite,new_patch_primary, bc_in) - call terminate_cohorts(currentSite, new_patch_primary, 2,17) - call sort_cohorts(new_patch_primary) - endif - - if ( areadis_secondary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_secondary, 1,18) - call fuse_cohorts(currentSite,new_patch_secondary, bc_in) - call terminate_cohorts(currentSite, new_patch_secondary, 2,18) - call sort_cohorts(new_patch_secondary) - endif - - end do ! PFT loop for nocomp + if ( site_areadis_primary .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_primary, 1,17) + call fuse_cohorts(currentSite,new_patch_primary, bc_in) + call terminate_cohorts(currentSite, new_patch_primary, 2,17) + call sort_cohorts(new_patch_primary) + endif + + if ( site_areadis_secondary .gt. nearzero) then + call terminate_cohorts(currentSite, new_patch_secondary, 1,18) + call fuse_cohorts(currentSite,new_patch_secondary, bc_in) + call terminate_cohorts(currentSite, new_patch_secondary, 2,18) + call sort_cohorts(new_patch_secondary) + endif + endif !end new_patch area - currentpatch => currentSite%youngest_patch - do while(associated(currentpatch)) - !zero disturbance rate trackers - currentPatch%disturbance_rate = 0._r8 - currentPatch%disturbance_rates = 0._r8 - currentPatch%fract_ldist_not_harvested = 0._r8 - currentpatch => currentpatch%older - end do - + call check_patch_area(currentSite) call set_patchno(currentSite) -! write(*,*) 'end spawn patches',currentsite%lat, currentSite%lon return end subroutine spawn_patches From c4ae2986053a650078da61ddbdc1b2c7224d47a3 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Sep 2020 11:36:40 +0200 Subject: [PATCH 035/578] comment in EDInit --- main/EDInitMod.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 2fd076c76f..c4b7d3915f 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -305,6 +305,8 @@ subroutine set_site_properties( nsites, sites,bc_in ) if(hlm_use_fixed_biogeog.eq.itrue)then ! MAPPING OF FATES PFTs on to HLM_PFTs ! add up the area associated with each FATES PFT + ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) + ! hlm_pft_map is the area of that land in each FATES PFT (from param file) sites(s)%area_pft(1:numpft) = 0._r8 do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts From cceff87bae46db314ffe085177b03d9676aa3de3 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Sep 2020 11:45:32 +0200 Subject: [PATCH 036/578] fixed apparent merge conflict in patch dynamics --- biogeochem/EDPatchDynamicsMod.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index f7e9eb562f..3e7e49ef37 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2402,9 +2402,6 @@ subroutine fuse_patches( csite, bc_in ) enddo !do while nopatches>maxPatchesPerSite end do ! i_disttype loop -||||||| merged common ancestors - -======= currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) @@ -2419,7 +2416,6 @@ subroutine fuse_patches( csite, bc_in ) currentSite%primary_land_patchfusion_error = primary_land_fraction_afterfusion - primary_land_fraction_beforefusion ->>>>>>> charlie_repo/fates_harvest_offmaster end subroutine fuse_patches ! ============================================================================ From e0f348186766cf0b2579c8a63544290c843821e7 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Sep 2020 11:58:42 +0200 Subject: [PATCH 037/578] modifications to write statements in EDInit --- main/EDInitMod.F90 | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index c4b7d3915f..37a4e5787c 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -511,7 +511,7 @@ subroutine init_patches( nsites, sites, bc_in) newp => sites(s)%oldest_patch do while (associated(newp)) tota=tota+newp%area - write(*,*) 'test links',s,newp%nocomp_pft_label,tota + if ( debug ) write(fates_log(),*) 'test links',s,newp%nocomp_pft_label,tota newp=>newp%younger end do if(abs(tota-area).gt.nearzero)then @@ -527,10 +527,9 @@ subroutine init_patches( nsites, sites, bc_in) end do call set_patchno(sites(s)) -! deallocate(recall_older_patch) +! deallocate(recall_older_patch) !leaving this as a potential fix for memory leak in multipatch nocomp mode enddo !s - write(*,*)'end init' end if ! This sets the rhizosphere shells based on the plant initialization From 312766e94d36dbe35411a10f1ebc13100c8d8a6f Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Sep 2020 15:09:02 +0200 Subject: [PATCH 038/578] a few more comments and a small fix to merge conflicts --- biogeochem/EDPatchDynamicsMod.F90 | 4 ++-- main/EDMainMod.F90 | 3 +++ main/EDPftvarcon.F90 | 5 +++-- 3 files changed, 8 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 3e7e49ef37..8f0e0a3027 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2607,7 +2607,7 @@ subroutine terminate_patches(currentSite) type(ed_patch_type), pointer :: oldercPatch type(ed_patch_type), pointer :: youngerPatch type(ed_patch_type), pointer :: fusingPatch - integer, parameter :: max_cycles = 1<<<<0 ! After 10 loops through + integer, parameter :: max_cycles = 10 ! After 10 loops through ! You should had fused integer :: count_cycles integer :: is_youngest @@ -2683,7 +2683,7 @@ subroutine terminate_patches(currentSite) currentPatch%area youngerPatch => currentPatch%younger -<<<<<<< HEAD + if (currentPatch%anthro_disturbance_label .eq. youngerPatch% anthro_disturbance_label) then call fuse_2_patches(currentSite, youngerPatch, currentPatch) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index ed7d3256d3..20d6c70d7e 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -247,6 +247,9 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) do_patch_dynamics = ifalse end if if(hlm_use_nocomp.eq.itrue)then + ! n.b. the this is currently set to false to get around a memory leak that occurs + ! when we have multiple patches for each PFT. + ! when this is fixed, we will need another option for 'one patch per PFT' vs 'multiple patches per PFT' do_patch_dynamics = ifalse end if ! make new patches from disturbed land diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 77323bd172..bed41f0eab 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -918,10 +918,11 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) + ! adding the hlm_pft_map variable with two dimensions - FATES PFTno and HLM PFTno pftmap_dim_names(1) = dimension_name_pft - pftmap_dim_names(2) = dimension_name_hlm_pftno + pftmap_dim_names(2) = dimension_name_hlm_pftno xs - name = 'fates_hlm_pft_map' + name = 'fates_hlm_pft_map' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=pftmap_dim_names, lower_bounds=dim_lower_bound) end subroutine Register_PFT From 0a5a866606faad6a0964beac60366c0bd64109a4 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Sep 2020 15:39:03 +0200 Subject: [PATCH 039/578] added patch ID's to the new create_patch calls from landuse mods --- biogeochem/EDPatchDynamicsMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 8f0e0a3027..d0fe122e50 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -562,7 +562,7 @@ subroutine spawn_patches( currentSite, bc_in) allocate(new_patch_primary) call create_patch(currentSite, new_patch_primary, age, & - site_areadis_primary, primaryforest) + site_areadis_primary, primaryforest,fates_unset_int) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -585,7 +585,7 @@ subroutine spawn_patches( currentSite, bc_in) if ( site_areadis_secondary .gt. nearzero) then allocate(new_patch_secondary) call create_patch(currentSite, new_patch_secondary, age, & - site_areadis_secondary, secondaryforest) + site_areadis_secondary, secondaryforest,fates_unset_int) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches From 0d720013c79a730af821edecd61c0ec55ca223d3 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Sep 2020 15:51:34 +0200 Subject: [PATCH 040/578] added comment to restart interface --- main/FatesRestartInterfaceMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index c8825acca5..d9e6c9b1b0 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -2056,6 +2056,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! create patch allocate(newp) nocomp_pft = fates_unset_int + ! the nocomp_pft label is set after patch creation has occured in 'get_restart_vectors' ! make new patch call create_patch(sites(s), newp, fates_unset_r8, fates_unset_r8, primaryforest, nocomp_pft ) @@ -2421,7 +2422,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%prt%variables(i_var)%net_alloc(i_pos) = & this%rvars(ir_prt_var)%r81d(io_idx_co) - ir_prt_var = ir_prt_var + 1 + ir_prt_var = ir_prt_var + 1 ccohort%prt%variables(i_var)%burned(i_pos) = & this%rvars(ir_prt_var)%r81d(io_idx_co) end do From 91ee991223d61d651e23759442099f732c5ddc12 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Sep 2020 16:02:34 +0200 Subject: [PATCH 041/578] added switch names to FatesInterfaceTypesMod.F90 --- main/FatesInterfaceTypesMod.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 547e095fa7..eadd3704f8 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -164,6 +164,12 @@ module FatesInterfaceTypesMod 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 competition mode + ! 1 = TRUE, 0 = FALSE + + integer, public :: hlm_use_sp ! Flag to use FATES satellite phenology (LAI) mode + ! 1 = TRUE, 0 = FALSE + ! ------------------------------------------------------------------------------------- ! Parameters that are dictated by FATES and known to be required knowledge ! needed by the HLMs From f146bc16fbdcd6f6fa83f5a976d671093bb27928 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Sep 2020 16:07:05 +0200 Subject: [PATCH 042/578] assert that patch dynamics are off when SP mode is on --- main/EDMainMod.F90 | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 20d6c70d7e..4f53ad10fc 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -246,12 +246,19 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) if(hlm_use_ed_st3.eq.ifalse)then do_patch_dynamics = ifalse end if - if(hlm_use_nocomp.eq.itrue)then + + if(hlm_use_nocomp.eq.itrue)then ! n.b. the this is currently set to false to get around a memory leak that occurs ! when we have multiple patches for each PFT. ! when this is fixed, we will need another option for 'one patch per PFT' vs 'multiple patches per PFT' do_patch_dynamics = ifalse - end if + end if + + if(hlm_use_sp.eq.itrue)then + ! if we want to assert LAI + do_patch_dynamics = ifalse + end if + ! make new patches from disturbed land if (do_patch_dynamics.eq.itrue ) then call spawn_patches(currentSite, bc_in) From 8d099f3c68391ec0376e365d392d092c13eb4439 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 12:14:14 +0200 Subject: [PATCH 043/578] allocate SP input variables in FatesInterfaceMod --- main/FatesInterfaceMod.F90 | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index b43992b94f..c95f87c001 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -376,6 +376,12 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) allocate(bc_in%pft_areafrac(maxpft)) + ! Variables for SP mode. + if(hlm_use_sp.eq.itrue) then + allocate(bc_in%sp_tlai(maxPatchesPerSite)) + allocate(bc_in%sp_tsai(maxPatchesPerSite)) + allocate(bc_in%sp_htop(maxPatchesPerSite)) + end if return end subroutine allocate_bcin @@ -1015,7 +1021,8 @@ 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 ! future reduced complexity mode + hlm_use_nocomp = unset_int ! future reduced complexity mode + hlm_use_sp = unset_int hlm_use_inventory_init = unset_int hlm_inventory_ctrl_file = 'unset' From 365561f1ae38beda58e7c8b53c5ea37a15d81cd8 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 12:24:50 +0200 Subject: [PATCH 044/578] defined SP input variables in FatesInterfaceTypesMod --- main/FatesInterfaceTypesMod.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index eadd3704f8..65689ce73c 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -478,6 +478,12 @@ module FatesInterfaceTypesMod ! Fixed biogeography mode real(r8), allocatable :: pft_areafrac(:) ! Fractional area of the FATES column occupied by each PFT + ! Satellite Phenology (SP) input variables. (where each patch only has one PFT) + ! --------------------------------------------------------------------------------- + real(r8),allocatable :: sp_tlai(:) ! Interpolated daily total LAI (leaf area index) input from HLM per patch/pft + real(r8),allocatable :: sp_tsai(:) ! Interpolated sailt total SAI (stem area index) input from HLM per patch/pft + real(r8),allocatable :: sp_htop(:) ! Interpolated daily canopy vegetation height input from HLM per patch/pft + end type bc_in_type From b128762ba8956f154ace8af4d6584a74da1ae0d6 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 13:50:27 +0200 Subject: [PATCH 045/578] changed nocmp and SP transfer from HLM to active in FatesInterfaceMod.F90 --- main/FatesInterfaceMod.F90 | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index c95f87c001..15ac63512c 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1271,12 +1271,20 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) 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_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_sp.eq.unset_int) then + if(fates_global_verbose()) then + write(fates_log(), *) 'switch for SP 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 @@ -1394,11 +1402,11 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) 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_nocomp') + hlm_use_nocomp = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_use_nocomp= ',ival,' to FATES' + end if case('use_planthydro') From 94b7aff881639ea67a1a6584901f327f79adf38c Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 14:23:47 +0200 Subject: [PATCH 046/578] added check so that nocomp needs to be on for SP to work in FatesInterfaceMod.F90 --- main/FatesInterfaceMod.F90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 15ac63512c..aed355bf53 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1260,8 +1260,6 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) end if call endrun(msg=errMsg(sourcefile, __LINE__)) end if - - if(hlm_use_fixed_biogeog.eq.unset_int) then if(fates_global_verbose()) then @@ -1285,7 +1283,6 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(hlm_use_cohort_age_tracking .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'switch for cohort_age_tracking unset: hlm_use_cohort_age_tracking, exiting' @@ -1293,6 +1290,10 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if(hlm_use_sp.eq.itrue.and.hlm_use_nocomp.eq.ifalse)then + write(fates_log(), *) 'SP cannot be on if nocomp mode is off. Exiting. ' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if if (fates_global_verbose()) then write(fates_log(), *) 'Checked. All control parameters sent to FATES.' From 87cd4920819285d1c65f0c6d20156a846443337e Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 14:32:58 +0200 Subject: [PATCH 047/578] changed dimensions of SP input variables to maxpft --- main/FatesInterfaceMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index aed355bf53..ebd8a5392e 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -378,9 +378,9 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) ! Variables for SP mode. if(hlm_use_sp.eq.itrue) then - allocate(bc_in%sp_tlai(maxPatchesPerSite)) - allocate(bc_in%sp_tsai(maxPatchesPerSite)) - allocate(bc_in%sp_htop(maxPatchesPerSite)) + allocate(bc_in%hlm_sp_tlai(maxpft)) + allocate(bc_in%hlm_sp_tsai(maxpft)) + allocate(bc_in%hlm_sp_htop(maxpft)) end if return end subroutine allocate_bcin From aeec14292eb8dc6e5aab1b4bb8b0ea3b56c53448 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 14:56:01 +0200 Subject: [PATCH 048/578] fixed a bunch of annoying spacing in EDInit --- main/EDInitMod.F90 | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 37a4e5787c..17261e61ce 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -326,18 +326,18 @@ subroutine set_site_properties( nsites, sites,bc_in ) endif end do - sumarea = sum(sites(s)%area_pft(1:numpft)) + sumarea = sum(sites(s)%area_pft(1:numpft)) do ft = 1,numpft if(sumarea.gt.0._r8)then - sites(s)%area_pft(ft) = sites(s)%area_pft(ft)/sumarea + sites(s)%area_pft(ft) = sites(s)%area_pft(ft)/sumarea else - sites(s)%area_pft(ft)= 1.0_r8/numpft - write(*,*) 'setting totally bare patch to all pfts.',s,sumarea,sites(s)%area_pft(ft) - end if - end do !ft - end if + sites(s)%area_pft(ft)= 1.0_r8/numpft + write(*,*) 'setting totally bare patch to all pfts.',s,sumarea,sites(s)%area_pft(ft) + end if + end do !ft + end if !fixed biogeog - do ft = 1,numpft + do ft = 1,numpft sites(s)%use_this_pft(ft) = itrue if(hlm_use_fixed_biogeog.eq.itrue)then if(sites(s)%area_pft(ft).gt.0.0_r8)then @@ -346,11 +346,9 @@ subroutine set_site_properties( nsites, sites,bc_in ) sites(s)%use_this_pft(ft) = ifalse end if !area end if !SBG - end do !ft - - end do - - end if + end do !ft + end do !site loop + end if !restart return end subroutine set_site_properties From 4d46a8b4eb8d9da1e89731578f32f50e23b2c15b Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 15:03:48 +0200 Subject: [PATCH 049/578] allocated FATES site SP input variables with PFT arrays --- main/EDInitMod.F90 | 5 +++++ main/EDTypesMod.F90 | 5 +++++ 2 files changed, 10 insertions(+) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 17261e61ce..a672b56f22 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -132,6 +132,11 @@ subroutine init_site_vars( site_in, bc_in ) allocate(site_in%area_pft(1:numpft)) allocate(site_in%use_this_pft(1:numpft)) + ! SP mode + allocate(site_in%sp_tlai(1:numpft)) + allocate(site_in%sp_tsai(1:numpft)) + allocate(site_in%sp_htop(1:numpft)) + do el=1,num_elements allocate(site_in%flux_diags(el)%leaf_litter_input(1:numpft)) allocate(site_in%flux_diags(el)%root_litter_input(1:numpft)) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 18c45cbafb..4e1121a139 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -662,6 +662,11 @@ module EDTypesMod real(r8), allocatable :: area_PFT(:) ! Area allocated to individual PFTs integer, allocatable :: use_this_pft(:) ! Is area_PFT > 0 ? (1=yes, 0=no) + ! SP mode target PFT level variables + real(r8), allocatable :: sp_tlai(:) ! target TLAI per FATES pft + real(r8), allocatable :: sp_tsai(:) ! target TSAI per FATES pft + real(r8), allocatable :: sp_htop(:) ! target HTOP per FATES pft + ! Mass Balance (allocation for each element) type(site_massbal_type), pointer :: mass_balance(:) From e38c7266b175e1c8f30378a26b2ca6907a6e8601 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 15:14:22 +0200 Subject: [PATCH 050/578] turning off cohort and patch dynamics in SP mode --- main/EDMainMod.F90 | 25 +++++++++++++++++-------- 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 4f53ad10fc..e4952c3bfc 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -133,6 +133,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) type(ed_patch_type), pointer :: currentPatch integer :: el ! Loop counter for elements integer :: do_patch_dynamics ! for some modes, we turn off patch dynamics + !----------------------------------------------------------------------- if ( hlm_masterproc==itrue ) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& @@ -170,12 +171,12 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! We do not allow phenology while in ST3 mode either, it is hypothetically ! possible to allow this, but we have not plugged in the litter fluxes ! of flushing or turning over leaves for non-dynamics runs - if (hlm_use_ed_st3.eq.ifalse) then + if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.false) then call phenology(currentSite, bc_in ) end if - if (hlm_use_ed_st3.eq.ifalse) then ! Bypass if ST3 + if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.false) then ! Bypass if ST3 call fire_model(currentSite, bc_in) ! Calculate disturbance and mortality based on previous timestep vegetation. @@ -183,7 +184,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call disturbance_rates(currentSite, bc_in) end if - if (hlm_use_ed_st3.eq.ifalse) then + if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.false) then ! Integrate state variables from annual rates to daily timestep call ed_integrate_state_variables(currentSite, bc_in ) else @@ -201,7 +202,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! Reproduction, Recruitment and Cohort Dynamics : controls cohort organization !****************************************************************************** - if(hlm_use_ed_st3.eq.ifalse) then + if(hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.false) then currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) @@ -215,7 +216,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call TotalBalanceCheck(currentSite,1) - if( hlm_use_ed_st3.eq.ifalse ) then + if( hlm_use_ed_st3.eq.ifalse .and.hlm_use_sp.eq.false ) then currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) @@ -253,6 +254,10 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! when this is fixed, we will need another option for 'one patch per PFT' vs 'multiple patches per PFT' do_patch_dynamics = ifalse end if + + if(hlm_use_sp.eq.itrue) ! cover for potential changes in nocomp logic above. + do_patch_dynamics = ifalse + end if if(hlm_use_sp.eq.itrue)then ! if we want to assert LAI @@ -280,15 +285,19 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) end if end if - call TotalBalanceCheck(currentSite,4) + ! SP has changes in leaf carbon but we don't expect them to be in balance. + if(hlm_use_sp.eq.ifalse)then + call TotalBalanceCheck(currentSite,4) + end if ! kill patches that are too small if ( do_patch_dynamics.eq.itrue ) then call terminate_patches(currentSite) end if - - call TotalBalanceCheck(currentSite,5) + if(hlm_use_sp.eq.ifalse)then + call TotalBalanceCheck(currentSite,5) + endif end subroutine ed_ecosystem_dynamics !-------------------------------------------------------------------------------! From 3118ea3b3f2d3a9a5832b2deb62d03ea17aebbfe Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 15:30:12 +0200 Subject: [PATCH 051/578] added call to satellite_phenology routine in EDMain --- main/EDMainMod.F90 | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index e4952c3bfc..bbbbe696c8 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -33,6 +33,7 @@ module EDMainMod use EDPatchDynamicsMod , only : spawn_patches use EDPatchDynamicsMod , only : terminate_patches use EDPhysiologyMod , only : phenology + use EDPhysiologyMod , only : satellite_phenology use EDPhysiologyMod , only : recruitment use EDPhysiologyMod , only : trim_canopy use EDPhysiologyMod , only : SeedIn @@ -171,8 +172,12 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! We do not allow phenology while in ST3 mode either, it is hypothetically ! possible to allow this, but we have not plugged in the litter fluxes ! of flushing or turning over leaves for non-dynamics runs - if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.false) then - call phenology(currentSite, bc_in ) + if (hlm_use_ed_st3.eq.ifalse) then + if(hlm_use_sp.eq.false) + call phenology(currentSite, bc_in ) + else + call satellite_phenology(currentSite, bc_in ) + end if ! SP phenology end if From 406c72bdbfb9828b0c567b24ed1120e4a125e2a9 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 15:44:12 +0200 Subject: [PATCH 052/578] begun satellite_phenology subroutine --- biogeochem/EDPhysiologyMod.F90 | 40 ++++++++++++++++++++++++++++++++++ 1 file changed, 40 insertions(+) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 0c23795f9a..3851082310 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -107,6 +107,7 @@ module EDPhysiologyMod public :: trim_canopy public :: phenology + public :: satellite_phenology public :: recruitment public :: ZeroLitterFluxes public :: FluxIntoLitterPools @@ -1063,6 +1064,7 @@ subroutine phenology( currentSite, bc_in ) end subroutine phenology + ! ============================================================================ subroutine phenology_leafonoff(currentSite) ! @@ -1329,7 +1331,45 @@ subroutine phenology_leafonoff(currentSite) end subroutine phenology_leafonoff + ! ===================================================================================== + + subroutine satellite_phenology + + ! ----------------------------------------------------------------------------------- + ! Takes the daily inputs of leaf area index, stem area index and canopy height and + ! translates them into a FATES structure with one patch and one cohort per PFT + ! The leaf area of the cohort is modified each day to match that asserted by the HLM + ! ----------------------------------------------------------------------------------- + + ! To Do in this routine. + ! Get access to HLM input varialbes. + ! Weight them by PFT + ! Loop around patches, and for each single cohort in each patch + ! determine what 'n' should be from the canopy height. + ! determine the leaf biomass that it should have. + ! figure out how this will interact with the canopy_structure routines. + ! determine what 'n' should be from the canopy height. + + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(associated(currentCohort%shorter) + write(*,*) "there is more than one cohort in SP mode.' + end if + + ft =currentCohort%pft + if(ft.ne.currentPatch%nocomp_pft)then + write(*,*) 'wrong PFT label in cohort in SP mode',ft,currentPatch%nocomp_pft + end if + + currentCohort => currentCohort%shorter + end do !cohort loop + + currentPatch => currentPatch%younger + end do ! patch loop + end subroutine satellite_phenology ! ===================================================================================== subroutine SeedIn( currentSite, bc_in ) From 552a0edb70cc222e82d78dccabb2e4f999d69c7b Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 8 Sep 2020 15:56:56 +0200 Subject: [PATCH 053/578] added weighting code for SP variables. need to finish --- biogeochem/EDPhysiologyMod.F90 | 35 +++++++++++++++++++++++++++++++++- 1 file changed, 34 insertions(+), 1 deletion(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 3851082310..7ea94da634 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1351,7 +1351,40 @@ subroutine satellite_phenology ! determine what 'n' should be from the canopy height. currentPatch => currentSite%oldest_patch - do while (associated(currentPatch)) + do while (associated(currentPatch)) + + if(hlm_use_fixed_biogeog.eq.itrue)then + ! WEIGHTING OF FATES PFTs on to HLM_PFTs + ! add up the area associated with each FATES PFT + ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) + ! hlm_pft_map is the area of that land in each FATES PFT (from param file) + + currentSite%sp_tlai(1:numpft) = 0._r8 + currentSite%sp_tsai(1:numpft) = 0._r8 + currentSite%sp_htop(1:numpft) = 0._r8 + +! weight each fates PFT target for lai, sai and htop by the area of the +! contrbuting HLM PFTs. + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts + !leaf area index + currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & + bc_in(s)%hlm_sp_tlai(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) + !stem area index + currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & + bc_in(s)%hlm_sp_tsai(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) + ! canopy height + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) + & + bc_in(s)%hlm_sp_htop(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) + + + end do + end do !hlm_pft + + sumarea = sum(sites(s)%area_pft(1:numpft)) +!** RENORMALIZE FOR TOTAL PFT AREA ACCOUNTING FOR DELETED TINY PACHES + + currentCohort => currentPatch%tallest do while (associated(currentCohort)) if(associated(currentCohort%shorter) From b163fbdce336f9119e172f9046635323ef671567 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 9 Sep 2020 09:45:50 +0200 Subject: [PATCH 054/578] modified comments for pft_areafrac calculation --- main/EDInitMod.F90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index a672b56f22..1f7c2c59c5 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -320,10 +320,6 @@ subroutine set_site_properties( nsites, sites,bc_in ) end do end do !hlm_pft - ! re-normalize PFT area to ensure it sums to one. - ! note that in areas of 'bare ground' (PFT 0 in CLM/ELM) - ! the bare ground will no longer be proscribed and should emerge from FATES - do ft = 1,numpft if(sites(s)%area_pft(ft).lt.0.01_r8)then sites(s)%area_pft(ft)=0.0_r8 !remove tiny patches to prevent numerical errors in terminate patches @@ -331,6 +327,11 @@ subroutine set_site_properties( nsites, sites,bc_in ) endif end do + ! re-normalize PFT area to ensure it sums to one. + ! note that in areas of 'bare ground' (PFT 0 in CLM/ELM) + ! the bare ground will no longer be proscribed and should emerge from FATES + ! this may or may not be the right way to deal with this? + sumarea = sum(sites(s)%area_pft(1:numpft)) do ft = 1,numpft if(sumarea.gt.0._r8)then From 12310b026c200a212c5859ee1e677688f8f365ff Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 9 Sep 2020 10:23:01 +0200 Subject: [PATCH 055/578] added normalization to SP variable weighting. Changed indents --- biogeochem/EDPhysiologyMod.F90 | 77 ++++++++++++++++++++-------------- 1 file changed, 46 insertions(+), 31 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 7ea94da634..31b0b1f498 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1353,38 +1353,53 @@ subroutine satellite_phenology currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) - if(hlm_use_fixed_biogeog.eq.itrue)then - ! WEIGHTING OF FATES PFTs on to HLM_PFTs - ! add up the area associated with each FATES PFT - ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) - ! hlm_pft_map is the area of that land in each FATES PFT (from param file) - - currentSite%sp_tlai(1:numpft) = 0._r8 - currentSite%sp_tsai(1:numpft) = 0._r8 - currentSite%sp_htop(1:numpft) = 0._r8 - -! weight each fates PFT target for lai, sai and htop by the area of the -! contrbuting HLM PFTs. - do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) - do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts - !leaf area index - currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & - bc_in(s)%hlm_sp_tlai(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) - !stem area index - currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & - bc_in(s)%hlm_sp_tsai(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) - ! canopy height + if(hlm_use_fixed_biogeog.eq.itrue)then + ! WEIGHTING OF FATES PFTs on to HLM_PFTs + ! add up the area associated with each FATES PFT + ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) + ! hlm_pft_map is the area of that land in each FATES PFT (from param file) + + currentSite%sp_tlai(1:numpft) = 0._r8 + currentSite%sp_tsai(1:numpft) = 0._r8 + currentSite%sp_htop(1:numpft) = 0._r8 + + ! weight each fates PFT target for lai, sai and htop by the area of the + ! contrbuting HLM PFTs. + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts + if(sites(s)%area_pft(ft).gt.0.0_r8)then + !leaf area index + currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & + bc_in(s)%hlm_sp_tlai(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) + !stem area index + currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & + bc_in(s)%hlm_sp_tsai(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) + ! canopy height currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) + & - bc_in(s)%hlm_sp_htop(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) - - - end do - end do !hlm_pft - - sumarea = sum(sites(s)%area_pft(1:numpft)) -!** RENORMALIZE FOR TOTAL PFT AREA ACCOUNTING FOR DELETED TINY PACHES - - + bc_in(s)%hlm_sp_htop(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) + end if ! there is some area in this patch + end do + end do !hlm_pft + + ! weight for total area in each fates_pft + do fates_pft = 1,numpft + if(sites(s)%area_pft(ft).gt.0.0_r8)then + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & + /sites(s)%area_pft(ft) + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & + /sites(s)%area_pft(ft) + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & + /sites(s)%area_pft(ft) + endif + enddo !fates_pft + + ! ------------------------------------------------------------ + ! now we have the target lai, sai and htop for each PFT/patch + ! find properties of the cohort that go along with that + ! 1. Find canopy area from HTOP (height) + ! 2. Find 'n' associated with canopy area, given a closed canopy + ! 3. Find 'bleaf' associated with TLAI and canopy area. + ! ------------------------------------------------------------ currentCohort => currentPatch%tallest do while (associated(currentCohort)) if(associated(currentCohort%shorter) From cf3ed64f3257f92d16e88c340e1b169a1eb8030b Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 9 Sep 2020 10:37:12 +0200 Subject: [PATCH 056/578] added leafc_from_treelai to FatesAllometryMod --- biogeochem/FatesAllometryMod.F90 | 96 ++++++++++++++++++++++++++++++++ 1 file changed, 96 insertions(+) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index ce56a15e35..73197e8b19 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -123,6 +123,7 @@ module FatesAllometryMod public :: CrownDepth public :: set_root_fraction ! Generic wrapper to calculate normalized ! root profiles + public :: leafc_from_treelai ! Calculate target leaf carbon for a given treelai for SP mode logical , parameter :: verbose_logging = .false. character(len=*), parameter :: sourcefile = __FILE__ @@ -756,6 +757,101 @@ real(r8) function tree_sai( pft, dbh, canopy_trim, c_area, nplant, cl, & return end function tree_sai +! ===================================================================================== + + real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, canopy_lai, vcmax25top) + + ! ----------------------------------------------------------------------------------- + ! LAI of individual trees is a function of the total leaf area and the total + ! canopy area. + ! ---------------------------------------------------------------------------------- + + ! !ARGUMENTS + real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, canopy_lai, vcmax25top) + + real(r8), intent(in) :: treelai ! desired tree lai m2/m2 + integer, intent(in) :: pft ! Plant Functional Type index + real(r8), intent(in) :: c_area ! areal extent of canopy (m2) + real(r8), intent(in) :: nplant ! number of individuals in cohort per ha + integer, intent(in) :: cl ! canopy layer index + real(r8), intent(in) :: canopy_lai(nclmax) ! total leaf area index of + ! each canopy layer + real(r8), intent(in) :: vcmax25top ! maximum carboxylation rate at canopy + ! top, ref 25C + + ! !LOCAL VARIABLES: + real(r8), :: leaf_c ! plant leaf carbon [kg] + real(r8) :: leafc_per_unitarea ! KgC of leaf per m2 area of ground. + real(r8) :: slat ! the sla of the top leaf layer. m2/kgC + real(r8) :: canopy_lai_above ! total LAI of canopy layer overlying this tree + real(r8) :: vai_per_lai ! ratio of vegetation area index (ie. sai+lai) + ! to lai for individual tree + real(r8) :: kn ! coefficient for exponential decay of 1/sla and + ! vcmax with canopy depth + real(r8) :: sla_max ! Observational constraint on how large sla + ! (m2/gC) can become + real(r8) :: leafc_slamax ! Leafc_per_unitarea at which sla_max is reached + real(r8) :: clim ! Upper limit for leafc_per_unitarea in exponential + ! tree_lai function + real(r8) :: tree_lai_at_slamax ! lai at which we reach the maximum sla value. + + !---------------------------------------------------------------------- + + if( treelai < 0._r8.or. pft == 0 ) then + write(fates_log(),*) 'negative tree lai in leafc_from_treelai?' + write(fates_log(),*) 'or.. pft was zero?' + write(fates_log(),*) 'problem in leafc_from_treelai',treelai,pft + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + if(cl>1)then + write(fates_log(),*) 'in sub-canopy layer in leafc_from_treelai' + write(fates_log(),*) 'this is not set up to work for lower canopy layers.' + write(fates_log(),*) 'problem in leafc_from_treelai',cl,pft + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + slat = g_per_kg * EDPftvarcon_inst%slatop(pft) ! m2/g to m2/kg + leafc_per_unitarea = leaf_c/(c_area/nplant) !KgC/m2 + + if(treelai > 0.0_r8)then + ! Coefficient for exponential decay of 1/sla with canopy depth: + kn = decay_coeff_kn(pft,vcmax25top) + + ! take PFT-level maximum SLA value, even if under a thick canopy (which has units of m2/gC), + ! and put into units of m2/kgC + sla_max = g_per_kg *EDPftvarcon_inst%slamax(pft) + + ! Leafc_per_unitarea at which sla_max is reached due to exponential sla profile in canopy: + leafc_slamax = max(0.0_r8,(slat - sla_max) / (-1.0_r8 * kn * slat * sla_max)) + + ! treelai at which we reach maximum sla. + tree_lai_at_slamax = (log( 1.0_r8- kn * slat * leafc_slamax)) / (-1.0_r8 * kn) + if(treelai > tree_lai_at_slamax)then + ! Inversion of the exponential phase calculation of treelai for a given leafc_per_unitarea + leafc_per_unitarea = (1.0_r8-exp(treelai*(-1.0_r8 * kn)))/(kn*slat) + else ! we exceed the maxumum sla + + ! Add exponential and linear portions of tree_lai + ! Exponential term for leafc = leafc_slamax; + leafc_linear_phase = (treelai-tree_lai_at_slamax)/sla_max + leafc_per_unitarea = leafc_slamax + leafc_linear_phase + end if + + else + leafc_from_treelai = 0.0_r8 + endif ! (leafc_per_unitarea > 0.0_r8) + + return + end function leafc_from_treelai + + ! ===================================================================================== + + + + + + ! ============================================================================ ! Generic sapwood biomass interface ! ============================================================================ From 21e09a454a98bbe9bfc1f4fa724f1b3feed7f516 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 9 Sep 2020 11:02:07 +0200 Subject: [PATCH 057/578] removed refences to canopy_lai in leafc_from_treelai --- biogeochem/FatesAllometryMod.F90 | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index 73197e8b19..6c33e5c8f8 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -759,7 +759,7 @@ end function tree_sai ! ===================================================================================== - real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, canopy_lai, vcmax25top) + real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25top) ! ----------------------------------------------------------------------------------- ! LAI of individual trees is a function of the total leaf area and the total @@ -767,15 +767,11 @@ real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, canopy_l ! ---------------------------------------------------------------------------------- ! !ARGUMENTS - real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, canopy_lai, vcmax25top) - real(r8), intent(in) :: treelai ! desired tree lai m2/m2 integer, intent(in) :: pft ! Plant Functional Type index real(r8), intent(in) :: c_area ! areal extent of canopy (m2) real(r8), intent(in) :: nplant ! number of individuals in cohort per ha integer, intent(in) :: cl ! canopy layer index - real(r8), intent(in) :: canopy_lai(nclmax) ! total leaf area index of - ! each canopy layer real(r8), intent(in) :: vcmax25top ! maximum carboxylation rate at canopy ! top, ref 25C @@ -783,7 +779,6 @@ real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, canopy_l real(r8), :: leaf_c ! plant leaf carbon [kg] real(r8) :: leafc_per_unitarea ! KgC of leaf per m2 area of ground. real(r8) :: slat ! the sla of the top leaf layer. m2/kgC - real(r8) :: canopy_lai_above ! total LAI of canopy layer overlying this tree real(r8) :: vai_per_lai ! ratio of vegetation area index (ie. sai+lai) ! to lai for individual tree real(r8) :: kn ! coefficient for exponential decay of 1/sla and From c501b561ddb6f6311638680ac50db0e1e5b67363 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 9 Sep 2020 11:03:45 +0200 Subject: [PATCH 058/578] added call to leafc_from_treelai --- biogeochem/EDPhysiologyMod.F90 | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 31b0b1f498..b4c9938b20 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -27,6 +27,7 @@ module EDPhysiologyMod use EDCohortDynamicsMod , only : InitPRTObject use FatesAllometryMod , only : tree_lai use FatesAllometryMod , only : tree_sai + use FatesAllometryMod , only : leafc_from_treelai use FatesAllometryMod , only : decay_coeff_kn use FatesLitterMod , only : litter_type use EDTypesMod , only : site_massbal_type @@ -1402,20 +1403,25 @@ subroutine satellite_phenology ! ------------------------------------------------------------ currentCohort => currentPatch%tallest do while (associated(currentCohort)) + + ! Do some checks if(associated(currentCohort%shorter) write(*,*) "there is more than one cohort in SP mode.' end if ft =currentCohort%pft if(ft.ne.currentPatch%nocomp_pft)then - write(*,*) 'wrong PFT label in cohort in SP mode',ft,currentPatch%nocomp_pft + write(*,*) 'wrong PFT label in cohort in SP mode',ft,currentPatch%nocomp_pft end if currentCohort => currentCohort%shorter end do !cohort loop + leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& + currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) + currentPatch => currentPatch%younger - end do ! patch loop + end do ! patch loop end subroutine satellite_phenology ! ===================================================================================== From d149ae67893ec70a8b2a5752f02d5bb0f9284615 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 9 Sep 2020 11:17:35 +0200 Subject: [PATCH 059/578] added calls to allometry functions to estimate cohort properties --- biogeochem/EDPhysiologyMod.F90 | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index b4c9938b20..42dbc815c5 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1417,9 +1417,31 @@ subroutine satellite_phenology currentCohort => currentCohort%shorter end do !cohort loop + !------------------------------------------ + ! Calculate dbh from input height, and c_area from dbh + !------------------------------------------ + currentCohort%hite = currentPatch%sp_htop + call h2d_allom(temp_cohort%hite,ft,temp_cohort%dbh) + currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. + call carea_allom(currentCohort%dbh,currentCohort%n,spread,currentCohort%pft,currentCohort%c_area) + + !------------------------------------------ + ! Calculate canopy N assuming patch area is full + !------------------------------------------ + currentCohort%n = currentPatch%area / currentCohort%c_area + + ! ------------------------------------------ + ! Calculate leaf carbon from target treelai + ! ------------------------------------------ + currentCohort%treelai = currentPatch%sp_tlai leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) + ! assert sai + currentCohort%treesai = currentPatch%sp_tsai + + !NB these will need to be put through the canopy_structure routine in order to figure out exposed lai and sai + currentPatch => currentPatch%younger end do ! patch loop From 57ba8a35f2cb13aa256a686af3dac7d981d7dcb0 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 10 Sep 2020 11:37:21 +0200 Subject: [PATCH 060/578] added fixed value of spread to c_area --- biogeochem/EDPhysiologyMod.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 42dbc815c5..9e4a90e1ed 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1342,6 +1342,8 @@ subroutine satellite_phenology ! The leaf area of the cohort is modified each day to match that asserted by the HLM ! ----------------------------------------------------------------------------------- + real(r8) :: spread ! need to send a fixed value of patch spread to carea_allom + ! To Do in this routine. ! Get access to HLM input varialbes. ! Weight them by PFT @@ -1423,6 +1425,9 @@ subroutine satellite_phenology currentCohort%hite = currentPatch%sp_htop call h2d_allom(temp_cohort%hite,ft,temp_cohort%dbh) currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. + spread = 0.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. + ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in + ! SP mode. call carea_allom(currentCohort%dbh,currentCohort%n,spread,currentCohort%pft,currentCohort%c_area) !------------------------------------------ From ae27d49e9c11ab544214fb9e4859f6ef67aea5cf Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 10 Sep 2020 11:48:35 +0200 Subject: [PATCH 061/578] added setstate call for leaf carbon in satellite_phenology --- biogeochem/EDPhysiologyMod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 9e4a90e1ed..f383eb0be9 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1444,6 +1444,7 @@ subroutine satellite_phenology ! assert sai currentCohort%treesai = currentPatch%sp_tsai + call SetState(prt,leaf_organ, element_id,leaf_c,1) !NB these will need to be put through the canopy_structure routine in order to figure out exposed lai and sai From d5d4466953c26f2ca57f46a9a2e73e861c4a87af Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 10 Sep 2020 12:12:23 +0200 Subject: [PATCH 062/578] added hlm_use_nocomp to FatesInterfaceTypesMod --- main/FatesInterfaceTypesMod.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 547e095fa7..9ef9dd8498 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -164,6 +164,9 @@ module FatesInterfaceTypesMod 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 nocomp mode + ! 1 = TRUE, 0 = FALSE + ! ------------------------------------------------------------------------------------- ! Parameters that are dictated by FATES and known to be required knowledge ! needed by the HLMs From fda950c622b99763cd1349b72eb3099649282b54 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 10 Sep 2020 12:23:03 +0200 Subject: [PATCH 063/578] broadcast nocomp parameter in FatesInterfaceMod.F90 --- main/FatesInterfaceMod.F90 | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index b43992b94f..db120acc17 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1263,13 +1263,12 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) 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_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 @@ -1386,12 +1385,11 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering hlm_use_fixed_biogeog= ',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_nocomp') + hlm_use_nocomp = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_use_nocomp= ',ival,' to FATES' + end if case('use_planthydro') From 0d84fafed3062c5d0d7f3eff369d375b0be2bfa1 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 02:13:52 -0600 Subject: [PATCH 064/578] uncomment nocomp statement in FatesInterfaceMod --- main/FatesInterfaceMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index db120acc17..43376af24d 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1015,7 +1015,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 ! future reduced complexity mode + hlm_use_nocomp = unset_int ! future reduced complexity mode hlm_use_inventory_init = unset_int hlm_inventory_ctrl_file = 'unset' @@ -1265,7 +1265,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) if(hlm_use_nocomp.eq.unset_int) then if(fates_global_verbose()) then - write(fates_log(), *) 'switch for no competition mode. ' + write(fates_log(), *) 'switch for no competition mode unset. use_nocomp exiting ' end if call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1384,7 +1384,7 @@ 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 From f8f48673e5a92f46f018ccd11cb2e41e37734438 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 02:15:08 -0600 Subject: [PATCH 065/578] remove typo in EDInitMod --- main/EDPftvarcon.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index bed41f0eab..0adffbef4d 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -920,7 +920,7 @@ subroutine Register_PFT(this, fates_params) ! adding the hlm_pft_map variable with two dimensions - FATES PFTno and HLM PFTno pftmap_dim_names(1) = dimension_name_pft - pftmap_dim_names(2) = dimension_name_hlm_pftno xs + pftmap_dim_names(2) = dimension_name_hlm_pftno name = 'fates_hlm_pft_map' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=pftmap_dim_names, lower_bounds=dim_lower_bound) From 11961e4e71093f816c503e783b9c4edd9b45e89d Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 02:47:35 -0600 Subject: [PATCH 066/578] removed extra write statements from EDPatchDynamicsMod --- biogeochem/EDPatchDynamicsMod.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index d0fe122e50..be75565516 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2619,7 +2619,6 @@ subroutine terminate_patches(currentSite) !--------------------------------------------------------------------- count_cycles = 0 -!write(*,*) 'start terminate patches',currentSite%lat,currentSite%lon currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) @@ -2837,7 +2836,7 @@ subroutine terminate_patches(currentSite) !check area is not exceeded call check_patch_area( currentSite ) -! write(*,*) 'leaving terminate patches',currentSite%lat,currentSite%lon + return end subroutine terminate_patches From fe2169f30ad3b54ccc88b4eb914cfb22da44abff Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 02:52:25 -0600 Subject: [PATCH 067/578] added comment on EDPatchDynamicsMod --- biogeochem/EDPatchDynamicsMod.F90 | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index be75565516..663471fb6d 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2726,6 +2726,13 @@ subroutine terminate_patches(currentSite) enddo !fusing patch is_oldest = itrue !try and find a younger same-PFT patch + !-------------------------------------------------- + ! n.b. The following code is to figure out how to + ! terminate small patches in nocomp mode + ! It was written in the context of the multi-patch version + ! which is currently inactive and may or may not be needed in the + ! single patch version. + !-------------------------------------------------- ! discover if this is the youngest patch of its PFT fusingPatch => currentPatch%older !if it's the youngest overall then it's defacto youngest of PFT do while(associated(fusingPatch).and.is_oldest.eq.itrue) From 812aa3bc2617a12d056c86ee8da9f9cabf6a6370 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 03:07:40 -0600 Subject: [PATCH 068/578] debugging --- biogeochem/FatesAllometryMod.F90 | 6 ++++-- main/EDPftvarcon.F90 | 2 +- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index 6c33e5c8f8..c397ab5bea 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -776,7 +776,7 @@ real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25t ! top, ref 25C ! !LOCAL VARIABLES: - real(r8), :: leaf_c ! plant leaf carbon [kg] + real(r8) :: leaf_c ! plant leaf carbon [kg] real(r8) :: leafc_per_unitarea ! KgC of leaf per m2 area of ground. real(r8) :: slat ! the sla of the top leaf layer. m2/kgC real(r8) :: vai_per_lai ! ratio of vegetation area index (ie. sai+lai) @@ -789,7 +789,9 @@ real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25t real(r8) :: clim ! Upper limit for leafc_per_unitarea in exponential ! tree_lai function real(r8) :: tree_lai_at_slamax ! lai at which we reach the maximum sla value. - + real(r8) :: leafc_linear_phase ! amount of leaf carbon needed to get to the target treelai + ! when the slamax value has been reached (i.e. deep layers with unchanging sla) + !---------------------------------------------------------------------- if( treelai < 0._r8.or. pft == 0 ) then diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index bed41f0eab..0adffbef4d 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -920,7 +920,7 @@ subroutine Register_PFT(this, fates_params) ! adding the hlm_pft_map variable with two dimensions - FATES PFTno and HLM PFTno pftmap_dim_names(1) = dimension_name_pft - pftmap_dim_names(2) = dimension_name_hlm_pftno xs + pftmap_dim_names(2) = dimension_name_hlm_pftno name = 'fates_hlm_pft_map' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=pftmap_dim_names, lower_bounds=dim_lower_bound) From a49c7dd4a0e1d2a196713444f7204468cb281b36 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 03:10:04 -0600 Subject: [PATCH 069/578] changed SP input variable names in FatesInterfaceTypesMod --- main/FatesInterfaceTypesMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 65689ce73c..be21cb4de3 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -480,9 +480,9 @@ module FatesInterfaceTypesMod ! Satellite Phenology (SP) input variables. (where each patch only has one PFT) ! --------------------------------------------------------------------------------- - real(r8),allocatable :: sp_tlai(:) ! Interpolated daily total LAI (leaf area index) input from HLM per patch/pft - real(r8),allocatable :: sp_tsai(:) ! Interpolated sailt total SAI (stem area index) input from HLM per patch/pft - real(r8),allocatable :: sp_htop(:) ! Interpolated daily canopy vegetation height input from HLM per patch/pft + real(r8),allocatable :: hlm_sp_tlai(:) ! Interpolated daily total LAI (leaf area index) input from HLM per patch/pft + real(r8),allocatable :: hlm_sp_tsai(:) ! Interpolated sailt total SAI (stem area index) input from HLM per patch/pft + real(r8),allocatable :: hlm_sp_htop(:) ! Interpolated daily canopy vegetation height input from HLM per patch/pft end type bc_in_type From 875c9d4db14c3c2997b42324c48303e3d00efa51 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 04:54:54 -0600 Subject: [PATCH 070/578] debugging EDPhysiologyMod.F90 --- biogeochem/EDPhysiologyMod.F90 | 134 +++++++++++++++++++-------------- 1 file changed, 76 insertions(+), 58 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 42dbc815c5..d8a6db408d 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -15,6 +15,7 @@ module EDPhysiologyMod use FatesInterfaceTypesMod, only : nleafage use FatesInterfaceTypesMod, only : hlm_use_planthydro use FatesInterfaceTypesMod, only : hlm_parteh_mode + use FatesInterfaceTypesMod, only : hlm_use_fixed_biogeog use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : nearzero use FatesConstantsMod, only : g_per_kg @@ -1334,7 +1335,7 @@ end subroutine phenology_leafonoff ! ===================================================================================== - subroutine satellite_phenology + subroutine satellite_phenology(currentSite, bc_in) ! ----------------------------------------------------------------------------------- ! Takes the daily inputs of leaf area index, stem area index and canopy height and @@ -1342,6 +1343,25 @@ subroutine satellite_phenology ! The leaf area of the cohort is modified each day to match that asserted by the HLM ! ----------------------------------------------------------------------------------- + ! !USES: + ! + ! !ARGUMENTS: + type(ed_site_type), intent(inout), target :: currentSite + type(bc_in_type), intent(in) :: bc_in + + class(prt_vartypes), pointer :: prt + + ! !LOCAL VARIABLES: + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + real(r8) :: spread ! dummy value of canopy spread to estimate c_area + real(r8) :: leaf_c ! leaf carbon estimated to generate target tlai + + integer :: fates_pft ! fates pft numer for weighting loop + integer :: hlm_pft ! host land model pft number for weighting loop. + integer :: s ! site index + ! To Do in this routine. ! Get access to HLM input varialbes. ! Weight them by PFT @@ -1351,10 +1371,9 @@ subroutine satellite_phenology ! figure out how this will interact with the canopy_structure routines. ! determine what 'n' should be from the canopy height. - currentPatch => currentSite%oldest_patch - do while (associated(currentPatch)) + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) - if(hlm_use_fixed_biogeog.eq.itrue)then ! WEIGHTING OF FATES PFTs on to HLM_PFTs ! add up the area associated with each FATES PFT ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) @@ -1365,34 +1384,32 @@ subroutine satellite_phenology currentSite%sp_htop(1:numpft) = 0._r8 ! weight each fates PFT target for lai, sai and htop by the area of the - ! contrbuting HLM PFTs. + ! contrbuting HLM PFTs. + ! we only need to do this for the patch/fates_pft we are currently in + fates_pft = currentPatch%nocomp_pft_label do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) - do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts - if(sites(s)%area_pft(ft).gt.0.0_r8)then - !leaf area index - currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & - bc_in(s)%hlm_sp_tlai(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) - !stem area index - currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & - bc_in(s)%hlm_sp_tsai(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) - ! canopy height - currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) + & - bc_in(s)%hlm_sp_htop(hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) - end if ! there is some area in this patch - end do + if(bc_in%pft_areafrac(hlm_pft).gt.0.0_r8)then + !leaf area index + currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & + bc_in%hlm_sp_tlai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) + !stem area index + currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & + bc_in%hlm_sp_tsai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) + ! canopy height + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) + & + bc_in%hlm_sp_htop(hlm_pft) * bc_in%pft_areafrac(hlm_pft) + end if ! there is some area in this patch end do !hlm_pft - ! weight for total area in each fates_pft - do fates_pft = 1,numpft - if(sites(s)%area_pft(ft).gt.0.0_r8)then + ! weight for total area in each patch/fates_pft + if(currentPatch%area.gt.0.0_r8)then + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & + /currentPatch%area + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & + /currentPatch%area currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & - /sites(s)%area_pft(ft) - currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & - /sites(s)%area_pft(ft) - currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & - /sites(s)%area_pft(ft) - endif - enddo !fates_pft + /currentPatch%area + endif ! ------------------------------------------------------------ ! now we have the target lai, sai and htop for each PFT/patch @@ -1405,43 +1422,44 @@ subroutine satellite_phenology do while (associated(currentCohort)) ! Do some checks - if(associated(currentCohort%shorter) - write(*,*) "there is more than one cohort in SP mode.' + if(associated(currentCohort%shorter))then + write(*,*) "there is more than one cohort in SP mode" end if - ft =currentCohort%pft - if(ft.ne.currentPatch%nocomp_pft)then - write(*,*) 'wrong PFT label in cohort in SP mode',ft,currentPatch%nocomp_pft + fates_pft =currentCohort%pft + if(fates_pft.ne.currentPatch%nocomp_pft_label)then + write(*,*) 'wrong PFT label in cohort in SP mode',fates_pft,currentPatch%nocomp_pft_label end if - currentCohort => currentCohort%shorter - end do !cohort loop - - !------------------------------------------ - ! Calculate dbh from input height, and c_area from dbh - !------------------------------------------ - currentCohort%hite = currentPatch%sp_htop - call h2d_allom(temp_cohort%hite,ft,temp_cohort%dbh) - currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. - call carea_allom(currentCohort%dbh,currentCohort%n,spread,currentCohort%pft,currentCohort%c_area) - - !------------------------------------------ - ! Calculate canopy N assuming patch area is full - !------------------------------------------ - currentCohort%n = currentPatch%area / currentCohort%c_area - - ! ------------------------------------------ - ! Calculate leaf carbon from target treelai - ! ------------------------------------------ - currentCohort%treelai = currentPatch%sp_tlai - leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& + !------------------------------------------ + ! Calculate dbh from input height, and c_area from dbh + !------------------------------------------ + currentCohort%hite = currentSite%sp_htop(fates_pft) + call h2d_allom(currentCohort%hite,currentCohort%pft,currentCohort%dbh) + currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. + spread = 0.0_r8 + call carea_allom(currentCohort%dbh,currentCohort%n,spread,currentCohort%pft,currentCohort%c_area) + + !------------------------------------------ + ! Calculate canopy N assuming patch area is full + !------------------------------------------ + currentCohort%n = currentPatch%area / currentCohort%c_area + + ! ------------------------------------------ + ! Calculate leaf carbon from target treelai + ! ------------------------------------------ + currentCohort%treelai = currentSite%sp_tlai(fates_pft) + leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) + call SetState(currentCohort%prt,leaf_organ,1,leaf_c,1) + + ! assert sai + currentCohort%treesai = currentSite%sp_tsai(fates_pft) - ! assert sai - currentCohort%treesai = currentPatch%sp_tsai - - !NB these will need to be put through the canopy_structure routine in order to figure out exposed lai and sai + !NB these will need to be put through the canopy_structure routine in order to figure out exposed lai and sai + currentCohort => currentCohort%shorter + end do !cohort loop currentPatch => currentPatch%younger end do ! patch loop From e4762b24dead38e3d5beb2aad91c0a8b529083cc Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 04:55:15 -0600 Subject: [PATCH 071/578] debugging main/EDMainMod.F90 --- main/EDMainMod.F90 | 20 ++++++++------------ 1 file changed, 8 insertions(+), 12 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index bbbbe696c8..6629627bd4 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -19,6 +19,7 @@ module EDMainMod use FatesInterfaceTypesMod , only : hlm_reference_date use FatesInterfaceTypesMod , only : hlm_use_ed_prescribed_phys use FatesInterfaceTypesMod , only : hlm_use_ed_st3 + use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_masterproc use FatesInterfaceTypesMod , only : numpft @@ -172,8 +173,8 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! We do not allow phenology while in ST3 mode either, it is hypothetically ! possible to allow this, but we have not plugged in the litter fluxes ! of flushing or turning over leaves for non-dynamics runs - if (hlm_use_ed_st3.eq.ifalse) then - if(hlm_use_sp.eq.false) + if (hlm_use_ed_st3.eq.ifalse)then + if(hlm_use_sp.eq.ifalse) then call phenology(currentSite, bc_in ) else call satellite_phenology(currentSite, bc_in ) @@ -181,7 +182,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) end if - if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.false) then ! Bypass if ST3 + if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.ifalse) then ! Bypass if ST3 call fire_model(currentSite, bc_in) ! Calculate disturbance and mortality based on previous timestep vegetation. @@ -189,7 +190,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call disturbance_rates(currentSite, bc_in) end if - if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.false) then + if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.ifalse) then ! Integrate state variables from annual rates to daily timestep call ed_integrate_state_variables(currentSite, bc_in ) else @@ -207,7 +208,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! Reproduction, Recruitment and Cohort Dynamics : controls cohort organization !****************************************************************************** - if(hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.false) then + if(hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.ifalse) then currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) @@ -221,7 +222,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call TotalBalanceCheck(currentSite,1) - if( hlm_use_ed_st3.eq.ifalse .and.hlm_use_sp.eq.false ) then + if( hlm_use_ed_st3.eq.ifalse .and.hlm_use_sp.eq.ifalse ) then currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) @@ -260,15 +261,10 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) do_patch_dynamics = ifalse end if - if(hlm_use_sp.eq.itrue) ! cover for potential changes in nocomp logic above. + if(hlm_use_sp.eq.itrue)then ! cover for potential changes in nocomp logic above. do_patch_dynamics = ifalse end if - if(hlm_use_sp.eq.itrue)then - ! if we want to assert LAI - do_patch_dynamics = ifalse - end if - ! make new patches from disturbed land if (do_patch_dynamics.eq.itrue ) then call spawn_patches(currentSite, bc_in) From a33655a2777f24d5ebcfef8b62af60f3f74f3abc Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 07:58:14 -0600 Subject: [PATCH 072/578] read use_sp in FatesInterfaceMod.F90 --- main/FatesInterfaceMod.F90 | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index ebd8a5392e..926da38def 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1402,13 +1402,18 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering hlm_use_fixed_biogeog= ',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_sp') + hlm_use_sp = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_use_sp= ',ival,' to FATES' + end if + case('use_planthydro') hlm_use_planthydro = ival From 97b39f10ddfb22f6c701def57263729e56cdf557 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 11 Sep 2020 08:03:08 -0600 Subject: [PATCH 073/578] commenting out balance check --- main/EDMainMod.F90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 6629627bd4..127ace6913 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -219,8 +219,9 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) enddo end if - - call TotalBalanceCheck(currentSite,1) + if(hlm_use_sp.eq.ifalse)then + call TotalBalanceCheck(currentSite,1) + end if if( hlm_use_ed_st3.eq.ifalse .and.hlm_use_sp.eq.ifalse ) then currentPatch => currentSite%oldest_patch @@ -242,9 +243,10 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) currentPatch => currentPatch%younger enddo end if - - call TotalBalanceCheck(currentSite,2) + if(hlm_use_sp.eq.ifalse)then + call TotalBalanceCheck(currentSite,2) + end if !********************************************************************************* ! Patch dynamics sub-routines: fusion, new patch creation (spwaning), termination. !********************************************************************************* From 0028a57cd2eefe05155c092ee00c7e66998a5dd0 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 02:57:32 -0600 Subject: [PATCH 074/578] turned off balance check calls in SP mode in EDMain --- main/EDMainMod.F90 | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 127ace6913..7d3df65365 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -168,8 +168,9 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call ZeroLitterFluxes(currentSite) ! Zero mass balance - call TotalBalanceCheck(currentSite, 0) - + if(hlm_use_sp.eq.ifalse)then + call TotalBalanceCheck(currentSite, 0) + end if ! We do not allow phenology while in ST3 mode either, it is hypothetically ! possible to allow this, but we have not plugged in the litter fluxes ! of flushing or turning over leaves for non-dynamics runs @@ -271,8 +272,10 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) if (do_patch_dynamics.eq.itrue ) then call spawn_patches(currentSite, bc_in) end if - - call TotalBalanceCheck(currentSite,3) + + if(hlm_use_sp.eq.ifalse)then + call TotalBalanceCheck(currentSite,3) + end if ! fuse on the spawned patches. if ( do_patch_dynamics.eq.itrue ) then @@ -569,12 +572,16 @@ subroutine ed_update_site( currentSite, bc_in ) !----------------------------------------------------------------------- call canopy_spread(currentSite) - - call TotalBalanceCheck(currentSite,6) + + if(hlm_use_sp.eq.ifalse)then + call TotalBalanceCheck(currentSite,6) + end if call canopy_structure(currentSite, bc_in) - call TotalBalanceCheck(currentSite,final_check_id) + if(hlm_use_sp.eq.ifalse)then + call TotalBalanceCheck(currentSite,final_check_id) + end if currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) From 6bfa6b2306ffc0b76a7a8b88460f17443a35bca9 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 03:03:37 -0600 Subject: [PATCH 075/578] check for hlm_pft_area --- main/EDPftvarcon.F90 | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 0adffbef4d..4dd3594af9 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -2137,6 +2137,7 @@ subroutine FatesCheckParams(is_master, parteh_mode) use FatesConstantsMod , only : fates_check_param_set use FatesConstantsMod , only : itrue, ifalse use EDParamsMod , only : logging_mechanical_frac, logging_collateral_frac, logging_direct_frac + use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog ! Argument logical, intent(in) :: is_master ! Only log if this is the master proc @@ -2149,6 +2150,10 @@ subroutine FatesCheckParams(is_master, parteh_mode) integer :: nleafage ! size of the leaf age class array integer :: iage ! leaf age class index integer :: norgans ! size of the plant organ dimension + integer :: hlm_pft ! used in fixed biogeog mode + integer :: fates_pft ! used in fixed biogeog mode + + real(r8) :: sumarea ! area of PFTs in nocomp mode. npft = size(EDPftvarcon_inst%evergreen,1) @@ -2704,7 +2709,7 @@ subroutine FatesCheckParams(is_master, parteh_mode) end if end if - end do + end do ! iage ! Check the turnover rates on the senescing leaf pool if ( EDPftvarcon_inst%leaf_long(ipft,nleafage)>nearzero ) then @@ -2770,8 +2775,21 @@ subroutine FatesCheckParams(is_master, parteh_mode) end if - end do - + end do !ipft + + ! check that the host-fates PFT map adds to one in both dimension + + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_oft)) + if(abs(sumarea-1.0_r8).gt. )then + write(fates_log(),*) 'The distribution of this host land model PFT :',hlm_pft + write(fates_log(),*) 'into FATES PFTs, does not add up to 1.0.' + write(fates_log(),*) 'Error is:',sumarea-1.0_r8 + write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_oft) + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end do !ipft + !! ! Checks for HYDRO !! if( hlm_use_planthydro == itrue ) then !! From 9eefda82636e318b9594b175bee79d10eaff757f Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 03:03:37 -0600 Subject: [PATCH 076/578] check for hlm_pft_area --- main/EDPftvarcon.F90 | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 0adffbef4d..4dd3594af9 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -2137,6 +2137,7 @@ subroutine FatesCheckParams(is_master, parteh_mode) use FatesConstantsMod , only : fates_check_param_set use FatesConstantsMod , only : itrue, ifalse use EDParamsMod , only : logging_mechanical_frac, logging_collateral_frac, logging_direct_frac + use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog ! Argument logical, intent(in) :: is_master ! Only log if this is the master proc @@ -2149,6 +2150,10 @@ subroutine FatesCheckParams(is_master, parteh_mode) integer :: nleafage ! size of the leaf age class array integer :: iage ! leaf age class index integer :: norgans ! size of the plant organ dimension + integer :: hlm_pft ! used in fixed biogeog mode + integer :: fates_pft ! used in fixed biogeog mode + + real(r8) :: sumarea ! area of PFTs in nocomp mode. npft = size(EDPftvarcon_inst%evergreen,1) @@ -2704,7 +2709,7 @@ subroutine FatesCheckParams(is_master, parteh_mode) end if end if - end do + end do ! iage ! Check the turnover rates on the senescing leaf pool if ( EDPftvarcon_inst%leaf_long(ipft,nleafage)>nearzero ) then @@ -2770,8 +2775,21 @@ subroutine FatesCheckParams(is_master, parteh_mode) end if - end do - + end do !ipft + + ! check that the host-fates PFT map adds to one in both dimension + + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_oft)) + if(abs(sumarea-1.0_r8).gt. )then + write(fates_log(),*) 'The distribution of this host land model PFT :',hlm_pft + write(fates_log(),*) 'into FATES PFTs, does not add up to 1.0.' + write(fates_log(),*) 'Error is:',sumarea-1.0_r8 + write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_oft) + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end do !ipft + !! ! Checks for HYDRO !! if( hlm_use_planthydro == itrue ) then !! From b5e9bcd02851e68a25262f9a44e389b69576e761 Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 14 Sep 2020 11:27:21 +0200 Subject: [PATCH 077/578] Update main/EDInitMod.F90 Co-authored-by: Charlie Koven --- main/EDInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 37a4e5787c..5ffd8963d3 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -449,7 +449,7 @@ subroutine init_patches( nsites, sites, bc_in) if(hlm_use_nocomp.eq.itrue)then nocomp_pft = n else - nocomp_pft = 999 + nocomp_pft = fates_unset_int end if if(hlm_use_nocomp.eq.itrue)then From ae5582dae26f6a4d7b74bd7b7745af6c5f95fdcc Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 14 Sep 2020 11:28:05 +0200 Subject: [PATCH 078/578] Typo main/EDInitMod.F90 Co-authored-by: Charlie Koven --- main/EDInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 5ffd8963d3..cddf7e818a 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -591,7 +591,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) patch_in%tallest => null() patch_in%shortest => null() - ! Manage interactions of ixed biogeg (site level filter) and + ! Manage interactions of fixed biogeog (site level filter) and ! nocomp (patch level filter) ! Need to cover all potential biogeog x nocomp combinations ! 1. biogeog = false. nocomp = false: all PFTs on (DEFAULT) From a812a358e78bc2c134da50c8751228925613e15a Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 14 Sep 2020 11:28:38 +0200 Subject: [PATCH 079/578] Small number tolerance in main/EDInitMod.F90 Co-authored-by: Charlie Koven --- main/EDInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index cddf7e818a..14a4d1f370 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -620,7 +620,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) do pft = 1,numpft if(use_pft_local(pft).eq.itrue)then - if(EDPftvarcon_inst%initd(pft)>1.0E-7) then + if(EDPftvarcon_inst%initd(pft)>nearzero) then allocate(temp_cohort) ! temporary cohort From 5a464232066fb4616566bba5f119607038451720 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 03:56:26 -0600 Subject: [PATCH 080/578] removed now irrelevant comment in FatesInterfaceMod.F90 --- main/FatesInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 43376af24d..2b3e5eed4e 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1015,7 +1015,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 ! future reduced complexity mode + hlm_use_nocomp = unset_int hlm_use_inventory_init = unset_int hlm_inventory_ctrl_file = 'unset' From 95737dd782a6651647832c121890c63aac4b5143 Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 14 Sep 2020 12:07:18 +0200 Subject: [PATCH 081/578] minor typo in biogeochem/EDPatchDynamicsMod.F90 Co-authored-by: Charlie Koven --- biogeochem/EDPatchDynamicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 663471fb6d..b99b6a430e 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2518,7 +2518,7 @@ subroutine fuse_2_patches(csite, dp, rp) else snull = 1 rp%shortest => currentCohort - Endif + endif call insert_cohort(currentCohort, rp%tallest, rp%shortest, tnull, snull, storebigcohort, storesmallcohort) From 9f38e0c07861f902136212120672ef65f7b92a98 Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 14 Sep 2020 12:08:35 +0200 Subject: [PATCH 082/578] comment in biogeochem/EDPatchDynamicsMod.F90 Co-authored-by: Charlie Koven --- biogeochem/EDPatchDynamicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index b99b6a430e..216d21c747 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2663,7 +2663,7 @@ subroutine terminate_patches(currentSite) ! patch. As mentioned earlier, we try not to fuse it. gotfused = .true. - else !anthro label + else !anthro labels of two patches are not the same if (count_cycles .gt. 0) then ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its older sibling From 74a4fe7f984a2d127b3d835a6b1634b5fc82ca1c Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 04:17:10 -0600 Subject: [PATCH 083/578] typo in EDPftvarcon.F90 --- main/EDPftvarcon.F90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 4dd3594af9..a63b0e8797 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -2780,14 +2780,15 @@ subroutine FatesCheckParams(is_master, parteh_mode) ! check that the host-fates PFT map adds to one in both dimension do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) - sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_oft)) - if(abs(sumarea-1.0_r8).gt. )then + sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft)) + if(abs(sumarea-1.0_r8).gt. nearzero )then write(fates_log(),*) 'The distribution of this host land model PFT :',hlm_pft write(fates_log(),*) 'into FATES PFTs, does not add up to 1.0.' write(fates_log(),*) 'Error is:',sumarea-1.0_r8 - write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_oft) + write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft) write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) + end if end do !ipft !! ! Checks for HYDRO From 6b1d5f2dbc498c2943c3006621b9ba3ea32a7f65 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 04:43:03 -0600 Subject: [PATCH 084/578] removing modifications from terminate_patches --- biogeochem/EDPatchDynamicsMod.F90 | 109 +----------------------------- 1 file changed, 2 insertions(+), 107 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 216d21c747..5279b166ac 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2604,15 +2604,10 @@ subroutine terminate_patches(currentSite) ! !LOCAL VARIABLES: type(ed_patch_type), pointer :: currentPatch type(ed_patch_type), pointer :: olderPatch - type(ed_patch_type), pointer :: oldercPatch type(ed_patch_type), pointer :: youngerPatch - type(ed_patch_type), pointer :: fusingPatch integer, parameter :: max_cycles = 10 ! After 10 loops through ! You should had fused integer :: count_cycles - integer :: is_youngest - integer :: is_oldest - integer :: found_fusion_patch logical :: gotfused real(r8) areatot ! variable for checking whether the total patch area is wrong. @@ -2622,10 +2617,9 @@ subroutine terminate_patches(currentSite) currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - oldercpatch => currentPatch%older + if(currentPatch%area <= min_patch_area)then - if(hlm_use_nocomp.eq.ifalse)then !just fuse to older or younger patch ! Even if the patch area is small, avoid fusing it into its neighbor ! if it is the youngest of all patches. We do this in attempts to maintain @@ -2703,96 +2697,6 @@ subroutine terminate_patches(currentSite) endif ! older or younder patch endif ! very small area - else !nocomp. We cannot fuse to patches with a different PFT identity in no competition mode. - - ! Each patch has a PFT identity, and so cannot simply fuse to the older or younger patch - ! For each small current patch, we must first search older patch candidates, and then younger - ! patch candidates. - ! need to think about the youngest of PFT logic later. - - is_youngest = itrue !try and find a younger same-PFT patch - ! discover if this is the youngest patch of its PFT - fusingPatch => currentPatch%younger !if it's the youngest overall then it's defacto youngest of PFT - do while(associated(fusingPatch).and.is_youngest.eq.itrue) - if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then - is_youngest = ifalse ! we found a yonger patch, so this isn't the youngest one. - endif ! PFT - if(associated(fusingpatch%younger))then - if(fusingpatch%patchno.eq.fusingpatch%younger%patchno)then - write(*,*) 'is_youngest patch list error',fusingpatch%patchno,fusingpatch%younger%patchno - endif - endif - fusingPatch => fusingPatch%younger - enddo !fusing patch - - is_oldest = itrue !try and find a younger same-PFT patch - !-------------------------------------------------- - ! n.b. The following code is to figure out how to - ! terminate small patches in nocomp mode - ! It was written in the context of the multi-patch version - ! which is currently inactive and may or may not be needed in the - ! single patch version. - !-------------------------------------------------- - ! discover if this is the youngest patch of its PFT - fusingPatch => currentPatch%older !if it's the youngest overall then it's defacto youngest of PFT - do while(associated(fusingPatch).and.is_oldest.eq.itrue) - if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then - is_oldest = ifalse ! we found a yonger patch, so this isn't the youngest one. - endif ! PFT - fusingPatch => fusingPatch%older - enddo !fusing patch - - if (is_youngest.eq.ifalse .or. currentPatch%area <= min_patch_area_forced ) then - found_fusion_patch = ifalse - - fusingPatch => currentPatch%older - do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) - olderPatch => fusingPatch%older - if(associated(fusingpatch%younger))then - if(fusingpatch%patchno.eq.fusingpatch%younger%patchno)then - write(*,*) 'fuse older patch list error',fusingpatch%patchno,fusingpatch%younger%patchno - endif - endif - if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then - if(debug) & - write(fates_log(),*) 'fusing to older patch of same PFT - this one is too small',& - currentPatch%area, fusingPatch%area, & - currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label, & - currentPatch%patchno, fusingPatch%patchno - call fuse_2_patches(currentSite, currentPatch, fusingPatch) - currentPatch => fusingPatch !redirect rest of main loop back to this cp - found_fusion_patch=itrue - endif ! PFT - fusingPatch => olderPatch - enddo !fusing patch - - if(associated(currentPatch).and.found_fusion_patch.eq.ifalse)then - ! if no older patches, search younger ones. - fusingPatch => currentPatch%younger - do while(associated(fusingPatch).and.found_fusion_patch.eq.ifalse ) - olderPatch => fusingPatch%older - - if(fusingPatch%nocomp_pft_label.eq.currentPatch%nocomp_pft_label)then - if(debug) & - write(fates_log(),*) 'fusing to younger patch of same PFT - this one is too small',& - currentPatch%area, fusingPatch%area , & - currentPatch%nocomp_pft_label, fusingPatch%nocomp_pft_label, & - currentPatch%patchno, fusingPatch%patchno,& - is_youngest,is_oldest - call fuse_2_patches(currentSite, currentPatch, fusingPatch) - currentPatch => fusingPatch - found_fusion_patch=itrue - endif ! PFT - fusingPatch => olderPatch - enddo !fusing patch - endif !current patch exists. - - - endif ! not youngest, or is very small patch - endif !nocomp - endif ! small area - - ! It is possible that an incredibly small patch just fused into another incredibly ! small patch, resulting in an incredibly small patch. It is also possible that this ! resulting incredibly small patch is the oldest patch. If this was true than @@ -2810,11 +2714,6 @@ subroutine terminate_patches(currentSite) end if if(count_cycles > max_cycles) then - if(is_oldest.eq.itrue.and.is_youngest.eq.itrue.and.hlm_use_nocomp)then - write(fates_log(),*) 'this is the only patch of this PFT',currentPatch%area - currentPatch => currentPatch%older - count_cycles = 0 - else !not the only patch write(fates_log(),*) 'FATES is having difficulties fusing very small patches.' write(fates_log(),*) 'It is possible that a either a secondary or primary' write(fates_log(),*) 'patch has become the only patch of its kind, and it is' @@ -2822,17 +2721,13 @@ subroutine terminate_patches(currentSite) write(fates_log(),*) 'disabling the endrun statement following this message.' write(fates_log(),*) 'FATES may or may not continue to operate within error' write(fates_log(),*) 'tolerances, but will generate another fail if it does not.' - - write(fates_log(),*) 'cp pft',currentPatch%nocomp_pft_label,currentPatch%area - call endrun(msg=errMsg(sourcefile, __LINE__)) ! Note to user. If you DO decide to remove the end-run above this line ! Make sure that you keep the pointer below this line, or you will get ! an infinite loop. - currentPatch => oldercPatch + currentPatch => currentPatch%older count_cycles = 0 - end if !only patch end if !count cycles call set_patchno(currentSite) !redo patch numbering for every potential termination. !n.b. could put filter in here for actual terminations to save time. From a0efc39d7aaca9bd0acc3f7bc5de39390102c1ef Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 04:55:43 -0600 Subject: [PATCH 085/578] endif statements in teminate patches --- biogeochem/EDPatchDynamicsMod.F90 | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 5279b166ac..3c69d3b463 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2690,13 +2690,11 @@ subroutine terminate_patches(currentSite) currentPatch%anthro_disturbance_label = youngerPatch%anthro_disturbance_label call fuse_2_patches(currentSite, youngerPatch, currentPatch) gotfused = .true. - endif - endif - ! The fusion process has updated the "younger" pointer on currentPatch - - endif ! older or younder patch - endif ! very small area - + endif ! count cycles + endif ! anthro labels + endif ! has an older patch + endif ! is not the youngest patch + endif ! very small patch ! It is possible that an incredibly small patch just fused into another incredibly ! small patch, resulting in an incredibly small patch. It is also possible that this ! resulting incredibly small patch is the oldest patch. If this was true than @@ -2704,9 +2702,8 @@ subroutine terminate_patches(currentSite) ! Think this is impossible? No, this really happens, especially when we have fires. ! So, we don't move forward until we have merged enough area into this thing. - if(currentPatch%area > min_patch_area_forced)then - currentPatch => oldercPatch + currentPatch => currentPatch%older count_cycles = 0 else From 948eb2a64ab3dfa95c8765809dd6f0f3ff10f8b8 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 04:59:40 -0600 Subject: [PATCH 086/578] spacing in terminate patches --- biogeochem/EDPatchDynamicsMod.F90 | 9 --------- 1 file changed, 9 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 3c69d3b463..bc0aae4c66 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2555,15 +2555,10 @@ subroutine fuse_2_patches(csite, dp, rp) youngerp => null() end if - - - ! We have no need for the dp pointer anymore, we have passed on it's legacy call dealloc_patch(dp) - deallocate(dp) - if(associated(youngerp))then ! Update the younger patch's new older patch (because it isn't dp anymore) youngerp%older => olderp @@ -2627,8 +2622,6 @@ subroutine terminate_patches(currentSite) ! However, if the patch to be fused is excessivlely small, then fuse ! at all costs. If it is not fused, it will make - ! the current patch is NOT the youngest. Or is it very very small. - ! so, skip merging if it is the youngest, unless the youngest is tiny. if ( .not.associated(currentPatch,currentSite%youngest_patch) .or. & currentPatch%area <= min_patch_area_forced ) then @@ -2729,8 +2722,6 @@ subroutine terminate_patches(currentSite) call set_patchno(currentSite) !redo patch numbering for every potential termination. !n.b. could put filter in here for actual terminations to save time. - fusingpatch => currentSite%oldest_patch - enddo ! current patch loop !check area is not exceeded From 025aabf0e0e62dd91f94f934cf87ef19bc14e57e Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 05:01:23 -0600 Subject: [PATCH 087/578] remove set_patchno call --- biogeochem/EDPatchDynamicsMod.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index bc0aae4c66..7147f39595 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2719,8 +2719,6 @@ subroutine terminate_patches(currentSite) currentPatch => currentPatch%older count_cycles = 0 end if !count cycles - call set_patchno(currentSite) !redo patch numbering for every potential termination. - !n.b. could put filter in here for actual terminations to save time. enddo ! current patch loop From d0a525622d60baf51bdbbfbcef6bc8490295d53e Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 07:50:49 -0600 Subject: [PATCH 088/578] code to manage bare gound in SP mode --- main/EDInitMod.F90 | 37 ++++++++++++++++++++++++++----------- 1 file changed, 26 insertions(+), 11 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 782c3481b3..c8c5d58e50 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -332,15 +332,20 @@ subroutine set_site_properties( nsites, sites,bc_in ) ! the bare ground will no longer be proscribed and should emerge from FATES ! this may or may not be the right way to deal with this? - sumarea = sum(sites(s)%area_pft(1:numpft)) - do ft = 1,numpft - if(sumarea.gt.0._r8)then - sites(s)%area_pft(ft) = sites(s)%area_pft(ft)/sumarea - else - sites(s)%area_pft(ft)= 1.0_r8/numpft - write(*,*) 'setting totally bare patch to all pfts.',s,sumarea,sites(s)%area_pft(ft) - end if - end do !ft + if(hlm_use_sp.eq.ifalse)then + sumarea = sum(sites(s)%area_pft(1:numpft)) + do ft = 1,numpft + if(sumarea.gt.0._r8)then + sites(s)%area_pft(ft) = sites(s)%area_pft(ft)/sumarea + else + sites(s)%area_pft(ft)= 1.0_r8/numpft + write(*,*) 'setting totally bare patch to all pfts.',s,sumarea,sites(s)%area_pft(ft) + end if + else ! for sp mode, assert a bare ground patch + sites(s)%area_bareground = 1.0_r8 - sumarea + end if !sp mode + end do !ft + end if !fixed biogeog do ft = 1,numpft @@ -441,6 +446,9 @@ subroutine init_patches( nsites, sites, bc_in) sites(s)%spread = init_spread_near_bare_ground if(hlm_use_nocomp.eq.itrue)then no_new_patches = numpft + if(hlm_use_sp.eq.itrue)then + no_new_patches = numpft + 1 ! bare ground patch in SP mode. + endif ! allocate(newppft(numpft)) else no_new_patches = 1 @@ -467,7 +475,12 @@ subroutine init_patches( nsites, sites, bc_in) end if else ! The default case is initialized w/ one patch with the area of the whole site. newparea = area - end if + end if !nocomp mode + + if(hlm_use_sp.eq.itrue.and.n.gt.numpft)then + newparea = sites(s)%area_bareground + nocomp_pft = 0 + end if if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode allocate(newp) @@ -506,7 +519,9 @@ subroutine init_patches( nsites, sites, bc_in) end do sitep => sites(s) - call init_cohorts(sitep, newp, bc_in(s)) + if(hlm_use_sp.eq.ifalse.and.nocomp_pft.eq.0)then !don't initialize cohorts for SP bare ground patch + call init_cohorts(sitep, newp, bc_in(s)) + end if end if end do !no new patches From 573dad509748f443e4a971a717545283c4fd16fa Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 14 Sep 2020 08:08:16 -0600 Subject: [PATCH 089/578] debugging after merge --- biogeochem/EDPhysiologyMod.F90 | 9 ++++----- main/EDInitMod.F90 | 3 ++- main/EDPftvarcon.F90 | 7 ++++--- main/EDTypesMod.F90 | 2 ++ 4 files changed, 12 insertions(+), 9 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 9aa9798132..ea9d4d783c 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1363,8 +1363,6 @@ subroutine satellite_phenology(currentSite, bc_in) integer :: s ! site index - real(r8) :: spread ! need to send a fixed value of patch spread to carea_allom - ! To Do in this routine. ! Get access to HLM input varialbes. ! Weight them by PFT @@ -1437,8 +1435,8 @@ subroutine satellite_phenology(currentSite, bc_in) !------------------------------------------ ! Calculate dbh from input height, and c_area from dbh !------------------------------------------ - currentCohort%hite = currentPatch%sp_htop - call h2d_allom(temp_cohort%hite,ft,temp_cohort%dbh) + currentCohort%hite = currentSite%sp_htop(fates_pft) + call h2d_allom(currentCohort%hite,fates_pft,currentCohort%dbh) currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. spread = 0.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in @@ -1453,7 +1451,8 @@ subroutine satellite_phenology(currentSite, bc_in) ! ------------------------------------------ ! Calculate leaf carbon from target treelai ! ------------------------------------------ - currentCohort%treelai = currentPatch%sp_tlai + currentCohort%treelai = currentSite%sp_tlai(fates_pft) + leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index c8c5d58e50..c8c5c50e48 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -42,6 +42,7 @@ module EDInitMod use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_use_inventory_init use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog + use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : numpft use FatesInterfaceTypesMod , only : nleafage use FatesInterfaceTypesMod , only : nlevsclass @@ -341,10 +342,10 @@ subroutine set_site_properties( nsites, sites,bc_in ) sites(s)%area_pft(ft)= 1.0_r8/numpft write(*,*) 'setting totally bare patch to all pfts.',s,sumarea,sites(s)%area_pft(ft) end if + end do !ft else ! for sp mode, assert a bare ground patch sites(s)%area_bareground = 1.0_r8 - sumarea end if !sp mode - end do !ft end if !fixed biogeog diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index ab46fa45ae..efd529aa2a 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -2778,14 +2778,15 @@ subroutine FatesCheckParams(is_master, parteh_mode) ! check that the host-fates PFT map adds to one in both dimension do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) - sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_oft)) - if(abs(sumarea-1.0_r8).gt. )then + sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft)) + if(abs(sumarea-1.0_r8).gt.nearzero)then write(fates_log(),*) 'The distribution of this host land model PFT :',hlm_pft write(fates_log(),*) 'into FATES PFTs, does not add up to 1.0.' write(fates_log(),*) 'Error is:',sumarea-1.0_r8 - write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_oft) + write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft) write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) + end if end do !ipft !! ! Checks for HYDRO diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 4e1121a139..e2cbcfbf11 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -666,6 +666,8 @@ module EDTypesMod real(r8), allocatable :: sp_tlai(:) ! target TLAI per FATES pft real(r8), allocatable :: sp_tsai(:) ! target TSAI per FATES pft real(r8), allocatable :: sp_htop(:) ! target HTOP per FATES pft + + real(r8) :: area_bareground ! in SP mode we assert a bare ground fraction ! Mass Balance (allocation for each element) From 867ff49e3441548aa0abf5bd8f783798ec853969 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 15 Sep 2020 03:13:22 -0600 Subject: [PATCH 090/578] fixing bare ground initialization errors. now runs --- main/EDInitMod.F90 | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index c8c5c50e48..ced8c2740b 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -313,6 +313,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) ! add up the area associated with each FATES PFT ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) ! hlm_pft_map is the area of that land in each FATES PFT (from param file) + sites(s)%area_pft(1:numpft) = 0._r8 do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts @@ -321,10 +322,11 @@ subroutine set_site_properties( nsites, sites,bc_in ) end do end do !hlm_pft + sumarea = sum(sites(s)%area_pft(1:numpft)) do ft = 1,numpft - if(sites(s)%area_pft(ft).lt.0.01_r8)then + if(sites(s)%area_pft(ft).lt.0.01_r8.and.sites(s)%area_pft(ft).gt.0.0_r8)then + if ( debug ) write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) sites(s)%area_pft(ft)=0.0_r8 !remove tiny patches to prevent numerical errors in terminate patches - write(*,*) 'removing small pft patches',sites(s)%lon,sites(s)%lat,ft,sites(s)%area_pft(ft) endif end do @@ -340,10 +342,11 @@ subroutine set_site_properties( nsites, sites,bc_in ) sites(s)%area_pft(ft) = sites(s)%area_pft(ft)/sumarea else sites(s)%area_pft(ft)= 1.0_r8/numpft - write(*,*) 'setting totally bare patch to all pfts.',s,sumarea,sites(s)%area_pft(ft) end if end do !ft else ! for sp mode, assert a bare ground patch + sumarea = sum(sites(s)%area_pft(1:numpft)) + ! here we subsume the destroyed tiny patches into the bare ground fraction. sites(s)%area_bareground = 1.0_r8 - sumarea end if !sp mode @@ -479,7 +482,7 @@ subroutine init_patches( nsites, sites, bc_in) end if !nocomp mode if(hlm_use_sp.eq.itrue.and.n.gt.numpft)then - newparea = sites(s)%area_bareground + newparea = sites(s)%area_bareground * area nocomp_pft = 0 end if @@ -534,13 +537,12 @@ subroutine init_patches( nsites, sites, bc_in) if ( debug ) write(fates_log(),*) 'test links',s,newp%nocomp_pft_label,tota newp=>newp%younger end do - if(abs(tota-area).gt.nearzero)then - write(*,*) 'error in assigning areas in init patch',s,tota-area + if(abs(tota-area).gt.nearzero*area)then + write(*,*) 'error in assigning areas in init patch',s,sites(s)%lat,tota-area,tota endif ! For carbon balance checks, we need to initialize the ! total carbon stock - write(*,*) 'calling sitemassstock',s do el=1,num_elements call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & biomass_stock,litter_stock,seed_stock) From 49d1eee8f928514affbb30a9820a9d976cc032ae Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 16 Sep 2020 01:56:54 -0600 Subject: [PATCH 091/578] moved SP check on totalbalancecheck into subroutine --- main/EDMainMod.F90 | 43 +++++++++++++++++-------------------------- 1 file changed, 17 insertions(+), 26 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 7d3df65365..6d13609701 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -168,9 +168,8 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call ZeroLitterFluxes(currentSite) ! Zero mass balance - if(hlm_use_sp.eq.ifalse)then - call TotalBalanceCheck(currentSite, 0) - end if + call TotalBalanceCheck(currentSite, 0) + ! We do not allow phenology while in ST3 mode either, it is hypothetically ! possible to allow this, but we have not plugged in the litter fluxes ! of flushing or turning over leaves for non-dynamics runs @@ -220,9 +219,8 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) enddo end if - if(hlm_use_sp.eq.ifalse)then - call TotalBalanceCheck(currentSite,1) - end if + call TotalBalanceCheck(currentSite,1) + if( hlm_use_ed_st3.eq.ifalse .and.hlm_use_sp.eq.ifalse ) then currentPatch => currentSite%oldest_patch @@ -245,9 +243,8 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) enddo end if - if(hlm_use_sp.eq.ifalse)then - call TotalBalanceCheck(currentSite,2) - end if + call TotalBalanceCheck(currentSite,2) + !********************************************************************************* ! Patch dynamics sub-routines: fusion, new patch creation (spwaning), termination. !********************************************************************************* @@ -273,9 +270,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) call spawn_patches(currentSite, bc_in) end if - if(hlm_use_sp.eq.ifalse)then - call TotalBalanceCheck(currentSite,3) - end if + call TotalBalanceCheck(currentSite,3) ! fuse on the spawned patches. if ( do_patch_dynamics.eq.itrue ) then @@ -292,18 +287,15 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) end if ! SP has changes in leaf carbon but we don't expect them to be in balance. - if(hlm_use_sp.eq.ifalse)then - call TotalBalanceCheck(currentSite,4) - end if + call TotalBalanceCheck(currentSite,4) ! kill patches that are too small if ( do_patch_dynamics.eq.itrue ) then call terminate_patches(currentSite) end if - if(hlm_use_sp.eq.ifalse)then - call TotalBalanceCheck(currentSite,5) - endif + call TotalBalanceCheck(currentSite,5) + end subroutine ed_ecosystem_dynamics !-------------------------------------------------------------------------------! @@ -570,18 +562,15 @@ subroutine ed_update_site( currentSite, bc_in ) ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch !----------------------------------------------------------------------- - - call canopy_spread(currentSite) - if(hlm_use_sp.eq.ifalse)then - call TotalBalanceCheck(currentSite,6) + call canopy_spread(currentSite) end if + call TotalBalanceCheck(currentSite,6) + call canopy_structure(currentSite, bc_in) - if(hlm_use_sp.eq.ifalse)then - call TotalBalanceCheck(currentSite,final_check_id) - end if + call TotalBalanceCheck(currentSite,final_check_id) currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) @@ -657,6 +646,8 @@ subroutine TotalBalanceCheck (currentSite, call_index ) ! upon fail (lots of text) !----------------------------------------------------------------------- + if(hlm_use_sp.eq.ifalse)then + change_in_stock = 0.0_r8 @@ -768,7 +759,7 @@ subroutine TotalBalanceCheck (currentSite, call_index ) end if end do - + end if ! not SP mode end subroutine TotalBalanceCheck ! ===================================================================================== From 40686b41b61a35c4195a7a76792b0f0414f821b8 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 17 Sep 2020 02:24:45 -0600 Subject: [PATCH 092/578] changes to EDPhysiology to get treelai calcas right --- biogeochem/EDPhysiologyMod.F90 | 70 +++++++++++++++++++++++----------- 1 file changed, 48 insertions(+), 22 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index ea9d4d783c..01ba620d66 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -35,6 +35,7 @@ module EDPhysiologyMod use EDTypesMod , only : numlevsoil_max use EDTypesMod , only : numWaterMem use EDTypesMod , only : dl_sf, dinc_ed, area_inv + use EDTypesMod , only : AREA use FatesLitterMod , only : ncwd use FatesLitterMod , only : ndcmpy use FatesLitterMod , only : ilabile @@ -1357,7 +1358,8 @@ subroutine satellite_phenology(currentSite, bc_in) real(r8) :: spread ! dummy value of canopy spread to estimate c_area real(r8) :: leaf_c ! leaf carbon estimated to generate target tlai - + real(r8) :: sumarea + real(r8) :: check_treelai integer :: fates_pft ! fates pft numer for weighting loop integer :: hlm_pft ! host land model pft number for weighting loop. integer :: s ! site index @@ -1372,44 +1374,51 @@ subroutine satellite_phenology(currentSite, bc_in) ! figure out how this will interact with the canopy_structure routines. ! determine what 'n' should be from the canopy height. - currentPatch => currentSite%oldest_patch - do while (associated(currentPatch)) + + currentSite%sp_tlai(1:numpft) = 0._r8 + currentSite%sp_tsai(1:numpft) = 0._r8 + currentSite%sp_htop(1:numpft) = 0._r8 + + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) ! WEIGHTING OF FATES PFTs on to HLM_PFTs ! add up the area associated with each FATES PFT ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) ! hlm_pft_map is the area of that land in each FATES PFT (from param file) - currentSite%sp_tlai(1:numpft) = 0._r8 - currentSite%sp_tsai(1:numpft) = 0._r8 - currentSite%sp_htop(1:numpft) = 0._r8 - ! weight each fates PFT target for lai, sai and htop by the area of the ! contrbuting HLM PFTs. ! we only need to do this for the patch/fates_pft we are currently in fates_pft = currentPatch%nocomp_pft_label + + sumarea = 0.0_r8 do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) - if(bc_in%pft_areafrac(hlm_pft).gt.0.0_r8)then - !leaf area index + if(bc_in%pft_areafrac(hlm_pft) * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft).gt.0.0_r8)then + sumarea = sumarea + bc_in%pft_areafrac(hlm_pft)*EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) + !leaf area index currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & - bc_in%hlm_sp_tlai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) + bc_in%hlm_sp_tlai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & + * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) !stem area index currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & - bc_in%hlm_sp_tsai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) + bc_in%hlm_sp_tsai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & + * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) ! canopy height currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) + & - bc_in%hlm_sp_htop(hlm_pft) * bc_in%pft_areafrac(hlm_pft) + bc_in%hlm_sp_htop(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & + * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) end if ! there is some area in this patch end do !hlm_pft ! weight for total area in each patch/fates_pft if(currentPatch%area.gt.0.0_r8)then + currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) & + /(currentPatch%area/area) + currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) & + /(currentPatch%area/area) currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & - /currentPatch%area - currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & - /currentPatch%area - currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & - /currentPatch%area + /(currentPatch%area/area) endif ! ------------------------------------------------------------ @@ -1424,12 +1433,16 @@ subroutine satellite_phenology(currentSite, bc_in) ! Do some checks if(associated(currentCohort%shorter))then - write(*,*) "there is more than one cohort in SP mode" + write(fates_log(),*) 'SP mode has >1 cohort' + write(fates_log(),*) "SP mode >1 cohort: PFT",currentCohort%pft, currentCohort%shorter%pft + write(fates_log(),*) "SP mode >1 cohort: CL",currentCohort%canopy_layer, currentCohort%shorter%canopy_layer + call endrun(msg=errMsg(sourcefile, __LINE__)) end if fates_pft =currentCohort%pft if(fates_pft.ne.currentPatch%nocomp_pft_label)then - write(*,*) 'wrong PFT label in cohort in SP mode',fates_pft,currentPatch%nocomp_pft_label + write(fates_log(),*) 'wrong PFT label in cohort in SP mode',fates_pft,currentPatch%nocomp_pft_label + call endrun(msg=errMsg(sourcefile, __LINE__)) end if !------------------------------------------ @@ -1437,12 +1450,14 @@ subroutine satellite_phenology(currentSite, bc_in) !------------------------------------------ currentCohort%hite = currentSite%sp_htop(fates_pft) call h2d_allom(currentCohort%hite,fates_pft,currentCohort%dbh) - currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. - spread = 0.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. + + currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. + spread = 1.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in ! SP mode. call carea_allom(currentCohort%dbh,currentCohort%n,spread,currentCohort%pft,currentCohort%c_area) + !------------------------------------------ ! Calculate canopy N assuming patch area is full !------------------------------------------ @@ -1453,9 +1468,21 @@ subroutine satellite_phenology(currentSite, bc_in) ! ------------------------------------------ currentCohort%treelai = currentSite%sp_tlai(fates_pft) + ! correct c_area for the new nplant + currentCohort%c_area = currentCohort%c_area * currentCohort%n + leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) + !check reverse - maybe can delete eventually + check_treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & + currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + + if( abs(currentCohort%treelai-check_treelai).gt.nearzero)then + write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%pft + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if call SetState(currentCohort%prt,leaf_organ,1,leaf_c,1) ! assert sai @@ -1979,7 +2006,6 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) ! ----------------------------------------------------------------------------------- call prt%CheckInitialConditions() - ! This initializes the cohort call create_cohort(currentSite,currentPatch, temp_cohort%pft, temp_cohort%n, & temp_cohort%hite, temp_cohort%coage, temp_cohort%dbh, prt, & From 47a005778101bc6bffeb6bda404832bf4c52157c Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 17 Sep 2020 02:27:18 -0600 Subject: [PATCH 093/578] changes to FatesAllometryMod.F90 to get treelai right --- biogeochem/FatesAllometryMod.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index c397ab5bea..469cff083d 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -810,21 +810,21 @@ real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25t slat = g_per_kg * EDPftvarcon_inst%slatop(pft) ! m2/g to m2/kg leafc_per_unitarea = leaf_c/(c_area/nplant) !KgC/m2 - + if(treelai > 0.0_r8)then ! Coefficient for exponential decay of 1/sla with canopy depth: kn = decay_coeff_kn(pft,vcmax25top) - ! take PFT-level maximum SLA value, even if under a thick canopy (which has units of m2/gC), ! and put into units of m2/kgC sla_max = g_per_kg *EDPftvarcon_inst%slamax(pft) ! Leafc_per_unitarea at which sla_max is reached due to exponential sla profile in canopy: leafc_slamax = max(0.0_r8,(slat - sla_max) / (-1.0_r8 * kn * slat * sla_max)) - + ! treelai at which we reach maximum sla. tree_lai_at_slamax = (log( 1.0_r8- kn * slat * leafc_slamax)) / (-1.0_r8 * kn) - if(treelai > tree_lai_at_slamax)then + + if(treelai < tree_lai_at_slamax)then ! Inversion of the exponential phase calculation of treelai for a given leafc_per_unitarea leafc_per_unitarea = (1.0_r8-exp(treelai*(-1.0_r8 * kn)))/(kn*slat) else ! we exceed the maxumum sla @@ -834,7 +834,7 @@ real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25t leafc_linear_phase = (treelai-tree_lai_at_slamax)/sla_max leafc_per_unitarea = leafc_slamax + leafc_linear_phase end if - + leafc_from_treelai = leafc_per_unitarea*(c_area/nplant) else leafc_from_treelai = 0.0_r8 endif ! (leafc_per_unitarea > 0.0_r8) From b7fa39c7b3e11a7f060dd6805427140281d5ef7f Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 17 Sep 2020 02:31:15 -0600 Subject: [PATCH 094/578] added check for no cohorts in bare patch --- biogeochem/EDCanopyStructureMod.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 0e2de53919..27fb709409 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1333,7 +1333,6 @@ subroutine canopy_summarization( nsites, sites, bc_in ) call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& currentCohort%pft,currentCohort%c_area) - currentCohort%treelai = tree_lai(leaf_c, & currentCohort%pft, currentCohort%c_area, currentCohort%n, & currentCohort%canopy_layer, currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) @@ -1346,7 +1345,10 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area endif endif - + if(currentPatch%nocomp_pft_label.eq.0)then + write(*,*) 'cohorts in barepatch',currentPatch%total_canopy_area,currentPatch%nocomp_pft_label,currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if ! Check for erroneous zero values. if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then write(fates_log(),*) 'FATES: dbh or n is zero in canopy_summarization', & @@ -1964,7 +1966,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! Calculate area indices for output boundary to HLM ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) - bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') @@ -2062,6 +2063,7 @@ function calc_areaindex(cpatch,ai_type) result(ai) cpatch%tlai_profile(cl,ft,1:cpatch%nrad(cl,ft))) enddo enddo + elseif (trim(ai_type) == 'esai') then do cl = 1,cpatch%NCL_p do ft = 1,numpft From d755c44d7fd99aa02fa95b5f500102940ab89f16 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 17 Sep 2020 02:33:36 -0600 Subject: [PATCH 095/578] added check to avoid copying cohorts in sp mode --- biogeochem/EDCohortDynamicsMod.F90 | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index a4124d9b34..8e6fa26125 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -9,6 +9,7 @@ module EDCohortDynamicsMod use FatesInterfaceTypesMod , only : hlm_freq_day use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : fates_unset_int @@ -226,7 +227,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & new_cohort%laimemory = laimemory new_cohort%sapwmemory = sapwmemory new_cohort%structmemory = structmemory - + write(*,*) 'createing cohort', pft, nn, clayer ! This sets things like vcmax25top, that depend on the ! leaf age fractions (which are defined by PARTEH) call UpdateCohortBioPhysRates(new_cohort) @@ -1664,6 +1665,11 @@ subroutine copy_cohort( currentCohort,copyc ) o => currentCohort n => copyc + if(hlm_use_sp.eq.itrue)then + write(fates_log(),*) 'copying cohort shouldnt happen in SP mode' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + n%indexnumber = fates_unset_int ! VEGETATION STRUCTURE From 06db8290f410a4b1dca6f99ee20b37caa82b7fdf Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 17 Sep 2020 02:42:35 -0600 Subject: [PATCH 096/578] remove write --- biogeochem/EDCohortDynamicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 8e6fa26125..d5dd51be4e 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -227,7 +227,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & new_cohort%laimemory = laimemory new_cohort%sapwmemory = sapwmemory new_cohort%structmemory = structmemory - write(*,*) 'createing cohort', pft, nn, clayer + ! This sets things like vcmax25top, that depend on the ! leaf age fractions (which are defined by PARTEH) call UpdateCohortBioPhysRates(new_cohort) From 8c8b559cb1475d5a00af7d9851f17ca71c00420b Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 18 Sep 2020 04:28:25 -0600 Subject: [PATCH 097/578] changed copy cohort error --- biogeochem/EDCohortDynamicsMod.F90 | 3 ++- biogeochem/EDPhysiologyMod.F90 | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index d5dd51be4e..0b9ab3bc60 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1666,7 +1666,8 @@ subroutine copy_cohort( currentCohort,copyc ) n => copyc if(hlm_use_sp.eq.itrue)then - write(fates_log(),*) 'copying cohort shouldnt happen in SP mode' + write(fates_log(),*) 'copying cohort shouldnt happen in SP mode,area,pft',o%c_area,o%pft + call endrun(msg=errMsg(sourcefile, __LINE__)) end if diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 01ba620d66..3f9ede346a 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1479,8 +1479,8 @@ subroutine satellite_phenology(currentSite, bc_in) currentCohort%n, currentCohort%canopy_layer, & currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) - if( abs(currentCohort%treelai-check_treelai).gt.nearzero)then - write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%pft + if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzerio (10^-16 typically) + write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%treelai-check_treelai call endrun(msg=errMsg(sourcefile, __LINE__)) end if call SetState(currentCohort%prt,leaf_organ,1,leaf_c,1) From c5d084adf06202af2933674917c24c1cc4760390 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 21 Sep 2020 04:45:58 -0600 Subject: [PATCH 098/578] checks in EDcanopystructure --- biogeochem/EDCanopyStructureMod.F90 | 47 ++++++++++++++++-------- main/FatesHistoryInterfaceMod.F90 | 2 +- parameter_files/fates_params_default.cdl | 7 ++-- 3 files changed, 37 insertions(+), 19 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 27fb709409..9500ba8eef 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -27,9 +27,11 @@ module EDCanopyStructureMod use FatesInterfaceTypesMod , only : hlm_days_per_year use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking + use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : numpft use FatesPlantHydraulicsMod, only : UpdateH2OVeg,InitHydrCohort, RecruitWaterStorage use EDTypesMod , only : maxCohortsPerPatch + use shr_infnan_mod , only : isnan => shr_infnan_isnan use PRTGenericMod, only : leaf_organ use PRTGenericMod, only : all_carbon_elements @@ -149,7 +151,7 @@ subroutine canopy_structure( currentSite , bc_in ) !---------------------------------------------------------------------- - + if(hlm_use_sp.eq.ifalse)then currentPatch => currentSite%oldest_patch ! ! zero site-level demotion / promotion tracking info @@ -321,7 +323,7 @@ subroutine canopy_structure( currentSite , bc_in ) currentPatch => currentPatch%younger enddo !patch - + end if ! SP mode return end subroutine canopy_structure @@ -364,11 +366,10 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) real(r8) :: total_crownarea_of_tied_cohorts ! First, determine how much total canopy area we have in this layer - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer) demote_area = arealayer - currentPatch%area - + if ( demote_area > area_target_precision ) then ! Is this layer currently over-occupied? @@ -378,10 +379,9 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) sumweights = 0.0_r8 currentCohort => currentPatch%shortest do while (associated(currentCohort)) - call carea_allom(currentCohort%dbh,currentCohort%n, & currentSite%spread,currentCohort%pft,currentCohort%c_area) - + if(debug) then if(currentCohort%c_area<0._r8)then write(fates_log(),*) 'negative c_area stage 1d: ',currentCohort%dbh,i_lyr,currentCohort%n, & @@ -655,7 +655,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) ! remains in the upper-story. The original is the one ! demoted to the understory - + allocate(copyc) ! Initialize the PARTEH object and point to the @@ -1330,9 +1330,10 @@ subroutine canopy_summarization( nsites, sites, bc_in ) call coagetype_class_index(currentCohort%coage,currentCohort%pft, & currentCohort%coage_class,currentCohort%coage_by_pft_class) end if - + if(hlm_use_sp.eq.ifalse)then call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& currentCohort%pft,currentCohort%c_area) + endif currentCohort%treelai = tree_lai(leaf_c, & currentCohort%pft, currentCohort%c_area, currentCohort%n, & currentCohort%canopy_layer, currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) @@ -1346,9 +1347,17 @@ subroutine canopy_summarization( nsites, sites, bc_in ) endif endif if(currentPatch%nocomp_pft_label.eq.0)then - write(*,*) 'cohorts in barepatch',currentPatch%total_canopy_area,currentPatch%nocomp_pft_label,currentCohort%c_area + write(fates_log(),*) 'cohorts in barepatch',currentPatch%total_canopy_area,currentPatch%nocomp_pft_label,currentCohort%c_area call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if(hlm_use_sp.eq.itrue.and.associated(currentPatch%tallest%shorter))then + write(fates_log(),*) 'morethanonecohort',s,currentPatch%nocomp_pft_label + endif + if(currentPatch%total_canopy_area-currentPatch%area.gt.1.0e-16)then + write(fates_log(),*) 'canopy area too large in summarization1,s,pft,error:',s,currentPatch%nocomp_pft_label,currentPatch%total_canopy_area-currentPatch%area,& + currentPatch%area,currentPatch%tallest%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if ! Check for erroneous zero values. if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then write(fates_log(),*) 'FATES: dbh or n is zero in canopy_summarization', & @@ -1371,9 +1380,11 @@ subroutine canopy_summarization( nsites, sites, bc_in ) enddo ! ends 'do while(associated(currentCohort)) if ( currentPatch%total_canopy_area>currentPatch%area ) then - if ( currentPatch%total_canopy_area-currentPatch%area > 0.001_r8 ) then + if ( currentPatch%total_canopy_area-currentPatch%area > 1.0e-16_r8 ) then write(fates_log(),*) 'FATES: canopy area bigger than area', & - currentPatch%total_canopy_area ,currentPatch%area + currentPatch%total_canopy_area ,currentPatch%area, & + currentPatch%total_canopy_area -currentPatch%area,& + currentPatch%nocomp_pft_label call endrun(msg=errMsg(sourcefile, __LINE__)) end if currentPatch%total_canopy_area = currentPatch%area @@ -1955,14 +1966,17 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%canopy_fraction_pa(ifp) = & min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) - + if(isnan(bc_out(s)%canopy_fraction_pa(ifp)))then + write(*,*) 'nan canopy_fraction_pa in canopystructure, ifp, canopy area,patch area:',ifp,currentPatch%total_canopy_area,currentPatch%area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & (currentPatch%area/AREA) total_patch_area = total_patch_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area total_canopy_area = total_canopy_area + bc_out(s)%canopy_fraction_pa(ifp) - + ! Calculate area indices for output boundary to HLM ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) @@ -1970,7 +1984,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') - ! Fraction of vegetation free of snow. This is used to flag those ! patches which shall under-go photosynthesis ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let @@ -2045,7 +2058,7 @@ function calc_areaindex(cpatch,ai_type) result(ai) real(r8) :: ai ! TODO: THIS MIN LAI IS AN ARTIFACT FROM TESTING LONG-AGO AND SHOULD BE REMOVED ! THIS HAS BEEN KEPT THUS FAR TO MAINTAIN B4B IN TESTING OTHER COMMITS - real(r8),parameter :: ai_min = 0.1_r8 + real(r8) :: ai_min = 0.1_r8 real(r8),pointer :: ai_profile ai = 0._r8 @@ -2167,6 +2180,10 @@ function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) res ! If so we need to make another layer. if(arealayer > currentPatch%area)then z = z + 1 + if(hlm_use_sp)then + write(*,*) 'SPmode, canopy_layer full:',arealayer,currentPatch%area + end if + endif end if diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index c5dd9b4d75..2db45f3970 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2906,8 +2906,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) cpatch => cpatch%younger end do - + ! ------------------------------------------------------------------------------ ! Diagnostics discretized by element type ! ------------------------------------------------------------------------------ diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 8486546707..83ab5a7fbf 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -12,7 +12,7 @@ dimensions: fates_prt_organs = 6 ; fates_string_length = 60 ; fates_variants = 2 ; - fates_hlm_pftno = 12 ; + fates_hlm_pftno = 14 ; variables: double fates_history_ageclass_bin_edges(fates_history_age_bins) ; @@ -1228,8 +1228,9 @@ data: 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1; - + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1; fates_fire_FBD = 15.4, 16.8, 19.6, 999, 4, 4 ; From 95089d1e41479787fd8a0e7cfcf8c51fb1a5612b Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 21 Sep 2020 04:46:54 -0600 Subject: [PATCH 099/578] added carea to create_cohort --- biogeochem/EDCohortDynamicsMod.F90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 0b9ab3bc60..40e461d13a 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -136,7 +136,7 @@ module EDCohortDynamicsMod subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & prt, laimemory, sapwmemory, structmemory, & - status, recruitstatus,ctrim, clayer, spread, bc_in) + status, recruitstatus,ctrim, carea, clayer, spread, bc_in) ! ! !DESCRIPTION: ! create new cohort @@ -179,6 +179,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & ! leaf biomass that we are targeting? real(r8), intent(in) :: spread ! The community assembly effects how ! spread crowns are in horizontal space + real(r8), intent(in) :: carea ! area of cohort NLY USED IN SP MODE. type(bc_in_type), intent(in) :: bc_in ! External boundary conditions @@ -255,8 +256,11 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & endif ! Assign canopy extent and depth - call carea_allom(new_cohort%dbh,new_cohort%n,spread,new_cohort%pft,new_cohort%c_area) - + if(hlm_use_sp.eq.ifalse)then + call carea_allom(new_cohort%dbh,new_cohort%n,spread,new_cohort%pft,new_cohort%c_area) + else + new_cohort%c_area = carea ! set this from previously precision-controlled value + endif ! Query PARTEH for the leaf carbon [kg] leaf_c = new_cohort%prt%GetState(leaf_organ,carbon12_element) From 4202f4ba515e2e5481517ca535e474721930feac Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 21 Sep 2020 04:47:42 -0600 Subject: [PATCH 100/578] added carea to create_cohort in inventory --- main/FatesInventoryInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 6dcd3e2f58..2d0acd24e8 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -1131,7 +1131,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & call create_cohort(csite, cpatch, temp_cohort%pft, temp_cohort%n, temp_cohort%hite, & temp_cohort%coage, temp_cohort%dbh, & prt_obj, temp_cohort%laimemory,temp_cohort%sapwmemory, temp_cohort%structmemory, & - cstatus, rstatus, temp_cohort%canopy_trim, & + cstatus, rstatus, temp_cohort%canopy_trim,temp_cohort%c_area, & 1, csite%spread, bc_in) deallocate(temp_cohort) ! get rid of temporary cohort From 003a7a383e75f2bff0315066fc2a5a6a5d5f3c3a Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 21 Sep 2020 08:03:39 -0600 Subject: [PATCH 101/578] updates to satelllite phenology in edphys --- biogeochem/EDPhysiologyMod.F90 | 104 ++++++++++++++++++++++++--------- 1 file changed, 78 insertions(+), 26 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 3f9ede346a..eacae06580 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -111,6 +111,7 @@ module EDPhysiologyMod public :: trim_canopy public :: phenology public :: satellite_phenology + public :: assign_cohort_SP_properties public :: recruitment public :: ZeroLitterFluxes public :: FluxIntoLitterPools @@ -1430,14 +1431,6 @@ subroutine satellite_phenology(currentSite, bc_in) ! ------------------------------------------------------------ currentCohort => currentPatch%tallest do while (associated(currentCohort)) - - ! Do some checks - if(associated(currentCohort%shorter))then - write(fates_log(),*) 'SP mode has >1 cohort' - write(fates_log(),*) "SP mode >1 cohort: PFT",currentCohort%pft, currentCohort%shorter%pft - write(fates_log(),*) "SP mode >1 cohort: CL",currentCohort%canopy_layer, currentCohort%shorter%canopy_layer - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if fates_pft =currentCohort%pft if(fates_pft.ne.currentPatch%nocomp_pft_label)then @@ -1445,10 +1438,55 @@ subroutine satellite_phenology(currentSite, bc_in) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) + + currentCohort => currentCohort%shorter + end do !cohort loop + currentPatch => currentPatch%younger + end do ! patch loop + + end subroutine satellite_phenology + +! ===================================================================================== + + subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,leaf_c) + + ! Takes the daily inputs of leaf area index, stem area index and canopy height and + ! translates them into a FATES structure with one patch and one cohort per PFT + ! The leaf area of the cohort is modified each day to match that asserted by the HLM + ! -----------------------------------------------------------------------------------! + use EDTypesMod , only : nclmax + + type(ed_cohort_type), intent(inout), target :: currentCohort + + real(r8), intent(in) :: tlai ! target leaf area index from SP inputs + real(r8), intent(in) :: tsai ! target stem area index from SP inputs + real(r8), intent(in) :: htop ! target tree height from SP inputs + real(r8), intent(in) :: parea ! patch area for this PFT + integer, intent(in) :: init ! are we in the initialization routine? if so do not set leaf_c + real(r8), intent(out) :: leaf_c ! leaf carbon estimated to generate target tlai + + integer :: fates_pft ! fates pft numer for weighting loop + real(r8) :: spread ! dummy value of canopy spread to estimate c_area + real(r8) :: sumarea + real(r8) :: check_treelai + real(r8) :: canopylai(1:nclmax) + real(r8) :: fracerr + real(r8) :: oldcarea + + ! Do some checks + if(associated(currentCohort%shorter))then + write(fates_log(),*) 'SP mode has >1 cohort' + write(fates_log(),*) "SP mode >1 cohort: PFT",currentCohort%pft, currentCohort%shorter%pft + write(fates_log(),*) "SP mode >1 cohort: CL",currentCohort%canopy_layer, currentCohort%shorter%canopy_layer + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + !------------------------------------------ ! Calculate dbh from input height, and c_area from dbh !------------------------------------------ - currentCohort%hite = currentSite%sp_htop(fates_pft) + currentCohort%hite = htop + fates_pft = currentCohort%pft call h2d_allom(currentCohort%hite,fates_pft,currentCohort%dbh) currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. @@ -1461,41 +1499,54 @@ subroutine satellite_phenology(currentSite, bc_in) !------------------------------------------ ! Calculate canopy N assuming patch area is full !------------------------------------------ - currentCohort%n = currentPatch%area / currentCohort%c_area + currentCohort%n = parea / currentCohort%c_area + + ! correct c_area for the new nplant + call carea_allom(currentCohort%dbh,currentCohort%n,spread,currentCohort%pft,currentCohort%c_area) ! ------------------------------------------ ! Calculate leaf carbon from target treelai ! ------------------------------------------ - currentCohort%treelai = currentSite%sp_tlai(fates_pft) - - ! correct c_area for the new nplant - currentCohort%c_area = currentCohort%c_area * currentCohort%n - + currentCohort%treelai = tlai + canopylai(:) = 0._r8 leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) !check reverse - maybe can delete eventually check_treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + canopylai,currentCohort%vcmax25top ) if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzerio (10^-16 typically) write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%treelai-check_treelai call endrun(msg=errMsg(sourcefile, __LINE__)) end if - call SetState(currentCohort%prt,leaf_organ,1,leaf_c,1) + + ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area + if(abs(currentCohort%c_area-parea).gt.nearzero)then + if(abs(currentCohort%c_area-parea).lt.10.e-9)then !correct this if it's a very sall error + oldcarea = currentCohort%c_area + !generate new cohort area + currentCohort%c_area = currentCohort%c_area - (currentCohort%c_area- parea) + currentCohort%n = currentCohort%n * (currentCohort%c_area/oldcarea) + if(abs(currentCohort%c_area-parea).gt.nearzero)then + write(fates_log(),*) 'SPassign, c_area still broken',currentCohort%c_area-parea,currentCohort%c_area-oldcarea + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + else + write(fates_log(),*) 'SPassign, big error in c_area',currentCohort%c_area-parea,currentCohort%pft + end if ! still broken + end if !small error + + if(init.eq.ifalse)then + call SetState(currentCohort%prt,leaf_organ,1,leaf_c,1) + endif ! assert sai - currentCohort%treesai = currentSite%sp_tsai(fates_pft) + currentCohort%treesai = tsai - !NB these will need to be put through the canopy_structure routine in order to figure out exposed lai and sai + end subroutine assign_cohort_SP_properties - currentCohort => currentCohort%shorter - end do !cohort loop - currentPatch => currentPatch%younger - end do ! patch loop - - end subroutine satellite_phenology ! ===================================================================================== subroutine SeedIn( currentSite, bc_in ) @@ -2011,7 +2062,8 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) temp_cohort%hite, temp_cohort%coage, temp_cohort%dbh, prt, & temp_cohort%laimemory, temp_cohort%sapwmemory, temp_cohort%structmemory, & cohortstatus, recruitstatus, & - temp_cohort%canopy_trim, currentPatch%NCL_p, currentSite%spread, bc_in) + temp_cohort%canopy_trim,temp_cohort%c_area, & + currentPatch%NCL_p, currentSite%spread, bc_in) ! Note that if hydraulics is on, the number of cohorts may had ! changed due to hydraulic constraints. From f34b399fc3c5158dee6a3d0a430407e47db6dde0 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 21 Sep 2020 09:03:52 -0600 Subject: [PATCH 102/578] large EDInit updates. now runs to third ts --- main/EDInitMod.F90 | 177 +++++++++++++++++++++++++++++++-------------- 1 file changed, 124 insertions(+), 53 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index ced8c2740b..d6e8a97c55 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -19,6 +19,7 @@ module EDInitMod use EDCohortDynamicsMod , only : InitPRTObject use EDPatchDynamicsMod , only : create_patch use EDPatchDynamicsMod , only : set_patchno + use EDPhysiologyMod , only : assign_cohort_sp_properties use ChecksBalancesMod , only : SiteMassStock use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDTypesMod , only : numWaterMem @@ -325,9 +326,18 @@ subroutine set_site_properties( nsites, sites,bc_in ) sumarea = sum(sites(s)%area_pft(1:numpft)) do ft = 1,numpft if(sites(s)%area_pft(ft).lt.0.01_r8.and.sites(s)%area_pft(ft).gt.0.0_r8)then - if ( debug ) write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) - sites(s)%area_pft(ft)=0.0_r8 !remove tiny patches to prevent numerical errors in terminate patches - endif + write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) + sites(s)%area_pft(ft)=0.0_r8 + ! remove tiny patches to prevent numerical errors in terminate patches + endif + end do +! change units to m2 from fractions + do ft = 1,numpft + sites(s)%area_pft(ft)= sites(s)%area_pft(ft) * AREA ! rescale units to m2. + if(sites(s)%area_pft(ft).lt.0._r8)then + write(fates_log(),*) 'negative area',s,ft,sites(s)%area_pft(ft) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if end do ! re-normalize PFT area to ensure it sums to one. @@ -346,10 +356,13 @@ subroutine set_site_properties( nsites, sites,bc_in ) end do !ft else ! for sp mode, assert a bare ground patch sumarea = sum(sites(s)%area_pft(1:numpft)) - ! here we subsume the destroyed tiny patches into the bare ground fraction. - sites(s)%area_bareground = 1.0_r8 - sumarea + + if(sumarea.lt.area)then !make some bare ground + sites(s)%area_bareground = area - sumarea + else + sites(s)%area_bareground = 0.0_r8 + end if end if !sp mode - end if !fixed biogeog do ft = 1,numpft @@ -458,8 +471,43 @@ subroutine init_patches( nsites, sites, bc_in) no_new_patches = 1 newparea = area end if - is_first_patch = 1 - do n = 1, no_new_patches + + !check if the total area adds to the same as site area + if(hlm_use_sp.eq.itrue)then + tota = 0.0_r8 + do n = 0, no_new_patches + if(n.eq.0)then + newparea = sites(s)%area_bareground + else + newparea = sites(s)%area_pft(n) + end if + tota=tota+newparea + end do !n + + if(abs(tota-area).gt.1.0e-16_r8)then + if(abs(tota-area).lt.1.0e-10_r8)then + write(*,*) 'error in assigning areas in init patch BEF',s,sites(s)%lat,tota-area,tota + if(sites(s)%area_bareground.gt.nearzero.and.sites(s)%area_bareground.gt.tota-area)then + !modify area of bare ground if thre is a bare ground patch and it is big enough + write(fates_log(),*) 'fixing patch precision in bg patch', sites(s)%area_bareground , tota-area,sites(s)%area_bareground - (tota-area) + sites(s)%area_bareground = sites(s)%area_bareground - (tota-area) !units of m2 + else !no bare ground + do n = 0, no_new_patches + if(sites(s)%area_pft(n).gt.tota-area)then + sites(s)%area_pft(n) = sites(s)%area_pft(n) - (tota-area) + write(fates_log(),*) 'fixing patch precision in veg patch',n,sites(s)%area_pft(n), tota-area + end if + end do + endif !area left in patches + else !this is a big error + write(fates_log(),*) 'error large', s,tota-area + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif ! big error + end if ! too much patch area + end if ! SP + + is_first_patch = 1 + do n = 0, no_new_patches ! set the PFT index for patches if in nocomp mode. if(hlm_use_nocomp.eq.itrue)then @@ -473,7 +521,7 @@ subroutine init_patches( nsites, sites, bc_in) ! then each PFT has the area dictated by the surface dataset. ! If not, each PFT gets the same area. if(hlm_use_fixed_biogeog.eq.itrue)then - newparea = area * sites(s)%area_pft(nocomp_pft) + newparea = sites(s)%area_pft(nocomp_pft) else newparea = area / numpft end if @@ -481,8 +529,8 @@ subroutine init_patches( nsites, sites, bc_in) newparea = area end if !nocomp mode - if(hlm_use_sp.eq.itrue.and.n.gt.numpft)then - newparea = sites(s)%area_bareground * area + if(hlm_use_sp.eq.itrue.and.n.eq.0)then + newparea = sites(s)%area_bareground nocomp_pft = 0 end if @@ -490,7 +538,7 @@ subroutine init_patches( nsites, sites, bc_in) allocate(newp) call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) - + if(is_first_patch.eq.1)then !is this the first patch? ! set poointers for first patch (or only patch, if nocomp is false) newp%patchno = 1 @@ -523,8 +571,12 @@ subroutine init_patches( nsites, sites, bc_in) end do sitep => sites(s) - if(hlm_use_sp.eq.ifalse.and.nocomp_pft.eq.0)then !don't initialize cohorts for SP bare ground patch - call init_cohorts(sitep, newp, bc_in(s)) + if(hlm_use_sp.eq.itrue)then + if(nocomp_pft.ne.0)then !don't initialize cohorts for SP bare ground patch + call init_cohorts(sitep, newp, bc_in(s)) + end if + else ! normal non SP case + call init_cohorts(sitep, newp, bc_in(s)) end if end if end do !no new patches @@ -534,12 +586,22 @@ subroutine init_patches( nsites, sites, bc_in) newp => sites(s)%oldest_patch do while (associated(newp)) tota=tota+newp%area - if ( debug ) write(fates_log(),*) 'test links',s,newp%nocomp_pft_label,tota newp=>newp%younger end do + if(abs(tota-area).gt.nearzero*area)then - write(*,*) 'error in assigning areas in init patch',s,sites(s)%lat,tota-area,tota - endif + if(abs(tota-area).lt.1.0e-10_r8)then ! this is a precision error + if(sites(s)%oldest_patch%area.gt.(tota-area+nearzero))then + ! remove or add extra area from bare ground patch + sites(s)%oldest_patch%area = sites(s)%oldest_patch%area - (tota-area) + write(*,*) 'fixing patch precision O',s, tota-area + else + sites(s)%youngest_patch%area = sites(s)%oldest_patch%area - (tota-area) + endif + else !this is a big error + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif ! big error + end if ! too much patch area ! For carbon balance checks, we need to initialize the ! total carbon stock @@ -549,7 +611,6 @@ subroutine init_patches( nsites, sites, bc_in) end do call set_patchno(sites(s)) -! deallocate(recall_older_patch) !leaving this as a potential fix for memory leak in multipatch nocomp mode enddo !s end if @@ -607,7 +668,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) real(r8) :: stem_drop_fraction integer, parameter :: rstatus = 0 - + integer init !---------------------------------------------------------------------- patch_in%tallest => null() @@ -627,8 +688,8 @@ subroutine init_cohorts( site_in, patch_in, bc_in) if(hlm_use_fixed_biogeog.eq.itrue)then !filter geographically use_pft_local(pft) = site_in%use_this_pft(pft) ! Case 2 if(hlm_use_nocomp.eq.itrue.and.pft.ne.patch_in%nocomp_pft_label)then - ! Having set the biogeog filter as on or off, turn off all patches - ! whose identiy does not correspond to this PFT. + ! Having set the biogeog filter as on or off, turn off all PFTs + ! whose identiy does not correspond to this patch label. use_pft_local(pft) = ifalse ! Case 3 endif else @@ -639,7 +700,6 @@ subroutine init_cohorts( site_in, patch_in, bc_in) endif end do - do pft = 1,numpft if(use_pft_local(pft).eq.itrue)then if(EDPftvarcon_inst%initd(pft)>nearzero) then @@ -656,13 +716,24 @@ subroutine init_cohorts( site_in, patch_in, bc_in) temp_cohort%n = temp_cohort%n * sum(site_in%use_this_pft) endif - temp_cohort%hite = EDPftvarcon_inst%hgt_min(pft) - + temp_cohort%canopy_trim = 1.0_r8 - ! Calculate the plant diameter from height - call h2d_allom(temp_cohort%hite,pft,temp_cohort%dbh) + ! h,dbh,leafc,n from SP values or from small initial size. - temp_cohort%canopy_trim = 1.0_r8 + if(hlm_use_sp.eq.itrue)then + init = itrue + call assign_cohort_SP_properties(temp_cohort, 0.5_r8,0.2_r8, 0.1_r8,patch_in%area,init,c_leaf) + + else + temp_cohort%hite = EDPftvarcon_inst%hgt_min(pft) + + ! Calculate the plant diameter from height + call h2d_allom(temp_cohort%hite,pft,temp_cohort%dbh) + + ! Calculate the leaf biomass from allometry + ! (calculates a maximum first, then applies canopy trim) + call bleaf(temp_cohort%dbh,pft,temp_cohort%canopy_trim,c_leaf) + end if ! sp mode ! Calculate total above-ground biomass from allometry call bagw_allom(temp_cohort%dbh,pft,c_agw) @@ -670,10 +741,6 @@ subroutine init_cohorts( site_in, patch_in, bc_in) ! Calculate coarse root biomass from allometry call bbgw_allom(temp_cohort%dbh,pft,c_bgw) - ! Calculate the leaf biomass from allometry - ! (calculates a maximum first, then applies canopy trim) - call bleaf(temp_cohort%dbh,pft,temp_cohort%canopy_trim,c_leaf) - ! Calculate fine root biomass from allometry ! (calculates a maximum and then trimming value) call bfineroot(temp_cohort%dbh,pft,temp_cohort%canopy_trim,c_fnrt) @@ -691,28 +758,30 @@ subroutine init_cohorts( site_in, patch_in, bc_in) cstatus = leaves_on stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) - - if( EDPftvarcon_inst%season_decid(pft) == itrue .and. & - any(site_in%cstatus == [phen_cstat_nevercold,phen_cstat_iscold])) then - temp_cohort%laimemory = c_leaf - temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction - c_leaf = 0._r8 - c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw - c_struct = (1.0_r8-stem_drop_fraction) * c_struct - cstatus = leaves_off - endif - if ( EDPftvarcon_inst%stress_decid(pft) == itrue .and. & - any(site_in%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then - temp_cohort%laimemory = c_leaf - temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction - c_leaf = 0._r8 - c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw - c_struct = (1.0_r8-stem_drop_fraction) * c_struct - cstatus = leaves_off - endif + if(hlm_use_sp.eq.ifalse)then ! do not override SP vales with phenology + if( EDPftvarcon_inst%season_decid(pft) == itrue .and. & + any(site_in%cstatus == [phen_cstat_nevercold,phen_cstat_iscold])) then + temp_cohort%laimemory = c_leaf + temp_cohort%sapwmemory = c_sapw * stem_drop_fraction + temp_cohort%structmemory = c_struct * stem_drop_fraction + c_leaf = 0._r8 + c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw + c_struct = (1.0_r8-stem_drop_fraction) * c_struct + cstatus = leaves_off + endif + + if ( EDPftvarcon_inst%stress_decid(pft) == itrue .and. & + any(site_in%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then + temp_cohort%laimemory = c_leaf + temp_cohort%sapwmemory = c_sapw * stem_drop_fraction + temp_cohort%structmemory = c_struct * stem_drop_fraction + c_leaf = 0._r8 + c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw + c_struct = (1.0_r8-stem_drop_fraction) * c_struct + cstatus = leaves_off + endif + end if ! SP mode if ( debug ) write(fates_log(),*) 'EDInitMod.F90 call create_cohort ' @@ -788,7 +857,8 @@ subroutine init_cohorts( site_in, patch_in, bc_in) call create_cohort(site_in, patch_in, pft, temp_cohort%n, temp_cohort%hite, & temp_cohort%coage, temp_cohort%dbh, prt_obj, temp_cohort%laimemory, & temp_cohort%sapwmemory, temp_cohort%structmemory, cstatus, rstatus, & - temp_cohort%canopy_trim, 1, site_in%spread, bc_in) + temp_cohort%canopy_trim, temp_cohort%c_area,1, site_in%spread, bc_in) + deallocate(temp_cohort) ! get rid of temporary cohort @@ -806,6 +876,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) call fuse_cohorts(site_in, patch_in,bc_in) call sort_cohorts(patch_in) + end subroutine init_cohorts ! =============================================================================================== From 4ef49f85e08019d5e68b321f3817d238dc38ac19 Mon Sep 17 00:00:00 2001 From: Joshua Rady Date: Tue, 22 Sep 2020 11:04:48 -0400 Subject: [PATCH 103/578] Add tolerance to disturbance check to resolve issue with precision error. --- biogeochem/EDPatchDynamicsMod.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index af0208cf43..84ea9258f6 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -481,6 +481,8 @@ subroutine spawn_patches( currentSite, bc_in) ! for both woody and grass species real(r8) :: leaf_m ! leaf mass during partial burn calculations logical :: found_youngest_primary ! logical for finding the first primary forest patch + + real(r8), parameter :: disturb_tolerance = 1.0e-14_r8 ! Allow for a small precision errors. !--------------------------------------------------------------------- storesmallcohort => null() ! storage of the smallest cohort for insertion routine @@ -500,7 +502,7 @@ subroutine spawn_patches( currentSite, bc_in) do while(associated(currentPatch)) - if(currentPatch%disturbance_rate>1.0_r8) then + if(currentPatch%disturbance_rate > (1.0_r8 + disturb_tolerance)) then write(fates_log(),*) 'patch disturbance rate > 1 ?',currentPatch%disturbance_rate call dump_patch(currentPatch) call endrun(msg=errMsg(sourcefile, __LINE__)) From 77729ab9dd683f9580ac2e738adcf1b56ea4df57 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 28 Sep 2020 05:59:24 -0600 Subject: [PATCH 104/578] modified initialization of SP variables --- main/EDInitMod.F90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index d6e8a97c55..5a8935d761 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -457,6 +457,10 @@ subroutine init_patches( nsites, sites, bc_in) allocate(recall_older_patch) do s = 1, nsites + sites(s)%sp_tlai(:) = 0._r8 + sites(s)%sp_tsai(:) = 0._r8 + sites(s)%sp_htop(:) = 0._r8 + ! Initialize the site-level crown area spread factor (0-1) ! It is likely that closed canopy forest inventories ! have smaller spread factors than bare ground (they are crowded) @@ -486,10 +490,9 @@ subroutine init_patches( nsites, sites, bc_in) if(abs(tota-area).gt.1.0e-16_r8)then if(abs(tota-area).lt.1.0e-10_r8)then - write(*,*) 'error in assigning areas in init patch BEF',s,sites(s)%lat,tota-area,tota if(sites(s)%area_bareground.gt.nearzero.and.sites(s)%area_bareground.gt.tota-area)then !modify area of bare ground if thre is a bare ground patch and it is big enough - write(fates_log(),*) 'fixing patch precision in bg patch', sites(s)%area_bareground , tota-area,sites(s)%area_bareground - (tota-area) + write(fates_log(),*) 'fixing patch precision in bg patch', sites(s)%area_bareground , tota-area sites(s)%area_bareground = sites(s)%area_bareground - (tota-area) !units of m2 else !no bare ground do n = 0, no_new_patches @@ -572,6 +575,7 @@ subroutine init_patches( nsites, sites, bc_in) sitep => sites(s) if(hlm_use_sp.eq.itrue)then + if(nocomp_pft.ne.0)then !don't initialize cohorts for SP bare ground patch call init_cohorts(sitep, newp, bc_in(s)) end if From 5fb8de8730b9447d0ce369b2e7b75c82272b4bbd Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 28 Sep 2020 07:53:36 -0600 Subject: [PATCH 105/578] seperate loops in satellite_phenology --- biogeochem/EDPhysiologyMod.F90 | 26 +++++++++++++++++++++----- 1 file changed, 21 insertions(+), 5 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index eacae06580..9e9593f58a 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1376,9 +1376,9 @@ subroutine satellite_phenology(currentSite, bc_in) ! determine what 'n' should be from the canopy height. - currentSite%sp_tlai(1:numpft) = 0._r8 - currentSite%sp_tsai(1:numpft) = 0._r8 - currentSite%sp_htop(1:numpft) = 0._r8 + currentSite%sp_tlai(:) = 0._r8 + currentSite%sp_tsai(:) = 0._r8 + currentSite%sp_htop(:) = 0._r8 currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) @@ -1391,10 +1391,13 @@ subroutine satellite_phenology(currentSite, bc_in) ! weight each fates PFT target for lai, sai and htop by the area of the ! contrbuting HLM PFTs. ! we only need to do this for the patch/fates_pft we are currently in - fates_pft = currentPatch%nocomp_pft_label + fates_pft = currentPatch%nocomp_pft_label + if(fates_pft.ne.0)then sumarea = 0.0_r8 + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + if(bc_in%pft_areafrac(hlm_pft) * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft).gt.0.0_r8)then sumarea = sumarea + bc_in%pft_areafrac(hlm_pft)*EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) !leaf area index @@ -1421,7 +1424,14 @@ subroutine satellite_phenology(currentSite, bc_in) currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & /(currentPatch%area/area) endif - + + + end if ! bare patch + currentPatch => currentPatch%younger + end do ! patch loop + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) + ! ------------------------------------------------------------ ! now we have the target lai, sai and htop for each PFT/patch ! find properties of the cohort that go along with that @@ -1438,6 +1448,10 @@ subroutine satellite_phenology(currentSite, bc_in) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if(fates_pft.eq.0)then + write(fates_log(),*) 'PFT0 in SP mode' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) currentCohort => currentCohort%shorter @@ -1486,6 +1500,7 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l ! Calculate dbh from input height, and c_area from dbh !------------------------------------------ currentCohort%hite = htop + fates_pft = currentCohort%pft call h2d_allom(currentCohort%hite,fates_pft,currentCohort%dbh) @@ -1521,6 +1536,7 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%treelai-check_treelai call endrun(msg=errMsg(sourcefile, __LINE__)) end if + ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area if(abs(currentCohort%c_area-parea).gt.nearzero)then From 1afadcc196754b59c743751357e541fda1c784db Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 28 Sep 2020 07:56:18 -0600 Subject: [PATCH 106/578] modified nan check --- biogeochem/EDCanopyStructureMod.F90 | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 9500ba8eef..ea29b6a40a 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1933,7 +1933,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) endif bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) - ! Use leaf area weighting for all cohorts in the patch to define the characteristic ! leaf width used by the HLM ! ---------------------------------------------------------------------------- @@ -1957,7 +1956,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) - ! We are assuming here that grass is all located underneath tree canopies. ! The alternative is to assume it is all spatial distinct from tree canopies. ! In which case, the bare area would have to be reduced by the grass area... @@ -1967,7 +1965,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%canopy_fraction_pa(ifp) = & min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) if(isnan(bc_out(s)%canopy_fraction_pa(ifp)))then - write(*,*) 'nan canopy_fraction_pa in canopystructure, ifp, canopy area,patch area:',ifp,currentPatch%total_canopy_area,currentPatch%area + write(fates_log(),*) 'nan canopy_fraction_pa in canopystructure:',ifp call endrun(msg=errMsg(sourcefile, __LINE__)) end if bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & From aa04775f0fd0e1329cc1d0b5cb597bb0b1e010f0 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 29 Sep 2020 02:11:37 -0600 Subject: [PATCH 107/578] fixing compile errors in FatesAllometry --- biogeochem/FatesAllometryMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index 60b03d54fa..c694614f35 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -808,7 +808,7 @@ real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25t call endrun(msg=errMsg(sourcefile, __LINE__)) endif - slat = g_per_kg * EDPftvarcon_inst%slatop(pft) ! m2/g to m2/kg + slat = g_per_kg * prt_params%slatop(pft) leafc_per_unitarea = leaf_c/(c_area/nplant) !KgC/m2 if(treelai > 0.0_r8)then @@ -816,7 +816,7 @@ real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25t kn = decay_coeff_kn(pft,vcmax25top) ! take PFT-level maximum SLA value, even if under a thick canopy (which has units of m2/gC), ! and put into units of m2/kgC - sla_max = g_per_kg *EDPftvarcon_inst%slamax(pft) + sla_max = g_per_kg * prt_params%slamax(pft) ! Leafc_per_unitarea at which sla_max is reached due to exponential sla profile in canopy: leafc_slamax = max(0.0_r8,(slat - sla_max) / (-1.0_r8 * kn * slat * sla_max)) From e1048554846f5abd6c7908c38604d84e55f3bed9 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 29 Sep 2020 02:42:20 -0600 Subject: [PATCH 108/578] fixing compiling/merge errors in EDpftvarcn --- main/EDPftvarcon.F90 | 704 +------------------------------------------ 1 file changed, 1 insertion(+), 703 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index dfe3e39df2..a44235eba8 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -1405,37 +1405,8 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'hydr_fcap_node = ',EDPftvarcon_inst%hydr_fcap_node write(fates_log(),fmt0) 'hydr_pinot_node = ',EDPftvarcon_inst%hydr_pinot_node write(fates_log(),fmt0) 'hydr_kmax_node = ',EDPftvarcon_inst%hydr_kmax_node -<<<<<<< HEAD - - write(fates_log(),fmt0) 'prt_nitr_stoich_p1 = ',EDPftvarcon_inst%prt_nitr_stoich_p1 - write(fates_log(),fmt0) 'prt_nitr_stoich_p2 = ',EDPftvarcon_inst%prt_nitr_stoich_p2 - write(fates_log(),fmt0) 'prt_phos_stoich_p1 = ',EDPftvarcon_inst%prt_phos_stoich_p1 - write(fates_log(),fmt0) 'prt_phos_stoich_p2 = ',EDPftvarcon_inst%prt_phos_stoich_p2 - write(fates_log(),fmt0) 'prt_grperc_organ = ',EDPftvarcon_inst%prt_grperc_organ - write(fates_log(),fmt0) 'prt_alloc_priority = ',EDPftvarcon_inst%prt_alloc_priority - - write(fates_log(),fmt0) 'turnover_carb_retrans = ',EDPftvarcon_inst%turnover_carb_retrans - write(fates_log(),fmt0) 'turnover_nitr_retrans = ',EDPftvarcon_inst%turnover_nitr_retrans - write(fates_log(),fmt0) 'turnover_phos_retrans = ',EDPftvarcon_inst%turnover_phos_retrans write(fates_log(),fmt0) 'hlm_pft_map = ', EDPftvarcon_inst%hlm_pft_map - -||||||| merged common ancestors - - - write(fates_log(),fmt0) 'prt_nitr_stoich_p1 = ',EDPftvarcon_inst%prt_nitr_stoich_p1 - write(fates_log(),fmt0) 'prt_nitr_stoich_p2 = ',EDPftvarcon_inst%prt_nitr_stoich_p2 - write(fates_log(),fmt0) 'prt_phos_stoich_p1 = ',EDPftvarcon_inst%prt_phos_stoich_p1 - write(fates_log(),fmt0) 'prt_phos_stoich_p2 = ',EDPftvarcon_inst%prt_phos_stoich_p2 - write(fates_log(),fmt0) 'prt_grperc_organ = ',EDPftvarcon_inst%prt_grperc_organ - write(fates_log(),fmt0) 'prt_alloc_priority = ',EDPftvarcon_inst%prt_alloc_priority - - write(fates_log(),fmt0) 'turnover_carb_retrans = ',EDPftvarcon_inst%turnover_carb_retrans - write(fates_log(),fmt0) 'turnover_nitr_retrans = ',EDPftvarcon_inst%turnover_nitr_retrans - write(fates_log(),fmt0) 'turnover_phos_retrans = ',EDPftvarcon_inst%turnover_phos_retrans - -======= ->>>>>>> 03a17bfebbc7d947ab4f7b88b649a31cdac213fb write(fates_log(),*) '-------------------------------------------------' end if @@ -1722,341 +1693,6 @@ subroutine FatesCheckParams(is_master) end if -<<<<<<< HEAD - - ! Check re-translocations - ! Seems reasonable to assume that sapwood, structure and reproduction - ! should not be re-translocating mass upon turnover. - ! Note to advanced users. Feel free to remove these checks... - ! ------------------------------------------------------------------- - - if ( (EDPftvarcon_inst%turnover_carb_retrans(ipft,repro_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of reproductive tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,repro_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,repro_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of reproductive tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,repro_organ) - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,repro_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,repro_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,sapw_organ) > nearzero)) then - write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,sapw_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,sapw_organ) > nearzero) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,sapw_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,sapw_organ) - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,sapw_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,sapw_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,struct_organ) > nearzero)) then - write(fates_log(),*) ' Retranslocation of structural(dead) tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,struct_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,struct_organ) > nearzero) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,struct_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of structural(dead) tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,struct_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,struct_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Leaf retranslocation should be between 0 and 1 - if ( (EDPftvarcon_inst%turnover_carb_retrans(ipft,leaf_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_carb_retrans(ipft,leaf_organ) < 0.0_r8) ) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,leaf_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,leaf_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,leaf_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_nitr_retrans(ipft,leaf_organ) < 0.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,leaf_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,leaf_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,leaf_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Fineroot retranslocation should be between 0-1 - if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_carb_retrans(ipft,fnrt_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,fnrt_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_nitr_retrans(ipft,fnrt_organ) < 0.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,fnrt_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,fnrt_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,fnrt_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Storage retranslocation should be between 0-1 (storage retrans seems weird, but who knows) - if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,store_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_carb_retrans(ipft,store_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,store_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,store_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,store_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_nitr_retrans(ipft,store_organ) < 0.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,store_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,store_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,store_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Growth respiration - if (parteh_mode .eq. prt_carbon_allom_hyp) then - if ( ( EDPftvarcon_inst%grperc(ipft) < 0.0_r8) .or. & - ( EDPftvarcon_inst%grperc(ipft) > 1.0_r8 ) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' Growth respiration must be between 0 and 1: ',EDPftvarcon_inst%grperc(ipft) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - elseif(parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ( ( any(EDPftvarcon_inst%prt_grperc_organ(ipft,:) < 0.0_r8)) .or. & - ( any(EDPftvarcon_inst%prt_grperc_organ(ipft,:) >= 1.0_r8)) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' Growth respiration must be between 0 and 1: ',EDPftvarcon_inst%prt_grperc_organ(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Stoichiometric Ratios - - ! Firstly, the seed production and germination models cannot handle nutrients. So - ! we assume (for now) that seeds do not have nutrients (parteh_mode = 1 is c only) - if(parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ( (EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,repro_organ) < -nearzero) .or. & - (EDPftvarcon_inst%prt_phos_stoich_p1(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%prt_phos_stoich_p1(ipft,repro_organ) < -nearzero) .or. & - (EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,repro_organ) < -nearzero) .or. & - (EDPftvarcon_inst%prt_phos_stoich_p2(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%prt_phos_stoich_p2(ipft,repro_organ) < -nearzero) ) then - write(fates_log(),*) 'N & P should be zero in reproductive tissues' - write(fates_log(),*) 'until nutrients are coupled into recruitment' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,repro_organ) - write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p1(ipft,repro_organ) - write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,repro_organ) - write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p2(ipft,repro_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! The first nitrogen stoichiometry is used in all cases - if ( (any(EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,:) < 0.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,:) >= 1.0_r8))) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' N per C stoichiometry must bet between 0-1' - write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if(parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if( (any(EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,:) < 0.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,:) >= 1.0_r8)) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' N per C stoichiometry must bet between 0-1' - write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Stoichiometric Ratios - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ( (any(EDPftvarcon_inst%prt_phos_stoich_p1(ipft,:) < 0.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_phos_stoich_p1(ipft,:) >= 1.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_phos_stoich_p2(ipft,:) < 0.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_phos_stoich_p2(ipft,:) >= 1.0_r8)) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' P per C stoichiometry must bet between 0-1' - write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p1(ipft,:) - write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p2(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ( any(EDPftvarcon_inst%prt_alloc_priority(ipft,:) < 0) .or. & - any(EDPftvarcon_inst%prt_alloc_priority(ipft,:) > 6) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' Allocation priorities should be 0-6 for H1' - write(fates_log(),*) EDPftvarcon_inst%prt_alloc_priority(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - - ! Check turnover time-scales - - nleafage = size(EDPftvarcon_inst%leaf_long,dim=2) - - do iage = 1, nleafage - - if ( EDPftvarcon_inst%leaf_long(ipft,iage)>nearzero ) then - - ! Check that leaf turnover doesn't exeed 1 day - if ( (years_per_day / EDPftvarcon_inst%leaf_long(ipft,iage)) > 1._r8 ) then - write(fates_log(),*) 'Leaf turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft,' iage: ',iage - write(fates_log(),*) 'leaf_long(ipft,iage): ',EDPftvarcon_inst%leaf_long(ipft,iage),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Check to make sure that all other age-classes for this PFT also - ! have non-zero entries, it wouldn't make sense otherwise - if ( any(EDPftvarcon_inst%leaf_long(ipft,:) <= nearzero) ) then - write(fates_log(),*) 'You specified a leaf_long that is zero or' - write(fates_log(),*) 'invalid for a particular age class.' - write(fates_log(),*) 'Yet, other age classes for this PFT are non-zero.' - write(fates_log(),*) 'this doesnt make sense.' - write(fates_log(),*) 'ipft = ',ipft - write(fates_log(),*) 'leaf_long(ipft,:) = ',EDPftvarcon_inst%leaf_long(ipft,:) - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - else - if (EDPftvarcon_inst%evergreen(ipft) .eq. itrue) then - write(fates_log(),*) 'You specified zero leaf turnover: ' - write(fates_log(),*) 'ipft: ',ipft,' iage: ',iage - write(fates_log(),*) 'leaf_long(ipft,iage): ',EDPftvarcon_inst%leaf_long(ipft,iage) - write(fates_log(),*) 'yet this is an evergreen PFT, and it only makes sense' - write(fates_log(),*) 'that an evergreen would have leaf maintenance turnover' - write(fates_log(),*) 'disable this error if you are ok with this' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - end do ! iage - - ! Check the turnover rates on the senescing leaf pool - if ( EDPftvarcon_inst%leaf_long(ipft,nleafage)>nearzero ) then - - ! Check that leaf turnover doesn't exeed 1 day - if ( (years_per_day / & - (EDPftvarcon_inst%leaf_long(ipft,nleafage) * & - EDPftvarcon_inst%senleaf_long_fdrought(ipft))) > 1._r8 ) then - write(fates_log(),*) 'Drought-senescent turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'leaf_long(ipft,nleafage)*senleaf_long_fdrought: ', & - EDPftvarcon_inst%leaf_long(ipft,nleafage)*EDPftvarcon_inst%senleaf_long_fdrought(ipft),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if ( EDPftvarcon_inst%senleaf_long_fdrought(ipft)1._r8 ) then - write(fates_log(),*) 'senleaf_long_fdrought(ipft) must be greater than 0 ' - write(fates_log(),*) 'or less than or equal to 1.' - write(fates_log(),*) 'Set this to 1 if you want no accelerated senescence turnover' - write(fates_log(),*) 'ipft = ',ipft - write(fates_log(),*) 'senleaf_long_fdrought(ipft) = ',EDPftvarcon_inst%senleaf_long_fdrought(ipft) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - if ( EDPftvarcon_inst%root_long(ipft)>nearzero ) then - - ! Check that root turnover doesn't exeed 1 day - if ( (years_per_day / EDPftvarcon_inst%root_long(ipft)) > 1._r8 ) then - write(fates_log(),*) 'Root turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'root_long(ipft): ',EDPftvarcon_inst%root_long(ipft),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - else - if (EDPftvarcon_inst%evergreen(ipft) .eq. itrue) then - write(fates_log(),*) 'You specified zero root turnover: ' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'root_long(ipft): ',EDPftvarcon_inst%root_long(ipft) - write(fates_log(),*) 'yet this is an evergreen PFT, and it only makes sense' - write(fates_log(),*) 'that an evergreen would have root maintenance turnover' - write(fates_log(),*) 'disable this error if you are ok with this' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Check Branch turnover doesn't exceed one day - if ( EDPftvarcon_inst%branch_turnover(ipft)>nearzero ) then - - ! Check that branch turnover doesn't exeed 1 day - if ( (years_per_day / EDPftvarcon_inst%branch_turnover(ipft)) > 1._r8 ) then - write(fates_log(),*) 'Branch turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'branch_turnover(ipft): ',EDPftvarcon_inst%branch_turnover(ipft),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - end do !ipft - ! check that the host-fates PFT map adds to one in both dimension do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft)) @@ -2068,348 +1704,10 @@ subroutine FatesCheckParams(is_master) write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - end do !ipft -||||||| merged common ancestors - - ! Check re-translocations - ! Seems reasonable to assume that sapwood, structure and reproduction - ! should not be re-translocating mass upon turnover. - ! Note to advanced users. Feel free to remove these checks... - ! ------------------------------------------------------------------- - - if ( (EDPftvarcon_inst%turnover_carb_retrans(ipft,repro_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of reproductive tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,repro_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,repro_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of reproductive tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,repro_organ) - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,repro_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,repro_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,sapw_organ) > nearzero)) then - write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,sapw_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,sapw_organ) > nearzero) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,sapw_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,sapw_organ) - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,sapw_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,sapw_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,struct_organ) > nearzero)) then - write(fates_log(),*) ' Retranslocation of structural(dead) tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,struct_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,struct_organ) > nearzero) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,struct_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of structural(dead) tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,struct_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,struct_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Leaf retranslocation should be between 0 and 1 - if ( (EDPftvarcon_inst%turnover_carb_retrans(ipft,leaf_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_carb_retrans(ipft,leaf_organ) < 0.0_r8) ) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,leaf_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,leaf_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,leaf_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_nitr_retrans(ipft,leaf_organ) < 0.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,leaf_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,leaf_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,leaf_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Fineroot retranslocation should be between 0-1 - if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_carb_retrans(ipft,fnrt_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,fnrt_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_nitr_retrans(ipft,fnrt_organ) < 0.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,fnrt_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,fnrt_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,fnrt_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Storage retranslocation should be between 0-1 (storage retrans seems weird, but who knows) - if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,store_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_carb_retrans(ipft,store_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,store_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,store_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,store_organ) > 1.0_r8) .or. & - (EDPftvarcon_inst%turnover_nitr_retrans(ipft,store_organ) < 0.0_r8) .or. & - (EDPftvarcon_inst%turnover_phos_retrans(ipft,store_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,store_organ) - write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,store_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Growth respiration - if (parteh_mode .eq. prt_carbon_allom_hyp) then - if ( ( EDPftvarcon_inst%grperc(ipft) < 0.0_r8) .or. & - ( EDPftvarcon_inst%grperc(ipft) > 1.0_r8 ) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' Growth respiration must be between 0 and 1: ',EDPftvarcon_inst%grperc(ipft) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - elseif(parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ( ( any(EDPftvarcon_inst%prt_grperc_organ(ipft,:) < 0.0_r8)) .or. & - ( any(EDPftvarcon_inst%prt_grperc_organ(ipft,:) >= 1.0_r8)) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' Growth respiration must be between 0 and 1: ',EDPftvarcon_inst%prt_grperc_organ(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Stoichiometric Ratios - - ! Firstly, the seed production and germination models cannot handle nutrients. So - ! we assume (for now) that seeds do not have nutrients (parteh_mode = 1 is c only) - if(parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ( (EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,repro_organ) < -nearzero) .or. & - (EDPftvarcon_inst%prt_phos_stoich_p1(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%prt_phos_stoich_p1(ipft,repro_organ) < -nearzero) .or. & - (EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,repro_organ) < -nearzero) .or. & - (EDPftvarcon_inst%prt_phos_stoich_p2(ipft,repro_organ) > nearzero) .or. & - (EDPftvarcon_inst%prt_phos_stoich_p2(ipft,repro_organ) < -nearzero) ) then - write(fates_log(),*) 'N & P should be zero in reproductive tissues' - write(fates_log(),*) 'until nutrients are coupled into recruitment' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,repro_organ) - write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p1(ipft,repro_organ) - write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,repro_organ) - write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p2(ipft,repro_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! The first nitrogen stoichiometry is used in all cases - if ( (any(EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,:) < 0.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,:) >= 1.0_r8))) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' N per C stoichiometry must bet between 0-1' - write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if(parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if( (any(EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,:) < 0.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,:) >= 1.0_r8)) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' N per C stoichiometry must bet between 0-1' - write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Stoichiometric Ratios - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ( (any(EDPftvarcon_inst%prt_phos_stoich_p1(ipft,:) < 0.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_phos_stoich_p1(ipft,:) >= 1.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_phos_stoich_p2(ipft,:) < 0.0_r8)) .or. & - (any(EDPftvarcon_inst%prt_phos_stoich_p2(ipft,:) >= 1.0_r8)) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' P per C stoichiometry must bet between 0-1' - write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p1(ipft,:) - write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p2(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ( any(EDPftvarcon_inst%prt_alloc_priority(ipft,:) < 0) .or. & - any(EDPftvarcon_inst%prt_alloc_priority(ipft,:) > 6) ) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' Allocation priorities should be 0-6 for H1' - write(fates_log(),*) EDPftvarcon_inst%prt_alloc_priority(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - - ! Check turnover time-scales - - nleafage = size(EDPftvarcon_inst%leaf_long,dim=2) - - do iage = 1, nleafage - - if ( EDPftvarcon_inst%leaf_long(ipft,iage)>nearzero ) then - - ! Check that leaf turnover doesn't exeed 1 day - if ( (years_per_day / EDPftvarcon_inst%leaf_long(ipft,iage)) > 1._r8 ) then - write(fates_log(),*) 'Leaf turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft,' iage: ',iage - write(fates_log(),*) 'leaf_long(ipft,iage): ',EDPftvarcon_inst%leaf_long(ipft,iage),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Check to make sure that all other age-classes for this PFT also - ! have non-zero entries, it wouldn't make sense otherwise - if ( any(EDPftvarcon_inst%leaf_long(ipft,:) <= nearzero) ) then - write(fates_log(),*) 'You specified a leaf_long that is zero or' - write(fates_log(),*) 'invalid for a particular age class.' - write(fates_log(),*) 'Yet, other age classes for this PFT are non-zero.' - write(fates_log(),*) 'this doesnt make sense.' - write(fates_log(),*) 'ipft = ',ipft - write(fates_log(),*) 'leaf_long(ipft,:) = ',EDPftvarcon_inst%leaf_long(ipft,:) - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - else - if (EDPftvarcon_inst%evergreen(ipft) .eq. itrue) then - write(fates_log(),*) 'You specified zero leaf turnover: ' - write(fates_log(),*) 'ipft: ',ipft,' iage: ',iage - write(fates_log(),*) 'leaf_long(ipft,iage): ',EDPftvarcon_inst%leaf_long(ipft,iage) - write(fates_log(),*) 'yet this is an evergreen PFT, and it only makes sense' - write(fates_log(),*) 'that an evergreen would have leaf maintenance turnover' - write(fates_log(),*) 'disable this error if you are ok with this' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - end do - - ! Check the turnover rates on the senescing leaf pool - if ( EDPftvarcon_inst%leaf_long(ipft,nleafage)>nearzero ) then - - ! Check that leaf turnover doesn't exeed 1 day - if ( (years_per_day / & - (EDPftvarcon_inst%leaf_long(ipft,nleafage) * & - EDPftvarcon_inst%senleaf_long_fdrought(ipft))) > 1._r8 ) then - write(fates_log(),*) 'Drought-senescent turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'leaf_long(ipft,nleafage)*senleaf_long_fdrought: ', & - EDPftvarcon_inst%leaf_long(ipft,nleafage)*EDPftvarcon_inst%senleaf_long_fdrought(ipft),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if ( EDPftvarcon_inst%senleaf_long_fdrought(ipft)1._r8 ) then - write(fates_log(),*) 'senleaf_long_fdrought(ipft) must be greater than 0 ' - write(fates_log(),*) 'or less than or equal to 1.' - write(fates_log(),*) 'Set this to 1 if you want no accelerated senescence turnover' - write(fates_log(),*) 'ipft = ',ipft - write(fates_log(),*) 'senleaf_long_fdrought(ipft) = ',EDPftvarcon_inst%senleaf_long_fdrought(ipft) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - if ( EDPftvarcon_inst%root_long(ipft)>nearzero ) then - - ! Check that root turnover doesn't exeed 1 day - if ( (years_per_day / EDPftvarcon_inst%root_long(ipft)) > 1._r8 ) then - write(fates_log(),*) 'Root turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'root_long(ipft): ',EDPftvarcon_inst%root_long(ipft),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - else - if (EDPftvarcon_inst%evergreen(ipft) .eq. itrue) then - write(fates_log(),*) 'You specified zero root turnover: ' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'root_long(ipft): ',EDPftvarcon_inst%root_long(ipft) - write(fates_log(),*) 'yet this is an evergreen PFT, and it only makes sense' - write(fates_log(),*) 'that an evergreen would have root maintenance turnover' - write(fates_log(),*) 'disable this error if you are ok with this' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Check Branch turnover doesn't exceed one day - if ( EDPftvarcon_inst%branch_turnover(ipft)>nearzero ) then - - ! Check that branch turnover doesn't exeed 1 day - if ( (years_per_day / EDPftvarcon_inst%branch_turnover(ipft)) > 1._r8 ) then - write(fates_log(),*) 'Branch turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'branch_turnover(ipft): ',EDPftvarcon_inst%branch_turnover(ipft),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - - end do + end do !ipft -======= - end do ->>>>>>> 03a17bfebbc7d947ab4f7b88b649a31cdac213fb !! ! Checks for HYDRO !! if( hlm_use_planthydro == itrue ) then !! From ee3ce528a0f46e6a50f843f5022b2c8bda149571 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 29 Sep 2020 02:48:26 -0600 Subject: [PATCH 109/578] fixing last compiling/merge errors in EDpftvarcn --- main/EDPftvarcon.F90 | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index a44235eba8..214ca75d3b 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -1693,19 +1693,19 @@ subroutine FatesCheckParams(is_master) end if - ! check that the host-fates PFT map adds to one in both dimension - do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) - sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft)) - if(abs(sumarea-1.0_r8).gt.nearzero)then - write(fates_log(),*) 'The distribution of this host land model PFT :',hlm_pft - write(fates_log(),*) 'into FATES PFTs, does not add up to 1.0.' - write(fates_log(),*) 'Error is:',sumarea-1.0_r8 - write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft) - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - end do !ipft + ! check that the host-fates PFT map adds to one in both dimension + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft)) + if(abs(sumarea-1.0_r8).gt.nearzero)then + write(fates_log(),*) 'The distribution of this host land model PFT :',hlm_pft + write(fates_log(),*) 'into FATES PFTs, does not add up to 1.0.' + write(fates_log(),*) 'Error is:',sumarea-1.0_r8 + write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft) + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do !hlm_pft + end do !ipft !! ! Checks for HYDRO From 1b96395d3a75a6ce1ef66046414905236a483731 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 29 Sep 2020 02:54:48 -0600 Subject: [PATCH 110/578] fixing merge errors in EDInit --- main/EDInitMod.F90 | 26 ++------------------------ 1 file changed, 2 insertions(+), 24 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 23e7ef4f7a..0789c78025 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -769,20 +769,9 @@ subroutine init_cohorts( site_in, patch_in, bc_in) stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) - if( EDPftvarcon_inst%season_decid(pft) == itrue .and. & - any(site_in%cstatus == [phen_cstat_nevercold,phen_cstat_iscold])) then - temp_cohort%laimemory = c_leaf - temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction - c_leaf = 0._r8 - c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw - c_struct = (1.0_r8-stem_drop_fraction) * c_struct - cstatus = leaves_off - endif - if(hlm_use_sp.eq.ifalse)then ! do not override SP vales with phenology - if( EDPftvarcon_inst%season_decid(pft) == itrue .and. & - any(site_in%cstatus == [phen_cstat_nevercold,phen_cstat_iscold])) then + if ( prt_params%stress_decid(pft) == itrue .and. & + any(site_in%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then temp_cohort%laimemory = c_leaf temp_cohort%sapwmemory = c_sapw * stem_drop_fraction temp_cohort%structmemory = c_struct * stem_drop_fraction @@ -791,17 +780,6 @@ subroutine init_cohorts( site_in, patch_in, bc_in) c_struct = (1.0_r8-stem_drop_fraction) * c_struct cstatus = leaves_off endif - - if ( EDPftvarcon_inst%stress_decid(pft) == itrue .and. & - any(site_in%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then - temp_cohort%laimemory = c_leaf - temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction - c_leaf = 0._r8 - c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw - c_struct = (1.0_r8-stem_drop_fraction) * c_struct - cstatus = leaves_off - endif end if ! SP mode if ( debug ) write(fates_log(),*) 'EDInitMod.F90 call create_cohort ' From 0635560d552cae8a3373b44fd2c4b14fe51d8117 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 29 Sep 2020 03:32:16 -0600 Subject: [PATCH 111/578] turning off trim canopy --- main/EDMainMod.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index ae7528e069..76a031e688 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -702,8 +702,9 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) ! If this is the second to last day of the year, then perform trimming if( hlm_day_of_year == hlm_days_per_year-1) then - write(fates_log(),*) 'calling trim canopy' - call trim_canopy(currentSite) + if(hlm_use_sp.eq.ifalse)then + call trim_canopy(currentSite) + endif endif end subroutine ed_update_site From 96abe15012af067c2c02cdf13763b89a26a31c22 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 5 Oct 2020 05:08:25 -0600 Subject: [PATCH 112/578] setting pa label --- biogeochem/EDCanopyStructureMod.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 89f725a107..72e8b29c35 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1972,6 +1972,8 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) total_patch_area = total_patch_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area total_canopy_area = total_canopy_area + bc_out(s)%canopy_fraction_pa(ifp) + + bc_out(s)%nocomp_pft_label_pa(ifp) = currentPatch%nocomp_pft_label ! Calculate area indices for output boundary to HLM ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles From 8eec5202fa59711223ec56ca0b7aeca7b74730ae Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 5 Oct 2020 05:35:43 -0600 Subject: [PATCH 113/578] made pft_label_pa variable --- main/FatesInterfaceMod.F90 | 6 +++++- main/FatesInterfaceTypesMod.F90 | 10 ++++++++-- 2 files changed, 13 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 496df88b58..3c0fd82c6f 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -295,7 +295,8 @@ subroutine zero_bcs(fates,s) 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)%nocomp_pft_label_pa(:) = 0 + fates%bc_out(s)%canopy_fraction_pa(:) = 0.0_r8 fates%bc_out(s)%frac_veg_nosno_alb_pa(:) = 0.0_r8 @@ -392,6 +393,7 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) allocate(bc_in%plant_p_uptake_flux(1,1)) end if + allocate(bc_in%zi_sisl(0:nlevsoil_in)) allocate(bc_in%dz_sisl(nlevsoil_in)) allocate(bc_in%z_sisl(nlevsoil_in)) @@ -586,6 +588,8 @@ subroutine allocate_bcout(bc_out, nlevsoil_in, nlevdecomp_in) allocate(bc_out%canopy_fraction_pa(maxPatchesPerSite)) allocate(bc_out%frac_veg_nosno_alb_pa(maxPatchesPerSite)) + + allocate(bc_out%nocomp_pft_label_pa(maxPatchesPerSite)) ! Plant-Hydro BC's if (hlm_use_planthydro.eq.itrue) then diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 1be8695b63..ba3fa9191c 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -336,6 +336,10 @@ module FatesInterfaceTypesMod ! be equivalent (ie integer ascending) ! Or, all will be 1. + integer,allocatable :: sp_patch_index(:) ! in SP mode, we need to map the p values for each patch + ! back onto the 'IFP' order i ED. So this is the number of e ! ach patch in the site. It does not correspond to PFT, more + ! to the number of occupied PFTs before it in the array. + ! Vegetation Dynamics ! --------------------------------------------------------------------------------- @@ -393,7 +397,7 @@ module FatesInterfaceTypesMod ! 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 @@ -660,7 +664,9 @@ module FatesInterfaceTypesMod ! vegetation in the patch is exposed. ! [0,1] - ! FATES Hydraulics + integer, allocatable :: nocomp_pft_label_pa(:) ! in nocomp and SP mode, each patch has a PFT identity. + + ! FATES Hydraulics From 5796f3607800f5ac38b302d31e9c256b051015af Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 8 Oct 2020 06:43:25 -0600 Subject: [PATCH 114/578] added checks on all FATES loops that use IFP to not include bare ground patches --- biogeochem/EDPhysiologyMod.F90 | 5 +++-- biogeophys/EDAccumulateFluxesMod.F90 | 2 ++ biogeophys/EDBtranMod.F90 | 3 ++- biogeophys/EDSurfaceAlbedoMod.F90 | 6 ++++-- biogeophys/FatesPlantHydraulicsMod.F90 | 3 ++- biogeophys/FatesPlantRespPhotosynthMod.F90 | 7 +++---- main/FatesRestartInterfaceMod.F90 | 3 ++- 7 files changed, 18 insertions(+), 11 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 851ce93981..8ebe490c7b 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -2493,7 +2493,7 @@ subroutine fragmentation_scaler( currentPatch, bc_in) catanf_30 = catanf(30._r8) ifp = currentPatch%patchno - + if(currentPatch%nocomp_pft_label.gt.0)then 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. @@ -2517,7 +2517,8 @@ subroutine fragmentation_scaler( currentPatch, bc_in) w_scalar = sum(currentPatch%btran_ft(1:numpft))/real(numpft,r8) currentPatch%fragmentation_scaler = min(1.0_r8,max(0.0_r8,t_scalar * w_scalar)) - + endif ! not bare ground + end subroutine fragmentation_scaler ! ============================================================================ diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index 4d873cca85..9355389185 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -64,6 +64,7 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) cpatch => sites(s)%oldest_patch do while (associated(cpatch)) + if(cpatch%nocomp_pft_label.gt.0)then ifp = ifp+1 if( bc_in(s)%filter_photo_pa(ifp) == 3 ) then @@ -104,6 +105,7 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) ccohort => ccohort%taller enddo ! while(associated(ccohort)) end if + end if ! not bare ground cpatch => cpatch%younger end do ! while(associated(cpatch)) end do diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index e7faac9cc3..694a24bd25 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -133,6 +133,7 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) ifp = 0 cpatch => sites(s)%oldest_patch do while (associated(cpatch)) + if(cpatch%nocomp_pft_label.gt.0)then ! only for veg patches ifp=ifp+1 ! THIS SHOULD REALLY BE A COHORT LOOP ONCE WE HAVE rootfr_ft FOR COHORTS (RGK) @@ -234,7 +235,7 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j)/temprootr enddo end if - + endif ! not bare ground cpatch => cpatch%younger end do diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 4e5309ea61..a3e420b9a0 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -89,6 +89,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) + if(currentpatch%nocomp_pft_label.gt.0)then ifp = ifp+1 currentPatch%f_sun (:,:,:) = 0._r8 @@ -148,6 +149,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) endif ! is there vegetation? end if ! if the vegetation and zenith filter is active + endif ! not bare ground currentPatch => currentPatch%younger end do ! Loop linked-list patches enddo ! Loop Sites @@ -1061,7 +1063,7 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) cpatch => sites(s)%oldest_patch do while (associated(cpatch)) - + if(cpatch%nocomp_pft_label.gt.0)then !only for veg patches ifp=ifp+1 if( debug ) write(fates_log(),*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft @@ -1199,7 +1201,7 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) cpatch%nrmlzd_parprof_dif_z(idiffuse,CL,iv)) end do ! iv end do ! CL - + endif ! not bareground patch cpatch => cpatch%younger enddo diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 57b9870916..33e5c41d21 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -2332,6 +2332,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ifp = 0 cpatch => sites(s)%oldest_patch do while (associated(cpatch)) + if(cpatch%nocomp_pft_label.gt.0)then ifp = ifp + 1 ! ---------------------------------------------------------------------------- @@ -2495,7 +2496,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ccohort => ccohort%shorter enddo !cohort - + endif ! not barground patch cpatch => cpatch%younger enddo !patch diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index bfe01d25be..23f7153da2 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -1,4 +1,3 @@ - module FATESPlantRespPhotosynthMod !------------------------------------------------------------------------------------- @@ -279,7 +278,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) - + if(currentpatch%nocomp_pft_label.gt.0)then ifp = ifp+1 NCL_p = currentPatch%NCL_p @@ -817,8 +816,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) end if - currentPatch => currentPatch%younger - + end if ! not bare ground patch + currentPatch => currentPatch%younger end do deallocate(rootfr_ft) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index fe90aa5d56..866af8095d 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -2922,6 +2922,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) + if(currentpatch%nocomp_pft_label.gt.0)then ifp = ifp+1 currentPatch%f_sun (:,:,:) = 0._r8 @@ -2986,7 +2987,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) end if ! if the vegetation and zenith filter is active - + end if ! not bare ground currentPatch => currentPatch%younger end do ! Loop linked-list patches enddo ! Loop Sites From 6b2d0624b83a97b0fe2accf3172eaea8f45f2e29 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 8 Oct 2020 06:46:09 -0600 Subject: [PATCH 115/578] added modificaitons to set_patchno to make bareground patches have a patchno of 0 --- biogeochem/EDPatchDynamicsMod.F90 | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 5a4d716e92..49b4b54dd8 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -45,6 +45,7 @@ module EDPatchDynamicsMod use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_days_per_year use FatesInterfaceTypesMod , only : numpft + use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : hlm_use_nocomp use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog use FatesGlobals , only : endrun => fates_endrun @@ -1274,6 +1275,22 @@ subroutine set_patchno( currentSite ) currentPatch => currentPatch%younger enddo + if(hlm_use_sp)then + patchno = 1 + currentPatch => currentSite%oldest_patch + do while(associated(currentPatch)) + if(currentPatch%nocomp_pft_label.eq.0)then + ! for bareground patch, we make the patch number 0 + ! we also do not count this in the veg. patch numbering scheme. + currentPatch%patchno = 0 + else + currentPatch%patchno = patchno + patchno = patchno + 1 + endif + currentPatch => currentPatch%younger + enddo + endif + end subroutine set_patchno ! ============================================================================ From 5893d9726e2633c89e3bf7045fd4def30b0d63e2 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 8 Oct 2020 06:59:30 -0600 Subject: [PATCH 116/578] changes to EDCanopystructure. Running at this point with LAI OK and GPP OK except in Amazon --- biogeochem/EDCanopyStructureMod.F90 | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 72e8b29c35..6152aee40a 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1275,7 +1275,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) type (ed_cohort_type) , pointer :: currentCohort integer :: s integer :: ft ! plant functional type - integer :: ifp + integer :: ifp ! the number of the vegeted patch (1,2,3). In SP mode bareground patch is 0 integer :: patchn ! identification number for each patch. real(r8) :: canopy_leaf_area ! total amount of leaf area in the vegetated area. m2. real(r8) :: leaf_c ! leaf carbon [kg] @@ -1915,8 +1915,9 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentPatch => sites(s)%oldest_patch c = fcolumn(s) do while(associated(currentPatch)) + if(currentPatch%nocomp_pft_label.gt.0)then ! only set values for vegetated patches in fixed modes ifp = ifp+1 - + endif ! stay with ifp=0 for bareground patch. if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area currentPatch%total_canopy_area = currentPatch%area @@ -1959,9 +1960,13 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! In which case, the bare area would have to be reduced by the grass area... ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants ! currentPatch%area/AREA is the fraction of the soil covered by this patch. - + if(currentPatch%area.gt.0.0_r8)then bc_out(s)%canopy_fraction_pa(ifp) = & min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) + else + bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 + endif + if(isnan(bc_out(s)%canopy_fraction_pa(ifp)))then write(fates_log(),*) 'nan canopy_fraction_pa in canopystructure:',ifp call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1995,7 +2000,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) else bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 0.0_r8 end if - currentPatch => currentPatch%younger end do @@ -2018,8 +2022,14 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentPatch => sites(s)%oldest_patch ifp = 0 do while(associated(currentPatch)) + if(.not.hlm_use_sp.or.currentPatch%nocomp_pft_label.gt.0)then ifp = ifp+1 bc_out(s)%canopy_fraction_pa(ifp) = bc_out(s)%canopy_fraction_pa(ifp)/total_patch_area + else ! when it is both SP mode and the bareground patch + bc_out(s)%canopy_fraction_pa(ifp) =0.0_r8 + endif ! veg patch + + currentPatch => currentPatch%younger end do From 79632e1813dc217feef7b6fed168d4d5bf74d485 Mon Sep 17 00:00:00 2001 From: Joshua Rady Date: Wed, 21 Oct 2020 20:05:00 -0400 Subject: [PATCH 117/578] Correct grammar error. --- biogeochem/EDPatchDynamicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 84ea9258f6..2932b992e5 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -482,7 +482,7 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: leaf_m ! leaf mass during partial burn calculations logical :: found_youngest_primary ! logical for finding the first primary forest patch - real(r8), parameter :: disturb_tolerance = 1.0e-14_r8 ! Allow for a small precision errors. + real(r8), parameter :: disturb_tolerance = 1.0e-14_r8 ! Allow for small precision errors. !--------------------------------------------------------------------- storesmallcohort => null() ! storage of the smallest cohort for insertion routine From e4032f9fe83a4cf219220f91528f10b03e34a554 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 30 Oct 2020 04:07:56 -0600 Subject: [PATCH 118/578] modified hlm_pft_map to have correct relation between fates and hlm pfts --- parameter_files/fates_params_default.cdl | 29 ++++++++++++------------ 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 06a3a59e84..c259b3c5df 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -1236,21 +1236,20 @@ data: 0.055, 0.055, 0.055 ; fates_hlm_pft_map = - 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1; - + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 ; fates_fire_FBD = 15.4, 16.8, 19.6, 999, 4, 4 ; From df2173df7e3de9dba800a54adaf8bcbd9e5db021 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 5 Nov 2020 03:39:48 -0700 Subject: [PATCH 119/578] copying minor changes from nocomp code review in EDInit --- main/EDInitMod.F90 | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 0789c78025..c96b2e6d85 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -417,7 +417,7 @@ subroutine init_patches( nsites, sites, bc_in) real(r8) :: litter_stock real(r8) :: seed_stock integer :: n - integer :: no_new_patches + integer :: num_new_patches integer :: nocomp_pft real(r8) :: newparea real(r8) :: tota !check on area @@ -471,13 +471,13 @@ subroutine init_patches( nsites, sites, bc_in) ! have smaller spread factors than bare ground (they are crowded) sites(s)%spread = init_spread_near_bare_ground if(hlm_use_nocomp.eq.itrue)then - no_new_patches = numpft + num_new_patches = numpft if(hlm_use_sp.eq.itrue)then - no_new_patches = numpft + 1 ! bare ground patch in SP mode. + num_new_patches = numpft + 1 ! bare ground patch in SP mode. endif ! allocate(newppft(numpft)) else - no_new_patches = 1 + num_new_patches = 1 newparea = area end if @@ -514,7 +514,7 @@ subroutine init_patches( nsites, sites, bc_in) end if ! too much patch area end if ! SP - is_first_patch = 1 + is_first_patch = itrue do n = 0, no_new_patches ! set the PFT index for patches if in nocomp mode. @@ -547,14 +547,14 @@ subroutine init_patches( nsites, sites, bc_in) call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) - if(is_first_patch.eq.1)then !is this the first patch? + if(is_first_patch.eq.itrue)then !is this the first patch? ! set poointers for first patch (or only patch, if nocomp is false) newp%patchno = 1 newp%younger => null() newp%older => null() sites(s)%youngest_patch => newp sites(s)%oldest_patch => newp - is_first_patch = 0 + is_first_patch = ifalse else ! the new patch is the 'oldest' one, arbitrarily. ! Set pointers for N>1 patches. Note this only happens when nocomp mode s on. ! The new patch is the 'youngest' one, arbitrarily. @@ -722,6 +722,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) ! to compensate (otherwise runs are very hard to compare) ! this multiplies it by the number of PFTs there would have been in ! the single shared patch in competition mode. + ! n.b. that this is the same as currentcohort%n = %initd(pft) &AREA temp_cohort%n = temp_cohort%n * sum(site_in%use_this_pft) endif From c2a18bb5ad2d9c825e3a253349fce2c3cd38f828 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 5 Nov 2020 03:54:16 -0700 Subject: [PATCH 120/578] modified comments in canopystructure --- biogeochem/EDCanopyStructureMod.F90 | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 6152aee40a..bca967919f 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1346,24 +1346,28 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area endif endif + + ! adding checks for SP and NOCOMP modes. if(currentPatch%nocomp_pft_label.eq.0)then - write(fates_log(),*) 'cohorts in barepatch',currentPatch%total_canopy_area,currentPatch%nocomp_pft_label,currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) + write(fates_log(),*) 'cohorts in barepatch',currentPatch%total_canopy_area,currentPatch%nocomp_pft_label call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(hlm_use_sp.eq.itrue.and.associated(currentPatch%tallest%shorter))then - write(fates_log(),*) 'morethanonecohort',s,currentPatch%nocomp_pft_label - endif + + if(hlm_use_sp.eq.itrue.and.associated(currentPatch%tallest%shorter))then + write(fates_log(),*) 'more than one cohort in SP mode',s,currentPatch%nocomp_pft_label + endif + if(currentPatch%total_canopy_area-currentPatch%area.gt.1.0e-16)then - write(fates_log(),*) 'canopy area too large in summarization1,s,pft,error:',s,currentPatch%nocomp_pft_label,currentPatch%total_canopy_area-currentPatch%area,& - currentPatch%area,currentPatch%tallest%c_area + write(fates_log(),*) 'too much canopy in summary',s,currentPatch%total_canopy_area-currentPatch%area call endrun(msg=errMsg(sourcefile, __LINE__)) end if + ! Check for erroneous zero values. if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then write(fates_log(),*) 'FATES: dbh or n is zero in canopy_summarization', & currentCohort%dbh,currentCohort%n call endrun(msg=errMsg(sourcefile, __LINE__)) endif + if(currentCohort%pft == 0.or.currentCohort%canopy_trim <= 0._r8)then write(fates_log(),*) 'FATES: PFT or trim is zero in canopy_summarization', & currentCohort%pft,currentCohort%canopy_trim From f8de4d817d016c056469fb687abfe0c8e1f4faf9 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 5 Nov 2020 04:05:40 -0700 Subject: [PATCH 121/578] tidying up CanopyStructure --- biogeochem/EDCanopyStructureMod.F90 | 15 ++++++--------- main/EDInitMod.F90 | 6 +++--- 2 files changed, 9 insertions(+), 12 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index bca967919f..b1643b700d 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -32,8 +32,6 @@ module EDCanopyStructureMod use FatesInterfaceTypesMod , only : numpft use FatesPlantHydraulicsMod, only : UpdateH2OVeg,InitHydrCohort, RecruitWaterStorage use EDTypesMod , only : maxCohortsPerPatch - use shr_infnan_mod , only : isnan => shr_infnan_isnan - use PRTGenericMod, only : leaf_organ use PRTGenericMod, only : all_carbon_elements use PRTGenericMod, only : leaf_organ @@ -1349,7 +1347,8 @@ subroutine canopy_summarization( nsites, sites, bc_in ) ! adding checks for SP and NOCOMP modes. if(currentPatch%nocomp_pft_label.eq.0)then - write(fates_log(),*) 'cohorts in barepatch',currentPatch%total_canopy_area,currentPatch%nocomp_pft_label call endrun(msg=errMsg(sourcefile, __LINE__)) + write(fates_log(),*) 'cohorts in barepatch',currentPatch%total_canopy_area,currentPatch%nocomp_pft_label + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_use_sp.eq.itrue.and.associated(currentPatch%tallest%shorter))then @@ -1357,8 +1356,8 @@ subroutine canopy_summarization( nsites, sites, bc_in ) endif if(currentPatch%total_canopy_area-currentPatch%area.gt.1.0e-16)then - write(fates_log(),*) 'too much canopy in summary',s,currentPatch%total_canopy_area-currentPatch%area - call endrun(msg=errMsg(sourcefile, __LINE__)) + write(fates_log(),*) 'too much canopy in summary',s,currentPatch%total_canopy_area-currentPatch%area + call endrun(msg=errMsg(sourcefile, __LINE__)) end if ! Check for erroneous zero values. @@ -1971,10 +1970,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 endif - if(isnan(bc_out(s)%canopy_fraction_pa(ifp)))then - write(fates_log(),*) 'nan canopy_fraction_pa in canopystructure:',ifp - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & (currentPatch%area/AREA) @@ -1987,10 +1982,12 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! Calculate area indices for output boundary to HLM ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) + bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') + ! Fraction of vegetation free of snow. This is used to flag those ! patches which shall under-go photosynthesis ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index c96b2e6d85..143eee5dc8 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -484,7 +484,7 @@ subroutine init_patches( nsites, sites, bc_in) !check if the total area adds to the same as site area if(hlm_use_sp.eq.itrue)then tota = 0.0_r8 - do n = 0, no_new_patches + do n = 0, num_new_patches if(n.eq.0)then newparea = sites(s)%area_bareground else @@ -500,7 +500,7 @@ subroutine init_patches( nsites, sites, bc_in) write(fates_log(),*) 'fixing patch precision in bg patch', sites(s)%area_bareground , tota-area sites(s)%area_bareground = sites(s)%area_bareground - (tota-area) !units of m2 else !no bare ground - do n = 0, no_new_patches + do n = 0, num_new_patches if(sites(s)%area_pft(n).gt.tota-area)then sites(s)%area_pft(n) = sites(s)%area_pft(n) - (tota-area) write(fates_log(),*) 'fixing patch precision in veg patch',n,sites(s)%area_pft(n), tota-area @@ -515,7 +515,7 @@ subroutine init_patches( nsites, sites, bc_in) end if ! SP is_first_patch = itrue - do n = 0, no_new_patches + do n = 0, num_new_patches ! set the PFT index for patches if in nocomp mode. if(hlm_use_nocomp.eq.itrue)then From a1d871068c1b80030737cdf57d43efbab87d78a7 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 5 Nov 2020 04:11:39 -0700 Subject: [PATCH 122/578] reverted aimin change --- biogeochem/EDCanopyStructureMod.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index b1643b700d..d259b67e61 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -2067,7 +2067,7 @@ function calc_areaindex(cpatch,ai_type) result(ai) real(r8) :: ai ! TODO: THIS MIN LAI IS AN ARTIFACT FROM TESTING LONG-AGO AND SHOULD BE REMOVED ! THIS HAS BEEN KEPT THUS FAR TO MAINTAIN B4B IN TESTING OTHER COMMITS - real(r8) :: ai_min = 0.1_r8 + real(r8),parameter :: ai_min = 0.1_r8 real(r8),pointer :: ai_profile ai = 0._r8 @@ -2085,7 +2085,6 @@ function calc_areaindex(cpatch,ai_type) result(ai) cpatch%tlai_profile(cl,ft,1:cpatch%nrad(cl,ft))) enddo enddo - elseif (trim(ai_type) == 'esai') then do cl = 1,cpatch%NCL_p do ft = 1,numpft From efeadf1b923d770cb529782a9dbc7a11a82114ed Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 5 Nov 2020 04:19:02 -0700 Subject: [PATCH 123/578] removing redundant check from copycohort --- biogeochem/EDCohortDynamicsMod.F90 | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index e7eeae6d15..e6fd43f66f 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -268,7 +268,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & if(hlm_use_sp.eq.ifalse)then call carea_allom(new_cohort%dbh,new_cohort%n,spread,new_cohort%pft,new_cohort%c_area) else - new_cohort%c_area = carea ! set this from previously precision-controlled value + new_cohort%c_area = carea ! set this from previously precision-controlled value in SP mode endif ! Query PARTEH for the leaf carbon [kg] leaf_c = new_cohort%prt%GetState(leaf_organ,carbon12_element) @@ -1768,12 +1768,6 @@ subroutine copy_cohort( currentCohort,copyc ) o => currentCohort n => copyc - if(hlm_use_sp.eq.itrue)then - write(fates_log(),*) 'copying cohort shouldnt happen in SP mode,area,pft',o%c_area,o%pft - - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - n%indexnumber = fates_unset_int ! VEGETATION STRUCTURE From 3c56759cbc6f22855fb56f75371814b5ee8014d6 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 5 Nov 2020 06:07:18 -0700 Subject: [PATCH 124/578] minor fixes to spacing in patch dynamics --- biogeochem/EDPatchDynamicsMod.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 49b4b54dd8..c27f5495f8 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -431,7 +431,8 @@ subroutine disturbance_rates( site_in, bc_in) end subroutine disturbance_rates - ! ============================================================================ + ! ============================================================================ + subroutine spawn_patches( currentSite, bc_in) ! ! !DESCRIPTION: @@ -2560,7 +2561,6 @@ subroutine fuse_2_patches(csite, dp, rp) ! Define some aliases for the donor patches younger and older neighbors ! which may or may not exist. After we set them, we will remove the donor ! And then we will go about re-setting the map. - if(associated(dp%older))then olderp => dp%older else @@ -2576,6 +2576,7 @@ subroutine fuse_2_patches(csite, dp, rp) call dealloc_patch(dp) deallocate(dp) + if(associated(youngerp))then ! Update the younger patch's new older patch (because it isn't dp anymore) youngerp%older => olderp From 49015da3f01b172d795af68fee527f5fecc4a787 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 5 Nov 2020 07:18:07 -0700 Subject: [PATCH 125/578] added start_patch and removed pre-initpatch checks --- main/EDInitMod.F90 | 48 ++++++++++------------------------------------ 1 file changed, 10 insertions(+), 38 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 143eee5dc8..14b566dbcd 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -417,6 +417,7 @@ subroutine init_patches( nsites, sites, bc_in) real(r8) :: litter_stock real(r8) :: seed_stock integer :: n + integer :: start_patch integer :: num_new_patches integer :: nocomp_pft real(r8) :: newparea @@ -470,52 +471,22 @@ subroutine init_patches( nsites, sites, bc_in) ! It is likely that closed canopy forest inventories ! have smaller spread factors than bare ground (they are crowded) sites(s)%spread = init_spread_near_bare_ground + + start_patch = 1 ! start at the first vegetated patch if(hlm_use_nocomp.eq.itrue)then num_new_patches = numpft if(hlm_use_sp.eq.itrue)then num_new_patches = numpft + 1 ! bare ground patch in SP mode. + start_patch = 0 ! start at the bare ground patch endif ! allocate(newppft(numpft)) - else + else !default num_new_patches = 1 newparea = area - end if - - !check if the total area adds to the same as site area - if(hlm_use_sp.eq.itrue)then - tota = 0.0_r8 - do n = 0, num_new_patches - if(n.eq.0)then - newparea = sites(s)%area_bareground - else - newparea = sites(s)%area_pft(n) - end if - tota=tota+newparea - end do !n - - if(abs(tota-area).gt.1.0e-16_r8)then - if(abs(tota-area).lt.1.0e-10_r8)then - if(sites(s)%area_bareground.gt.nearzero.and.sites(s)%area_bareground.gt.tota-area)then - !modify area of bare ground if thre is a bare ground patch and it is big enough - write(fates_log(),*) 'fixing patch precision in bg patch', sites(s)%area_bareground , tota-area - sites(s)%area_bareground = sites(s)%area_bareground - (tota-area) !units of m2 - else !no bare ground - do n = 0, num_new_patches - if(sites(s)%area_pft(n).gt.tota-area)then - sites(s)%area_pft(n) = sites(s)%area_pft(n) - (tota-area) - write(fates_log(),*) 'fixing patch precision in veg patch',n,sites(s)%area_pft(n), tota-area - end if - end do - endif !area left in patches - else !this is a big error - write(fates_log(),*) 'error large', s,tota-area - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif ! big error - end if ! too much patch area - end if ! SP + end if !nocomp - is_first_patch = itrue - do n = 0, num_new_patches + is_first_patch = itrue + do n = start_patch, num_new_patches ! set the PFT index for patches if in nocomp mode. if(hlm_use_nocomp.eq.itrue)then @@ -537,7 +508,7 @@ subroutine init_patches( nsites, sites, bc_in) newparea = area end if !nocomp mode - if(hlm_use_sp.eq.itrue.and.n.eq.0)then + if(hlm_use_sp.eq.itrue.and.n.eq.0)then ! bare ground patch newparea = sites(s)%area_bareground nocomp_pft = 0 end if @@ -608,6 +579,7 @@ subroutine init_patches( nsites, sites, bc_in) sites(s)%youngest_patch%area = sites(s)%oldest_patch%area - (tota-area) endif else !this is a big error + write(*,*) 'issue with patch area in EDinit',tota-area,tota call endrun(msg=errMsg(sourcefile, __LINE__)) endif ! big error end if ! too much patch area From 9bd54e3e1e4c8972131c093685b30a09e99508c8 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 5 Nov 2020 16:49:24 -0700 Subject: [PATCH 126/578] modified error statements in canopystructure --- biogeochem/EDCanopyStructureMod.F90 | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index d259b67e61..a2e860ad28 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1351,14 +1351,18 @@ subroutine canopy_summarization( nsites, sites, bc_in ) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(hlm_use_sp.eq.itrue.and.associated(currentPatch%tallest%shorter))then - write(fates_log(),*) 'more than one cohort in SP mode',s,currentPatch%nocomp_pft_label - endif + if(hlm_use_sp.eq.itrue)then - if(currentPatch%total_canopy_area-currentPatch%area.gt.1.0e-16)then - write(fates_log(),*) 'too much canopy in summary',s,currentPatch%total_canopy_area-currentPatch%area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + if(associated(currentPatch%tallest%shorter))then + write(fates_log(),*) 'more than one cohort in SP mode',s,currentPatch%nocomp_pft_label + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(currentPatch%total_canopy_area-currentPatch%area.gt.1.0e-16)then + write(fates_log(),*) 'too much canopy in summary',s,currentPatch%total_canopy_area-currentPatch%area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if !sp mode ! Check for erroneous zero values. if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then @@ -1383,7 +1387,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) enddo ! ends 'do while(associated(currentCohort)) if ( currentPatch%total_canopy_area>currentPatch%area ) then - if ( currentPatch%total_canopy_area-currentPatch%area > 1.0e-16_r8 ) then + if ( currentPatch%total_canopy_area-currentPatch%area > 1.0e-10_r8 ) then write(fates_log(),*) 'FATES: canopy area bigger than area', & currentPatch%total_canopy_area ,currentPatch%area, & currentPatch%total_canopy_area -currentPatch%area,& From d6edbb34a2747697d3f07acbfad3133474ce420e Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 5 Nov 2020 16:54:35 -0700 Subject: [PATCH 127/578] modified area_pft units in nocomp mode --- main/EDInitMod.F90 | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 14b566dbcd..211f58834d 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -350,13 +350,16 @@ subroutine set_site_properties( nsites, sites,bc_in ) ! the bare ground will no longer be proscribed and should emerge from FATES ! this may or may not be the right way to deal with this? - if(hlm_use_sp.eq.ifalse)then + if(hlm_use_sp.eq.ifalse)then ! when not in SP mode, subsume bare ground evenly into the existing patches. + !n.b. that it might be better if nocomp mode used the same bare groud logic as SP mode. sumarea = sum(sites(s)%area_pft(1:numpft)) do ft = 1,numpft if(sumarea.gt.0._r8)then - sites(s)%area_pft(ft) = sites(s)%area_pft(ft)/sumarea + sites(s)%area_pft(ft) = area * sites(s)%area_pft(ft)/sumarea else - sites(s)%area_pft(ft)= 1.0_r8/numpft + sites(s)%area_pft(ft) = area/numpft + ! in nocomp mode where there is only bare ground, we assign equal area to + ! all pfts and let the model figure out whether land should be bare or not. end if end do !ft else ! for sp mode, assert a bare ground patch @@ -551,11 +554,10 @@ subroutine init_patches( nsites, sites, bc_in) sitep => sites(s) if(hlm_use_sp.eq.itrue)then - if(nocomp_pft.ne.0)then !don't initialize cohorts for SP bare ground patch call init_cohorts(sitep, newp, bc_in(s)) end if - else ! normal non SP case + else ! normal non SP case always call init cohorts call init_cohorts(sitep, newp, bc_in(s)) end if end if From abadd8d34b464094259172d6aa9b65b02b6a8b14 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 6 Nov 2020 01:33:52 -0700 Subject: [PATCH 128/578] adding check which requires SP mode to also use fixed_biogeog mode --- main/FatesInterfaceMod.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 3c0fd82c6f..844c180663 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1475,6 +1475,12 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(), *) 'SP cannot be on if nocomp mode is off. Exiting. ' call endrun(msg=errMsg(sourcefile, __LINE__)) end if + + + if(hlm_use_sp.eq.itrue.and.hlm_use_fixed_biogeog.eq.ifalse)then + write(fates_log(), *) 'SP cannot be on if fixed biogeog mode is off. Exiting. ' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if if (fates_global_verbose()) then write(fates_log(), *) 'Checked. All control parameters sent to FATES.' From 1b035ac394b06ee5cb1e32bf48d742a41699c8ae Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 6 Nov 2020 02:47:36 -0700 Subject: [PATCH 129/578] fixing issue with IFP bareground couting in defualt mode --- biogeochem/EDCanopyStructureMod.F90 | 12 ++++++------ biogeophys/EDAccumulateFluxesMod.F90 | 2 +- biogeophys/EDBtranMod.F90 | 2 +- biogeophys/EDSurfaceAlbedoMod.F90 | 4 ++-- biogeophys/FatesPlantHydraulicsMod.F90 | 2 +- biogeophys/FatesPlantRespPhotosynthMod.F90 | 2 +- 6 files changed, 12 insertions(+), 12 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index a2e860ad28..d3109383ce 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1653,7 +1653,6 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) currentCohort => currentPatch%shortest do while(associated(currentCohort)) - ft = currentCohort%pft cl = currentCohort%canopy_layer @@ -1922,7 +1921,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentPatch => sites(s)%oldest_patch c = fcolumn(s) do while(associated(currentPatch)) - if(currentPatch%nocomp_pft_label.gt.0)then ! only set values for vegetated patches in fixed modes + if(currentPatch%nocomp_pft_label.ne.0)then ! only increase ifp for veg patches not BG (in SP mode) ifp = ifp+1 endif ! stay with ifp=0 for bareground patch. if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then @@ -2027,11 +2026,11 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentPatch => sites(s)%oldest_patch ifp = 0 do while(associated(currentPatch)) - if(.not.hlm_use_sp.or.currentPatch%nocomp_pft_label.gt.0)then + if(currentPatch%nocomp_pft_label.ne.0)then ! for vegetated patches only ifp = ifp+1 bc_out(s)%canopy_fraction_pa(ifp) = bc_out(s)%canopy_fraction_pa(ifp)/total_patch_area - else ! when it is both SP mode and the bareground patch - bc_out(s)%canopy_fraction_pa(ifp) =0.0_r8 + else ! for the bareground patch (in SP mode). + bc_out(s)%canopy_fraction_pa(ifp) =0.0_r8 endif ! veg patch @@ -2089,6 +2088,7 @@ function calc_areaindex(cpatch,ai_type) result(ai) cpatch%tlai_profile(cl,ft,1:cpatch%nrad(cl,ft))) enddo enddo + elseif (trim(ai_type) == 'esai') then do cl = 1,cpatch%NCL_p do ft = 1,numpft @@ -2193,7 +2193,7 @@ function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) res if(arealayer > currentPatch%area)then z = z + 1 if(hlm_use_sp)then - write(*,*) 'SPmode, canopy_layer full:',arealayer,currentPatch%area + write(fates_log(),*) 'SPmode, canopy_layer full:',arealayer,currentPatch%area end if endif diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index 9355389185..f9bf10e44f 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -64,7 +64,7 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) cpatch => sites(s)%oldest_patch do while (associated(cpatch)) - if(cpatch%nocomp_pft_label.gt.0)then + if(cpatch%nocomp_pft_label.ne.0)then ifp = ifp+1 if( bc_in(s)%filter_photo_pa(ifp) == 3 ) then diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index 694a24bd25..5bdcd966bb 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -133,7 +133,7 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) ifp = 0 cpatch => sites(s)%oldest_patch do while (associated(cpatch)) - if(cpatch%nocomp_pft_label.gt.0)then ! only for veg patches + if(cpatch%nocomp_pft_label.ne.0)then ! only for veg patches ifp=ifp+1 ! THIS SHOULD REALLY BE A COHORT LOOP ONCE WE HAVE rootfr_ft FOR COHORTS (RGK) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index a3e420b9a0..60a8f69ecf 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -89,7 +89,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) - if(currentpatch%nocomp_pft_label.gt.0)then + if(currentpatch%nocomp_pft_label.ne.0)then ifp = ifp+1 currentPatch%f_sun (:,:,:) = 0._r8 @@ -1063,7 +1063,7 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) cpatch => sites(s)%oldest_patch do while (associated(cpatch)) - if(cpatch%nocomp_pft_label.gt.0)then !only for veg patches + if(cpatch%nocomp_pft_label.ne.0)then !only for veg patches ifp=ifp+1 if( debug ) write(fates_log(),*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 33e5c41d21..7dda7cc928 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -2332,7 +2332,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ifp = 0 cpatch => sites(s)%oldest_patch do while (associated(cpatch)) - if(cpatch%nocomp_pft_label.gt.0)then + if(cpatch%nocomp_pft_label.ne.0)then ifp = ifp + 1 ! ---------------------------------------------------------------------------- diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 23f7153da2..6f74e95979 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -278,7 +278,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) - if(currentpatch%nocomp_pft_label.gt.0)then + if(currentpatch%nocomp_pft_label.ne.0)then ifp = ifp+1 NCL_p = currentPatch%NCL_p From a7ad770e7980b8c43954830e24a2a21046a48dfa Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 6 Nov 2020 03:29:54 -0700 Subject: [PATCH 130/578] modifying comments in EDPhysiology --- biogeochem/EDPhysiologyMod.F90 | 65 ++++++++++++++++++---------------- 1 file changed, 35 insertions(+), 30 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 8ebe490c7b..ed4d24cba9 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1371,32 +1371,27 @@ subroutine satellite_phenology(currentSite, bc_in) ! Get access to HLM input varialbes. ! Weight them by PFT ! Loop around patches, and for each single cohort in each patch - ! determine what 'n' should be from the canopy height. - ! determine the leaf biomass that it should have. - ! figure out how this will interact with the canopy_structure routines. - ! determine what 'n' should be from the canopy height. - + ! call assign_cohort_SP_properties to determine cohort height, dbh, 'n', area, leafc from drivers. currentSite%sp_tlai(:) = 0._r8 currentSite%sp_tsai(:) = 0._r8 currentSite%sp_htop(:) = 0._r8 + ! WEIGHTING OF FATES PFTs on to HLM_PFTs + ! 1. Add up the area associated with each FATES PFT + ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) + ! hlm_pft_map is the area of that land in each FATES PFT (from param file) + + ! 2. weight each fates PFT target for lai, sai and htop by the area of the + ! contrbuting HLM PFTs. + currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) - ! WEIGHTING OF FATES PFTs on to HLM_PFTs - ! add up the area associated with each FATES PFT - ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) - ! hlm_pft_map is the area of that land in each FATES PFT (from param file) - - ! weight each fates PFT target for lai, sai and htop by the area of the - ! contrbuting HLM PFTs. - ! we only need to do this for the patch/fates_pft we are currently in fates_pft = currentPatch%nocomp_pft_label if(fates_pft.ne.0)then sumarea = 0.0_r8 - do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) if(bc_in%pft_areafrac(hlm_pft) * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft).gt.0.0_r8)then @@ -1426,25 +1421,28 @@ subroutine satellite_phenology(currentSite, bc_in) /(currentPatch%area/area) endif - - end if ! bare patch + end if ! not bare patch currentPatch => currentPatch%younger end do ! patch loop + + ! ------------------------------------------------------------ + ! now we have the target lai, sai and htop for each PFT/patch + ! find properties of the cohort that go along with that + ! 1. Find canopy area from HTOP (height) + ! 2. Find 'n' associated with canopy area, given a closed canopy + ! 3. Find 'bleaf' associated with TLAI and canopy area. + ! These things happen in the catchily titled "assign_cohort_SP_properties" routine. + ! ------------------------------------------------------------ + currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) - ! ------------------------------------------------------------ - ! now we have the target lai, sai and htop for each PFT/patch - ! find properties of the cohort that go along with that - ! 1. Find canopy area from HTOP (height) - ! 2. Find 'n' associated with canopy area, given a closed canopy - ! 3. Find 'bleaf' associated with TLAI and canopy area. - ! ------------------------------------------------------------ currentCohort => currentPatch%tallest do while (associated(currentCohort)) + ! FIRST SOME CHECKS. fates_pft =currentCohort%pft - if(fates_pft.ne.currentPatch%nocomp_pft_label)then + if(fates_pft.ne.currentPatch%nocomp_pft_label)then ! does this cohort belong in this PFT patch? write(fates_log(),*) 'wrong PFT label in cohort in SP mode',fates_pft,currentPatch%nocomp_pft_label call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1453,6 +1451,8 @@ subroutine satellite_phenology(currentSite, bc_in) write(fates_log(),*) 'PFT0 in SP mode' call endrun(msg=errMsg(sourcefile, __LINE__)) end if + + ! Call routine to invert SP drivers into cohort properites. call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) currentCohort => currentCohort%shorter @@ -1466,6 +1466,7 @@ end subroutine satellite_phenology subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,leaf_c) + ! -----------------------------------------------------------------------------------! ! Takes the daily inputs of leaf area index, stem area index and canopy height and ! translates them into a FATES structure with one patch and one cohort per PFT ! The leaf area of the cohort is modified each day to match that asserted by the HLM @@ -1506,12 +1507,11 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l call h2d_allom(currentCohort%hite,fates_pft,currentCohort%dbh) currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. - spread = 1.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. + spread = 1.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in ! SP mode. call carea_allom(currentCohort%dbh,currentCohort%n,spread,currentCohort%pft,currentCohort%c_area) - !------------------------------------------ ! Calculate canopy N assuming patch area is full !------------------------------------------ @@ -1528,19 +1528,24 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) - !check reverse - maybe can delete eventually + !check that the inverse calculation of leafc from treelai is the same as the + ! standard calculation of treelai from leafc. Maybe can delete eventually? + check_treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & currentCohort%n, currentCohort%canopy_layer, & canopylai,currentCohort%vcmax25top ) - if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzerio (10^-16 typically) + if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzero write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%treelai-check_treelai call endrun(msg=errMsg(sourcefile, __LINE__)) end if - ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area - if(abs(currentCohort%c_area-parea).gt.nearzero)then + ! these mean that the canopy area does not exactly add up to the patch area, which causes chaos in + ! the radiation routines. Correct both the area and the 'n' to remove error, and don't use + !! carea_allom in SP mode after this point. + + if(abs(currentCohort%c_area-parea).gt.nearzero)then ! there is an error if(abs(currentCohort%c_area-parea).lt.10.e-9)then !correct this if it's a very sall error oldcarea = currentCohort%c_area !generate new cohort area From 9a9505f0322dad03ae0920f8e90617a7c285a7af Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 10 Nov 2020 12:57:32 -0500 Subject: [PATCH 131/578] Fixes to parteh scaling algorithm, particularly trivial boundary condition cases (prescribed N or P). --- biogeochem/FatesSoilBGCFluxMod.F90 | 105 ++++++++++++++++++----------- main/EDTypesMod.F90 | 4 +- main/FatesConstantsMod.F90 | 14 ++-- 3 files changed, 76 insertions(+), 47 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 258c37e847..be496db494 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -63,6 +63,7 @@ module FatesSoilBGCFluxMod use FatesConstantsMod, only : fates_np_comp_scaling use FatesConstantsMod, only : cohort_np_comp_scaling use FatesConstantsMod, only : pft_np_comp_scaling + use FatesCosntantsMod, only : trivial_np_comp_scaling use FatesConstantsMod, only : rsnbl_math_prec use FatesLitterMod, only : litter_type use FatesLitterMod , only : ncwd @@ -239,7 +240,6 @@ subroutine UnPackNutrientAquisitionBCs(sites, bc_in) return end if - do s = 1, nsites ! If the plant is in "prescribed uptake mode" @@ -453,24 +453,33 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) real(r8) :: deficit_p_demand ! Phosphorus needed to get stoich back to ! optimal [kgP] real(r8) :: comp_per_pft(numpft) ! Competitors per PFT, used for averaging + real(r8) :: decompmicc_layer ! Microbial dedcomposer biomass for current layer + integer :: comp_scaling ! Flag that defines the boundary condition scaling method (includes trivial) + + real(r8), parameter :: decompmicc_lambda = 2.5_r8 ! Depth attenuation exponent for decomposer biomass + real(r8), parameter :: decompmicc_zmax = 7.0e-2_r8 ! Depth of maximum decomposer biomass + - ! Run the trivial case where we do not have a nutrient model - ! running in fates, send zero demands to the BGC model - if((hlm_parteh_mode.ne.prt_cnp_flex_allom_hyp)) then + ! Determine the scaling approach + if((hlm_parteh_mode.eq.prt_cnp_flex_allom_hyp) .and. & + ((n_uptake_mode.eq.coupled_n_uptake) .or. & + (p_uptake_mode.eq.coupled_p_uptake))) then + comp_scaling = fates_np_comp_scaling + else + comp_scaling = trivial_np_comp_scaling bc_out%num_plant_comps = 1 if(trim(hlm_nu_com).eq.'ECA')then bc_out%ft_index(1) = 1 - bc_out%veg_rootc(1,:) = 0._r8 bc_out%cn_scalar(1) = 0._r8 bc_out%cp_scalar(1) = 0._r8 - bc_out%decompmicc(1) = 0._r8 elseif(trim(hlm_nu_com).eq.'RD') then bc_out%n_demand(1) = 0._r8 bc_out%p_demand(1) = 0._r8 + return end if - return end if + ! This is the number of effective soil layers to transfer from nlev_eff_soil = max(bc_in%max_rooting_depth_index_col, 1) @@ -480,8 +489,6 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) if(trim(hlm_nu_com).eq.'ECA')then bc_out%veg_rootc(:,:) = 0._r8 ! Zero this, it will be incremented - bc_out%cn_scalar(:) = 0._r8 - bc_out%cp_scalar(:) = 0._r8 bc_out%decompmicc(:) = 0._r8 bc_out%ft_index(:) = -1 @@ -497,12 +504,22 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) do while (associated(ccohort)) pft = ccohort%pft + + ! If we are not coupling plant uptake + ! with ECA, then we send 1 token + ! competitor with plant root biomass, but no + ! uptake affinity - if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then + if(comp_scaling.eq.trivial_comp_scaling) then + icomp = 1 + bc_out%ft_index(icomp) = 1 ! Trivial (not used) + elseif(comp_scaling.eq.cohort_np_comp_scaling) then icomp = icomp+1 + bc_out%ft_index(icomp) = pft else icomp = pft comp_per_pft(pft) = comp_per_pft(pft) + 1 + bc_out%ft_index(icomp) = pft end if call set_root_fraction(csite%rootfrac_scr, pft, csite%zi_soil) @@ -517,23 +534,22 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) id = bc_in%decomp_id(j) ! Map from soil layer to decomp layer veg_rootc = fnrt_c * ccohort%n * csite%rootfrac_scr(j) * AREA_INV * g_per_kg / csite%dz_soil(j) bc_out%veg_rootc(icomp,id) = bc_out%veg_rootc(icomp,id) + veg_rootc - bc_out%decompmicc(id) = bc_out%decompmicc(id) + & - EDPftvarcon_inst%decompmicc(pft) * veg_rootc + + ! We use a 3 parameter exponential attenuation function to estimate decomposer biomass + ! The parameter EDPftvarcon_inst%decompmicc(pft) is the maximum amount found at depth + ! decompmicc_zmax, and the profile attenuates with strength lambda + + decompmic_layer = EDPftvarcon_inst%decompmicc(pft) * & + exp(-decompmicc_lambda*abs(csite%z_soil(j)-decompmicc_zmax)) + + bc_out%decompmicc(id) = bc_out%decompmicc(id) + decompmic_layer * veg_rootc end do - - bc_out%ft_index(icomp) = pft ccohort => ccohort%shorter end do cpatch => cpatch%younger end do - - if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then - bc_out%num_plant_comps = icomp - else - bc_out%num_plant_comps = numpft - end if ! We calculate the decomposer microbial biomass by weighting with the ! root biomass. This is just the normalization step @@ -542,6 +558,18 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) max(nearzero,sum(bc_out%veg_rootc(:,id),dim=1)) end do + + if(comp_scaling.eq.cohort_np_comp_scaling) then + bc_out%num_plant_comps = icomp + elseif(comp_scaling.eq.pft_np_comp_scaling) then + bc_out%num_plant_comps = numpft + else + bc_out%num_plant_comps = 1 + bc_out%cn_scalar(:) = 0._r8 + bc_out%cp_scalar(:) = 0._r8 + return + end if + coupled_n_if: if(n_uptake_mode.eq.coupled_n_uptake) then icomp = 0 cpatch => csite%oldest_patch @@ -571,6 +599,12 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) bc_out%cn_scalar(icomp) = bc_out%cn_scalar(icomp)/real(comp_per_pft(icomp),r8) end do end if + + else + + ! If we are not coupling N, then make sure to set affinity of plants to 0 + ! (it is possible to be here if P is coupled but N is not) + bc_out%cn_scalar(:) = 0._r8 end if coupled_n_if @@ -603,6 +637,11 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) bc_out%cp_scalar(icomp) = bc_out%cp_scalar(icomp)/real(comp_per_pft(icomp),r8) end do end if + else + + ! If we are not coupling P, then make sure to set affinity of plants to 0 + ! (it is possible to be here if N is coupled but P is not) + bc_out%cp_scalar(:) = 0._r8 end if coupled_p_if @@ -624,6 +663,7 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) end do cpatch => cpatch%younger end do + end if if(p_uptake_mode .eq. coupled_p_uptake ) then @@ -690,17 +730,12 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) end do end if - if( (n_uptake_mode.eq.coupled_n_uptake) .or. & - (p_uptake_mode.eq.coupled_p_uptake)) then - if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then - bc_out%num_plant_comps = icomp - else - bc_out%num_plant_comps = numpft - end if - + if(comp_scaling.eq.cohort_np_comp_scaling) then + bc_out%num_plant_comps = icomp + elseif(comp_scaling.eq.pft_np_comp_scaling) then + bc_out%num_plant_comps = numpft else bc_out%num_plant_comps = 1 - end if end if @@ -787,7 +822,6 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) ! how steep profile is for surface components (1/ e_folding depth) (1/m) real(r8), parameter :: surfprof_exp = 10. - ! This is the number of effective soil layers to transfer from nlev_eff_soil = max(bc_in%max_rooting_depth_index_col, 1) @@ -841,11 +875,6 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) flux_lab_si => bc_out%litt_flux_lab_n_si(:) flux_lig_si => bc_out%litt_flux_lig_n_si(:) - ! If we have prescribed boundary conditions - ! we do not take N out of the BGC model's - ! stores, so nor do we send any back - if(n_uptake_mode.eq.prescribed_n_uptake) cycle - case (phosphorus_element) bc_out%litt_flux_cel_p_si(:) = 0._r8 bc_out%litt_flux_lig_p_si(:) = 0._r8 @@ -854,11 +883,6 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) flux_lab_si => bc_out%litt_flux_lab_p_si(:) flux_lig_si => bc_out%litt_flux_lig_p_si(:) - ! If we have prescribed boundary conditions - ! we do not take N out of the BGC model's - ! stores, so nor do we send any back - if(p_uptake_mode.eq.prescribed_p_uptake) cycle - end select @@ -957,7 +981,6 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) flux_lab_si(id) / bc_in%dz_decomp_sisl(id) end do - end do ! do elements diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 5ae635d5c8..13a08f6205 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -26,9 +26,9 @@ module EDTypesMod integer, parameter, public :: maxPatchesPerSite = 14 ! maximum number of patches to live on a site integer, parameter, public :: maxPatchesPerSite_by_disttype(n_anthro_disturbance_categories) = & (/ 10, 4 /) !!! MUST SUM TO maxPatchesPerSite !!! - integer, public :: maxCohortsPerPatch = 100 ! maximum number of cohorts per patch + integer, public :: maxCohortsPerPatch = 150 ! maximum number of cohorts per patch - integer, parameter, public :: nclmax = 2 ! Maximum number of canopy layers + integer, parameter, public :: nclmax = 3 ! Maximum number of canopy layers integer, parameter, public :: ican_upper = 1 ! Nominal index for the upper canopy integer, parameter, public :: ican_ustory = 2 ! Nominal index for diagnostics that refer ! to understory layers (all layers that diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 66d089a895..7e19856aa2 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -48,13 +48,19 @@ module FatesConstantsMod integer, public, parameter :: cohort_np_comp_scaling = 1 ! This flag definition indicates that EVERY cohort on - ! the column should compete independently in the soil - ! BGC nitrogen and phosphorus acquisition scheme. + ! the column should compete independently in the soil + ! BGC nitrogen and phosphorus acquisition scheme. integer, public, parameter :: pft_np_comp_scaling = 2 ! This flag definition indicates that cohorts should - ! be grouped into PFTs, and each PFT will be represented - ! as the competitor, in the BGC N and P acquisition scheme + ! be grouped into PFTs, and each PFT will be represented + ! as the competitor, in the BGC N and P acquisition scheme + integer, public, parameter :: trivial_np_comp_scaling = 3 ! This flag definition indicates that either + ! nutrients are turned off in FATES, or, that the + ! plants are not coupled with below ground chemistry. In + ! this situation, we send token boundary condition information. + + ! This flag specifies the scaling of how we present ! nutrient competitors to the HLM's soil BGC model From 8fdb1d9f482effe7be10d5064f70ebca9c425693 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 10 Nov 2020 16:30:05 -0500 Subject: [PATCH 132/578] cnp boundary scaling fixes --- biogeochem/FatesSoilBGCFluxMod.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index be496db494..36499e6544 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -63,7 +63,7 @@ module FatesSoilBGCFluxMod use FatesConstantsMod, only : fates_np_comp_scaling use FatesConstantsMod, only : cohort_np_comp_scaling use FatesConstantsMod, only : pft_np_comp_scaling - use FatesCosntantsMod, only : trivial_np_comp_scaling + use FatesConstantsMod, only : trivial_np_comp_scaling use FatesConstantsMod, only : rsnbl_math_prec use FatesLitterMod, only : litter_type use FatesLitterMod , only : ncwd @@ -510,7 +510,7 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) ! competitor with plant root biomass, but no ! uptake affinity - if(comp_scaling.eq.trivial_comp_scaling) then + if(comp_scaling.eq.trivial_np_comp_scaling) then icomp = 1 bc_out%ft_index(icomp) = 1 ! Trivial (not used) elseif(comp_scaling.eq.cohort_np_comp_scaling) then @@ -539,10 +539,10 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) ! The parameter EDPftvarcon_inst%decompmicc(pft) is the maximum amount found at depth ! decompmicc_zmax, and the profile attenuates with strength lambda - decompmic_layer = EDPftvarcon_inst%decompmicc(pft) * & + decompmicc_layer = EDPftvarcon_inst%decompmicc(pft) * & exp(-decompmicc_lambda*abs(csite%z_soil(j)-decompmicc_zmax)) - bc_out%decompmicc(id) = bc_out%decompmicc(id) + decompmic_layer * veg_rootc + bc_out%decompmicc(id) = bc_out%decompmicc(id) + decompmicc_layer * veg_rootc end do ccohort => ccohort%shorter From 54fc2d68243d575342a8d45c9143662b1355496b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 11 Nov 2020 12:00:06 -0500 Subject: [PATCH 133/578] Condensing the N/P need diagnostics --- biogeochem/EDCohortDynamicsMod.F90 | 37 +++++-------- biogeochem/FatesSoilBGCFluxMod.F90 | 4 +- main/EDMainMod.F90 | 20 +++---- main/EDTypesMod.F90 | 17 +++--- main/FatesHistoryInterfaceMod.F90 | 86 +++++++++--------------------- main/FatesRestartInterfaceMod.F90 | 8 +-- parteh/PRTAllometricCNPMod.F90 | 25 +++------ 7 files changed, 61 insertions(+), 136 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index f29fd27fc4..adf9686630 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -409,10 +409,8 @@ subroutine InitPRTBoundaryConditions(new_cohort) call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_cefflux, bc_rval = new_cohort%daily_c_efflux) call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_nefflux, bc_rval = new_cohort%daily_n_efflux) call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_pefflux, bc_rval = new_cohort%daily_p_efflux) - call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_ngrow, bc_rval = new_cohort%daily_n_need1) - call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_nmax, bc_rval = new_cohort%daily_n_need2) - call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_pgrow, bc_rval = new_cohort%daily_p_need1) - call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_pmax, bc_rval = new_cohort%daily_p_need2) + call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_nneed, bc_rval = new_cohort%daily_n_need) + call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_pneed, bc_rval = new_cohort%daily_p_need) case DEFAULT @@ -564,10 +562,8 @@ subroutine nan_cohort(cc_p) currentCohort%daily_c_efflux = nan currentCohort%daily_n_efflux = nan currentCohort%daily_p_efflux = nan - currentCohort%daily_n_need1 = nan - currentCohort%daily_n_need2 = nan - currentCohort%daily_p_need1 = nan - currentCohort%daily_p_need2 = nan + currentCohort%daily_n_need = nan + currentCohort%daily_p_need = nan currentCohort%daily_n_demand = nan currentCohort%daily_p_demand = nan @@ -685,10 +681,8 @@ subroutine zero_cohort(cc_p) currentCohort%daily_n_efflux = 0._r8 currentCohort%daily_p_efflux = 0._r8 - currentCohort%daily_n_need1 = 0._r8 - currentCohort%daily_n_need2 = 0._r8 - currentCohort%daily_p_need1 = 0._r8 - currentCohort%daily_p_need2 = 0._r8 + currentCohort%daily_n_need = 0._r8 + currentCohort%daily_p_need = 0._r8 ! Initialize these as negative currentCohort%daily_p_demand = -9._r8 @@ -1413,15 +1407,10 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) currentCohort%daily_p_efflux = (currentCohort%n*currentCohort%daily_p_efflux + & nextc%n*nextc%daily_p_efflux)/newn - currentCohort%daily_n_need1 = (currentCohort%n*currentCohort%daily_n_need1 + & - nextc%n*nextc%daily_n_need1)/newn - currentCohort%daily_n_need2 = (currentCohort%n*currentCohort%daily_n_need2 + & - nextc%n*nextc%daily_n_need2)/newn - currentCohort%daily_p_need1 = (currentCohort%n*currentCohort%daily_p_need1 + & - nextc%n*nextc%daily_p_need1)/newn - currentCohort%daily_p_need2 = (currentCohort%n*currentCohort%daily_p_need2 + & - nextc%n*nextc%daily_p_need2)/newn - + currentCohort%daily_n_need = (currentCohort%n*currentCohort%daily_n_need + & + nextc%n*nextc%daily_n_need)/newn + currentCohort%daily_p_need = (currentCohort%n*currentCohort%daily_p_need + & + nextc%n*nextc%daily_p_need)/newn ! logging mortality, Yi Xu @@ -1822,10 +1811,8 @@ subroutine copy_cohort( currentCohort,copyc ) n%daily_c_efflux = o%daily_c_efflux n%daily_n_efflux = o%daily_n_efflux n%daily_p_efflux = o%daily_p_efflux - n%daily_n_need1 = o%daily_n_need1 - n%daily_n_need2 = o%daily_n_need2 - n%daily_p_need1 = o%daily_p_need1 - n%daily_p_need2 = o%daily_p_need2 + n%daily_n_need = o%daily_n_need + n%daily_p_need = o%daily_p_need n%daily_n_demand = o%daily_n_demand n%daily_p_demand = o%daily_p_demand diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 36499e6544..83d0620100 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -166,11 +166,11 @@ function GetPlantDemand(ccohort,element_id) result(plant_demand) if(element_id.eq.nitrogen_element) then - plant_demand = smth_fac*ccohort%daily_n_demand + (1._r8-smth_fac)*ccohort%daily_n_need2 + plant_demand = smth_fac*ccohort%daily_n_demand + (1._r8-smth_fac)*ccohort%daily_n_need elseif(element_id.eq.phosphorus_element) then - plant_demand = smth_fac*ccohort%daily_p_demand + (1._r8-smth_fac)*ccohort%daily_p_need2 + plant_demand = smth_fac*ccohort%daily_p_demand + (1._r8-smth_fac)*ccohort%daily_p_need end if diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 1188802e03..e1e122e88f 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -476,21 +476,13 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) currentCohort%daily_c_efflux*currentCohort%n ! Diagnostics on plant nutrient need - currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_needgrow_scpf(iscpf) = & - currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_needgrow_scpf(iscpf) + & - currentCohort%daily_n_need1*currentCohort%n + currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_need_scpf(iscpf) = & + currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_need_scpf(iscpf) + & + currentCohort%daily_n_need*currentCohort%n - currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_needmax_scpf(iscpf) = & - currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_needmax_scpf(iscpf) + & - currentCohort%daily_n_need2*currentCohort%n - - currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_needgrow_scpf(iscpf) = & - currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_needgrow_scpf(iscpf) + & - currentCohort%daily_p_need1*currentCohort%n - - currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_needmax_scpf(iscpf) = & - currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_needmax_scpf(iscpf) + & - currentCohort%daily_p_need2*currentCohort%n + currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_need_scpf(iscpf) = & + currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_need_scpf(iscpf) + & + currentCohort%daily_p_need*currentCohort%n end if diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 13a08f6205..4373ef24c0 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -289,14 +289,11 @@ module EDTypesMod real(r8) :: daily_n_efflux ! daily mean efflux of excess nitrogen from roots into labile pool [kg N/plant/day] real(r8) :: daily_p_efflux ! daily mean efflux of excess phophorus from roots into labile pool [kg P/plant/day] - real(r8) :: daily_n_need1 ! Nitrogen needed to enable non-limited C growth (AllometricCNP hypothesis) - real(r8) :: daily_n_need2 ! Nitrogen needed to bring N concentrations up to optimal - real(r8) :: daily_p_need1 ! Phosphorus needed to enable non-limited C growth (AllometricCNP hypothesis) - real(r8) :: daily_p_need2 ! Phosphorus needed to bring P concentrations up to optimal + real(r8) :: daily_n_need ! Generic Nitrogen need of the plant, (hypothesis dependent) [kgN/plant/day] + real(r8) :: daily_p_need ! Generic Phosphorus need of the plant, (hypothesis dependent) [kgN/plant/day] + ! These two variables may use the previous "need" variables, by applying a smoothing function. - ! Or, its possible that the plant will use another method to calculate this, perhaps based - ! on storage. ! These variables are used in two scenarios. 1) They work with the prescribed uptake fraction ! in un-coupled mode, and 2) They are the plant's demand subbmitted to the Relative-Demand ! type soil BGC scheme. @@ -602,8 +599,7 @@ module EDTypesMod real(r8),allocatable :: nutrient_uptake_scpf(:) real(r8),allocatable :: nutrient_efflux_scpf(:) - real(r8),allocatable :: nutrient_needgrow_scpf(:) - real(r8),allocatable :: nutrient_needmax_scpf(:) + real(r8),allocatable :: nutrient_need_scpf(:) contains @@ -743,7 +739,7 @@ module EDTypesMod real(r8), allocatable :: dz_soil(:) ! layer thickness (m) real(r8), allocatable :: z_soil(:) ! layer depth (m) real(r8), allocatable :: rootfrac_scr(:) ! This is just allocated scratch space to hold - ! root fractions. Since root fractions may be dependant + ! root fractions. Since root fractions may be dependent ! on cohort properties, and we do not want to store this infromation ! on each cohort, we do not keep root fractions in ! memory, and instead calculate them on demand. @@ -835,8 +831,7 @@ subroutine ZeroFluxDiags(this) this%root_litter_input(:) = 0._r8 this%nutrient_uptake_scpf(:) = 0._r8 this%nutrient_efflux_scpf(:) = 0._r8 - this%nutrient_needgrow_scpf(:) = 0._r8 - this%nutrient_needmax_scpf(:) = 0._r8 + this%nutrient_need_scpf(:) = 0._r8 return end subroutine ZeroFluxDiags diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 1abff247e9..ec3060a810 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -171,10 +171,8 @@ module FatesHistoryInterfaceMod integer :: ih_cefflux_si integer :: ih_nefflux_si integer :: ih_pefflux_si - integer :: ih_nneedgrow_si - integer :: ih_nneedmax_si - integer :: ih_pneedgrow_si - integer :: ih_pneedmax_si + integer :: ih_nneed_si + integer :: ih_pneed_si integer :: ih_trimming_si integer :: ih_area_plant_si @@ -218,8 +216,7 @@ module FatesHistoryInterfaceMod integer :: ih_repron_scpf integer :: ih_nuptake_scpf integer :: ih_nefflux_scpf - integer :: ih_nneedgrow_scpf - integer :: ih_nneedmax_scpf + integer :: ih_nneed_scpf integer :: ih_totvegc_scpf integer :: ih_leafc_scpf @@ -237,8 +234,7 @@ module FatesHistoryInterfaceMod integer :: ih_sapwp_scpf integer :: ih_puptake_scpf integer :: ih_pefflux_scpf - integer :: ih_pneedgrow_scpf - integer :: ih_pneedmax_scpf + integer :: ih_pneed_scpf integer :: ih_daily_temp integer :: ih_daily_rh @@ -3066,17 +3062,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_nefflux_scpf)%r82d(io_si,:) = & sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) - this%hvars(ih_nneedgrow_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_needgrow_scpf(:) - - this%hvars(ih_nneedmax_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_needmax_scpf(:) + this%hvars(ih_nneed_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_need_scpf(:) - this%hvars(ih_nneedgrow_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_needgrow_scpf(:),dim=1) - - this%hvars(ih_nneedmax_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_needmax_scpf(:),dim=1) + this%hvars(ih_nneed_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_need_scpf(:),dim=1) this%hvars(ih_nuptake_si)%r81d(io_si) = & sum(sites(s)%flux_diags(el)%nutrient_uptake_scpf(:),dim=1) @@ -3099,17 +3089,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_pefflux_scpf)%r82d(io_si,:) = & sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) - this%hvars(ih_pneedgrow_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_needgrow_scpf(:) - - this%hvars(ih_pneedmax_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_needmax_scpf(:) - - this%hvars(ih_pneedgrow_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_needgrow_scpf(:),dim=1) + this%hvars(ih_pneed_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_need_scpf(:) - this%hvars(ih_pneedmax_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_needmax_scpf(:),dim=1) + this%hvars(ih_pneed_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_need_scpf(:),dim=1) this%hvars(ih_puptake_si)%r81d(io_si) = & sum(sites(s)%flux_diags(el)%nutrient_uptake_scpf(:),dim=1) @@ -4611,15 +4595,10 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_nefflux_si ) - call this%set_history_var(vname='NNEED_GROW', units='kgN d-1 ha-1', & - long='(Approx) plant nitrogen needed to satisfy growth', use_default='active', & + call this%set_history_var(vname='NNEED', units='kgN d-1 ha-1', & + long='Plant nitrogen need (algorithm dependent)', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_nneedgrow_si ) - - call this%set_history_var(vname='NNEED_MAX', units='kgN d-1 ha-1', & - long='(Approx) plant nitrogen needed to reach maximum capacity', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_nneedmax_si ) + ivar=ivar, initialize=initialize_variables, index = ih_nneed_si ) end if nitrogen_active_if @@ -4665,17 +4644,11 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_pefflux_si ) - call this%set_history_var(vname='PNEED_GROW', units='kgP ha-1 d-1', & - long='Plant phosphorus needed to satisfy growth', use_default='active', & + call this%set_history_var(vname='PNEED', units='kgP ha-1 d-1', & + long='Plant phosphorus need (algorithm dependent)', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_pneedgrow_si ) + ivar=ivar, initialize=initialize_variables, index = ih_pneed_si ) - call this%set_history_var(vname='PNEED_MAX', units='kgP ha-1 d-1', & - long='Plant phosphorus needed to reach maximum capacity', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_pneedmax_si ) - - end if phosphorus_active_if @@ -5944,16 +5917,10 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nefflux_scpf ) - call this%set_history_var(vname='NNEEDGROW_SCPF', units='kgN d-1 ha-1', & - long='nitrogen needed to match growth, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nneedgrow_scpf ) - - call this%set_history_var(vname='NNEEDMAX_SCPF', units='kgN d-1 ha-1', & - long='nitrogen needed to reach max concentrations, by size-class x pft', use_default='inactive', & + call this%set_history_var(vname='NNEED_SCPF', units='kgN d-1 ha-1', & + long='plant N need (algorithm dependent), by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nneedmax_scpf ) - + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nneed_scpf ) end if nitrogen_active_if2 @@ -5999,15 +5966,10 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_pefflux_scpf ) - call this%set_history_var(vname='PNEEDGROW_SCPF', units='kg/ha/day', & - long='phosphorus needed to match growth, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_pneedgrow_scpf ) - - call this%set_history_var(vname='PNEEDMAX_SCPF', units='kg/ha/day', & - long='phosphorus needed to reach max concentrations, by size-class x pft', use_default='inactive', & + call this%set_history_var(vname='PNEED_SCPF', units='kg/ha/day', & + long='plant P need (algorithm dependent), by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_pneedmax_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_pneed_scpf ) end if phosphorus_active_if2 diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 0b621dec0a..c39893e5f3 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -1881,8 +1881,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_daily_n_demand_co(io_idx_co) = ccohort%daily_n_demand rio_daily_p_demand_co(io_idx_co) = ccohort%daily_p_demand - rio_daily_n_need_co(io_idx_co) = ccohort%daily_n_need2 - rio_daily_p_need_co(io_idx_co) = ccohort%daily_p_need2 + rio_daily_n_need_co(io_idx_co) = ccohort%daily_n_need + rio_daily_p_need_co(io_idx_co) = ccohort%daily_p_need !Logging rio_lmort_direct_co(io_idx_co) = ccohort%lmort_direct @@ -2628,8 +2628,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%daily_n_demand = rio_daily_n_demand_co(io_idx_co) ccohort%daily_p_demand = rio_daily_p_demand_co(io_idx_co) - ccohort%daily_n_need2 = rio_daily_n_need_co(io_idx_co) - ccohort%daily_p_need2 = rio_daily_p_need_co(io_idx_co) + ccohort%daily_n_need = rio_daily_n_need_co(io_idx_co) + ccohort%daily_p_need = rio_daily_p_need_co(io_idx_co) !Logging ccohort%lmort_direct = rio_lmort_direct_co(io_idx_co) diff --git a/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 index ccefa67924..043638c442 100644 --- a/parteh/PRTAllometricCNPMod.F90 +++ b/parteh/PRTAllometricCNPMod.F90 @@ -159,12 +159,10 @@ module PRTAllometricCNPMod integer, public, parameter :: acnp_bc_out_id_cefflux = 1 ! Daily exudation of C [kg] integer, public, parameter :: acnp_bc_out_id_nefflux = 2 ! Daily exudation of N [kg] integer, public, parameter :: acnp_bc_out_id_pefflux = 3 ! Daily exudation of P [kg] - integer, public, parameter :: acnp_bc_out_id_ngrow = 4 ! N needed to match C growth at low N/C - integer, public, parameter :: acnp_bc_out_id_nmax = 5 ! N needed to match C growth at max N/C - integer, public, parameter :: acnp_bc_out_id_pgrow = 6 ! P needed to match C growth at low P/C - integer, public, parameter :: acnp_bc_out_id_pmax = 7 ! P needed to match C growth at max P/C + integer, public, parameter :: acnp_bc_out_id_nneed = 4 ! N need (algorithm dependent [kgN] + integer, public, parameter :: acnp_bc_out_id_pneed = 5 ! P need (algorithm dependent [kgP] - integer, parameter :: num_bc_out = 7 ! Total number of + integer, parameter :: num_bc_out = 5 ! Total number of ! ------------------------------------------------------------------------------------- @@ -337,10 +335,8 @@ subroutine DailyPRTAllometricCNP(this) real(r8),pointer :: c_efflux ! Total plant efflux of carbon (kgC) real(r8),pointer :: n_efflux ! Total plant efflux of nitrogen (kgN) real(r8),pointer :: p_efflux ! Total plant efflux of phosphorus (kgP) - real(r8),pointer :: n_grow ! N needed to match C stature growth (kgN) - real(r8),pointer :: n_max ! N needed to reach max stoich at final C (kgN) - real(r8),pointer :: p_grow ! P needed to match C stature growth (kgP) - real(r8),pointer :: p_max ! P needed to reach max stoich at final C (kgP) + real(r8),pointer :: n_need ! N need (algorithm dependent) (kgN) + real(r8),pointer :: p_need ! P need (algorithm dependent) (KgP) real(r8),pointer :: growth_r ! Total plant growth respiration this step (kgC) ! These are pointers to the state variables, rearranged in organ dimensioned @@ -488,10 +484,6 @@ subroutine DailyPRTAllometricCNP(this) call this%CNPPrioritizedReplacement(maint_r_def, c_gain_unl, n_gain_unl, p_gain_unl, & state_c, state_n, state_p, target_c) - ! Uncomment to see intermediate n and p needs - !n_grow = n_gain_unl0 - n_gain_unl - !p_grow = p_gain_unl0 - p_gain_unl - ! =================================================================================== ! Step 2. Grow out the stature of the plant by allocating to tissues beyond ! current targets. @@ -502,9 +494,6 @@ subroutine DailyPRTAllometricCNP(this) call this%CNPStatureGrowth(c_gain_unl, n_gain_unl, p_gain_unl, & state_c, state_n, state_p, target_c, target_dcdd, cnp_limiter) - n_grow = max(0._r8,(n_gain_unl0 - n_gain_unl)) - p_grow = max(0._r8,(p_gain_unl0 - p_gain_unl)) - ! =================================================================================== ! Step 3. ! At this point, 1 of the 3 resources (C,N,P) has been used up for stature growth. @@ -515,8 +504,8 @@ subroutine DailyPRTAllometricCNP(this) state_c, state_n, state_p, c_efflux, n_efflux, p_efflux) - n_max = max(n_gain_unl0 - n_efflux,0._r8) - p_max = max(p_gain_unl0 - p_efflux,0._r8) + n_need = max(n_gain_unl0 - n_efflux,0._r8) + p_need = max(p_gain_unl0 - p_efflux,0._r8) ! We must now reset the state so that we can perform nutrient limited allocation From 60fb19caf56feb7e27831888a2a81d0c41c5d16a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 11 Nov 2020 12:26:41 -0500 Subject: [PATCH 134/578] Updated need algorithm to use storage deficit --- parteh/PRTAllometricCNPMod.F90 | 40 +++++++++++++++++++++++----------- 1 file changed, 27 insertions(+), 13 deletions(-) diff --git a/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 index 043638c442..59ca74dae1 100644 --- a/parteh/PRTAllometricCNPMod.F90 +++ b/parteh/PRTAllometricCNPMod.F90 @@ -159,8 +159,8 @@ module PRTAllometricCNPMod integer, public, parameter :: acnp_bc_out_id_cefflux = 1 ! Daily exudation of C [kg] integer, public, parameter :: acnp_bc_out_id_nefflux = 2 ! Daily exudation of N [kg] integer, public, parameter :: acnp_bc_out_id_pefflux = 3 ! Daily exudation of P [kg] - integer, public, parameter :: acnp_bc_out_id_nneed = 4 ! N need (algorithm dependent [kgN] - integer, public, parameter :: acnp_bc_out_id_pneed = 5 ! P need (algorithm dependent [kgP] + integer, public, parameter :: acnp_bc_out_id_nneed = 4 ! N need [kgN] + integer, public, parameter :: acnp_bc_out_id_pneed = 5 ! P need [kgP] integer, parameter :: num_bc_out = 5 ! Total number of @@ -335,8 +335,8 @@ subroutine DailyPRTAllometricCNP(this) real(r8),pointer :: c_efflux ! Total plant efflux of carbon (kgC) real(r8),pointer :: n_efflux ! Total plant efflux of nitrogen (kgN) real(r8),pointer :: p_efflux ! Total plant efflux of phosphorus (kgP) - real(r8),pointer :: n_need ! N need (algorithm dependent) (kgN) - real(r8),pointer :: p_need ! P need (algorithm dependent) (KgP) + real(r8),pointer :: n_need ! N need (algorithm dependant) (kgN) + real(r8),pointer :: p_need ! P need (algorithm dependant) (kgP) real(r8),pointer :: growth_r ! Total plant growth respiration this step (kgC) ! These are pointers to the state variables, rearranged in organ dimensioned @@ -382,7 +382,10 @@ subroutine DailyPRTAllometricCNP(this) real(r8) :: allocated_p real(r8) :: sum_c ! error checking sum - logical, parameter :: prt_assess_nutr_need = .true. + + integer, parameter :: unrstr_cgrow_nutr_need = 1 + integer, parameter :: refill_store_nutr_need = 2 + integer, parameter :: nutr_need_mode = refill_store_nutr_need ! integrator variables @@ -402,10 +405,9 @@ subroutine DailyPRTAllometricCNP(this) c_efflux => this%bc_out(acnp_bc_out_id_cefflux)%rval; c_efflux = 0._r8 n_efflux => this%bc_out(acnp_bc_out_id_nefflux)%rval; n_efflux = 0._r8 p_efflux => this%bc_out(acnp_bc_out_id_pefflux)%rval; p_efflux = 0._r8 - n_grow => this%bc_out(acnp_bc_out_id_ngrow)%rval; n_grow = fates_unset_r8 - n_max => this%bc_out(acnp_bc_out_id_nmax)%rval; n_max = fates_unset_r8 - p_grow => this%bc_out(acnp_bc_out_id_pgrow)%rval; p_grow = fates_unset_r8 - p_max => this%bc_out(acnp_bc_out_id_pmax)%rval; p_max = fates_unset_r8 + n_need => this%bc_out(acnp_bc_out_id_nneed)%rval; n_need = fates_unset_r8 + p_need => this%bc_out(acnp_bc_out_id_pneed)%rval; p_need = fates_unset_r8 + ! In/out boundary conditions maint_r_def => this%bc_inout(acnp_bc_inout_id_rmaint_def)%rval; maint_r_def0 = maint_r_def @@ -474,7 +476,7 @@ subroutine DailyPRTAllometricCNP(this) end do - assess_need_if: if(prt_assess_nutr_need) then + assess_need_if: if(nutr_need_mode.eq.unrstr_cgrow_nutr_need) then ! =================================================================================== ! Step 1. Prioritized allocation to replace tissues from turnover, and/or pay @@ -484,6 +486,10 @@ subroutine DailyPRTAllometricCNP(this) call this%CNPPrioritizedReplacement(maint_r_def, c_gain_unl, n_gain_unl, p_gain_unl, & state_c, state_n, state_p, target_c) + ! Uncomment to see intermediate n and p needs + !n_grow = n_gain_unl0 - n_gain_unl + !p_grow = p_gain_unl0 - p_gain_unl + ! =================================================================================== ! Step 2. Grow out the stature of the plant by allocating to tissues beyond ! current targets. @@ -503,10 +509,8 @@ subroutine DailyPRTAllometricCNP(this) call this%CNPAllocateRemainder(c_gain_unl, n_gain_unl, p_gain_unl, & state_c, state_n, state_p, c_efflux, n_efflux, p_efflux) - n_need = max(n_gain_unl0 - n_efflux,0._r8) p_need = max(p_gain_unl0 - p_efflux,0._r8) - ! We must now reset the state so that we can perform nutrient limited allocation ! Note: Even if there is more than 1 leaf pool, allocation only modifies @@ -650,7 +654,17 @@ subroutine DailyPRTAllometricCNP(this) end do - + ! Alternative need hypothesis, need is based simply on storage deficit + ! at end of time-step + if(nutr_need_mode.eq.refill_store_nutr_need) then + call bstore_allom(dbh,ipft,canopy_trim, store_c_target) + store_n_target = store_c_target*prt_params%nitr_stoich_p2(ipft,store_organ) + store_p_target = store_c_target*prt_params%phos_stoich_p2(ipft,store_organ) + n_need = max(store_n_target-state_n(store_id)%ptr,0._r8) + p_need = max(store_p_target-state_p(store_id)%ptr,0._r8) + end if + + if(debug) then ! Error Check: Do a final balance between how much mass From ca81774a585983e18916b2a0f616d309fc30171e Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 13 Nov 2020 06:00:31 -0700 Subject: [PATCH 135/578] reverting canopy area error tolerance back to previous higher value --- biogeochem/EDCanopyStructureMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index d3109383ce..d9d44a8e31 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1387,7 +1387,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) enddo ! ends 'do while(associated(currentCohort)) if ( currentPatch%total_canopy_area>currentPatch%area ) then - if ( currentPatch%total_canopy_area-currentPatch%area > 1.0e-10_r8 ) then + if ( currentPatch%total_canopy_area-currentPatch%area > 0.001_r8 ) then write(fates_log(),*) 'FATES: canopy area bigger than area', & currentPatch%total_canopy_area ,currentPatch%area, & currentPatch%total_canopy_area -currentPatch%area,& From 63359083fdfef00da3d38b5b7381f45a38f57783 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 13 Nov 2020 15:45:51 -0700 Subject: [PATCH 136/578] fixed error in fire intensity calculation --- fire/SFMainMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index dd417c9974..c48543b861 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -800,8 +800,8 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) W = currentPatch%TFC_ROS / 0.45_r8 !kgC/m2 to kgbiomass/m2 ! EQ 15 Thonicke et al 2010 - !units of fire intensity = (kJ/kg)*(kgBiomass/m2)*(m/min)*unitless_fraction - currentPatch%FI = SF_val_fuel_energy * W * ROS * currentPatch%frac_burnt !kj/m/s, or kW/m + !units of fire intensity = (kJ/kg)*(kgBiomass/m2)*(m/min) + currentPatch%FI = SF_val_fuel_energy * W * ROS !kj/m/s, or kW/m if(write_sf == itrue)then if( hlm_masterproc == itrue ) write(fates_log(),*) 'fire_intensity',currentPatch%fi,W,currentPatch%ROS_front From 41f5dea20812a971769e0cb238bb1da31ef9ed80 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 13 Nov 2020 16:09:55 -0700 Subject: [PATCH 137/578] added diagnostic to track total number of succesful iginitions, and added that to history --- fire/SFMainMod.F90 | 6 ++++-- main/EDInitMod.F90 | 2 ++ main/EDTypesMod.F90 | 1 + main/FatesHistoryInterfaceMod.F90 | 4 ++-- 4 files changed, 9 insertions(+), 4 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index c48543b861..8591b31b89 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -696,7 +696,7 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) ! ---initialize site parameters to zero--- currentSite%frac_burnt = 0.0_r8 - + currentSite%NF_successful = 0._r8 ! Equation 7 from Venevsky et al GCB 2002 (modification of equation 8 in Thonicke et al. 2010) ! FDI 0.1 = low, 0.3 moderate, 0.75 high, and 1 = extreme ignition potential for alpha 0.000337 @@ -810,7 +810,9 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) !'decide_fire' subroutine if (currentPatch%FI > SF_val_fire_threshold) then !track fires greater than kW/m energy threshold currentPatch%fire = 1 ! Fire... :D - + ! + currentSite%NF_successful = currentSite%NF_successful + & + currentSite%NF * currentSite%FDI * currentPatch%area / area else currentPatch%fire = 0 ! No fire... :-/ currentPatch%FD = 0.0_r8 diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index bec7a99537..caf93f8a7f 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -186,6 +186,7 @@ subroutine zero_site( site_in ) ! FIRE site_in%acc_ni = 0.0_r8 ! daily nesterov index accumulating over time. time unlimited theoretically. site_in%NF = 0.0_r8 ! daily lightning strikes per km2 + site_in%NF_successful = 0.0_r8 ! daily successful iginitions per km2 site_in%frac_burnt = 0.0_r8 ! burn area read in from external file do el=1,num_elements @@ -296,6 +297,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) sites(s)%acc_NI = acc_NI sites(s)%NF = 0.0_r8 + sites(s)%NF_successful = 0.0_r8 sites(s)%frac_burnt = 0.0_r8 ! PLACEHOLDER FOR PFT AREA DATA MOVED ACROSS INTERFACE diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 7288a4ef99..9a5fa28e6c 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -730,6 +730,7 @@ module EDTypesMod real(r8) :: acc_ni ! daily nesterov index accumulating over time. real(r8) :: fdi ! daily probability an ignition event will start a fire real(r8) :: NF ! daily ignitions in km2 + real(r8) :: NF_successful ! daily ignitions in km2 that actually lead to fire real(r8) :: frac_burnt ! fraction of area burnt in this day. ! PLANT HYDRAULICS diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index ec02ecbfc1..f1789495af 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2071,7 +2071,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! site-level fire variables hio_nesterov_fire_danger_si(io_si) = sites(s)%acc_NI - hio_fire_nignitions_si(io_si) = sites(s)%NF + hio_fire_nignitions_si(io_si) = sites(s)%NF_successful hio_fire_fdi_si(io_si) = sites(s)%FDI ! If hydraulics are turned on, track the error terms @@ -4362,7 +4362,7 @@ subroutine define_history_vars(this, initialize_variables) ivar=ivar, initialize=initialize_variables, index = ih_nesterov_fire_danger_si) call this%set_history_var(vname='FIRE_IGNITIONS', units='number/km2/day', & - long='number of ignitions', use_default='active', & + long='number of successful ignitions', 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_nignitions_si) From 8c3a99a44c48b0a0d0176357e82fb70865aa4188 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 16 Nov 2020 10:30:56 -0500 Subject: [PATCH 138/578] Updates to parteh and nutrient coupling. Mostly related to defining maximum storage, and fixes to defining plant need and its relationship to storage --- biogeochem/EDCohortDynamicsMod.F90 | 4 +- biogeochem/EDPhysiologyMod.F90 | 31 ++++++----- biogeochem/FatesSoilBGCFluxMod.F90 | 12 +++-- main/EDInitMod.F90 | 3 +- parteh/PRTAllometricCNPMod.F90 | 87 ++++++++++++++++++++++-------- 5 files changed, 93 insertions(+), 44 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index adf9686630..8d5188a0af 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -94,8 +94,8 @@ module EDCohortDynamicsMod use PRTAllometricCNPMod, only : acnp_bc_in_id_netdn, acnp_bc_in_id_netdp use PRTAllometricCNPMod, only : acnp_bc_out_id_cefflux, acnp_bc_out_id_nefflux use PRTAllometricCNPMod, only : acnp_bc_out_id_pefflux - use PRTAllometricCNPMod, only : acnp_bc_out_id_ngrow,acnp_bc_out_id_nmax - use PRTAllometricCNPMod, only : acnp_bc_out_id_pgrow,acnp_bc_out_id_pmax + use PRTAllometricCNPMod, only : acnp_bc_out_id_nneed + use PRTAllometricCNPMod, only : acnp_bc_out_id_pneed use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index e5cd6ce45c..1525133dff 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1701,19 +1701,20 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) case(nitrogen_element) - mass_demand = c_struct*prt_params%nitr_stoich_p1(ft,struct_organ) + & - c_leaf*prt_params%nitr_stoich_p1(ft,leaf_organ) + & - c_fnrt*prt_params%nitr_stoich_p1(ft,fnrt_organ) + & - c_sapw*prt_params%nitr_stoich_p1(ft,sapw_organ) + & - c_store*prt_params%nitr_stoich_p1(ft,store_organ) - + mass_demand = (1._r8 + prt_params%nitr_stoich_p1(ft,store_organ)) * & + (c_struct*prt_params%nitr_stoich_p1(ft,struct_organ) + & + c_leaf*prt_params%nitr_stoich_p1(ft,leaf_organ) + & + c_fnrt*prt_params%nitr_stoich_p1(ft,fnrt_organ) + & + c_sapw*prt_params%nitr_stoich_p1(ft,sapw_organ)) + case(phosphorus_element) - - mass_demand = c_struct*prt_params%phos_stoich_p1(ft,struct_organ) + & - c_leaf*prt_params%phos_stoich_p1(ft,leaf_organ) + & - c_fnrt*prt_params%phos_stoich_p1(ft,fnrt_organ) + & - c_sapw*prt_params%phos_stoich_p1(ft,sapw_organ) + & - c_store*prt_params%phos_stoich_p1(ft,store_organ) + + mass_demand = (1._r8 + prt_params%phos_stoich_p1(ft,store_organ)) * & + (c_struct*prt_params%phos_stoich_p1(ft,struct_organ) + & + c_leaf*prt_params%phos_stoich_p1(ft,leaf_organ) + & + c_fnrt*prt_params%phos_stoich_p1(ft,fnrt_organ) + & + c_sapw*prt_params%phos_stoich_p1(ft,sapw_organ)) + case default write(fates_log(),*) 'Undefined element type in recruitment' @@ -1771,7 +1772,8 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) m_leaf = c_leaf*prt_params%nitr_stoich_p1(ft,leaf_organ) m_fnrt = c_fnrt*prt_params%nitr_stoich_p1(ft,fnrt_organ) m_sapw = c_sapw*prt_params%nitr_stoich_p1(ft,sapw_organ) - m_store = c_store*prt_params%nitr_stoich_p1(ft,store_organ) + m_store = prt_params%nitr_stoich_p1(ft,store_organ) * & + (m_struct+m_leaf+m_fnrt+m_sapw) m_repro = 0._r8 case(phosphorus_element) @@ -1780,7 +1782,8 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) m_leaf = c_leaf*prt_params%phos_stoich_p1(ft,leaf_organ) m_fnrt = c_fnrt*prt_params%phos_stoich_p1(ft,fnrt_organ) m_sapw = c_sapw*prt_params%phos_stoich_p1(ft,sapw_organ) - m_store = c_store*prt_params%phos_stoich_p1(ft,store_organ) + m_store = prt_params%phos_stoich_p1(ft,store_organ) * & + (m_struct+m_leaf+m_fnrt+m_sapw) m_repro = 0._r8 end select diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 83d0620100..fc6ce19ba6 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -850,7 +850,7 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) do id = 1,nlev_eff_decomp surface_prof(id) = surface_prof(id)/surface_prof_tot end do - + ! Loop over the different elements. do el = 1, num_elements @@ -874,7 +874,7 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) flux_cel_si => bc_out%litt_flux_cel_n_si(:) flux_lab_si => bc_out%litt_flux_lab_n_si(:) flux_lig_si => bc_out%litt_flux_lig_n_si(:) - + case (phosphorus_element) bc_out%litt_flux_cel_p_si(:) = 0._r8 bc_out%litt_flux_lig_p_si(:) = 0._r8 @@ -882,7 +882,7 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) flux_cel_si => bc_out%litt_flux_cel_p_si(:) flux_lab_si => bc_out%litt_flux_lab_p_si(:) flux_lig_si => bc_out%litt_flux_lig_p_si(:) - + end select @@ -902,9 +902,13 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) elseif(element_list(el).eq.phosphorus_element) then efflux_ptr => currentCohort%daily_p_efflux end if + + ! Unit conversion + ! kg/plant/day * plant/ha * ha/m2 -> kg/m2/day + do id = 1,nlev_eff_decomp flux_lab_si(id) = flux_lab_si(id) + & - efflux_ptr*currentCohort%n* AREA_INV * surface_prof(id) + efflux_ptr * currentCohort%n* AREA_INV * surface_prof(id) end do end if currentCohort => currentCohort%shorter diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index bec7a99537..0b1b7490f4 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -133,8 +133,7 @@ subroutine init_site_vars( site_in, bc_in ) allocate(site_in%flux_diags(el)%root_litter_input(1:numpft)) allocate(site_in%flux_diags(el)%nutrient_efflux_scpf(nlevsclass*numpft)) allocate(site_in%flux_diags(el)%nutrient_uptake_scpf(nlevsclass*numpft)) - allocate(site_in%flux_diags(el)%nutrient_needgrow_scpf(nlevsclass*numpft)) - allocate(site_in%flux_diags(el)%nutrient_needmax_scpf(nlevsclass*numpft)) + allocate(site_in%flux_diags(el)%nutrient_need_scpf(nlevsclass*numpft)) end do ! Initialize the static soil diff --git a/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 index 59ca74dae1..a31b7895fd 100644 --- a/parteh/PRTAllometricCNPMod.F90 +++ b/parteh/PRTAllometricCNPMod.F90 @@ -353,7 +353,7 @@ subroutine DailyPRTAllometricCNP(this) real(r8) :: bgw_c_target,bgw_dcdd_target real(r8) :: sapw_area integer :: cnp_limiter - + real(r8) :: max_store_n ! These arrays hold various support variables dimensioned by organ ! Zero suffix indicates the initial state values at the beginning of the routine ! _unl suffix indicates values used for tracking nutrient need (ie unlimited) @@ -380,7 +380,7 @@ subroutine DailyPRTAllometricCNP(this) real(r8) :: allocated_c real(r8) :: allocated_n real(r8) :: allocated_p - + real(r8) :: target_n,target_p real(r8) :: sum_c ! error checking sum integer, parameter :: unrstr_cgrow_nutr_need = 1 @@ -553,7 +553,6 @@ subroutine DailyPRTAllometricCNP(this) p_gain = p_gain + sum(this%variables(i_var)%val(:)) this%variables(i_var)%val(:) = 0._r8 - ! =================================================================================== ! Step 1. Prioritized allocation to replace tissues from turnover, and/or pay ! any un-paid maintenance respiration from storage. @@ -654,15 +653,7 @@ subroutine DailyPRTAllometricCNP(this) end do - ! Alternative need hypothesis, need is based simply on storage deficit - ! at end of time-step - if(nutr_need_mode.eq.refill_store_nutr_need) then - call bstore_allom(dbh,ipft,canopy_trim, store_c_target) - store_n_target = store_c_target*prt_params%nitr_stoich_p2(ipft,store_organ) - store_p_target = store_c_target*prt_params%phos_stoich_p2(ipft,store_organ) - n_need = max(store_n_target-state_n(store_id)%ptr,0._r8) - p_need = max(store_p_target-state_p(store_id)%ptr,0._r8) - end if + if(debug) then @@ -686,6 +677,31 @@ subroutine DailyPRTAllometricCNP(this) end if end if + ! Alternative need hypothesis, need is based simply on storage deficit + ! at end of time-step + if(nutr_need_mode.eq.refill_store_nutr_need) then + + target_n = this%GetNutrientTarget(nitrogen_element,store_organ,stoich_max) + target_p = this%GetNutrientTarget(phosphorus_element,store_organ,stoich_max) + + n_need = max(target_n - state_n(store_id)%ptr,0._r8) + p_need = max(target_p - state_p(store_id)%ptr,0._r8) + +! print*,"================" +! allocated_n = (state_n(leaf_id)%ptr - state_n0(leaf_id)) + & +! (state_n(fnrt_id)%ptr - state_n0(fnrt_id)) + & +! (state_n(sapw_id)%ptr - state_n0(sapw_id)) + & +! (state_n(repro_id)%ptr - state_n0(repro_id)) + & +! (state_n(struct_id)%ptr - state_n0(struct_id)) + +! print*,"dbh: ",dbh +! print*,"need:",n_need +! print*,"max storage:",target_n +! print*,"allocated: ",allocated_n +! print*,"alloc/max: ",allocated_n/target_n + + + end if deallocate(state_c) deallocate(state_n) @@ -1621,18 +1637,14 @@ subroutine CNPAllocateRemainder(this,c_gain, n_gain, p_gain, & ! ----------------------------------------------------------------------------------- do i = 1, num_organs - - ! Update the nitrogen deficits (which are based off of carbon actual..) - ! Note that the nitrogen target is tied to the stoichiometry of thegrowing pool only + + ! Update the nitrogen and phosphorus deficits target_n = this%GetNutrientTarget(nitrogen_element,organ_list(i),stoich_max) deficit_n(i) = max(0._r8,this%GetDeficit(nitrogen_element,organ_list(i),target_n)) - - ! Update the nitrogen deficits (which are based off of carbon actual..) - ! Note that the nitrogen target is tied to the stoichiometry of thegrowing pool only target_p = this%GetNutrientTarget(phosphorus_element,organ_list(i),stoich_max) deficit_p(i) = max(0._r8,this%GetDeficit(phosphorus_element,organ_list(i),target_p)) - + end do ! ----------------------------------------------------------------------------------- @@ -1749,6 +1761,11 @@ function GetNutrientTarget(this,element_id,organ_id,stoich_mode) result(target_m real(r8) :: canopy_trim integer :: ipft integer :: i_cvar + real(r8) :: sapw_area + real(r8) :: leaf_c_target,fnrt_c_target + real(r8) :: sapw_c_target,agw_c_target + real(r8) :: bgw_c_target,struct_c_target + dbh => this%bc_inout(acnp_bc_inout_id_dbh)%rval canopy_trim = this%bc_in(acnp_bc_in_id_ctrim)%rval @@ -1756,11 +1773,37 @@ function GetNutrientTarget(this,element_id,organ_id,stoich_mode) result(target_m i_cvar = prt_global%sp_organ_map(organ_id,carbon12_element) ! Storage of nutrients are assumed to have different compartments than - ! for carbon, and thus their targets are not associated with the current amount of carbon - ! but the plant's carrying capacity + ! for carbon, and thus their targets are not associated with a tissue + ! but is more represented as a fraction of the maximum amount of nutrient + ! that can be bound in non-reproductive tissues if(organ_id == store_organ) then - call bstore_allom(dbh,ipft,canopy_trim, target_c) + + call bleaf(dbh,ipft,canopy_trim,leaf_c_target) + call bfineroot(dbh,ipft,canopy_trim,fnrt_c_target) + call bsap_allom(dbh,ipft,canopy_trim,sapw_area,sapw_c_target) + call bagw_allom(dbh,ipft,agw_c_target) + call bbgw_allom(dbh,ipft,bgw_c_target) + call bdead_allom(agw_c_target,bgw_c_target, sapw_c_target, ipft, struct_c_target) + + ! Target for storage is a fraction of the sum target of all + ! non-reproductive organs + + if( element_id == nitrogen_element) then + target_c = & + leaf_c_target*prt_params%nitr_stoich_p2(ipft,leaf_organ)+ & + fnrt_c_target*prt_params%nitr_stoich_p2(ipft,fnrt_organ)+ & + sapw_c_target*prt_params%nitr_stoich_p2(ipft,sapw_organ)+ & + struct_c_target*prt_params%nitr_stoich_p2(ipft,struct_organ) + else + target_c = & + leaf_c_target*prt_params%phos_stoich_p2(ipft,leaf_organ)+ & + fnrt_c_target*prt_params%phos_stoich_p2(ipft,fnrt_organ)+ & + sapw_c_target*prt_params%phos_stoich_p2(ipft,sapw_organ)+ & + struct_c_target*prt_params%phos_stoich_p2(ipft,struct_organ) + + end if + else ! In all cases, we want the first index because for non-leaves ! that is the only index, and for leaves, that is the newly From 055a370358b8fb84ff18cff18227a4506c65d218 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 17 Nov 2020 10:24:09 -0700 Subject: [PATCH 139/578] reverted to ld frag scalar --- biogeochem/EDPhysiologyMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 26073ecd35..6d4aa312b8 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -2248,7 +2248,7 @@ subroutine fragmentation_scaler( currentPatch, bc_in) ! ! !LOCAL VARIABLES: logical :: use_century_tfunc = .false. - logical :: use_hlm_soil_scalar = .true. ! Use hlm input decomp fraction scalars + logical :: use_hlm_soil_scalar = .false. ! Use hlm input decomp fraction scalars integer :: j integer :: ifp ! Index of a FATES Patch "ifp" real(r8) :: t_scalar ! temperature scalar From 2a7c346282dfd290225c0c9d264a0ea4fe75c10a Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 20 Nov 2020 11:21:08 -0700 Subject: [PATCH 140/578] updated ncvarsort.py and modify_fates_paramfile.py to work with new fates_hlm_pftno dimension on parameter file --- tools/modify_fates_paramfile.py | 2 +- tools/ncvarsort.py | 7 ++++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/tools/modify_fates_paramfile.py b/tools/modify_fates_paramfile.py index 12fb552cdc..86d547d9d2 100755 --- a/tools/modify_fates_paramfile.py +++ b/tools/modify_fates_paramfile.py @@ -91,7 +91,7 @@ def main(): npft_file = var.shape[i] pftdim = i otherdimpresent = False - elif var.dimensions[i] in ['fates_history_age_bins','fates_history_size_bins','fates_history_coage_bins','fates_history_height_bins','fates_NCWD','fates_litterclass','fates_leafage_class','fates_prt_organs','fates_hydr_organs','fates_variants']: + elif var.dimensions[i] in ['fates_history_age_bins','fates_history_size_bins','fates_history_coage_bins','fates_history_height_bins','fates_NCWD','fates_litterclass','fates_leafage_class','fates_prt_organs','fates_hydr_organs','fates_variants','fates_hlm_pftno']: otherdimpresent = True otherdimname = var.dimensions[i] otherdimlength = var.shape[i] diff --git a/tools/ncvarsort.py b/tools/ncvarsort.py index 3f0f3a3a47..f2546060f8 100755 --- a/tools/ncvarsort.py +++ b/tools/ncvarsort.py @@ -45,9 +45,10 @@ def main(): (u'fates_hydr_organs', u'fates_pft'):6, (u'fates_leafage_class', u'fates_pft'):6, (u'fates_prt_organs', u'fates_pft'):6, - (u'fates_litterclass',):7, - (u'fates_NCWD',):8, - ():9} + (u'fates_hlm_pftno', u'fates_pft'):7, + (u'fates_litterclass',):8, + (u'fates_NCWD',):9, + ():10} # # go through each of the variables and assign it to one of the sub-lists based on its dimensionality for v_name, varin in dsin.variables.iteritems(): From 799dc650b7ef8e546e4610a064470793813f3512 Mon Sep 17 00:00:00 2001 From: ckoven Date: Sun, 22 Nov 2020 16:11:11 -0700 Subject: [PATCH 141/578] fixed frac_burnt unit error and added burned-area hist var to check order of operations --- fire/SFMainMod.F90 | 12 ++++++------ main/EDInitMod.F90 | 5 ++++- main/EDTypesMod.F90 | 4 ++-- main/FatesHistoryInterfaceMod.F90 | 11 +++++++++++ 4 files changed, 23 insertions(+), 9 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 8591b31b89..253559f7df 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -695,7 +695,7 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) real(r8),parameter :: km2_to_m2 = 1000000.0_r8 !area conversion for square km to square m ! ---initialize site parameters to zero--- - currentSite%frac_burnt = 0.0_r8 + currentSite%frac_burnt(:) = 0.0_r8 currentSite%NF_successful = 0._r8 ! Equation 7 from Venevsky et al GCB 2002 (modification of equation 8 in Thonicke et al. 2010) @@ -788,7 +788,7 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) AB = size_of_fire * currentSite%NF * currentSite%FDI !frac_burnt - currentPatch%frac_burnt = (min(0.99_r8, AB / km2_to_m2)) * currentPatch%area/area + currentPatch%frac_burnt = (min(0.99_r8, AB / km2_to_m2)) if(write_SF == itrue)then if ( hlm_masterproc == itrue ) write(fates_log(),*) 'frac_burnt',currentPatch%frac_burnt @@ -813,6 +813,10 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) ! currentSite%NF_successful = currentSite%NF_successful + & currentSite%NF * currentSite%FDI * currentPatch%area / area + ! + ! accumulate frac_burnt % at site level + currentSite%frac_burnt(cpatch%age_class) = currentSite%frac_burnt(cpatch%age_class) + currentPatch%frac_burnt + ! else currentPatch%fire = 0 ! No fire... :-/ currentPatch%FD = 0.0_r8 @@ -820,11 +824,7 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) endif endif! NF ignitions check - - ! accumulate frac_burnt % at site level - currentSite%frac_burnt = currentSite%frac_burnt + currentPatch%frac_burnt - currentPatch => currentPatch%younger enddo !end patch loop diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index caf93f8a7f..d59c5ffda0 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -44,6 +44,7 @@ module EDInitMod use FatesInterfaceTypesMod , only : nleafage use FatesInterfaceTypesMod , only : nlevsclass use FatesInterfaceTypesMod , only : nlevcoage + use FatesInterfaceTypesMod , only : nlevage use FatesAllometryMod , only : h2d_allom use FatesAllometryMod , only : bagw_allom use FatesAllometryMod , only : bbgw_allom @@ -119,6 +120,8 @@ subroutine init_site_vars( site_in, bc_in ) allocate(site_in%mass_balance(1:num_elements)) allocate(site_in%flux_diags(1:num_elements)) + allocate(site_in%frac_burnt(1:nlevage)) + site_in%nlevsoil = bc_in%nlevsoil allocate(site_in%rootfrac_scr(site_in%nlevsoil)) allocate(site_in%zi_soil(0:site_in%nlevsoil)) @@ -187,7 +190,7 @@ subroutine zero_site( site_in ) site_in%acc_ni = 0.0_r8 ! daily nesterov index accumulating over time. time unlimited theoretically. site_in%NF = 0.0_r8 ! daily lightning strikes per km2 site_in%NF_successful = 0.0_r8 ! daily successful iginitions per km2 - site_in%frac_burnt = 0.0_r8 ! burn area read in from external file + site_in%frac_burnt(:) = 0.0_r8 ! burn area do el=1,num_elements ! Zero the state variables used for checking mass conservation diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 9a5fa28e6c..bca591f303 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -555,7 +555,7 @@ module EDTypesMod ! FIRE EFFECTS real(r8) :: scorch_ht(maxpft) ! scorch height: m - real(r8) :: frac_burnt ! fraction burnt: frac gridcell/day + real(r8) :: frac_burnt ! fraction burnt: frac patch/day real(r8) :: tfc_ros ! total fuel consumed - no trunks. KgC/m2/day real(r8) :: burnt_frac_litter(nfsc) ! fraction of each litter pool burned:- @@ -731,7 +731,7 @@ module EDTypesMod real(r8) :: fdi ! daily probability an ignition event will start a fire real(r8) :: NF ! daily ignitions in km2 real(r8) :: NF_successful ! daily ignitions in km2 that actually lead to fire - real(r8) :: frac_burnt ! fraction of area burnt in this day. + real(r8), allocatable :: frac_burnt(:) ! fraction of gridcell area burnt in this day. indexed by patch age bins ! PLANT HYDRAULICS type(ed_site_hydr_type), pointer :: si_hydr diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index dd8d1287a2..f0cbaddef3 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -522,6 +522,7 @@ module FatesHistoryInterfaceMod integer :: ih_agesince_anthrodist_si_age integer :: ih_secondaryforest_area_si_age integer :: ih_area_burnt_si_age + integer :: ih_area_burnt2_si_age ! integer :: ih_fire_rate_of_spread_front_si_age integer :: ih_fire_intensity_si_age integer :: ih_fire_sum_fuel_si_age @@ -2001,6 +2002,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) 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_area_burnt2_si_age => this%hvars(ih_area_burnt2_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, & @@ -2873,6 +2875,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_lai_si_age(io_si, ipa2) = 0._r8 hio_ncl_si_age(io_si, ipa2) = 0._r8 endif + + hio_area_burnt2_si_age(io_si,ipa2) = sites(s)%frac_burnt(ipa2) + end do ! pass the cohort termination mortality as a flux to the history, and then reset the termination mortality buffer @@ -4509,6 +4514,12 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_area_burnt_si_age ) + call this%set_history_var(vname='AREA_BURNT2_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_burnt2_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', & From d793fe3a1b1a0e2f00543180bedc1f73969201e2 Mon Sep 17 00:00:00 2001 From: ckoven Date: Sun, 22 Nov 2020 16:39:23 -0700 Subject: [PATCH 142/578] bugfix on prior --- fire/SFMainMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 253559f7df..518aabb9a9 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -815,7 +815,8 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) currentSite%NF * currentSite%FDI * currentPatch%area / area ! ! accumulate frac_burnt % at site level - currentSite%frac_burnt(cpatch%age_class) = currentSite%frac_burnt(cpatch%age_class) + currentPatch%frac_burnt + currentSite%frac_burnt(currentPatch%age_class) = currentSite%frac_burnt(currentPatch%age_class) + & + currentPatch%frac_burnt ! else currentPatch%fire = 0 ! No fire... :-/ From 081bab968c2e9f05b9a2f84a690ab9a129143cb1 Mon Sep 17 00:00:00 2001 From: ckoven Date: Sun, 22 Nov 2020 16:45:45 -0700 Subject: [PATCH 143/578] unit fix on prior --- fire/SFMainMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 518aabb9a9..9cc7162464 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -816,7 +816,7 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) ! ! accumulate frac_burnt % at site level currentSite%frac_burnt(currentPatch%age_class) = currentSite%frac_burnt(currentPatch%age_class) + & - currentPatch%frac_burnt + currentPatch%frac_burnt * currentPatch%area / area ! else currentPatch%fire = 0 ! No fire... :-/ From 5f556966f71984d701833acbfb45328c355d011a Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 23 Nov 2020 14:20:37 +0100 Subject: [PATCH 144/578] Update biogeochem/EDCanopyStructureMod.F90 Co-authored-by: Charlie Koven --- biogeochem/EDCanopyStructureMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index d9d44a8e31..e598ab18be 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1967,7 +1967,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants ! currentPatch%area/AREA is the fraction of the soil covered by this patch. if(currentPatch%area.gt.0.0_r8)then - bc_out(s)%canopy_fraction_pa(ifp) = & + bc_out(s)%canopy_fraction_pa(ifp) = & min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) else bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 From ef67e8cdd6cc2a1d21356aa796cbf2ef145aa490 Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 23 Nov 2020 14:22:38 +0100 Subject: [PATCH 145/578] Update biogeochem/EDCanopyStructureMod.F90 CDK2 Co-authored-by: Charlie Koven --- biogeochem/EDCanopyStructureMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index e598ab18be..d229c036fb 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1970,7 +1970,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%canopy_fraction_pa(ifp) = & min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) else - bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 + bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 endif bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & From 518b621e863aee6012980807d7cf3354d64c5f1f Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 23 Nov 2020 14:22:57 +0100 Subject: [PATCH 146/578] Update biogeochem/EDCanopyStructureMod.F90 CDK3 Co-authored-by: Charlie Koven --- biogeochem/EDCanopyStructureMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index d229c036fb..d4e1cf2ee7 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1273,7 +1273,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) type (ed_cohort_type) , pointer :: currentCohort integer :: s integer :: ft ! plant functional type - integer :: ifp ! the number of the vegeted patch (1,2,3). In SP mode bareground patch is 0 + integer :: ifp ! the number of the vegetated patch (1,2,3). In SP mode bareground patch is 0 integer :: patchn ! identification number for each patch. real(r8) :: canopy_leaf_area ! total amount of leaf area in the vegetated area. m2. real(r8) :: leaf_c ! leaf carbon [kg] From 90bbd1e56a4d76c4206aa44087b4d938a99d777b Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 23 Nov 2020 14:29:02 +0100 Subject: [PATCH 147/578] add currentPatch%nocomp_pft_label to log file HT --- biogeochem/EDCanopyStructureMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index d4e1cf2ee7..adf164a538 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1359,7 +1359,8 @@ subroutine canopy_summarization( nsites, sites, bc_in ) end if if(currentPatch%total_canopy_area-currentPatch%area.gt.1.0e-16)then - write(fates_log(),*) 'too much canopy in summary',s,currentPatch%total_canopy_area-currentPatch%area + write(fates_log(),*) 'too much canopy in summary',s, & + currentPatch%nocomp_pft_label, currentPatch%total_canopy_area-currentPatch%area call endrun(msg=errMsg(sourcefile, __LINE__)) end if end if !sp mode From 7e4d62d7b0d079fd7eb1277f7adc03dec0a98d04 Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 23 Nov 2020 14:31:16 +0100 Subject: [PATCH 148/578] Update biogeochem/EDPhysiologyMod.F90 CDK5 Co-authored-by: Charlie Koven --- biogeochem/EDPhysiologyMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index ed4d24cba9..d85d44508b 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1546,7 +1546,7 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l !! carea_allom in SP mode after this point. if(abs(currentCohort%c_area-parea).gt.nearzero)then ! there is an error - if(abs(currentCohort%c_area-parea).lt.10.e-9)then !correct this if it's a very sall error + if(abs(currentCohort%c_area-parea).lt.10.e-9)then !correct this if it's a very small error oldcarea = currentCohort%c_area !generate new cohort area currentCohort%c_area = currentCohort%c_area - (currentCohort%c_area- parea) From 4d8af4a7a40d3812e3143439cd1b3165ef8b0411 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 23 Nov 2020 07:00:43 -0700 Subject: [PATCH 149/578] remove use_sp statement from canopy structure routine --- biogeochem/EDCanopyStructureMod.F90 | 4 ++-- main/EDMainMod.F90 | 4 +++- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index d9d44a8e31..58be3abdaa 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -150,7 +150,6 @@ subroutine canopy_structure( currentSite , bc_in ) !---------------------------------------------------------------------- - if(hlm_use_sp.eq.ifalse)then currentPatch => currentSite%oldest_patch ! ! zero site-level demotion / promotion tracking info @@ -322,7 +321,7 @@ subroutine canopy_structure( currentSite , bc_in ) currentPatch => currentPatch%younger enddo !patch - end if ! SP mode + return end subroutine canopy_structure @@ -1328,6 +1327,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) call coagetype_class_index(currentCohort%coage,currentCohort%pft, & currentCohort%coage_class,currentCohort%coage_by_pft_class) end if + if(hlm_use_sp.eq.ifalse)then call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& currentCohort%pft,currentCohort%c_area) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 76a031e688..c7bdc30f41 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -668,7 +668,9 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) call TotalBalanceCheck(currentSite,6) - call canopy_structure(currentSite, bc_in) + if(hlm_use_sp.eq.ifalse)then + call canopy_structure(currentSite, bc_in) + endif call TotalBalanceCheck(currentSite,final_check_id) From a396a835f0d1ce913cdf888c4b38a8c5b0f5f997 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 23 Nov 2020 07:10:11 -0700 Subject: [PATCH 150/578] add dummy n variable --- biogeochem/EDPhysiologyMod.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index d85d44508b..24c3705753 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1482,9 +1482,10 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l integer, intent(in) :: init ! are we in the initialization routine? if so do not set leaf_c real(r8), intent(out) :: leaf_c ! leaf carbon estimated to generate target tlai - integer :: fates_pft ! fates pft numer for weighting loop - real(r8) :: spread ! dummy value of canopy spread to estimate c_area - real(r8) :: sumarea + real(r8) :: dummy_n ! set cohort n to a dummy value of 1.0 + integer :: fates_pft ! fates pft numer for weighting loop + real(r8) :: spread ! dummy value of canopy spread to estimate c_area + real(r8) :: sumarea real(r8) :: check_treelai real(r8) :: canopylai(1:nclmax) real(r8) :: fracerr @@ -1506,11 +1507,11 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l fates_pft = currentCohort%pft call h2d_allom(currentCohort%hite,fates_pft,currentCohort%dbh) - currentCohort%n = 1.0_r8 ! make n=1 to get area of one tree. + dummy_n = 1.0_r8 ! make n=1 to get area of one tree. spread = 1.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in ! SP mode. - call carea_allom(currentCohort%dbh,currentCohort%n,spread,currentCohort%pft,currentCohort%c_area) + call carea_allom(currentCohort%dbh,dummy_n,spread,currentCohort%pft,currentCohort%c_area) !------------------------------------------ ! Calculate canopy N assuming patch area is full From 04b9e9dcda5d737d6f91455ade1fd299ce5a5bcc Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 23 Nov 2020 07:50:38 -0700 Subject: [PATCH 151/578] indenting in fatesinterface --- main/FatesInterfaceMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 844c180663..28ef965f96 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1443,14 +1443,14 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) end if - if(hlm_use_fixed_biogeog.eq.unset_int) then + if(hlm_use_fixed_biogeog.eq.unset_int) then if(fates_global_verbose()) then write(fates_log(), *) 'switch for fixed biogeog unset: him_use_fixed_biogeog, exiting' end if call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(hlm_use_nocomp.eq.unset_int) then + if(hlm_use_nocomp.eq.unset_int) then if(fates_global_verbose()) then write(fates_log(), *) 'switch for no competition mode. ' end if From e1129ce76060ce541044791a32a9bba8ceb0d069 Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 23 Nov 2020 15:51:38 +0100 Subject: [PATCH 152/578] Update main/FatesRestartInterfaceMod.F90 CDK6 Co-authored-by: Charlie Koven --- main/FatesRestartInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 866af8095d..1328edef8c 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -2588,7 +2588,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%prt%variables(i_var)%net_alloc(i_pos) = & this%rvars(ir_prt_var)%r81d(io_idx_co) - ir_prt_var = ir_prt_var + 1 + ir_prt_var = ir_prt_var + 1 ccohort%prt%variables(i_var)%burned(i_pos) = & this%rvars(ir_prt_var)%r81d(io_idx_co) end do From 206a844a102944ed8980d6de2c3175b5bbcc9d3b Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 23 Nov 2020 08:00:43 -0700 Subject: [PATCH 153/578] change comment. HT --- biogeochem/EDCanopyStructureMod.F90 | 3 ++- parameter_files/fates_params_default.cdl | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 17e4bb69e2..ee22a48623 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1922,7 +1922,8 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentPatch => sites(s)%oldest_patch c = fcolumn(s) do while(associated(currentPatch)) - if(currentPatch%nocomp_pft_label.ne.0)then ! only increase ifp for veg patches not BG (in SP mode) + if(currentPatch%nocomp_pft_label.ne.0)then + ! only increase ifp for veg patches, not bareground (in SP mode) ifp = ifp+1 endif ! stay with ifp=0 for bareground patch. if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index c259b3c5df..a886c4c78e 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -505,7 +505,7 @@ variables: fates_z0mr:long_name = "Ratio of momentum roughness length to canopy top height" ; double fates_hlm_pft_map(fates_hlm_pftno, fates_pft) ; fates_hlm_pft_map:units = "area fraction" ; - fates_hlm_pft_map:long_name = "In fixed biogeog mode, fraction of HLM area associated with each FATES PFT" ; + fates_hlm_pft_map:long_name = "In fixed biogeog mode, fraction of HLM area associated with each FATES PFT" ; double fates_fire_FBD(fates_litterclass) ; fates_fire_FBD:units = "NA" ; fates_fire_FBD:long_name = "spitfire parameter related to fuel bulk density, see SFMain.F90" ; From 4611ded5e3dad9d225a68faec63b2b2134a3b01a Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 23 Nov 2020 16:01:07 +0100 Subject: [PATCH 154/578] Update biogeochem/EDPhysiologyMod.F90 HT1 Co-authored-by: huitang-earth --- biogeochem/EDPhysiologyMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 24c3705753..22bbde2397 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1450,7 +1450,7 @@ subroutine satellite_phenology(currentSite, bc_in) if(fates_pft.eq.0)then write(fates_log(),*) 'PFT0 in SP mode' call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + end if ! Call routine to invert SP drivers into cohort properites. call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) From cfc76321d5929a66a3410716d6441ba9ed691a78 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 23 Nov 2020 10:17:27 -0700 Subject: [PATCH 155/578] fix to vector-zeroing of site_in%frac_burnt in set_site_properties --- main/EDInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index d59c5ffda0..bb09d13704 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -301,7 +301,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) sites(s)%acc_NI = acc_NI sites(s)%NF = 0.0_r8 sites(s)%NF_successful = 0.0_r8 - sites(s)%frac_burnt = 0.0_r8 + sites(s)%frac_burnt(:) = 0.0_r8 ! PLACEHOLDER FOR PFT AREA DATA MOVED ACROSS INTERFACE if(hlm_use_fixed_biogeog.eq.itrue)then From 60dcff6f39d3c424970aaa70b135336b695d51a9 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 24 Nov 2020 06:41:25 -0700 Subject: [PATCH 156/578] removed sumarea calcs from edphysiology --- biogeochem/EDPhysiologyMod.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 24c3705753..63e61676eb 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1360,7 +1360,6 @@ subroutine satellite_phenology(currentSite, bc_in) real(r8) :: spread ! dummy value of canopy spread to estimate c_area real(r8) :: leaf_c ! leaf carbon estimated to generate target tlai - real(r8) :: sumarea real(r8) :: check_treelai integer :: fates_pft ! fates pft numer for weighting loop integer :: hlm_pft ! host land model pft number for weighting loop. @@ -1391,11 +1390,9 @@ subroutine satellite_phenology(currentSite, bc_in) fates_pft = currentPatch%nocomp_pft_label if(fates_pft.ne.0)then - sumarea = 0.0_r8 do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) if(bc_in%pft_areafrac(hlm_pft) * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft).gt.0.0_r8)then - sumarea = sumarea + bc_in%pft_areafrac(hlm_pft)*EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) !leaf area index currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & bc_in%hlm_sp_tlai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & @@ -1485,7 +1482,6 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l real(r8) :: dummy_n ! set cohort n to a dummy value of 1.0 integer :: fates_pft ! fates pft numer for weighting loop real(r8) :: spread ! dummy value of canopy spread to estimate c_area - real(r8) :: sumarea real(r8) :: check_treelai real(r8) :: canopylai(1:nclmax) real(r8) :: fracerr From 12c6d6f7604ba0c18dec8f8aafd46dd75cd91450 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 24 Nov 2020 06:50:41 -0700 Subject: [PATCH 157/578] tidy up leafc_from_treelai function --- biogeochem/FatesAllometryMod.F90 | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index c694614f35..00ded88348 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -807,17 +807,14 @@ real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25t write(fates_log(),*) 'problem in leafc_from_treelai',cl,pft call endrun(msg=errMsg(sourcefile, __LINE__)) endif - + + ! convert PFT-level canopy top and maximum SLA values and convert from m2/gC to m2/kgC slat = g_per_kg * prt_params%slatop(pft) - leafc_per_unitarea = leaf_c/(c_area/nplant) !KgC/m2 + sla_max = g_per_kg * prt_params%slamax(pft) + ! Coefficient for exponential decay of 1/sla with canopy depth: + kn = decay_coeff_kn(pft,vcmax25top) - if(treelai > 0.0_r8)then - ! Coefficient for exponential decay of 1/sla with canopy depth: - kn = decay_coeff_kn(pft,vcmax25top) - ! take PFT-level maximum SLA value, even if under a thick canopy (which has units of m2/gC), - ! and put into units of m2/kgC - sla_max = g_per_kg * prt_params%slamax(pft) - + if(treelai > 0.0_r8)then ! Leafc_per_unitarea at which sla_max is reached due to exponential sla profile in canopy: leafc_slamax = max(0.0_r8,(slat - sla_max) / (-1.0_r8 * kn * slat * sla_max)) From a9269df5cef1838c4e383c39cf95d1d55310c808 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 24 Nov 2020 07:11:39 -0700 Subject: [PATCH 158/578] moving negative check into small patch loop in edinit as per HT request --- main/EDInitMod.F90 | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 211f58834d..a4c9cfd15f 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -335,15 +335,12 @@ subroutine set_site_properties( nsites, sites,bc_in ) sites(s)%area_pft(ft)=0.0_r8 ! remove tiny patches to prevent numerical errors in terminate patches endif - end do -! change units to m2 from fractions - do ft = 1,numpft - sites(s)%area_pft(ft)= sites(s)%area_pft(ft) * AREA ! rescale units to m2. if(sites(s)%area_pft(ft).lt.0._r8)then write(fates_log(),*) 'negative area',s,ft,sites(s)%area_pft(ft) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - end do + sites(s)%area_pft(ft)= sites(s)%area_pft(ft) * AREA ! rescale units to m2. + end do ! re-normalize PFT area to ensure it sums to one. ! note that in areas of 'bare ground' (PFT 0 in CLM/ELM) From 4a67dd87ed77a2c16951aae90735138d5fdd23cb Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 24 Nov 2020 07:23:06 -0700 Subject: [PATCH 159/578] removed sp_patch_index --- main/FatesInterfaceTypesMod.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index ba3fa9191c..4002af90ea 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -336,10 +336,6 @@ module FatesInterfaceTypesMod ! be equivalent (ie integer ascending) ! Or, all will be 1. - integer,allocatable :: sp_patch_index(:) ! in SP mode, we need to map the p values for each patch - ! back onto the 'IFP' order i ED. So this is the number of e ! ach patch in the site. It does not correspond to PFT, more - ! to the number of occupied PFTs before it in the array. - ! Vegetation Dynamics ! --------------------------------------------------------------------------------- From 1f1980975fd336dc9d1c61d8a2d9ba772158ac52 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 24 Nov 2020 07:31:55 -0700 Subject: [PATCH 160/578] added cmments to area check in EDInit --- main/EDInitMod.F90 | 10 ++++++---- main/EDPftvarcon.F90 | 3 ++- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index a4c9cfd15f..1a4ebf89b5 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -571,13 +571,15 @@ subroutine init_patches( nsites, sites, bc_in) if(abs(tota-area).gt.nearzero*area)then if(abs(tota-area).lt.1.0e-10_r8)then ! this is a precision error if(sites(s)%oldest_patch%area.gt.(tota-area+nearzero))then - ! remove or add extra area from bare ground patch + ! remove or add extra area + ! if the oldest patch has enough area, use that sites(s)%oldest_patch%area = sites(s)%oldest_patch%area - (tota-area) - write(*,*) 'fixing patch precision O',s, tota-area - else + write(*,*) 'fixing patch precision - oldest',s, tota-area + else ! or otherwise take the area from the youngest patch. sites(s)%youngest_patch%area = sites(s)%oldest_patch%area - (tota-area) + write(*,*) 'fixing patch precision -youngest ',s, tota-area endif - else !this is a big error + else !this is a big error not just a precision error. write(*,*) 'issue with patch area in EDinit',tota-area,tota call endrun(msg=errMsg(sourcefile, __LINE__)) endif ! big error diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 214ca75d3b..6ca06b3f43 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -1693,7 +1693,8 @@ subroutine FatesCheckParams(is_master) end if - ! check that the host-fates PFT map adds to one in both dimension + ! check that the host-fates PFT map adds to one along HLM dimension so that all the HLM area + ! goes to a FATES PFT. Each FATES PFT can get < or > 1 of an HLM PFT. do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft)) if(abs(sumarea-1.0_r8).gt.nearzero)then From 4f3bd4eb75e0f9fc39c0ca776d0c9c0b1ebb8490 Mon Sep 17 00:00:00 2001 From: Jacquelyn Shuman Date: Tue, 24 Nov 2020 17:32:32 -0700 Subject: [PATCH 161/578] Update lb term for fire ellipse shape --- fire/SFMainMod.F90 | 36 ++++++++++++++++++++++-------------- 1 file changed, 22 insertions(+), 14 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index dd417c9974..4e3bbe0244 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -682,6 +682,7 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) real(r8) ROS !m/s real(r8) W !kgBiomass/m2 + real(r8) :: tree_fraction_patch ! patch level. no units real(r8) lb !length to breadth ratio of fire ellipse (unitless) real(r8) df !distance fire has travelled forward in m real(r8) db !distance fire has travelled backward in m @@ -692,7 +693,8 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) real(r8) anthro_ign_count ! anthropogenic ignition count/km2/day integer :: iofp ! index of oldest fates patch real(r8), parameter :: pot_hmn_ign_counts_alpha = 0.0035_r8 ! Potential human ignition counts (alpha in Li et al. 2012) (#/person/month) - real(r8),parameter :: km2_to_m2 = 1000000.0_r8 !area conversion for square km to square m + real(r8), parameter :: km2_to_m2 = 1000000.0_r8 !area conversion for square km to square m + real(r8), parameter :: wind_convert = 0.06_r8 ! convert wind speed from m/min to km/hr ! ---initialize site parameters to zero--- currentSite%frac_burnt = 0.0_r8 @@ -751,19 +753,25 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) !equation 15 in Arora and Boer CTEM model.Average fire is 1 day long. !currentPatch%FD = 60.0_r8 * 24.0_r8 !no minutes in a day - - ! The feedback between vegetation structure and ellipse size if turned off for now, - ! to reduce the positive feedback in the syste, - ! This will also be investigated by William Hoffmans proposal. - ! if (currentPatch%effect_wspeed < 16.67_r8) then !16.67m/min = 1km/hr - lb = 1.0_r8 - ! else - !FIX(RF,032414) FOR NO GRASS - ! lb = currentPatch%total_canopy_area/currentPatch%area*(1.0_r8)+(8.729_r8 * & - ! ((1.0_r8 -(exp(-0.03_r8 * 0.06_r8 * currentPatch%effect_wspeed)))**2.155_r8)) !& - !& +currentPatch%fpc_grass*(1.1_r8+((0.06_r8*currentPatch%effect_wspeed)**0.0464)) - - ! endif + tree_fraction_patch = 0.0_r8 + tree_fraction_patch = currentPatch%total_tree_area/currentPatch%area + + if(debug)then + write(fates_log(),*) 'SF currentPatch%area ',currentPatch%area + write(fates_log(),*) 'SF currentPatch%total_area ',currentPatch%total_tree_area + write(fates_log(),*) 'SF patch tree fraction ',tree_fraction_patch + write(fates_log(),*) 'SF AREA ',AREA + endif + + if (currentPatch%effect_wspeed < 16.67_r8) then !16.67m/min = 1km/hr + lb = 1.0_r8 + else + if (tree_fraction_patch > 0.55_r8) then !benchmark for forest cover per Staver 2010 + lb = (1.0_r8 + (8.729_r8 * & + ((1.0_r8 -(exp(-0.03_r8 * wind_convert * currentPatch%effect_wspeed)))**2.155_r8)) + else + lb = (1.1_r8+((wind_convert * currentPatch%effect_wspeed)**0.0464)) + endif ! if (lb > 8.0_r8)then ! lb = 8.0_r8 !Constraint Canadian Fire Behaviour System From 587e3aefb56eae41e1e3b25d416fb2c8cf04592d Mon Sep 17 00:00:00 2001 From: Jacquelyn Shuman Date: Tue, 24 Nov 2020 18:14:27 -0700 Subject: [PATCH 162/578] typo: close equation parenthesis --- fire/SFMainMod.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 4e3bbe0244..ab6fdf25b1 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -768,9 +768,10 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) else if (tree_fraction_patch > 0.55_r8) then !benchmark for forest cover per Staver 2010 lb = (1.0_r8 + (8.729_r8 * & - ((1.0_r8 -(exp(-0.03_r8 * wind_convert * currentPatch%effect_wspeed)))**2.155_r8)) + ((1.0_r8 -(exp(-0.03_r8 * wind_convert * currentPatch%effect_wspeed)))**2.155_r8))) else - lb = (1.1_r8+((wind_convert * currentPatch%effect_wspeed)**0.0464)) + lb = (1.1_r8+((wind_convert * currentPatch%effect_wspeed)**0.0464)) + endif endif ! if (lb > 8.0_r8)then From 9b31a8ccb79e8c072ef4491b6de8cb3d1dac5b7a Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Wed, 25 Nov 2020 10:58:16 +0100 Subject: [PATCH 163/578] Update biogeochem/EDCohortDynamicsMod.F90 CDK7 Co-authored-by: Charlie Koven --- biogeochem/EDCohortDynamicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index e6fd43f66f..ae9983f356 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -188,7 +188,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & ! leaf biomass that we are targeting? real(r8), intent(in) :: spread ! The community assembly effects how ! spread crowns are in horizontal space - real(r8), intent(in) :: carea ! area of cohort NLY USED IN SP MODE. + real(r8), intent(in) :: carea ! area of cohort ONLY USED IN SP MODE. type(bc_in_type), intent(in) :: bc_in ! External boundary conditions From 6a4dec9aa1bf4d61e301379e143f0b4311f5e77f Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 08:05:43 -0700 Subject: [PATCH 164/578] indenting all of EDCanopyStructureMod.F90 --- biogeochem/EDCanopyStructureMod.F90 | 3286 +++++++++++++-------------- 1 file changed, 1643 insertions(+), 1643 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index ee22a48623..3460871e7f 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -59,1133 +59,1133 @@ module EDCanopyStructureMod character(len=*), parameter, private :: sourcefile = & __FILE__ - + real(r8), parameter :: area_target_precision = 1.0E-11_r8 ! Area conservation - ! will attempt to reduce errors - ! below this level - + ! will attempt to reduce errors + ! below this level + real(r8), parameter :: area_check_precision = 1.0E-7_r8 ! Area conservation checks must - ! be within this absolute tolerance + ! be within this absolute tolerance real(r8), parameter :: area_check_rel_precision = 1.0E-4_r8 ! Area conservation checks must - ! be within this relative tolerance + ! be within this relative tolerance real(r8), parameter :: similar_height_tol = 1.0E-3_r8 ! I think trees that differ by 1mm - ! can be roughly considered the same right? + ! can be roughly considered the same right? ! 10/30/09: Created by Rosie Fisher ! 2017/2018: Modifications and updates by Ryan Knox ! ============================================================================ -contains +contains + + ! ============================================================================ + subroutine canopy_structure( currentSite , bc_in ) + ! + ! !DESCRIPTION: + ! create cohort instance + ! + ! This routine allocates the 'canopy_layer' attribute to each cohort + ! All top leaves in the same canopy layer get the same light resources. + ! The first canopy layer is the 'canopy' or 'overstorey'. The second is the 'understorey'. + ! More than two layers is not permitted at the moment + ! Seeds germinating into the 3rd or higher layers are automatically removed. + ! + ! ------Perfect Plasticity----- + ! The idea of these canopy layers derives originally from Purves et al. 2009 + ! Their concept is that, given enoughplasticity in canopy position, size, shape and depth + ! all of the gound area will be filled perfectly by leaves, and additional leaves will have + ! to exist in the understorey. + ! Purves et al. use the concept of 'Z*' to assume that the height required to attain a place in the + ! canopy is spatially uniform. In this implementation, described in Fisher et al. (2010, New Phyt) we + ! extent that concept to assume that position in the canopy has some random element, and that BOTH height + ! and chance combine to determine whether trees get into the canopy. + ! Thus, when the canopy is closed and there is excess area, some of it must be demoted + ! If we demote -all- the trees less than a given height, there is a massive advantage in being the cohort that is + ! the biggest when the canopy is closed. + ! In this implementation, the amount demoted, ('weight') is a function of the height weighted by the competitive exclusion + ! parameter (ED_val_comp_excln). + + ! Complexity in this routine results from a few things. + ! Firstly, the complication of the demotion amount sometimes being larger than the cohort area (for a very small, short cohort) + ! Second, occasionaly, disturbance (specifically fire) can cause the canopy layer to become less than closed, + ! without changing the area of the patch. If this happens, then some of the plants in the lower layer need to be 'promoted' so + ! all of the routine has to happen in both the downwards and upwards directions. + ! + ! The order of events here is therefore: + ! (The entire subroutine has a single outer 'patch' loop. + ! Section 1: figure out the total area, and whether there are >1 canopy layers at all. + ! + ! Sorts out cohorts into canopy and understorey layers... + ! + ! !USES: + + use EDParamsMod, only : ED_val_comp_excln + use EDTypesMod , only : min_patch_area + use FatesInterfaceTypesMod, only : bc_in_type + ! + ! !ARGUMENTS + type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type), intent(in) :: bc_in + + ! + ! !LOCAL VARIABLES: + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + integer :: i_lyr ! current layer index + integer :: z ! Current number of canopy layers. (1= canopy, 2 = understorey) + integer :: ipft + real(r8) :: arealayer(nclmax+2) ! Amount of plant area currently in each canopy layer + integer :: patch_area_counter ! count iterations used to solve canopy areas + logical :: area_not_balanced ! logical controlling if the patch layer areas + ! have successfully been redistributed + integer :: return_code ! math checks on variables will return>0 if problems exist + + ! We only iterate because of possible imprecisions generated by the cohort + ! termination process. These should be super small, so at the most + ! try to re-balance 3 times. If that doesn't give layer areas + ! within tolerance of canopy area, there is something wrong + + integer, parameter :: max_patch_iterations = 10 + + + !---------------------------------------------------------------------- + currentPatch => currentSite%oldest_patch + ! + ! zero site-level demotion / promotion tracking info + currentSite%demotion_rate(:) = 0._r8 + currentSite%promotion_rate(:) = 0._r8 + currentSite%demotion_carbonflux = 0._r8 + currentSite%promotion_carbonflux = 0._r8 + + + ! + ! Section 1: Check total canopy area. + ! + do while (associated(currentPatch)) ! Patch loop + + ! ------------------------------------------------------------------------------ + ! Perform numerical checks on some cohort and patch structures + ! ------------------------------------------------------------------------------ + + ! canopy layer has a special bounds check + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if( currentCohort%canopy_layer < 1 .or. currentCohort%canopy_layer > nclmax+1 ) then + write(fates_log(),*) 'lat:',currentSite%lat + write(fates_log(),*) 'lon:',currentSite%lon + write(fates_log(),*) 'BOGUS CANOPY LAYER: ',currentCohort%canopy_layer + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + currentCohort => currentCohort%shorter + enddo + + + ! Does any layer have excess area in it? Keep going until it does not... + patch_area_counter = 0 + area_not_balanced = .true. + + do while(area_not_balanced) + + ! --------------------------------------------------------------------------- + ! Demotion Phase: Identify upper layers that are too full, and demote them to + ! the layers below. + ! --------------------------------------------------------------------------- + + ! Its possible that before we even enter this scheme + ! some cohort numbers are very low. Terminate them. + call terminate_cohorts(currentSite, currentPatch, 1, 12) + + ! Calculate how many layers we have in this canopy + ! This also checks the understory to see if its crown + ! area is large enough to warrant a temporary sub-understory layer + z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) + + do i_lyr = 1,z ! Loop around the currently occupied canopy layers. + call DemoteFromLayer(currentSite, currentPatch, i_lyr) + end do + + ! After demotions, we may then again have cohorts that are very very + ! very sparse, remove them + call terminate_cohorts(currentSite, currentPatch, 1,13) + + call fuse_cohorts(currentSite, currentPatch, bc_in) + + ! Remove cohorts for various other reasons + call terminate_cohorts(currentSite, currentPatch, 2,13) + + + ! --------------------------------------------------------------------------------------- + ! Promotion Phase: Identify if any upper-layers are underful and layers below them + ! have cohorts that can be split and promoted to the layer above. + ! --------------------------------------------------------------------------------------- + + ! Re-calculate Number of layers without the false substory + z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) + + ! We only promote if we have at least two layers + if (z>1) then + + do i_lyr=1,z-1 + call PromoteIntoLayer(currentSite, currentPatch, i_lyr) + end do + + ! Remove cohorts that are incredibly sparse + call terminate_cohorts(currentSite, currentPatch, 1,14) + + call fuse_cohorts(currentSite, currentPatch, bc_in) + + ! Remove cohorts for various other reasons + call terminate_cohorts(currentSite, currentPatch, 2,14) + + end if + + ! --------------------------------------------------------------------------------------- + ! Check on Layer Area (if the layer differences are not small + ! Continue trying to demote/promote. Its possible on the first pass through, + ! that cohort fusion has nudged the areas a little bit. + ! --------------------------------------------------------------------------------------- + + z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) + area_not_balanced = .false. + do i_lyr = 1,z + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer(i_lyr)) + if( ((arealayer(i_lyr)-currentPatch%area)/currentPatch%area > area_check_rel_precision) .or. & + ((arealayer(i_lyr)-currentPatch%area) > area_check_precision ) ) then + area_not_balanced = .true. + endif + enddo + + ! --------------------------------------------------------------------------------------- + ! Gracefully exit if too many iterations have gone by + ! --------------------------------------------------------------------------------------- + + patch_area_counter = patch_area_counter + 1 + if(patch_area_counter > max_patch_iterations .and. area_not_balanced) then + write(fates_log(),*) 'PATCH AREA CHECK NOT CLOSING' + write(fates_log(),*) 'patch area:',currentpatch%area + do i_lyr = 1,z + write(fates_log(),*) 'layer: ',i_lyr,' area: ',arealayer(i_lyr) + write(fates_log(),*) 'rel error: ',(arealayer(i_lyr)-currentPatch%area)/currentPatch%area + write(fates_log(),*) 'abs error: ',arealayer(i_lyr)-currentPatch%area + enddo + write(fates_log(),*) 'lat:',currentSite%lat + write(fates_log(),*) 'lon:',currentSite%lon + write(fates_log(),*) 'spread:',currentSite%spread + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + write(fates_log(),*) 'coh ilayer:',currentCohort%canopy_layer + write(fates_log(),*) 'coh dbh:',currentCohort%dbh + write(fates_log(),*) 'coh pft:',currentCohort%pft + write(fates_log(),*) 'coh n:',currentCohort%n + write(fates_log(),*) 'coh carea:',currentCohort%c_area + ipft=currentCohort%pft + write(fates_log(),*) 'maxh:',prt_params%allom_dbh_maxheight(ipft) + write(fates_log(),*) 'lmode: ',prt_params%allom_lmode(ipft) + write(fates_log(),*) 'd2bl2: ',prt_params%allom_d2bl2(ipft) + write(fates_log(),*) 'd2bl_ediff: ',prt_params%allom_blca_expnt_diff(ipft) + write(fates_log(),*) 'd2ca_min: ',prt_params%allom_d2ca_coefficient_min(ipft) + write(fates_log(),*) 'd2ca_max: ',prt_params%allom_d2ca_coefficient_max(ipft) + currentCohort => currentCohort%shorter + enddo + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + enddo ! do while(area_not_balanced) + + + ! Set current canopy layer occupancy indicator. + currentPatch%NCL_p = min(nclmax,z) + + ! ------------------------------------------------------------------------------------------- + ! if we are using "strict PPA", then calculate a z_star value as + ! the height of the smallest tree in the canopy + ! loop from top to bottom and locate the shortest cohort in level 1 whose shorter + ! neighbor is in level 2 set zstar as the ehight of that shortest level 1 cohort + ! ------------------------------------------------------------------------------------------- + + if ( ED_val_comp_excln .lt. 0.0_r8) then + currentPatch%zstar = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer .eq. 2)then + if (associated(currentCohort%taller)) then + if (currentCohort%taller%canopy_layer .eq. 1 ) then + currentPatch%zstar = currentCohort%taller%hite + endif + endif + endif + currentCohort => currentCohort%shorter + enddo + endif + + currentPatch => currentPatch%younger + enddo !patch + + return + end subroutine canopy_structure + + + ! ============================================================================================== + + + subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) + + use EDParamsMod, only : ED_val_comp_excln + use SFParamsMod, only : SF_val_CWD_frac + + ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite + type(ed_patch_type), intent(inout), target :: currentPatch + integer, intent(in) :: i_lyr ! Current canopy layer of interest + + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer :: currentCohort + type(ed_cohort_type), pointer :: copyc + type(ed_cohort_type), pointer :: nextc ! The next cohort in line + integer :: i_cwd ! Index for CWD pool + real(r8) :: cc_loss ! cohort crown area loss in demotion (m2) + real(r8) :: leaf_c ! leaf carbon [kg] + real(r8) :: fnrt_c ! fineroot carbon [kg] + real(r8) :: sapw_c ! sapwood carbon [kg] + real(r8) :: store_c ! storage carbon [kg] + real(r8) :: struct_c ! structure carbon [kg] + real(r8) :: scale_factor ! for prob. exclusion - scales weight to a fraction + real(r8) :: scale_factor_min ! "" minimum before exeedance of 1 + real(r8) :: scale_factor_res ! "" applied to residual areas + real(r8) :: area_res ! residual area to demote after weakest cohort hits max + real(r8) :: newarea + real(r8) :: demote_area + real(r8) :: sumweights + real(r8) :: sumequal ! for rank-ordered same-size cohorts + ! this tallies their excluded area + real(r8) :: arealayer ! the area of the current canopy layer + logical :: tied_size_with_neighbors + real(r8) :: total_crownarea_of_tied_cohorts + + ! First, determine how much total canopy area we have in this layer + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer) + + demote_area = arealayer - currentPatch%area + + if ( demote_area > area_target_precision ) then + + ! Is this layer currently over-occupied? + ! In that case, we need to work out which cohorts to demote. + ! We go in order from shortest to tallest for ranked demotion + + sumweights = 0.0_r8 + currentCohort => currentPatch%shortest + do while (associated(currentCohort)) + call carea_allom(currentCohort%dbh,currentCohort%n, & + currentSite%spread,currentCohort%pft,currentCohort%c_area) + + if(debug) then + if(currentCohort%c_area<0._r8)then + write(fates_log(),*) 'negative c_area stage 1d: ',currentCohort%dbh,i_lyr,currentCohort%n, & + currentSite%spread,currentCohort%pft,currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + if( currentCohort%canopy_layer == i_lyr)then + + if (ED_val_comp_excln .ge. 0.0_r8 ) then + + ! ---------------------------------------------------------- + ! Stochastic method. + ! Weight cohort demotion by inverse size to a constant power. + ! In this hypothesis, it is assumed that even the tallest + ! cohorts have a chance (although smaller) of being forced + ! to the understory. + ! ---------------------------------------------------------- + + currentCohort%excl_weight = 1._r8 / (currentCohort%hite**ED_val_comp_excln) + sumweights = sumweights + currentCohort%excl_weight + + else + + ! ----------------------------------------------------------- + ! Rank ordered deterministic method + ! ----------------------------------------------------------- + ! If there are cohorts that have the exact same height (which is possible, really) + ! we don't want to unilaterally promote/demote one before the others. + ! So we <>mote them as a unit + ! now we need to go through and figure out how many equal-size cohorts there are. + ! then we need to go through, add up the collective crown areas of all equal-sized + ! and equal-canopy-layer cohorts, + ! and then demote from each as if they were a single group + + total_crownarea_of_tied_cohorts = currentCohort%c_area + + tied_size_with_neighbors = .false. + nextc => currentCohort%taller + do while (associated(nextc)) + if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then + if( nextc%canopy_layer .eq. currentCohort%canopy_layer ) then + tied_size_with_neighbors = .true. + total_crownarea_of_tied_cohorts = & + total_crownarea_of_tied_cohorts + nextc%c_area + end if + else + exit + endif + nextc => nextc%taller + end do + + if ( tied_size_with_neighbors ) then + + currentCohort%excl_weight = & + max(0.0_r8,min(currentCohort%c_area, & + (currentCohort%c_area/total_crownarea_of_tied_cohorts) * & + (demote_area - sumweights) )) + + sumequal = currentCohort%excl_weight + + nextc => currentCohort%taller + do while (associated(nextc)) + if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then + if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then + ! now we know the total crown area of all equal-sized, + ! equal-canopy-layer cohorts + nextc%excl_weight = & + max(0.0_r8,min(nextc%c_area, & + (nextc%c_area/total_crownarea_of_tied_cohorts) * & + (demote_area - sumweights) )) + sumequal = sumequal + nextc%excl_weight + end if + else + exit + endif + nextc => nextc%taller + end do + + ! Update the current cohort pointer to the last similar cohort + ! Its ok if this is not in the right layer + if(associated(nextc))then + currentCohort => nextc%shorter + else + currentCohort => currentPatch%tallest + end if + sumweights = sumweights + sumequal + + else + currentCohort%excl_weight = & + max(min(currentCohort%c_area, demote_area - sumweights ), 0._r8) + sumweights = sumweights + currentCohort%excl_weight + end if + + endif + endif + currentCohort => currentCohort%taller + enddo + + ! If this is probabalistic demotion, we need to do a round of normalization. + ! And then a few rounds where we pre-calculate the demotion areas + ! and adjust things if the demoted area wants to be greater than + ! what is available. The math is too hard to explain here, see + ! the tech note section on promotion/demotion. + + if (ED_val_comp_excln .ge. 0.0_r8 ) then + + scale_factor_min = 1.e10_r8 + scale_factor = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + + if(currentCohort%canopy_layer == i_lyr) then + + currentCohort%excl_weight = currentCohort%excl_weight/sumweights + if( 1._r8/currentCohort%excl_weight < scale_factor_min ) & + scale_factor_min = 1._r8/currentCohort%excl_weight + + scale_factor = scale_factor + currentCohort%excl_weight * currentCohort%c_area + + endif + currentCohort => currentCohort%shorter + enddo + + ! This is the factor by which we need to multiply + ! the demotion probabilities, so the sum result equals + ! the total amount to demote + + scale_factor = demote_area/scale_factor + + if(scale_factor <= scale_factor_min) then + + ! Trivial case, all of the demotion fractions are less than 1. + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then + currentCohort%excl_weight = currentCohort%c_area * currentCohort%excl_weight * scale_factor + + if(debug) then + if((currentCohort%excl_weight > (currentCohort%c_area+area_target_precision)) .or. & + (currentCohort%excl_weight < 0._r8) ) then + write(fates_log(),*) 'exclusion area too big (1)' + write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area + write(fates_log(),*) 'dbh: ',currentCohort%dbh + write(fates_log(),*) 'n: ',currentCohort%n + write(fates_log(),*) 'spread: ',currentSite%spread + write(fates_log(),*) 'pft: ',currentCohort%pft + write(fates_log(),*) 'currentCohort%excl_weight: ',currentCohort%excl_weight + write(fates_log(),*) 'excess: ',currentCohort%excl_weight - currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + endif + currentCohort => currentCohort%shorter + enddo + + else + + + ! Non-trivial case, at least 1 cohort's demotion + ! rate would exceed its area, given the trivial scale factor + + area_res = 0._r8 + scale_factor_res = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then + area_res = area_res + & + currentCohort%c_area * currentCohort%excl_weight * & + scale_factor_min + scale_factor_res = scale_factor_res + & + currentCohort%c_area * & + (1._r8 - (currentCohort%excl_weight * scale_factor_min)) + endif + currentCohort => currentCohort%shorter + enddo + + area_res = demote_area - area_res + + scale_factor_res = area_res / scale_factor_res + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then + + currentCohort%excl_weight = currentCohort%c_area * & + (currentCohort%excl_weight * scale_factor_min + & + (1._r8 - (currentCohort%excl_weight*scale_factor_min) ) * scale_factor_res) + + if(debug)then + if((currentCohort%excl_weight > & + (currentCohort%c_area+area_target_precision)) .or. & + (currentCohort%excl_weight < 0._r8) ) then + write(fates_log(),*) 'exclusion area error (2)' + write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area + write(fates_log(),*) 'currentCohort%excl_weight: ', & + currentCohort%excl_weight + write(fates_log(),*) 'excess: ', & + currentCohort%excl_weight - currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + endif + currentCohort => currentCohort%shorter + enddo + + end if + + end if + + + ! perform a check and see if the demotions meet the demand + sumweights = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then + sumweights = sumweights + currentCohort%excl_weight + end if + currentCohort => currentCohort%shorter + end do + + if (abs(sumweights - demote_area) > area_check_precision ) then + write(fates_log(),*) 'demotions dont add up' + write(fates_log(),*) 'sum demotions: ',sumweights + write(fates_log(),*) 'area needed to be demoted: ',demote_area + write(fates_log(),*) 'excess: ',sumweights - demote_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + ! Weights have been calculated. Now move them to the lower layer + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + + if(currentCohort%canopy_layer == i_lyr )then + + cc_loss = currentCohort%excl_weight + leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) + sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) + struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) + + if ( (cc_loss-currentCohort%c_area) > -nearzero .and. & + (cc_loss-currentCohort%c_area) < area_target_precision ) then + + ! If the whole cohort is being demoted, just change its + ! layer index + + currentCohort%canopy_layer = i_lyr+1 + + ! keep track of number and biomass of demoted cohort + currentSite%demotion_rate(currentCohort%size_class) = & + currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & + (leaf_c + store_c + fnrt_c + sapw_c + struct_c) * currentCohort%n + + elseif( (cc_loss < currentCohort%c_area) .and. & + (cc_loss > area_target_precision) ) then + + ! If only part of the cohort is demoted + ! then it must be split (little more complicated) + + ! Make a copy of the current cohort. The copy and the original + ! conserve total number density of the original. The copy + ! remains in the upper-story. The original is the one + ! demoted to the understory + + + allocate(copyc) + + ! Initialize the PARTEH object and point to the + ! correct boundary condition fields + copyc%prt => null() + call InitPRTObject(copyc%prt) + call InitPRTBoundaryConditions(copyc) + + if( hlm_use_planthydro.eq.itrue ) then + call InitHydrCohort(currentSite,copyc) + endif + + call copy_cohort(currentCohort, copyc) + + newarea = currentCohort%c_area - cc_loss + copyc%n = currentCohort%n*newarea/currentCohort%c_area + currentCohort%n = currentCohort%n - copyc%n + + copyc%canopy_layer = i_lyr !the taller cohort is the copy + + ! Demote the current cohort to the understory. + currentCohort%canopy_layer = i_lyr + 1 + + ! keep track of number and biomass of demoted cohort + currentSite%demotion_rate(currentCohort%size_class) = & + currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & + (leaf_c + store_c + fnrt_c + sapw_c + struct_c) * currentCohort%n + + call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + currentCohort%pft,currentCohort%c_area) + + !----------- Insert copy into linked list ------------------------! + copyc%shorter => currentCohort + if(associated(currentCohort%taller))then + copyc%taller => currentCohort%taller + currentCohort%taller%shorter => copyc + else + currentPatch%tallest => copyc + copyc%taller => null() + endif + currentCohort%taller => copyc + + elseif(cc_loss > currentCohort%c_area)then + + write(fates_log(),*) 'more area than the cohort has is being demoted' + write(fates_log(),*) 'loss:',cc_loss + write(fates_log(),*) 'existing area:',currentCohort%c_area + write(fates_log(),*) 'excess: ',cc_loss - currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end if + + ! kill the ones which go into canopy layers that are not allowed + + if(currentCohort%canopy_layer>nclmax )then + + ! put the litter from the terminated cohorts + ! straight into the fragmenting pools + call SendCohortToLitter(currentSite,currentPatch, & + currentCohort,currentCohort%n) + + currentCohort%n = 0.0_r8 + currentCohort%c_area = 0.0_r8 + currentCohort%canopy_layer = i_lyr + + end if + + call carea_allom(currentCohort%dbh,currentCohort%n, & + currentSite%spread,currentCohort%pft,currentCohort%c_area) + + endif !canopy layer = i_ly + + currentCohort => currentCohort%shorter + enddo !currentCohort + + + ! Update the area calculations of the current layer + ! And the layer below that may or may not had recieved + ! Demotions + + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer) + + if ( (abs(arealayer - currentPatch%area)/arealayer > area_check_rel_precision ) .or. & + (abs(arealayer - currentPatch%area) > area_check_precision) ) then + write(fates_log(),*) 'demotion did not trim area within tolerance' + write(fates_log(),*) 'arealayer:',arealayer + write(fates_log(),*) 'patch%area:',currentPatch%area + write(fates_log(),*) 'ilayer: ',i_lyr + write(fates_log(),*) 'bias:',arealayer - currentPatch%area + write(fates_log(),*) 'rel bias:',(arealayer - currentPatch%area)/arealayer + write(fates_log(),*) 'demote_area:',demote_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + end if + + return + end subroutine DemoteFromLayer + + ! ============================================================================================== + + subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) + + ! ------------------------------------------------------------------------------------------- + ! Check whether the intended 'full' layers are actually filling all the space. + ! If not, promote some fraction of cohorts upwards. + ! THIS SECTION MIGHT BE TRIGGERED BY A FIRE OR MORTALITY EVENT, FOLLOWED BY A PATCH FUSION, + ! SO THE TOP LAYER IS NO LONGER FULL. + ! ------------------------------------------------------------------------------------------- + + use EDParamsMod, only : ED_val_comp_excln + + ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite + type(ed_patch_type), intent(inout), target :: currentPatch + integer, intent(in) :: i_lyr ! Current canopy layer of interest + + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer :: currentCohort + type(ed_cohort_type), pointer :: copyc + type(ed_cohort_type), pointer :: nextc ! the next cohort, or used for looping + ! cohorts against the current + + real(r8) :: scale_factor ! for prob. exclusion - scales weight to a fraction + real(r8) :: scale_factor_min ! "" minimum before exeedance of 1 + real(r8) :: scale_factor_res ! "" applied to residual areas + real(r8) :: area_res ! residual area to demote after weakest cohort hits max + real(r8) :: promote_area + real(r8) :: newarea + real(r8) :: sumweights + real(r8) :: sumequal ! for tied cohorts, the sum of weights in + ! their group + real(r8) :: cc_gain ! cohort crown area gain in promotion (m2) + real(r8) :: arealayer_current ! area (m2) of the current canopy layer + real(r8) :: arealayer_below ! area (m2) of the layer below the current layer + real(r8) :: leaf_c ! leaf carbon [kg] + real(r8) :: fnrt_c ! fineroot carbon [kg] + real(r8) :: sapw_c ! sapwood carbon [kg] + real(r8) :: store_c ! storage carbon [kg] + real(r8) :: struct_c ! structure carbon [kg] + + logical :: tied_size_with_neighbors + real(r8) :: total_crownarea_of_tied_cohorts + + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr+1,arealayer_below) + + + ! how much do we need to gain? + promote_area = currentPatch%area - arealayer_current + + if( promote_area > area_target_precision ) then + + if(arealayer_below <= promote_area ) then + + ! --------------------------------------------------------------------------- + ! Promote all cohorts from layer below if that whole layer has area smaller + ! than the tolerance on the gains needed into current layer + ! --------------------------------------------------------------------------- + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + !look at the cohorts in the canopy layer below... + if(currentCohort%canopy_layer == i_lyr+1)then + + leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) + sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) + struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) + + currentCohort%canopy_layer = i_lyr + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + currentCohort%pft,currentCohort%c_area) + ! keep track of number and biomass of promoted cohort + currentSite%promotion_rate(currentCohort%size_class) = & + currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & + (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n + + endif + currentCohort => currentCohort%shorter + enddo + + else + + ! --------------------------------------------------------------------------- + ! This is the non-trivial case where the lower layer can accomodate + ! more than what is necessary. + ! --------------------------------------------------------------------------- + + + ! figure out with what weighting we need to promote cohorts. + ! This is the opposite of the demotion weighting... + + sumweights = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + currentCohort%pft,currentCohort%c_area) + if(currentCohort%canopy_layer == i_lyr+1)then !look at the cohorts in the canopy layer below... + + if (ED_val_comp_excln .ge. 0.0_r8 ) then + + ! ------------------------------------------------------------------ + ! Stochastic case, as above (in demotion portion of code) + ! ------------------------------------------------------------------ + + currentCohort%prom_weight = currentCohort%hite**ED_val_comp_excln + sumweights = sumweights + currentCohort%prom_weight + else + + ! ------------------------------------------------------------------ + ! Rank ordered deterministic method + ! If there are cohorts that have the exact same height (which is possible, really) + ! we don't want to unilaterally promote/demote one before the others. + ! So we <>mote them as a unit + ! now we need to go through and figure out how many equal-size cohorts there are. + ! then we need to go through, add up the collective crown areas of all equal-sized + ! and equal-canopy-layer cohorts, + ! and then demote from each as if they were a single group + ! ------------------------------------------------------------------ + + total_crownarea_of_tied_cohorts = currentCohort%c_area + tied_size_with_neighbors = .false. + nextc => currentCohort%shorter + do while (associated(nextc)) + if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then + if( nextc%canopy_layer .eq. currentCohort%canopy_layer ) then + tied_size_with_neighbors = .true. + total_crownarea_of_tied_cohorts = & + total_crownarea_of_tied_cohorts + nextc%c_area + end if + else + exit + endif + nextc => nextc%shorter + end do + + if ( tied_size_with_neighbors ) then + + currentCohort%prom_weight = & + max(0.0_r8,min(currentCohort%c_area, & + (currentCohort%c_area/total_crownarea_of_tied_cohorts) * & + (promote_area - sumweights) )) + sumequal = currentCohort%prom_weight + + nextc => currentCohort%shorter + do while (associated(nextc)) + if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then + if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then + ! now we know the total crown area of all equal-sized, + ! equal-canopy-layer cohorts + nextc%prom_weight = & + max(0.0_r8,min(nextc%c_area, & + (nextc%c_area/total_crownarea_of_tied_cohorts) * & + (promote_area - sumweights) )) + sumequal = sumequal + nextc%prom_weight + end if + else + exit + endif + nextc => nextc%shorter + end do + + ! Update the current cohort pointer to the last similar cohort + ! Its ok if this is not in the right layer + if(associated(nextc))then + currentCohort => nextc%taller + else + currentCohort => currentPatch%shortest + end if + sumweights = sumweights + sumequal + + else + currentCohort%prom_weight = & + max(min(currentCohort%c_area, promote_area - sumweights ), 0._r8) + sumweights = sumweights + currentCohort%prom_weight + + end if + + endif + endif + currentCohort => currentCohort%shorter + enddo !currentCohort + + + ! If this is probabalistic promotion, we need to do a round of normalization. + ! And then a few rounds where we pre-calculate the promotion areas + ! and adjust things if the promoted area wants to be greater than + ! what is available. + + if (ED_val_comp_excln .ge. 0.0_r8 ) then + + scale_factor_min = 1.e10_r8 + scale_factor = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + + if(currentCohort%canopy_layer == (i_lyr+1) ) then + + currentCohort%prom_weight = currentCohort%prom_weight/sumweights + if( 1._r8/currentCohort%prom_weight < scale_factor_min ) & + scale_factor_min = 1._r8/currentCohort%prom_weight + + scale_factor = scale_factor + currentCohort%prom_weight * currentCohort%c_area + + endif + currentCohort => currentCohort%shorter + enddo + + ! This is the factor by which we need to multiply + ! the demotion probabilities, so the sum result equals + ! the total amount to demote + scale_factor = promote_area/scale_factor + + + if(scale_factor <= scale_factor_min) then + + ! Trivial case, all of the demotion fractions + ! are less than 1. + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1) ) then + currentCohort%prom_weight = currentCohort%c_area * & + currentCohort%prom_weight * scale_factor + + if(debug)then + if((currentCohort%prom_weight > & + (currentCohort%c_area+area_target_precision)) .or. & + (currentCohort%prom_weight < 0._r8) ) then + write(fates_log(),*) 'promotion area too big (1)' + write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area + write(fates_log(),*) 'currentCohort%prom_weight: ', & + currentCohort%prom_weight + write(fates_log(),*) 'excess: ', & + currentCohort%prom_weight - currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + endif + currentCohort => currentCohort%shorter + enddo + + else + + ! Non-trivial case, at least 1 cohort's promotion + ! rate would exceed its area, given the trivial scale factor + + area_res = 0._r8 + scale_factor_res = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1) ) then + area_res = area_res + & + currentCohort%c_area*currentCohort%prom_weight*scale_factor_min + scale_factor_res = scale_factor_res + & + currentCohort%c_area * & + (1._r8 - (currentCohort%prom_weight * scale_factor_min)) + endif + currentCohort => currentCohort%shorter + enddo + + area_res = promote_area - area_res + + scale_factor_res = area_res / scale_factor_res - ! ============================================================================ - subroutine canopy_structure( currentSite , bc_in ) - ! - ! !DESCRIPTION: - ! create cohort instance - ! - ! This routine allocates the 'canopy_layer' attribute to each cohort - ! All top leaves in the same canopy layer get the same light resources. - ! The first canopy layer is the 'canopy' or 'overstorey'. The second is the 'understorey'. - ! More than two layers is not permitted at the moment - ! Seeds germinating into the 3rd or higher layers are automatically removed. - ! - ! ------Perfect Plasticity----- - ! The idea of these canopy layers derives originally from Purves et al. 2009 - ! Their concept is that, given enoughplasticity in canopy position, size, shape and depth - ! all of the gound area will be filled perfectly by leaves, and additional leaves will have - ! to exist in the understorey. - ! Purves et al. use the concept of 'Z*' to assume that the height required to attain a place in the - ! canopy is spatially uniform. In this implementation, described in Fisher et al. (2010, New Phyt) we - ! extent that concept to assume that position in the canopy has some random element, and that BOTH height - ! and chance combine to determine whether trees get into the canopy. - ! Thus, when the canopy is closed and there is excess area, some of it must be demoted - ! If we demote -all- the trees less than a given height, there is a massive advantage in being the cohort that is - ! the biggest when the canopy is closed. - ! In this implementation, the amount demoted, ('weight') is a function of the height weighted by the competitive exclusion - ! parameter (ED_val_comp_excln). - - ! Complexity in this routine results from a few things. - ! Firstly, the complication of the demotion amount sometimes being larger than the cohort area (for a very small, short cohort) - ! Second, occasionaly, disturbance (specifically fire) can cause the canopy layer to become less than closed, - ! without changing the area of the patch. If this happens, then some of the plants in the lower layer need to be 'promoted' so - ! all of the routine has to happen in both the downwards and upwards directions. - ! - ! The order of events here is therefore: - ! (The entire subroutine has a single outer 'patch' loop. - ! Section 1: figure out the total area, and whether there are >1 canopy layers at all. - ! - ! Sorts out cohorts into canopy and understorey layers... - ! - ! !USES: - - use EDParamsMod, only : ED_val_comp_excln - use EDTypesMod , only : min_patch_area - use FatesInterfaceTypesMod, only : bc_in_type - ! - ! !ARGUMENTS - type(ed_site_type) , intent(inout), target :: currentSite - type(bc_in_type), intent(in) :: bc_in - - ! - ! !LOCAL VARIABLES: - type(ed_patch_type) , pointer :: currentPatch - type(ed_cohort_type), pointer :: currentCohort - integer :: i_lyr ! current layer index - integer :: z ! Current number of canopy layers. (1= canopy, 2 = understorey) - integer :: ipft - real(r8) :: arealayer(nclmax+2) ! Amount of plant area currently in each canopy layer - integer :: patch_area_counter ! count iterations used to solve canopy areas - logical :: area_not_balanced ! logical controlling if the patch layer areas - ! have successfully been redistributed - integer :: return_code ! math checks on variables will return>0 if problems exist - - ! We only iterate because of possible imprecisions generated by the cohort - ! termination process. These should be super small, so at the most - ! try to re-balance 3 times. If that doesn't give layer areas - ! within tolerance of canopy area, there is something wrong - - integer, parameter :: max_patch_iterations = 10 - - - !---------------------------------------------------------------------- - currentPatch => currentSite%oldest_patch - ! - ! zero site-level demotion / promotion tracking info - currentSite%demotion_rate(:) = 0._r8 - currentSite%promotion_rate(:) = 0._r8 - currentSite%demotion_carbonflux = 0._r8 - currentSite%promotion_carbonflux = 0._r8 - - - ! - ! Section 1: Check total canopy area. - ! - do while (associated(currentPatch)) ! Patch loop - - ! ------------------------------------------------------------------------------ - ! Perform numerical checks on some cohort and patch structures - ! ------------------------------------------------------------------------------ - - ! canopy layer has a special bounds check - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if( currentCohort%canopy_layer < 1 .or. currentCohort%canopy_layer > nclmax+1 ) then - write(fates_log(),*) 'lat:',currentSite%lat - write(fates_log(),*) 'lon:',currentSite%lon - write(fates_log(),*) 'BOGUS CANOPY LAYER: ',currentCohort%canopy_layer - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - currentCohort => currentCohort%shorter - enddo - - - ! Does any layer have excess area in it? Keep going until it does not... - patch_area_counter = 0 - area_not_balanced = .true. - - do while(area_not_balanced) - - ! --------------------------------------------------------------------------- - ! Demotion Phase: Identify upper layers that are too full, and demote them to - ! the layers below. - ! --------------------------------------------------------------------------- - - ! Its possible that before we even enter this scheme - ! some cohort numbers are very low. Terminate them. - call terminate_cohorts(currentSite, currentPatch, 1, 12) - - ! Calculate how many layers we have in this canopy - ! This also checks the understory to see if its crown - ! area is large enough to warrant a temporary sub-understory layer - z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) - - do i_lyr = 1,z ! Loop around the currently occupied canopy layers. - call DemoteFromLayer(currentSite, currentPatch, i_lyr) - end do - - ! After demotions, we may then again have cohorts that are very very - ! very sparse, remove them - call terminate_cohorts(currentSite, currentPatch, 1,13) - - call fuse_cohorts(currentSite, currentPatch, bc_in) - - ! Remove cohorts for various other reasons - call terminate_cohorts(currentSite, currentPatch, 2,13) - - - ! --------------------------------------------------------------------------------------- - ! Promotion Phase: Identify if any upper-layers are underful and layers below them - ! have cohorts that can be split and promoted to the layer above. - ! --------------------------------------------------------------------------------------- - - ! Re-calculate Number of layers without the false substory - z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) - - ! We only promote if we have at least two layers - if (z>1) then - - do i_lyr=1,z-1 - call PromoteIntoLayer(currentSite, currentPatch, i_lyr) - end do - - ! Remove cohorts that are incredibly sparse - call terminate_cohorts(currentSite, currentPatch, 1,14) - - call fuse_cohorts(currentSite, currentPatch, bc_in) - - ! Remove cohorts for various other reasons - call terminate_cohorts(currentSite, currentPatch, 2,14) - - end if - - ! --------------------------------------------------------------------------------------- - ! Check on Layer Area (if the layer differences are not small - ! Continue trying to demote/promote. Its possible on the first pass through, - ! that cohort fusion has nudged the areas a little bit. - ! --------------------------------------------------------------------------------------- - - z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) - area_not_balanced = .false. - do i_lyr = 1,z - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer(i_lyr)) - if( ((arealayer(i_lyr)-currentPatch%area)/currentPatch%area > area_check_rel_precision) .or. & - ((arealayer(i_lyr)-currentPatch%area) > area_check_precision ) ) then - area_not_balanced = .true. - endif - enddo - - ! --------------------------------------------------------------------------------------- - ! Gracefully exit if too many iterations have gone by - ! --------------------------------------------------------------------------------------- - - patch_area_counter = patch_area_counter + 1 - if(patch_area_counter > max_patch_iterations .and. area_not_balanced) then - write(fates_log(),*) 'PATCH AREA CHECK NOT CLOSING' - write(fates_log(),*) 'patch area:',currentpatch%area - do i_lyr = 1,z - write(fates_log(),*) 'layer: ',i_lyr,' area: ',arealayer(i_lyr) - write(fates_log(),*) 'rel error: ',(arealayer(i_lyr)-currentPatch%area)/currentPatch%area - write(fates_log(),*) 'abs error: ',arealayer(i_lyr)-currentPatch%area - enddo - write(fates_log(),*) 'lat:',currentSite%lat - write(fates_log(),*) 'lon:',currentSite%lon - write(fates_log(),*) 'spread:',currentSite%spread - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - write(fates_log(),*) 'coh ilayer:',currentCohort%canopy_layer - write(fates_log(),*) 'coh dbh:',currentCohort%dbh - write(fates_log(),*) 'coh pft:',currentCohort%pft - write(fates_log(),*) 'coh n:',currentCohort%n - write(fates_log(),*) 'coh carea:',currentCohort%c_area - ipft=currentCohort%pft - write(fates_log(),*) 'maxh:',prt_params%allom_dbh_maxheight(ipft) - write(fates_log(),*) 'lmode: ',prt_params%allom_lmode(ipft) - write(fates_log(),*) 'd2bl2: ',prt_params%allom_d2bl2(ipft) - write(fates_log(),*) 'd2bl_ediff: ',prt_params%allom_blca_expnt_diff(ipft) - write(fates_log(),*) 'd2ca_min: ',prt_params%allom_d2ca_coefficient_min(ipft) - write(fates_log(),*) 'd2ca_max: ',prt_params%allom_d2ca_coefficient_max(ipft) - currentCohort => currentCohort%shorter - enddo - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - enddo ! do while(area_not_balanced) - - - ! Set current canopy layer occupancy indicator. - currentPatch%NCL_p = min(nclmax,z) - - ! ------------------------------------------------------------------------------------------- - ! if we are using "strict PPA", then calculate a z_star value as - ! the height of the smallest tree in the canopy - ! loop from top to bottom and locate the shortest cohort in level 1 whose shorter - ! neighbor is in level 2 set zstar as the ehight of that shortest level 1 cohort - ! ------------------------------------------------------------------------------------------- - - if ( ED_val_comp_excln .lt. 0.0_r8) then - currentPatch%zstar = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer .eq. 2)then - if (associated(currentCohort%taller)) then - if (currentCohort%taller%canopy_layer .eq. 1 ) then - currentPatch%zstar = currentCohort%taller%hite - endif - endif - endif - currentCohort => currentCohort%shorter - enddo - endif - - currentPatch => currentPatch%younger - enddo !patch - - return - end subroutine canopy_structure - - - ! ============================================================================================== - - - subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) - - use EDParamsMod, only : ED_val_comp_excln - use SFParamsMod, only : SF_val_CWD_frac - - ! !ARGUMENTS - type(ed_site_type), intent(inout), target :: currentSite - type(ed_patch_type), intent(inout), target :: currentPatch - integer, intent(in) :: i_lyr ! Current canopy layer of interest - - ! !LOCAL VARIABLES: - type(ed_cohort_type), pointer :: currentCohort - type(ed_cohort_type), pointer :: copyc - type(ed_cohort_type), pointer :: nextc ! The next cohort in line - integer :: i_cwd ! Index for CWD pool - real(r8) :: cc_loss ! cohort crown area loss in demotion (m2) - real(r8) :: leaf_c ! leaf carbon [kg] - real(r8) :: fnrt_c ! fineroot carbon [kg] - real(r8) :: sapw_c ! sapwood carbon [kg] - real(r8) :: store_c ! storage carbon [kg] - real(r8) :: struct_c ! structure carbon [kg] - real(r8) :: scale_factor ! for prob. exclusion - scales weight to a fraction - real(r8) :: scale_factor_min ! "" minimum before exeedance of 1 - real(r8) :: scale_factor_res ! "" applied to residual areas - real(r8) :: area_res ! residual area to demote after weakest cohort hits max - real(r8) :: newarea - real(r8) :: demote_area - real(r8) :: sumweights - real(r8) :: sumequal ! for rank-ordered same-size cohorts - ! this tallies their excluded area - real(r8) :: arealayer ! the area of the current canopy layer - logical :: tied_size_with_neighbors - real(r8) :: total_crownarea_of_tied_cohorts - - ! First, determine how much total canopy area we have in this layer - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer) - - demote_area = arealayer - currentPatch%area - - if ( demote_area > area_target_precision ) then - - ! Is this layer currently over-occupied? - ! In that case, we need to work out which cohorts to demote. - ! We go in order from shortest to tallest for ranked demotion - - sumweights = 0.0_r8 - currentCohort => currentPatch%shortest - do while (associated(currentCohort)) - call carea_allom(currentCohort%dbh,currentCohort%n, & - currentSite%spread,currentCohort%pft,currentCohort%c_area) - - if(debug) then - if(currentCohort%c_area<0._r8)then - write(fates_log(),*) 'negative c_area stage 1d: ',currentCohort%dbh,i_lyr,currentCohort%n, & - currentSite%spread,currentCohort%pft,currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if( currentCohort%canopy_layer == i_lyr)then - - if (ED_val_comp_excln .ge. 0.0_r8 ) then - - ! ---------------------------------------------------------- - ! Stochastic method. - ! Weight cohort demotion by inverse size to a constant power. - ! In this hypothesis, it is assumed that even the tallest - ! cohorts have a chance (although smaller) of being forced - ! to the understory. - ! ---------------------------------------------------------- - - currentCohort%excl_weight = 1._r8 / (currentCohort%hite**ED_val_comp_excln) - sumweights = sumweights + currentCohort%excl_weight - - else - - ! ----------------------------------------------------------- - ! Rank ordered deterministic method - ! ----------------------------------------------------------- - ! If there are cohorts that have the exact same height (which is possible, really) - ! we don't want to unilaterally promote/demote one before the others. - ! So we <>mote them as a unit - ! now we need to go through and figure out how many equal-size cohorts there are. - ! then we need to go through, add up the collective crown areas of all equal-sized - ! and equal-canopy-layer cohorts, - ! and then demote from each as if they were a single group - - total_crownarea_of_tied_cohorts = currentCohort%c_area - - tied_size_with_neighbors = .false. - nextc => currentCohort%taller - do while (associated(nextc)) - if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then - if( nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - tied_size_with_neighbors = .true. - total_crownarea_of_tied_cohorts = & - total_crownarea_of_tied_cohorts + nextc%c_area - end if - else - exit - endif - nextc => nextc%taller - end do - - if ( tied_size_with_neighbors ) then - - currentCohort%excl_weight = & - max(0.0_r8,min(currentCohort%c_area, & - (currentCohort%c_area/total_crownarea_of_tied_cohorts) * & - (demote_area - sumweights) )) - - sumequal = currentCohort%excl_weight - - nextc => currentCohort%taller - do while (associated(nextc)) - if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then - if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - ! now we know the total crown area of all equal-sized, - ! equal-canopy-layer cohorts - nextc%excl_weight = & - max(0.0_r8,min(nextc%c_area, & - (nextc%c_area/total_crownarea_of_tied_cohorts) * & - (demote_area - sumweights) )) - sumequal = sumequal + nextc%excl_weight - end if - else - exit - endif - nextc => nextc%taller - end do - - ! Update the current cohort pointer to the last similar cohort - ! Its ok if this is not in the right layer - if(associated(nextc))then - currentCohort => nextc%shorter - else - currentCohort => currentPatch%tallest - end if - sumweights = sumweights + sumequal - - else - currentCohort%excl_weight = & - max(min(currentCohort%c_area, demote_area - sumweights ), 0._r8) - sumweights = sumweights + currentCohort%excl_weight - end if - - endif - endif - currentCohort => currentCohort%taller - enddo - - ! If this is probabalistic demotion, we need to do a round of normalization. - ! And then a few rounds where we pre-calculate the demotion areas - ! and adjust things if the demoted area wants to be greater than - ! what is available. The math is too hard to explain here, see - ! the tech note section on promotion/demotion. - - if (ED_val_comp_excln .ge. 0.0_r8 ) then - - scale_factor_min = 1.e10_r8 - scale_factor = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - - if(currentCohort%canopy_layer == i_lyr) then - - currentCohort%excl_weight = currentCohort%excl_weight/sumweights - if( 1._r8/currentCohort%excl_weight < scale_factor_min ) & - scale_factor_min = 1._r8/currentCohort%excl_weight - - scale_factor = scale_factor + currentCohort%excl_weight * currentCohort%c_area - - endif - currentCohort => currentCohort%shorter - enddo - - ! This is the factor by which we need to multiply - ! the demotion probabilities, so the sum result equals - ! the total amount to demote - - scale_factor = demote_area/scale_factor - - if(scale_factor <= scale_factor_min) then - - ! Trivial case, all of the demotion fractions are less than 1. - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then - currentCohort%excl_weight = currentCohort%c_area * currentCohort%excl_weight * scale_factor - - if(debug) then - if((currentCohort%excl_weight > (currentCohort%c_area+area_target_precision)) .or. & - (currentCohort%excl_weight < 0._r8) ) then - write(fates_log(),*) 'exclusion area too big (1)' - write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area - write(fates_log(),*) 'dbh: ',currentCohort%dbh - write(fates_log(),*) 'n: ',currentCohort%n - write(fates_log(),*) 'spread: ',currentSite%spread - write(fates_log(),*) 'pft: ',currentCohort%pft - write(fates_log(),*) 'currentCohort%excl_weight: ',currentCohort%excl_weight - write(fates_log(),*) 'excess: ',currentCohort%excl_weight - currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - endif - currentCohort => currentCohort%shorter - enddo - - else - - - ! Non-trivial case, at least 1 cohort's demotion - ! rate would exceed its area, given the trivial scale factor - - area_res = 0._r8 - scale_factor_res = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then - area_res = area_res + & - currentCohort%c_area * currentCohort%excl_weight * & - scale_factor_min - scale_factor_res = scale_factor_res + & - currentCohort%c_area * & - (1._r8 - (currentCohort%excl_weight * scale_factor_min)) - endif - currentCohort => currentCohort%shorter - enddo - - area_res = demote_area - area_res - - scale_factor_res = area_res / scale_factor_res - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then - - currentCohort%excl_weight = currentCohort%c_area * & - (currentCohort%excl_weight * scale_factor_min + & - (1._r8 - (currentCohort%excl_weight*scale_factor_min) ) * scale_factor_res) - - if(debug)then - if((currentCohort%excl_weight > & - (currentCohort%c_area+area_target_precision)) .or. & - (currentCohort%excl_weight < 0._r8) ) then - write(fates_log(),*) 'exclusion area error (2)' + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1)) then + + currentCohort%prom_weight = currentCohort%c_area * & + (currentCohort%prom_weight * scale_factor_min + & + (1._r8 - (currentCohort%prom_weight*scale_factor_min) ) * & + scale_factor_res) + + if(debug)then + if((currentCohort%prom_weight > & + (currentCohort%c_area+area_target_precision)) .or. & + (currentCohort%prom_weight < 0._r8) ) then + write(fates_log(),*) 'promotion area error (2)' write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area - write(fates_log(),*) 'currentCohort%excl_weight: ', & - currentCohort%excl_weight + write(fates_log(),*) 'currentCohort%prom_weight: ', & + currentCohort%prom_weight write(fates_log(),*) 'excess: ', & - currentCohort%excl_weight - currentCohort%c_area + currentCohort%prom_weight - currentCohort%c_area call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - endif - currentCohort => currentCohort%shorter - enddo - - end if - - end if - - - ! perform a check and see if the demotions meet the demand - sumweights = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then - sumweights = sumweights + currentCohort%excl_weight - end if - currentCohort => currentCohort%shorter - end do - - if (abs(sumweights - demote_area) > area_check_precision ) then - write(fates_log(),*) 'demotions dont add up' - write(fates_log(),*) 'sum demotions: ',sumweights - write(fates_log(),*) 'area needed to be demoted: ',demote_area - write(fates_log(),*) 'excess: ',sumweights - demote_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - ! Weights have been calculated. Now move them to the lower layer - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - - if(currentCohort%canopy_layer == i_lyr )then - - cc_loss = currentCohort%excl_weight - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) - fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) - sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) - struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) - - if ( (cc_loss-currentCohort%c_area) > -nearzero .and. & - (cc_loss-currentCohort%c_area) < area_target_precision ) then - - ! If the whole cohort is being demoted, just change its - ! layer index - - currentCohort%canopy_layer = i_lyr+1 - - ! keep track of number and biomass of demoted cohort - currentSite%demotion_rate(currentCohort%size_class) = & - currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n - currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & - (leaf_c + store_c + fnrt_c + sapw_c + struct_c) * currentCohort%n - - elseif( (cc_loss < currentCohort%c_area) .and. & - (cc_loss > area_target_precision) ) then - - ! If only part of the cohort is demoted - ! then it must be split (little more complicated) - - ! Make a copy of the current cohort. The copy and the original - ! conserve total number density of the original. The copy - ! remains in the upper-story. The original is the one - ! demoted to the understory - - - allocate(copyc) - - ! Initialize the PARTEH object and point to the - ! correct boundary condition fields - copyc%prt => null() - call InitPRTObject(copyc%prt) - call InitPRTBoundaryConditions(copyc) - - if( hlm_use_planthydro.eq.itrue ) then - call InitHydrCohort(currentSite,copyc) - endif - - call copy_cohort(currentCohort, copyc) - - newarea = currentCohort%c_area - cc_loss - copyc%n = currentCohort%n*newarea/currentCohort%c_area - currentCohort%n = currentCohort%n - copyc%n - - copyc%canopy_layer = i_lyr !the taller cohort is the copy - - ! Demote the current cohort to the understory. - currentCohort%canopy_layer = i_lyr + 1 - - ! keep track of number and biomass of demoted cohort - currentSite%demotion_rate(currentCohort%size_class) = & - currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n - currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & - (leaf_c + store_c + fnrt_c + sapw_c + struct_c) * currentCohort%n - - call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) - - !----------- Insert copy into linked list ------------------------! - copyc%shorter => currentCohort - if(associated(currentCohort%taller))then - copyc%taller => currentCohort%taller - currentCohort%taller%shorter => copyc - else - currentPatch%tallest => copyc - copyc%taller => null() - endif - currentCohort%taller => copyc - - elseif(cc_loss > currentCohort%c_area)then - - write(fates_log(),*) 'more area than the cohort has is being demoted' - write(fates_log(),*) 'loss:',cc_loss - write(fates_log(),*) 'existing area:',currentCohort%c_area - write(fates_log(),*) 'excess: ',cc_loss - currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - - end if - - ! kill the ones which go into canopy layers that are not allowed - - if(currentCohort%canopy_layer>nclmax )then - - ! put the litter from the terminated cohorts - ! straight into the fragmenting pools - call SendCohortToLitter(currentSite,currentPatch, & - currentCohort,currentCohort%n) - - currentCohort%n = 0.0_r8 - currentCohort%c_area = 0.0_r8 - currentCohort%canopy_layer = i_lyr - - end if - - call carea_allom(currentCohort%dbh,currentCohort%n, & - currentSite%spread,currentCohort%pft,currentCohort%c_area) - - endif !canopy layer = i_ly - - currentCohort => currentCohort%shorter - enddo !currentCohort - - - ! Update the area calculations of the current layer - ! And the layer below that may or may not had recieved - ! Demotions - - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer) - - if ( (abs(arealayer - currentPatch%area)/arealayer > area_check_rel_precision ) .or. & - (abs(arealayer - currentPatch%area) > area_check_precision) ) then - write(fates_log(),*) 'demotion did not trim area within tolerance' - write(fates_log(),*) 'arealayer:',arealayer - write(fates_log(),*) 'patch%area:',currentPatch%area - write(fates_log(),*) 'ilayer: ',i_lyr - write(fates_log(),*) 'bias:',arealayer - currentPatch%area - write(fates_log(),*) 'rel bias:',(arealayer - currentPatch%area)/arealayer - write(fates_log(),*) 'demote_area:',demote_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - end if - - return - end subroutine DemoteFromLayer - - ! ============================================================================================== - - subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) - - ! ------------------------------------------------------------------------------------------- - ! Check whether the intended 'full' layers are actually filling all the space. - ! If not, promote some fraction of cohorts upwards. - ! THIS SECTION MIGHT BE TRIGGERED BY A FIRE OR MORTALITY EVENT, FOLLOWED BY A PATCH FUSION, - ! SO THE TOP LAYER IS NO LONGER FULL. - ! ------------------------------------------------------------------------------------------- - - use EDParamsMod, only : ED_val_comp_excln - - ! !ARGUMENTS - type(ed_site_type), intent(inout), target :: currentSite - type(ed_patch_type), intent(inout), target :: currentPatch - integer, intent(in) :: i_lyr ! Current canopy layer of interest - - ! !LOCAL VARIABLES: - type(ed_cohort_type), pointer :: currentCohort - type(ed_cohort_type), pointer :: copyc - type(ed_cohort_type), pointer :: nextc ! the next cohort, or used for looping - ! cohorts against the current - - real(r8) :: scale_factor ! for prob. exclusion - scales weight to a fraction - real(r8) :: scale_factor_min ! "" minimum before exeedance of 1 - real(r8) :: scale_factor_res ! "" applied to residual areas - real(r8) :: area_res ! residual area to demote after weakest cohort hits max - real(r8) :: promote_area - real(r8) :: newarea - real(r8) :: sumweights - real(r8) :: sumequal ! for tied cohorts, the sum of weights in - ! their group - real(r8) :: cc_gain ! cohort crown area gain in promotion (m2) - real(r8) :: arealayer_current ! area (m2) of the current canopy layer - real(r8) :: arealayer_below ! area (m2) of the layer below the current layer - real(r8) :: leaf_c ! leaf carbon [kg] - real(r8) :: fnrt_c ! fineroot carbon [kg] - real(r8) :: sapw_c ! sapwood carbon [kg] - real(r8) :: store_c ! storage carbon [kg] - real(r8) :: struct_c ! structure carbon [kg] - - logical :: tied_size_with_neighbors - real(r8) :: total_crownarea_of_tied_cohorts - - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr+1,arealayer_below) - - - ! how much do we need to gain? - promote_area = currentPatch%area - arealayer_current - - if( promote_area > area_target_precision ) then - - if(arealayer_below <= promote_area ) then - - ! --------------------------------------------------------------------------- - ! Promote all cohorts from layer below if that whole layer has area smaller - ! than the tolerance on the gains needed into current layer - ! --------------------------------------------------------------------------- - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - !look at the cohorts in the canopy layer below... - if(currentCohort%canopy_layer == i_lyr+1)then - - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) - fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) - sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) - struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) - - currentCohort%canopy_layer = i_lyr - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + end if + end if + + endif + currentCohort => currentCohort%shorter + enddo + + end if + + end if + + + ! lets perform a check and see if the promotions meet the demand + sumweights = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1)) then + sumweights = sumweights + currentCohort%prom_weight + end if + currentCohort => currentCohort%shorter + end do + + if(debug)then + if (abs(sumweights - promote_area) > area_check_precision ) then + write(fates_log(),*) 'promotions dont add up' + write(fates_log(),*) 'sum promotions: ',sumweights + write(fates_log(),*) 'area needed to be promoted: ',promote_area + write(fates_log(),*) 'excess: ',sumweights - promote_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + + + !All the trees in this layer need to promote some area upwards... + if( (currentCohort%canopy_layer == i_lyr+1) ) then + + cc_gain = currentCohort%prom_weight + leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) + sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) + struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) + + if ( (cc_gain-currentCohort%c_area) > -nearzero .and. & + (cc_gain-currentCohort%c_area) < area_target_precision ) then + + currentCohort%canopy_layer = i_lyr + + ! keep track of number and biomass of promoted cohort + currentSite%promotion_rate(currentCohort%size_class) = & + currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n + + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & + (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n + + elseif ( (cc_gain < currentCohort%c_area) .and. & + (cc_gain > area_target_precision) ) then + + allocate(copyc) + + ! Initialize the PARTEH object and point to the + ! correct boundary condition fields + copyc%prt => null() + call InitPRTObject(copyc%prt) + call InitPRTBoundaryConditions(copyc) + + if( hlm_use_planthydro.eq.itrue ) then + call InitHydrCohort(CurrentSite,copyc) + endif + call copy_cohort(currentCohort, copyc) !makes an identical copy... + + newarea = currentCohort%c_area - cc_gain !new area of existing cohort + + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + currentCohort%pft,currentCohort%c_area) + + ! number of individuals in promoted cohort. + copyc%n = currentCohort%n*cc_gain/currentCohort%c_area + + ! number of individuals in cohort remaining in understorey + currentCohort%n = currentCohort%n - copyc%n + + currentCohort%canopy_layer = i_lyr + 1 ! keep current cohort in the understory. + copyc%canopy_layer = i_lyr ! promote copy to the higher canopy layer. + + ! keep track of number and biomass of promoted cohort + currentSite%promotion_rate(copyc%size_class) = & + currentSite%promotion_rate(copyc%size_class) + copyc%n + + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & + (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * copyc%n + + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) - ! keep track of number and biomass of promoted cohort - currentSite%promotion_rate(currentCohort%size_class) = & - currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n - currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & - (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n - - endif - currentCohort => currentCohort%shorter - enddo - - else - - ! --------------------------------------------------------------------------- - ! This is the non-trivial case where the lower layer can accomodate - ! more than what is necessary. - ! --------------------------------------------------------------------------- - - - ! figure out with what weighting we need to promote cohorts. - ! This is the opposite of the demotion weighting... - - sumweights = 0.0_r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) - if(currentCohort%canopy_layer == i_lyr+1)then !look at the cohorts in the canopy layer below... - - if (ED_val_comp_excln .ge. 0.0_r8 ) then - - ! ------------------------------------------------------------------ - ! Stochastic case, as above (in demotion portion of code) - ! ------------------------------------------------------------------ - - currentCohort%prom_weight = currentCohort%hite**ED_val_comp_excln - sumweights = sumweights + currentCohort%prom_weight - else - - ! ------------------------------------------------------------------ - ! Rank ordered deterministic method - ! If there are cohorts that have the exact same height (which is possible, really) - ! we don't want to unilaterally promote/demote one before the others. - ! So we <>mote them as a unit - ! now we need to go through and figure out how many equal-size cohorts there are. - ! then we need to go through, add up the collective crown areas of all equal-sized - ! and equal-canopy-layer cohorts, - ! and then demote from each as if they were a single group - ! ------------------------------------------------------------------ - - total_crownarea_of_tied_cohorts = currentCohort%c_area - tied_size_with_neighbors = .false. - nextc => currentCohort%shorter - do while (associated(nextc)) - if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then - if( nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - tied_size_with_neighbors = .true. - total_crownarea_of_tied_cohorts = & - total_crownarea_of_tied_cohorts + nextc%c_area - end if - else - exit - endif - nextc => nextc%shorter - end do - - if ( tied_size_with_neighbors ) then - - currentCohort%prom_weight = & - max(0.0_r8,min(currentCohort%c_area, & - (currentCohort%c_area/total_crownarea_of_tied_cohorts) * & - (promote_area - sumweights) )) - sumequal = currentCohort%prom_weight - - nextc => currentCohort%shorter - do while (associated(nextc)) - if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then - if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - ! now we know the total crown area of all equal-sized, - ! equal-canopy-layer cohorts - nextc%prom_weight = & - max(0.0_r8,min(nextc%c_area, & - (nextc%c_area/total_crownarea_of_tied_cohorts) * & - (promote_area - sumweights) )) - sumequal = sumequal + nextc%prom_weight - end if - else - exit - endif - nextc => nextc%shorter - end do - - ! Update the current cohort pointer to the last similar cohort - ! Its ok if this is not in the right layer - if(associated(nextc))then - currentCohort => nextc%taller - else - currentCohort => currentPatch%shortest - end if - sumweights = sumweights + sumequal - - else - currentCohort%prom_weight = & - max(min(currentCohort%c_area, promote_area - sumweights ), 0._r8) - sumweights = sumweights + currentCohort%prom_weight - - end if - - endif - endif - currentCohort => currentCohort%shorter - enddo !currentCohort - - - ! If this is probabalistic promotion, we need to do a round of normalization. - ! And then a few rounds where we pre-calculate the promotion areas - ! and adjust things if the promoted area wants to be greater than - ! what is available. - - if (ED_val_comp_excln .ge. 0.0_r8 ) then - - scale_factor_min = 1.e10_r8 - scale_factor = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - - if(currentCohort%canopy_layer == (i_lyr+1) ) then - - currentCohort%prom_weight = currentCohort%prom_weight/sumweights - if( 1._r8/currentCohort%prom_weight < scale_factor_min ) & - scale_factor_min = 1._r8/currentCohort%prom_weight - - scale_factor = scale_factor + currentCohort%prom_weight * currentCohort%c_area - - endif - currentCohort => currentCohort%shorter - enddo - - ! This is the factor by which we need to multiply - ! the demotion probabilities, so the sum result equals - ! the total amount to demote - scale_factor = promote_area/scale_factor - - - if(scale_factor <= scale_factor_min) then - - ! Trivial case, all of the demotion fractions - ! are less than 1. - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1) ) then - currentCohort%prom_weight = currentCohort%c_area * & - currentCohort%prom_weight * scale_factor - - if(debug)then - if((currentCohort%prom_weight > & - (currentCohort%c_area+area_target_precision)) .or. & - (currentCohort%prom_weight < 0._r8) ) then - write(fates_log(),*) 'promotion area too big (1)' - write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area - write(fates_log(),*) 'currentCohort%prom_weight: ', & - currentCohort%prom_weight - write(fates_log(),*) 'excess: ', & - currentCohort%prom_weight - currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - endif - currentCohort => currentCohort%shorter - enddo - - else - - ! Non-trivial case, at least 1 cohort's promotion - ! rate would exceed its area, given the trivial scale factor - - area_res = 0._r8 - scale_factor_res = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1) ) then - area_res = area_res + & - currentCohort%c_area*currentCohort%prom_weight*scale_factor_min - scale_factor_res = scale_factor_res + & - currentCohort%c_area * & - (1._r8 - (currentCohort%prom_weight * scale_factor_min)) - endif - currentCohort => currentCohort%shorter - enddo - - area_res = promote_area - area_res - - scale_factor_res = area_res / scale_factor_res - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1)) then - - currentCohort%prom_weight = currentCohort%c_area * & - (currentCohort%prom_weight * scale_factor_min + & - (1._r8 - (currentCohort%prom_weight*scale_factor_min) ) * & - scale_factor_res) - - if(debug)then - if((currentCohort%prom_weight > & - (currentCohort%c_area+area_target_precision)) .or. & - (currentCohort%prom_weight < 0._r8) ) then - write(fates_log(),*) 'promotion area error (2)' - write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area - write(fates_log(),*) 'currentCohort%prom_weight: ', & - currentCohort%prom_weight - write(fates_log(),*) 'excess: ', & - currentCohort%prom_weight - currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - endif - currentCohort => currentCohort%shorter - enddo - - end if - - end if - - - ! lets perform a check and see if the promotions meet the demand - sumweights = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1)) then - sumweights = sumweights + currentCohort%prom_weight - end if - currentCohort => currentCohort%shorter - end do - - if(debug)then - if (abs(sumweights - promote_area) > area_check_precision ) then - write(fates_log(),*) 'promotions dont add up' - write(fates_log(),*) 'sum promotions: ',sumweights - write(fates_log(),*) 'area needed to be promoted: ',promote_area - write(fates_log(),*) 'excess: ',sumweights - promote_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - - - !All the trees in this layer need to promote some area upwards... - if( (currentCohort%canopy_layer == i_lyr+1) ) then - - cc_gain = currentCohort%prom_weight - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) - fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) - sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) - struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) - - if ( (cc_gain-currentCohort%c_area) > -nearzero .and. & - (cc_gain-currentCohort%c_area) < area_target_precision ) then - - currentCohort%canopy_layer = i_lyr - - ! keep track of number and biomass of promoted cohort - currentSite%promotion_rate(currentCohort%size_class) = & - currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n - - currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & - (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n - - elseif ( (cc_gain < currentCohort%c_area) .and. & - (cc_gain > area_target_precision) ) then - - allocate(copyc) - - ! Initialize the PARTEH object and point to the - ! correct boundary condition fields - copyc%prt => null() - call InitPRTObject(copyc%prt) - call InitPRTBoundaryConditions(copyc) - - if( hlm_use_planthydro.eq.itrue ) then - call InitHydrCohort(CurrentSite,copyc) - endif - call copy_cohort(currentCohort, copyc) !makes an identical copy... - - newarea = currentCohort%c_area - cc_gain !new area of existing cohort - - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) - - ! number of individuals in promoted cohort. - copyc%n = currentCohort%n*cc_gain/currentCohort%c_area - - ! number of individuals in cohort remaining in understorey - currentCohort%n = currentCohort%n - copyc%n - - currentCohort%canopy_layer = i_lyr + 1 ! keep current cohort in the understory. - copyc%canopy_layer = i_lyr ! promote copy to the higher canopy layer. - - ! keep track of number and biomass of promoted cohort - currentSite%promotion_rate(copyc%size_class) = & - currentSite%promotion_rate(copyc%size_class) + copyc%n - - currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & - (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * copyc%n - - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) - call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) - - !----------- Insert copy into linked list ------------------------! - copyc%shorter => currentCohort - if(associated(currentCohort%taller))then - copyc%taller => currentCohort%taller - currentCohort%taller%shorter => copyc - else - currentPatch%tallest => copyc - copyc%taller => null() - endif - currentCohort%taller => copyc - - elseif(cc_gain > currentCohort%c_area)then - - write(fates_log(),*) 'more area than the cohort has is being promoted' - write(fates_log(),*) 'loss:',cc_gain - write(fates_log(),*) 'existing area:',currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - - endif - - endif ! if(currentCohort%canopy_layer == i_lyr+1) then - currentCohort => currentCohort%shorter - enddo !currentCohort - - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) - - if ((abs(arealayer_current - currentPatch%area)/arealayer_current > & - area_check_rel_precision ) .or. & - (abs(arealayer_current - currentPatch%area) > area_check_precision) ) then - write(fates_log(),*) 'promotion did not bring area within tolerance' - write(fates_log(),*) 'arealayer:',arealayer_current - write(fates_log(),*) 'patch%area:',currentPatch%area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - end if - - end if - - return - end subroutine PromoteIntoLayer + call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) + + !----------- Insert copy into linked list ------------------------! + copyc%shorter => currentCohort + if(associated(currentCohort%taller))then + copyc%taller => currentCohort%taller + currentCohort%taller%shorter => copyc + else + currentPatch%tallest => copyc + copyc%taller => null() + endif + currentCohort%taller => copyc + + elseif(cc_gain > currentCohort%c_area)then + + write(fates_log(),*) 'more area than the cohort has is being promoted' + write(fates_log(),*) 'loss:',cc_gain + write(fates_log(),*) 'existing area:',currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + + endif + + endif ! if(currentCohort%canopy_layer == i_lyr+1) then + currentCohort => currentCohort%shorter + enddo !currentCohort + + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) + + if ((abs(arealayer_current - currentPatch%area)/arealayer_current > & + area_check_rel_precision ) .or. & + (abs(arealayer_current - currentPatch%area) > area_check_precision) ) then + write(fates_log(),*) 'promotion did not bring area within tolerance' + write(fates_log(),*) 'arealayer:',arealayer_current + write(fates_log(),*) 'patch%area:',currentPatch%area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end if + + end if + + return + end subroutine PromoteIntoLayer ! ============================================================================ @@ -1220,9 +1220,9 @@ subroutine canopy_spread( currentSite ) currentCohort => currentPatch%tallest do while (associated(currentCohort)) call carea_allom(currentCohort%dbh,currentCohort%n, & - currentSite%spread,currentCohort%pft,currentCohort%c_area) + currentSite%spread,currentCohort%pft,currentCohort%c_area) if( ( int(prt_params%woody(currentCohort%pft)) .eq. itrue ) .and. & - (currentCohort%canopy_layer .eq. 1 ) ) then + (currentCohort%canopy_layer .eq. 1 ) ) then sitelevel_canopyarea = sitelevel_canopyarea + currentCohort%c_area endif currentCohort => currentCohort%shorter @@ -1250,9 +1250,9 @@ end subroutine canopy_spread subroutine canopy_summarization( nsites, sites, bc_in ) - ! ---------------------------------------------------------------------------------- - ! Much of this routine was once ed_clm_link minus all the IO and history stuff - ! --------------------------------------------------------------------------------- + ! ---------------------------------------------------------------------------------- + ! Much of this routine was once ed_clm_link minus all the IO and history stuff + ! --------------------------------------------------------------------------------- use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking @@ -1282,13 +1282,13 @@ subroutine canopy_summarization( nsites, sites, bc_in ) real(r8) :: struct_c ! structure carbon [kg] !---------------------------------------------------------------------- - + if ( debug ) then write(fates_log(),*) 'in canopy_summarization' endif do s = 1,nsites - + ! -------------------------------------------------------------------------------- ! Set the patch indices (this is usefull mostly for communicating with a host or ! driving model. Loops through all patches and sets cpatch%patchno to the integer @@ -1299,16 +1299,16 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentPatch => sites(s)%oldest_patch do while(associated(currentPatch)) - + !zero cohort-summed variables. currentPatch%total_canopy_area = 0.0_r8 currentPatch%total_tree_area = 0.0_r8 canopy_leaf_area = 0.0_r8 - + !update cohort quantitie s currentCohort => currentPatch%shortest do while(associated(currentCohort)) - + ft = currentCohort%pft @@ -1317,27 +1317,27 @@ subroutine canopy_summarization( nsites, sites, bc_in ) struct_c = currentCohort%prt%GetState(struct_organ, all_carbon_elements) fnrt_c = currentCohort%prt%GetState(fnrt_organ, all_carbon_elements) store_c = currentCohort%prt%GetState(store_organ, all_carbon_elements) - + ! Update the cohort's index within the size bin classes ! Update the cohort's index within the SCPF classification system call sizetype_class_index(currentCohort%dbh,currentCohort%pft, & currentCohort%size_class,currentCohort%size_by_pft_class) if (hlm_use_cohort_age_tracking .eq. itrue) then - call coagetype_class_index(currentCohort%coage,currentCohort%pft, & - currentCohort%coage_class,currentCohort%coage_by_pft_class) - end if + call coagetype_class_index(currentCohort%coage,currentCohort%pft, & + currentCohort%coage_class,currentCohort%coage_by_pft_class) + end if - if(hlm_use_sp.eq.ifalse)then - call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& - currentCohort%pft,currentCohort%c_area) - endif + if(hlm_use_sp.eq.ifalse)then + call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& + currentCohort%pft,currentCohort%c_area) + endif currentCohort%treelai = tree_lai(leaf_c, & currentCohort%pft, currentCohort%c_area, currentCohort%n, & currentCohort%canopy_layer, currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) canopy_leaf_area = canopy_leaf_area + currentCohort%treelai *currentCohort%c_area - + if(currentCohort%canopy_layer==1)then currentPatch%total_canopy_area = currentPatch%total_canopy_area + currentCohort%c_area if( int(prt_params%woody(ft))==itrue)then @@ -1353,40 +1353,40 @@ subroutine canopy_summarization( nsites, sites, bc_in ) if(hlm_use_sp.eq.itrue)then - if(associated(currentPatch%tallest%shorter))then - write(fates_log(),*) 'more than one cohort in SP mode',s,currentPatch%nocomp_pft_label - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + if(associated(currentPatch%tallest%shorter))then + write(fates_log(),*) 'more than one cohort in SP mode',s,currentPatch%nocomp_pft_label + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - if(currentPatch%total_canopy_area-currentPatch%area.gt.1.0e-16)then - write(fates_log(),*) 'too much canopy in summary',s, & - currentPatch%nocomp_pft_label, currentPatch%total_canopy_area-currentPatch%area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + if(currentPatch%total_canopy_area-currentPatch%area.gt.1.0e-16)then + write(fates_log(),*) 'too much canopy in summary',s, & + currentPatch%nocomp_pft_label, currentPatch%total_canopy_area-currentPatch%area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if end if !sp mode ! Check for erroneous zero values. if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then write(fates_log(),*) 'FATES: dbh or n is zero in canopy_summarization', & - currentCohort%dbh,currentCohort%n + currentCohort%dbh,currentCohort%n call endrun(msg=errMsg(sourcefile, __LINE__)) endif if(currentCohort%pft == 0.or.currentCohort%canopy_trim <= 0._r8)then write(fates_log(),*) 'FATES: PFT or trim is zero in canopy_summarization', & - currentCohort%pft,currentCohort%canopy_trim + currentCohort%pft,currentCohort%canopy_trim call endrun(msg=errMsg(sourcefile, __LINE__)) endif if( (sapw_c + leaf_c + fnrt_c) <= 0._r8)then write(fates_log(),*) 'FATES: alive biomass is zero in canopy_summarization', & - sapw_c + leaf_c + fnrt_c + sapw_c + leaf_c + fnrt_c call endrun(msg=errMsg(sourcefile, __LINE__)) endif currentCohort => currentCohort%taller - + enddo ! ends 'do while(associated(currentCohort)) - + if ( currentPatch%total_canopy_area>currentPatch%area ) then if ( currentPatch%total_canopy_area-currentPatch%area > 0.001_r8 ) then write(fates_log(),*) 'FATES: canopy area bigger than area', & @@ -1400,18 +1400,18 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentPatch => currentPatch%younger end do !patch loop - + call leaf_area_profile(sites(s),bc_in(s)%snow_depth_si,bc_in(s)%frac_sno_eff_si) - + end do ! site loop - + return end subroutine canopy_summarization - - ! ===================================================================================== - subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) - + ! ===================================================================================== + + subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) + ! ----------------------------------------------------------------------------------- ! This subroutine calculates how leaf and stem areas are distributed ! in vertical and horizontal space. @@ -1448,7 +1448,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) ! !USES: use EDtypesMod , only : area, dinc_ed, hitemax, n_hite_bins - + ! ! !ARGUMENTS type(ed_site_type) , intent(inout) :: currentSite @@ -1478,7 +1478,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) real(r8) :: lai ! summed lai for checking m2 m-2 real(r8) :: snow_depth_avg ! avg snow over whole site real(r8) :: leaf_c ! leaf carbon [kg] - + !---------------------------------------------------------------------- @@ -1489,7 +1489,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) ! We assume that each point in the canopy recieved the light attenuated by the average ! leaf area index above it, irrespective of PFT identity... ! Each leaf is defined by how deep in the canopy it is, in terms of LAI units. (FIX(RF,032414), GB) - + currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) @@ -1514,166 +1514,166 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) ! It is remotely possible that in deserts we will not have any canopy ! area, ie not plants at all... ! ------------------------------------------------------------------------------ - + if (currentPatch%total_canopy_area > nearzero ) then - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) - ft = currentCohort%pft - cl = currentCohort%canopy_layer + ft = currentCohort%pft + cl = currentCohort%canopy_layer - ! Calculate LAI of layers above - ! Note that the canopy_layer_lai is also calculated in this loop - ! but since we go top down in terms of plant size, we should be okay + ! Calculate LAI of layers above + ! Note that the canopy_layer_lai is also calculated in this loop + ! but since we go top down in terms of plant size, we should be okay - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & - currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & + currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) - currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & - currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai, currentCohort%treelai , & - currentCohort%vcmax25top,4) + currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & + currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai, currentCohort%treelai , & + currentCohort%vcmax25top,4) - currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area - currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area + currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area + currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area - ! Number of actual vegetation layers in this cohort's crown - currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) + ! Number of actual vegetation layers in this cohort's crown + currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) - currentPatch%ncan(cl,ft) = max(currentPatch%ncan(cl,ft),currentCohort%NV) + currentPatch%ncan(cl,ft) = max(currentPatch%ncan(cl,ft),currentCohort%NV) - patch_lai = patch_lai + currentCohort%lai + patch_lai = patch_lai + currentCohort%lai - currentPatch%canopy_layer_tlai(cl) = currentPatch%canopy_layer_tlai(cl) + currentCohort%lai + currentPatch%canopy_layer_tlai(cl) = currentPatch%canopy_layer_tlai(cl) + currentCohort%lai - currentCohort => currentCohort%shorter - - enddo !currentCohort + currentCohort => currentCohort%shorter - if(smooth_leaf_distribution == 1)then + enddo !currentCohort - ! ----------------------------------------------------------------------------- - ! we are going to ignore the concept of canopy layers, and put all of the leaf - ! area into height banded bins. using the same domains as we had before, except - ! that CL always = 1 - ! ----------------------------------------------------------------------------- - - ! this is a crude way of dividing up the bins. Should it be a function of actual maximum height? - dh = 1.0_r8*(HITEMAX/N_HITE_BINS) - do iv = 1,N_HITE_BINS - if (iv == 1) then - minh(iv) = 0.0_r8 - maxh(iv) = dh - else - minh(iv) = (iv-1)*dh - maxh(iv) = (iv)*dh - endif - enddo - - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - ft = currentCohort%pft - min_chite = currentCohort%hite - currentCohort%hite * EDPftvarcon_inst%crown(ft) - max_chite = currentCohort%hite + if(smooth_leaf_distribution == 1)then + + ! ----------------------------------------------------------------------------- + ! we are going to ignore the concept of canopy layers, and put all of the leaf + ! area into height banded bins. using the same domains as we had before, except + ! that CL always = 1 + ! ----------------------------------------------------------------------------- + + ! this is a crude way of dividing up the bins. Should it be a function of actual maximum height? + dh = 1.0_r8*(HITEMAX/N_HITE_BINS) do iv = 1,N_HITE_BINS - frac_canopy(iv) = 0.0_r8 - ! this layer is in the middle of the canopy - if(max_chite > maxh(iv).and.min_chite < minh(iv))then - frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*EDPftvarcon_inst%crown(ft))) - ! this is the layer with the bottom of the canopy in it. - elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then - frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) - ! this is the layer with the top of the canopy in it. - elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then - frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) - elseif(max_chite < maxh(iv).and.min_chite > minh(iv))then !the whole cohort is within this layer. - frac_canopy(iv) = 1.0_r8 - endif - - ! no m2 of leaf per m2 of ground in each height class - currentPatch%tlai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) + frac_canopy(iv) * & - currentCohort%lai - currentPatch%tsai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) + frac_canopy(iv) * & - currentCohort%sai - - !snow burial - !write(fates_log(), *) 'calc snow' - snow_depth_avg = snow_depth_si * frac_sno_eff_si - if(snow_depth_avg > maxh(iv))then - fraction_exposed = 0._r8 - endif - if(snow_depth_avg < minh(iv))then - fraction_exposed = 1._r8 - endif - if(snow_depth_avg>= minh(iv).and.snow_depth_avg <= maxh(iv))then !only partly hidden... - fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_avg-minh(iv))/dh))) + if (iv == 1) then + minh(iv) = 0.0_r8 + maxh(iv) = dh + else + minh(iv) = (iv-1)*dh + maxh(iv) = (iv)*dh endif - fraction_exposed = 1.0_r8 - ! no m2 of leaf per m2 of ground in each height class - ! FIX(SPM,032414) these should be uncommented this and double check - - if ( debug ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) - - currentPatch%elai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) * fraction_exposed - currentPatch%esai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) * fraction_exposed - - if ( debug ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) - - enddo ! (iv) hite bins - - currentCohort => currentCohort%taller - - enddo !currentCohort - - ! ----------------------------------------------------------------------------- - ! Perform a leaf area conservation check on the LAI profile - lai = 0.0_r8 - do ft = 1,numpft - lai = lai+ sum(currentPatch%tlai_profile(1,ft,:)) - enddo - - if(lai > patch_lai)then - write(fates_log(), *) 'FATES: problem with lai assignments' - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - - - else ! smooth leaf distribution + enddo + + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + ft = currentCohort%pft + min_chite = currentCohort%hite - currentCohort%hite * EDPftvarcon_inst%crown(ft) + max_chite = currentCohort%hite + do iv = 1,N_HITE_BINS + frac_canopy(iv) = 0.0_r8 + ! this layer is in the middle of the canopy + if(max_chite > maxh(iv).and.min_chite < minh(iv))then + frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*EDPftvarcon_inst%crown(ft))) + ! this is the layer with the bottom of the canopy in it. + elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then + frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) + ! this is the layer with the top of the canopy in it. + elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then + frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) + elseif(max_chite < maxh(iv).and.min_chite > minh(iv))then !the whole cohort is within this layer. + frac_canopy(iv) = 1.0_r8 + endif + + ! no m2 of leaf per m2 of ground in each height class + currentPatch%tlai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) + frac_canopy(iv) * & + currentCohort%lai + currentPatch%tsai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) + frac_canopy(iv) * & + currentCohort%sai + + !snow burial + !write(fates_log(), *) 'calc snow' + snow_depth_avg = snow_depth_si * frac_sno_eff_si + if(snow_depth_avg > maxh(iv))then + fraction_exposed = 0._r8 + endif + if(snow_depth_avg < minh(iv))then + fraction_exposed = 1._r8 + endif + if(snow_depth_avg>= minh(iv).and.snow_depth_avg <= maxh(iv))then !only partly hidden... + fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_avg-minh(iv))/dh))) + endif + fraction_exposed = 1.0_r8 + ! no m2 of leaf per m2 of ground in each height class + ! FIX(SPM,032414) these should be uncommented this and double check + + if ( debug ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) + + currentPatch%elai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) * fraction_exposed + currentPatch%esai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) * fraction_exposed + + if ( debug ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) + + enddo ! (iv) hite bins + + currentCohort => currentCohort%taller + + enddo !currentCohort + + ! ----------------------------------------------------------------------------- + ! Perform a leaf area conservation check on the LAI profile + lai = 0.0_r8 + do ft = 1,numpft + lai = lai+ sum(currentPatch%tlai_profile(1,ft,:)) + enddo + + if(lai > patch_lai)then + write(fates_log(), *) 'FATES: problem with lai assignments' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + + else ! smooth leaf distribution + + ! ----------------------------------------------------------------------------- + ! Standard canopy layering model. + ! Go through all cohorts and add their leaf area + ! and canopy area to the accumulators. + ! ----------------------------------------------------------------------------- - ! ----------------------------------------------------------------------------- - ! Standard canopy layering model. - ! Go through all cohorts and add their leaf area - ! and canopy area to the accumulators. - ! ----------------------------------------------------------------------------- - currentCohort => currentPatch%shortest do while(associated(currentCohort)) ft = currentCohort%pft cl = currentCohort%canopy_layer - + ! ---------------------------------------------------------------- ! How much of each tree is stem area index? Assuming that there is ! This may indeed be zero if there is a sensecent grass ! ---------------------------------------------------------------- - + if( (currentCohort%treelai+currentCohort%treesai) > 0._r8)then fleaf = currentCohort%lai / (currentCohort%lai + currentCohort%sai) else fleaf = 0._r8 endif - + ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX ! SNOW BURIAL IS CURRENTLY TURNED OFF ! WHEN IT IS TURNED ON, IT WILL HAVE TO BE COMPARED ! WITH SNOW HEIGHTS CALCULATED BELOW. ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - + currentPatch%nrad(cl,ft) = currentPatch%ncan(cl,ft) if (currentPatch%nrad(cl,ft) > nlevleaf ) then @@ -1691,22 +1691,22 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) ! Whole layers. Make a weighted average of the leaf area in each layer ! before dividing it by the total area. Fill up layer for whole layers. ! -------------------------------------------------------------------------- - + do iv = 1,currentCohort%NV - + ! This loop builds the arrays that define the effective (not snow covered) ! and total (includes snow covered) area indices for leaves and stems ! We calculate the absolute elevation of each layer to help determine if the layer ! is obscured by snow. - + layer_top_hite = currentCohort%hite - & - ( real(iv-1,r8)/currentCohort%NV * currentCohort%hite * & - EDPftvarcon_inst%crown(currentCohort%pft) ) - + ( real(iv-1,r8)/currentCohort%NV * currentCohort%hite * & + EDPftvarcon_inst%crown(currentCohort%pft) ) + layer_bottom_hite = currentCohort%hite - & - ( real(iv,r8)/currentCohort%NV * currentCohort%hite * & - EDPftvarcon_inst%crown(currentCohort%pft) ) - + ( real(iv,r8)/currentCohort%NV * currentCohort%hite * & + EDPftvarcon_inst%crown(currentCohort%pft) ) + fraction_exposed = 1.0_r8 snow_depth_avg = snow_depth_si * frac_sno_eff_si if(snow_depth_avg > layer_top_hite)then @@ -1716,61 +1716,61 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) fraction_exposed = 1._r8 endif if( snow_depth_avg>= layer_bottom_hite .and. & - snow_depth_avg <= layer_top_hite) then !only partly hidden... + snow_depth_avg <= layer_top_hite) then !only partly hidden... fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_avg-layer_bottom_hite)/ & - (layer_top_hite-layer_bottom_hite )))) + (layer_top_hite-layer_bottom_hite )))) endif - + ! =========== OVER-WRITE ================= fraction_exposed= 1.0_r8 ! =========== OVER-WRITE ================= - + if(iv==currentCohort%NV) then remainder = (currentCohort%treelai + currentCohort%treesai) - & - (dinc_ed*real(currentCohort%nv-1,r8)) + (dinc_ed*real(currentCohort%nv-1,r8)) if(remainder > dinc_ed )then write(fates_log(), *)'ED: issue with remainder', & - currentCohort%treelai,currentCohort%treesai,dinc_ed, & - currentCohort%NV,remainder + currentCohort%treelai,currentCohort%treesai,dinc_ed, & + currentCohort%NV,remainder call endrun(msg=errMsg(sourcefile, __LINE__)) endif else remainder = dinc_ed end if - + currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) + & - remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area - + remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%elai_profile(cl,ft,iv) = currentPatch%elai_profile(cl,ft,iv) + & - remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & - fraction_exposed - + remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & + fraction_exposed + currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) + & - remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area - + remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%esai_profile(cl,ft,iv) = currentPatch%esai_profile(cl,ft,iv) + & - remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area * & - fraction_exposed - + remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area * & + fraction_exposed + currentPatch%canopy_area_profile(cl,ft,iv) = currentPatch%canopy_area_profile(cl,ft,iv) + & - currentCohort%c_area/currentPatch%total_canopy_area - + currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%layer_height_profile(cl,ft,iv) = currentPatch%layer_height_profile(cl,ft,iv) + & - (remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & - (layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. - + (remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & + (layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. + end do - + currentCohort => currentCohort%taller - + enddo !cohort - + ! -------------------------------------------------------------------------- - + ! If there is an upper-story, the top canopy layer ! should have a value of exactly 1.0 in its top leaf layer ! -------------------------------------------------------------------------- - + if ( (currentPatch%NCL_p > 1) .and. & (sum(currentPatch%canopy_area_profile(1,:,1)) < 0.9999 )) then write(fates_log(), *) 'FATES: canopy_area_profile was less than 1 at the canopy top' @@ -1789,9 +1789,9 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) currentCohort => currentCohort%taller enddo !currentCohort call endrun(msg=errMsg(sourcefile, __LINE__)) - + end if - + ! -------------------------------------------------------------------------- ! In the following loop we are now normalizing the effective and @@ -1806,57 +1806,57 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) do cl = 1,currentPatch%NCL_p do iv = 1,currentPatch%ncan(cl,ft) - + if( debug .and. sum(currentPatch%canopy_area_profile(cl,:,iv)) > 1.0001_r8 ) then - + write(fates_log(), *) 'FATES: A canopy_area_profile exceeded 1.0' write(fates_log(), *) 'cl: ',cl write(fates_log(), *) 'iv: ',iv write(fates_log(), *) 'sum(cpatch%canopy_area_profile(cl,:,iv)): ', & - sum(currentPatch%canopy_area_profile(cl,:,iv)) - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - if(currentCohort%canopy_layer==cl)then - write(fates_log(), *) 'FATES: cohorts in layer cl = ',cl, & - currentCohort%dbh,currentCohort%c_area, & - currentPatch%total_canopy_area,currentPatch%area - write(fates_log(), *) 'ED: fracarea', currentCohort%pft, & - currentCohort%c_area/currentPatch%total_canopy_area - endif - currentCohort => currentCohort%taller - enddo !currentCohort - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end do - + sum(currentPatch%canopy_area_profile(cl,:,iv)) + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + if(currentCohort%canopy_layer==cl)then + write(fates_log(), *) 'FATES: cohorts in layer cl = ',cl, & + currentCohort%dbh,currentCohort%c_area, & + currentPatch%total_canopy_area,currentPatch%area + write(fates_log(), *) 'ED: fracarea', currentCohort%pft, & + currentCohort%c_area/currentPatch%total_canopy_area + endif + currentCohort => currentCohort%taller + enddo !currentCohort + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do + do ft = 1,numpft do iv = 1,currentPatch%ncan(cl,ft) if( currentPatch%canopy_area_profile(cl,ft,iv) > nearzero ) then - + currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) / & - currentPatch%canopy_area_profile(cl,ft,iv) - + currentPatch%canopy_area_profile(cl,ft,iv) + currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) / & - currentPatch%canopy_area_profile(cl,ft,iv) - + currentPatch%canopy_area_profile(cl,ft,iv) + currentPatch%elai_profile(cl,ft,iv) = currentPatch%elai_profile(cl,ft,iv) / & - currentPatch%canopy_area_profile(cl,ft,iv) - + currentPatch%canopy_area_profile(cl,ft,iv) + currentPatch%esai_profile(cl,ft,iv) = currentPatch%esai_profile(cl,ft,iv) / & - currentPatch%canopy_area_profile(cl,ft,iv) + currentPatch%canopy_area_profile(cl,ft,iv) end if - + if(currentPatch%tlai_profile(cl,ft,iv)>nearzero )then currentPatch%layer_height_profile(cl,ft,iv) = currentPatch%layer_height_profile(cl,ft,iv) & - /currentPatch%tlai_profile(cl,ft,iv) + /currentPatch%tlai_profile(cl,ft,iv) end if - + enddo - + enddo enddo - + ! -------------------------------------------------------------------------- ! Set the mask that identifies which PFT x can-layer combinations have ! scattering elements in them. @@ -1871,183 +1871,183 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) end do !iv enddo !ft enddo ! loop over cl - + endif !leaf distribution - + end if - + currentPatch => currentPatch%younger - + enddo !patch - + return - end subroutine leaf_area_profile + end subroutine leaf_area_profile - ! ====================================================================================== + ! ====================================================================================== subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) - ! ---------------------------------------------------------------------------------- - ! The purpose of this routine is to package output boundary conditions related - ! to vegetation coverage to the host land model. - ! ---------------------------------------------------------------------------------- - - use EDTypesMod , only : ed_patch_type, ed_cohort_type, & - ed_site_type, AREA - use FatesInterfaceTypesMod , only : bc_out_type - - ! - ! !ARGUMENTS - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) - integer, intent(in) :: fcolumn(nsites) - type(bc_out_type), intent(inout) :: bc_out(nsites) - - ! Locals - type (ed_cohort_type) , pointer :: currentCohort - integer :: s, ifp, c, p - type (ed_patch_type) , pointer :: currentPatch - real(r8) :: bare_frac_area - real(r8) :: total_patch_area - real(r8) :: total_canopy_area - real(r8) :: weight ! Weighting for cohort variables in patch - - - do s = 1,nsites - - ifp = 0 - total_patch_area = 0._r8 - total_canopy_area = 0._r8 - bc_out(s)%canopy_fraction_pa(:) = 0._r8 - currentPatch => sites(s)%oldest_patch - c = fcolumn(s) - do while(associated(currentPatch)) + ! ---------------------------------------------------------------------------------- + ! The purpose of this routine is to package output boundary conditions related + ! to vegetation coverage to the host land model. + ! ---------------------------------------------------------------------------------- + + use EDTypesMod , only : ed_patch_type, ed_cohort_type, & + ed_site_type, AREA + use FatesInterfaceTypesMod , only : bc_out_type + + ! + ! !ARGUMENTS + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + integer, intent(in) :: fcolumn(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + ! Locals + type (ed_cohort_type) , pointer :: currentCohort + integer :: s, ifp, c, p + type (ed_patch_type) , pointer :: currentPatch + real(r8) :: bare_frac_area + real(r8) :: total_patch_area + real(r8) :: total_canopy_area + real(r8) :: weight ! Weighting for cohort variables in patch + + + do s = 1,nsites + + ifp = 0 + total_patch_area = 0._r8 + total_canopy_area = 0._r8 + bc_out(s)%canopy_fraction_pa(:) = 0._r8 + currentPatch => sites(s)%oldest_patch + c = fcolumn(s) + do while(associated(currentPatch)) if(currentPatch%nocomp_pft_label.ne.0)then - ! only increase ifp for veg patches, not bareground (in SP mode) - ifp = ifp+1 - endif ! stay with ifp=0 for bareground patch. - if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then - write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area - currentPatch%total_canopy_area = currentPatch%area - endif - - - if (associated(currentPatch%tallest)) then - bc_out(s)%htop_pa(ifp) = currentPatch%tallest%hite - else - ! FIX(RF,040113) - should this be a parameter for the minimum possible vegetation height? - bc_out(s)%htop_pa(ifp) = 0.1_r8 - endif - - bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) - ! Use leaf area weighting for all cohorts in the patch to define the characteristic - ! leaf width used by the HLM - ! ---------------------------------------------------------------------------- -! bc_out(s)%dleaf_pa(ifp) = 0.0_r8 -! if(currentPatch%lai>1.0e-9_r8) then -! currentCohort => currentPatch%shortest -! do while(associated(currentCohort)) -! weight = min(1.0_r8,currentCohort%lai/currentPatch%lai) -! bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & -! EDPftvarcon_inst%dleaf(currentCohort%pft)*weight -! currentCohort => currentCohort%taller -! enddo -! end if - - ! Roughness length and displacement height are not PFT properties, they are - ! properties of the canopy assemblage. Defining this needs an appropriate model. - ! Right now z0 and d are pft level parameters. For the time being we will just - ! use the 1st index until a suitable model is defined. (RGK 04-2017) - ! ----------------------------------------------------------------------------- - bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(1) * bc_out(s)%htop_pa(ifp) - bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) - bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) - - ! We are assuming here that grass is all located underneath tree canopies. - ! The alternative is to assume it is all spatial distinct from tree canopies. - ! In which case, the bare area would have to be reduced by the grass area... - ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants - ! currentPatch%area/AREA is the fraction of the soil covered by this patch. - if(currentPatch%area.gt.0.0_r8)then - bc_out(s)%canopy_fraction_pa(ifp) = & - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) - else - bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 - endif - - bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & - (currentPatch%area/AREA) - - total_patch_area = total_patch_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area - - total_canopy_area = total_canopy_area + bc_out(s)%canopy_fraction_pa(ifp) - - bc_out(s)%nocomp_pft_label_pa(ifp) = currentPatch%nocomp_pft_label - - ! Calculate area indices for output boundary to HLM - ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles - ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) - - bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') - bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') - bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') - bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') - - ! Fraction of vegetation free of snow. This is used to flag those - ! patches which shall under-go photosynthesis - ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let - ! FATES internal variables decide if photosynthesis is possible - ! we are essentially calculating it inside FATES to tell the - ! host to tell itself when to do things (circuitous). Just have - ! to determine where else it is used - - if ((bc_out(s)%elai_pa(ifp) + bc_out(s)%esai_pa(ifp)) > 0._r8) then - bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 1.0_r8 - else - bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 0.0_r8 - end if - currentPatch => currentPatch%younger - end do - - - ! Apply patch and canopy area corrections - ! If the difference is above reasonable math precision, apply a fix - ! If the difference is way above reasonable math precision, gracefully exit - - if(abs(total_patch_area-1.0_r8) > rsnbl_math_prec ) then - - if(abs(total_patch_area-1.0_r8) > 1.0e-8_r8 )then - write(fates_log(),*) 'total area is wrong in update_hlm_dynamics',total_patch_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if(debug) then - write(fates_log(),*) 'imprecise patch areas in update_hlm_dynamics',total_patch_area - end if - - currentPatch => sites(s)%oldest_patch - ifp = 0 - do while(associated(currentPatch)) - if(currentPatch%nocomp_pft_label.ne.0)then ! for vegetated patches only - ifp = ifp+1 - bc_out(s)%canopy_fraction_pa(ifp) = bc_out(s)%canopy_fraction_pa(ifp)/total_patch_area + ! only increase ifp for veg patches, not bareground (in SP mode) + ifp = ifp+1 + endif ! stay with ifp=0 for bareground patch. + if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then + write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area + currentPatch%total_canopy_area = currentPatch%area + endif + + + if (associated(currentPatch%tallest)) then + bc_out(s)%htop_pa(ifp) = currentPatch%tallest%hite + else + ! FIX(RF,040113) - should this be a parameter for the minimum possible vegetation height? + bc_out(s)%htop_pa(ifp) = 0.1_r8 + endif + + bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) + ! Use leaf area weighting for all cohorts in the patch to define the characteristic + ! leaf width used by the HLM + ! ---------------------------------------------------------------------------- + ! bc_out(s)%dleaf_pa(ifp) = 0.0_r8 + ! if(currentPatch%lai>1.0e-9_r8) then + ! currentCohort => currentPatch%shortest + ! do while(associated(currentCohort)) + ! weight = min(1.0_r8,currentCohort%lai/currentPatch%lai) + ! bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & + ! EDPftvarcon_inst%dleaf(currentCohort%pft)*weight + ! currentCohort => currentCohort%taller + ! enddo + ! end if + + ! Roughness length and displacement height are not PFT properties, they are + ! properties of the canopy assemblage. Defining this needs an appropriate model. + ! Right now z0 and d are pft level parameters. For the time being we will just + ! use the 1st index until a suitable model is defined. (RGK 04-2017) + ! ----------------------------------------------------------------------------- + bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) + + ! We are assuming here that grass is all located underneath tree canopies. + ! The alternative is to assume it is all spatial distinct from tree canopies. + ! In which case, the bare area would have to be reduced by the grass area... + ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants + ! currentPatch%area/AREA is the fraction of the soil covered by this patch. + if(currentPatch%area.gt.0.0_r8)then + bc_out(s)%canopy_fraction_pa(ifp) = & + min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) + else + bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 + endif + + bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & + (currentPatch%area/AREA) + + total_patch_area = total_patch_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area + + total_canopy_area = total_canopy_area + bc_out(s)%canopy_fraction_pa(ifp) + + bc_out(s)%nocomp_pft_label_pa(ifp) = currentPatch%nocomp_pft_label + + ! Calculate area indices for output boundary to HLM + ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles + ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) + + bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') + bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') + bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') + bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') + + ! Fraction of vegetation free of snow. This is used to flag those + ! patches which shall under-go photosynthesis + ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let + ! FATES internal variables decide if photosynthesis is possible + ! we are essentially calculating it inside FATES to tell the + ! host to tell itself when to do things (circuitous). Just have + ! to determine where else it is used + + if ((bc_out(s)%elai_pa(ifp) + bc_out(s)%esai_pa(ifp)) > 0._r8) then + bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 1.0_r8 + else + bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 0.0_r8 + end if + currentPatch => currentPatch%younger + end do + + + ! Apply patch and canopy area corrections + ! If the difference is above reasonable math precision, apply a fix + ! If the difference is way above reasonable math precision, gracefully exit + + if(abs(total_patch_area-1.0_r8) > rsnbl_math_prec ) then + + if(abs(total_patch_area-1.0_r8) > 1.0e-8_r8 )then + write(fates_log(),*) 'total area is wrong in update_hlm_dynamics',total_patch_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(debug) then + write(fates_log(),*) 'imprecise patch areas in update_hlm_dynamics',total_patch_area + end if + + currentPatch => sites(s)%oldest_patch + ifp = 0 + do while(associated(currentPatch)) + if(currentPatch%nocomp_pft_label.ne.0)then ! for vegetated patches only + ifp = ifp+1 + bc_out(s)%canopy_fraction_pa(ifp) = bc_out(s)%canopy_fraction_pa(ifp)/total_patch_area else ! for the bareground patch (in SP mode). - bc_out(s)%canopy_fraction_pa(ifp) =0.0_r8 + bc_out(s)%canopy_fraction_pa(ifp) =0.0_r8 endif ! veg patch - currentPatch => currentPatch%younger - end do - - endif - - end do + currentPatch => currentPatch%younger + end do - ! If hydraulics is turned on, update the amount of water bound in vegetation - if (hlm_use_planthydro.eq.itrue) then - call RecruitWaterStorage(nsites,sites,bc_out) - call UpdateH2OVeg(nsites,sites,bc_out) - end if + endif + + end do + + ! If hydraulics is turned on, update the amount of water bound in vegetation + if (hlm_use_planthydro.eq.itrue) then + call RecruitWaterStorage(nsites,sites,bc_out) + call UpdateH2OVeg(nsites,sites,bc_out) + end if end subroutine update_hlm_dynamics @@ -2056,151 +2056,151 @@ end subroutine update_hlm_dynamics function calc_areaindex(cpatch,ai_type) result(ai) - ! ---------------------------------------------------------------------------------- - ! This subroutine calculates the exposed leaf area index of a patch - ! this is the square meters of leaf per square meter of ground area - ! It does so by integrating over the depth and functional type profile of leaf area - ! which are per area of crown. This value has to be scaled by crown area to convert - ! to ground area. - ! ---------------------------------------------------------------------------------- - - ! Arguments - type(ed_patch_type),intent(in), target :: cpatch - character(len=*),intent(in) :: ai_type - - integer :: cl,ft - real(r8) :: ai - ! TODO: THIS MIN LAI IS AN ARTIFACT FROM TESTING LONG-AGO AND SHOULD BE REMOVED - ! THIS HAS BEEN KEPT THUS FAR TO MAINTAIN B4B IN TESTING OTHER COMMITS - real(r8),parameter :: ai_min = 0.1_r8 - real(r8),pointer :: ai_profile - - ai = 0._r8 - if (trim(ai_type) == 'elai') then - do cl = 1,cpatch%NCL_p - do ft = 1,numpft - ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & - cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft))) - enddo - enddo - elseif (trim(ai_type) == 'tlai') then - do cl = 1,cpatch%NCL_p - do ft = 1,numpft - ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & - cpatch%tlai_profile(cl,ft,1:cpatch%nrad(cl,ft))) - enddo - enddo - - elseif (trim(ai_type) == 'esai') then - do cl = 1,cpatch%NCL_p - do ft = 1,numpft - ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & - cpatch%esai_profile(cl,ft,1:cpatch%nrad(cl,ft))) - enddo - enddo - elseif (trim(ai_type) == 'tsai') then - do cl = 1,cpatch%NCL_p - do ft = 1,numpft - ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & - cpatch%tsai_profile(cl,ft,1:cpatch%nrad(cl,ft))) - enddo - enddo - else - - write(fates_log(),*) 'Unsupported area index sent to calc_areaindex' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ai = max(ai_min,ai) - - return + ! ---------------------------------------------------------------------------------- + ! This subroutine calculates the exposed leaf area index of a patch + ! this is the square meters of leaf per square meter of ground area + ! It does so by integrating over the depth and functional type profile of leaf area + ! which are per area of crown. This value has to be scaled by crown area to convert + ! to ground area. + ! ---------------------------------------------------------------------------------- + + ! Arguments + type(ed_patch_type),intent(in), target :: cpatch + character(len=*),intent(in) :: ai_type + + integer :: cl,ft + real(r8) :: ai + ! TODO: THIS MIN LAI IS AN ARTIFACT FROM TESTING LONG-AGO AND SHOULD BE REMOVED + ! THIS HAS BEEN KEPT THUS FAR TO MAINTAIN B4B IN TESTING OTHER COMMITS + real(r8),parameter :: ai_min = 0.1_r8 + real(r8),pointer :: ai_profile + + ai = 0._r8 + if (trim(ai_type) == 'elai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + elseif (trim(ai_type) == 'tlai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%tlai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + + elseif (trim(ai_type) == 'esai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%esai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + elseif (trim(ai_type) == 'tsai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%tsai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + else + + write(fates_log(),*) 'Unsupported area index sent to calc_areaindex' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ai = max(ai_min,ai) + + return end function calc_areaindex ! =============================================================================================== - + subroutine CanopyLayerArea(currentPatch,site_spread,layer_index,layer_area) - - ! -------------------------------------------------------------------------------------------- - ! This function calculates the total crown area footprint for a desired layer of the canopy - ! within a patch. - ! The return units are the same as patch%area, which is m2 - ! --------------------------------------------------------------------------------------------- - - ! Arguments - type(ed_patch_type),intent(inout), target :: currentPatch - real(r8),intent(in) :: site_spread - integer,intent(in) :: layer_index - real(r8),intent(inout) :: layer_area - - type(ed_cohort_type), pointer :: currentCohort - - - layer_area = 0.0_r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - call carea_allom(currentCohort%dbh,currentCohort%n,site_spread, & - currentCohort%pft,currentCohort%c_area) - if (currentCohort%canopy_layer .eq. layer_index) then - layer_area = layer_area + currentCohort%c_area - end if - currentCohort => currentCohort%shorter - enddo - return + + ! -------------------------------------------------------------------------------------------- + ! This function calculates the total crown area footprint for a desired layer of the canopy + ! within a patch. + ! The return units are the same as patch%area, which is m2 + ! --------------------------------------------------------------------------------------------- + + ! Arguments + type(ed_patch_type),intent(inout), target :: currentPatch + real(r8),intent(in) :: site_spread + integer,intent(in) :: layer_index + real(r8),intent(inout) :: layer_area + + type(ed_cohort_type), pointer :: currentCohort + + + layer_area = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + call carea_allom(currentCohort%dbh,currentCohort%n,site_spread, & + currentCohort%pft,currentCohort%c_area) + if (currentCohort%canopy_layer .eq. layer_index) then + layer_area = layer_area + currentCohort%c_area + end if + currentCohort => currentCohort%shorter + enddo + return end subroutine CanopyLayerArea ! =============================================================================================== - + function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) result(z) - ! -------------------------------------------------------------------------------------------- - ! Calculate the number of canopy layers in this patch. - ! This simple call only determines total layering by querying the cohorts - ! which layer they are in, it doesn't do any size evaluation. - ! It may also, optionally, account for the temporary "substory", which is the imaginary - ! layer below the understory which will be needed to temporarily accomodate demotions from - ! the understory in the event the understory has reached maximum allowable area. - ! -------------------------------------------------------------------------------------------- - - type(ed_patch_type),target :: currentPatch - real(r8),intent(in) :: site_spread - logical :: include_substory - - type(ed_cohort_type),pointer :: currentCohort - - integer :: z - real(r8) :: c_area - real(r8) :: arealayer - - z = 1 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - z = max(z,currentCohort%canopy_layer) - currentCohort => currentCohort%shorter - enddo - - if(include_substory)then - arealayer = 0.0 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == z) then - call carea_allom(currentCohort%dbh,currentCohort%n,site_spread,currentCohort%pft,c_area) - arealayer = arealayer + c_area - end if - currentCohort => currentCohort%shorter - enddo - - ! Does the bottom layer have more than a full canopy? - ! If so we need to make another layer. - if(arealayer > currentPatch%area)then - z = z + 1 - if(hlm_use_sp)then - write(fates_log(),*) 'SPmode, canopy_layer full:',arealayer,currentPatch%area - end if - - endif - end if - + ! -------------------------------------------------------------------------------------------- + ! Calculate the number of canopy layers in this patch. + ! This simple call only determines total layering by querying the cohorts + ! which layer they are in, it doesn't do any size evaluation. + ! It may also, optionally, account for the temporary "substory", which is the imaginary + ! layer below the understory which will be needed to temporarily accomodate demotions from + ! the understory in the event the understory has reached maximum allowable area. + ! -------------------------------------------------------------------------------------------- + + type(ed_patch_type),target :: currentPatch + real(r8),intent(in) :: site_spread + logical :: include_substory + + type(ed_cohort_type),pointer :: currentCohort + + integer :: z + real(r8) :: c_area + real(r8) :: arealayer + + z = 1 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + z = max(z,currentCohort%canopy_layer) + currentCohort => currentCohort%shorter + enddo + + if(include_substory)then + arealayer = 0.0 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == z) then + call carea_allom(currentCohort%dbh,currentCohort%n,site_spread,currentCohort%pft,c_area) + arealayer = arealayer + c_area + end if + currentCohort => currentCohort%shorter + enddo + + ! Does the bottom layer have more than a full canopy? + ! If so we need to make another layer. + if(arealayer > currentPatch%area)then + z = z + 1 + if(hlm_use_sp)then + write(fates_log(),*) 'SPmode, canopy_layer full:',arealayer,currentPatch%area + end if + + endif + end if + end function NumPotentialCanopyLayers end module EDCanopyStructureMod From 627b962d487bb08bf08ba1988626985c33943c46 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 08:22:20 -0700 Subject: [PATCH 165/578] indenting all of EDInit --- main/EDInitMod.F90 | 887 ++++++++++++++++++++++----------------------- 1 file changed, 443 insertions(+), 444 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 1a4ebf89b5..ffe56889bc 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -84,7 +84,7 @@ module EDInitMod logical :: debug = .false. character(len=*), parameter, private :: sourcefile = & - __FILE__ + __FILE__ public :: zero_site public :: init_site_vars @@ -125,7 +125,7 @@ subroutine init_site_vars( site_in, bc_in ) allocate(site_in%growthflux_fusion(1:nlevsclass,1:numpft)) allocate(site_in%mass_balance(1:num_elements)) allocate(site_in%flux_diags(1:num_elements)) - + site_in%nlevsoil = bc_in%nlevsoil allocate(site_in%rootfrac_scr(site_in%nlevsoil)) allocate(site_in%zi_soil(0:site_in%nlevsoil)) @@ -141,25 +141,25 @@ subroutine init_site_vars( site_in, bc_in ) allocate(site_in%sp_htop(1:numpft)) do el=1,num_elements - allocate(site_in%flux_diags(el)%leaf_litter_input(1:numpft)) - allocate(site_in%flux_diags(el)%root_litter_input(1:numpft)) - allocate(site_in%flux_diags(el)%nutrient_efflux_scpf(nlevsclass*numpft)) - allocate(site_in%flux_diags(el)%nutrient_uptake_scpf(nlevsclass*numpft)) - allocate(site_in%flux_diags(el)%nutrient_needgrow_scpf(nlevsclass*numpft)) - allocate(site_in%flux_diags(el)%nutrient_needmax_scpf(nlevsclass*numpft)) + allocate(site_in%flux_diags(el)%leaf_litter_input(1:numpft)) + allocate(site_in%flux_diags(el)%root_litter_input(1:numpft)) + allocate(site_in%flux_diags(el)%nutrient_efflux_scpf(nlevsclass*numpft)) + allocate(site_in%flux_diags(el)%nutrient_uptake_scpf(nlevsclass*numpft)) + allocate(site_in%flux_diags(el)%nutrient_needgrow_scpf(nlevsclass*numpft)) + allocate(site_in%flux_diags(el)%nutrient_needmax_scpf(nlevsclass*numpft)) end do ! Initialize the static soil ! arrays from the boundary (initial) condition - + site_in%zi_soil(:) = bc_in%zi_sisl(:) site_in%dz_soil(:) = bc_in%dz_sisl(:) site_in%z_soil(:) = bc_in%z_sisl(:) - + ! - end subroutine init_site_vars + end subroutine init_site_vars ! ============================================================================ subroutine zero_site( site_in ) @@ -178,7 +178,7 @@ subroutine zero_site( site_in ) site_in%oldest_patch => null() ! pointer to oldest patch at the site site_in%youngest_patch => null() ! pointer to yngest patch at the site - + ! PHENOLOGY @@ -206,7 +206,7 @@ subroutine zero_site( site_in ) call site_in%mass_balance(el)%ZeroMassBalFlux() call site_in%flux_diags(el)%ZeroFluxDiags() end do - + ! termination and recruitment info site_in%term_nindivs_canopy(:,:) = 0._r8 @@ -231,7 +231,7 @@ subroutine zero_site( site_in ) site_in%demotion_carbonflux = 0._r8 site_in%promotion_rate(:) = 0._r8 site_in%promotion_carbonflux = 0._r8 - + ! Resources management (logging/harvesting, etc) site_in%resources_management%trunk_product_site = 0.0_r8 @@ -293,95 +293,94 @@ subroutine set_site_properties( nsites, sites,bc_in ) do s = 1,nsites sites(s)%nchilldays = 0 sites(s)%ncolddays = 0 ! recalculated in phenology - ! immediately, so yes this - ! is memory-less, but needed - ! for first value in history file + ! immediately, so yes this + ! is memory-less, but needed + ! for first value in history file sites(s)%cleafondate = cleafon sites(s)%cleafoffdate = cleafoff sites(s)%dleafoffdate = dleafoff sites(s)%dleafondate = dleafon sites(s)%grow_deg_days = GDD - + sites(s)%water_memory(1:numWaterMem) = watermem sites(s)%vegtemp_memory(1:num_vegtemp_mem) = 0._r8 - + sites(s)%cstatus = cstat sites(s)%dstatus = dstat - + sites(s)%acc_NI = acc_NI sites(s)%NF = 0.0_r8 sites(s)%frac_burnt = 0.0_r8 - + if(hlm_use_fixed_biogeog.eq.itrue)then - ! MAPPING OF FATES PFTs on to HLM_PFTs - ! add up the area associated with each FATES PFT - ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) - ! hlm_pft_map is the area of that land in each FATES PFT (from param file) - - sites(s)%area_pft(1:numpft) = 0._r8 - do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) - do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts - sites(s)%area_pft(fates_pft) = sites(s)%area_pft(fates_pft) + & - EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) - end do - end do !hlm_pft - - sumarea = sum(sites(s)%area_pft(1:numpft)) - do ft = 1,numpft - if(sites(s)%area_pft(ft).lt.0.01_r8.and.sites(s)%area_pft(ft).gt.0.0_r8)then - write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) - sites(s)%area_pft(ft)=0.0_r8 - ! remove tiny patches to prevent numerical errors in terminate patches + ! MAPPING OF FATES PFTs on to HLM_PFTs + ! add up the area associated with each FATES PFT + ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) + ! hlm_pft_map is the area of that land in each FATES PFT (from param file) + + sites(s)%area_pft(1:numpft) = 0._r8 + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts + sites(s)%area_pft(fates_pft) = sites(s)%area_pft(fates_pft) + & + EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) + end do + end do !hlm_pft + + do ft = 1,numpft + if(sites(s)%area_pft(ft).lt.0.01_r8.and.sites(s)%area_pft(ft).gt.0.0_r8)then + write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) + sites(s)%area_pft(ft)=0.0_r8 + ! remove tiny patches to prevent numerical errors in terminate patches endif - if(sites(s)%area_pft(ft).lt.0._r8)then - write(fates_log(),*) 'negative area',s,ft,sites(s)%area_pft(ft) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - sites(s)%area_pft(ft)= sites(s)%area_pft(ft) * AREA ! rescale units to m2. - end do - - ! re-normalize PFT area to ensure it sums to one. - ! note that in areas of 'bare ground' (PFT 0 in CLM/ELM) - ! the bare ground will no longer be proscribed and should emerge from FATES - ! this may or may not be the right way to deal with this? - - if(hlm_use_sp.eq.ifalse)then ! when not in SP mode, subsume bare ground evenly into the existing patches. - !n.b. that it might be better if nocomp mode used the same bare groud logic as SP mode. - sumarea = sum(sites(s)%area_pft(1:numpft)) - do ft = 1,numpft - if(sumarea.gt.0._r8)then - sites(s)%area_pft(ft) = area * sites(s)%area_pft(ft)/sumarea - else - sites(s)%area_pft(ft) = area/numpft - ! in nocomp mode where there is only bare ground, we assign equal area to - ! all pfts and let the model figure out whether land should be bare or not. + if(sites(s)%area_pft(ft).lt.0._r8)then + write(fates_log(),*) 'negative area',s,ft,sites(s)%area_pft(ft) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if - end do !ft - else ! for sp mode, assert a bare ground patch + sites(s)%area_pft(ft)= sites(s)%area_pft(ft) * AREA ! rescale units to m2. + end do + + ! re-normalize PFT area to ensure it sums to one. + ! note that in areas of 'bare ground' (PFT 0 in CLM/ELM) + ! the bare ground will no longer be proscribed and should emerge from FATES + ! this may or may not be the right way to deal with this? + + if(hlm_use_sp.eq.ifalse)then ! when not in SP mode, subsume bare ground evenly into the existing patches. + !n.b. that it might be better if nocomp mode used the same bare groud logic as SP mode. + sumarea = sum(sites(s)%area_pft(1:numpft)) + do ft = 1,numpft + if(sumarea.gt.0._r8)then + sites(s)%area_pft(ft) = area * sites(s)%area_pft(ft)/sumarea + else + sites(s)%area_pft(ft) = area/numpft + ! in nocomp mode where there is only bare ground, we assign equal area to + ! all pfts and let the model figure out whether land should be bare or not. + end if + end do !ft + else ! for sp mode, assert a bare ground patch sumarea = sum(sites(s)%area_pft(1:numpft)) if(sumarea.lt.area)then !make some bare ground - sites(s)%area_bareground = area - sumarea + sites(s)%area_bareground = area - sumarea else - sites(s)%area_bareground = 0.0_r8 + sites(s)%area_bareground = 0.0_r8 end if - end if !sp mode - end if !fixed biogeog - - do ft = 1,numpft - sites(s)%use_this_pft(ft) = itrue - if(hlm_use_fixed_biogeog.eq.itrue)then - if(sites(s)%area_pft(ft).gt.0.0_r8)then - sites(s)%use_this_pft(ft) = itrue - else - sites(s)%use_this_pft(ft) = ifalse - end if !area - end if !SBG - end do !ft + end if !sp mode + end if !fixed biogeog + + do ft = 1,numpft + sites(s)%use_this_pft(ft) = itrue + if(hlm_use_fixed_biogeog.eq.itrue)then + if(sites(s)%area_pft(ft).gt.0.0_r8)then + sites(s)%use_this_pft(ft) = itrue + else + sites(s)%use_this_pft(ft) = ifalse + end if !area + end if !SBG + end do !ft end do !site loop - end if !restart + end if !restart return end subroutine set_site_properties @@ -389,226 +388,226 @@ end subroutine set_site_properties ! ============================================================================ subroutine init_patches( nsites, sites, bc_in) - ! - ! !DESCRIPTION: - ! initialize patches - ! This may be call a near bare ground initialization, or it may - ! load patches from an inventory. - - ! - - - use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydProps - use FatesInventoryInitMod, only : initialize_sites_by_inventory - - ! - ! !ARGUMENTS - integer, intent(in) :: nsites - type(ed_site_type) , intent(inout), target :: sites(nsites) - type(bc_in_type), intent(in) :: bc_in(nsites) - ! - ! !LOCAL VARIABLES: - integer :: s - integer :: el - real(r8) :: age !notional age of this patch - - ! dummy locals - real(r8) :: biomass_stock - real(r8) :: litter_stock - real(r8) :: seed_stock - integer :: n - integer :: start_patch - integer :: num_new_patches - integer :: nocomp_pft - real(r8) :: newparea - real(r8) :: tota !check on area - integer :: is_first_patch - - type(ed_site_type), pointer :: sitep - type(ed_patch_type), pointer :: newppft(:) - type(ed_patch_type), pointer :: newp - type(ed_patch_type), pointer :: recall_older_patch - - ! List out some nominal patch values that are used for Near Bear Ground initializations - ! as well as initializing inventory - age = 0.0_r8 - ! --------------------------------------------------------------------------------------------- - - ! --------------------------------------------------------------------------------------------- - ! Two primary options, either a Near Bear Ground (NBG) or Inventory based cold-start - ! --------------------------------------------------------------------------------------------- - - if ( hlm_use_inventory_init.eq.itrue ) then - - ! Initialize the site-level crown area spread factor (0-1) - ! It is likely that closed canopy forest inventories - ! have smaller spread factors than bare ground (they are crowded) - do s = 1, nsites - sites(s)%spread = init_spread_inventory - enddo - - call initialize_sites_by_inventory(nsites,sites,bc_in) - - - ! For carbon balance checks, we need to initialize the - ! total carbon stock - do s = 1, nsites - do el=1,num_elements - call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & - biomass_stock,litter_stock,seed_stock) - end do - enddo - - else - - allocate(recall_older_patch) - do s = 1, nsites + ! + ! !DESCRIPTION: + ! initialize patches + ! This may be call a near bare ground initialization, or it may + ! load patches from an inventory. + + ! + + + use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydProps + use FatesInventoryInitMod, only : initialize_sites_by_inventory + + ! + ! !ARGUMENTS + integer, intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type), intent(in) :: bc_in(nsites) + ! + ! !LOCAL VARIABLES: + integer :: s + integer :: el + real(r8) :: age !notional age of this patch + + ! dummy locals + real(r8) :: biomass_stock + real(r8) :: litter_stock + real(r8) :: seed_stock + integer :: n + integer :: start_patch + integer :: num_new_patches + integer :: nocomp_pft + real(r8) :: newparea + real(r8) :: tota !check on area + integer :: is_first_patch + + type(ed_site_type), pointer :: sitep + type(ed_patch_type), pointer :: newppft(:) + type(ed_patch_type), pointer :: newp + type(ed_patch_type), pointer :: recall_older_patch + + ! List out some nominal patch values that are used for Near Bear Ground initializations + ! as well as initializing inventory + age = 0.0_r8 + ! --------------------------------------------------------------------------------------------- + + ! --------------------------------------------------------------------------------------------- + ! Two primary options, either a Near Bear Ground (NBG) or Inventory based cold-start + ! --------------------------------------------------------------------------------------------- + + if ( hlm_use_inventory_init.eq.itrue ) then + + ! Initialize the site-level crown area spread factor (0-1) + ! It is likely that closed canopy forest inventories + ! have smaller spread factors than bare ground (they are crowded) + do s = 1, nsites + sites(s)%spread = init_spread_inventory + enddo + + call initialize_sites_by_inventory(nsites,sites,bc_in) + + + ! For carbon balance checks, we need to initialize the + ! total carbon stock + do s = 1, nsites + do el=1,num_elements + call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & + biomass_stock,litter_stock,seed_stock) + end do + enddo + + else + + allocate(recall_older_patch) + do s = 1, nsites sites(s)%sp_tlai(:) = 0._r8 sites(s)%sp_tsai(:) = 0._r8 sites(s)%sp_htop(:) = 0._r8 - ! Initialize the site-level crown area spread factor (0-1) - ! It is likely that closed canopy forest inventories - ! have smaller spread factors than bare ground (they are crowded) - sites(s)%spread = init_spread_near_bare_ground + ! Initialize the site-level crown area spread factor (0-1) + ! It is likely that closed canopy forest inventories + ! have smaller spread factors than bare ground (they are crowded) + sites(s)%spread = init_spread_near_bare_ground start_patch = 1 ! start at the first vegetated patch if(hlm_use_nocomp.eq.itrue)then - num_new_patches = numpft - if(hlm_use_sp.eq.itrue)then - num_new_patches = numpft + 1 ! bare ground patch in SP mode. - start_patch = 0 ! start at the bare ground patch - endif -! allocate(newppft(numpft)) + num_new_patches = numpft + if(hlm_use_sp.eq.itrue)then + num_new_patches = numpft + 1 ! bare ground patch in SP mode. + start_patch = 0 ! start at the bare ground patch + endif + ! allocate(newppft(numpft)) else !default - num_new_patches = 1 - newparea = area + num_new_patches = 1 + newparea = area end if !nocomp - is_first_patch = itrue + is_first_patch = itrue do n = start_patch, num_new_patches - ! set the PFT index for patches if in nocomp mode. - if(hlm_use_nocomp.eq.itrue)then - nocomp_pft = n - else - nocomp_pft = fates_unset_int - end if - - if(hlm_use_nocomp.eq.itrue)then - ! In no competition mode, if we are using the fixed_biogeog filter - ! then each PFT has the area dictated by the surface dataset. - ! If not, each PFT gets the same area. - if(hlm_use_fixed_biogeog.eq.itrue)then - newparea = sites(s)%area_pft(nocomp_pft) - else - newparea = area / numpft - end if - else ! The default case is initialized w/ one patch with the area of the whole site. - newparea = area - end if !nocomp mode - - if(hlm_use_sp.eq.itrue.and.n.eq.0)then ! bare ground patch - newparea = sites(s)%area_bareground - nocomp_pft = 0 - end if - - if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode - allocate(newp) - - call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) - - if(is_first_patch.eq.itrue)then !is this the first patch? - ! set poointers for first patch (or only patch, if nocomp is false) - newp%patchno = 1 - newp%younger => null() - newp%older => null() - sites(s)%youngest_patch => newp - sites(s)%oldest_patch => newp - is_first_patch = ifalse - else ! the new patch is the 'oldest' one, arbitrarily. - ! Set pointers for N>1 patches. Note this only happens when nocomp mode s on. - ! The new patch is the 'youngest' one, arbitrarily. - newp%patchno = nocomp_pft - newp%older => recall_older_patch - newp%younger => null() - recall_older_patch%younger => newp - sites(s)%youngest_patch => newp - end if - recall_older_patch => newp ! remember this patch for the next one to point at. - - ! Initialize the litter pools to zero, these - ! pools will be populated by looping over the existing patches - ! and transfering in mass - do el=1,num_elements - call newp%litter(el)%InitConditions(init_leaf_fines=0._r8, & - init_root_fines=0._r8, & - init_ag_cwd=0._r8, & - init_bg_cwd=0._r8, & - init_seed=0._r8, & - init_seed_germ=0._r8) - end do + ! set the PFT index for patches if in nocomp mode. + if(hlm_use_nocomp.eq.itrue)then + nocomp_pft = n + else + nocomp_pft = fates_unset_int + end if - sitep => sites(s) - if(hlm_use_sp.eq.itrue)then - if(nocomp_pft.ne.0)then !don't initialize cohorts for SP bare ground patch - call init_cohorts(sitep, newp, bc_in(s)) + if(hlm_use_nocomp.eq.itrue)then + ! In no competition mode, if we are using the fixed_biogeog filter + ! then each PFT has the area dictated by the surface dataset. + ! If not, each PFT gets the same area. + if(hlm_use_fixed_biogeog.eq.itrue)then + newparea = sites(s)%area_pft(nocomp_pft) + else + newparea = area / numpft end if - else ! normal non SP case always call init cohorts - call init_cohorts(sitep, newp, bc_in(s)) - end if - end if - end do !no new patches - - !check if the total area adds to the same as site area - tota = 0.0_r8 - newp => sites(s)%oldest_patch - do while (associated(newp)) - tota=tota+newp%area - newp=>newp%younger - end do - - if(abs(tota-area).gt.nearzero*area)then - if(abs(tota-area).lt.1.0e-10_r8)then ! this is a precision error - if(sites(s)%oldest_patch%area.gt.(tota-area+nearzero))then - ! remove or add extra area - ! if the oldest patch has enough area, use that - sites(s)%oldest_patch%area = sites(s)%oldest_patch%area - (tota-area) - write(*,*) 'fixing patch precision - oldest',s, tota-area - else ! or otherwise take the area from the youngest patch. - sites(s)%youngest_patch%area = sites(s)%oldest_patch%area - (tota-area) - write(*,*) 'fixing patch precision -youngest ',s, tota-area - endif - else !this is a big error not just a precision error. - write(*,*) 'issue with patch area in EDinit',tota-area,tota - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif ! big error - end if ! too much patch area + else ! The default case is initialized w/ one patch with the area of the whole site. + newparea = area + end if !nocomp mode + + if(hlm_use_sp.eq.itrue.and.n.eq.0)then ! bare ground patch + newparea = sites(s)%area_bareground + nocomp_pft = 0 + end if + + if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode + allocate(newp) + + call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) + + if(is_first_patch.eq.itrue)then !is this the first patch? + ! set poointers for first patch (or only patch, if nocomp is false) + newp%patchno = 1 + newp%younger => null() + newp%older => null() + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp + is_first_patch = ifalse + else ! the new patch is the 'oldest' one, arbitrarily. + ! Set pointers for N>1 patches. Note this only happens when nocomp mode s on. + ! The new patch is the 'youngest' one, arbitrarily. + newp%patchno = nocomp_pft + newp%older => recall_older_patch + newp%younger => null() + recall_older_patch%younger => newp + sites(s)%youngest_patch => newp + end if + recall_older_patch => newp ! remember this patch for the next one to point at. + + ! Initialize the litter pools to zero, these + ! pools will be populated by looping over the existing patches + ! and transfering in mass + do el=1,num_elements + call newp%litter(el)%InitConditions(init_leaf_fines=0._r8, & + init_root_fines=0._r8, & + init_ag_cwd=0._r8, & + init_bg_cwd=0._r8, & + init_seed=0._r8, & + init_seed_germ=0._r8) + end do + + sitep => sites(s) + if(hlm_use_sp.eq.itrue)then + if(nocomp_pft.ne.0)then !don't initialize cohorts for SP bare ground patch + call init_cohorts(sitep, newp, bc_in(s)) + end if + else ! normal non SP case always call init cohorts + call init_cohorts(sitep, newp, bc_in(s)) + end if + end if + end do !no new patches + + !check if the total area adds to the same as site area + tota = 0.0_r8 + newp => sites(s)%oldest_patch + do while (associated(newp)) + tota=tota+newp%area + newp=>newp%younger + end do + + if(abs(tota-area).gt.nearzero*area)then + if(abs(tota-area).lt.1.0e-10_r8)then ! this is a precision error + if(sites(s)%oldest_patch%area.gt.(tota-area+nearzero))then + ! remove or add extra area + ! if the oldest patch has enough area, use that + sites(s)%oldest_patch%area = sites(s)%oldest_patch%area - (tota-area) + write(*,*) 'fixing patch precision - oldest',s, tota-area + else ! or otherwise take the area from the youngest patch. + sites(s)%youngest_patch%area = sites(s)%oldest_patch%area - (tota-area) + write(*,*) 'fixing patch precision -youngest ',s, tota-area + endif + else !this is a big error not just a precision error. + write(*,*) 'issue with patch area in EDinit',tota-area,tota + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif ! big error + end if ! too much patch area ! For carbon balance checks, we need to initialize the ! total carbon stock do el=1,num_elements call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & - biomass_stock,litter_stock,seed_stock) + biomass_stock,litter_stock,seed_stock) end do call set_patchno(sites(s)) - enddo !s - end if - - ! This sets the rhizosphere shells based on the plant initialization - ! The initialization of the plant-relevant hydraulics variables - ! 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) - call updateSizeDepRhizHydProps(sitep, bc_in(s)) - end do - deallocate(recall_older_patch) - end if - - return + enddo !s + end if + + ! This sets the rhizosphere shells based on the plant initialization + ! The initialization of the plant-relevant hydraulics variables + ! 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) + call updateSizeDepRhizHydProps(sitep, bc_in(s)) + end do + deallocate(recall_older_patch) + end if + + return end subroutine init_patches ! ============================================================================ @@ -665,186 +664,186 @@ subroutine init_cohorts( site_in, patch_in, bc_in) ! 4. biogeog = true. nocomp = true : patch and site level filter ! in principle this could be a patch level variable. do pft = 1,numpft - ! Turn every PFT ON, unless we are in a special case. - use_pft_local(pft) = itrue ! Case 1 - if(hlm_use_fixed_biogeog.eq.itrue)then !filter geographically - use_pft_local(pft) = site_in%use_this_pft(pft) ! Case 2 - if(hlm_use_nocomp.eq.itrue.and.pft.ne.patch_in%nocomp_pft_label)then - ! Having set the biogeog filter as on or off, turn off all PFTs - ! whose identiy does not correspond to this patch label. - use_pft_local(pft) = ifalse ! Case 3 - endif - else - if(hlm_use_nocomp.eq.itrue.and.pft.ne.patch_in%nocomp_pft_label)then - ! This case has all PFTs on their own patch everywhere. - use_pft_local(pft) = ifalse ! Case 4 - endif - endif + ! Turn every PFT ON, unless we are in a special case. + use_pft_local(pft) = itrue ! Case 1 + if(hlm_use_fixed_biogeog.eq.itrue)then !filter geographically + use_pft_local(pft) = site_in%use_this_pft(pft) ! Case 2 + if(hlm_use_nocomp.eq.itrue.and.pft.ne.patch_in%nocomp_pft_label)then + ! Having set the biogeog filter as on or off, turn off all PFTs + ! whose identiy does not correspond to this patch label. + use_pft_local(pft) = ifalse ! Case 3 + endif + else + if(hlm_use_nocomp.eq.itrue.and.pft.ne.patch_in%nocomp_pft_label)then + ! This case has all PFTs on their own patch everywhere. + use_pft_local(pft) = ifalse ! Case 4 + endif + endif end do do pft = 1,numpft - if(use_pft_local(pft).eq.itrue)then - if(EDPftvarcon_inst%initd(pft)>nearzero) then - - allocate(temp_cohort) ! temporary cohort - - temp_cohort%pft = pft - temp_cohort%n = EDPftvarcon_inst%initd(pft) * patch_in%area - if(hlm_use_nocomp.eq.itrue)then !in nocomp mode we only have one PFT per patch - ! as opposed to numpft's. So we should up the initial density - ! to compensate (otherwise runs are very hard to compare) - ! this multiplies it by the number of PFTs there would have been in - ! the single shared patch in competition mode. - ! n.b. that this is the same as currentcohort%n = %initd(pft) &AREA - temp_cohort%n = temp_cohort%n * sum(site_in%use_this_pft) - endif + if(use_pft_local(pft).eq.itrue)then + if(EDPftvarcon_inst%initd(pft)>nearzero) then + + allocate(temp_cohort) ! temporary cohort + + temp_cohort%pft = pft + temp_cohort%n = EDPftvarcon_inst%initd(pft) * patch_in%area + if(hlm_use_nocomp.eq.itrue)then !in nocomp mode we only have one PFT per patch + ! as opposed to numpft's. So we should up the initial density + ! to compensate (otherwise runs are very hard to compare) + ! this multiplies it by the number of PFTs there would have been in + ! the single shared patch in competition mode. + ! n.b. that this is the same as currentcohort%n = %initd(pft) &AREA + temp_cohort%n = temp_cohort%n * sum(site_in%use_this_pft) + endif + + temp_cohort%canopy_trim = 1.0_r8 + + ! h,dbh,leafc,n from SP values or from small initial size. + + if(hlm_use_sp.eq.itrue)then + init = itrue + call assign_cohort_SP_properties(temp_cohort, 0.5_r8,0.2_r8, 0.1_r8,patch_in%area,init,c_leaf) + + else + temp_cohort%hite = EDPftvarcon_inst%hgt_min(pft) + + ! Calculate the plant diameter from height + call h2d_allom(temp_cohort%hite,pft,temp_cohort%dbh) + + ! Calculate the leaf biomass from allometry + ! (calculates a maximum first, then applies canopy trim) + call bleaf(temp_cohort%dbh,pft,temp_cohort%canopy_trim,c_leaf) + end if ! sp mode + + ! Calculate total above-ground biomass from allometry + call bagw_allom(temp_cohort%dbh,pft,c_agw) + + ! Calculate coarse root biomass from allometry + call bbgw_allom(temp_cohort%dbh,pft,c_bgw) + + ! Calculate fine root biomass from allometry + ! (calculates a maximum and then trimming value) + call bfineroot(temp_cohort%dbh,pft,temp_cohort%canopy_trim,c_fnrt) + + ! Calculate sapwood biomass + call bsap_allom(temp_cohort%dbh,pft,temp_cohort%canopy_trim,a_sapw,c_sapw) + + call bdead_allom( c_agw, c_bgw, c_sapw, pft, c_struct ) + + call bstore_allom(temp_cohort%dbh, pft, temp_cohort%canopy_trim, c_store) + + temp_cohort%laimemory = 0._r8 + temp_cohort%sapwmemory = 0._r8 + temp_cohort%structmemory = 0._r8 + cstatus = leaves_on + + stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) + + + if(hlm_use_sp.eq.ifalse)then ! do not override SP vales with phenology + if ( prt_params%stress_decid(pft) == itrue .and. & + any(site_in%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then + temp_cohort%laimemory = c_leaf + temp_cohort%sapwmemory = c_sapw * stem_drop_fraction + temp_cohort%structmemory = c_struct * stem_drop_fraction + c_leaf = 0._r8 + c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw + c_struct = (1.0_r8-stem_drop_fraction) * c_struct + cstatus = leaves_off + endif + end if ! SP mode + + if ( debug ) write(fates_log(),*) 'EDInitMod.F90 call create_cohort ' + + temp_cohort%coage = 0.0_r8 + + + ! -------------------------------------------------------------------------------- + ! Initialize the mass of every element in every organ of the organ + ! -------------------------------------------------------------------------------- + + prt_obj => null() + call InitPRTObject(prt_obj) + + do el = 1,num_elements + + element_id = element_list(el) + + ! If this is carbon12, then the initialization is straight forward + ! otherwise, we use stoichiometric ratios + select case(element_id) + case(carbon12_element) + + m_struct = c_struct + m_leaf = c_leaf + m_fnrt = c_fnrt + m_sapw = c_sapw + m_store = c_store + m_repro = 0._r8 + + case(nitrogen_element) + + m_struct = c_struct*prt_params%nitr_stoich_p2(pft,struct_organ) + m_leaf = c_leaf*prt_params%nitr_stoich_p2(pft,leaf_organ) + m_fnrt = c_fnrt*prt_params%nitr_stoich_p2(pft,fnrt_organ) + m_sapw = c_sapw*prt_params%nitr_stoich_p2(pft,sapw_organ) + m_store = c_store*prt_params%nitr_stoich_p2(pft,store_organ) + m_repro = 0._r8 + + case(phosphorus_element) + + m_struct = c_struct*prt_params%phos_stoich_p2(pft,struct_organ) + m_leaf = c_leaf*prt_params%phos_stoich_p2(pft,leaf_organ) + m_fnrt = c_fnrt*prt_params%phos_stoich_p2(pft,fnrt_organ) + m_sapw = c_sapw*prt_params%phos_stoich_p2(pft,sapw_organ) + m_store = c_store*prt_params%phos_stoich_p2(pft,store_organ) + m_repro = 0._r8 + end select + + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp,prt_cnp_flex_allom_hyp ) + + ! Put all of the leaf mass into the first bin + call SetState(prt_obj,leaf_organ, element_id,m_leaf,1) + do iage = 2,nleafage + call SetState(prt_obj,leaf_organ, element_id,0._r8,iage) + end do + + call SetState(prt_obj,fnrt_organ, element_id, m_fnrt) + call SetState(prt_obj,sapw_organ, element_id, m_sapw) + call SetState(prt_obj,store_organ, element_id, m_store) + call SetState(prt_obj,struct_organ, element_id, m_struct) + call SetState(prt_obj,repro_organ, element_id, m_repro) + + case default + write(fates_log(),*) 'Unspecified PARTEH module during create_cohort' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select - temp_cohort%canopy_trim = 1.0_r8 - - ! h,dbh,leafc,n from SP values or from small initial size. - - if(hlm_use_sp.eq.itrue)then - init = itrue - call assign_cohort_SP_properties(temp_cohort, 0.5_r8,0.2_r8, 0.1_r8,patch_in%area,init,c_leaf) - - else - temp_cohort%hite = EDPftvarcon_inst%hgt_min(pft) - - ! Calculate the plant diameter from height - call h2d_allom(temp_cohort%hite,pft,temp_cohort%dbh) - - ! Calculate the leaf biomass from allometry - ! (calculates a maximum first, then applies canopy trim) - call bleaf(temp_cohort%dbh,pft,temp_cohort%canopy_trim,c_leaf) - end if ! sp mode - - ! Calculate total above-ground biomass from allometry - call bagw_allom(temp_cohort%dbh,pft,c_agw) - - ! Calculate coarse root biomass from allometry - call bbgw_allom(temp_cohort%dbh,pft,c_bgw) - - ! Calculate fine root biomass from allometry - ! (calculates a maximum and then trimming value) - call bfineroot(temp_cohort%dbh,pft,temp_cohort%canopy_trim,c_fnrt) - - ! Calculate sapwood biomass - call bsap_allom(temp_cohort%dbh,pft,temp_cohort%canopy_trim,a_sapw,c_sapw) - - call bdead_allom( c_agw, c_bgw, c_sapw, pft, c_struct ) - - call bstore_allom(temp_cohort%dbh, pft, temp_cohort%canopy_trim, c_store) - - temp_cohort%laimemory = 0._r8 - temp_cohort%sapwmemory = 0._r8 - temp_cohort%structmemory = 0._r8 - cstatus = leaves_on - - stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) - - - if(hlm_use_sp.eq.ifalse)then ! do not override SP vales with phenology - if ( prt_params%stress_decid(pft) == itrue .and. & - any(site_in%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then - temp_cohort%laimemory = c_leaf - temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction - c_leaf = 0._r8 - c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw - c_struct = (1.0_r8-stem_drop_fraction) * c_struct - cstatus = leaves_off - endif - end if ! SP mode - - if ( debug ) write(fates_log(),*) 'EDInitMod.F90 call create_cohort ' - - temp_cohort%coage = 0.0_r8 - - - ! -------------------------------------------------------------------------------- - ! Initialize the mass of every element in every organ of the organ - ! -------------------------------------------------------------------------------- - - prt_obj => null() - call InitPRTObject(prt_obj) - - do el = 1,num_elements - - element_id = element_list(el) - - ! If this is carbon12, then the initialization is straight forward - ! otherwise, we use stoichiometric ratios - select case(element_id) - case(carbon12_element) - - m_struct = c_struct - m_leaf = c_leaf - m_fnrt = c_fnrt - m_sapw = c_sapw - m_store = c_store - m_repro = 0._r8 - - case(nitrogen_element) - - m_struct = c_struct*prt_params%nitr_stoich_p2(pft,struct_organ) - m_leaf = c_leaf*prt_params%nitr_stoich_p2(pft,leaf_organ) - m_fnrt = c_fnrt*prt_params%nitr_stoich_p2(pft,fnrt_organ) - m_sapw = c_sapw*prt_params%nitr_stoich_p2(pft,sapw_organ) - m_store = c_store*prt_params%nitr_stoich_p2(pft,store_organ) - m_repro = 0._r8 - - case(phosphorus_element) - - m_struct = c_struct*prt_params%phos_stoich_p2(pft,struct_organ) - m_leaf = c_leaf*prt_params%phos_stoich_p2(pft,leaf_organ) - m_fnrt = c_fnrt*prt_params%phos_stoich_p2(pft,fnrt_organ) - m_sapw = c_sapw*prt_params%phos_stoich_p2(pft,sapw_organ) - m_store = c_store*prt_params%phos_stoich_p2(pft,store_organ) - m_repro = 0._r8 - end select - - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp,prt_cnp_flex_allom_hyp ) - - ! Put all of the leaf mass into the first bin - call SetState(prt_obj,leaf_organ, element_id,m_leaf,1) - do iage = 2,nleafage - call SetState(prt_obj,leaf_organ, element_id,0._r8,iage) end do - - call SetState(prt_obj,fnrt_organ, element_id, m_fnrt) - call SetState(prt_obj,sapw_organ, element_id, m_sapw) - call SetState(prt_obj,store_organ, element_id, m_store) - call SetState(prt_obj,struct_organ, element_id, m_struct) - call SetState(prt_obj,repro_organ, element_id, m_repro) - - case default - write(fates_log(),*) 'Unspecified PARTEH module during create_cohort' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - end do - call prt_obj%CheckInitialConditions() + call prt_obj%CheckInitialConditions() - call create_cohort(site_in, patch_in, pft, temp_cohort%n, temp_cohort%hite, & - temp_cohort%coage, temp_cohort%dbh, prt_obj, temp_cohort%laimemory, & - temp_cohort%sapwmemory, temp_cohort%structmemory, cstatus, rstatus, & - temp_cohort%canopy_trim, temp_cohort%c_area,1, site_in%spread, bc_in) + call create_cohort(site_in, patch_in, pft, temp_cohort%n, temp_cohort%hite, & + temp_cohort%coage, temp_cohort%dbh, prt_obj, temp_cohort%laimemory, & + temp_cohort%sapwmemory, temp_cohort%structmemory, cstatus, rstatus, & + temp_cohort%canopy_trim, temp_cohort%c_area,1, site_in%spread, bc_in) - deallocate(temp_cohort) ! get rid of temporary cohort + deallocate(temp_cohort) ! get rid of temporary cohort - endif - endif !use_this_pft + endif + endif !use_this_pft enddo !numpft ! Zero the mass flux pools of the new cohorts -! temp_cohort => patch_in%tallest -! do while(associated(temp_cohort)) -! call temp_cohort%prt%ZeroRates() -! temp_cohort => temp_cohort%shorter -! end do + ! temp_cohort => patch_in%tallest + ! do while(associated(temp_cohort)) + ! call temp_cohort%prt%ZeroRates() + ! temp_cohort => temp_cohort%shorter + ! end do call fuse_cohorts(site_in, patch_in,bc_in) call sort_cohorts(patch_in) From 125c850461e05c503bacf915af2a0bbc16a5c8a3 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 08:38:34 -0700 Subject: [PATCH 166/578] editing comments for clarity from CDK/HT review --- biogeochem/FatesAllometryMod.F90 | 4 ++-- main/EDInitMod.F90 | 15 ++++++++++++++- 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index 00ded88348..dbdd445693 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -762,8 +762,8 @@ end function tree_sai real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25top) ! ----------------------------------------------------------------------------------- - ! LAI of individual trees is a function of the total leaf area and the total - ! canopy area. + ! Calculates the amount of leaf carbon which is needed to generate a given treelai. + ! iss the inverse of the 'tree_lai function. ! ---------------------------------------------------------------------------------- ! !ARGUMENTS diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index ffe56889bc..f010574ac8 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -361,6 +361,16 @@ subroutine set_site_properties( nsites, sites,bc_in ) else ! for sp mode, assert a bare ground patch sumarea = sum(sites(s)%area_pft(1:numpft)) + ! In all the other FATES modes, bareground is the area in which plants + ! do not grow of their own accord. In SP mod wweassert that the canopy is full for + ! each PFT patche. Thus, we also need to assert a bare ground area in + ! order to not have all of the ground filled by leaves. + + ! Further to that, one could calculate bare ground as the remaining area when + ! all fhe canopies are accounted for, but this means we don't pass balance checks + ! on canopy are inside FATES, and so in SP mode, we define the bare groud + ! patch as having a PFT identifier as zero. + if(sumarea.lt.area)then !make some bare ground sites(s)%area_bareground = area - sumarea else @@ -497,7 +507,10 @@ subroutine init_patches( nsites, sites, bc_in) if(hlm_use_nocomp.eq.itrue)then ! In no competition mode, if we are using the fixed_biogeog filter ! then each PFT has the area dictated by the surface dataset. - ! If not, each PFT gets the same area. + + ! If we are not using fixed biogeog model, each PFT gets the same area. + ! i.e. each grid cell is divided exactly into the number of FATES PFTs. + if(hlm_use_fixed_biogeog.eq.itrue)then newparea = sites(s)%area_pft(nocomp_pft) else From 1d3f4c010529d3135f8cd22d8c056f18ea023d56 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 08:43:42 -0700 Subject: [PATCH 167/578] indenting and comments in EDSurfaceAlbedoMod.F90 --- biogeophys/EDSurfaceAlbedoMod.F90 | 2164 +++++++++++++++-------------- 1 file changed, 1085 insertions(+), 1079 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 60a8f69ecf..c59f81b47f 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -1,15 +1,15 @@ module EDSurfaceRadiationMod - - !------------------------------------------------------------------------------------- - ! EDSurfaceRadiation - ! - ! This module contains function and type definitions for all things related - ! to radiative transfer in ED modules at the land surface. - ! - !------------------------------------------------------------------------------------- + + !------------------------------------------------------------------------------------- + ! EDSurfaceRadiation + ! + ! This module contains function and type definitions for all things related + ! to radiative transfer in ED modules at the land surface. + ! + !------------------------------------------------------------------------------------- #include "shr_assert.h" - + use EDTypesMod , only : ed_patch_type, ed_site_type use EDTypesMod , only : maxPatchesPerSite use EDTypesMod , only : maxpft @@ -42,132 +42,135 @@ module EDSurfaceRadiationMod public :: ED_Norman_Radiation ! Surface albedo and two-stream fluxes public :: PatchNormanRadiation public :: ED_SunShadeFracs - + logical :: debug = .false. ! for debugging this module - + real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) - (/ 0.80_r8, 0.55_r8 /) + (/ 0.80_r8, 0.55_r8 /) contains - + subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) - ! - - ! - ! !USES: - use EDPftvarcon , only : EDPftvarcon_inst - use EDtypesMod , only : ed_patch_type - use EDTypesMod , only : ed_site_type - - - ! !ARGUMENTS: - - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) ! FATES site vector - type(bc_in_type), intent(in) :: bc_in(nsites) - type(bc_out_type), intent(inout) :: bc_out(nsites) - - - ! !LOCAL VARIABLES: - integer :: s ! site loop counter - integer :: ifp ! patch loop counter - integer :: ib ! radiation broad band counter - type(ed_patch_type), pointer :: currentPatch ! patch pointer - - !----------------------------------------------------------------------- - ! ------------------------------------------------------------------------------- - ! TODO (mv, 2014-10-29) the filter here is different than below - ! this is needed to have the VOC's be bfb - this needs to be - ! re-examined int he future - ! RGK,2016-08-06: FATES is still incompatible with VOC emission module - ! ------------------------------------------------------------------------------- - - - do s = 1, nsites - - ifp = 0 - currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) - if(currentpatch%nocomp_pft_label.ne.0)then - ifp = ifp+1 - - currentPatch%f_sun (:,:,:) = 0._r8 - currentPatch%fabd_sun_z (:,:,:) = 0._r8 - currentPatch%fabd_sha_z (:,:,:) = 0._r8 - currentPatch%fabi_sun_z (:,:,:) = 0._r8 - currentPatch%fabi_sha_z (:,:,:) = 0._r8 - currentPatch%fabd (:) = 0._r8 - currentPatch%fabi (:) = 0._r8 - - ! zero diagnostic radiation profiles - currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 - - currentPatch%solar_zenith_flag = bc_in(s)%filter_vegzen_pa(ifp) - currentPatch%solar_zenith_angle = bc_in(s)%coszen_pa(ifp) - currentPatch%gnd_alb_dif(1:hlm_numSWb) = bc_in(s)%albgr_dif_rb(1:hlm_numSWb) - currentPatch%gnd_alb_dir(1:hlm_numSWb) = bc_in(s)%albgr_dir_rb(1:hlm_numSWb) - - if(currentPatch%solar_zenith_flag )then - - bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%fabd_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM - bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM - bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM - - if (maxval(currentPatch%nrad(1,:))==0)then - !there are no leaf layers in this patch. it is effectively bare ground. - ! no radiation is absorbed - bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 - bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 - do ib = 1,hlm_numSWb - bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) - bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) - bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 - bc_out(s)%ftid_parb(ifp,ib)= 1.0_r8 - bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 - enddo - - else - - call PatchNormanRadiation (currentPatch, & - bc_out(s)%albd_parb(ifp,:), & - bc_out(s)%albi_parb(ifp,:), & - bc_out(s)%fabd_parb(ifp,:), & - bc_out(s)%fabi_parb(ifp,:), & - bc_out(s)%ftdd_parb(ifp,:), & - bc_out(s)%ftid_parb(ifp,:), & - bc_out(s)%ftii_parb(ifp,:)) - - - endif ! is there vegetation? - - end if ! if the vegetation and zenith filter is active - endif ! not bare ground - currentPatch => currentPatch%younger - end do ! Loop linked-list patches - enddo ! Loop Sites - - return - end subroutine ED_Norman_Radiation - - - ! ====================================================================================== + ! + + ! + ! !USES: + use EDPftvarcon , only : EDPftvarcon_inst + use EDtypesMod , only : ed_patch_type + use EDTypesMod , only : ed_site_type + + + ! !ARGUMENTS: + + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) ! FATES site vector + type(bc_in_type), intent(in) :: bc_in(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + + ! !LOCAL VARIABLES: + integer :: s ! site loop counter + integer :: ifp ! patch loop counter + integer :: ib ! radiation broad band counter + type(ed_patch_type), pointer :: currentPatch ! patch pointer + + !----------------------------------------------------------------------- + ! ------------------------------------------------------------------------------- + ! TODO (mv, 2014-10-29) the filter here is different than below + ! this is needed to have the VOC's be bfb - this needs to be + ! re-examined int he future + ! RGK,2016-08-06: FATES is still incompatible with VOC emission module + ! ------------------------------------------------------------------------------- + + + do s = 1, nsites + + ifp = 0 + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + if(currentpatch%nocomp_pft_label.ne.0)then + ! do not do albedo calculations for bare ground patch in SP mode + ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein + ! ifp=1 is the first vegetated patch. + ifp = ifp+1 + + currentPatch%f_sun (:,:,:) = 0._r8 + currentPatch%fabd_sun_z (:,:,:) = 0._r8 + currentPatch%fabd_sha_z (:,:,:) = 0._r8 + currentPatch%fabi_sun_z (:,:,:) = 0._r8 + currentPatch%fabi_sha_z (:,:,:) = 0._r8 + currentPatch%fabd (:) = 0._r8 + currentPatch%fabi (:) = 0._r8 + + ! zero diagnostic radiation profiles + currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 + + currentPatch%solar_zenith_flag = bc_in(s)%filter_vegzen_pa(ifp) + currentPatch%solar_zenith_angle = bc_in(s)%coszen_pa(ifp) + currentPatch%gnd_alb_dif(1:hlm_numSWb) = bc_in(s)%albgr_dif_rb(1:hlm_numSWb) + currentPatch%gnd_alb_dir(1:hlm_numSWb) = bc_in(s)%albgr_dir_rb(1:hlm_numSWb) + + if(currentPatch%solar_zenith_flag )then + + bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%fabd_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM + + if (maxval(currentPatch%nrad(1,:))==0)then + !there are no leaf layers in this patch. it is effectively bare ground. + ! no radiation is absorbed + bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 + bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 + do ib = 1,hlm_numSWb + bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) + bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) + bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 + bc_out(s)%ftid_parb(ifp,ib)= 1.0_r8 + bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 + enddo + + else + + call PatchNormanRadiation (currentPatch, & + bc_out(s)%albd_parb(ifp,:), & + bc_out(s)%albi_parb(ifp,:), & + bc_out(s)%fabd_parb(ifp,:), & + bc_out(s)%fabi_parb(ifp,:), & + bc_out(s)%ftdd_parb(ifp,:), & + bc_out(s)%ftid_parb(ifp,:), & + bc_out(s)%ftii_parb(ifp,:)) + + + endif ! is there vegetation? + + end if ! if the vegetation and zenith filter is active + endif ! not bare ground + currentPatch => currentPatch%younger + end do ! Loop linked-list patches + enddo ! Loop Sites + + return + end subroutine ED_Norman_Radiation + + + ! ====================================================================================== subroutine PatchNormanRadiation (currentPatch, & - albd_parb_out, & ! (ifp,ib) - albi_parb_out, & ! (ifp,ib) - fabd_parb_out, & ! (ifp,ib) - fabi_parb_out, & ! (ifp,ib) - ftdd_parb_out, & ! (ifp,ib) - ftid_parb_out, & ! (ifp,ib) - ftii_parb_out) ! (ifp,ib) + albd_parb_out, & ! (ifp,ib) + albi_parb_out, & ! (ifp,ib) + fabd_parb_out, & ! (ifp,ib) + fabi_parb_out, & ! (ifp,ib) + ftdd_parb_out, & ! (ifp,ib) + ftid_parb_out, & ! (ifp,ib) + ftii_parb_out) ! (ifp,ib) ! ----------------------------------------------------------------------------------- ! @@ -183,7 +186,7 @@ subroutine PatchNormanRadiation (currentPatch, & ! ----------------------------------------------------------------------------------- ! !ARGUMENTS: ! ----------------------------------------------------------------------------------- - + type(ed_patch_type), intent(inout), target :: currentPatch real(r8), intent(inout) :: albd_parb_out(hlm_numSWb) real(r8), intent(inout) :: albi_parb_out(hlm_numSWb) @@ -227,28 +230,28 @@ subroutine PatchNormanRadiation (currentPatch, & real(r8) :: phi2b(maxpft) real(r8) :: laisum ! cumulative lai+sai for canopy layer (at middle of layer) real(r8) :: angle - + real(r8),parameter :: tolerance = 0.000000001_r8 - - + + integer, parameter :: max_diag_nlevleaf = 4 integer, parameter :: diag_nlevleaf = min(nlevleaf,max_diag_nlevleaf) ! for diagnostics, write a small number of leaf layers - + real(r8) :: denom real(r8) :: lai_reduction(nclmax) - + integer :: fp,iv,s ! array indices integer :: ib ! waveband number real(r8) :: cosz ! 0.001 <= coszen <= 1.000 real(r8) :: chil real(r8) :: gdir - + real(r8), parameter :: forc_dir(n_rad_stream_types) = (/ 1.0_r8, 0.0_r8 /) ! These are binary switches used real(r8), parameter :: forc_dif(n_rad_stream_types) = (/ 0.0_r8, 1.0_r8 /) ! to turn off and on radiation streams - + associate(& rhol => EDPftvarcon_inst%rhol , & ! Input: [real(r8) (:) ] leaf reflectance: 1=vis, 2=nir rhos => EDPftvarcon_inst%rhos , & ! Input: [real(r8) (:) ] stem reflectance: 1=vis, 2=nir @@ -260,955 +263,958 @@ subroutine PatchNormanRadiation (currentPatch, & ! Initialize local arrays - weighted_dir_tr(:) = 0._r8 - weighted_dif_down(:) = 0._r8 - weighted_dif_up(:) = 0._r8 - - tr_dir_z(:,:,:) = 0._r8 - tr_dif_z(:,:,:) = 0._r8 - lai_change(:,:,:) = 0._r8 - Dif_up(:,:,:) = 0._r8 - Dif_dn(:,:,:) = 0._r8 - refl_dif(:,:,:,:) = 0.0_r8 - tran_dif(:,:,:,:) = 0.0_r8 - dif_ratio(:,:,:,:) = 0.0_r8 - - - ! Initialize the ouput arrays - ! --------------------------------------------------------------------------------- - albd_parb_out(1:hlm_numSWb) = 0.0_r8 - albi_parb_out(1:hlm_numSWb) = 0.0_r8 - fabd_parb_out(1:hlm_numSWb) = 0.0_r8 - fabi_parb_out(1:hlm_numSWb) = 0.0_r8 - ftdd_parb_out(1:hlm_numSWb) = 1.0_r8 - ftid_parb_out(1:hlm_numSWb) = 1.0_r8 - ftii_parb_out(1:hlm_numSWb) = 1.0_r8 - - ! Is this pft/canopy layer combination present in this patch? - - do L = 1,nclmax - do ft = 1,numpft - currentPatch%canopy_mask(L,ft) = 0 - do iv = 1, currentPatch%nrad(L,ft) - if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then - currentPatch%canopy_mask(L,ft) = 1 - !I think 'present' is only used here... - endif - end do !iv - end do !ft - end do !L - - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Direct beam extinction coefficient, k_dir. PFT specific. - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - cosz = max(0.001_r8, currentPatch%solar_zenith_angle ) !copied from previous radiation code... - do ft = 1,numpft - sb = (90._r8 - (acos(cosz)*180._r8/pi_const)) * (pi_const / 180._r8) - chil = xl(ft) !min(max(xl(ft), -0.4_r8), 0.6_r8 ) - if ( abs(chil) <= 0.01_r8) then - chil = 0.01_r8 - end if - phi1b(ft) = 0.5_r8 - 0.633_r8*chil - 0.330_r8*chil*chil - phi2b(ft) = 0.877_r8 * (1._r8 - 2._r8*phi1b(ft)) !0 = horiz leaves, 1 - vert leaves. - gdir = phi1b(ft) + phi2b(ft) * sin(sb) - !how much direct light penetrates a singleunit of lai? - k_dir(ft) = clumping_index(ft) * gdir / sin(sb) - end do !FT - - - - - !do this once for one unit of diffuse, and once for one unit of direct radiation - do radtype = 1, n_rad_stream_types - - ! Extract information that needs to be provided by ED into local array. - ! RGK: NOT SURE WHY WE NEED FTWEIGHT ... - ! ------------------------------------------------------------------------------ - - ftweight(:,:,:) = 0._r8 - do L = 1,currentPatch%NCL_p - do ft = 1,numpft - do iv = 1, currentPatch%nrad(L,ft) - !this is already corrected for area in CLAP - ftweight(L,ft,iv) = currentPatch%canopy_area_profile(L,ft,iv) - end do !iv - end do !ft1 - end do !L - if (sum(ftweight(1,:,1))<0.999_r8)then - write(fates_log(),*) 'canopy not full',ftweight(1,:,1) - endif - if (sum(ftweight(1,:,1))>1.0001_r8)then - write(fates_log(),*) 'canopy too full',ftweight(1,:,1) - endif - - do L = 1,currentPatch%NCL_p !start at the top canopy layer (1 is the top layer.) - - weighted_dir_tr(L) = 0.0_r8 - weighted_fsun(L) = 0._r8 - weighted_dif_ratio(L,1:hlm_numSWb) = 0._r8 - - !Each canopy layer (canopy, understorey) has multiple 'parallel' pft's - - do ft =1,numpft - - if (currentPatch%canopy_mask(L,ft) == 1)then !only do calculation if there are the appropriate leaves. - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Diffuse transmittance, tr_dif, do each layer with thickness elai_z. - ! Estimated do nine sky angles in increments of 10 degrees - ! PFT specific... - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - tr_dif_z(L,ft,:) = 0._r8 - do iv = 1,currentPatch%nrad(L,ft) - do j = 1,9 - angle = (5._r8 + real(j - 1,r8) * 10._r8) * pi_const / 180._r8 - gdir = phi1b(ft) + phi2b(ft) * sin(angle) - tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-clumping_index(ft) * & - gdir / sin(angle) * & - (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))) * & - sin(angle)*cos(angle) - end do - - tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) * 2._r8 * (10._r8 * pi_const / 180._r8) - - end do - - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Direct beam transmittance, tr_dir_z, uses cumulative LAI above layer J to give - ! unscattered direct beam onto layer J. do each PFT section. - ! This is just an decay curve based on k_dir. (leaf & sun angle) - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - if (L==1)then - tr_dir_z(L,ft,1) = 1._r8 - else - tr_dir_z(L,ft,1) = weighted_dir_tr(L-1) - endif - laisum = 0.00_r8 - !total direct beam getting to the bottom of the top canopy. - do iv = 1,currentPatch%nrad(L,ft) - laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) - lai_change(L,ft,iv) = 0.0_r8 - if (( ftweight(L,ft,iv+1) > 0.0_r8 ) .and. ( ftweight(L,ft,iv+1) < ftweight(L,ft,iv) ))then - !where there is a partly empty leaf layer, some fluxes go straight through. - lai_change(L,ft,iv) = ftweight(L,ft,iv)-ftweight(L,ft,iv+1) - endif - if (ftweight(L,ft,iv+1) - ftweight(L,ft,iv) > 1.e-10_r8)then - write(fates_log(),*) 'lower layer has more coverage. This is wrong' , & - ftweight(L,ft,iv),ftweight(L,ft,iv+1),ftweight(L,ft,iv+1)-ftweight(L,ft,iv) - endif - - !n.b. in theory lai_change could be calculated daily in the ED code. - !This is light coming striaght through the canopy. - if (L==1)then - tr_dir_z(L,ft,iv+1) = exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - else - tr_dir_z(L,ft,iv+1) = weighted_dir_tr(L-1)*exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - endif - - if (iv == 1)then - !this is the top layer. - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & - ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) - else - !the lai_change(iv) affects the light incident on layer iv+2 not iv+1 - ! light coming from the layer above (iv-1) goes through iv and onto iv+1. - if (lai_change(L,ft,iv-1) > 0.0_r8)then - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv)* & - lai_change(L,ft,iv-1) / ftweight(L,ft,1) - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv-1)* & - (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) - else - !account fot the light that comes striaght down from unfilled layers above. - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & - ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) - endif - endif - - end do - - !add up all the weighted contributions from the different PFT columns. - weighted_dir_tr(L) = weighted_dir_tr(L) + tr_dir_z(L,ft,currentPatch%nrad(L,ft)+1)*ftweight(L,ft,1) - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Sunlit and shaded fraction of leaf layer - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - - !laisum = 0._r8 - do iv = 1,currentPatch%nrad(L,ft) - ! Cumulative leaf area. Original code uses cumulative lai do layer. - ! Now use cumulative lai at center of layer. - ! Same as tr_dir_z calcualtions, but in the middle of the layer? FIX(RF,032414)-WHY? - if (iv == 1) then - laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) - else - laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) - end if - - - if (L == 1)then !top canopy layer - currentPatch%f_sun(L,ft,iv) = exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - else - currentPatch%f_sun(L,ft,iv) = weighted_fsun(L-1)* exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - endif - - if ( iv > 1 ) then ! becasue we are looking at this layer (not the next) - ! we only ever add fluxes if iv>1 - if (lai_change(L,ft,iv-1) > 0.0_r8)then - currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & - currentPatch%f_sun(L,ft,iv) * & - lai_change(L,ft,iv-1)/ftweight(L,ft,1) - currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & - currentPatch%f_sun(L,ft,iv-1) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) - else - currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & - currentPatch%f_sun(L,ft,iv-1) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - endif - endif - - end do !iv - - weighted_fsun(L) = weighted_fsun(L) + currentPatch%f_sun(L,ft,currentPatch%nrad(L,ft))* & - ftweight(L,ft,1) - - ! instance where the first layer ftweight is used a proxy for the whole column. FTWA - ! this is possibly a source of slight error. If we use the ftweight at the top of the PFT column, - ! then we willl underestimate fsun, but if we use ftweight at the bottom of the column, we will - ! underestimate it. Really, we should be tracking the release of direct light from the column as it tapers - ! towards the ground. Is that necessary to get energy closure? It would be quite hard... - endif !present. - end do!pft loop - end do !L - - - do L = currentPatch%NCL_p,1, -1 !start at the bottom and work up. - do ft = 1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - - !==============================================================================! - ! Iterative solution do scattering - !==============================================================================! - - do ib = 1,hlm_numSWb !vis, nir - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Leaf scattering coefficient and terms do diffuse radiation reflected - ! and transmitted by a layer - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - f_not_abs(ft,ib) = rhol(ft,ib) + taul(ft,ib) !leaf level fraction NOT absorbed. - !tr_dif_z is a term that uses the LAI in each layer, whereas rhol and taul do not, - !because they are properties of leaf surfaces and not of the leaf matrix. - do iv = 1,currentPatch%nrad(L,ft) - !How much diffuse light is intercepted and then reflected? - refl_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * rhol(ft,ib) - !How much diffuse light in this layer is transmitted? - tran_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * & - taul(ft,ib) + tr_dif_z(L,ft,iv) - end do - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Ratio of upward to forward diffuse fluxes, dif_ratio - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Soil diffuse reflectance (ratio of down to up radiation). - iv = currentPatch%nrad(L,ft) + 1 - if (L == currentPatch%NCL_p)then !nearest the soil - dif_ratio(L,ft,iv,ib) = currentPatch%gnd_alb_dif(ib) !bc_in(s)%albgr_dif_rb(ib) - else - dif_ratio(L,ft,iv,ib) = weighted_dif_ratio(L+1,ib) - end if - ! Canopy layers, working upwardfrom soil with dif_ratio(iv+1) known - ! FIX(RF,032414) ray tracing eqution - need to find derivation of this... - ! for each unit going down, there are x units going up. - do iv = currentPatch%nrad(L,ft),1, -1 - dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv+1,ib) * & - tran_dif(L,ft,iv,ib)*tran_dif(L,ft,iv,ib) / & - (1._r8 - dif_ratio(L,ft,iv+1,ib) * refl_dif(L,ft,iv,ib)) & - + refl_dif(L,ft,iv,ib) - dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) * & - ftweight(L,ft,iv)/ftweight(L,ft,1) - dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) + dif_ratio(L,ft,iv+1,ib) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - end do - weighted_dif_ratio(L,ib) = weighted_dif_ratio(L,ib) + & - dif_ratio(L,ft,1,ib) * ftweight(L,ft,1) - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - end do!hlm_numSWb - endif ! currentPatch%canopy_mask - end do!ft - end do!L - - - do ib = 1,hlm_numSWb - Dif_dn(:,:,:) = 0.00_r8 - Dif_up(:,:,:) = 0.00_r8 - do L = 1, currentPatch%NCL_p !work down from the top of the canopy. - weighted_dif_down(L) = 0._r8 - do ft = 1, numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! First estimates do downward and upward diffuse flux - ! - ! Dif_dn = forward diffuse flux onto layer J - ! Dif_up = Upward diffuse flux above layer J - ! - ! Solved here without direct beam radiation and using dif_ratio = Dif_up / Dif_dn - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! downward diffuse flux onto the top surface of the canopy - - if (L == 1)then - Dif_dn(L,ft,1) = forc_dif(radtype) - else - Dif_dn(L,ft,1) = weighted_dif_down(L-1) - end if - ! forward diffuse flux within the canopy and at soil, working forward through canopy - do iv = 1,currentPatch%nrad(L,ft) - denom = refl_dif(L,ft,iv,ib) * dif_ratio(L,ft,iv,ib) - denom = 1._r8 - denom - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) / & - denom *ftweight(L,ft,iv)/ftweight(L,ft,1) - if (iv > 1)then - if (lai_change(L,ft,iv-1) > 0.0_r8)then - !here we are thinking about whether the layer above had an laichange, - !but calculating the flux onto the layer below. - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv)* & - lai_change(L,ft,iv-1)/ftweight(L,ft,1) - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv-1)* & - (ftweight(L,ft,1)-ftweight(L,ft,iv-1)/ftweight(L,ft,1)) - else - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - endif - else - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - endif - end do - - weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & - ftweight(L,ft,1) - - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - endif !present - end do !ft - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is the the (incomplete) understorey? - !Add on the radiation going through the canopy gaps. - weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1)*(1.0-sum(ftweight(L,:,1))) - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - endif - end do !L - - do L = currentPatch%NCL_p,1 ,-1 !work up from the bottom. - weighted_dif_up(L) = 0._r8 - do ft = 1, numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - !Bounce diffuse radiation off soil surface. - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%NCL_p)then !is this the bottom layer ? - Dif_up(L,ft,iv) = currentPatch%gnd_alb_dif(ib) * Dif_dn(L,ft,iv) - else - Dif_up(L,ft,iv) = weighted_dif_up(L+1) - end if - ! Upward diffuse flux within the canopy and above the canopy, working upward through canopy - - do iv = currentPatch%nrad(L,ft), 1, -1 - if (lai_change(L,ft,iv) > 0.0_r8)then - Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * & - ftweight(L,ft,iv) / ftweight(L,ft,1) - Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & - tran_dif(L,ft,iv,ib) * lai_change(L,ft,iv)/ftweight(L,ft,1) - Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - !nb is this the right constuction? - ! the radiation that hits the empty space is not reflected. - else - Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * ftweight(L,ft,iv) - Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * (1.0_r8-ftweight(L,ft,iv)) - endif - end do - - weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - endif !present - end do !ft - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? - !Add on the radiation coming up through the canopy gaps. - !diffuse to diffuse - weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & - weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) - !direct to diffuse - weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & - weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) * currentPatch%gnd_alb_dir(ib) - endif - end do !L - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! 3. Iterative calculation of forward and upward diffuse fluxes, iNCL_puding - ! scattered direct beam - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - - ! Flag to exit iteration loop: 0 = exit and 1 = iterate - irep = 1 - ! Iteration loop - iter = 0 - do while(irep ==1 .and. iter<50) - - iter = iter + 1 - irep = 0 - do L = 1,currentPatch%NCL_p !working from the top down - weighted_dif_down(L) = 0._r8 - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - ! forward diffuse flux within the canopy and at soil, working forward through canopy - ! with Dif_up -from previous iteration-. Dif_dn(1) is the forward diffuse flux onto the canopy. - ! Note: down = forward flux onto next layer - if (L == 1)then !is this the top layer? - Dif_dn(L,ft,1) = forc_dif(radtype) - else - Dif_dn(L,ft,1) = weighted_dif_down(L-1) - end if - down_rad = 0._r8 - - do iv = 1, currentPatch%nrad(L,ft) - - down_rad = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) + & - Dif_up(L,ft,iv+1) * refl_dif(L,ft,iv,ib) + & - forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - & - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & - currentPatch%esai_profile(L,ft,iv)))) * taul(ft,ib) - down_rad = down_rad *(ftweight(L,ft,iv)/ftweight(L,ft,1)) - - if (iv > 1)then - if (lai_change(L,ft,iv-1) > 0.0_r8)then - down_rad = down_rad + Dif_dn(L,ft,iv) * lai_change(L,ft,iv-1)/ftweight(L,ft,1) - down_rad = down_rad + Dif_dn(L,ft,iv-1) * (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ & - ftweight(L,ft,1) - else - down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & - ftweight(L,ft,1) - endif - else - down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & - ftweight(L,ft,1) - endif - - !this is just Dif down, plus refl up, plus dir intercepted and turned into dif... , - if (abs(down_rad - Dif_dn(L,ft,iv+1)) > tolerance)then - irep = 1 - end if - Dif_dn(L,ft,iv+1) = down_rad - - end do !iv - - weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & - ftweight(L,ft,1) - - endif !present - end do!ft - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? - weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1) * & - (1.0_r8-sum(ftweight(L,1:numpft,1))) - end if - end do ! do L loop - - do L = 1, currentPatch%NCL_p ! working from the top down. - weighted_dif_up(L) = 0._r8 - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - ! Upward diffuse flux at soil or from lower canopy (forward diffuse and unscattered direct beam) - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%NCL_p)then !In the bottom canopy layer, reflect off the soil - Dif_up(L,ft,iv) = Dif_dn(L,ft,iv) * currentPatch%gnd_alb_dif(ib) + & - forc_dir(radtype) * tr_dir_z(L,ft,iv) * currentPatch%gnd_alb_dir(ib) - else !In the other canopy layers, reflect off the underlying vegetation. - Dif_up(L,ft,iv) = weighted_dif_up(L+1) - end if - - ! Upward diffuse flux within and above the canopy, working upward through canopy - ! with Dif_dn from previous interation. Note: up = upward flux above current layer - do iv = currentPatch%nrad(L,ft),1,-1 - !this is radiation up, by layer transmittance, by - - !reflection of the lower layer, - up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) - up_rad = up_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - exp(-k_dir(ft) * & - (currentPatch%elai_profile(L,ft,iv) + currentPatch%esai_profile(L,ft,iv)))) * & - rhol(ft,ib) - up_rad = up_rad + Dif_up(L,ft,iv+1) * tran_dif(L,ft,iv,ib) - up_rad = up_rad * ftweight(L,ft,iv)/ftweight(L,ft,1) - up_rad = up_rad + Dif_up(L,ft,iv+1) *(ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - ! THE LOWER LAYER FLUX IS HOMOGENIZED, SO WE DON"T CONSIDER THE LAI_CHANGE HERE... - - if (abs(up_rad - Dif_up(L,ft,iv)) > tolerance) then !are we close to the tolerance level? - irep = 1 - end if - Dif_up(L,ft,iv) = up_rad - - end do !iv - weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) - end if !present - end do!ft - - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? - !Add on the radiation coming up through the canopy gaps. - weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & - weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) - weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & - weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1)))*currentPatch%gnd_alb_dir(ib) - end if - end do!L - end do ! do while over iter - - abs_rad(ib) = 0._r8 - tr_soili = 0._r8 - tr_soild = 0._r8 - - do L = 1, currentPatch%NCL_p !working from the top down. - abs_dir_z(:,:) = 0._r8 - abs_dif_z(:,:) = 0._r8 - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - !==============================================================================! - ! Compute absorbed flux densities - !==============================================================================! - - ! Absorbed direct beam and diffuse do leaf layers - do iv = 1, currentPatch%nrad(L,ft) - Abs_dir_z(ft,iv) = ftweight(L,ft,iv)* forc_dir(radtype) * tr_dir_z(L,ft,iv) * & - (1.00_r8 - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & - currentPatch%esai_profile(L,ft,iv)))) * (1.00_r8 - f_not_abs(ft,ib)) - Abs_dif_z(ft,iv) = ftweight(L,ft,iv)* ((Dif_dn(L,ft,iv) + & - Dif_up(L,ft,iv+1)) * (1.00_r8 - tr_dif_z(L,ft,iv)) * & - (1.00_r8 - f_not_abs(ft,ib))) - end do - - ! Absorbed direct beam and diffuse do soil - if (L == currentPatch%NCL_p)then - iv = currentPatch%nrad(L,ft) + 1 - Abs_dif_z(ft,iv) = ftweight(L,ft,1)*Dif_dn(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dif(ib) ) - Abs_dir_z(ft,iv) = ftweight(L,ft,1)*forc_dir(radtype) * & - tr_dir_z(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dir(ib) ) - tr_soild = tr_soild + ftweight(L,ft,1)*forc_dir(radtype) * tr_dir_z(L,ft,iv) - tr_soili = tr_soili + ftweight(L,ft,1)*Dif_dn(L,ft,iv) - end if - - ! Absorbed radiation, shaded and sunlit portions of leaf layers - !here we get one unit of diffuse radiation... how much of - !it is absorbed? - if (ib == ivis) then ! only set the absorbed PAR for the visible light band. - do iv = 1, currentPatch%nrad(L,ft) - if (radtype==idirect) then - if ( debug ) then - write(fates_log(),*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) - write(fates_log(),*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & - currentPatch%fabd_sun_z(L,ft,iv) - endif - currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - (1._r8 - currentPatch%f_sun(L,ft,iv)) - currentPatch%fabd_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - currentPatch%f_sun(L,ft,iv) + & - Abs_dir_z(ft,iv) - else - currentPatch%fabi_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - (1._r8 - currentPatch%f_sun(L,ft,iv)) - currentPatch%fabi_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - currentPatch%f_sun(L,ft,iv) - endif - if ( debug ) then - write(fates_log(),*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & - currentPatch%fabd_sun_z(L,ft,iv) - endif - end do - endif ! ib - - - !==============================================================================! - ! Sum fluxes - !==============================================================================! - ! Solar radiation absorbed by ground - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%NCL_p)then - abs_rad(ib) = abs_rad(ib) + (Abs_dir_z(ft,iv) + Abs_dif_z(ft,iv)) - end if - ! Solar radiation absorbed by vegetation and sunlit/shaded leaves - do iv = 1,currentPatch%nrad(L,ft) - if (radtype == idirect)then - currentPatch%fabd(ib) = currentPatch%fabd(ib) + & - Abs_dir_z(ft,iv)+Abs_dif_z(ft,iv) - ! bc_out(s)%fabd_parb_out(ib) = currentPatch%fabd(ib) - else - currentPatch%fabi(ib) = currentPatch%fabi(ib) + Abs_dif_z(ft,iv) - ! bc_out(s)%fabi_parb_out(ib) = currentPatch%fabi(ib) - endif - end do - - ! Albefor - if (L==1)then !top canopy layer. - if (radtype == idirect)then - albd_parb_out(ib) = albd_parb_out(ib) + & - Dif_up(L,ft,1) * ftweight(L,ft,1) - else - albi_parb_out(ib) = albi_parb_out(ib) + & - Dif_up(L,ft,1) * ftweight(L,ft,1) - end if - end if - - ! pass normalized PAR profiles for use in diagnostic averaging for history fields - if (ib == ivis) then ! only diagnose PAR profiles for the visible band - do iv = 1, currentPatch%nrad(L,ft) - currentPatch%nrmlzd_parprof_pft_dir_z(radtype,L,ft,iv) = & - forc_dir(radtype) * tr_dir_z(L,ft,iv) - currentPatch%nrmlzd_parprof_pft_dif_z(radtype,L,ft,iv) = & - Dif_dn(L,ft,iv) + Dif_up(L,ft,iv) - ! - currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) = & - currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) + & - (forc_dir(radtype) * tr_dir_z(L,ft,iv)) * & - (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) - currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) = & - currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) + & - (Dif_dn(L,ft,iv) + Dif_up(L,ft,iv)) * & - (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) - end do - end if ! ib = visible - end if ! present - end do !ft - if (radtype == idirect)then - fabd_parb_out(ib) = currentPatch%fabd(ib) - else - fabi_parb_out(ib) = currentPatch%fabi(ib) - endif - - - !radiation absorbed from fluxes through unfilled part of lower canopy. - if (currentPatch%NCL_p > 1.and.L == currentPatch%NCL_p)then - abs_rad(ib) = abs_rad(ib) + weighted_dif_down(L-1) * & - (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dif(ib) ) - abs_rad(ib) = abs_rad(ib) + forc_dir(radtype) * weighted_dir_tr(L-1) * & - (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dir(ib) ) - tr_soili = tr_soili + weighted_dif_down(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) - tr_soild = tr_soild + forc_dir(radtype) * weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) - endif - - if (radtype == idirect)then - currentPatch%tr_soil_dir(ib) = tr_soild - currentPatch%tr_soil_dir_dif(ib) = tr_soili - currentPatch%sabs_dir(ib) = abs_rad(ib) - ftdd_parb_out(ib) = tr_soild - ftid_parb_out(ib) = tr_soili - else - currentPatch%tr_soil_dif(ib) = tr_soili - currentPatch%sabs_dif(ib) = abs_rad(ib) - ftii_parb_out(ib) = tr_soili - end if - - end do!l - - - !==============================================================================! - ! Conservation check - !==============================================================================! - ! Total radiation balance: absorbed = incoming - outgoing - - if (radtype == idirect)then - error = abs(currentPatch%sabs_dir(ib) - (currentPatch%tr_soil_dir(ib) * & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + & - currentPatch%tr_soil_dir_dif(ib) * (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) - if ( abs(error) > 0.0001)then - write(fates_log(),*)'dir ground absorption error',error,currentPatch%sabs_dir(ib), & - currentPatch%tr_soil_dir(ib)* & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) - write(fates_log(),*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ) - - do ft =1,3 - iv = currentPatch%nrad(1,ft) + 1 - write(fates_log(),*) 'abs soil fluxes', Abs_dir_z(ft,iv),Abs_dif_z(ft,iv) - end do - - end if - else - if ( abs(currentPatch%sabs_dif(ib)-(currentPatch%tr_soil_dif(ib) * & - (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) > 0.0001_r8)then - write(fates_log(),*)'dif ground absorption error',currentPatch%sabs_dif(ib) , & - (currentPatch%tr_soil_dif(ib)* & - (1.0_r8-currentPatch%gnd_alb_dif(ib) )),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) - endif - endif - - if (radtype == idirect)then - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) - else - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) - endif - lai_reduction(:) = 0.0_r8 - do L = 1, currentPatch%NCL_p - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - do iv = 1, currentPatch%nrad(L,ft) - if (lai_change(L,ft,iv) > 0.0_r8)then - lai_reduction(L) = max(lai_reduction(L),lai_change(L,ft,iv)) - endif - enddo - endif - enddo - enddo - - if (radtype == idirect)then - !here we are adding a within-ED radiation scheme tolerance, and then adding the diffrence onto the albedo - !it is important that the lower boundary for this is ~1000 times smaller than the tolerance in surface albedo. - if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then - albd_parb_out(ib) = albd_parb_out(ib) + error - !this terms adds the error back on to the albedo. While this is partly inexcusable, it is - ! in the medium term a solution that - ! prevents the model from crashing with small and occasional energy balances issues. - ! These are extremely difficult to debug, many have been solved already, leading - ! to the complexity of this code, but where the system generates occasional errors, we - ! will deal with them for now. - end if - if (abs(error) > 0.15_r8)then - write(fates_log(),*) 'Large Dir Radn consvn error',error ,ib - write(fates_log(),*) 'diags', albd_parb_out(ib), ftdd_parb_out(ib), & - ftid_parb_out(ib), fabd_parb_out(ib) - write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno - write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) - - albd_parb_out(ib) = albd_parb_out(ib) + error - end if - else - - if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then - albi_parb_out(ib) = albi_parb_out(ib) + error - end if - - if (abs(error) > 0.15_r8)then - write(fates_log(),*) '>5% Dif Radn consvn error',error ,ib - write(fates_log(),*) 'diags', albi_parb_out(ib), ftii_parb_out(ib), & - fabi_parb_out(ib) - write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno - write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) - write(fates_log(),*) 'rhol',rhol(1:numpft,:) - write(fates_log(),*) 'ftw',sum(ftweight(1,1:numpft,1)),ftweight(1,1:numpft,1) - write(fates_log(),*) 'present',currentPatch%canopy_mask(1,1:numpft) - write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:numpft,1) - - albi_parb_out(ib) = albi_parb_out(ib) + error - end if - - if (radtype == idirect)then - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) - else - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) - endif - - if (abs(error) > 0.00000001_r8)then - write(fates_log(),*) 'there is still error after correction',error ,ib - end if - - end if - - end do !hlm_numSWb - - enddo ! rad-type - - - end associate - return - end subroutine PatchNormanRadiation - - ! ====================================================================================== - - subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) - - implicit none - - ! 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) - - - ! locals - type (ed_patch_type),pointer :: cpatch ! c"urrent" patch - real(r8) :: sunlai - real(r8) :: shalai - real(r8) :: elai - integer :: CL - integer :: FT - integer :: iv - integer :: s - integer :: ifp - - - do s = 1,nsites + weighted_dir_tr(:) = 0._r8 + weighted_dif_down(:) = 0._r8 + weighted_dif_up(:) = 0._r8 + + tr_dir_z(:,:,:) = 0._r8 + tr_dif_z(:,:,:) = 0._r8 + lai_change(:,:,:) = 0._r8 + Dif_up(:,:,:) = 0._r8 + Dif_dn(:,:,:) = 0._r8 + refl_dif(:,:,:,:) = 0.0_r8 + tran_dif(:,:,:,:) = 0.0_r8 + dif_ratio(:,:,:,:) = 0.0_r8 + + + ! Initialize the ouput arrays + ! --------------------------------------------------------------------------------- + albd_parb_out(1:hlm_numSWb) = 0.0_r8 + albi_parb_out(1:hlm_numSWb) = 0.0_r8 + fabd_parb_out(1:hlm_numSWb) = 0.0_r8 + fabi_parb_out(1:hlm_numSWb) = 0.0_r8 + ftdd_parb_out(1:hlm_numSWb) = 1.0_r8 + ftid_parb_out(1:hlm_numSWb) = 1.0_r8 + ftii_parb_out(1:hlm_numSWb) = 1.0_r8 + + ! Is this pft/canopy layer combination present in this patch? + + do L = 1,nclmax + do ft = 1,numpft + currentPatch%canopy_mask(L,ft) = 0 + do iv = 1, currentPatch%nrad(L,ft) + if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then + currentPatch%canopy_mask(L,ft) = 1 + !I think 'present' is only used here... + endif + end do !iv + end do !ft + end do !L + + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Direct beam extinction coefficient, k_dir. PFT specific. + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + cosz = max(0.001_r8, currentPatch%solar_zenith_angle ) !copied from previous radiation code... + do ft = 1,numpft + sb = (90._r8 - (acos(cosz)*180._r8/pi_const)) * (pi_const / 180._r8) + chil = xl(ft) !min(max(xl(ft), -0.4_r8), 0.6_r8 ) + if ( abs(chil) <= 0.01_r8) then + chil = 0.01_r8 + end if + phi1b(ft) = 0.5_r8 - 0.633_r8*chil - 0.330_r8*chil*chil + phi2b(ft) = 0.877_r8 * (1._r8 - 2._r8*phi1b(ft)) !0 = horiz leaves, 1 - vert leaves. + gdir = phi1b(ft) + phi2b(ft) * sin(sb) + !how much direct light penetrates a singleunit of lai? + k_dir(ft) = clumping_index(ft) * gdir / sin(sb) + end do !FT + + + + + !do this once for one unit of diffuse, and once for one unit of direct radiation + do radtype = 1, n_rad_stream_types + + ! Extract information that needs to be provided by ED into local array. + ! RGK: NOT SURE WHY WE NEED FTWEIGHT ... + ! ------------------------------------------------------------------------------ + + ftweight(:,:,:) = 0._r8 + do L = 1,currentPatch%NCL_p + do ft = 1,numpft + do iv = 1, currentPatch%nrad(L,ft) + !this is already corrected for area in CLAP + ftweight(L,ft,iv) = currentPatch%canopy_area_profile(L,ft,iv) + end do !iv + end do !ft1 + end do !L + if (sum(ftweight(1,:,1))<0.999_r8)then + write(fates_log(),*) 'canopy not full',ftweight(1,:,1) + endif + if (sum(ftweight(1,:,1))>1.0001_r8)then + write(fates_log(),*) 'canopy too full',ftweight(1,:,1) + endif + + do L = 1,currentPatch%NCL_p !start at the top canopy layer (1 is the top layer.) + + weighted_dir_tr(L) = 0.0_r8 + weighted_fsun(L) = 0._r8 + weighted_dif_ratio(L,1:hlm_numSWb) = 0._r8 + + !Each canopy layer (canopy, understorey) has multiple 'parallel' pft's + + do ft =1,numpft + + if (currentPatch%canopy_mask(L,ft) == 1)then !only do calculation if there are the appropriate leaves. + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Diffuse transmittance, tr_dif, do each layer with thickness elai_z. + ! Estimated do nine sky angles in increments of 10 degrees + ! PFT specific... + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + tr_dif_z(L,ft,:) = 0._r8 + do iv = 1,currentPatch%nrad(L,ft) + do j = 1,9 + angle = (5._r8 + real(j - 1,r8) * 10._r8) * pi_const / 180._r8 + gdir = phi1b(ft) + phi2b(ft) * sin(angle) + tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-clumping_index(ft) * & + gdir / sin(angle) * & + (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))) * & + sin(angle)*cos(angle) + end do + + tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) * 2._r8 * (10._r8 * pi_const / 180._r8) + + end do + + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Direct beam transmittance, tr_dir_z, uses cumulative LAI above layer J to give + ! unscattered direct beam onto layer J. do each PFT section. + ! This is just an decay curve based on k_dir. (leaf & sun angle) + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + if (L==1)then + tr_dir_z(L,ft,1) = 1._r8 + else + tr_dir_z(L,ft,1) = weighted_dir_tr(L-1) + endif + laisum = 0.00_r8 + !total direct beam getting to the bottom of the top canopy. + do iv = 1,currentPatch%nrad(L,ft) + laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) + lai_change(L,ft,iv) = 0.0_r8 + if (( ftweight(L,ft,iv+1) > 0.0_r8 ) .and. ( ftweight(L,ft,iv+1) < ftweight(L,ft,iv) ))then + !where there is a partly empty leaf layer, some fluxes go straight through. + lai_change(L,ft,iv) = ftweight(L,ft,iv)-ftweight(L,ft,iv+1) + endif + if (ftweight(L,ft,iv+1) - ftweight(L,ft,iv) > 1.e-10_r8)then + write(fates_log(),*) 'lower layer has more coverage. This is wrong' , & + ftweight(L,ft,iv),ftweight(L,ft,iv+1),ftweight(L,ft,iv+1)-ftweight(L,ft,iv) + endif + + !n.b. in theory lai_change could be calculated daily in the ED code. + !This is light coming striaght through the canopy. + if (L==1)then + tr_dir_z(L,ft,iv+1) = exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + else + tr_dir_z(L,ft,iv+1) = weighted_dir_tr(L-1)*exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + endif + + if (iv == 1)then + !this is the top layer. + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & + ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) + else + !the lai_change(iv) affects the light incident on layer iv+2 not iv+1 + ! light coming from the layer above (iv-1) goes through iv and onto iv+1. + if (lai_change(L,ft,iv-1) > 0.0_r8)then + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv)* & + lai_change(L,ft,iv-1) / ftweight(L,ft,1) + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv-1)* & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) + else + !account fot the light that comes striaght down from unfilled layers above. + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & + ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) + endif + endif - ifp = 0 - cpatch => sites(s)%oldest_patch - - do while (associated(cpatch)) - if(cpatch%nocomp_pft_label.ne.0)then !only for veg patches - ifp=ifp+1 - - if( debug ) write(fates_log(),*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft - - ! zero out various datas - cpatch%ed_parsun_z(:,:,:) = 0._r8 - cpatch%ed_parsha_z(:,:,:) = 0._r8 - cpatch%ed_laisun_z(:,:,:) = 0._r8 - cpatch%ed_laisha_z(:,:,:) = 0._r8 - - bc_out(s)%fsun_pa(ifp) = 0._r8 - - sunlai = 0._r8 - shalai = 0._r8 - - cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 - cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 - cpatch%parprof_dir_z(:,:) = 0._r8 - cpatch%parprof_dif_z(:,:) = 0._r8 - - ! Loop over patches to calculate laisun_z and laisha_z for each layer. - ! Derive canopy laisun, laisha, and fsun from layer sums. - ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from - ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. - - ! cpatch%f_sun is calculated in the surface_albedo routine... - - do CL = 1, cpatch%NCL_p - do FT = 1,numpft - - if( debug ) write(fates_log(),*) 'edsurfRad_5601',CL,FT,cpatch%nrad(CL,ft) - - do iv = 1, cpatch%nrad(CL,ft) !NORMAL CASE. - - ! FIX(SPM,040114) - existing comment - ! ** Should this be elai or tlai? Surely we only do radiation for elai? - - cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & - cpatch%f_sun(CL,ft,iv) - - if ( debug ) write(fates_log(),*) 'edsurfRad 570 ',cpatch%elai_profile(CL,ft,iv) - if ( debug ) write(fates_log(),*) 'edsurfRad 571 ',cpatch%f_sun(CL,ft,iv) - - cpatch%ed_laisha_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & - (1._r8 - cpatch%f_sun(CL,ft,iv)) - end do - - !needed for the VOC emissions, etc. - sunlai = sunlai + sum(cpatch%ed_laisun_z(CL,ft,1:cpatch%nrad(CL,ft))) - shalai = shalai + sum(cpatch%ed_laisha_z(CL,ft,1:cpatch%nrad(CL,ft))) - - end do - end do - - if(sunlai+shalai > 0._r8)then - bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) + + !add up all the weighted contributions from the different PFT columns. + weighted_dir_tr(L) = weighted_dir_tr(L) + tr_dir_z(L,ft,currentPatch%nrad(L,ft)+1)*ftweight(L,ft,1) + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Sunlit and shaded fraction of leaf layer + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + + !laisum = 0._r8 + do iv = 1,currentPatch%nrad(L,ft) + ! Cumulative leaf area. Original code uses cumulative lai do layer. + ! Now use cumulative lai at center of layer. + ! Same as tr_dir_z calcualtions, but in the middle of the layer? FIX(RF,032414)-WHY? + if (iv == 1) then + laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) + else + laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) + end if + + + if (L == 1)then !top canopy layer + currentPatch%f_sun(L,ft,iv) = exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + else + currentPatch%f_sun(L,ft,iv) = weighted_fsun(L-1)* exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + endif + + if ( iv > 1 ) then ! becasue we are looking at this layer (not the next) + ! we only ever add fluxes if iv>1 + if (lai_change(L,ft,iv-1) > 0.0_r8)then + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv) * & + lai_change(L,ft,iv-1)/ftweight(L,ft,1) + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv-1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) + else + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv-1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + endif + + end do !iv + + weighted_fsun(L) = weighted_fsun(L) + currentPatch%f_sun(L,ft,currentPatch%nrad(L,ft))* & + ftweight(L,ft,1) + + ! instance where the first layer ftweight is used a proxy for the whole column. FTWA + ! this is possibly a source of slight error. If we use the ftweight at the top of the PFT column, + ! then we willl underestimate fsun, but if we use ftweight at the bottom of the column, we will + ! underestimate it. Really, we should be tracking the release of direct light from the column as it tapers + ! towards the ground. Is that necessary to get energy closure? It would be quite hard... + endif !present. + end do!pft loop + end do !L + + + do L = currentPatch%NCL_p,1, -1 !start at the bottom and work up. + do ft = 1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + + !==============================================================================! + ! Iterative solution do scattering + !==============================================================================! + + do ib = 1,hlm_numSWb !vis, nir + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Leaf scattering coefficient and terms do diffuse radiation reflected + ! and transmitted by a layer + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + f_not_abs(ft,ib) = rhol(ft,ib) + taul(ft,ib) !leaf level fraction NOT absorbed. + !tr_dif_z is a term that uses the LAI in each layer, whereas rhol and taul do not, + !because they are properties of leaf surfaces and not of the leaf matrix. + do iv = 1,currentPatch%nrad(L,ft) + !How much diffuse light is intercepted and then reflected? + refl_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * rhol(ft,ib) + !How much diffuse light in this layer is transmitted? + tran_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * & + taul(ft,ib) + tr_dif_z(L,ft,iv) + end do + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Ratio of upward to forward diffuse fluxes, dif_ratio + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Soil diffuse reflectance (ratio of down to up radiation). + iv = currentPatch%nrad(L,ft) + 1 + if (L == currentPatch%NCL_p)then !nearest the soil + dif_ratio(L,ft,iv,ib) = currentPatch%gnd_alb_dif(ib) !bc_in(s)%albgr_dif_rb(ib) + else + dif_ratio(L,ft,iv,ib) = weighted_dif_ratio(L+1,ib) + end if + ! Canopy layers, working upwardfrom soil with dif_ratio(iv+1) known + ! FIX(RF,032414) ray tracing eqution - need to find derivation of this... + ! for each unit going down, there are x units going up. + do iv = currentPatch%nrad(L,ft),1, -1 + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv+1,ib) * & + tran_dif(L,ft,iv,ib)*tran_dif(L,ft,iv,ib) / & + (1._r8 - dif_ratio(L,ft,iv+1,ib) * refl_dif(L,ft,iv,ib)) & + + refl_dif(L,ft,iv,ib) + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) * & + ftweight(L,ft,iv)/ftweight(L,ft,1) + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) + dif_ratio(L,ft,iv+1,ib) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + end do + weighted_dif_ratio(L,ib) = weighted_dif_ratio(L,ib) + & + dif_ratio(L,ft,1,ib) * ftweight(L,ft,1) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + end do!hlm_numSWb + endif ! currentPatch%canopy_mask + end do!ft + end do!L + + + do ib = 1,hlm_numSWb + Dif_dn(:,:,:) = 0.00_r8 + Dif_up(:,:,:) = 0.00_r8 + do L = 1, currentPatch%NCL_p !work down from the top of the canopy. + weighted_dif_down(L) = 0._r8 + do ft = 1, numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! First estimates do downward and upward diffuse flux + ! + ! Dif_dn = forward diffuse flux onto layer J + ! Dif_up = Upward diffuse flux above layer J + ! + ! Solved here without direct beam radiation and using dif_ratio = Dif_up / Dif_dn + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! downward diffuse flux onto the top surface of the canopy + + if (L == 1)then + Dif_dn(L,ft,1) = forc_dif(radtype) + else + Dif_dn(L,ft,1) = weighted_dif_down(L-1) + end if + ! forward diffuse flux within the canopy and at soil, working forward through canopy + do iv = 1,currentPatch%nrad(L,ft) + denom = refl_dif(L,ft,iv,ib) * dif_ratio(L,ft,iv,ib) + denom = 1._r8 - denom + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) / & + denom *ftweight(L,ft,iv)/ftweight(L,ft,1) + if (iv > 1)then + if (lai_change(L,ft,iv-1) > 0.0_r8)then + !here we are thinking about whether the layer above had an laichange, + !but calculating the flux onto the layer below. + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv)* & + lai_change(L,ft,iv-1)/ftweight(L,ft,1) + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv-1)* & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1)/ftweight(L,ft,1)) + else + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + else + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + end do + + weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & + ftweight(L,ft,1) + + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif !present + end do !ft + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is the the (incomplete) understorey? + !Add on the radiation going through the canopy gaps. + weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1)*(1.0-sum(ftweight(L,:,1))) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif + end do !L + + do L = currentPatch%NCL_p,1 ,-1 !work up from the bottom. + weighted_dif_up(L) = 0._r8 + do ft = 1, numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + !Bounce diffuse radiation off soil surface. + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then !is this the bottom layer ? + Dif_up(L,ft,iv) = currentPatch%gnd_alb_dif(ib) * Dif_dn(L,ft,iv) + else + Dif_up(L,ft,iv) = weighted_dif_up(L+1) + end if + ! Upward diffuse flux within the canopy and above the canopy, working upward through canopy + + do iv = currentPatch%nrad(L,ft), 1, -1 + if (lai_change(L,ft,iv) > 0.0_r8)then + Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * & + ftweight(L,ft,iv) / ftweight(L,ft,1) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & + tran_dif(L,ft,iv,ib) * lai_change(L,ft,iv)/ftweight(L,ft,1) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + !nb is this the right constuction? + ! the radiation that hits the empty space is not reflected. + else + Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * ftweight(L,ft,iv) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * (1.0_r8-ftweight(L,ft,iv)) + endif + end do + + weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif !present + end do !ft + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? + !Add on the radiation coming up through the canopy gaps. + !diffuse to diffuse + weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & + weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) + !direct to diffuse + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & + weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) * currentPatch%gnd_alb_dir(ib) + endif + end do !L + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! 3. Iterative calculation of forward and upward diffuse fluxes, iNCL_puding + ! scattered direct beam + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + + ! Flag to exit iteration loop: 0 = exit and 1 = iterate + irep = 1 + ! Iteration loop + iter = 0 + do while(irep ==1 .and. iter<50) + + iter = iter + 1 + irep = 0 + do L = 1,currentPatch%NCL_p !working from the top down + weighted_dif_down(L) = 0._r8 + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + ! forward diffuse flux within the canopy and at soil, working forward through canopy + ! with Dif_up -from previous iteration-. Dif_dn(1) is the forward diffuse flux onto the canopy. + ! Note: down = forward flux onto next layer + if (L == 1)then !is this the top layer? + Dif_dn(L,ft,1) = forc_dif(radtype) + else + Dif_dn(L,ft,1) = weighted_dif_down(L-1) + end if + down_rad = 0._r8 + + do iv = 1, currentPatch%nrad(L,ft) + + down_rad = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) + & + Dif_up(L,ft,iv+1) * refl_dif(L,ft,iv,ib) + & + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - & + exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv)))) * taul(ft,ib) + down_rad = down_rad *(ftweight(L,ft,iv)/ftweight(L,ft,1)) + + if (iv > 1)then + if (lai_change(L,ft,iv-1) > 0.0_r8)then + down_rad = down_rad + Dif_dn(L,ft,iv) * lai_change(L,ft,iv-1)/ftweight(L,ft,1) + down_rad = down_rad + Dif_dn(L,ft,iv-1) * (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ & + ftweight(L,ft,1) + else + down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & + ftweight(L,ft,1) + endif + else + down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & + ftweight(L,ft,1) + endif + + !this is just Dif down, plus refl up, plus dir intercepted and turned into dif... , + if (abs(down_rad - Dif_dn(L,ft,iv+1)) > tolerance)then + irep = 1 + end if + Dif_dn(L,ft,iv+1) = down_rad + + end do !iv + + weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & + ftweight(L,ft,1) + + endif !present + end do!ft + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? + weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1) * & + (1.0_r8-sum(ftweight(L,1:numpft,1))) + end if + end do ! do L loop + + do L = 1, currentPatch%NCL_p ! working from the top down. + weighted_dif_up(L) = 0._r8 + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + ! Upward diffuse flux at soil or from lower canopy (forward diffuse and unscattered direct beam) + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then !In the bottom canopy layer, reflect off the soil + Dif_up(L,ft,iv) = Dif_dn(L,ft,iv) * currentPatch%gnd_alb_dif(ib) + & + forc_dir(radtype) * tr_dir_z(L,ft,iv) * currentPatch%gnd_alb_dir(ib) + else !In the other canopy layers, reflect off the underlying vegetation. + Dif_up(L,ft,iv) = weighted_dif_up(L+1) + end if + + ! Upward diffuse flux within and above the canopy, working upward through canopy + ! with Dif_dn from previous interation. Note: up = upward flux above current layer + do iv = currentPatch%nrad(L,ft),1,-1 + !this is radiation up, by layer transmittance, by + + !reflection of the lower layer, + up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) + up_rad = up_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - exp(-k_dir(ft) * & + (currentPatch%elai_profile(L,ft,iv) + currentPatch%esai_profile(L,ft,iv)))) * & + rhol(ft,ib) + up_rad = up_rad + Dif_up(L,ft,iv+1) * tran_dif(L,ft,iv,ib) + up_rad = up_rad * ftweight(L,ft,iv)/ftweight(L,ft,1) + up_rad = up_rad + Dif_up(L,ft,iv+1) *(ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + ! THE LOWER LAYER FLUX IS HOMOGENIZED, SO WE DON"T CONSIDER THE LAI_CHANGE HERE... + + if (abs(up_rad - Dif_up(L,ft,iv)) > tolerance) then !are we close to the tolerance level? + irep = 1 + end if + Dif_up(L,ft,iv) = up_rad + + end do !iv + weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) + end if !present + end do!ft + + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? + !Add on the radiation coming up through the canopy gaps. + weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & + weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & + weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1)))*currentPatch%gnd_alb_dir(ib) + end if + end do!L + end do ! do while over iter + + abs_rad(ib) = 0._r8 + tr_soili = 0._r8 + tr_soild = 0._r8 + + do L = 1, currentPatch%NCL_p !working from the top down. + abs_dir_z(:,:) = 0._r8 + abs_dif_z(:,:) = 0._r8 + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + !==============================================================================! + ! Compute absorbed flux densities + !==============================================================================! + + ! Absorbed direct beam and diffuse do leaf layers + do iv = 1, currentPatch%nrad(L,ft) + Abs_dir_z(ft,iv) = ftweight(L,ft,iv)* forc_dir(radtype) * tr_dir_z(L,ft,iv) * & + (1.00_r8 - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv)))) * (1.00_r8 - f_not_abs(ft,ib)) + Abs_dif_z(ft,iv) = ftweight(L,ft,iv)* ((Dif_dn(L,ft,iv) + & + Dif_up(L,ft,iv+1)) * (1.00_r8 - tr_dif_z(L,ft,iv)) * & + (1.00_r8 - f_not_abs(ft,ib))) + end do + + ! Absorbed direct beam and diffuse do soil + if (L == currentPatch%NCL_p)then + iv = currentPatch%nrad(L,ft) + 1 + Abs_dif_z(ft,iv) = ftweight(L,ft,1)*Dif_dn(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dif(ib) ) + Abs_dir_z(ft,iv) = ftweight(L,ft,1)*forc_dir(radtype) * & + tr_dir_z(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dir(ib) ) + tr_soild = tr_soild + ftweight(L,ft,1)*forc_dir(radtype) * tr_dir_z(L,ft,iv) + tr_soili = tr_soili + ftweight(L,ft,1)*Dif_dn(L,ft,iv) + end if + + ! Absorbed radiation, shaded and sunlit portions of leaf layers + !here we get one unit of diffuse radiation... how much of + !it is absorbed? + if (ib == ivis) then ! only set the absorbed PAR for the visible light band. + do iv = 1, currentPatch%nrad(L,ft) + if (radtype==idirect) then + if ( debug ) then + write(fates_log(),*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) + write(fates_log(),*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & + currentPatch%fabd_sun_z(L,ft,iv) + endif + currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv)) + currentPatch%fabd_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + currentPatch%f_sun(L,ft,iv) + & + Abs_dir_z(ft,iv) + else + currentPatch%fabi_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv)) + currentPatch%fabi_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + currentPatch%f_sun(L,ft,iv) + endif + if ( debug ) then + write(fates_log(),*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & + currentPatch%fabd_sun_z(L,ft,iv) + endif + end do + endif ! ib + + + !==============================================================================! + ! Sum fluxes + !==============================================================================! + ! Solar radiation absorbed by ground + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then + abs_rad(ib) = abs_rad(ib) + (Abs_dir_z(ft,iv) + Abs_dif_z(ft,iv)) + end if + ! Solar radiation absorbed by vegetation and sunlit/shaded leaves + do iv = 1,currentPatch%nrad(L,ft) + if (radtype == idirect)then + currentPatch%fabd(ib) = currentPatch%fabd(ib) + & + Abs_dir_z(ft,iv)+Abs_dif_z(ft,iv) + ! bc_out(s)%fabd_parb_out(ib) = currentPatch%fabd(ib) + else + currentPatch%fabi(ib) = currentPatch%fabi(ib) + Abs_dif_z(ft,iv) + ! bc_out(s)%fabi_parb_out(ib) = currentPatch%fabi(ib) + endif + end do + + ! Albefor + if (L==1)then !top canopy layer. + if (radtype == idirect)then + albd_parb_out(ib) = albd_parb_out(ib) + & + Dif_up(L,ft,1) * ftweight(L,ft,1) + else + albi_parb_out(ib) = albi_parb_out(ib) + & + Dif_up(L,ft,1) * ftweight(L,ft,1) + end if + end if + + ! pass normalized PAR profiles for use in diagnostic averaging for history fields + if (ib == ivis) then ! only diagnose PAR profiles for the visible band + do iv = 1, currentPatch%nrad(L,ft) + currentPatch%nrmlzd_parprof_pft_dir_z(radtype,L,ft,iv) = & + forc_dir(radtype) * tr_dir_z(L,ft,iv) + currentPatch%nrmlzd_parprof_pft_dif_z(radtype,L,ft,iv) = & + Dif_dn(L,ft,iv) + Dif_up(L,ft,iv) + ! + currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) = & + currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) + & + (forc_dir(radtype) * tr_dir_z(L,ft,iv)) * & + (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) + currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) = & + currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) + & + (Dif_dn(L,ft,iv) + Dif_up(L,ft,iv)) * & + (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) + end do + end if ! ib = visible + end if ! present + end do !ft + if (radtype == idirect)then + fabd_parb_out(ib) = currentPatch%fabd(ib) + else + fabi_parb_out(ib) = currentPatch%fabi(ib) + endif + + + !radiation absorbed from fluxes through unfilled part of lower canopy. + if (currentPatch%NCL_p > 1.and.L == currentPatch%NCL_p)then + abs_rad(ib) = abs_rad(ib) + weighted_dif_down(L-1) * & + (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dif(ib) ) + abs_rad(ib) = abs_rad(ib) + forc_dir(radtype) * weighted_dir_tr(L-1) * & + (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dir(ib) ) + tr_soili = tr_soili + weighted_dif_down(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) + tr_soild = tr_soild + forc_dir(radtype) * weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) + endif + + if (radtype == idirect)then + currentPatch%tr_soil_dir(ib) = tr_soild + currentPatch%tr_soil_dir_dif(ib) = tr_soili + currentPatch%sabs_dir(ib) = abs_rad(ib) + ftdd_parb_out(ib) = tr_soild + ftid_parb_out(ib) = tr_soili + else + currentPatch%tr_soil_dif(ib) = tr_soili + currentPatch%sabs_dif(ib) = abs_rad(ib) + ftii_parb_out(ib) = tr_soili + end if + + end do!l + + + !==============================================================================! + ! Conservation check + !==============================================================================! + ! Total radiation balance: absorbed = incoming - outgoing + + if (radtype == idirect)then + error = abs(currentPatch%sabs_dir(ib) - (currentPatch%tr_soil_dir(ib) * & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + & + currentPatch%tr_soil_dir_dif(ib) * (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) + if ( abs(error) > 0.0001)then + write(fates_log(),*)'dir ground absorption error',error,currentPatch%sabs_dir(ib), & + currentPatch%tr_soil_dir(ib)* & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) + write(fates_log(),*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + + do ft =1,3 + iv = currentPatch%nrad(1,ft) + 1 + write(fates_log(),*) 'abs soil fluxes', Abs_dir_z(ft,iv),Abs_dif_z(ft,iv) + end do + + end if else - bc_out(s)%fsun_pa(ifp) = 0._r8 + if ( abs(currentPatch%sabs_dif(ib)-(currentPatch%tr_soil_dif(ib) * & + (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) > 0.0001_r8)then + write(fates_log(),*)'dif ground absorption error',currentPatch%sabs_dif(ib) , & + (currentPatch%tr_soil_dif(ib)* & + (1.0_r8-currentPatch%gnd_alb_dif(ib) )),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) + endif endif - - if(bc_out(s)%fsun_pa(ifp) > 1._r8)then - write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & - sunlai,shalai + + if (radtype == idirect)then + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) + else + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) endif + lai_reduction(:) = 0.0_r8 + do L = 1, currentPatch%NCL_p + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + do iv = 1, currentPatch%nrad(L,ft) + if (lai_change(L,ft,iv) > 0.0_r8)then + lai_reduction(L) = max(lai_reduction(L),lai_change(L,ft,iv)) + endif + enddo + endif + enddo + enddo + + if (radtype == idirect)then + !here we are adding a within-ED radiation scheme tolerance, and then adding the diffrence onto the albedo + !it is important that the lower boundary for this is ~1000 times smaller than the tolerance in surface albedo. + if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then + albd_parb_out(ib) = albd_parb_out(ib) + error + !this terms adds the error back on to the albedo. While this is partly inexcusable, it is + ! in the medium term a solution that + ! prevents the model from crashing with small and occasional energy balances issues. + ! These are extremely difficult to debug, many have been solved already, leading + ! to the complexity of this code, but where the system generates occasional errors, we + ! will deal with them for now. + end if + if (abs(error) > 0.15_r8)then + write(fates_log(),*) 'Large Dir Radn consvn error',error ,ib + write(fates_log(),*) 'diags', albd_parb_out(ib), ftdd_parb_out(ib), & + ftid_parb_out(ib), fabd_parb_out(ib) + write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) + + albd_parb_out(ib) = albd_parb_out(ib) + error + end if + else + + if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then + albi_parb_out(ib) = albi_parb_out(ib) + error + end if + + if (abs(error) > 0.15_r8)then + write(fates_log(),*) '>5% Dif Radn consvn error',error ,ib + write(fates_log(),*) 'diags', albi_parb_out(ib), ftii_parb_out(ib), & + fabi_parb_out(ib) + write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) + write(fates_log(),*) 'rhol',rhol(1:numpft,:) + write(fates_log(),*) 'ftw',sum(ftweight(1,1:numpft,1)),ftweight(1,1:numpft,1) + write(fates_log(),*) 'present',currentPatch%canopy_mask(1,1:numpft) + write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:numpft,1) + + albi_parb_out(ib) = albi_parb_out(ib) + error + end if + + if (radtype == idirect)then + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) + else + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) + endif + + if (abs(error) > 0.00000001_r8)then + write(fates_log(),*) 'there is still error after correction',error ,ib + end if + + end if + + end do !hlm_numSWb + + enddo ! rad-type + + + end associate + return +end subroutine PatchNormanRadiation + +! ====================================================================================== + +subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) + + implicit none + + ! 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) + + + ! locals + type (ed_patch_type),pointer :: cpatch ! c"urrent" patch + real(r8) :: sunlai + real(r8) :: shalai + real(r8) :: elai + integer :: CL + integer :: FT + integer :: iv + integer :: s + integer :: ifp + + + do s = 1,nsites + + ifp = 0 + cpatch => sites(s)%oldest_patch + + do while (associated(cpatch)) + if(cpatch%nocomp_pft_label.ne.0)then !only for veg patches + ! do not do albedo calculations for bare ground patch in SP mode + ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein + ! ifp=1 is the first vegetated patch. + ifp=ifp+1 + + if( debug ) write(fates_log(),*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft + + ! zero out various datas + cpatch%ed_parsun_z(:,:,:) = 0._r8 + cpatch%ed_parsha_z(:,:,:) = 0._r8 + cpatch%ed_laisun_z(:,:,:) = 0._r8 + cpatch%ed_laisha_z(:,:,:) = 0._r8 + + bc_out(s)%fsun_pa(ifp) = 0._r8 + + sunlai = 0._r8 + shalai = 0._r8 + + cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 + cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 + cpatch%parprof_dir_z(:,:) = 0._r8 + cpatch%parprof_dif_z(:,:) = 0._r8 + + ! Loop over patches to calculate laisun_z and laisha_z for each layer. + ! Derive canopy laisun, laisha, and fsun from layer sums. + ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from + ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. + + ! cpatch%f_sun is calculated in the surface_albedo routine... + + do CL = 1, cpatch%NCL_p + do FT = 1,numpft + + if( debug ) write(fates_log(),*) 'edsurfRad_5601',CL,FT,cpatch%nrad(CL,ft) + + do iv = 1, cpatch%nrad(CL,ft) !NORMAL CASE. + + ! FIX(SPM,040114) - existing comment + ! ** Should this be elai or tlai? Surely we only do radiation for elai? + + cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + cpatch%f_sun(CL,ft,iv) + + if ( debug ) write(fates_log(),*) 'edsurfRad 570 ',cpatch%elai_profile(CL,ft,iv) + if ( debug ) write(fates_log(),*) 'edsurfRad 571 ',cpatch%f_sun(CL,ft,iv) + + cpatch%ed_laisha_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + (1._r8 - cpatch%f_sun(CL,ft,iv)) + + end do + + !needed for the VOC emissions, etc. + sunlai = sunlai + sum(cpatch%ed_laisun_z(CL,ft,1:cpatch%nrad(CL,ft))) + shalai = shalai + sum(cpatch%ed_laisha_z(CL,ft,1:cpatch%nrad(CL,ft))) + + end do + end do + + if(sunlai+shalai > 0._r8)then + bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) + else + bc_out(s)%fsun_pa(ifp) = 0._r8 + endif + + if(bc_out(s)%fsun_pa(ifp) > 1._r8)then + write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & + sunlai,shalai + endif + + elai = calc_areaindex(cpatch,'elai') + + bc_out(s)%laisun_pa(ifp) = elai*bc_out(s)%fsun_pa(ifp) + bc_out(s)%laisha_pa(ifp) = elai*(1.0_r8-bc_out(s)%fsun_pa(ifp)) + + ! Absorbed PAR profile through canopy + ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo + ! are canopy integrated so that layer values equal big leaf values. + + if ( debug ) write(fates_log(),*) 'edsurfRad 645 ',cpatch%NCL_p,numpft + + do CL = 1, cpatch%NCL_p + do FT = 1,numpft + + if ( debug ) write(fates_log(),*) 'edsurfRad 649 ',cpatch%nrad(CL,ft) + + do iv = 1, cpatch%nrad(CL,ft) + + if ( debug ) then + write(fates_log(),*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) + write(fates_log(),*) 'edsurfRad 654 ', bc_in(s)%solad_parb(ifp,ipar) + write(fates_log(),*) 'edsurfRad 655 ', bc_in(s)%solai_parb(ifp,ipar) + write(fates_log(),*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) + write(fates_log(),*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) + endif + + cpatch%ed_parsun_z(CL,ft,iv) = & + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(CL,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(CL,ft,iv) + + if ( debug )write(fates_log(),*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) + + cpatch%ed_parsha_z(CL,ft,iv) = & + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(CL,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(CL,ft,iv) + + if ( debug ) write(fates_log(),*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) + + end do !iv + end do !FT + end do !CL + + ! output the actual PAR profiles through the canopy for diagnostic purposes + + do CL = 1, cpatch%NCL_p + do FT = 1,numpft + do iv = 1, cpatch%nrad(CL,ft) + cpatch%parprof_pft_dir_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dir_z(idirect,CL,FT,iv)) + & + (bc_in(s)%solai_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dir_z(idiffuse,CL,FT,iv)) + cpatch%parprof_pft_dif_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dif_z(idirect,CL,FT,iv)) + & + (bc_in(s)%solai_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dif_z(idiffuse,CL,FT,iv)) + end do ! iv + end do ! FT + end do ! CL + + do CL = 1, cpatch%NCL_p + do iv = 1, maxval(cpatch%nrad(CL,:)) + cpatch%parprof_dir_z(CL,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_dir_z(idirect,CL,iv)) + & + (bc_in(s)%solai_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_dir_z(idiffuse,CL,iv)) + cpatch%parprof_dif_z(CL,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_dif_z(idirect,CL,iv)) + & + (bc_in(s)%solai_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_dif_z(idiffuse,CL,iv)) + end do ! iv + end do ! CL + endif ! not bareground patch + cpatch => cpatch%younger + enddo + + + enddo + return - elai = calc_areaindex(cpatch,'elai') - - bc_out(s)%laisun_pa(ifp) = elai*bc_out(s)%fsun_pa(ifp) - bc_out(s)%laisha_pa(ifp) = elai*(1.0_r8-bc_out(s)%fsun_pa(ifp)) - - ! Absorbed PAR profile through canopy - ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo - ! are canopy integrated so that layer values equal big leaf values. - - if ( debug ) write(fates_log(),*) 'edsurfRad 645 ',cpatch%NCL_p,numpft - - do CL = 1, cpatch%NCL_p - do FT = 1,numpft - - if ( debug ) write(fates_log(),*) 'edsurfRad 649 ',cpatch%nrad(CL,ft) - - do iv = 1, cpatch%nrad(CL,ft) - - if ( debug ) then - write(fates_log(),*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) - write(fates_log(),*) 'edsurfRad 654 ', bc_in(s)%solad_parb(ifp,ipar) - write(fates_log(),*) 'edsurfRad 655 ', bc_in(s)%solai_parb(ifp,ipar) - write(fates_log(),*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) - write(fates_log(),*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) - endif - - cpatch%ed_parsun_z(CL,ft,iv) = & - bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(CL,ft,iv) + & - bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(CL,ft,iv) - - if ( debug )write(fates_log(),*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) - - cpatch%ed_parsha_z(CL,ft,iv) = & - bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(CL,ft,iv) + & - bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(CL,ft,iv) - - if ( debug ) write(fates_log(),*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) - - end do !iv - end do !FT - end do !CL - - ! output the actual PAR profiles through the canopy for diagnostic purposes - - do CL = 1, cpatch%NCL_p - do FT = 1,numpft - do iv = 1, cpatch%nrad(CL,ft) - cpatch%parprof_pft_dir_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dir_z(idirect,CL,FT,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dir_z(idiffuse,CL,FT,iv)) - cpatch%parprof_pft_dif_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dif_z(idirect,CL,FT,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dif_z(idiffuse,CL,FT,iv)) - end do ! iv - end do ! FT - end do ! CL - - do CL = 1, cpatch%NCL_p - do iv = 1, maxval(cpatch%nrad(CL,:)) - cpatch%parprof_dir_z(CL,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dir_z(idirect,CL,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dir_z(idiffuse,CL,iv)) - cpatch%parprof_dif_z(CL,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dif_z(idirect,CL,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dif_z(idiffuse,CL,iv)) - end do ! iv - end do ! CL - endif ! not bareground patch - cpatch => cpatch%younger - enddo - - - enddo - return - end subroutine ED_SunShadeFracs @@ -1240,6 +1246,6 @@ end subroutine ED_SunShadeFracs ! end do ! return ! end subroutine ED_CheckSolarBalance - + end module EDSurfaceRadiationMod From 543c4d70fa04100c6f3b26d96cc736f6b6b2c17d Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 08:45:08 -0700 Subject: [PATCH 168/578] indenting EDAccumulateFluxesMod.F90 --- biogeophys/EDAccumulateFluxesMod.F90 | 96 ++++++++++++++-------------- 1 file changed, 48 insertions(+), 48 deletions(-) diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index f9bf10e44f..a0fe4dd7df 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -23,8 +23,8 @@ module EDAccumulateFluxesMod logical :: debug = .false. ! for debugging this module character(len=*), parameter, private :: sourcefile = & - __FILE__ - + __FILE__ + contains !------------------------------------------------------------------------------ @@ -36,9 +36,9 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) ! see above ! ! !USES: - + use EDTypesMod , only : ed_patch_type, ed_cohort_type, & - ed_site_type, AREA + ed_site_type, AREA use FatesInterfaceTypesMod , only : bc_in_type,bc_out_type ! @@ -59,59 +59,59 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) !---------------------------------------------------------------------- do s = 1, nsites - + ifp = 0 cpatch => sites(s)%oldest_patch do while (associated(cpatch)) - if(cpatch%nocomp_pft_label.ne.0)then - ifp = ifp+1 - - if( bc_in(s)%filter_photo_pa(ifp) == 3 ) then - ccohort => cpatch%shortest - do while(associated(ccohort)) - - ! Accumulate fluxes from hourly to daily values. - ! _tstep fluxes are KgC/indiv/timestep _acc are KgC/indiv/day - - if ( debug ) then - - write(fates_log(),*) 'EDAccumFlux 64 ',ccohort%npp_tstep - write(fates_log(),*) 'EDAccumFlux 66 ',ccohort%gpp_tstep - write(fates_log(),*) 'EDAccumFlux 67 ',ccohort%resp_tstep - - endif - - ccohort%npp_acc = ccohort%npp_acc + ccohort%npp_tstep - ccohort%gpp_acc = ccohort%gpp_acc + ccohort%gpp_tstep - ccohort%resp_acc = ccohort%resp_acc + ccohort%resp_tstep - - ! weighted mean of D13C by gpp - if((ccohort%gpp_acc + ccohort%gpp_tstep) .eq. 0.0_r8) then - ccohort%c13disc_acc = 0.0_r8 - else - ccohort%c13disc_acc = ((ccohort%c13disc_acc * ccohort%gpp_acc) + & - (ccohort%c13disc_clm * ccohort%gpp_tstep)) / & - (ccohort%gpp_acc + ccohort%gpp_tstep) - endif - - do iv=1,ccohort%nv - if(ccohort%year_net_uptake(iv) == 999._r8)then ! note that there were leaves in this layer this year. - ccohort%year_net_uptake(iv) = 0._r8 - end if - ccohort%year_net_uptake(iv) = ccohort%year_net_uptake(iv) + ccohort%ts_net_uptake(iv) - enddo - - ccohort => ccohort%taller - enddo ! while(associated(ccohort)) - end if + if(cpatch%nocomp_pft_label.ne.0)then + ifp = ifp+1 + + if( bc_in(s)%filter_photo_pa(ifp) == 3 ) then + ccohort => cpatch%shortest + do while(associated(ccohort)) + + ! Accumulate fluxes from hourly to daily values. + ! _tstep fluxes are KgC/indiv/timestep _acc are KgC/indiv/day + + if ( debug ) then + + write(fates_log(),*) 'EDAccumFlux 64 ',ccohort%npp_tstep + write(fates_log(),*) 'EDAccumFlux 66 ',ccohort%gpp_tstep + write(fates_log(),*) 'EDAccumFlux 67 ',ccohort%resp_tstep + + endif + + ccohort%npp_acc = ccohort%npp_acc + ccohort%npp_tstep + ccohort%gpp_acc = ccohort%gpp_acc + ccohort%gpp_tstep + ccohort%resp_acc = ccohort%resp_acc + ccohort%resp_tstep + + ! weighted mean of D13C by gpp + if((ccohort%gpp_acc + ccohort%gpp_tstep) .eq. 0.0_r8) then + ccohort%c13disc_acc = 0.0_r8 + else + ccohort%c13disc_acc = ((ccohort%c13disc_acc * ccohort%gpp_acc) + & + (ccohort%c13disc_clm * ccohort%gpp_tstep)) / & + (ccohort%gpp_acc + ccohort%gpp_tstep) + endif + + do iv=1,ccohort%nv + if(ccohort%year_net_uptake(iv) == 999._r8)then ! note that there were leaves in this layer this year. + ccohort%year_net_uptake(iv) = 0._r8 + end if + ccohort%year_net_uptake(iv) = ccohort%year_net_uptake(iv) + ccohort%ts_net_uptake(iv) + enddo + + ccohort => ccohort%taller + enddo ! while(associated(ccohort)) + end if end if ! not bare ground cpatch => cpatch%younger end do ! while(associated(cpatch)) end do return - - end subroutine AccumulateFluxes_ED + + end subroutine AccumulateFluxes_ED end module EDAccumulateFluxesMod From 73e8799e52f53e899f61a57e78842d89ef6fd2e7 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 08:53:39 -0700 Subject: [PATCH 169/578] indenting EDBtranMod.F90 --- biogeophys/EDBtranMod.F90 | 428 +++++++++++++++++++------------------- 1 file changed, 214 insertions(+), 214 deletions(-) diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index 5bdcd966bb..17b279d6b3 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -1,44 +1,44 @@ module EDBtranMod - - !------------------------------------------------------------------------------------- - ! Description: - ! - ! ------------------------------------------------------------------------------------ - - use EDPftvarcon , only : EDPftvarcon_inst - use FatesConstantsMod , only : tfrz => t_water_freeze_k_1atm - use FatesConstantsMod , only : itrue,ifalse,nearzero - use EDTypesMod , only : ed_site_type, & - ed_patch_type, & - ed_cohort_type, & - maxpft - use shr_kind_mod , only : r8 => shr_kind_r8 - use FatesInterfaceTypesMod , only : bc_in_type, & - bc_out_type, & - numpft - use FatesInterfaceTypesMod , only : hlm_use_planthydro - use FatesGlobals , only : fates_log - use FatesAllometryMod , only : set_root_fraction - - ! - implicit none - private - - public :: btran_ed - public :: get_active_suction_layers - public :: check_layer_water - + + !------------------------------------------------------------------------------------- + ! Description: + ! + ! ------------------------------------------------------------------------------------ + + use EDPftvarcon , only : EDPftvarcon_inst + use FatesConstantsMod , only : tfrz => t_water_freeze_k_1atm + use FatesConstantsMod , only : itrue,ifalse,nearzero + use EDTypesMod , only : ed_site_type, & + ed_patch_type, & + ed_cohort_type, & + maxpft + use shr_kind_mod , only : r8 => shr_kind_r8 + use FatesInterfaceTypesMod , only : bc_in_type, & + bc_out_type, & + numpft + use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesGlobals , only : fates_log + use FatesAllometryMod , only : set_root_fraction + + ! + implicit none + private + + public :: btran_ed + public :: get_active_suction_layers + public :: check_layer_water + contains - + ! ==================================================================================== logical function check_layer_water(h2o_liq_vol, tempk) - + implicit none ! Arguments real(r8),intent(in) :: h2o_liq_vol real(r8),intent(in) :: tempk - + check_layer_water = .false. if ( h2o_liq_vol .gt. 0._r8 ) then @@ -50,206 +50,206 @@ logical function check_layer_water(h2o_liq_vol, tempk) end function check_layer_water ! ===================================================================================== - + subroutine get_active_suction_layers(nsites, sites, bc_in, bc_out) - + ! 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) - + ! !LOCAL VARIABLES: integer :: s ! site integer :: j ! soil layer !------------------------------------------------------------------------------ - - do s = 1,nsites - if (bc_in(s)%filter_btran) then - do j = 1,bc_in(s)%nlevsoil - bc_out(s)%active_suction_sl(j) = check_layer_water( bc_in(s)%h2o_liqvol_sl(j),bc_in(s)%tempk_sl(j) ) - end do - else - bc_out(s)%active_suction_sl(:) = .false. - end if - end do + + do s = 1,nsites + if (bc_in(s)%filter_btran) then + do j = 1,bc_in(s)%nlevsoil + bc_out(s)%active_suction_sl(j) = check_layer_water( bc_in(s)%h2o_liqvol_sl(j),bc_in(s)%tempk_sl(j) ) + end do + else + bc_out(s)%active_suction_sl(:) = .false. + end if + end do end subroutine get_active_suction_layers - + ! ===================================================================================== subroutine btran_ed( nsites, sites, bc_in, bc_out) use FatesPlantHydraulicsMod, only : BTranForHLMDiagnosticsFromCohortHydr - - ! --------------------------------------------------------------------------------- - ! Calculate the transpiration wetness function (BTRAN) and the root uptake - ! distribution (ROOTR). - ! Boundary conditions in: bc_in(s)%eff_porosity_sl(j) unfrozen porosity - ! bc_in(s)%watsat_sl(j) porosity - ! bc_in(s)%active_uptake_sl(j) frozen/not frozen - ! bc_in(s)%smp_sl(j) suction - ! Boundary conditions out: bc_out(s)%rootr_pasl root uptake distribution - ! bc_out(s)%btran_pa wetness factor - ! --------------------------------------------------------------------------------- - - ! 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) - - ! - ! !LOCAL VARIABLES: - type(ed_patch_type),pointer :: cpatch ! Current Patch Pointer - type(ed_cohort_type),pointer :: ccohort ! Current cohort pointer - integer :: s ! site - integer :: j ! soil layer - integer :: ifp ! patch vector index for the site - integer :: ft ! plant functional type index - real(r8) :: smp_node ! matrix potential - real(r8) :: rresis ! suction limitation to transpiration independent - ! of root density - real(r8) :: pftgs(maxpft) ! pft weighted stomatal conductance m/s - real(r8) :: temprootr - real(r8) :: sum_pftgs ! sum of weighted conductances (for normalization) - real(r8), allocatable :: root_resis(:,:) ! Root resistance in each pft x layer - !------------------------------------------------------------------------------ - - associate( & - smpsc => EDPftvarcon_inst%smpsc , & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS - smpso => EDPftvarcon_inst%smpso & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS - ) - - do s = 1,nsites - - allocate(root_resis(numpft,bc_in(s)%nlevsoil)) - - bc_out(s)%rootr_pasl(:,:) = 0._r8 - - ifp = 0 - cpatch => sites(s)%oldest_patch - do while (associated(cpatch)) - if(cpatch%nocomp_pft_label.ne.0)then ! only for veg patches - ifp=ifp+1 - - ! THIS SHOULD REALLY BE A COHORT LOOP ONCE WE HAVE rootfr_ft FOR COHORTS (RGK) - - do ft = 1,numpft - - call set_root_fraction(sites(s)%rootfrac_scr, ft, sites(s)%zi_soil ) - - cpatch%btran_ft(ft) = 0.0_r8 - do j = 1,bc_in(s)%nlevsoil - - ! Calculations are only relevant where liquid water exists - ! see clm_fates%wrap_btran for calculation with CLM/ALM - - if ( check_layer_water(bc_in(s)%h2o_liqvol_sl(j),bc_in(s)%tempk_sl(j)) ) then - - smp_node = max(smpsc(ft), bc_in(s)%smp_sl(j)) - - rresis = min( (bc_in(s)%eff_porosity_sl(j)/bc_in(s)%watsat_sl(j))* & - (smp_node - smpsc(ft)) / (smpso(ft) - smpsc(ft)), 1._r8) - - root_resis(ft,j) = sites(s)%rootfrac_scr(j)*rresis - - ! root water uptake is not linearly proportional to root density, - ! to allow proper deep root funciton. Replace with equations from SPA/Newman. FIX(RF,032414) - - cpatch%btran_ft(ft) = cpatch%btran_ft(ft) + root_resis(ft,j) - - else - root_resis(ft,j) = 0._r8 - end if - - end do !j - - ! Normalize root resistances to get layer contribution to ET - do j = 1,bc_in(s)%nlevsoil - if (cpatch%btran_ft(ft) > nearzero) then - root_resis(ft,j) = root_resis(ft,j)/cpatch%btran_ft(ft) - else - root_resis(ft,j) = 0._r8 - end if - end do - - end do !PFT - - ! PFT-averaged point level root fraction for extraction purposese. - ! The cohort's conductance g_sb_laweighted, contains a weighting factor - ! based on the cohort's leaf area. units: [m/s] * [m2] - - pftgs(1:maxpft) = 0._r8 - ccohort => cpatch%tallest - do while(associated(ccohort)) - pftgs(ccohort%pft) = pftgs(ccohort%pft) + ccohort%g_sb_laweight - ccohort => ccohort%shorter - enddo - - ! Process the boundary output, this is necessary for calculating the soil-moisture - ! sink term across the different layers in driver/host. Photosynthesis will - ! pass the host a total transpiration for the patch. This needs rootr to be - ! distributed over the soil layers. - sum_pftgs = sum(pftgs(1:numpft)) - - do j = 1, bc_in(s)%nlevsoil - bc_out(s)%rootr_pasl(ifp,j) = 0._r8 - do ft = 1,numpft - if( sum_pftgs > 0._r8)then !prevent problem with the first timestep - might fail - !bit-retart test as a result? FIX(RF,032414) - bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j) + & - root_resis(ft,j) * pftgs(ft)/sum_pftgs - else - bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j) + & - root_resis(ft,j) * 1._r8/real(numpft,r8) - end if - enddo - enddo - - ! Calculate the BTRAN that is passed back to the HLM - ! used only for diagnostics. If plant hydraulics is turned off - ! we are using the patchxpft level btran calculation - - if(hlm_use_planthydro.eq.ifalse) then - !weight patch level output BTRAN for the - bc_out(s)%btran_pa(ifp) = 0.0_r8 - do ft = 1,numpft - if( sum_pftgs > 0._r8)then !prevent problem with the first timestep - might fail - !bit-retart test as a result? FIX(RF,032414) - bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * pftgs(ft)/sum_pftgs - else - bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * 1./numpft - end if - enddo - end if - - temprootr = sum(bc_out(s)%rootr_pasl(ifp,1:bc_in(s)%nlevsoil)) - - if(abs(1.0_r8-temprootr) > 1.0e-10_r8 .and. temprootr > 1.0e-10_r8)then - write(fates_log(),*) 'error with rootr in canopy fluxes',temprootr,sum_pftgs - do j = 1,bc_in(s)%nlevsoil - bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j)/temprootr - enddo - end if - endif ! not bare ground - cpatch => cpatch%younger - end do - - deallocate(root_resis) - - end do - - if(hlm_use_planthydro.eq.itrue) then - call BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) - end if - - end associate - - end subroutine btran_ed + + ! --------------------------------------------------------------------------------- + ! Calculate the transpiration wetness function (BTRAN) and the root uptake + ! distribution (ROOTR). + ! Boundary conditions in: bc_in(s)%eff_porosity_sl(j) unfrozen porosity + ! bc_in(s)%watsat_sl(j) porosity + ! bc_in(s)%active_uptake_sl(j) frozen/not frozen + ! bc_in(s)%smp_sl(j) suction + ! Boundary conditions out: bc_out(s)%rootr_pasl root uptake distribution + ! bc_out(s)%btran_pa wetness factor + ! --------------------------------------------------------------------------------- + + ! 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) + + ! + ! !LOCAL VARIABLES: + type(ed_patch_type),pointer :: cpatch ! Current Patch Pointer + type(ed_cohort_type),pointer :: ccohort ! Current cohort pointer + integer :: s ! site + integer :: j ! soil layer + integer :: ifp ! patch vector index for the site + integer :: ft ! plant functional type index + real(r8) :: smp_node ! matrix potential + real(r8) :: rresis ! suction limitation to transpiration independent + ! of root density + real(r8) :: pftgs(maxpft) ! pft weighted stomatal conductance m/s + real(r8) :: temprootr + real(r8) :: sum_pftgs ! sum of weighted conductances (for normalization) + real(r8), allocatable :: root_resis(:,:) ! Root resistance in each pft x layer + !------------------------------------------------------------------------------ + + associate( & + smpsc => EDPftvarcon_inst%smpsc , & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS + smpso => EDPftvarcon_inst%smpso & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS + ) + + do s = 1,nsites + + allocate(root_resis(numpft,bc_in(s)%nlevsoil)) + + bc_out(s)%rootr_pasl(:,:) = 0._r8 + + ifp = 0 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + if(cpatch%nocomp_pft_label.ne.0)then ! only for veg patches + ifp=ifp+1 + + ! THIS SHOULD REALLY BE A COHORT LOOP ONCE WE HAVE rootfr_ft FOR COHORTS (RGK) + + do ft = 1,numpft + + call set_root_fraction(sites(s)%rootfrac_scr, ft, sites(s)%zi_soil ) + + cpatch%btran_ft(ft) = 0.0_r8 + do j = 1,bc_in(s)%nlevsoil + + ! Calculations are only relevant where liquid water exists + ! see clm_fates%wrap_btran for calculation with CLM/ALM + + if ( check_layer_water(bc_in(s)%h2o_liqvol_sl(j),bc_in(s)%tempk_sl(j)) ) then + + smp_node = max(smpsc(ft), bc_in(s)%smp_sl(j)) + + rresis = min( (bc_in(s)%eff_porosity_sl(j)/bc_in(s)%watsat_sl(j))* & + (smp_node - smpsc(ft)) / (smpso(ft) - smpsc(ft)), 1._r8) + + root_resis(ft,j) = sites(s)%rootfrac_scr(j)*rresis + + ! root water uptake is not linearly proportional to root density, + ! to allow proper deep root funciton. Replace with equations from SPA/Newman. FIX(RF,032414) + + cpatch%btran_ft(ft) = cpatch%btran_ft(ft) + root_resis(ft,j) + + else + root_resis(ft,j) = 0._r8 + end if + + end do !j + + ! Normalize root resistances to get layer contribution to ET + do j = 1,bc_in(s)%nlevsoil + if (cpatch%btran_ft(ft) > nearzero) then + root_resis(ft,j) = root_resis(ft,j)/cpatch%btran_ft(ft) + else + root_resis(ft,j) = 0._r8 + end if + end do + + end do !PFT + + ! PFT-averaged point level root fraction for extraction purposese. + ! The cohort's conductance g_sb_laweighted, contains a weighting factor + ! based on the cohort's leaf area. units: [m/s] * [m2] + + pftgs(1:maxpft) = 0._r8 + ccohort => cpatch%tallest + do while(associated(ccohort)) + pftgs(ccohort%pft) = pftgs(ccohort%pft) + ccohort%g_sb_laweight + ccohort => ccohort%shorter + enddo + + ! Process the boundary output, this is necessary for calculating the soil-moisture + ! sink term across the different layers in driver/host. Photosynthesis will + ! pass the host a total transpiration for the patch. This needs rootr to be + ! distributed over the soil layers. + sum_pftgs = sum(pftgs(1:numpft)) + + do j = 1, bc_in(s)%nlevsoil + bc_out(s)%rootr_pasl(ifp,j) = 0._r8 + do ft = 1,numpft + if( sum_pftgs > 0._r8)then !prevent problem with the first timestep - might fail + !bit-retart test as a result? FIX(RF,032414) + bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j) + & + root_resis(ft,j) * pftgs(ft)/sum_pftgs + else + bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j) + & + root_resis(ft,j) * 1._r8/real(numpft,r8) + end if + enddo + enddo + + ! Calculate the BTRAN that is passed back to the HLM + ! used only for diagnostics. If plant hydraulics is turned off + ! we are using the patchxpft level btran calculation + + if(hlm_use_planthydro.eq.ifalse) then + !weight patch level output BTRAN for the + bc_out(s)%btran_pa(ifp) = 0.0_r8 + do ft = 1,numpft + if( sum_pftgs > 0._r8)then !prevent problem with the first timestep - might fail + !bit-retart test as a result? FIX(RF,032414) + bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * pftgs(ft)/sum_pftgs + else + bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * 1./numpft + end if + enddo + end if + + temprootr = sum(bc_out(s)%rootr_pasl(ifp,1:bc_in(s)%nlevsoil)) + + if(abs(1.0_r8-temprootr) > 1.0e-10_r8 .and. temprootr > 1.0e-10_r8)then + write(fates_log(),*) 'error with rootr in canopy fluxes',temprootr,sum_pftgs + do j = 1,bc_in(s)%nlevsoil + bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j)/temprootr + enddo + end if + endif ! not bare ground + cpatch => cpatch%younger + end do + + deallocate(root_resis) + + end do + + if(hlm_use_planthydro.eq.itrue) then + call BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) + end if + + end associate + +end subroutine btran_ed end module EDBtranMod From b24f4688388e548971030e1fe2f123a7b983ca7f Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 08:55:53 -0700 Subject: [PATCH 170/578] indenting EDPhysiologyMod.F90 --- biogeochem/EDPhysiologyMod.F90 | 1980 ++++++++++++++++---------------- 1 file changed, 990 insertions(+), 990 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 6437566e34..b624167af9 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -105,7 +105,7 @@ module EDPhysiologyMod use PRTLossFluxesMod, only : PRTDeciduousTurnover use PRTLossFluxesMod, only : PRTReproRelease - + public :: trim_canopy public :: phenology @@ -113,21 +113,21 @@ module EDPhysiologyMod public :: assign_cohort_SP_properties public :: recruitment public :: ZeroLitterFluxes - + public :: ZeroAllocationRates public :: PreDisturbanceLitterFluxes public :: PreDisturbanceIntegrateLitter public :: SeedIn - + logical, parameter :: debug = .false. ! local debug flag character(len=*), parameter, private :: sourcefile = & - __FILE__ + __FILE__ integer, parameter :: dleafon_drycheck = 100 ! Drought deciduous leaves max days on check parameter - + ! ============================================================================ contains @@ -153,7 +153,7 @@ subroutine ZeroLitterFluxes( currentSite ) end do currentPatch => currentPatch%older end do - + return end subroutine ZeroLitterFluxes @@ -169,13 +169,13 @@ subroutine ZeroAllocationRates( currentSite ) currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - + currentCohort => currentPatch%tallest do while (associated(currentCohort)) ! This sets turnover and growth rates to zero call currentCohort%prt%ZeroRates() - + currentCohort => currentCohort%shorter enddo currentPatch => currentPatch%older @@ -204,7 +204,7 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! patch areas that are changing. ! ! ----------------------------------------------------------------------------------- - + ! !ARGUMENTS type(ed_site_type), intent(inout) :: currentSite @@ -215,10 +215,10 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! !LOCAL VARIABLES: type(site_massbal_type), pointer :: site_mass type(litter_type), pointer :: litt ! Points to the litter object for - ! the different element types + ! the different element types integer :: el ! Litter element loop index integer :: nlev_eff_decomp ! Number of active layers over which - ! fragmentation fluxes are transfered + ! fragmentation fluxes are transfered !------------------------------------------------------------------------------------ ! Calculate the fragmentation rates @@ -226,21 +226,21 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) do el = 1, num_elements - + litt => currentPatch%litter(el) ! Calculate loss rate of viable seeds to litter call SeedDecay(litt) - + ! Send those decaying seeds in the previous call ! to the litter input flux call SeedDecayToFines(litt) - + ! Calculate seed germination rate, the status flags prevent ! germination from occuring when the site is in a drought ! (for drought deciduous) or too cold (for cold deciduous) call SeedGermination(litt, currentSite%cstatus, currentSite%dstatus) - + ! Send fluxes from newly created litter into the litter pools ! This litter flux is from non-disturbance inducing mortality, as well ! as litter fluxes from live trees @@ -255,15 +255,15 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) site_mass => currentSite%mass_balance(el) - + ! Fragmentation flux to soil decomposition model [kg/site/day] site_mass%frag_out = site_mass%frag_out + currentPatch%area * & ( sum(litt%ag_cwd_frag) + sum(litt%bg_cwd_frag) + & sum(litt%leaf_fines_frag) + sum(litt%root_fines_frag)) - + end do - - + + return end subroutine PreDisturbanceLitterFluxes @@ -304,28 +304,28 @@ subroutine PreDisturbanceIntegrateLitter(currentPatch) integer :: dcmpy ! decomposability index do el = 1, num_elements - + litt => currentPatch%litter(el) - + ! Update the bank of viable seeds ! ----------------------------------------------------------------------------------- - + do pft = 1,numpft litt%seed(pft) = litt%seed(pft) + & - litt%seed_in_local(pft) + & - litt%seed_in_extern(pft) - & - litt%seed_decay(pft) - & - litt%seed_germ_in(pft) + litt%seed_in_local(pft) + & + litt%seed_in_extern(pft) - & + litt%seed_decay(pft) - & + litt%seed_germ_in(pft) ! Note that the recruitment scheme will use seed_germ ! for its construction costs. litt%seed_germ(pft) = litt%seed_germ(pft) + & - litt%seed_germ_in(pft) - & - litt%seed_germ_decay(pft) + litt%seed_germ_in(pft) - & + litt%seed_germ_decay(pft) enddo - + ! Update the Coarse Woody Debris pools (above and below) ! ----------------------------------------------------------------------------------- nlevsoil = size(litt%bg_cwd,dim=2) @@ -337,30 +337,30 @@ subroutine PreDisturbanceIntegrateLitter(currentPatch) - litt%bg_cwd_frag(c,ilyr) enddo end do - + ! Update the fine litter pools from leaves and fine-roots ! ----------------------------------------------------------------------------------- - + do dcmpy = 1,ndcmpy - litt%leaf_fines(dcmpy) = litt%leaf_fines(dcmpy) & - + litt%leaf_fines_in(dcmpy) & - - litt%leaf_fines_frag(dcmpy) - do ilyr=1,nlevsoil - litt%root_fines(dcmpy,ilyr) = litt%root_fines(dcmpy,ilyr) & - + litt%root_fines_in(dcmpy,ilyr) & - - litt%root_fines_frag(dcmpy,ilyr) - enddo + litt%leaf_fines(dcmpy) = litt%leaf_fines(dcmpy) & + + litt%leaf_fines_in(dcmpy) & + - litt%leaf_fines_frag(dcmpy) + do ilyr=1,nlevsoil + litt%root_fines(dcmpy,ilyr) = litt%root_fines(dcmpy,ilyr) & + + litt%root_fines_in(dcmpy,ilyr) & + - litt%root_fines_frag(dcmpy,ilyr) + enddo end do - + end do ! litter element loop - + return end subroutine PreDisturbanceIntegrateLitter - + ! ============================================================================ subroutine trim_canopy( currentSite ) @@ -395,7 +395,7 @@ subroutine trim_canopy( currentSite ) real(r8) :: leaf_inc ! LAI-only portion of the vegetation increment of dinc_ed real(r8) :: lai_canopy_above ! the LAI in the canopy layers above the layer of interest real(r8) :: lai_layers_above ! the LAI in the leaf layers, within the current canopy, - ! above the leaf layer of interest + ! above the leaf layer of interest real(r8) :: lai_current ! the LAI in the current leaf layer real(r8) :: cumulative_lai ! whole canopy cumulative LAI, top down, to the leaf layer of interest real(r8) :: cumulative_lai_cohort ! cumulative LAI within the current cohort only @@ -414,7 +414,7 @@ subroutine trim_canopy( currentSite ) ! m is the slope of the linear fit integer :: nll = 3 ! Number of leaf layers to fit a regression to for calculating the optimum lai character(1) :: trans = 'N' ! Input matrix is not transposed - + integer, parameter :: m = 2, n = 2 ! Number of rows and columns, respectively, in matrix A integer, parameter :: nrhs = 1 ! Number of columns in matrix B and X integer, parameter :: workmax = 100 ! Maximum iterations to minimize work @@ -422,7 +422,7 @@ subroutine trim_canopy( currentSite ) integer :: lda = m, ldb = n ! Leading dimension of A and B, respectively integer :: lwork ! Dimension of work array integer :: info ! Procedure diagnostic ouput - + real(r8) :: nnu_clai_a(m,n) ! LHS of linear least squares fit, A matrix real(r8) :: nnu_clai_b(m,nrhs) ! RHS of linear least squares fit, B matrix real(r8) :: work(workmax) ! work array @@ -438,28 +438,28 @@ subroutine trim_canopy( currentSite ) currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - + ! Add debug diagnstic output to determine which patch if (debug) then write(fates_log(),*) 'Current patch:', ipatch write(fates_log(),*) 'Current patch cohorts:', currentPatch%countcohorts endif - + icohort = 1 - + currentCohort => currentPatch%tallest do while (associated(currentCohort)) - ! Save off the incoming trim and laimemory - initial_trim = currentCohort%canopy_trim - initial_laimem = currentCohort%laimemory + ! Save off the incoming trim and laimemory + initial_trim = currentCohort%canopy_trim + initial_laimem = currentCohort%laimemory ! Add debug diagnstic output to determine which cohort if (debug) then - write(fates_log(),*) 'Current cohort:', icohort - write(fates_log(),*) 'Starting canopy trim:', initial_trim - write(fates_log(),*) 'Starting laimemory:', currentCohort%laimemory - endif + write(fates_log(),*) 'Current cohort:', icohort + write(fates_log(),*) 'Starting canopy trim:', initial_trim + write(fates_log(),*) 'Starting laimemory:', currentCohort%laimemory + endif trimmed = .false. ipft = currentCohort%pft @@ -468,20 +468,20 @@ subroutine trim_canopy( currentSite ) leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & - currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & - currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai, currentCohort%treelai, & - currentCohort%vcmax25top,0 ) + currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai, currentCohort%treelai, & + currentCohort%vcmax25top,0 ) currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) if (currentCohort%nv > nlevleaf)then write(fates_log(),*) 'nv > nlevleaf',currentCohort%nv, & - currentCohort%treelai,currentCohort%treesai, & - currentCohort%c_area,currentCohort%n,leaf_c + currentCohort%treelai,currentCohort%treesai, & + currentCohort%c_area,currentCohort%n,leaf_c call endrun(msg=errMsg(sourcefile, __LINE__)) endif @@ -495,22 +495,22 @@ subroutine trim_canopy( currentSite ) ! Identify current canopy layer (cl) cl = currentCohort%canopy_layer - + ! PFT-level maximum SLA value, even if under a thick canopy (same units as slatop) sla_max = prt_params%slamax(ipft) ! Initialize nnu_clai_a nnu_clai_a(:,:) = 0._r8 nnu_clai_b(:,:) = 0._r8 - + !Leaf cost vs netuptake for each leaf layer. do z = 1, currentCohort%nv ! Calculate the cumulative total vegetation area index (no snow occlusion, stems and leaves) leaf_inc = dinc_ed * & - currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) - + currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) + ! Now calculate the cumulative top-down lai of the current layer's midpoint within the current cohort lai_layers_above = leaf_inc * (z-1) lai_current = min(leaf_inc, currentCohort%treelai - lai_layers_above) @@ -522,7 +522,7 @@ subroutine trim_canopy( currentSite ) ! There was activity this year in this leaf layer. This should only occur for bottom most leaf layer if (currentCohort%year_net_uptake(z) /= 999._r8)then - + ! Calculate sla_levleaf following the sla profile with overlying leaf area ! Scale for leaf nitrogen profile kn = decay_coeff_kn(ipft,currentCohort%vcmax25top) @@ -534,7 +534,7 @@ subroutine trim_canopy( currentSite ) if(sla_levleaf > sla_max)then sla_levleaf = sla_max end if - + !Leaf Cost kgC/m2/year-1 !decidous costs. if (prt_params%season_decid(ipft) == itrue .or. & @@ -552,14 +552,14 @@ subroutine trim_canopy( currentSite ) endif currentCohort%leaf_cost = currentCohort%leaf_cost * & - (prt_params%grperc(ipft) + 1._r8) + (prt_params%grperc(ipft) + 1._r8) else !evergreen costs ! Leaf cost at leaf level z accounting for sla profile currentCohort%leaf_cost = 1.0_r8/(sla_levleaf* & sum(prt_params%leaf_long(ipft,:))*1000.0_r8) !convert from sla in m2g-1 to m2kg-1 - - + + if ( int(prt_params%allom_fmode(ipft)) .eq. 1 ) then ! if using trimmed leaf for fine root biomass allometry, add the cost of the root increment ! to the leaf increment; otherwise do not. @@ -568,7 +568,7 @@ subroutine trim_canopy( currentSite ) bfr_per_bleaf / prt_params%root_long(ipft) endif currentCohort%leaf_cost = currentCohort%leaf_cost * & - (prt_params%grperc(ipft) + 1._r8) + (prt_params%grperc(ipft) + 1._r8) endif ! Construct the arrays for a least square fit of the net_net_uptake versus the cumulative lai @@ -576,18 +576,18 @@ subroutine trim_canopy( currentSite ) ! leaf layers. if (currentCohort%nv > nll .and. currentCohort%nv - z < nll) then - ! Build the A matrix for the LHS of the linear system. A = [n sum(x); sum(x) sum(x^2)] - ! where n = nll and x = yearly_net_uptake-leafcost - nnu_clai_a(1,1) = nnu_clai_a(1,1) + 1 ! Increment for each layer used - nnu_clai_a(1,2) = nnu_clai_a(1,2) + currentCohort%year_net_uptake(z) - currentCohort%leaf_cost - nnu_clai_a(2,1) = nnu_clai_a(1,2) - nnu_clai_a(2,2) = nnu_clai_a(2,2) + (currentCohort%year_net_uptake(z) - currentCohort%leaf_cost)**2 - - ! Build the B matrix for the RHS of the linear system. B = [sum(y); sum(x*y)] - ! where x = yearly_net_uptake-leafcost and y = cumulative_lai_cohort - nnu_clai_b(1,1) = nnu_clai_b(1,1) + cumulative_lai_cohort - nnu_clai_b(2,1) = nnu_clai_b(2,1) + (cumulative_lai_cohort * & - (currentCohort%year_net_uptake(z) - currentCohort%leaf_cost)) + ! Build the A matrix for the LHS of the linear system. A = [n sum(x); sum(x) sum(x^2)] + ! where n = nll and x = yearly_net_uptake-leafcost + nnu_clai_a(1,1) = nnu_clai_a(1,1) + 1 ! Increment for each layer used + nnu_clai_a(1,2) = nnu_clai_a(1,2) + currentCohort%year_net_uptake(z) - currentCohort%leaf_cost + nnu_clai_a(2,1) = nnu_clai_a(1,2) + nnu_clai_a(2,2) = nnu_clai_a(2,2) + (currentCohort%year_net_uptake(z) - currentCohort%leaf_cost)**2 + + ! Build the B matrix for the RHS of the linear system. B = [sum(y); sum(x*y)] + ! where x = yearly_net_uptake-leafcost and y = cumulative_lai_cohort + nnu_clai_b(1,1) = nnu_clai_b(1,1) + cumulative_lai_cohort + nnu_clai_b(2,1) = nnu_clai_b(2,1) + (cumulative_lai_cohort * & + (currentCohort%year_net_uptake(z) - currentCohort%leaf_cost)) end if ! Check leaf cost against the yearly net uptake for that cohort leaf layer @@ -595,18 +595,18 @@ subroutine trim_canopy( currentSite ) ! Make sure the cohort trim fraction is great than the pft trim limit if (currentCohort%canopy_trim > EDPftvarcon_inst%trim_limit(ipft)) then - ! if ( debug ) then - ! write(fates_log(),*) 'trimming leaves', & - ! currentCohort%canopy_trim,currentCohort%leaf_cost - ! endif + ! if ( debug ) then + ! write(fates_log(),*) 'trimming leaves', & + ! currentCohort%canopy_trim,currentCohort%leaf_cost + ! endif ! keep trimming until none of the canopy is in negative carbon balance. if (currentCohort%hite > EDPftvarcon_inst%hgt_min(ipft)) then currentCohort%canopy_trim = currentCohort%canopy_trim - & - EDPftvarcon_inst%trim_inc(ipft) + EDPftvarcon_inst%trim_inc(ipft) if (prt_params%evergreen(ipft) /= 1)then currentCohort%laimemory = currentCohort%laimemory * & - (1.0_r8 - EDPftvarcon_inst%trim_inc(ipft)) + (1.0_r8 - EDPftvarcon_inst%trim_inc(ipft)) endif trimmed = .true. @@ -620,55 +620,55 @@ subroutine trim_canopy( currentSite ) ! Compute the optimal cumulative lai based on the cohort net-net uptake profile if at least 2 leaf layers if (nnu_clai_a(1,1) > 1) then - ! Compute the optimum size of the work array - lwork = -1 ! Ask sgels to compute optimal number of entries for work - call dgels(trans, m, n, nrhs, nnu_clai_a, lda, nnu_clai_b, ldb, work, lwork, info) - lwork = int(work(1)) ! Pick the optimum. TBD, can work(1) come back with greater than work size? - - ! if (debug) then - ! write(fates_log(),*) 'LLSF lwork output (info, lwork):', info, lwork - ! endif - - ! Compute the minimum of 2-norm of of the least squares fit to solve for X - ! Note that dgels returns the solution by overwriting the nnu_clai_b array. - ! The result has the form: X = [b; m] - ! where b = y-intercept (i.e. the cohort lai that has zero yearly net-net uptake) - ! and m is the slope of the linear fit - call dgels(trans, m, n, nrhs, nnu_clai_a, lda, nnu_clai_b, ldb, work, lwork, info) - - if (info < 0) then - write(fates_log(),*) 'LLSF optimium LAI calculation returned illegal value' - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - - if (debug) then - write(fates_log(),*) 'LLSF optimium LAI (intercept,slope):', nnu_clai_b - write(fates_log(),*) 'LLSF optimium LAI:', nnu_clai_b(1,1) - write(fates_log(),*) 'LLSF optimium LAI info:', info - write(fates_log(),*) 'LAI fraction (optimum_lai/cumulative_lai):', nnu_clai_b(1,1) / cumulative_lai_cohort - endif - - ! Calculate the optimum trim based on the initial canopy trim value - if (cumulative_lai_cohort > 0._r8) then ! Sometime cumulative_lai comes in at 0.0? - - ! - optimum_trim = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_trim - optimum_laimem = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_laimem - - ! Determine if the optimum trim value makes sense. The smallest cohorts tend to have unrealistic fits. - if (optimum_trim > 0. .and. optimum_trim < 1.) then - currentCohort%canopy_trim = optimum_trim - - ! If the cohort pft is not evergreen we reduce the laimemory as well - if (prt_params%evergreen(ipft) /= 1) then - currentCohort%laimemory = optimum_laimem - endif + ! Compute the optimum size of the work array + lwork = -1 ! Ask sgels to compute optimal number of entries for work + call dgels(trans, m, n, nrhs, nnu_clai_a, lda, nnu_clai_b, ldb, work, lwork, info) + lwork = int(work(1)) ! Pick the optimum. TBD, can work(1) come back with greater than work size? + + ! if (debug) then + ! write(fates_log(),*) 'LLSF lwork output (info, lwork):', info, lwork + ! endif + + ! Compute the minimum of 2-norm of of the least squares fit to solve for X + ! Note that dgels returns the solution by overwriting the nnu_clai_b array. + ! The result has the form: X = [b; m] + ! where b = y-intercept (i.e. the cohort lai that has zero yearly net-net uptake) + ! and m is the slope of the linear fit + call dgels(trans, m, n, nrhs, nnu_clai_a, lda, nnu_clai_b, ldb, work, lwork, info) + + if (info < 0) then + write(fates_log(),*) 'LLSF optimium LAI calculation returned illegal value' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + if (debug) then + write(fates_log(),*) 'LLSF optimium LAI (intercept,slope):', nnu_clai_b + write(fates_log(),*) 'LLSF optimium LAI:', nnu_clai_b(1,1) + write(fates_log(),*) 'LLSF optimium LAI info:', info + write(fates_log(),*) 'LAI fraction (optimum_lai/cumulative_lai):', nnu_clai_b(1,1) / cumulative_lai_cohort + endif + + ! Calculate the optimum trim based on the initial canopy trim value + if (cumulative_lai_cohort > 0._r8) then ! Sometime cumulative_lai comes in at 0.0? + + ! + optimum_trim = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_trim + optimum_laimem = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_laimem + + ! Determine if the optimum trim value makes sense. The smallest cohorts tend to have unrealistic fits. + if (optimum_trim > 0. .and. optimum_trim < 1.) then + currentCohort%canopy_trim = optimum_trim + + ! If the cohort pft is not evergreen we reduce the laimemory as well + if (prt_params%evergreen(ipft) /= 1) then + currentCohort%laimemory = optimum_laimem + endif - trimmed = .true. + trimmed = .true. - endif - endif - endif + endif + endif + endif ! Reset activity for the cohort for the start of the next year currentCohort%year_net_uptake(:) = 999.0_r8 @@ -676,12 +676,12 @@ subroutine trim_canopy( currentSite ) ! Add to trim fraction if cohort not trimmed at all if ( (.not.trimmed) .and.currentCohort%canopy_trim < 1.0_r8)then currentCohort%canopy_trim = currentCohort%canopy_trim + EDPftvarcon_inst%trim_inc(ipft) - endif + endif if ( debug ) then write(fates_log(),*) 'trimming:',currentCohort%canopy_trim endif - + ! currentCohort%canopy_trim = 1.0_r8 !FIX(RF,032414) this turns off ctrim for now. currentCohort => currentCohort%shorter icohort = icohort + 1 @@ -703,7 +703,7 @@ subroutine phenology( currentSite, bc_in ) use EDParamsMod, only : ED_val_phen_drought_threshold, ED_val_phen_doff_time use EDParamsMod, only : ED_val_phen_a, ED_val_phen_b, ED_val_phen_c, ED_val_phen_chiltemp use EDParamsMod, only : ED_val_phen_mindayson, ED_val_phen_ncolddayslim, ED_val_phen_coldtemp - + ! ! !ARGUMENTS: @@ -730,7 +730,7 @@ subroutine phenology( currentSite, bc_in ) real(r8) :: struct_c ! structure carbon [kg] real(r8) :: gdd_threshold ! GDD accumulation function, integer :: ilayer_swater ! Layer index for soil water - ! which also depends on chilling days. + ! which also depends on chilling days. integer :: ncdstart ! beginning of counting period for chilling degree days. integer :: gddstart ! beginning of counting period for growing degree days. real(r8) :: temp_in_C ! daily averaged temperature in celcius @@ -738,16 +738,16 @@ subroutine phenology( currentSite, bc_in ) integer, parameter :: canopy_leaf_lifespan = 365 ! Maximum lifespan of drought decid leaves integer, parameter :: min_daysoff_dforcedflush = 30 ! THis is the number of days that must had elapsed - ! since leaves had dropped, in order to forcably - ! flush leaves again. This does not impact flushing - ! due to real moisture constraints, and will prevent - ! drought deciduous in perennially wet environments - ! that have been forced to drop their leaves, from - ! flushing them back immediately. + ! since leaves had dropped, in order to forcably + ! flush leaves again. This does not impact flushing + ! due to real moisture constraints, and will prevent + ! drought deciduous in perennially wet environments + ! that have been forced to drop their leaves, from + ! flushing them back immediately. real(r8),parameter :: dphen_soil_depth = 0.1 ! Use liquid soil water that is - ! closest to this depth [m] - + ! closest to this depth [m] + ! This is the integer model day. The first day of the simulation is 1, and it ! continues monotonically, indefinitely model_day_int = nint(hlm_model_day) @@ -769,8 +769,8 @@ subroutine phenology( currentSite, bc_in ) cpatch => cpatch%younger end do temp_in_C = temp_in_C * area_inv - tfrz - - + + !-----------------Cold Phenology--------------------! !Zero growing degree and chilling day counters @@ -781,7 +781,7 @@ subroutine phenology( currentSite, bc_in ) ncdstart = 120 !Southern Hemisphere beginning May gddstart = 181 !Northern Hemisphere begining July endif - + ! Count the number of chilling days over a seasonal window. ! For comparing against GDD, we start calculating chilling ! in the late autumn. @@ -823,25 +823,25 @@ subroutine phenology( currentSite, bc_in ) 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 ! beginnning of the accumulation period, to prevend erroneous autumn leaf flushing. if(model_day_int>365)then !only do this after the first year to prevent odd behaviour - if(currentSite%lat .gt. 0.0_r8)then !Northern Hemisphere - ! In the north, don't accumulate when we are past the leaf fall date. - ! Accumulation starts on day 1 of year in NH. - ! The 180 is to prevent going into an 'always off' state after initialization - if( model_day_int .gt. currentSite%cleafoffdate.and.hlm_day_of_year.gt.180)then ! - currentSite%grow_deg_days = 0._r8 - endif - else !Southern Hemisphere - ! In the South, don't accumulate after the leaf off date, and before the start of - ! the accumulation phase (day 181). - if(model_day_int .gt. currentSite%cleafoffdate.and.hlm_day_of_year.lt.gddstart) then! - currentSite%grow_deg_days = 0._r8 - endif - endif + if(currentSite%lat .gt. 0.0_r8)then !Northern Hemisphere + ! In the north, don't accumulate when we are past the leaf fall date. + ! Accumulation starts on day 1 of year in NH. + ! The 180 is to prevent going into an 'always off' state after initialization + if( model_day_int .gt. currentSite%cleafoffdate.and.hlm_day_of_year.gt.180)then ! + currentSite%grow_deg_days = 0._r8 + endif + else !Southern Hemisphere + ! In the South, don't accumulate after the leaf off date, and before the start of + ! the accumulation phase (day 181). + if(model_day_int .gt. currentSite%cleafoffdate.and.hlm_day_of_year.lt.gddstart) then! + currentSite%grow_deg_days = 0._r8 + endif + endif endif !year1 ! Calculate the number of days since the leaves last came on @@ -871,7 +871,7 @@ subroutine phenology( currentSite, bc_in ) ! preventing them from competing if ( (currentSite%cstatus == phen_cstat_iscold .or. & - currentSite%cstatus == phen_cstat_nevercold) .and. & + currentSite%cstatus == phen_cstat_nevercold) .and. & (currentSite%grow_deg_days > gdd_threshold) .and. & (dayssincecleafoff > ED_val_phen_mindayson) .and. & (currentSite%nchilldays >= 1)) then @@ -892,23 +892,23 @@ subroutine phenology( currentSite, bc_in ) !3) The leaves should not be off already !4) The day of simulation should be larger than the counting period. - + if ( (currentSite%cstatus == phen_cstat_notcold) .and. & (model_day_int > num_vegtemp_mem) .and. & (ncolddays > ED_val_phen_ncolddayslim) .and. & (dayssincecleafon > ED_val_phen_mindayson) )then - + currentSite%grow_deg_days = 0._r8 ! The equations for Botta et al - ! are for calculations of - ! first flush, but if we dont - ! clear this value, it will cause - ! leaves to flush later in the year + ! are for calculations of + ! first flush, but if we dont + ! clear this value, it will cause + ! leaves to flush later in the year currentSite%cstatus = phen_cstat_iscold ! alter status of site to 'leaves off' currentSite%cleafoffdate = model_day_int ! record leaf off date if ( debug ) write(fates_log(),*) 'leaves off' endif - + ! LEAF OFF: COLD LIFESPAN THRESHOLD ! NOTE: Some areas of the planet will never generate a cold day ! and thus %nchilldays will never go from zero to 1. The following logic @@ -916,15 +916,15 @@ subroutine phenology( currentSite, bc_in ) ! plants from re-emerging in areas without at least some cold days if( (currentSite%cstatus == phen_cstat_notcold) .and. & - (dayssincecleafoff > 400)) then ! remove leaves after a whole year - ! when there is no 'off' period. + (dayssincecleafoff > 400)) then ! remove leaves after a whole year + ! when there is no 'off' period. currentSite%grow_deg_days = 0._r8 currentSite%cstatus = phen_cstat_nevercold ! alter status of site to imply that this - ! site is never really cold enough - ! for cold deciduous + ! site is never really cold enough + ! for cold deciduous currentSite%cleafoffdate = model_day_int ! record leaf off date - + if ( debug ) write(fates_log(),*) 'leaves off' endif @@ -979,7 +979,7 @@ subroutine phenology( currentSite, bc_in ) else dayssincedleafoff = model_day_int - currentSite%dleafoffdate endif - + ! the leaves are on. How long have they been on? if (model_day_int < currentSite%dleafondate) then dayssincedleafon = model_day_int - (currentSite%dleafondate-365) @@ -990,7 +990,7 @@ subroutine phenology( currentSite, bc_in ) ! LEAF ON: DROUGHT DECIDUOUS WETNESS ! Here, we used a window of oppurtunity to determine if we are ! close to the time when then leaves came on last year - + ! Has it been ... ! a) a year, plus or minus 1 month since we last had leaf-on? ! b) Has there also been at least a nominaly short amount of "leaf-off" @@ -998,15 +998,15 @@ subroutine phenology( currentSite, bc_in ) ! Note that cold-starts begin in the "leaf-on" ! status if ( (currentSite%dstatus == phen_dstat_timeoff .or. & - currentSite%dstatus == phen_dstat_moistoff) .and. & - (model_day_int > numWaterMem) .and. & - (dayssincedleafon >= 365-30 .and. dayssincedleafon <= 365+30 ) .and. & - (dayssincedleafoff > ED_val_phen_doff_time) ) then + currentSite%dstatus == phen_dstat_moistoff) .and. & + (model_day_int > numWaterMem) .and. & + (dayssincedleafon >= 365-30 .and. dayssincedleafon <= 365+30 ) .and. & + (dayssincedleafoff > ED_val_phen_doff_time) ) then ! If leaves are off, and have been off for at least a few days ! and the time is consistent with the correct ! time window... test if the moisture conditions allow for leaf-on - + if ( mean_10day_liqvol >= ED_val_phen_drought_threshold ) then currentSite%dstatus = phen_dstat_moiston ! set status to leaf-on currentSite%dleafondate = model_day_int ! save the model day we start flushing @@ -1047,17 +1047,17 @@ subroutine phenology( currentSite, bc_in ) ! i.e. Are the leaves rouhgly at the end of their lives? if ( (currentSite%dstatus == phen_dstat_moiston .or. & - currentSite%dstatus == phen_dstat_timeon ) .and. & + currentSite%dstatus == phen_dstat_timeon ) .and. & (dayssincedleafon > canopy_leaf_lifespan) )then - currentSite%dstatus = phen_dstat_timeoff !alter status of site to 'leaves off' - currentSite%dleafoffdate = model_day_int !record leaf on date + currentSite%dstatus = phen_dstat_timeoff !alter status of site to 'leaves off' + currentSite%dleafoffdate = model_day_int !record leaf on date endif ! LEAF OFF: DROUGHT DECIDUOUS DRYNESS - if the soil gets too dry, ! and the leaves have already been on a while... if ( (currentSite%dstatus == phen_dstat_moiston .or. & - currentSite%dstatus == phen_dstat_timeon ) .and. & + currentSite%dstatus == phen_dstat_timeon ) .and. & (model_day_int > numWaterMem) .and. & (mean_10day_liqvol <= ED_val_phen_drought_threshold) .and. & (dayssincedleafon > dleafon_drycheck ) ) then @@ -1113,9 +1113,9 @@ subroutine phenology_leafonoff(currentSite) leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) sapw_c = currentCohort%prt%GetState(sapw_organ, all_carbon_elements) struct_c = currentCohort%prt%GetState(struct_organ, all_carbon_elements) - + stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(ipft) - + ! COLD LEAF ON ! The site level flags signify that it is no-longer too cold ! for leaves. Time to signal flushing @@ -1124,215 +1124,215 @@ subroutine phenology_leafonoff(currentSite) if ( currentSite%cstatus == phen_cstat_notcold )then ! we have just moved to leaves being on . if (currentCohort%status_coh == leaves_off)then ! Are the leaves currently off? currentCohort%status_coh = leaves_on ! Leaves are on, so change status to - ! stop flow of carbon out of bstore. - + ! stop flow of carbon out of bstore. + if(store_c>nearzero) then - ! flush either the amount required from the laimemory, or -most- of the storage pool - ! RF: added a criterion to stop the entire store pool emptying and triggering termination mortality - ! n.b. this might not be necessary if we adopted a more gradual approach to leaf flushing... - store_c_transfer_frac = min((EDPftvarcon_inst%phenflush_fraction(ipft)* & - currentCohort%laimemory)/store_c,(1.0_r8-carbon_store_buffer)) - - if(prt_params%woody(ipft).ne.itrue)then - totalmemory=currentCohort%laimemory+currentCohort%sapwmemory+currentCohort%structmemory - store_c_transfer_frac = min((EDPftvarcon_inst%phenflush_fraction(ipft)* & - totalmemory)/store_c, (1.0_r8-carbon_store_buffer)) - endif - + ! flush either the amount required from the laimemory, or -most- of the storage pool + ! RF: added a criterion to stop the entire store pool emptying and triggering termination mortality + ! n.b. this might not be necessary if we adopted a more gradual approach to leaf flushing... + store_c_transfer_frac = min((EDPftvarcon_inst%phenflush_fraction(ipft)* & + currentCohort%laimemory)/store_c,(1.0_r8-carbon_store_buffer)) + + if(prt_params%woody(ipft).ne.itrue)then + totalmemory=currentCohort%laimemory+currentCohort%sapwmemory+currentCohort%structmemory + store_c_transfer_frac = min((EDPftvarcon_inst%phenflush_fraction(ipft)* & + totalmemory)/store_c, (1.0_r8-carbon_store_buffer)) + endif + else store_c_transfer_frac = 0.0_r8 end if ! This call will request that storage carbon will be transferred to ! leaf tissues. It is specified as a fraction of the available storage - if(prt_params%woody(ipft) == itrue) then + if(prt_params%woody(ipft) == itrue) then - call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, store_c_transfer_frac) - currentCohort%laimemory = 0.0_r8 + call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, store_c_transfer_frac) + currentCohort%laimemory = 0.0_r8 - else - - ! Check that the stem drop fraction is set to non-zero amount otherwise flush all carbon store to leaves - if (stem_drop_fraction .gt. 0.0_r8) then + else + + ! Check that the stem drop fraction is set to non-zero amount otherwise flush all carbon store to leaves + if (stem_drop_fraction .gt. 0.0_r8) then + + call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & + store_c_transfer_frac*currentCohort%laimemory/totalmemory) + + call PRTPhenologyFlush(currentCohort%prt, ipft, sapw_organ, & + store_c_transfer_frac*currentCohort%sapwmemory/totalmemory) - call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac*currentCohort%laimemory/totalmemory) + call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & + store_c_transfer_frac*currentCohort%structmemory/totalmemory) - call PRTPhenologyFlush(currentCohort%prt, ipft, sapw_organ, & - store_c_transfer_frac*currentCohort%sapwmemory/totalmemory) + else - call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & - store_c_transfer_frac*currentCohort%structmemory/totalmemory) + call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & + store_c_transfer_frac) - else + end if - call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac) + currentCohort%laimemory = 0.0_r8 + currentCohort%structmemory = 0.0_r8 + currentCohort%sapwmemory = 0.0_r8 - end if - - currentCohort%laimemory = 0.0_r8 - currentCohort%structmemory = 0.0_r8 - currentCohort%sapwmemory = 0.0_r8 - - endif + endif endif !pft phenology endif ! growing season !COLD LEAF OFF if (currentSite%cstatus == phen_cstat_nevercold .or. & - currentSite%cstatus == phen_cstat_iscold) then ! past leaf drop day? Leaves still on tree? + currentSite%cstatus == phen_cstat_iscold) then ! past leaf drop day? Leaves still on tree? if (currentCohort%status_coh == leaves_on) then ! leaves have not dropped - ! leaf off occur on individuals bigger than specific size for grass - if (currentCohort%dbh > EDPftvarcon_inst%phen_cold_size_threshold(ipft) & - .or. prt_params%woody(ipft)==itrue) then - - ! This sets the cohort to the "leaves off" flag - currentCohort%status_coh = leaves_off + ! leaf off occur on individuals bigger than specific size for grass + if (currentCohort%dbh > EDPftvarcon_inst%phen_cold_size_threshold(ipft) & + .or. prt_params%woody(ipft)==itrue) then - ! Remember what the lai was (leaf mass actually) was for next year - ! the same amount back on in the spring... + ! This sets the cohort to the "leaves off" flag + currentCohort%status_coh = leaves_off - currentCohort%laimemory = leaf_c + ! Remember what the lai was (leaf mass actually) was for next year + ! the same amount back on in the spring... - ! Drop Leaves (this routine will update the leaf state variables, - ! for carbon and any other element that are prognostic. It will - ! also track the turnover masses that will be sent to litter later on) + currentCohort%laimemory = leaf_c - call PRTDeciduousTurnover(currentCohort%prt,ipft, & - leaf_organ, leaf_drop_fraction) - - if(prt_params%woody(ipft).ne.itrue)then - - currentCohort%sapwmemory = sapw_c * stem_drop_fraction - - currentCohort%structmemory = struct_c * stem_drop_fraction - - call PRTDeciduousTurnover(currentCohort%prt,ipft, & + ! Drop Leaves (this routine will update the leaf state variables, + ! for carbon and any other element that are prognostic. It will + ! also track the turnover masses that will be sent to litter later on) + + call PRTDeciduousTurnover(currentCohort%prt,ipft, & + leaf_organ, leaf_drop_fraction) + + if(prt_params%woody(ipft).ne.itrue)then + + currentCohort%sapwmemory = sapw_c * stem_drop_fraction + + currentCohort%structmemory = struct_c * stem_drop_fraction + + call PRTDeciduousTurnover(currentCohort%prt,ipft, & sapw_organ, stem_drop_fraction) - call PRTDeciduousTurnover(currentCohort%prt,ipft, & + call PRTDeciduousTurnover(currentCohort%prt,ipft, & struct_organ, stem_drop_fraction) - endif ! woody plant check - endif ! individual dbh size check - endif !leaf status - endif !currentSite status - endif !season_decid + endif ! woody plant check + endif ! individual dbh size check + endif !leaf status + endif !currentSite status + endif !season_decid ! DROUGHT LEAF ON ! Site level flag indicates it is no longer in drought condition ! deciduous plants can flush if (prt_params%stress_decid(ipft) == itrue )then - - if (currentSite%dstatus == phen_dstat_moiston .or. & - currentSite%dstatus == phen_dstat_timeon )then - ! we have just moved to leaves being on . - if (currentCohort%status_coh == leaves_off)then + if (currentSite%dstatus == phen_dstat_moiston .or. & + currentSite%dstatus == phen_dstat_timeon )then + + ! we have just moved to leaves being on . + if (currentCohort%status_coh == leaves_off)then !is it the leaf-on day? Are the leaves currently off? - currentCohort%status_coh = leaves_on ! Leaves are on, so change status to - ! stop flow of carbon out of bstore. + currentCohort%status_coh = leaves_on ! Leaves are on, so change status to + ! stop flow of carbon out of bstore. - if(store_c>nearzero) then + if(store_c>nearzero) then + + store_c_transfer_frac = & + min(EDPftvarcon_inst%phenflush_fraction(ipft)*currentCohort%laimemory, store_c)/store_c - store_c_transfer_frac = & - min(EDPftvarcon_inst%phenflush_fraction(ipft)*currentCohort%laimemory, store_c)/store_c + if(prt_params%woody(ipft).ne.itrue)then - if(prt_params%woody(ipft).ne.itrue)then - - totalmemory=currentCohort%laimemory+currentCohort%sapwmemory+currentCohort%structmemory - store_c_transfer_frac = min(EDPftvarcon_inst%phenflush_fraction(ipft)* & - totalmemory, store_c)/store_c + totalmemory=currentCohort%laimemory+currentCohort%sapwmemory+currentCohort%structmemory + store_c_transfer_frac = min(EDPftvarcon_inst%phenflush_fraction(ipft)* & + totalmemory, store_c)/store_c - endif + endif + + else + store_c_transfer_frac = 0.0_r8 + endif - else - store_c_transfer_frac = 0.0_r8 - endif - ! This call will request that storage carbon will be transferred to ! leaf tissues. It is specified as a fraction of the available storage - if(prt_params%woody(ipft) == itrue) then - - call PRTPhenologyFlush(currentCohort%prt, ipft, & - leaf_organ, store_c_transfer_frac) - - currentCohort%laimemory = 0.0_r8 - - else - - ! Check that the stem drop fraction is set to non-zero amount otherwise flush all carbon store to leaves - if (stem_drop_fraction .gt. 0.0_r8) then - - call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac*currentCohort%laimemory/totalmemory) - - call PRTPhenologyFlush(currentCohort%prt, ipft, sapw_organ, & - store_c_transfer_frac*currentCohort%sapwmemory/totalmemory) - - call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & - store_c_transfer_frac*currentCohort%structmemory/totalmemory) - - else - - call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac) - - end if - - currentCohort%laimemory = 0.0_r8 - currentCohort%structmemory = 0.0_r8 - currentCohort%sapwmemory = 0.0_r8 - - endif ! woody plant check - endif !currentCohort status again? - endif !currentSite status - - !DROUGHT LEAF OFF - if (currentSite%dstatus == phen_dstat_moistoff .or. & - currentSite%dstatus == phen_dstat_timeoff) then - - if (currentCohort%status_coh == leaves_on) then ! leaves have not dropped - - ! This sets the cohort to the "leaves off" flag - currentCohort%status_coh = leaves_off - - ! Remember what the lai (leaf mass actually) was for next year - currentCohort%laimemory = leaf_c - - call PRTDeciduousTurnover(currentCohort%prt,ipft, & + if(prt_params%woody(ipft) == itrue) then + + call PRTPhenologyFlush(currentCohort%prt, ipft, & + leaf_organ, store_c_transfer_frac) + + currentCohort%laimemory = 0.0_r8 + + else + + ! Check that the stem drop fraction is set to non-zero amount otherwise flush all carbon store to leaves + if (stem_drop_fraction .gt. 0.0_r8) then + + call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & + store_c_transfer_frac*currentCohort%laimemory/totalmemory) + + call PRTPhenologyFlush(currentCohort%prt, ipft, sapw_organ, & + store_c_transfer_frac*currentCohort%sapwmemory/totalmemory) + + call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & + store_c_transfer_frac*currentCohort%structmemory/totalmemory) + + else + + call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & + store_c_transfer_frac) + + end if + + currentCohort%laimemory = 0.0_r8 + currentCohort%structmemory = 0.0_r8 + currentCohort%sapwmemory = 0.0_r8 + + endif ! woody plant check + endif !currentCohort status again? + endif !currentSite status + + !DROUGHT LEAF OFF + if (currentSite%dstatus == phen_dstat_moistoff .or. & + currentSite%dstatus == phen_dstat_timeoff) then + + if (currentCohort%status_coh == leaves_on) then ! leaves have not dropped + + ! This sets the cohort to the "leaves off" flag + currentCohort%status_coh = leaves_off + + ! Remember what the lai (leaf mass actually) was for next year + currentCohort%laimemory = leaf_c + + call PRTDeciduousTurnover(currentCohort%prt,ipft, & leaf_organ, leaf_drop_fraction) - - if(prt_params%woody(ipft).ne.itrue)then - - currentCohort%sapwmemory = sapw_c * stem_drop_fraction - currentCohort%structmemory = struct_c * stem_drop_fraction - call PRTDeciduousTurnover(currentCohort%prt,ipft, & - sapw_organ, stem_drop_fraction) + if(prt_params%woody(ipft).ne.itrue)then - call PRTDeciduousTurnover(currentCohort%prt,ipft, & - struct_organ, stem_drop_fraction) - endif + currentCohort%sapwmemory = sapw_c * stem_drop_fraction + currentCohort%structmemory = struct_c * stem_drop_fraction - endif - endif !status - endif !drought dec. + call PRTDeciduousTurnover(currentCohort%prt,ipft, & + sapw_organ, stem_drop_fraction) - if(debug) call currentCohort%prt%CheckMassConservation(ipft,1) + call PRTDeciduousTurnover(currentCohort%prt,ipft, & + struct_organ, stem_drop_fraction) + endif + + endif + endif !status + endif !drought dec. - currentCohort => currentCohort%shorter - enddo !currentCohort + if(debug) call currentCohort%prt%CheckMassConservation(ipft,1) - currentPatch => currentPatch%younger + currentCohort => currentCohort%shorter + enddo !currentCohort - enddo !currentPatch + currentPatch => currentPatch%younger + + enddo !currentPatch end subroutine phenology_leafonoff @@ -1340,11 +1340,11 @@ end subroutine phenology_leafonoff subroutine satellite_phenology(currentSite, bc_in) - ! ----------------------------------------------------------------------------------- - ! Takes the daily inputs of leaf area index, stem area index and canopy height and - ! translates them into a FATES structure with one patch and one cohort per PFT - ! The leaf area of the cohort is modified each day to match that asserted by the HLM - ! ----------------------------------------------------------------------------------- + ! ----------------------------------------------------------------------------------- + ! Takes the daily inputs of leaf area index, stem area index and canopy height and + ! translates them into a FATES structure with one patch and one cohort per PFT + ! The leaf area of the cohort is modified each day to match that asserted by the HLM + ! ----------------------------------------------------------------------------------- ! !USES: ! @@ -1366,110 +1366,110 @@ subroutine satellite_phenology(currentSite, bc_in) integer :: s ! site index - ! To Do in this routine. - ! Get access to HLM input varialbes. - ! Weight them by PFT - ! Loop around patches, and for each single cohort in each patch - ! call assign_cohort_SP_properties to determine cohort height, dbh, 'n', area, leafc from drivers. - - currentSite%sp_tlai(:) = 0._r8 - currentSite%sp_tsai(:) = 0._r8 - currentSite%sp_htop(:) = 0._r8 - - ! WEIGHTING OF FATES PFTs on to HLM_PFTs - ! 1. Add up the area associated with each FATES PFT - ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) - ! hlm_pft_map is the area of that land in each FATES PFT (from param file) - - ! 2. weight each fates PFT target for lai, sai and htop by the area of the - ! contrbuting HLM PFTs. - - currentPatch => currentSite%oldest_patch - do while (associated(currentPatch)) - - fates_pft = currentPatch%nocomp_pft_label - if(fates_pft.ne.0)then - - do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) - - if(bc_in%pft_areafrac(hlm_pft) * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft).gt.0.0_r8)then - !leaf area index - currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & - bc_in%hlm_sp_tlai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & - * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) - !stem area index - currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & - bc_in%hlm_sp_tsai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & - * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) - ! canopy height - currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) + & - bc_in%hlm_sp_htop(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & - * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) - end if ! there is some area in this patch - end do !hlm_pft - - ! weight for total area in each patch/fates_pft - if(currentPatch%area.gt.0.0_r8)then - currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) & - /(currentPatch%area/area) - currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) & - /(currentPatch%area/area) - currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & - /(currentPatch%area/area) - endif - - end if ! not bare patch - currentPatch => currentPatch%younger - end do ! patch loop - - ! ------------------------------------------------------------ - ! now we have the target lai, sai and htop for each PFT/patch - ! find properties of the cohort that go along with that - ! 1. Find canopy area from HTOP (height) - ! 2. Find 'n' associated with canopy area, given a closed canopy - ! 3. Find 'bleaf' associated with TLAI and canopy area. - ! These things happen in the catchily titled "assign_cohort_SP_properties" routine. - ! ------------------------------------------------------------ - - currentPatch => currentSite%oldest_patch - do while (associated(currentPatch)) - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - - ! FIRST SOME CHECKS. - fates_pft =currentCohort%pft - if(fates_pft.ne.currentPatch%nocomp_pft_label)then ! does this cohort belong in this PFT patch? - write(fates_log(),*) 'wrong PFT label in cohort in SP mode',fates_pft,currentPatch%nocomp_pft_label - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if(fates_pft.eq.0)then - write(fates_log(),*) 'PFT0 in SP mode' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Call routine to invert SP drivers into cohort properites. - call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) - - currentCohort => currentCohort%shorter - end do !cohort loop - currentPatch => currentPatch%younger - end do ! patch loop + ! To Do in this routine. + ! Get access to HLM input varialbes. + ! Weight them by PFT + ! Loop around patches, and for each single cohort in each patch + ! call assign_cohort_SP_properties to determine cohort height, dbh, 'n', area, leafc from drivers. + + currentSite%sp_tlai(:) = 0._r8 + currentSite%sp_tsai(:) = 0._r8 + currentSite%sp_htop(:) = 0._r8 + + ! WEIGHTING OF FATES PFTs on to HLM_PFTs + ! 1. Add up the area associated with each FATES PFT + ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) + ! hlm_pft_map is the area of that land in each FATES PFT (from param file) + + ! 2. weight each fates PFT target for lai, sai and htop by the area of the + ! contrbuting HLM PFTs. + + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) + + fates_pft = currentPatch%nocomp_pft_label + if(fates_pft.ne.0)then + + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + + if(bc_in%pft_areafrac(hlm_pft) * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft).gt.0.0_r8)then + !leaf area index + currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & + bc_in%hlm_sp_tlai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & + * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) + !stem area index + currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & + bc_in%hlm_sp_tsai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & + * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) + ! canopy height + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) + & + bc_in%hlm_sp_htop(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & + * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) + end if ! there is some area in this patch + end do !hlm_pft + + ! weight for total area in each patch/fates_pft + if(currentPatch%area.gt.0.0_r8)then + currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) & + /(currentPatch%area/area) + currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) & + /(currentPatch%area/area) + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & + /(currentPatch%area/area) + endif + + end if ! not bare patch + currentPatch => currentPatch%younger + end do ! patch loop + + ! ------------------------------------------------------------ + ! now we have the target lai, sai and htop for each PFT/patch + ! find properties of the cohort that go along with that + ! 1. Find canopy area from HTOP (height) + ! 2. Find 'n' associated with canopy area, given a closed canopy + ! 3. Find 'bleaf' associated with TLAI and canopy area. + ! These things happen in the catchily titled "assign_cohort_SP_properties" routine. + ! ------------------------------------------------------------ + + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + + ! FIRST SOME CHECKS. + fates_pft =currentCohort%pft + if(fates_pft.ne.currentPatch%nocomp_pft_label)then ! does this cohort belong in this PFT patch? + write(fates_log(),*) 'wrong PFT label in cohort in SP mode',fates_pft,currentPatch%nocomp_pft_label + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(fates_pft.eq.0)then + write(fates_log(),*) 'PFT0 in SP mode' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Call routine to invert SP drivers into cohort properites. + call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) + + currentCohort => currentCohort%shorter + end do !cohort loop + currentPatch => currentPatch%younger + end do ! patch loop end subroutine satellite_phenology -! ===================================================================================== + ! ===================================================================================== subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,leaf_c) - ! -----------------------------------------------------------------------------------! - ! Takes the daily inputs of leaf area index, stem area index and canopy height and - ! translates them into a FATES structure with one patch and one cohort per PFT - ! The leaf area of the cohort is modified each day to match that asserted by the HLM - ! -----------------------------------------------------------------------------------! - use EDTypesMod , only : nclmax - + ! -----------------------------------------------------------------------------------! + ! Takes the daily inputs of leaf area index, stem area index and canopy height and + ! translates them into a FATES structure with one patch and one cohort per PFT + ! The leaf area of the cohort is modified each day to match that asserted by the HLM + ! -----------------------------------------------------------------------------------! + use EDTypesMod , only : nclmax + type(ed_cohort_type), intent(inout), target :: currentCohort real(r8), intent(in) :: tlai ! target leaf area index from SP inputs @@ -1487,13 +1487,13 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l real(r8) :: fracerr real(r8) :: oldcarea - ! Do some checks - if(associated(currentCohort%shorter))then - write(fates_log(),*) 'SP mode has >1 cohort' - write(fates_log(),*) "SP mode >1 cohort: PFT",currentCohort%pft, currentCohort%shorter%pft - write(fates_log(),*) "SP mode >1 cohort: CL",currentCohort%canopy_layer, currentCohort%shorter%canopy_layer - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + ! Do some checks + if(associated(currentCohort%shorter))then + write(fates_log(),*) 'SP mode has >1 cohort' + write(fates_log(),*) "SP mode >1 cohort: PFT",currentCohort%pft, currentCohort%shorter%pft + write(fates_log(),*) "SP mode >1 cohort: CL",currentCohort%canopy_layer, currentCohort%shorter%canopy_layer + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if !------------------------------------------ ! Calculate dbh from input height, and c_area from dbh @@ -1503,10 +1503,10 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l fates_pft = currentCohort%pft call h2d_allom(currentCohort%hite,fates_pft,currentCohort%dbh) - dummy_n = 1.0_r8 ! make n=1 to get area of one tree. - spread = 1.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. - ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in - ! SP mode. + dummy_n = 1.0_r8 ! make n=1 to get area of one tree. + spread = 1.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. + ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in + ! SP mode. call carea_allom(currentCohort%dbh,dummy_n,spread,currentCohort%pft,currentCohort%c_area) !------------------------------------------ @@ -1523,46 +1523,46 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l currentCohort%treelai = tlai canopylai(:) = 0._r8 leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& - currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) + currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) !check that the inverse calculation of leafc from treelai is the same as the ! standard calculation of treelai from leafc. Maybe can delete eventually? check_treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & - currentCohort%n, currentCohort%canopy_layer, & - canopylai,currentCohort%vcmax25top ) - - if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzero - write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%treelai-check_treelai - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area - ! these mean that the canopy area does not exactly add up to the patch area, which causes chaos in - ! the radiation routines. Correct both the area and the 'n' to remove error, and don't use + currentCohort%n, currentCohort%canopy_layer, & + canopylai,currentCohort%vcmax25top ) + + if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzero + write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%treelai-check_treelai + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area + ! these mean that the canopy area does not exactly add up to the patch area, which causes chaos in + ! the radiation routines. Correct both the area and the 'n' to remove error, and don't use !! carea_allom in SP mode after this point. - if(abs(currentCohort%c_area-parea).gt.nearzero)then ! there is an error + if(abs(currentCohort%c_area-parea).gt.nearzero)then ! there is an error if(abs(currentCohort%c_area-parea).lt.10.e-9)then !correct this if it's a very small error - oldcarea = currentCohort%c_area - !generate new cohort area - currentCohort%c_area = currentCohort%c_area - (currentCohort%c_area- parea) - currentCohort%n = currentCohort%n * (currentCohort%c_area/oldcarea) - if(abs(currentCohort%c_area-parea).gt.nearzero)then - write(fates_log(),*) 'SPassign, c_area still broken',currentCohort%c_area-parea,currentCohort%c_area-oldcarea - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + oldcarea = currentCohort%c_area + !generate new cohort area + currentCohort%c_area = currentCohort%c_area - (currentCohort%c_area- parea) + currentCohort%n = currentCohort%n * (currentCohort%c_area/oldcarea) + if(abs(currentCohort%c_area-parea).gt.nearzero)then + write(fates_log(),*) 'SPassign, c_area still broken',currentCohort%c_area-parea,currentCohort%c_area-oldcarea + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if else - write(fates_log(),*) 'SPassign, big error in c_area',currentCohort%c_area-parea,currentCohort%pft + write(fates_log(),*) 'SPassign, big error in c_area',currentCohort%c_area-parea,currentCohort%pft end if ! still broken - end if !small error + end if !small error - if(init.eq.ifalse)then + if(init.eq.ifalse)then call SetState(currentCohort%prt,leaf_organ,1,leaf_c,1) - endif - - ! assert sai - currentCohort%treesai = tsai + endif + + ! assert sai + currentCohort%treesai = tsai end subroutine assign_cohort_SP_properties @@ -1608,7 +1608,7 @@ subroutine SeedIn( currentSite, bc_in ) !------------------------------------------------------------------------------------ do el = 1, num_elements - + site_seed_rain(:) = 0._r8 element_id = element_list(el) @@ -1618,12 +1618,12 @@ subroutine SeedIn( currentSite, bc_in ) ! Loop over all patches and sum up the seed input for each PFT currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) - + currentCohort => currentPatch%tallest do while (associated(currentCohort)) - + pft = currentCohort%pft - + ! a certain fraction of bstore might go to clonal reproduction when plants die ! (since this is only applied to the dying portion of the cohort ! we do not actually pair down the storage via PARTEH, instead @@ -1631,8 +1631,8 @@ subroutine SeedIn( currentSite, bc_in ) ! to the litter in CWDInput) ! units = [kg/ha/day] = [kg] * [fraction] * [plants/ha/year] * [year/day] store_m_to_repro = -currentCohort%prt%GetState(store_organ,element_id) * & - EDPftvarcon_inst%allom_frbstor_repro(pft)*currentCohort%dndt*years_per_day - + EDPftvarcon_inst%allom_frbstor_repro(pft)*currentCohort%dndt*years_per_day + ! Transfer all reproductive tissues into seed production ! The following call to PRTReproRelease, will return the mass ! of seeds [kg] released by the plant, per the mass_fraction @@ -1640,18 +1640,18 @@ subroutine SeedIn( currentSite, bc_in ) ! from the parteh state-variable. call PRTReproRelease(currentCohort%prt,repro_organ,element_id, & - 1.0_r8, seed_prod) - + 1.0_r8, seed_prod) + if(element_id==carbon12_element)then - currentcohort%seed_prod = seed_prod + currentcohort%seed_prod = seed_prod end if site_seed_rain(pft) = site_seed_rain(pft) + & - (seed_prod * currentCohort%n + store_m_to_repro) - + (seed_prod * currentCohort%n + store_m_to_repro) + currentCohort => currentCohort%shorter enddo !cohort loop - + currentPatch => currentPatch%younger enddo @@ -1661,8 +1661,8 @@ subroutine SeedIn( currentSite, bc_in ) if ( homogenize_seed_pfts ) then site_seed_rain(1:numpft) = sum(site_seed_rain(:))/real(numpft,r8) end if - - + + ! Loop over all patches again and disperse the mixed seeds into the input flux ! arrays @@ -1674,43 +1674,43 @@ subroutine SeedIn( currentSite, bc_in ) do pft = 1,numpft if(currentSite%use_this_pft(pft).eq.itrue)then - ! Seed input from local sources (within site) - litt%seed_in_local(pft) = litt%seed_in_local(pft) + site_seed_rain(pft)/area - - ! If there is forced external seed rain, we calculate the input mass flux - ! from the different elements, usung the seed optimal stoichiometry - ! for non-carbon - select case(element_id) - case(carbon12_element) - seed_stoich = 1._r8 - case(nitrogen_element) - seed_stoich = prt_params%nitr_stoich_p2(pft,repro_organ) - case(phosphorus_element) - seed_stoich = prt_params%phos_stoich_p2(pft,repro_organ) - case default - write(fates_log(), *) 'undefined element specified' - write(fates_log(), *) 'while defining forced external seed mass flux' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - ! Seed input from external sources (user param seed rain, or dispersal model) - seed_in_external = seed_stoich*EDPftvarcon_inst%seed_suppl(pft)*years_per_day - litt%seed_in_extern(pft) = litt%seed_in_extern(pft) + seed_in_external - - ! Seeds entering externally [kg/site/day] - site_mass%seed_in = site_mass%seed_in + seed_in_external*currentPatch%area - end if !use this pft + ! Seed input from local sources (within site) + litt%seed_in_local(pft) = litt%seed_in_local(pft) + site_seed_rain(pft)/area + + ! If there is forced external seed rain, we calculate the input mass flux + ! from the different elements, usung the seed optimal stoichiometry + ! for non-carbon + select case(element_id) + case(carbon12_element) + seed_stoich = 1._r8 + case(nitrogen_element) + seed_stoich = prt_params%nitr_stoich_p2(pft,repro_organ) + case(phosphorus_element) + seed_stoich = prt_params%phos_stoich_p2(pft,repro_organ) + case default + write(fates_log(), *) 'undefined element specified' + write(fates_log(), *) 'while defining forced external seed mass flux' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + ! Seed input from external sources (user param seed rain, or dispersal model) + seed_in_external = seed_stoich*EDPftvarcon_inst%seed_suppl(pft)*years_per_day + litt%seed_in_extern(pft) = litt%seed_in_extern(pft) + seed_in_external + + ! Seeds entering externally [kg/site/day] + site_mass%seed_in = site_mass%seed_in + seed_in_external*currentPatch%area + end if !use this pft enddo - - + + currentPatch => currentPatch%younger enddo - + end do return end subroutine SeedIn - + ! ============================================================================ subroutine SeedDecay( litt ) @@ -1733,10 +1733,10 @@ subroutine SeedDecay( litt ) do pft = 1,numpft litt%seed_decay(pft) = litt%seed(pft) * & - EDPftvarcon_inst%seed_decay_rate(pft)*years_per_day + EDPftvarcon_inst%seed_decay_rate(pft)*years_per_day litt%seed_germ_decay(pft) = litt%seed_germ(pft) * & - EDPftvarcon_inst%seed_decay_rate(pft)*years_per_day + EDPftvarcon_inst%seed_decay_rate(pft)*years_per_day enddo @@ -1750,7 +1750,7 @@ subroutine SeedGermination( litt, cold_stat, drought_stat ) ! Flux from seed pool into sapling pool ! ! !USES: - + ! ! !ARGUMENTS type(litter_type) :: litt @@ -1760,9 +1760,9 @@ subroutine SeedGermination( litt, cold_stat, drought_stat ) ! !LOCAL VARIABLES: integer :: pft - + real(r8), parameter :: max_germination = 1.0_r8 ! Cap on germination rates. - ! KgC/m2/yr Lishcke et al. 2009 + ! KgC/m2/yr Lishcke et al. 2009 ! Turning of this cap? because the cap will impose changes on proportionality ! of nutrients. (RGK 02-2019) @@ -1778,17 +1778,17 @@ subroutine SeedGermination( litt, cold_stat, drought_stat ) do pft = 1,numpft litt%seed_germ_in(pft) = min(litt%seed(pft) * EDPftvarcon_inst%germination_rate(pft), & - max_germination)*years_per_day - + max_germination)*years_per_day + !set the germination only under the growing season...c.xu if ((prt_params%season_decid(pft) == itrue ) .and. & - (any(cold_stat == [phen_cstat_nevercold,phen_cstat_iscold]))) then - litt%seed_germ_in(pft) = 0.0_r8 + (any(cold_stat == [phen_cstat_nevercold,phen_cstat_iscold]))) then + litt%seed_germ_in(pft) = 0.0_r8 endif if ((prt_params%stress_decid(pft) == itrue ) .and. & - (any(drought_stat == [phen_dstat_timeoff,phen_dstat_moistoff]))) then - litt%seed_germ_in(pft) = 0.0_r8 + (any(drought_stat == [phen_dstat_timeoff,phen_dstat_moistoff]))) then + litt%seed_germ_in(pft) = 0.0_r8 end if @@ -1846,9 +1846,9 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) real(r8) :: m_repro ! reproductive mass (element agnostic) [kg] real(r8) :: mass_avail ! The mass of each nutrient/carbon available in the seed_germination pool [kg] real(r8) :: mass_demand ! Total mass demanded by the plant to achieve the stoichiometric targets - ! of all the organs in the recruits. Used for both [kg per plant] and [kg per cohort] + ! of all the organs in the recruits. Used for both [kg per plant] and [kg per cohort] real(r8) :: stem_drop_fraction - + !---------------------------------------------------------------------- allocate(temp_cohort) ! create temporary cohort @@ -1856,247 +1856,247 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) do ft = 1,numpft - if(currentSite%use_this_pft(ft).eq.itrue)then - temp_cohort%canopy_trim = 0.8_r8 !starting with the canopy not fully expanded - temp_cohort%pft = ft - temp_cohort%hite = EDPftvarcon_inst%hgt_min(ft) - temp_cohort%coage = 0.0_r8 - stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(ft) - - call h2d_allom(temp_cohort%hite,ft,temp_cohort%dbh) - - ! Initialize live pools - call bleaf(temp_cohort%dbh,ft,temp_cohort%canopy_trim,c_leaf) - call bfineroot(temp_cohort%dbh,ft,temp_cohort%canopy_trim,c_fnrt) - call bsap_allom(temp_cohort%dbh,ft,temp_cohort%canopy_trim,a_sapw, c_sapw) - call bagw_allom(temp_cohort%dbh,ft,c_agw) - call bbgw_allom(temp_cohort%dbh,ft,c_bgw) - call bdead_allom(c_agw,c_bgw,c_sapw,ft,c_struct) - call bstore_allom(temp_cohort%dbh,ft,temp_cohort%canopy_trim,c_store) - - ! Default assumption is that leaves are on - cohortstatus = leaves_on - temp_cohort%laimemory = 0.0_r8 - temp_cohort%sapwmemory = 0.0_r8 - temp_cohort%structmemory = 0.0_r8 - - - ! But if the plant is seasonally (cold) deciduous, and the site status is flagged - ! as "cold", then set the cohort's status to leaves_off, and remember the leaf biomass - if ((prt_params%season_decid(ft) == itrue) .and. & - (any(currentSite%cstatus == [phen_cstat_nevercold,phen_cstat_iscold]))) then - temp_cohort%laimemory = c_leaf - c_leaf = 0.0_r8 - - ! If plant is not woody then set sapwood and structural biomass as well - if (prt_params%woody(ft).ne.itrue) then - temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction - c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw - c_struct = (1.0_r8 - stem_drop_fraction) * c_struct - endif - cohortstatus = leaves_off - endif - - ! Or.. if the plant is drought deciduous, and the site status is flagged as - ! "in a drought", then likewise, set the cohort's status to leaves_off, and remember leaf - ! biomass - if ((prt_params%stress_decid(ft) == itrue) .and. & - (any(currentSite%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff]))) then - temp_cohort%laimemory = c_leaf - c_leaf = 0.0_r8 - - ! If plant is not woody then set sapwood and structural biomass as well - if(prt_params%woody(ft).ne.itrue)then - temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction - c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw - c_struct = (1.0_r8 - stem_drop_fraction) * c_struct - endif - cohortstatus = leaves_off - endif - - - ! Cycle through available carbon and nutrients, find the limiting element - ! to dictate the total number of plants that can be generated - - if ( (hlm_use_ed_prescribed_phys .eq. ifalse) .or. & - (EDPftvarcon_inst%prescribed_recruitment(ft) .lt. 0._r8) ) then - - temp_cohort%n = 1.e10_r8 - - do el = 1,num_elements - - element_id = element_list(el) - select case(element_id) - case(carbon12_element) - - mass_demand = (c_struct+c_leaf+c_fnrt+c_sapw+c_store) - - case(nitrogen_element) - - mass_demand = c_struct*prt_params%nitr_stoich_p1(ft,struct_organ) + & - c_leaf*prt_params%nitr_stoich_p1(ft,leaf_organ) + & - c_fnrt*prt_params%nitr_stoich_p1(ft,fnrt_organ) + & - c_sapw*prt_params%nitr_stoich_p1(ft,sapw_organ) + & - c_store*prt_params%nitr_stoich_p1(ft,store_organ) - - case(phosphorus_element) - - mass_demand = c_struct*prt_params%phos_stoich_p1(ft,struct_organ) + & - c_leaf*prt_params%phos_stoich_p1(ft,leaf_organ) + & - c_fnrt*prt_params%phos_stoich_p1(ft,fnrt_organ) + & - c_sapw*prt_params%phos_stoich_p1(ft,sapw_organ) + & - c_store*prt_params%phos_stoich_p1(ft,store_organ) - - case default + if(currentSite%use_this_pft(ft).eq.itrue)then + temp_cohort%canopy_trim = 0.8_r8 !starting with the canopy not fully expanded + temp_cohort%pft = ft + temp_cohort%hite = EDPftvarcon_inst%hgt_min(ft) + temp_cohort%coage = 0.0_r8 + stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(ft) + + call h2d_allom(temp_cohort%hite,ft,temp_cohort%dbh) + + ! Initialize live pools + call bleaf(temp_cohort%dbh,ft,temp_cohort%canopy_trim,c_leaf) + call bfineroot(temp_cohort%dbh,ft,temp_cohort%canopy_trim,c_fnrt) + call bsap_allom(temp_cohort%dbh,ft,temp_cohort%canopy_trim,a_sapw, c_sapw) + call bagw_allom(temp_cohort%dbh,ft,c_agw) + call bbgw_allom(temp_cohort%dbh,ft,c_bgw) + call bdead_allom(c_agw,c_bgw,c_sapw,ft,c_struct) + call bstore_allom(temp_cohort%dbh,ft,temp_cohort%canopy_trim,c_store) + + ! Default assumption is that leaves are on + cohortstatus = leaves_on + temp_cohort%laimemory = 0.0_r8 + temp_cohort%sapwmemory = 0.0_r8 + temp_cohort%structmemory = 0.0_r8 + + + ! But if the plant is seasonally (cold) deciduous, and the site status is flagged + ! as "cold", then set the cohort's status to leaves_off, and remember the leaf biomass + if ((prt_params%season_decid(ft) == itrue) .and. & + (any(currentSite%cstatus == [phen_cstat_nevercold,phen_cstat_iscold]))) then + temp_cohort%laimemory = c_leaf + c_leaf = 0.0_r8 + + ! If plant is not woody then set sapwood and structural biomass as well + if (prt_params%woody(ft).ne.itrue) then + temp_cohort%sapwmemory = c_sapw * stem_drop_fraction + temp_cohort%structmemory = c_struct * stem_drop_fraction + c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw + c_struct = (1.0_r8 - stem_drop_fraction) * c_struct + endif + cohortstatus = leaves_off + endif + + ! Or.. if the plant is drought deciduous, and the site status is flagged as + ! "in a drought", then likewise, set the cohort's status to leaves_off, and remember leaf + ! biomass + if ((prt_params%stress_decid(ft) == itrue) .and. & + (any(currentSite%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff]))) then + temp_cohort%laimemory = c_leaf + c_leaf = 0.0_r8 + + ! If plant is not woody then set sapwood and structural biomass as well + if(prt_params%woody(ft).ne.itrue)then + temp_cohort%sapwmemory = c_sapw * stem_drop_fraction + temp_cohort%structmemory = c_struct * stem_drop_fraction + c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw + c_struct = (1.0_r8 - stem_drop_fraction) * c_struct + endif + cohortstatus = leaves_off + endif + + + ! Cycle through available carbon and nutrients, find the limiting element + ! to dictate the total number of plants that can be generated + + if ( (hlm_use_ed_prescribed_phys .eq. ifalse) .or. & + (EDPftvarcon_inst%prescribed_recruitment(ft) .lt. 0._r8) ) then + + temp_cohort%n = 1.e10_r8 + + do el = 1,num_elements + + element_id = element_list(el) + select case(element_id) + case(carbon12_element) + + mass_demand = (c_struct+c_leaf+c_fnrt+c_sapw+c_store) + + case(nitrogen_element) + + mass_demand = c_struct*prt_params%nitr_stoich_p1(ft,struct_organ) + & + c_leaf*prt_params%nitr_stoich_p1(ft,leaf_organ) + & + c_fnrt*prt_params%nitr_stoich_p1(ft,fnrt_organ) + & + c_sapw*prt_params%nitr_stoich_p1(ft,sapw_organ) + & + c_store*prt_params%nitr_stoich_p1(ft,store_organ) + + case(phosphorus_element) + + mass_demand = c_struct*prt_params%phos_stoich_p1(ft,struct_organ) + & + c_leaf*prt_params%phos_stoich_p1(ft,leaf_organ) + & + c_fnrt*prt_params%phos_stoich_p1(ft,fnrt_organ) + & + c_sapw*prt_params%phos_stoich_p1(ft,sapw_organ) + & + c_store*prt_params%phos_stoich_p1(ft,store_organ) + + case default write(fates_log(),*) 'Undefined element type in recruitment' call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - mass_avail = currentPatch%area * currentPatch%litter(el)%seed_germ(ft) + end select - ! ------------------------------------------------------------------------ - ! Update number density if this is the limiting mass - ! ------------------------------------------------------------------------ + mass_avail = currentPatch%area * currentPatch%litter(el)%seed_germ(ft) - temp_cohort%n = min(temp_cohort%n, mass_avail/mass_demand) + ! ------------------------------------------------------------------------ + ! Update number density if this is the limiting mass + ! ------------------------------------------------------------------------ - end do + temp_cohort%n = min(temp_cohort%n, mass_avail/mass_demand) + end do - else - ! prescribed recruitment rates. number per sq. meter per year - temp_cohort%n = currentPatch%area * & - EDPftvarcon_inst%prescribed_recruitment(ft) * & - hlm_freq_day - endif - ! Only bother allocating a new cohort if there is a reasonable amount of it - if (temp_cohort%n > min_n_safemath )then - - ! ----------------------------------------------------------------------------- - ! PART II. - ! Initialize the PARTEH object, and determine the initial masses of all - ! organs and elements. - ! ----------------------------------------------------------------------------- - prt => null() - call InitPRTObject(prt) - - do el = 1,num_elements - - element_id = element_list(el) - - ! If this is carbon12, then the initialization is straight forward - ! otherwise, we use stoichiometric ratios - select case(element_id) - case(carbon12_element) - - m_struct = c_struct - m_leaf = c_leaf - m_fnrt = c_fnrt - m_sapw = c_sapw - m_store = c_store - m_repro = 0._r8 - - case(nitrogen_element) - - m_struct = c_struct*prt_params%nitr_stoich_p1(ft,struct_organ) - m_leaf = c_leaf*prt_params%nitr_stoich_p1(ft,leaf_organ) - m_fnrt = c_fnrt*prt_params%nitr_stoich_p1(ft,fnrt_organ) - m_sapw = c_sapw*prt_params%nitr_stoich_p1(ft,sapw_organ) - m_store = c_store*prt_params%nitr_stoich_p1(ft,store_organ) - m_repro = 0._r8 - - case(phosphorus_element) - - m_struct = c_struct*prt_params%phos_stoich_p1(ft,struct_organ) - m_leaf = c_leaf*prt_params%phos_stoich_p1(ft,leaf_organ) - m_fnrt = c_fnrt*prt_params%phos_stoich_p1(ft,fnrt_organ) - m_sapw = c_sapw*prt_params%phos_stoich_p1(ft,sapw_organ) - m_store = c_store*prt_params%phos_stoich_p1(ft,store_organ) - m_repro = 0._r8 - - end select - - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp,prt_cnp_flex_allom_hyp ) - - ! Put all of the leaf mass into the first bin - call SetState(prt,leaf_organ, element_id,m_leaf,1) - do iage = 2,nleafage - call SetState(prt,leaf_organ, element_id,0._r8,iage) - end do - - call SetState(prt,fnrt_organ, element_id, m_fnrt) - call SetState(prt,sapw_organ, element_id, m_sapw) - call SetState(prt,store_organ, element_id, m_store) - call SetState(prt,struct_organ, element_id, m_struct) - call SetState(prt,repro_organ, element_id, m_repro) - - case default - write(fates_log(),*) 'Unspecified PARTEH module during create_cohort' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - site_mass => currentSite%mass_balance(el) - - ! Remove mass from the germination pool. However, if we are use prescribed physiology, - ! AND the forced recruitment model, then we are not realling using the prognostic - ! seed_germination model, so we have to short circuit things. We send all of the - ! seed germination mass to an outflux pool, and use an arbitrary generic input flux - ! to balance out the new recruits. - - if ( (hlm_use_ed_prescribed_phys .eq. itrue ) .and. & - (EDPftvarcon_inst%prescribed_recruitment(ft) .ge. 0._r8 )) then - - site_mass%flux_generic_in = site_mass%flux_generic_in + & + else + ! prescribed recruitment rates. number per sq. meter per year + temp_cohort%n = currentPatch%area * & + EDPftvarcon_inst%prescribed_recruitment(ft) * & + hlm_freq_day + endif + + ! Only bother allocating a new cohort if there is a reasonable amount of it + if (temp_cohort%n > min_n_safemath )then + + ! ----------------------------------------------------------------------------- + ! PART II. + ! Initialize the PARTEH object, and determine the initial masses of all + ! organs and elements. + ! ----------------------------------------------------------------------------- + prt => null() + call InitPRTObject(prt) + + do el = 1,num_elements + + element_id = element_list(el) + + ! If this is carbon12, then the initialization is straight forward + ! otherwise, we use stoichiometric ratios + select case(element_id) + case(carbon12_element) + + m_struct = c_struct + m_leaf = c_leaf + m_fnrt = c_fnrt + m_sapw = c_sapw + m_store = c_store + m_repro = 0._r8 + + case(nitrogen_element) + + m_struct = c_struct*prt_params%nitr_stoich_p1(ft,struct_organ) + m_leaf = c_leaf*prt_params%nitr_stoich_p1(ft,leaf_organ) + m_fnrt = c_fnrt*prt_params%nitr_stoich_p1(ft,fnrt_organ) + m_sapw = c_sapw*prt_params%nitr_stoich_p1(ft,sapw_organ) + m_store = c_store*prt_params%nitr_stoich_p1(ft,store_organ) + m_repro = 0._r8 + + case(phosphorus_element) + + m_struct = c_struct*prt_params%phos_stoich_p1(ft,struct_organ) + m_leaf = c_leaf*prt_params%phos_stoich_p1(ft,leaf_organ) + m_fnrt = c_fnrt*prt_params%phos_stoich_p1(ft,fnrt_organ) + m_sapw = c_sapw*prt_params%phos_stoich_p1(ft,sapw_organ) + m_store = c_store*prt_params%phos_stoich_p1(ft,store_organ) + m_repro = 0._r8 + + end select + + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp,prt_cnp_flex_allom_hyp ) + + ! Put all of the leaf mass into the first bin + call SetState(prt,leaf_organ, element_id,m_leaf,1) + do iage = 2,nleafage + call SetState(prt,leaf_organ, element_id,0._r8,iage) + end do + + call SetState(prt,fnrt_organ, element_id, m_fnrt) + call SetState(prt,sapw_organ, element_id, m_sapw) + call SetState(prt,store_organ, element_id, m_store) + call SetState(prt,struct_organ, element_id, m_struct) + call SetState(prt,repro_organ, element_id, m_repro) + + case default + write(fates_log(),*) 'Unspecified PARTEH module during create_cohort' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + site_mass => currentSite%mass_balance(el) + + ! Remove mass from the germination pool. However, if we are use prescribed physiology, + ! AND the forced recruitment model, then we are not realling using the prognostic + ! seed_germination model, so we have to short circuit things. We send all of the + ! seed germination mass to an outflux pool, and use an arbitrary generic input flux + ! to balance out the new recruits. + + if ( (hlm_use_ed_prescribed_phys .eq. itrue ) .and. & + (EDPftvarcon_inst%prescribed_recruitment(ft) .ge. 0._r8 )) then + + site_mass%flux_generic_in = site_mass%flux_generic_in + & temp_cohort%n*(m_struct + m_leaf + m_fnrt + m_sapw + m_store + m_repro) - - site_mass%flux_generic_out = site_mass%flux_generic_out + & + + site_mass%flux_generic_out = site_mass%flux_generic_out + & currentPatch%area * currentPatch%litter(el)%seed_germ(ft) - - currentPatch%litter(el)%seed_germ(ft) = 0._r8 - - else + currentPatch%litter(el)%seed_germ(ft) = 0._r8 + - currentPatch%litter(el)%seed_germ(ft) = currentPatch%litter(el)%seed_germ(ft) - & + else + + currentPatch%litter(el)%seed_germ(ft) = currentPatch%litter(el)%seed_germ(ft) - & temp_cohort%n / currentPatch%area * & (m_struct + m_leaf + m_fnrt + m_sapw + m_store + m_repro) - - end if - - - - end do - - ! This call cycles through the initial conditions, and makes sure that they - ! are all initialized. - ! ----------------------------------------------------------------------------------- - - call prt%CheckInitialConditions() - ! This initializes the cohort - call create_cohort(currentSite,currentPatch, temp_cohort%pft, temp_cohort%n, & - temp_cohort%hite, temp_cohort%coage, temp_cohort%dbh, prt, & - temp_cohort%laimemory, temp_cohort%sapwmemory, temp_cohort%structmemory, & - cohortstatus, recruitstatus, & - temp_cohort%canopy_trim,temp_cohort%c_area, & - currentPatch%NCL_p, currentSite%spread, bc_in) - - ! Note that if hydraulics is on, the number of cohorts may had - ! changed due to hydraulic constraints. - ! This constaint is applied during "create_cohort" subroutine. - - ! keep track of how many individuals were recruited for passing to history - currentSite%recruitment_rate(ft) = currentSite%recruitment_rate(ft) + temp_cohort%n - - endif - endif !use_this_pft - enddo !pft loop - - deallocate(temp_cohort) ! delete temporary cohort + end if + + + + end do + + ! This call cycles through the initial conditions, and makes sure that they + ! are all initialized. + ! ----------------------------------------------------------------------------------- + + call prt%CheckInitialConditions() + ! This initializes the cohort + call create_cohort(currentSite,currentPatch, temp_cohort%pft, temp_cohort%n, & + temp_cohort%hite, temp_cohort%coage, temp_cohort%dbh, prt, & + temp_cohort%laimemory, temp_cohort%sapwmemory, temp_cohort%structmemory, & + cohortstatus, recruitstatus, & + temp_cohort%canopy_trim,temp_cohort%c_area, & + currentPatch%NCL_p, currentSite%spread, bc_in) + + ! Note that if hydraulics is on, the number of cohorts may had + ! changed due to hydraulic constraints. + ! This constaint is applied during "create_cohort" subroutine. + + ! keep track of how many individuals were recruited for passing to history + currentSite%recruitment_rate(ft) = currentSite%recruitment_rate(ft) + temp_cohort%n + + + endif + endif !use_this_pft + enddo !pft loop + + deallocate(temp_cohort) ! delete temporary cohort end subroutine recruitment @@ -2132,9 +2132,9 @@ subroutine CWDInput( currentSite, currentPatch, litt) real(r8) :: dead_n_dlogging ! direct logging understory dead-tree density real(r8) :: dead_n_ilogging ! indirect understory dead-tree density (logging) real(r8) :: dead_n_natural ! understory dead density not associated - ! with direct logging + ! with direct logging real(r8) :: leaf_m ! mass of the element of interest in the - ! leaf [kg] + ! leaf [kg] real(r8) :: fnrt_m ! fine-root [kg] real(r8) :: sapw_m ! sapwood [kg] real(r8) :: struct_m ! structural [kg] @@ -2149,9 +2149,9 @@ subroutine CWDInput( currentSite, currentPatch, litt) real(r8) :: dcmpy_frac ! Fraction of mass sent to decomposability pool real(r8) :: plant_dens ! Number of plants per m2 real(r8) :: bg_cwd_tot ! Total below-ground coarse woody debris - ! input flux + ! input flux real(r8) :: root_fines_tot ! Total below-ground fine root coarse - ! woody debris + ! woody debris integer :: element_id ! element id consistent with parteh/PRTGenericMod.F90 real(r8) :: trunk_wood ! carbon flux into trunk products kgC/day/site @@ -2168,263 +2168,263 @@ subroutine CWDInput( currentSite, currentPatch, litt) numlevsoil = currentSite%nlevsoil element_id = litt%element_id - + ! Object tracking flux diagnostics for each element flux_diags => currentSite%flux_diags(element_pos(element_id)) - + ! Object tracking site level mass balance for each element site_mass => currentSite%mass_balance(element_pos(element_id)) currentCohort => currentPatch%shortest do while(associated(currentCohort)) - pft = currentCohort%pft - - call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil) - - leaf_m_turnover = currentCohort%prt%GetTurnover(leaf_organ,element_id) - store_m_turnover = currentCohort%prt%GetTurnover(store_organ,element_id) - fnrt_m_turnover = currentCohort%prt%GetTurnover(fnrt_organ,element_id) - sapw_m_turnover = currentCohort%prt%GetTurnover(sapw_organ,element_id) - struct_m_turnover = currentCohort%prt%GetTurnover(struct_organ,element_id) - repro_m_turnover = currentCohort%prt%GetTurnover(repro_organ,element_id) - - leaf_m = currentCohort%prt%GetState(leaf_organ,element_id) - store_m = currentCohort%prt%GetState(store_organ,element_id) - fnrt_m = currentCohort%prt%GetState(fnrt_organ,element_id) - sapw_m = currentCohort%prt%GetState(sapw_organ,element_id) - struct_m = currentCohort%prt%GetState(struct_organ,element_id) - repro_m = currentCohort%prt%GetState(repro_organ,element_id) - - plant_dens = currentCohort%n/currentPatch%area - - ! --------------------------------------------------------------------------------- - ! PART 1 Litter fluxes from non-mortal tissue turnovers Kg/m2/day - ! Important note: Turnover has already been removed from the cohorts. - ! So, in the next part of this algorithm, when we send the biomass - ! from dying trees to the litter pools, we don't have to worry - ! about double counting. - ! --------------------------------------------------------------------------------- - - flux_diags%leaf_litter_input(pft) = & + pft = currentCohort%pft + + call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil) + + leaf_m_turnover = currentCohort%prt%GetTurnover(leaf_organ,element_id) + store_m_turnover = currentCohort%prt%GetTurnover(store_organ,element_id) + fnrt_m_turnover = currentCohort%prt%GetTurnover(fnrt_organ,element_id) + sapw_m_turnover = currentCohort%prt%GetTurnover(sapw_organ,element_id) + struct_m_turnover = currentCohort%prt%GetTurnover(struct_organ,element_id) + repro_m_turnover = currentCohort%prt%GetTurnover(repro_organ,element_id) + + leaf_m = currentCohort%prt%GetState(leaf_organ,element_id) + store_m = currentCohort%prt%GetState(store_organ,element_id) + fnrt_m = currentCohort%prt%GetState(fnrt_organ,element_id) + sapw_m = currentCohort%prt%GetState(sapw_organ,element_id) + struct_m = currentCohort%prt%GetState(struct_organ,element_id) + repro_m = currentCohort%prt%GetState(repro_organ,element_id) + + plant_dens = currentCohort%n/currentPatch%area + + ! --------------------------------------------------------------------------------- + ! PART 1 Litter fluxes from non-mortal tissue turnovers Kg/m2/day + ! Important note: Turnover has already been removed from the cohorts. + ! So, in the next part of this algorithm, when we send the biomass + ! from dying trees to the litter pools, we don't have to worry + ! about double counting. + ! --------------------------------------------------------------------------------- + + flux_diags%leaf_litter_input(pft) = & flux_diags%leaf_litter_input(pft) + & leaf_m_turnover * currentCohort%n - - root_fines_tot = (fnrt_m_turnover + store_m_turnover ) * & + + root_fines_tot = (fnrt_m_turnover + store_m_turnover ) * & plant_dens - do dcmpy=1,ndcmpy + do dcmpy=1,ndcmpy dcmpy_frac = GetDecompyFrac(pft,leaf_organ,dcmpy) litt%leaf_fines_in(dcmpy) = litt%leaf_fines_in(dcmpy) + & - (leaf_m_turnover+repro_m_turnover) * plant_dens * dcmpy_frac + (leaf_m_turnover+repro_m_turnover) * plant_dens * dcmpy_frac dcmpy_frac = GetDecompyFrac(pft,fnrt_organ,dcmpy) do ilyr = 1, numlevsoil - litt%root_fines_in(dcmpy,ilyr) = litt%root_fines_in(dcmpy,ilyr) + & - currentSite%rootfrac_scr(ilyr) * root_fines_tot * dcmpy_frac + litt%root_fines_in(dcmpy,ilyr) = litt%root_fines_in(dcmpy,ilyr) + & + currentSite%rootfrac_scr(ilyr) * root_fines_tot * dcmpy_frac end do - end do - - flux_diags%root_litter_input(pft) = & + end do + + flux_diags%root_litter_input(pft) = & flux_diags%root_litter_input(pft) + & (fnrt_m_turnover + store_m_turnover ) * currentCohort%n - - - ! Assumption: turnover from deadwood and sapwood are lumped together in CWD pool - - do c = 1,ncwd - litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + & - (sapw_m_turnover + struct_m_turnover) * & - SF_val_CWD_frac(c) * plant_dens * & - prt_params%allom_agb_frac(pft) - - flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & + + + ! Assumption: turnover from deadwood and sapwood are lumped together in CWD pool + + do c = 1,ncwd + litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + & + (sapw_m_turnover + struct_m_turnover) * & + SF_val_CWD_frac(c) * plant_dens * & + prt_params%allom_agb_frac(pft) + + flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & (struct_m_turnover + sapw_m_turnover) * SF_val_CWD_frac(c) * & prt_params%allom_agb_frac(pft) * currentCohort%n - bg_cwd_tot = (sapw_m_turnover + struct_m_turnover) * & - SF_val_CWD_frac(c) * plant_dens * & - (1.0_r8-prt_params%allom_agb_frac(pft)) + bg_cwd_tot = (sapw_m_turnover + struct_m_turnover) * & + SF_val_CWD_frac(c) * plant_dens * & + (1.0_r8-prt_params%allom_agb_frac(pft)) - do ilyr = 1, numlevsoil - litt%bg_cwd_in(c,ilyr) = litt%bg_cwd_in(c,ilyr) + & + do ilyr = 1, numlevsoil + litt%bg_cwd_in(c,ilyr) = litt%bg_cwd_in(c,ilyr) + & bg_cwd_tot * currentSite%rootfrac_scr(ilyr) - end do - - flux_diags%cwd_bg_input(c) = flux_diags%cwd_bg_input(c) + & + end do + + flux_diags%cwd_bg_input(c) = flux_diags%cwd_bg_input(c) + & bg_cwd_tot*currentPatch%area - - enddo + + enddo - ! --------------------------------------------------------------------------------- - ! PART 2 Litter fluxes from non-disturbance inducing mortality. Kg/m2/day - ! --------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------- + ! PART 2 Litter fluxes from non-disturbance inducing mortality. Kg/m2/day + ! --------------------------------------------------------------------------------- - ! Total number of dead (n/m2/day) - dead_n = -1.0_r8 * currentCohort%dndt/currentPatch%area*years_per_day + ! Total number of dead (n/m2/day) + dead_n = -1.0_r8 * currentCohort%dndt/currentPatch%area*years_per_day - if(currentCohort%canopy_layer > 1)then + if(currentCohort%canopy_layer > 1)then - ! Total number of dead understory from direct logging - ! (it is possible that large harvestable trees are in the understory) - dead_n_dlogging = currentCohort%lmort_direct * & - currentCohort%n/currentPatch%area + ! Total number of dead understory from direct logging + ! (it is possible that large harvestable trees are in the understory) + dead_n_dlogging = currentCohort%lmort_direct * & + currentCohort%n/currentPatch%area - ! Total number of dead understory from indirect logging - dead_n_ilogging = (currentCohort%lmort_collateral + currentCohort%lmort_infra) * & - currentCohort%n/currentPatch%area + ! Total number of dead understory from indirect logging + dead_n_ilogging = (currentCohort%lmort_collateral + currentCohort%lmort_infra) * & + currentCohort%n/currentPatch%area - else + else - ! All mortality from logging in the canopy is - ! is disturbance generating + ! All mortality from logging in the canopy is + ! is disturbance generating - dead_n_dlogging = 0._r8 - dead_n_ilogging = 0._r8 + dead_n_dlogging = 0._r8 + dead_n_ilogging = 0._r8 - end if + end if - dead_n_natural = dead_n - dead_n_dlogging - dead_n_ilogging + dead_n_natural = dead_n - dead_n_dlogging - dead_n_ilogging - flux_diags%leaf_litter_input(pft) = & + flux_diags%leaf_litter_input(pft) = & flux_diags%leaf_litter_input(pft) + & leaf_m * dead_n*currentPatch%area - ! %n has not been updated due to mortality yet, thus - ! the litter flux has already been counted since it captured - ! the losses of live trees and those flagged for death - - root_fines_tot = dead_n * (fnrt_m + & - store_m*(1._r8-EDPftvarcon_inst%allom_frbstor_repro(pft)) ) + ! %n has not been updated due to mortality yet, thus + ! the litter flux has already been counted since it captured + ! the losses of live trees and those flagged for death - do dcmpy=1,ndcmpy + root_fines_tot = dead_n * (fnrt_m + & + store_m*(1._r8-EDPftvarcon_inst%allom_frbstor_repro(pft)) ) + + do dcmpy=1,ndcmpy dcmpy_frac = GetDecompyFrac(pft,leaf_organ,dcmpy) litt%leaf_fines_in(dcmpy) = litt%leaf_fines_in(dcmpy) + & - (leaf_m+repro_m) * dead_n * dcmpy_frac + (leaf_m+repro_m) * dead_n * dcmpy_frac dcmpy_frac = GetDecompyFrac(pft,fnrt_organ,dcmpy) do ilyr = 1, numlevsoil - litt%root_fines_in(dcmpy,ilyr) = litt%root_fines_in(dcmpy,ilyr) + & - root_fines_tot * currentSite%rootfrac_scr(ilyr) * dcmpy_frac + litt%root_fines_in(dcmpy,ilyr) = litt%root_fines_in(dcmpy,ilyr) + & + root_fines_tot * currentSite%rootfrac_scr(ilyr) * dcmpy_frac end do - end do + end do - flux_diags%root_litter_input(pft) = & + flux_diags%root_litter_input(pft) = & flux_diags%root_litter_input(pft) + & root_fines_tot*currentPatch%area - ! Track CWD inputs from dead plants - - do c = 1,ncwd - - ! Below-ground - - bg_cwd_tot = (struct_m + sapw_m) * & - SF_val_CWD_frac(c) * dead_n * & - (1.0_r8-prt_params%allom_agb_frac(pft)) - - do ilyr = 1, numlevsoil - litt%bg_cwd_in(c,ilyr) = litt%bg_cwd_in(c,ilyr) + & + ! Track CWD inputs from dead plants + + do c = 1,ncwd + + ! Below-ground + + bg_cwd_tot = (struct_m + sapw_m) * & + SF_val_CWD_frac(c) * dead_n * & + (1.0_r8-prt_params%allom_agb_frac(pft)) + + do ilyr = 1, numlevsoil + litt%bg_cwd_in(c,ilyr) = litt%bg_cwd_in(c,ilyr) + & currentSite%rootfrac_scr(ilyr) * bg_cwd_tot - end do + end do - flux_diags%cwd_bg_input(c) = flux_diags%cwd_bg_input(c) + & + flux_diags%cwd_bg_input(c) = flux_diags%cwd_bg_input(c) + & bg_cwd_tot * currentPatch%area - ! Send AGB component of boles from logging activities into the litter. - ! This includes fluxes from indirect modes of death, as well as the - ! non-exported boles due to direct harvesting. + ! Send AGB component of boles from logging activities into the litter. + ! This includes fluxes from indirect modes of death, as well as the + ! non-exported boles due to direct harvesting. + + if (c==ncwd) then - if (c==ncwd) then - - trunk_wood = (struct_m + sapw_m) * & - SF_val_CWD_frac(c) * dead_n_dlogging * & - prt_params%allom_agb_frac(pft) - - site_mass%wood_product = site_mass%wood_product + & - trunk_wood * currentPatch%area * logging_export_frac + trunk_wood = (struct_m + sapw_m) * & + SF_val_CWD_frac(c) * dead_n_dlogging * & + prt_params%allom_agb_frac(pft) - ! Add AG wood to litter from the non-exported fraction of wood - ! from direct anthro sources + site_mass%wood_product = site_mass%wood_product + & + trunk_wood * currentPatch%area * logging_export_frac - litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + & - trunk_wood * (1._r8-logging_export_frac) + ! Add AG wood to litter from the non-exported fraction of wood + ! from direct anthro sources - flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & - trunk_wood * (1._r8-logging_export_frac) * currentPatch%area + litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + & + trunk_wood * (1._r8-logging_export_frac) - ! Add AG wood to litter from indirect anthro sources + flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & + trunk_wood * (1._r8-logging_export_frac) * currentPatch%area - litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & - SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & - prt_params%allom_agb_frac(pft) + ! Add AG wood to litter from indirect anthro sources - flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & + litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & + SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & + prt_params%allom_agb_frac(pft) + + flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & currentPatch%area * prt_params%allom_agb_frac(pft) - else + else - litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & - SF_val_CWD_frac(c) * dead_n * & - prt_params%allom_agb_frac(pft) + litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & + SF_val_CWD_frac(c) * dead_n * & + prt_params%allom_agb_frac(pft) - flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & + flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & SF_val_CWD_frac(c) * dead_n * (struct_m + sapw_m) * & currentPatch%area * prt_params%allom_agb_frac(pft) - - end if - - end do + end if + + end do + + + ! Update diagnostics that track resource management - ! Update diagnostics that track resource management + if( element_id .eq. carbon12_element ) then - if( element_id .eq. carbon12_element ) then - - currentSite%resources_management%delta_litter_stock = & - currentSite%resources_management%delta_litter_stock + & - (leaf_m + fnrt_m + store_m ) * & - (dead_n_ilogging+dead_n_dlogging) * currentPatch%area + currentSite%resources_management%delta_litter_stock = & + currentSite%resources_management%delta_litter_stock + & + (leaf_m + fnrt_m + store_m ) * & + (dead_n_ilogging+dead_n_dlogging) * currentPatch%area - currentSite%resources_management%delta_biomass_stock = & - currentSite%resources_management%delta_biomass_stock + & - (leaf_m + fnrt_m + store_m ) * & - (dead_n_ilogging+dead_n_dlogging) *currentPatch%area + currentSite%resources_management%delta_biomass_stock = & + currentSite%resources_management%delta_biomass_stock + & + (leaf_m + fnrt_m + store_m ) * & + (dead_n_ilogging+dead_n_dlogging) *currentPatch%area - currentSite%resources_management%trunk_product_site = & + currentSite%resources_management%trunk_product_site = & currentSite%resources_management%trunk_product_site + & trunk_wood * logging_export_frac * currentPatch%area - do c = 1,ncwd - currentSite%resources_management%delta_litter_stock = & + do c = 1,ncwd + currentSite%resources_management%delta_litter_stock = & currentSite%resources_management%delta_litter_stock + & (struct_m + sapw_m) * & SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & currentPatch%area - - currentSite%resources_management%delta_biomass_stock = & + + currentSite%resources_management%delta_biomass_stock = & currentSite%resources_management%delta_biomass_stock + & (struct_m + sapw_m) * & SF_val_CWD_frac(c) * dead_n * currentPatch%area - end do - - ! Update diagnostics that track resource management - currentSite%resources_management%delta_individual = & + end do + + ! Update diagnostics that track resource management + currentSite%resources_management%delta_individual = & currentSite%resources_management%delta_individual + & (dead_n_dlogging+dead_n_ilogging) * hlm_freq_day * currentPatch%area - end if - - - currentCohort => currentCohort%taller - enddo ! end loop over cohorts - - - return + end if + + + currentCohort => currentCohort%taller + enddo ! end loop over cohorts + + + return end subroutine CWDInput ! ===================================================================================== @@ -2441,22 +2441,22 @@ subroutine SeedDecayToFines(litt) do pft = 1,numpft - litt%leaf_fines_in(ilabile) = litt%leaf_fines_in(ilabile) + & - (litt%seed_decay(pft) + litt%seed_germ_decay(pft)) * EDPftvarcon_inst%lf_flab(pft) - - litt%leaf_fines_in(icellulose) = litt%leaf_fines_in(icellulose) + & - (litt%seed_decay(pft) + litt%seed_germ_decay(pft)) * EDPftvarcon_inst%lf_fcel(pft) - - litt%leaf_fines_in(ilignin) = litt%leaf_fines_in(ilignin) + & - (litt%seed_decay(pft) + litt%seed_germ_decay(pft)) * EDPftvarcon_inst%lf_flig(pft) + litt%leaf_fines_in(ilabile) = litt%leaf_fines_in(ilabile) + & + (litt%seed_decay(pft) + litt%seed_germ_decay(pft)) * EDPftvarcon_inst%lf_flab(pft) + + litt%leaf_fines_in(icellulose) = litt%leaf_fines_in(icellulose) + & + (litt%seed_decay(pft) + litt%seed_germ_decay(pft)) * EDPftvarcon_inst%lf_fcel(pft) + + litt%leaf_fines_in(ilignin) = litt%leaf_fines_in(ilignin) + & + (litt%seed_decay(pft) + litt%seed_germ_decay(pft)) * EDPftvarcon_inst%lf_flig(pft) enddo - - + + return end subroutine SeedDecayToFines - - + + @@ -2493,36 +2493,36 @@ subroutine fragmentation_scaler( currentPatch, bc_in) catanf(t1) = 11.75_r8 +(29.7_r8 / pi) * atan( pi * 0.031_r8 * ( t1 - 15.4_r8 )) catanf_30 = catanf(30._r8) - + ifp = currentPatch%patchno if(currentPatch%nocomp_pft_label.gt.0)then - 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. - 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) - else - t_scalar = (q10_mr**(-25._r8/10._r8))*(q10_froz**((bc_in%t_veg24_pa(ifp)-tfrz)/10._r8)) - !Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-tfrz)/10._r8) - endif - else - ! original century uses an arctangent function to calculate the - ! temperature dependence of decomposition - t_scalar = max(catanf(bc_in%t_veg24_pa(ifp)-tfrz)/catanf_30,0.01_r8) - endif - - !Moisture Limitations - !BTRAN APPROACH - is quite simple, but max's out decomp at all unstressed - !soil moisture values, which is not realistic. - !litter decomp is proportional to water limitation on average... - w_scalar = sum(currentPatch%btran_ft(1:numpft))/real(numpft,r8) - - currentPatch%fragmentation_scaler = min(1.0_r8,max(0.0_r8,t_scalar * w_scalar)) + 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. + 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) + else + t_scalar = (q10_mr**(-25._r8/10._r8))*(q10_froz**((bc_in%t_veg24_pa(ifp)-tfrz)/10._r8)) + !Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-tfrz)/10._r8) + endif + else + ! original century uses an arctangent function to calculate the + ! temperature dependence of decomposition + t_scalar = max(catanf(bc_in%t_veg24_pa(ifp)-tfrz)/catanf_30,0.01_r8) + endif + + !Moisture Limitations + !BTRAN APPROACH - is quite simple, but max's out decomp at all unstressed + !soil moisture values, which is not realistic. + !litter decomp is proportional to water limitation on average... + w_scalar = sum(currentPatch%btran_ft(1:numpft))/real(numpft,r8) + + currentPatch%fragmentation_scaler = min(1.0_r8,max(0.0_r8,t_scalar * w_scalar)) endif ! not bare ground end subroutine fragmentation_scaler - + ! ============================================================================ subroutine CWDOut( litt, fragmentation_scaler, nlev_eff_decomp ) @@ -2537,14 +2537,14 @@ subroutine CWDOut( litt, fragmentation_scaler, nlev_eff_decomp ) ! ! !ARGUMENTS type(litter_type),intent(inout),target :: litt - + real(r8),intent(in) :: fragmentation_scaler ! This is not necessarily every soil layer, this is the number ! of effective layers that are active and can be sent ! to the soil decomposition model integer,intent(in) :: nlev_eff_decomp - + ! ! !LOCAL VARIABLES: integer :: c @@ -2556,12 +2556,12 @@ subroutine CWDOut( litt, fragmentation_scaler, nlev_eff_decomp ) do c = 1,ncwd litt%ag_cwd_frag(c) = litt%ag_cwd(c) * SF_val_max_decomp(c) * & - years_per_day * fragmentation_scaler - + years_per_day * fragmentation_scaler + do ilyr = 1,nlev_eff_decomp - - litt%bg_cwd_frag(c,ilyr) = litt%bg_cwd(c,ilyr) * SF_val_max_decomp(c) * & - years_per_day * fragmentation_scaler + + litt%bg_cwd_frag(c,ilyr) = litt%bg_cwd(c,ilyr) * SF_val_max_decomp(c) * & + years_per_day * fragmentation_scaler enddo end do @@ -2574,11 +2574,11 @@ subroutine CWDOut( litt, fragmentation_scaler, nlev_eff_decomp ) do dcmpy = 1,ndcmpy litt%leaf_fines_frag(dcmpy) = litt%leaf_fines(dcmpy) * & - years_per_day * SF_val_max_decomp(dl_sf) * fragmentation_scaler - + years_per_day * SF_val_max_decomp(dl_sf) * fragmentation_scaler + do ilyr = 1,nlev_eff_decomp - litt%root_fines_frag(dcmpy,ilyr) = litt%root_fines(dcmpy,ilyr) * & - years_per_day * SF_val_max_decomp(dl_sf) * fragmentation_scaler + litt%root_fines_frag(dcmpy,ilyr) = litt%root_fines(dcmpy,ilyr) * & + years_per_day * SF_val_max_decomp(dl_sf) * fragmentation_scaler end do enddo From 74f33d5b8453e819ef038013aa4b836ee949cdba Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 09:07:08 -0700 Subject: [PATCH 171/578] biogeophys/FatesPlantHydraulicsMod.F90 --- biogeophys/FatesPlantHydraulicsMod.F90 | 8235 ++++++++++++------------ 1 file changed, 4117 insertions(+), 4118 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 7dda7cc928..ee7c4454f4 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -47,7 +47,7 @@ module FatesPlantHydraulicsMod 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 @@ -89,7 +89,7 @@ module FatesPlantHydraulicsMod 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 @@ -131,9 +131,9 @@ module FatesPlantHydraulicsMod ! (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)? + ! 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 @@ -142,7 +142,7 @@ module FatesPlantHydraulicsMod ! 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 @@ -154,7 +154,7 @@ module FatesPlantHydraulicsMod 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 @@ -164,23 +164,22 @@ module FatesPlantHydraulicsMod ! proceeds over the entire time-step. - ! These switches are for developers who which to understand if there simulations ! are ever entering regimes where water contents go negative (yes physically impossible) ! or water pressures exceed that at saturation (maybe, maybe not likely) ! These situations are possible/likely due to the nature of the constant flux boundary condition ! of transpiration, due to the loosely-coupled nature of the hydro-land-energy-photosynthesis ! system - + logical, parameter :: trap_neg_wc = .false. logical, parameter :: trap_supersat_psi = .false. - + 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) - + ! 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 @@ -191,21 +190,21 @@ module FatesPlantHydraulicsMod 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 @@ -328,7 +327,7 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) do s = 1,nsites csite_hydr=>sites(s)%si_hydr - + cpatch => sites(s)%oldest_patch do while(associated(cpatch)) @@ -369,7 +368,7 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ! -------------------------------------------------------------------------------- ! Initialize the Water Retention Functions ! ----------------------------------------------------------------------------------- - + select case(soil_wrf_type) case(van_genuchten_type) do j=1,sites(s)%si_hydr%nlevrhiz @@ -385,17 +384,17 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) 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)]) + 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 @@ -417,7 +416,7 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) write(fates_log(),*) 'TFS conductance not used in soil' call endrun(msg=errMsg(sourcefile, __LINE__)) end select - + @@ -465,8 +464,8 @@ subroutine InitPlantHydStates(site, cohort) 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] - + ! compartment total potentials [MPa/meter] + ! In init mode = 1, set absorbing roots to -0.2 MPa ! = 2, use soil as starting point, match total potentials ! and then reduce plant compartment total potential by 1KPa @@ -475,7 +474,7 @@ subroutine InitPlantHydStates(site, cohort) integer, parameter :: init_mode = 2 class(wrf_arr_type),pointer :: wrfa,wrft class(wkf_arr_type),pointer :: wkfa,wkft - + site_hydr => site%si_hydr cohort_hydr => cohort%co_hydr ft = cohort%pft @@ -487,32 +486,32 @@ subroutine InitPlantHydStates(site, cohort) ! Set abosrbing root if(init_mode == 2) then - -! h_aroot_mean = 0._r8 + + ! 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)) - + ! 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) = wrfa%p%th_from_psi(cohort_hydr%psi_aroot(j)) cohort_hydr%ftc_aroot(j) = wkfa%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)) + ! 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) = wrfa%p%th_from_psi(cohort_hydr%psi_aroot(j)) cohort_hydr%ftc_aroot(j) = wkfa%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) end do end if - + !h_aroot_mean = h_aroot_mean/real(site_hydr%nlevrhiz,r8) h_aroot_mean = minval(cohort_hydr%psi_aroot(:) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(:))) @@ -543,7 +542,7 @@ subroutine InitPlantHydStates(site, cohort) 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) - & @@ -567,11 +566,11 @@ subroutine InitPlantHydStates(site, cohort) !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_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 @@ -580,14 +579,14 @@ subroutine InitPlantHydStates(site, cohort) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + end subroutine InitPlantHydStates - + ! ===================================================================================== subroutine UpdatePlantPsiFTCFromTheta(ccohort,csite_hydr) - + ! This subroutine updates the potential and the fractional ! of total conductivity based on the relative water ! content @@ -602,15 +601,15 @@ subroutine UpdatePlantPsiFTCFromTheta(ccohort,csite_hydr) type(ed_cohort_hydr_type), pointer :: ccohort_hydr - + ccohort_hydr => ccohort%co_hydr ft = ccohort%pft - + ! Update Psi and FTC in above-ground compartments ! ----------------------------------------------------------------------------------- do k = 1,n_hypool_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)) + ccohort_hydr%psi_ag(k) = wrf_plant(leaf_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) + ccohort_hydr%ftc_ag(k) = wkf_plant(leaf_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) end do do k = n_hypool_leaf+1, n_hypool_ag @@ -704,7 +703,7 @@ subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) 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 @@ -791,7 +790,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! Arguments type(ed_cohort_type),intent(inout) :: ccohort type(ed_site_hydr_type),intent(in) :: site_hydr - + type(ed_cohort_hydr_type),pointer :: ccohort_hydr ! Plant hydraulics structure integer :: j,k integer :: ft ! Plant functional type index @@ -825,10 +824,10 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) 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 + ! 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 - + ! to estimate maximum leaf carbon + ccohort_hydr => ccohort%co_hydr ft = ccohort%pft nlevrhiz = site_hydr%nlevrhiz @@ -846,12 +845,12 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! 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 = prt_params%slatop(ft) * cm2_per_m2 - + ! empirical regression data from leaves at Caxiuana (~ 8 spp) denleaf = -2.3231_r8*sla/prt_params%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 @@ -865,7 +864,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! We also place a lower bound on how low the leaf volume is allowed to go, which is 10% ! of the plant's carrying capacity. - + ! [kgC] * [kg/kgC] / [kg/m3] -> [m3] ! Get the target, or rather, maximum leaf carrying capacity of plant @@ -877,7 +876,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ccohort_hydr%v_ag(1:n_hypool_leaf) = max(leaf_c,min_leaf_frac*leaf_c_target) * & prt_params%c2b(ft) / denleaf/ real(n_hypool_leaf,r8) end if - + ! Step sapwood volume ! ----------------------------------------------------------------------------------- @@ -907,18 +906,18 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! coarse (transporting) root biomass woody_bg_c = (1.0_r8-prt_params%allom_agb_frac(ft)) * (sapw_c + struct_c) - + v_troot = woody_bg_c * prt_params%c2b(ft) / & - (prt_params%wood_density(ft)*kg_per_g*cm3_per_m3) - - + (prt_params%wood_density(ft)*kg_per_g*cm3_per_m3) + + ! Estimate absorbing root total length (all layers) ! SRL is in m/g ! [m] = [kgC]*1000[g/kg]*[kg/kgC]*[m/g] ! ------------------------------------------------------------------------------ l_aroot_tot = fnrt_c*g_per_kg*prt_params%c2b(ft)*EDPftvarcon_inst%hydr_srl(ft) - - + + ! Estimate absorbing root volume (all layers) ! ------------------------------------------------------------------------------ v_aroot_tot = pi_const * (EDPftvarcon_inst%hydr_rs2(ft)**2._r8) * l_aroot_tot @@ -927,26 +926,26 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! to the layer-by-layer absorbing root (which is now a hybrid compartment) ! ------------------------------------------------------------------------------ ccohort_hydr%v_troot = (1._r8-t2aroot_vol_donate_frac) * v_troot - + ! Partition the total absorbing root lengths and volumes into the active soil layers ! We have a condition, where we may ignore the first layer ! ------------------------------------------------------------------------------ - + norm = 1._r8 - & - zeng2001_crootfr(roota, rootb,site_hydr%zi_rhiz(1)-site_hydr%dz_rhiz(1), site_hydr%zi_rhiz(nlevrhiz)) - + zeng2001_crootfr(roota, rootb,site_hydr%zi_rhiz(1)-site_hydr%dz_rhiz(1), site_hydr%zi_rhiz(nlevrhiz)) + do j=1,nlevrhiz - - rootfr = norm*(zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j),site_hydr%zi_rhiz(nlevrhiz)) - & - zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j)-site_hydr%dz_rhiz(j),site_hydr%zi_rhiz(nlevrhiz))) - - ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot - - ! This is a hybrid absorbing root and transporting root volume - ccohort_hydr%v_aroot_layer(j) = rootfr*(v_aroot_tot + t2aroot_vol_donate_frac*v_troot) + + rootfr = norm*(zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j),site_hydr%zi_rhiz(nlevrhiz)) - & + zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j)-site_hydr%dz_rhiz(j),site_hydr%zi_rhiz(nlevrhiz))) + + ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot + + ! This is a hybrid absorbing root and transporting root volume + ccohort_hydr%v_aroot_layer(j) = rootfr*(v_aroot_tot + t2aroot_vol_donate_frac*v_troot) end do - + return end subroutine UpdatePlantHydrLenVol @@ -978,15 +977,15 @@ subroutine UpdateSizeDepPlantHydStates(currentSite,ccohort) ccohort_hydr => ccohort%co_hydr FT = cCohort%pft - + 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) + ! 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_leaf if( ccohort_hydr%v_ag(k) > nearzero ) then @@ -1032,4369 +1031,4369 @@ subroutine UpdateSizeDepPlantHydStates(currentSite,ccohort) ! UPDATES OF WATER POTENTIALS ARE DONE PRIOR TO RICHARDS' SOLUTION WITHIN FATESPLANTHYDRAULICSMOD.F90 - end associate + end associate - end subroutine UpdateSizeDepPlantHydStates - - ! ===================================================================================== +end subroutine UpdateSizeDepPlantHydStates - 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) :: pm_type - ! - ! !Local: - real(r8) :: thr ! residual water content (m3 m-3) - real(r8) :: ths ! saturated water content (m3 m-3) - ! - ! !RESULT - real(r8) :: th_corr ! corrected water content - ! - !------------------------------------------------------------------------ - 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)) +function constrain_water_contents(th_uncorr, delta, ft, pm_type) result(th_corr) - return + ! !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) :: pm_type + ! + ! !Local: + real(r8) :: thr ! residual water content (m3 m-3) + real(r8) :: ths ! saturated water content (m3 m-3) + ! + ! !RESULT + real(r8) :: th_corr ! corrected water content + ! + !------------------------------------------------------------------------ + 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 + +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 + + ! 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 + +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 + + 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 + + do k = n_hypool_leaf+1,n_hypool_ag + ccohort_hydr%psi_ag(k) = wrf_plant(stem_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) + ccohort_hydr%ftc_ag(k) = wkf_plant(stem_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) + end do + + ccohort_hydr%psi_troot = wrf_plant(troot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_troot) + ccohort_hydr%ftc_troot = wkf_plant(troot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_troot) + + do j=1,site_hydr%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%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 - end function constrain_water_contents + ccohort_hydr%is_newly_recruited = .false. - ! ===================================================================================== +end subroutine FuseCohortHydraulics - subroutine CopyCohortHydraulics(newCohort, oldCohort) +! ===================================================================================== +! Initialization Routines +! ===================================================================================== - ! Arguments - type(ed_cohort_type), intent(inout), target :: newCohort - type(ed_cohort_type), intent(inout), target :: oldCohort +subroutine InitHydrCohort(currentSite,currentCohort) - ! 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 - - end subroutine CopyCohortHydraulics + ! Arguments + type(ed_site_type), target :: currentSite + type(ed_cohort_type), target :: currentCohort + type(ed_cohort_hydr_type), pointer :: ccohort_hydr - ! ===================================================================================== - subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, newn) + if ( hlm_use_planthydro.eq.ifalse ) return + allocate(ccohort_hydr) + currentCohort%co_hydr => ccohort_hydr + call ccohort_hydr%AllocateHydrCohortArrays(currentSite%si_hydr%nlevrhiz) + ccohort_hydr%is_newly_recruited = .false. - 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 +end subroutine InitHydrCohort - type(bc_in_type), intent(in) :: bc_in - real(r8), intent(in) :: newn +! ===================================================================================== +subroutine DeallocateHydrCohort(currentCohort) - ! !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 - - 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 + ! Arguments + type(ed_cohort_type), target :: currentCohort + type(ed_cohort_hydr_type), pointer :: ccohort_hydr - 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 + if ( hlm_use_planthydro.eq.ifalse ) return - do k = n_hypool_leaf+1,n_hypool_ag - ccohort_hydr%psi_ag(k) = wrf_plant(stem_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) - ccohort_hydr%ftc_ag(k) = wkf_plant(stem_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) - end do + ccohort_hydr => currentCohort%co_hydr + call ccohort_hydr%DeAllocateHydrCohortArrays() + deallocate(ccohort_hydr) - 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) + return +end subroutine DeallocateHydrCohort - 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 +! ===================================================================================== +subroutine InitHydrSites(sites,bc_in) - ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) + ! Arguments + type(ed_site_type),intent(inout),target :: sites(:) + type(bc_in_type),intent(in) :: bc_in(:) - ccohort_hydr%qtop = (currentCohort%n*ccohort_hydr%qtop + & - nextCohort%n*ncohort_hydr%qtop)/newn + ! Locals + integer :: nsites + integer :: s + integer :: j + integer :: jj + type(ed_site_hydr_type),pointer :: csite_hydr - 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 + if ( hlm_use_planthydro.eq.ifalse ) return - ! ===================================================================================== - ! Initialization Routines - ! ===================================================================================== + ! Initialize any derived hydraulics parameters - subroutine InitHydrCohort(currentSite,currentCohort) + 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 - ! Arguments - type(ed_site_type), target :: currentSite - type(ed_cohort_type), target :: currentCohort - type(ed_cohort_hydr_type), pointer :: ccohort_hydr + ! 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 - if ( hlm_use_planthydro.eq.ifalse ) return - allocate(ccohort_hydr) - currentCohort%co_hydr => ccohort_hydr - call ccohort_hydr%AllocateHydrCohortArrays(currentSite%si_hydr%nlevrhiz) + csite_hydr%nlevrhiz = csite_hydr%i_rhiz_b-csite_hydr%i_rhiz_t+1 + call sites(s)%si_hydr%InitHydrSite(numpft,nlevsclass) - ccohort_hydr%is_newly_recruited = .false. + 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 subroutine InitHydrCohort + end do - ! ===================================================================================== - subroutine DeallocateHydrCohort(currentCohort) +end subroutine InitHydrSites - ! Arguments - type(ed_cohort_type), target :: currentCohort - type(ed_cohort_hydr_type), pointer :: ccohort_hydr +! =================================================================================== +subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) - if ( hlm_use_planthydro.eq.ifalse ) return - ccohort_hydr => currentCohort%co_hydr - call ccohort_hydr%DeAllocateHydrCohortArrays() - deallocate(ccohort_hydr) + ! Arguments + type(ed_site_type),intent(inout),target :: sites(:) + type(bc_in_type),intent(in) :: bc_in(:) - return - end subroutine DeallocateHydrCohort + ! 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 - ! ===================================================================================== - subroutine InitHydrSites(sites,bc_in) + nsites = ubound(sites,1) - ! Arguments - type(ed_site_type),intent(inout),target :: sites(:) - type(bc_in_type),intent(in) :: bc_in(:) + do s = 1,nsites - ! Locals - integer :: nsites - integer :: s - integer :: j - integer :: jj - type(ed_site_hydr_type),pointer :: csite_hydr + 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 - if ( hlm_use_planthydro.eq.ifalse ) return - ! Initialize any derived hydraulics parameters + site_hydr%l_aroot_layer(1:site_hydr%nlevrhiz) = 0.0_r8 - 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 - - 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 + ! -------------------------------------------------------------------------------- + ! 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 + ! ----------------------------------------------------------------------------------- - end subroutine InitHydrSites + 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 + + ! ----------------------------------------------------------------------------------- + ! 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 + 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 - ! =================================================================================== - subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) + end do + ! + !! call UpdateH2OVeg(nsites,sites,bc_out) - ! Arguments - type(ed_site_type),intent(inout),target :: sites(:) - type(bc_in_type),intent(in) :: bc_in(:) + ! -------------------------------------------------------------------------------- + ! 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 + ! -------------------------------------------------------------------------------- - ! 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 + return +end subroutine HydrSiteColdStart +! ===================================================================================== - nsites = ubound(sites,1) +subroutine UpdateH2OVeg(nsites,sites,bc_out) - do s = 1,nsites + ! ---------------------------------------------------------------------------------- + ! 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. + ! ---------------------------------------------------------------------------------- - 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 - + ! 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(:)) + & + 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_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 + + + return +end subroutine UpdateH2OVeg + +!===================================================================================== +subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) - site_hydr%l_aroot_layer(1:site_hydr%nlevrhiz) = 0.0_r8 + ! ---------------------------------------------------------------------------------- + ! 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) :: 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. + 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%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 + ! --------------------------------------------------------------------------- + + ! 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) :: 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 + + 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 subroutine ConstrainRecruitNumber + + +! ===================================================================================== + +subroutine SavePreviousRhizVolumes(currentSite) + + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + type(ed_site_hydr_type), pointer :: csite_hydr + + csite_hydr => currentSite%si_hydr + 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) - ! -------------------------------------------------------------------------------- - ! 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 - ! ----------------------------------------------------------------------------------- + ! + ! !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 tapped by fine roots remains + ! the same. + ! + ! !USES: - 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 - ! ----------------------------------------------------------------------------------- - ! 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 - 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 + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type) , intent(in) :: bc_in - end do + ! + ! !LOCAL VARIABLES: + type(ed_site_hydr_type), pointer :: csite_hydr + type(ed_patch_type) , pointer :: cPatch + type(ed_cohort_type) , pointer :: cCohort + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + real(r8) :: hksat_s ! hksat converted to units of 10^6sec + ! which is equiv to [kg m-1 s-1 MPa-1] + 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 :: nlevrhiz + integer, parameter :: k_inner = 1 ! innermost rhizosphere shell + !----------------------------------------------------------------------- + + csite_hydr => currentSite%si_hydr + 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 + cPatch => currentSite%youngest_patch + do while(associated(cPatch)) + cCohort => cPatch%tallest + do while(associated(cCohort)) + ccohort_hydr => cCohort%co_hydr + csite_hydr%l_aroot_layer(:) = csite_hydr%l_aroot_layer(:) + ccohort_hydr%l_aroot_layer(:)*cCohort%n + cCohort => cCohort%shorter + enddo !cohort + cPatch => cPatch%older + enddo !patch + + ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) + 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, csite_hydr%dz_rhiz(j), & + csite_hydr%r_out_shell(j,:), csite_hydr%r_node_shell(j,:),csite_hydr%v_shell(j,:)) + ! end if !has l_aroot_layer changed? + enddo + + + do j = 1,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 + + ! 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 - ! - !! call UpdateH2OVeg(nsites,sites,bc_out) + 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 - ! -------------------------------------------------------------------------------- - ! 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 - ! -------------------------------------------------------------------------------- + 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 - return - end subroutine HydrSiteColdStart + 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 - ! ===================================================================================== - 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. - ! ---------------------------------------------------------------------------------- - ! Arguments - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) - type(bc_out_type), intent(inout) :: bc_out(nsites) + end if !has l_aroot_layer changed? + enddo ! loop over soil layers - ! 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 + return +end subroutine UpdateSizeDepRhizVolLenCon - !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 +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 + ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains + ! the same. + ! + ! !USES: - 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(:)) + & - 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_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 + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type) , intent(in) :: bc_in - end do + ! Save current volumes, lenghts and nodes to an "initial" + ! used to calculate effects in states later on. - return - end subroutine UpdateH2OVeg + call SavePreviousRhizVolumes(currentSite) - !===================================================================================== - subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) + ! Update the properties of the vegetation-soil hydraulic environment + ! these are independent on the water state - ! ---------------------------------------------------------------------------------- - ! 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. - ! ---------------------------------------------------------------------------------- + call UpdateSizeDepRhizVolLenCon(currentSite, bc_in) - ! 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) :: 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. - 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%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 + return +end subroutine UpdateSizeDepRhizHydProps +! ================================================================================= - end subroutine RecruitWUptake +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 + ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains + ! the same. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_site_type), intent(inout), target :: currentSite + type(bc_in_type), intent(in) :: bc_in + ! + ! !LOCAL VARIABLES: + 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 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] + real(r8) :: h2osoi_liq_col_new(nlevsoi_hyd_max) ! water mass per area after interpolating to new rhizosphere [kg/m2] + real(r8) :: s_shell_init(nlevsoi_hyd_max,nshell) ! initial saturation fraction in rhizosphere compartment [0-1] + real(r8) :: s_shell_interp(nlevsoi_hyd_max,nshell) ! interpolated saturation fraction in rhizosphere compartment [0-1] + real(r8) :: psi_shell_init(nlevsoi_hyd_max,nshell) ! initial water potential in rhizosphere compartment [MPa] + real(r8) :: psi_shell_interp(nlevsoi_hyd_max,nshell) ! interpolated psi_shell to new r_node_shell [MPa] + 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 + s_shell_interp(:,:) = 0._r8 + + csite_hydr => currentSite%si_hydr + + if(.false.) then + + 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 + psi_shell_init(j,k) = csite_hydr%wrf_soil(j)%p%psi_from_th(csite_hydr%h2osoi_liqvol_shell(j,k)) + end do - !===================================================================================== - subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) + end if !has l_aroot_coh changed? + enddo - ! --------------------------------------------------------------------------- - ! This subroutine constrains the number of plants so that there is enought water - ! for newly recruited individuals from the soil - ! --------------------------------------------------------------------------- + ! 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 + end if + end if !has l_aroot_coh changed? + enddo - ! 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 + ! 1st guess at new s based on interpolated psi + do j = 1,csite_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 - ! 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) :: 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 - - 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 + ! proceed only if l_aroot_coh has changed + if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - 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) + 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)) - 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) + end if !has l_aroot_coh changed? + enddo - !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) + ! 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 + 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 + end if !has l_aroot_coh changed? + enddo - end do + ! 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 - 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) + ! 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 + 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 subroutine ConstrainRecruitNumber + ! 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 ',& + ' updating rhizosphere shells: ',j,errh2o(j) + write(fates_log(),*)'errh2o= ',errh2o(j), ' [kg/m2]' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + enddo + end if !nshell > 1 + +end subroutine UpdateSizeDepRhizHydStates + +! ==================================================================================== + +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 * & + (cCohort%prt%GetState(fnrt_organ, all_carbon_elements) + & + cCohort%prt%GetState(sapw_organ, all_carbon_elements) + & + cCohort%prt%GetState(leaf_organ, all_carbon_elements)) * & + ccohort%n / balive_patch + ccohort => ccohort%shorter + enddo !cohort + cpatch => cpatch%younger + enddo !end patch loop + end do + return +end subroutine BTranForHLMDiagnosticsFromCohortHydr + +! ========================================================================== + +subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) + ! + ! Created by Brad Christoffersen, Jan 2016 + ! + ! !DESCRIPTION: + ! Parses out mean vertical water fluxes resulting from infiltration, + ! drainage, and vertical water movement (dwat_kgm2) over radially stratified + ! rhizosphere shells. + ! + ! The approach used is heuristic, but based on the principle that water + ! fluxing out of a layer will preferentially come from rhizosphere + ! shells with higher water contents/potentials within that layer, and + ! alternatively, that water fluxing into a layer will preferentially go + ! into shells with lower water contents/potentials. + ! + ! This principle is implemented by filling (draining) the rhizosphere + ! shells in order from the driest (wettest) shell to the wettest (driest). + ! Each shell is filled (drained) up (down) to the next wettest (driest) + ! shell until the change in mean layer water (dwat_kgm2) is accounted for. + ! + ! !USES: + ! + ! !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) + + ! Locals + 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 + + + ! First step, identify how the liquid water in each layer has changed + ! since the last time it was updated. This should be due to drainage. + ! The drainage component should be the total change in liquid water content from the last time + ! the hydraulics driver was called, and then adding back in the losses due to root uptake + ! (which was already taken out). + + ! BOC: This was previously in HydrologyDrainage: + + csite_hydr => sites(s)%si_hydr + + 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 + ! algorithm same as that used in histFileMod.F90 to alphabetize history tape contents + if(nshell > 1) then + do k = nshell-1,1,-1 + do kk = 1,k + if (csite_hydr%h2osoi_liqvol_shell(j,ordered(kk)) > & + csite_hydr%h2osoi_liqvol_shell(j,ordered(kk+1))) then + if (dwat_kg > 0._r8) then !order increasing + tmp = ordered(kk) + ordered(kk) = ordered(kk+1) + ordered(kk+1) = tmp + end if + else + if (dwat_kg < 0._r8) then !order decreasing + tmp = ordered(kk) + ordered(kk) = ordered(kk+1) + ordered(kk+1) = tmp + end if + end if + enddo + enddo + end if - ! ===================================================================================== + ! fill shells with water up to the water content of the next-wettest shell, + ! in order from driest to wettest (dwat_kg > 0) + ! ------ OR ------ + ! drain shells' water down to the water content of the next-driest shell, + ! in order from wettest to driest (dwat_kg < 0) + k = 1 + do while ( (dwat_kg /= 0._r8) .and. (k < nshell) ) + thdiff = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) - & + csite_hydr%h2osoi_liqvol_shell(j,ordered(k)) + v_cum = sum(csite_hydr%v_shell(j,ordered(1:k))) + wdiff = thdiff * v_cum * denh2o ! change in h2o [kg / ha] for shells ordered(1:k) + if(abs(dwat_kg) >= abs(wdiff)) then + csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) + dwat_kg = dwat_kg - wdiff + else + csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = & + csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) + dwat_kg/denh2o/v_cum + dwat_kg = 0._r8 + end if + k = k + 1 + enddo + + if (dwat_kg /= 0._r8) then + v_cum = sum(csite_hydr%v_shell(j,ordered(1:nshell))) + thdiff = dwat_kg / v_cum / denh2o + do k = nshell, 1, -1 + csite_hydr%h2osoi_liqvol_shell(j,k) = csite_hydr%h2osoi_liqvol_shell(j,k) + thdiff + end do + end if - subroutine SavePreviousRhizVolumes(currentSite) + ! m3/m3 * Total volume m3 * kg/m3 = kg + h2osoi_liq_shell(j,:) = csite_hydr%h2osoi_liqvol_shell(j,:) * & + csite_hydr%v_shell(j,:) * denh2o - ! !ARGUMENTS: - type(ed_site_type) , intent(inout), target :: currentSite - type(ed_site_hydr_type), pointer :: csite_hydr - csite_hydr => currentSite%si_hydr - 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(:,:) + errh2o(j) = sum(h2osoi_liq_shell(j,:))*AREA_INV - bc_in(s)%h2o_liq_sisl(j_bc) - return - end subroutine SavePreviousRhizVolumes + 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 - subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) +! ==================================================================================== - ! - ! !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 tapped by fine roots remains - ! the same. - ! - ! !USES: +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 - ! !ARGUMENTS: - type(ed_site_type) , intent(inout), target :: currentSite - type(bc_in_type) , intent(in) :: bc_in + ! 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 + ! ---------------------------------------------------------------------------------- - ! - ! !LOCAL VARIABLES: - type(ed_site_hydr_type), pointer :: csite_hydr - type(ed_patch_type) , pointer :: cPatch - type(ed_cohort_type) , pointer :: cCohort - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - real(r8) :: hksat_s ! hksat converted to units of 10^6sec - ! which is equiv to [kg m-1 s-1 MPa-1] - 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 :: nlevrhiz - integer, parameter :: k_inner = 1 ! innermost rhizosphere shell - !----------------------------------------------------------------------- + ! + ! !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 - csite_hydr => currentSite%si_hydr - 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 - cPatch => currentSite%youngest_patch - do while(associated(cPatch)) - cCohort => cPatch%tallest - do while(associated(cCohort)) - ccohort_hydr => cCohort%co_hydr - csite_hydr%l_aroot_layer(:) = csite_hydr%l_aroot_layer(:) + ccohort_hydr%l_aroot_layer(:)*cCohort%n - cCohort => cCohort%shorter - enddo !cohort - cPatch => cPatch%older - enddo !patch - - ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) - 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, 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 + ! + ! !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 + + !---------------------------------------------------------------------- + + 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 + + ! 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)/) + + ! 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. + ! ---------------------------------------------------------------------------------- - 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 - - ! 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 + !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 + + 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)) + if(cpatch%nocomp_pft_label.ne.0)then + 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 - 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 - ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains - ! the same. - ! - ! !USES: + ! 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 | + !--------------------------------------------------------------------------- + + + if(use_2d_hydrosolve) then - ! !ARGUMENTS: - type(ed_site_type) , intent(inout), target :: currentSite - type(bc_in_type) , intent(in) :: bc_in + call MatSolve2D(bc_in(s),site_hydr,ccohort,ccohort_hydr, & + dtime,qflx_tran_veg_indiv, & + sapflow,rootuptake(1:nlevrhiz),wb_err_plant,dwat_plant, & + dth_layershell_col) + + else + + ! --------------------------------------------------------------------------------- + ! 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 + ! ----------------------------------------------------------------------------------- + + 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 - ! Save current volumes, lenghts and nodes to an "initial" - ! used to calculate effects in states later on. + ! Remember the error for the cohort + ccohort_hydr%errh2o = ccohort_hydr%errh2o + wb_err_plant - call SavePreviousRhizVolumes(currentSite) + ! Update total error in [kg/m2 ground] + site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + wb_err_plant*ccohort%n*AREA_INV - ! Update the properties of the vegetation-soil hydraulic environment - ! these are independent on the water state + ! 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 - call UpdateSizeDepRhizVolLenCon(currentSite, bc_in) + ! 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 - return - end subroutine UpdateSizeDepRhizHydProps + ! 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 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 - ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains - ! the same. - ! - ! !USES: - ! - ! !ARGUMENTS: - type(ed_site_type), intent(inout), target :: currentSite - type(bc_in_type), intent(in) :: bc_in - ! - ! !LOCAL VARIABLES: - 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 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] - real(r8) :: h2osoi_liq_col_new(nlevsoi_hyd_max) ! water mass per area after interpolating to new rhizosphere [kg/m2] - real(r8) :: s_shell_init(nlevsoi_hyd_max,nshell) ! initial saturation fraction in rhizosphere compartment [0-1] - real(r8) :: s_shell_interp(nlevsoi_hyd_max,nshell) ! interpolated saturation fraction in rhizosphere compartment [0-1] - real(r8) :: psi_shell_init(nlevsoi_hyd_max,nshell) ! initial water potential in rhizosphere compartment [MPa] - real(r8) :: psi_shell_interp(nlevsoi_hyd_max,nshell) ! interpolated psi_shell to new r_node_shell [MPa] - 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 - !----------------------------------------------------------------------- + ! 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) - s_shell_init(:,:) = 0._r8 - psi_shell_init(:,:) = 0._r8 - psi_shell_interp(:,:) = 0._r8 - s_shell_interp(:,:) = 0._r8 - - csite_hydr => currentSite%si_hydr - - if(.false.) then - - 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 - psi_shell_init(j,k) = csite_hydr%wrf_soil(j)%p%psi_from_th(csite_hydr%h2osoi_liqvol_shell(j,k)) - end do - - end if !has l_aroot_coh changed? - enddo - - ! 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 - end if - end if !has l_aroot_coh changed? - enddo - - ! 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)) - - end if !has l_aroot_coh changed? - enddo - - ! 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 - 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 - 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 - 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 - - ! 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 ',& - ' updating rhizosphere shells: ',j,errh2o(j) - write(fates_log(),*)'errh2o= ',errh2o(j), ' [kg/m2]' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - enddo - - end if !nshell > 1 - - end subroutine UpdateSizeDepRhizHydStates + 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 - ! ==================================================================================== - - subroutine BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) + 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 - ! Arguments - integer,intent(in) :: nsites - type(ed_site_type),intent(inout),target :: sites(nsites) - type(bc_out_type),intent(inout) :: bc_out(nsites) + 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 - ! Locals - integer :: s - integer :: ifp - real(r8) :: balive_patch - type(ed_patch_type),pointer :: cpatch - type(ed_cohort_type),pointer :: ccohort + 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 - do s = 1,nsites + ! --------------------------------------------------------- + ! Update water potential and frac total conductivity + ! of plant compartments + ! --------------------------------------------------------- - 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 + call UpdatePlantPsiFTCFromTheta(ccohort,site_hydr) - ! ========================================================================== + ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) - subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) - ! - ! Created by Brad Christoffersen, Jan 2016 - ! - ! !DESCRIPTION: - ! Parses out mean vertical water fluxes resulting from infiltration, - ! drainage, and vertical water movement (dwat_kgm2) over radially stratified - ! rhizosphere shells. - ! - ! The approach used is heuristic, but based on the principle that water - ! fluxing out of a layer will preferentially come from rhizosphere - ! shells with higher water contents/potentials within that layer, and - ! alternatively, that water fluxing into a layer will preferentially go - ! into shells with lower water contents/potentials. - ! - ! This principle is implemented by filling (draining) the rhizosphere - ! shells in order from the driest (wettest) shell to the wettest (driest). - ! Each shell is filled (drained) up (down) to the next wettest (driest) - ! shell until the change in mean layer water (dwat_kgm2) is accounted for. - ! - ! !USES: - ! - ! !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) - ! Locals - 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 - !----------------------------------------------------------------------- + ccohort => ccohort%shorter + enddo !cohort + endif ! not barground patch + cpatch => cpatch%younger + enddo !patch - do s = 1,nsites + ! -------------------------------------------------------------------------------- + ! 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] - ! First step, identify how the liquid water in each layer has changed - ! since the last time it was updated. This should be due to drainage. - ! The drainage component should be the total change in liquid water content from the last time - ! the hydraulics driver was called, and then adding back in the losses due to root uptake - ! (which was already taken out). - - ! BOC: This was previously in HydrologyDrainage: - - csite_hydr => sites(s)%si_hydr - - 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 - ! algorithm same as that used in histFileMod.F90 to alphabetize history tape contents - if(nshell > 1) then - do k = nshell-1,1,-1 - do kk = 1,k - if (csite_hydr%h2osoi_liqvol_shell(j,ordered(kk)) > & - csite_hydr%h2osoi_liqvol_shell(j,ordered(kk+1))) then - if (dwat_kg > 0._r8) then !order increasing - tmp = ordered(kk) - ordered(kk) = ordered(kk+1) - ordered(kk+1) = tmp - end if - else - if (dwat_kg < 0._r8) then !order decreasing - tmp = ordered(kk) - ordered(kk) = ordered(kk+1) - ordered(kk+1) = tmp - end if - end if - enddo - enddo - end if - - ! fill shells with water up to the water content of the next-wettest shell, - ! in order from driest to wettest (dwat_kg > 0) - ! ------ OR ------ - ! drain shells' water down to the water content of the next-driest shell, - ! in order from wettest to driest (dwat_kg < 0) - k = 1 - do while ( (dwat_kg /= 0._r8) .and. (k < nshell) ) - thdiff = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) - & - csite_hydr%h2osoi_liqvol_shell(j,ordered(k)) - v_cum = sum(csite_hydr%v_shell(j,ordered(1:k))) - wdiff = thdiff * v_cum * denh2o ! change in h2o [kg / ha] for shells ordered(1:k) - if(abs(dwat_kg) >= abs(wdiff)) then - csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) - dwat_kg = dwat_kg - wdiff - else - csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = & - csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) + dwat_kg/denh2o/v_cum - dwat_kg = 0._r8 - end if - k = k + 1 - enddo - - if (dwat_kg /= 0._r8) then - v_cum = sum(csite_hydr%v_shell(j,ordered(1:nshell))) - thdiff = dwat_kg / v_cum / denh2o - do k = nshell, 1, -1 - csite_hydr%h2osoi_liqvol_shell(j,k) = csite_hydr%h2osoi_liqvol_shell(j,k) + thdiff - end do - end if - - ! m3/m3 * Total volume m3 * kg/m3 = kg - h2osoi_liq_shell(j,:) = csite_hydr%h2osoi_liqvol_shell(j,:) * & - csite_hydr%v_shell(j,:) * denh2o - - - errh2o(j) = sum(h2osoi_liq_shell(j,:))*AREA_INV - bc_in(s)%h2o_liq_sisl(j_bc) - - if (abs(errh2o(j)) > 1.e-9_r8) then - write(fates_log(),*)'WARNING: water balance error in FillDrainRhizShells' - write(fates_log(),*)'errh2o= ',errh2o(j), ' [kg/m2]' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end do + root_flux = -sum(dth_layershell_col(1:site_hydr%nlevrhiz,:)*site_hydr%v_shell(:,:))*denh2o*AREA_INV - end do - return - end subroutine FillDrainRhizShells - ! ==================================================================================== + do j=1,site_hydr%nlevrhiz + j_bc = j+site_hydr%i_rhiz_t-1 - subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) + ! 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,:) - ! ---------------------------------------------------------------------------------- - ! 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 - ! ---------------------------------------------------------------------------------- + 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) - ! - ! !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 + ! 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) - ! - ! !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 - !---------------------------------------------------------------------- - - 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 - - ! 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)/) - - ! 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. - ! ---------------------------------------------------------------------------------- + ! 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 - !For newly recruited cohorts, add the water uptake demand to csite_hydr%recruit_w_uptake - call RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) + 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 - !update water storage in veg after incorporating newly recuited cohorts - if(recruitflag) call UpdateH2OVeg(nsites,sites,bc_out) + ! [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 - do s = 1, nsites + site_hydr%h2osoi_liqvol_shell(j,i) = bc_in(s)%watsat_sisl(j_bc)-thsat_buff - site_hydr => sites(s)%si_hydr + end if + end do - 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(j_bc) = site_runoff/dtime + end if + enddo - 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 + ! Note that the cohort-level solvers are expected to update + ! site_hydr%h2oveg - ! Initialize water mass balancing terms [kg h2o / m2] - ! -------------------------------------------------------------------------------- - transp_flux = 0._r8 - root_flux = 0._r8 - - ! Initialize the delta in soil water and plant water storage - ! with the initial condition. - - !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)) - if(cpatch%nocomp_pft_label.ne.0)then - 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)) + ! Calculate site total kg's of runoff + site_runoff = sum(bc_out(s)%qflx_ro_sisl(:))*dtime - 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 | - !--------------------------------------------------------------------------- - - - if(use_2d_hydrosolve) then + delta_plant_storage = site_hydr%h2oveg - prev_h2oveg - call MatSolve2D(bc_in(s),site_hydr,ccohort,ccohort_hydr, & - dtime,qflx_tran_veg_indiv, & - sapflow,rootuptake(1:nlevrhiz),wb_err_plant,dwat_plant, & - dth_layershell_col) - - else - - ! --------------------------------------------------------------------------------- - ! 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 - ! ----------------------------------------------------------------------------------- - - 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 - - ! Remember the error for the cohort - ccohort_hydr%errh2o = ccohort_hydr%errh2o + wb_err_plant - - ! Update total error in [kg/m2 ground] - site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + wb_err_plant*ccohort%n*AREA_INV - - ! Accumulate site level diagnostic of plant water change [kg/m2] - ! (this is zerod) - site_hydr%dwat_veg = site_hydr%dwat_veg + dwat_plant*ccohort%n*AREA_INV - - ! Update total site-level stored plant water [kg/m2] - ! (this is not zerod, but incremented) - site_hydr%h2oveg = site_hydr%h2oveg + dwat_plant*ccohort%n*AREA_INV - - 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 - - ! Root uptake per pft x size class, over set layer depths [kg/ha/m/s] - ! These are normalized by depth (in case the desired horizon extends - ! beyond the actual rhizosphere) - - site_hydr%rootuptake0_scpf(sc,ft) = site_hydr%rootuptake0_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,0._r8,0.1_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - - site_hydr%rootuptake10_scpf(sc,ft) = site_hydr%rootuptake10_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,0.1_r8,0.5_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - - site_hydr%rootuptake50_scpf(sc,ft) = site_hydr%rootuptake50_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,0.5_r8,1.0_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - - site_hydr%rootuptake100_scpf(sc,ft) = site_hydr%rootuptake100_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,1.0_r8,1.e10_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - - ! --------------------------------------------------------- - ! Update water potential and frac total conductivity - ! of plant compartments - ! --------------------------------------------------------- - - call UpdatePlantPsiFTCFromTheta(ccohort,site_hydr) - - ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) - - - ccohort => ccohort%shorter - enddo !cohort - endif ! not barground patch - cpatch => cpatch%younger - enddo !patch + delta_soil_storage = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & + site_hydr%v_shell(:,:)) * denh2o * AREA_INV - prev_h2osoil - ! -------------------------------------------------------------------------------- - ! The cohort level water fluxes are complete, the remainder of this subroutine - ! is dedicated to doing site level resulting mass balance calculations and checks - ! -------------------------------------------------------------------------------- + if(abs(delta_plant_storage - (root_flux - transp_flux)) > 1.e-3_r8 ) then + write(fates_log(),*) 'Site plant water balance does not close' + write(fates_log(),*) 'balance error: ',abs(delta_plant_storage - (root_flux - transp_flux)) + 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 - ! 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 - - - do j=1,site_hydr%nlevrhiz - j_bc = j+site_hydr%i_rhiz_t-1 - - ! Update the site-level state variable - ! rhizosphere shell water content [m3/m3] - site_hydr%h2osoi_liqvol_shell(j,:) = site_hydr%h2osoi_liqvol_shell(j,:) + & - dth_layershell_col(j,:) - - - 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 + if(abs(delta_soil_storage + root_flux + site_runoff) > 1.e-3_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 - - ! 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-3_r8 ) then - write(fates_log(),*) 'Site plant water balance does not close' - write(fates_log(),*) 'balance error: ',abs(delta_plant_storage - (root_flux - transp_flux)) - 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-3_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 + !----------------------------------------------------------------------- + ! mass balance check and pass the total stored vegetation water to HLM + ! in order for it to fill its balance checks + + + ! 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-5_r8 ) then + ! write(fates_log(),*) 'FATES hydro water ERROR balance does not add up [kg/m2]:',wb_check_site - site_hydr%errh2o_hyd + ! 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 + ! call endrun(msg=errMsg(sourcefile, __LINE__)) + ! end if + + ! Now check on total error + if( abs(wb_check_site) > 1.e-4_r8 ) then + write(fates_log(),*) 'FATES hydro water balance is not so great [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 - !----------------------------------------------------------------------- - ! mass balance check and pass the total stored vegetation water to HLM - ! in order for it to fill its balance checks - - - ! 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-5_r8 ) then -! write(fates_log(),*) 'FATES hydro water ERROR balance does not add up [kg/m2]:',wb_check_site - site_hydr%errh2o_hyd -! 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 -! call endrun(msg=errMsg(sourcefile, __LINE__)) -! end if - - ! Now check on total error - if( abs(wb_check_site) > 1.e-4_r8 ) then - write(fates_log(),*) 'FATES hydro water balance is not so great [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 - 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 - 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 - enddo !site + return +end subroutine Hydraulics_BC - return - end subroutine Hydraulics_BC +! ===================================================================================== - ! ===================================================================================== +subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr) - subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr) + ! --------------------------------------------------------------------------------- + ! + ! This routine sets the maximum conductance of all compartments in the plant, from + ! leaves, to stem, to transporting root, to the absorbing roots. + ! These properties are dependent only on the materials (conductivity) and the + ! geometry of the compartments. + ! The units of all K_max values are [kg H2O s-1 MPa-1] + ! + ! There are some different ways to represent overall conductance from node-to-node + ! throughout the hydraulic system. Universally, all can make use of a system + ! where we separate the hydraulic compartments of the nodes into the upper (closer + ! to the sky) and lower (away from the sky) portions of the compartment. It is + ! possible that due to things like xylem taper, the two portions may have different + ! conductivity, and therefore differnet conductances. + ! + ! Assumption 0. This routine calculates maximum conductivity for 1 plant. + ! Assumption 1. The compartment volumes, heights and lengths have all been + ! determined, probably called just before this routine. + ! + ! Steudle, E. Water uptake by roots: effects of water deficit. + ! J Exp Bot 51, 1531-1542, doi:DOI 10.1093/jexbot/51.350.1531 (2000). + ! --------------------------------------------------------------------------------- + + ! Arguments + + type(ed_cohort_hydr_type),intent(inout),target :: ccohort_hydr + type(ed_cohort_type),intent(in),target :: ccohort + type(ed_site_hydr_type),intent(in),target :: csite_hydr + + ! 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) :: sum_l_aroot ! sum of plant's total root length + 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 + + ! 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(EDPftvarcon_inst%hydr_p_taper(pft), z_upper) * & + a_sapwood / z_upper + + ! max conductance from node to mean petiole height + kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), 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(EDPftvarcon_inst%hydr_p_taper(pft), 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 - ! --------------------------------------------------------------------------------- - ! - ! This routine sets the maximum conductance of all compartments in the plant, from - ! leaves, to stem, to transporting root, to the absorbing roots. - ! These properties are dependent only on the materials (conductivity) and the - ! geometry of the compartments. - ! The units of all K_max values are [kg H2O s-1 MPa-1] - ! - ! There are some different ways to represent overall conductance from node-to-node - ! throughout the hydraulic system. Universally, all can make use of a system - ! where we separate the hydraulic compartments of the nodes into the upper (closer - ! to the sky) and lower (away from the sky) portions of the compartment. It is - ! possible that due to things like xylem taper, the two portions may have different - ! conductivity, and therefore differnet conductances. - ! - ! Assumption 0. This routine calculates maximum conductivity for 1 plant. - ! Assumption 1. The compartment volumes, heights and lengths have all been - ! determined, probably called just before this routine. - ! - ! Steudle, E. Water uptake by roots: effects of water deficit. - ! J Exp Bot 51, 1531-1542, doi:DOI 10.1093/jexbot/51.350.1531 (2000). - ! --------------------------------------------------------------------------------- + enddo - ! Arguments + ! Maximum conductance of the upper compartment in the transporting root + ! that connects to the lowest stem (btw: z_lower_ag(n_hypool_ag) == 0) - 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 + 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 - ! 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) :: sum_l_aroot ! sum of plant's total root length - 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 - - ! 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(EDPftvarcon_inst%hydr_p_taper(pft), z_upper) * & - a_sapwood / z_upper - - ! max conductance from node to mean petiole height - kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), 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(EDPftvarcon_inst%hydr_p_taper(pft), 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 + kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_node) * & + a_sapwood / z_node - ! Maximum conductance of the upper compartment in the transporting root - ! that connects to the lowest stem (btw: z_lower_ag(n_hypool_ag) == 0) + kmax_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_upper) * & + a_sapwood / z_upper - 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 + ccohort_hydr%kmax_troot_upper = (1._r8/kmax_node - 1._r8/kmax_upper)**(-1._r8) - kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_node) * & - a_sapwood / z_node + ! 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: - kmax_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_upper) * & - a_sapwood / z_upper - ccohort_hydr%kmax_troot_upper = (1._r8/kmax_node - 1._r8/kmax_upper)**(-1._r8) + 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 - ! 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: + ! 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 + ! + ! if kmax_bg = 1/rmin_bg : + ! + ! kmax_bg = 1/((1/fr-1) * rmin_ag) + kmax_bg = 1._r8/(rmin_ag*(1._r8/EDPftvarcon_inst%hydr_rfrac_stem(pft) - 1._r8)) - 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 - ! - ! if kmax_bg = 1/rmin_bg : - ! - ! kmax_bg = 1/((1/fr-1) * rmin_ag) - - kmax_bg = 1._r8/(rmin_ag*(1._r8/EDPftvarcon_inst%hydr_rfrac_stem(pft) - 1._r8)) - - - ! The max conductance of each layer is in parallel, therefore - ! the kmax terms of each layer, should sum to kmax_bg - 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 + ! 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 - end do + kmax_layer = kmax_bg*ccohort_hydr%l_aroot_layer(j)/sum_l_aroot - ! 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. + ! 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) - do j=1,csite_hydr%nlevrhiz + 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 - ! 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) + end do - ! 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 + ! 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. - ccohort_hydr%kmax_aroot_radial_out(j) = hydr_kmax_rsurf2 * surfarea_aroot_layer + do j=1,csite_hydr%nlevrhiz - end do + ! 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) - return - end subroutine UpdatePlantKmax + ! 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 - subroutine OrderLayersForSolve1D(site_hydr,cohort,cohort_hydr,ordered, kbg_layer) - - ! Arguments (IN) - type(ed_site_hydr_type), intent(in),target :: site_hydr - type(ed_cohort_type), intent(in),target :: cohort - type(ed_cohort_hydr_type),intent(in),target :: cohort_hydr + end do + return +end subroutine UpdatePlantKmax - ! 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 - - ft = cohort%pft - - do j=1,site_hydr%nlevrhiz - - ! 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)) - - ! 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 site_hydr%pm_node) + ! 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 + + + ! 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 + + ft = cohort%pft + + do j=1,site_hydr%nlevrhiz + + ! 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)) + + ! 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 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 + 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 - if(weight_serial_dt)then - dt_step = dtime*kbg_layer(ilayer) - else - dt_step = dtime/real(site_hydr%nlevrhiz,r8) - end if + dt_step = dtime/real(site_hydr%nlevrhiz,r8) 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 + 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 - rootfr_scaler = 1.0_r8 + 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 - 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 + ! 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 - ! 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 + solution_found = .false. + iter = 0 + do while( .not.solution_found ) - 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 + ! 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) - 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 + 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 - ! Total water mass in the plant at the beginning of this solve [kg h2o] - w_tot_beg = sum(th_node(:)*v_node(:))*denh2o + sapflow_lyr = 0._r8 + rootuptake_lyr = 0._r8 - ! Calculate on-node quantities: potential, and derivatives - do i = 1,n_hypool_plant + ! For each attempt, we want to reset theta with the initial value + th_node(:) = th_node_init(:) - ! Get matric potential [Mpa] - psi_node(i) = wrf_plant(pm_node(i),ft)%p%psi_from_th(th_node(i)) + ! Determine how many substeps, and how long they are - ! Get total potential [Mpa] - h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) + 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. - ! Get Fraction of Total Conductivity [-] - ftc_node(i) = wkf_plant(pm_node(i),ft)%p%ftc_from_psi(psi_node(i)) + dt_substep = dt_step/real(nsteps,r8) ! This is the sub-stem length in seconds - ! deriv psi wrt theta - dpsi_dtheta_node(i) = wrf_plant(pm_node(i),ft)%p%dpsidth_from_th(th_node(i)) + ! Walk through sub-steps + do istep = 1,nsteps - ! deriv ftc wrt psi + ! Total water mass in the plant at the beginning of this solve [kg h2o] + w_tot_beg = sum(th_node(:)*v_node(:))*denh2o - dftc_dpsi = wkf_plant(pm_node(i),ft)%p%dftcdpsi_from_psi(psi_node(i)) + ! Calculate on-node quantities: potential, and derivatives + do i = 1,n_hypool_plant - dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) + ! Get matric potential [Mpa] + psi_node(i) = wrf_plant(pm_node(i),ft)%p%psi_from_th(th_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 + ! Get total potential [Mpa] + h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) - 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 + ! 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 + + ! If desired, check and trap water contents + ! that are negative + if(trap_neg_wc) then + if( any(th_node(:)<0._r8) ) then + solution_found = .false. + error_code = 3 + error_arr(:) = th_node(:) + exit + 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 + ! 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 + + ! If desired, check and trap pressures that are supersaturated + if(trap_supersat_psi) then + do i = 1,n_hypool_plant + if(psi_node(i)>wrf_plant(pm_node(i),ft)%p%get_thsat()) 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 + error_code = 4 + end if + end do + do i = n_hypool_plant+1,n_hypool_tot + if(psi_node(i)>site_hydr%wrf_soil(ilayer)%p%get_thsat()) 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 - - ! If desired, check and trap water contents - ! that are negative - if(trap_neg_wc) then - if( any(th_node(:)<0._r8) ) then - solution_found = .false. - error_code = 3 - error_arr(:) = th_node(:) - exit - end if - 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 - - ! If desired, check and trap pressures that are supersaturated - if(trap_supersat_psi) then - do i = 1,n_hypool_plant - if(psi_node(i)>wrf_plant(pm_node(i),ft)%p%get_thsat()) then - solution_found = .false. - error_code = 4 - end if - end do - do i = n_hypool_plant+1,n_hypool_tot - if(psi_node(i)>site_hydr%wrf_soil(ilayer)%p%get_thsat()) then - solution_found = .false. - error_code = 4 - end if - end do - if(error_code==4) then - error_arr(:) = th_node(:) - end if - end if - - ! Accumulate the water balance error of the layer over the sub-steps - ! for diagnostic purposes - ! [kg/m2] - wb_err_layer = wb_err_layer + wb_step_err - - ! ------------------------------------------------------------------------- - ! Diagnostics - ! ------------------------------------------------------------------------- - - ! Sapflow at the base of the tree is the flux rate - ! between the transporting root node and the first stem node - ! (note: a path j is between node i and i+1) - ! [kg] = [kg/s] * [s] - - i = n_hypool_ag - sapflow_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 + error_code = 4 + end if + end do + if(error_code==4) then + error_arr(:) = th_node(:) + end if + end if + ! Accumulate the water balance error of the layer over the sub-steps + ! for diagnostic purposes + ! [kg/m2] + wb_err_layer = wb_err_layer + wb_step_err + + ! ------------------------------------------------------------------------- + ! Diagnostics + ! ------------------------------------------------------------------------- + + ! Sapflow at the base of the tree is the flux rate + ! between the transporting root node and the first stem node + ! (note: a path j is between node i and i+1) + ! [kg] = [kg/s] * [s] + + i = n_hypool_ag + sapflow_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 - ! 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,r8)) - ! Save the number of sub-steps we ultimately used - cohort_hydr%iterh2 = max(cohort_hydr%iterh2,real(nsteps,r8)) - - ! 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 + end do ! do istep = 1,nsteps (substep loop) - ! ===================================================================================== + iter=iter+1 - 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(:) + end do - cohort_hydr => cohort%co_hydr - ft = cohort%pft + ! ----------------------------------------------------------- + ! Do a final check on water balance error sumed over sub-steps + ! ------------------------------------------------------------ + if ( abs(wb_err_layer) > max_wb_err ) then - allocate(psi_node(size(z_node))) - allocate(h_node(size(z_node))) + 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' - 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(:) + 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 - 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 + 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 - 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... + ! 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. - 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 + dth_node(:) = th_node(:)-th_node_init(:) - 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)) + ! Add the current soil layer's contribution to total + ! sap and root flux [kg] + sapflow = sapflow + sapflow_lyr + rootuptake(ilayer) = rootuptake_lyr - ! "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 - - + ! 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 - return - end subroutine GetImTaylorKAB + ! Save the number of times we refined our sub-step counts (iterh1) + cohort_hydr%iterh1 = max(cohort_hydr%iterh1,real(iter,r8)) + ! Save the number of sub-steps we ultimately used + cohort_hydr%iterh2 = max(cohort_hydr%iterh2,real(nsteps,r8)) + + ! 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 if + +! Calculate total effective conductance over path [kg s-1 MPa-1] +k_eff = 1._r8/(1._r8/(ftc_up*kmax_up)+1._r8/(ftc_dn*kmax_dn)) + +! "A" term, which operates on the downstream node (closer to atm) +a_term = k_eff**2.0_r8 * h_diff * kmax_dn**(-1.0_r8) * ftc_dn**(-2.0_r8) & + * dftc_dtheta_dn - k_eff * dpsi_dtheta_dn + + +! "B" term, which operates on the 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(in) :: ftc_dn ! frac total cond (downstream) [-] +real(r8),intent(in) :: ftc_up ! frac total cond (upstream) [-] +real(r8),intent(in) :: dftc_dpsi_dn ! derivative ftc / theta (downstream) +real(r8),intent(in) :: 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 +real(r8) :: ftc_dnx ! frac total cond (downstream) [-] (local copy) +real(r8) :: ftc_upx ! frac total cond (upstream) [-] (local copy) +real(r8) :: dftc_dpsi_dnx ! derivative ftc / theta (downstream) (local copy) +real(r8) :: dftc_dpsi_upx ! derivative ftc / theta (upstream) (local copy) - 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(in) :: ftc_dn ! frac total cond (downstream) [-] - real(r8),intent(in) :: ftc_up ! frac total cond (upstream) [-] - real(r8),intent(in) :: dftc_dpsi_dn ! derivative ftc / theta (downstream) - real(r8),intent(in) :: 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 - real(r8) :: ftc_dnx ! frac total cond (downstream) [-] (local copy) - real(r8) :: ftc_upx ! frac total cond (upstream) [-] (local copy) - real(r8) :: dftc_dpsi_dnx ! derivative ftc / theta (downstream) (local copy) - real(r8) :: dftc_dpsi_upx ! derivative ftc / theta (upstream) (local copy) - - - - ! We use the local copies of the FTC in our calculations - ! because we don't want to over-write the global values. This prevents - ! us from overwriting FTC on nodes that have more than one connection - - ftc_dnx = ftc_dn - ftc_upx = ftc_up - dftc_dpsi_dnx = dftc_dpsi_dn - dftc_dpsi_upx = dftc_dpsi_up - - ! 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_dnx = ftc_up - dftc_dpsi_dnx = 0._r8 - else - ftc_upx = ftc_dn - dftc_dpsi_upx = 0._r8 - end if - end if +! We use the local copies of the FTC in our calculations +! because we don't want to over-write the global values. This prevents +! us from overwriting FTC on nodes that have more than one connection - ! Calculate total effective conductance over path [kg s-1 MPa-1] - k_eff = 1._r8/(1._r8/(ftc_upx*kmax_up)+1._r8/(ftc_dnx*kmax_dn)) +ftc_dnx = ftc_dn +ftc_upx = ftc_up +dftc_dpsi_dnx = dftc_dpsi_dn +dftc_dpsi_upx = dftc_dpsi_up - dk_dpsi_dn = k_eff**2._r8 * kmax_dn**(-1._r8) * ftc_dnx**(-2._r8) * dftc_dpsi_dnx +! Calculate difference in total potential over the path [MPa] - dk_dpsi_up = k_eff**2._r8 * kmax_up**(-1._r8) * ftc_upx**(-2._r8) * dftc_dpsi_upx - +h_diff = h_up - h_dn - return - end subroutine GetKAndDKDPsi - +! 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_dnx = ftc_up + dftc_dpsi_dnx = 0._r8 + else + ftc_upx = ftc_dn + dftc_dpsi_upx = 0._r8 + end if + +end if + +! Calculate total effective conductance over path [kg s-1 MPa-1] +k_eff = 1._r8/(1._r8/(ftc_upx*kmax_up)+1._r8/(ftc_dnx*kmax_dn)) + +dk_dpsi_dn = k_eff**2._r8 * kmax_dn**(-1._r8) * ftc_dnx**(-2._r8) * dftc_dpsi_dnx + +dk_dpsi_up = k_eff**2._r8 * kmax_up**(-1._r8) * ftc_upx**(-2._r8) * dftc_dpsi_upx + + +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 AccumulateMortalityWaterStorage(csite,ccohort,delta_n) +subroutine RecruitWaterStorage(nsites,sites,bc_out) - ! --------------------------------------------------------------------------- - ! 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. - ! --------------------------------------------------------------------------- + ! --------------------------------------------------------------------------- + ! 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 + ! Arguments +integer, intent(in) :: nsites +type(ed_site_type), intent(inout), target :: sites(nsites) +type(bc_out_type), intent(inout) :: bc_out(nsites) - 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 +! 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) :: 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 +if( hlm_use_planthydro.eq.ifalse ) return - 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 +do s = 1,nsites - csite_hydr%h2oveg_dead = csite_hydr%h2oveg_dead + delta_w + 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 - csite_hydr%h2oveg = csite_hydr%h2oveg - delta_w +end do - return - end subroutine AccumulateMortalityWaterStorage +return +end subroutine RecruitWaterStorage - !-------------------------------------------------------------------------------! +! ===================================================================================== - subroutine RecruitWaterStorage(nsites,sites,bc_out) +! ===================================================================================== +! Utility Functions +! ===================================================================================== - ! --------------------------------------------------------------------------- - ! 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. - ! --------------------------------------------------------------------------- +subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_new) + ! + ! !DESCRIPTION: Bisection routine for getting the inverse of the cumulative root + ! distribution. No analytical soln bc crootfr ~ exp(ax) + exp(bx). + ! + ! !USES: + ! + ! !ARGUMENTS +real(r8) , intent(in) :: a, b ! pft root distribution constants +real(r8) , intent(in) :: lower_init ! lower bound of initial x estimate [m] +real(r8) , intent(in) :: upper_init ! upper bound of initial x estimate [m] +real(r8) , intent(in) :: xtol ! error tolerance for x_new [m] +real(r8) , intent(in) :: ytol ! error tolerance for crootfr [-] +real(r8) , intent(in) :: crootfr ! cumulative root fraction at x_new [-] +real(r8) , intent(out) :: x_new ! soil depth [m] +! +! !LOCAL VARIABLES: +real(r8) :: lower ! lower bound x estimate [m] +real(r8) :: upper ! upper bound x estimate [m] +real(r8) :: y_lo ! corresponding y value at lower +real(r8) :: f_lo ! y difference between lower bound guess and target y +real(r8) :: y_hi ! corresponding y value at upper +real(r8) :: f_hi ! y difference between upper bound guess and target y +real(r8) :: y_new ! corresponding y value at x.new +real(r8) :: f_new ! y difference between new y guess at x.new and target y +real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) +!---------------------------------------------------------------------- + +lower = lower_init +upper = upper_init +f_lo = zeng2001_crootfr(a, b, lower) - crootfr +f_hi = zeng2001_crootfr(a, b, upper) - crootfr +chg = upper - lower +do while(abs(chg) .gt. xtol) + x_new = 0.5_r8*(lower + upper) + f_new = zeng2001_crootfr(a, b, x_new) - crootfr + if(abs(f_new) .le. ytol) then + EXIT + end if + if((f_lo * f_new) .lt. 0._r8) upper = x_new + if((f_hi * f_new) .lt. 0._r8) lower = x_new + chg = upper - lower +end do +end subroutine bisect_rootfr + +! ===================================================================================== + +function zeng2001_crootfr(a, b, z, z_max) result(crootfr) + + ! !ARGUMENTS: +real(r8) , intent(in) :: a,b ! pft parameters +real(r8) , intent(in) :: z ! soil depth (m) +real(r8) , intent(in), optional :: z_max ! max soil depth (m) +! +real(r8) :: crootfr_max + +! !RESULT +real(r8) :: crootfr ! cumulative root fraction +! +!------------------------------------------------------------------------ +crootfr = 1._r8 - .5_r8*(exp(-a*z) + exp(-b*z)) + + +! If a maximum rooting depth is provided, then +! we force everything to sum to unity. We do this by +! simply dividing through by the maximum possible +! root fraction. + +if(present(z_max))then + crootfr_max = 1._r8 - .5_r8*(exp(-a*z_max) + exp(-b*z_max)) + crootfr = crootfr/crootfr_max +end if + +if(debug)then + if(present(z_max))then + if((crootfr_max1.0_r8) )then + write(fates_log(),*) 'problem scaling crootfr in zeng2001' + write(fates_log(),*) 'z_max: ',z_max + write(fates_log(),*) 'crootfr_max: ',crootfr_max + end if + end if +end if - ! 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 +return - if( hlm_use_planthydro.eq.ifalse ) return +end function zeng2001_crootfr - 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 +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: - end do + ! + ! !ARGUMENTS: +real(r8) , intent(in) :: l_aroot ! Total length of absorbing roots +! for the whole site, this layer (m) +real(r8) , intent(in) :: rs1 ! Fine root radius (m) +real(r8) , intent(in) :: area_site ! Area of site (10,000 m2) +real(r8) , intent(in) :: dz ! Width of current soil layer (m) +real(r8) , intent(out) :: r_out_shell(:) ! Outer radius of each shell (m) +real(r8) , intent(out) :: r_node_shell(:) ! Radius of the shell's midpoint +real(r8) , intent(out) :: v_shell(:) ! volume of the rhizosphere shells (m3/ha) +! for this layer +! +! !LOCAL VARIABLES: +integer :: k ! rhizosphere shell indicies +integer :: nshells ! We don't use the global because of unit testing +!----------------------------------------------------------------------- + + +nshells = size(r_out_shell,dim=1) + +! update outer radii of column-level rhizosphere shells (same across patches and cohorts) +r_out_shell(nshells) = (pi_const*l_aroot/(area_site*dz))**(-0.5_r8) ! eqn(8) S98 +if(nshells > 1) then + do k = 1,nshells-1 + r_out_shell(k) = rs1*(r_out_shell(nshells)/rs1)**((real(k,r8))/real(nshells,r8)) ! eqn(7) S98 + enddo +end if + +! set nodal (midpoint) radii of these shells +! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level +r_node_shell(1) = 0.5_r8*(rs1 + r_out_shell(1)) +!r_node_shell(1) = 0.5_r8*(r_out_shell(1)) + +do k = 2,nshells + r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) +enddo + +! update volumes +do k = 1,nshells + if(k == 1) then + v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - rs1**2._r8) + else + v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) + end if +enddo + +return +end subroutine shellGeom + +! ===================================================================================== + +function xylemtaper(p, dz) result(chi_tapnotap) + + ! !ARGUMENTS: +real(r8) , intent(in) :: p ! Taper exponent (see EDPftvar hydr_p_taper) [-] +real(r8) , intent(in) :: dz ! hydraulic distance from petiole to node of interest [m] +! +! !LOCAL VARIABLES: +real(r8) :: atap,btap ! scaling exponents for total conductance ~ tree size (ratio of stem radius to terminal twig radius) +real(r8) :: anotap,bnotap ! same as atap, btap, but not acounting for xylem taper (Savage et al. (2010) p = 0) +! NOTE: these scaling exponents were digitized from Fig 2a of Savage et al. (2010) +! Savage VM, Bentley LP, Enquist BJ, Sperry JS, Smith DD, Reich PB, von Allmen EI. 2010. +! Hydraulic trade-offs and space filling enable better predictions of vascular structure +! and function in plants. Proceedings of the National Academy of Sciences 107(52): 22722-22727. +real(r8) :: lN=0.04_r8 ! petiole length [m] +real(r8) :: little_n=2._r8 ! number of daughter branches per parent branch, assumed constant throughout tree (self-similarity) [-] +real(r8) :: big_n ! number of branching levels (allowed here to take on non-integer values): increases with tree size [-] +real(r8) :: ktap ! hydraulic conductance along the pathway, accounting for xylem taper [kg s-1 MPa-1] +real(r8) :: knotap ! hydraulic conductance along the pathway, not accounting for xylem taper [kg s-1 MPa-1] +real(r8) :: num ! temporary +real(r8) :: den ! temporary +! +! !RESULT +real(r8) :: chi_tapnotap ! ratio of total tree conductance accounting for xylem taper to that without, over interval dz +! +!------------------------------------------------------------------------ + +anotap = 7.19903e-13_r8 +bnotap = 1.326105578_r8 +if (p >= 1.0_r8) then + btap = 2.00586217_r8 + atap = 1.82513E-12_r8 +else if (p >= (1._r8/3._r8) .AND. p < 1._r8) then + btap = 1.854812819_r8 + atap = 6.66908E-13_r8 +else if (p >= (1._r8/6._r8) .AND. p < (1._r8/3._r8)) then + btap = 1.628179741_r8 + atap = 6.58345E-13_r8 +else + btap = bnotap + atap = anotap +end if + +num = 3._r8*log(1._r8 - dz/lN * (1._r8-little_n**(1._r8/3._r8))) +den = log(little_n) +big_n = num/den - 1._r8 +ktap = atap * (little_n**(big_N* btap/2._r8)) +knotap = anotap * (little_n**(big_N*bnotap/2._r8)) +chi_tapnotap = ktap / knotap + +return + +end function xylemtaper + +! ===================================================================================== + +subroutine Hydraulics_Tridiagonal(a, b, c, r, u, ierr) + ! + ! !DESCRIPTION: An abbreviated version of biogeophys/TridiagonalMod.F90 + ! + ! This solves the form: + ! + ! a(i)*u(i-1) + b(i)*u(i) + c(i)*u(i+1) = r(i) + ! + ! It assumed that coefficient a(1) and c(N) DNE as there is + ! no u(0) or u(N-1). + ! + ! !USES: + ! + ! !ARGUMENTS +real(r8), intent(in) :: a(:) ! "a" left off diagonal of tridiagonal matrix +real(r8), intent(in) :: b(:) ! "b" diagonal column of tridiagonal matrix +real(r8), intent(in) :: c(:) ! "c" right off diagonal of tridiagonal matrix +real(r8), intent(in) :: r(:) ! "r" forcing term of tridiagonal matrix +real(r8), intent(out) :: u(:) ! solution +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 + +do k=N-1,1,-1 + u(k) = u(k) - gam(k+1) * u(k+1) +enddo + +! If debug mode, calculate error on the forward solution +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 + +! ===================================================================================== + +subroutine MatSolve2D(bc_in,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). + ! + ! ----------------------------------------------------------------------------------- - return - end subroutine RecruitWaterStorage - ! ===================================================================================== + ! ARGUMENTS: + ! ----------------------------------------------------------------------------------- +type(bc_in_type),intent(in) :: bc_in +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] - ! ===================================================================================== - ! Utility Functions - ! ===================================================================================== - subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_new) - ! - ! !DESCRIPTION: Bisection routine for getting the inverse of the cumulative root - ! distribution. No analytical soln bc crootfr ~ exp(ax) + exp(bx). - ! - ! !USES: - ! - ! !ARGUMENTS - real(r8) , intent(in) :: a, b ! pft root distribution constants - real(r8) , intent(in) :: lower_init ! lower bound of initial x estimate [m] - real(r8) , intent(in) :: upper_init ! upper bound of initial x estimate [m] - real(r8) , intent(in) :: xtol ! error tolerance for x_new [m] - real(r8) , intent(in) :: ytol ! error tolerance for crootfr [-] - real(r8) , intent(in) :: crootfr ! cumulative root fraction at x_new [-] - real(r8) , intent(out) :: x_new ! soil depth [m] - ! - ! !LOCAL VARIABLES: - real(r8) :: lower ! lower bound x estimate [m] - real(r8) :: upper ! upper bound x estimate [m] - real(r8) :: y_lo ! corresponding y value at lower - real(r8) :: f_lo ! y difference between lower bound guess and target y - real(r8) :: y_hi ! corresponding y value at upper - real(r8) :: f_hi ! y difference between upper bound guess and target y - real(r8) :: y_new ! corresponding y value at x.new - real(r8) :: f_new ! y difference between new y guess at x.new and target y - real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) - !---------------------------------------------------------------------- - - lower = lower_init - upper = upper_init - f_lo = zeng2001_crootfr(a, b, lower) - crootfr - f_hi = zeng2001_crootfr(a, b, upper) - crootfr - chg = upper - lower - do while(abs(chg) .gt. xtol) - x_new = 0.5_r8*(lower + upper) - f_new = zeng2001_crootfr(a, b, x_new) - crootfr - if(abs(f_new) .le. ytol) then - EXIT - end if - if((f_lo * f_new) .lt. 0._r8) upper = x_new - if((f_hi * f_new) .lt. 0._r8) lower = x_new - chg = upper - lower - end do - end subroutine bisect_rootfr +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_bc ! layer of bc +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 + + +real(r8) :: rlfx_soil ! Pressure update reduction factor for soil compartments +real(r8) :: rlfx_plnt ! Pressure update reduction factor for plant comparmtents +real(r8) :: rlfx_soil0 ! Base relaxation factor for the current iteration round +real(r8) :: rlfx_plnt0 ! "" + +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] +logical :: continue_search +real(r8) :: k_eff ! Effective conductivity over the current pathway +! between two nodes. Factors in fractional +! loss of conductivity on each side of the pathway, and the material maximum +! conductivity on each side [kg/s/MPa] +integer :: icnx_ar ! Connection index of the aroot <-> rhizosphere shell + +integer :: nsd ! node index of highest residual +integer :: nwtn_iter ! number of (Newton) iterations on each substep + +! to get a succesfull Newton solve. +integer :: kshell ! rhizosphere shell index, 1->nshell + +integer :: info +integer :: nstep !number of time steps + + +! 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 + +! 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 + +! dtime will shrink at the following rate (halving) [s]: +! 1800,900,450,225,112.5,56.25,28.125,14.0625,7.03125,3.515625, +! 1.7578125,0.87890625,0.439453125,0.2197265625,0.10986328125, +! 0.054931640625,0.0274658203125,0.01373291015625,0.006866455078125, +! 0.0034332275390625,0.00171661376953125, + + +! Maximum number of Newton iterations in each round +integer, parameter :: max_newton_iter = 100 + +! 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 + + +integer, parameter :: icnv_fail_round = 1 +integer, parameter :: icnv_pass_round = 2 + +! Timestep reduction factor when a round of +! newton iterations fail. + +real(r8), parameter :: dtime_rf = 0.5_r8 + +! These are the initial relaxation factors at the beginning +! of the large time-step. These may or may not shrink on +! subsequent rounds, and may or may not grow over subsequent +! iterations within rounds +real(r8), parameter :: rlfx_soil_init = 1.0 ! Initial Pressure update +! reduction factor for soil compartments +real(r8), parameter :: rlfx_plnt_init = 1.0 ! Initial Pressure update +! reduction factor for plant comparmtents +real(r8), parameter :: dpsi_scap = 0.2 ! Changes in psi (for soil) larger than this +! will be subject to a capping routine +real(r8), parameter :: dpsi_pcap = 0.3 ! Change sin psi (for plants) larger than this +! will be subject to a capping routine +real(r8), parameter :: rlfx_plnt_shrink = 1.0 ! Shrink the starting plant relaxtion factor +! by this multipliler each round +real(r8), parameter :: rlfx_soil_shrink = 1.0 ! Shrink the starting soil relaxtion factor +! by this multipliler each round +logical, parameter :: reset_on_fail = .false. ! If a round of Newton iterations is unable +! to find a solution, you can either reset +! to the beginning of the large timestep (true), or +! to the beginning of the current substep (false) + +logical, parameter :: allow_lenient_lastiter = .true. ! If this is true, when the newton iteration +! reaches its last allowed attempt, the +! error tolerance will be increased (the bar lowered) by 10x + + + +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_prev => site_hydr%th_node_prev, & + 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() + + +! This NaN's the scratch arrays +call site_hydr%FlushSiteScratch() + +! This is the maximum number of iterations needed for this cohort +! (each soil layer has a different number, this saves the max) +cohort_hydr%iterh1 = 0 +cohort_hydr%iterh2 = 0 + +! These are output fluxes from the subroutine, total integrated +! mass fluxes [kg] over the time-step. sapflow is the integrated +! flux between the transporting root and the 1st stem compartment. +! The rootuptake is the integrated flux between the 1st rhizosphere +! and absorbing roots +sapflow = 0._r8 +rootuptake(:) = 0._r8 + +! Chnage in water content, over all substeps [m3/m3] +dth_node(:) = 0._r8 + +! Transfer node heights, volumes and initial water contents for +! the transporting root and above ground compartments to the +! complete node vector + +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 + + ! 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 - function zeng2001_crootfr(a, b, z, z_max) result(crootfr) +enddo - ! !ARGUMENTS: - real(r8) , intent(in) :: a,b ! pft parameters - real(r8) , intent(in) :: z ! soil depth (m) - real(r8) , intent(in), optional :: z_max ! max soil depth (m) - ! - real(r8) :: crootfr_max - ! !RESULT - real(r8) :: crootfr ! cumulative root fraction - ! - !------------------------------------------------------------------------ - crootfr = 1._r8 - .5_r8*(exp(-a*z) + exp(-b*z)) +! Total water mass in the plant at the beginning of this solve [kg h2o] +w_tot_beg = sum(th_node_init(:)*v_node(:))*denh2o - ! 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. +! Initialize variables and flags that track +! the progress of the solve - 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 +tm = 0 +nsteps = 0 +th_node_prev(:) = th_node_init(:) +th_node(:) = th_node_init(:) +dtime = tmx +rlfx_plnt0 = rlfx_plnt_init +rlfx_soil0 = rlfx_soil_init +rlfx_plnt = rlfx_plnt0 +rlfx_soil = rlfx_soil0 - 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 +outerloop: do while( tm < tmx ) + ! The solve may reduce the time-step, the shorter + ! time-steps may not be perfectly divisible into + ! the remaining time. If so, then make sure we + ! don't overshoot - return + dtime = min(dtime,tmx-tm) - end function zeng2001_crootfr + ! Advance time forward + tm = tm + dtime + ! 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 - 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: + ! Complete failure to converge even with re-trying + ! iterations with smaller timesteps - ! - ! !ARGUMENTS: - real(r8) , intent(in) :: l_aroot ! Total length of absorbing roots - ! for the whole site, this layer (m) - real(r8) , intent(in) :: rs1 ! Fine root radius (m) - real(r8) , intent(in) :: area_site ! Area of site (10,000 m2) - real(r8) , intent(in) :: dz ! Width of current soil layer (m) - real(r8) , intent(out) :: r_out_shell(:) ! Outer radius of each shell (m) - real(r8) , intent(out) :: r_node_shell(:) ! Radius of the shell's midpoint - real(r8) , intent(out) :: v_shell(:) ! volume of the rhizosphere shells (m3/ha) - ! for this layer - ! - ! !LOCAL VARIABLES: - integer :: k ! rhizosphere shell indicies - integer :: nshells ! We don't use the global because of unit testing - !----------------------------------------------------------------------- + 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.' + write(fates_log(),*) 'pft: ',ft,' dbh: ',cohort%dbh + call endrun(msg=errMsg(sourcefile, __LINE__)) - - nshells = size(r_out_shell,dim=1) - - ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) - r_out_shell(nshells) = (pi_const*l_aroot/(area_site*dz))**(-0.5_r8) ! eqn(8) S98 - if(nshells > 1) then - do k = 1,nshells-1 - r_out_shell(k) = rs1*(r_out_shell(nshells)/rs1)**((real(k,r8))/real(nshells,r8)) ! eqn(7) S98 - enddo - end if - - ! set nodal (midpoint) radii of these shells - ! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level - r_node_shell(1) = 0.5_r8*(rs1 + r_out_shell(1)) - !r_node_shell(1) = 0.5_r8*(r_out_shell(1)) - - do k = 2,nshells - r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) - enddo - - ! update volumes - do k = 1,nshells - if(k == 1) then - v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - rs1**2._r8) - else - v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) - end if - enddo + endif - return - end subroutine shellGeom - ! ===================================================================================== + ! This is the newton search loop - function xylemtaper(p, dz) result(chi_tapnotap) + continue_search = .true. + nwtn_iter = 0 + newtonloop: do while(continue_search) - ! !ARGUMENTS: - real(r8) , intent(in) :: p ! Taper exponent (see EDPftvar hydr_p_taper) [-] - 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 + nwtn_iter = nwtn_iter + 1 - 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 + ! 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 - return + do k=1,site_hydr%num_nodes - end function xylemtaper - - ! ===================================================================================== - - subroutine Hydraulics_Tridiagonal(a, b, c, r, u, ierr) - ! - ! !DESCRIPTION: An abbreviated version of biogeophys/TridiagonalMod.F90 - ! - ! This solves the form: - ! - ! a(i)*u(i-1) + b(i)*u(i) + c(i)*u(i+1) = r(i) - ! - ! It assumed that coefficient a(1) and c(N) DNE as there is - ! no u(0) or u(N-1). - ! - ! !USES: - ! - ! !ARGUMENTS - real(r8), intent(in) :: a(:) ! "a" left off diagonal of tridiagonal matrix - real(r8), intent(in) :: b(:) ! "b" diagonal column of tridiagonal matrix - real(r8), intent(in) :: c(:) ! "c" right off diagonal of tridiagonal matrix - real(r8), intent(in) :: r(:) ! "r" forcing term of tridiagonal matrix - real(r8), intent(out) :: u(:) ! solution - 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 + ! This is the storage gained from previous newton iterations. + residual(k) = residual(k) + denh2o*v_node(k)*(th_node(k) - th_node_prev(k))/dtime - do k=N-1,1,-1 - u(k) = u(k) - gam(k+1) * u(k+1) - enddo + if(pm_node(k) == rhiz_p_media) then - ! 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 + j = node_layer(k) + psi_node(k) = site_hydr%wrf_soil(j)%p%psi_from_th(th_node(k)) - end subroutine Hydraulics_Tridiagonal + ! 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)) - ! ===================================================================================== + else - subroutine MatSolve2D(bc_in,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). - ! - ! ----------------------------------------------------------------------------------- + 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)) - - ! ARGUMENTS: - ! ----------------------------------------------------------------------------------- - type(bc_in_type),intent(in) :: bc_in - 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] - - - 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_bc ! layer of bc - 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 - - - real(r8) :: rlfx_soil ! Pressure update reduction factor for soil compartments - real(r8) :: rlfx_plnt ! Pressure update reduction factor for plant comparmtents - real(r8) :: rlfx_soil0 ! Base relaxation factor for the current iteration round - real(r8) :: rlfx_plnt0 ! "" - - 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] - logical :: continue_search - real(r8) :: k_eff ! Effective conductivity over the current pathway - ! between two nodes. Factors in fractional - ! loss of conductivity on each side of the pathway, and the material maximum - ! conductivity on each side [kg/s/MPa] - integer :: icnx_ar ! Connection index of the aroot <-> rhizosphere shell - - integer :: nsd ! node index of highest residual - integer :: nwtn_iter ! number of (Newton) iterations on each substep - - ! to get a succesfull Newton solve. - integer :: kshell ! rhizosphere shell index, 1->nshell - - integer :: info - integer :: nstep !number of time steps - - - ! 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 - - ! 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 - - ! dtime will shrink at the following rate (halving) [s]: - ! 1800,900,450,225,112.5,56.25,28.125,14.0625,7.03125,3.515625, - ! 1.7578125,0.87890625,0.439453125,0.2197265625,0.10986328125, - ! 0.054931640625,0.0274658203125,0.01373291015625,0.006866455078125, - ! 0.0034332275390625,0.00171661376953125, - - - ! Maximum number of Newton iterations in each round - integer, parameter :: max_newton_iter = 100 - - ! 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 - - - integer, parameter :: icnv_fail_round = 1 - integer, parameter :: icnv_pass_round = 2 - - ! Timestep reduction factor when a round of - ! newton iterations fail. - - real(r8), parameter :: dtime_rf = 0.5_r8 - - ! These are the initial relaxation factors at the beginning - ! of the large time-step. These may or may not shrink on - ! subsequent rounds, and may or may not grow over subsequent - ! iterations within rounds - real(r8), parameter :: rlfx_soil_init = 1.0 ! Initial Pressure update - ! reduction factor for soil compartments - real(r8), parameter :: rlfx_plnt_init = 1.0 ! Initial Pressure update - ! reduction factor for plant comparmtents - real(r8), parameter :: dpsi_scap = 0.2 ! Changes in psi (for soil) larger than this - ! will be subject to a capping routine - real(r8), parameter :: dpsi_pcap = 0.3 ! Change sin psi (for plants) larger than this - ! will be subject to a capping routine - real(r8), parameter :: rlfx_plnt_shrink = 1.0 ! Shrink the starting plant relaxtion factor - ! by this multipliler each round - real(r8), parameter :: rlfx_soil_shrink = 1.0 ! Shrink the starting soil relaxtion factor - ! by this multipliler each round - logical, parameter :: reset_on_fail = .false. ! If a round of Newton iterations is unable - ! to find a solution, you can either reset - ! to the beginning of the large timestep (true), or - ! to the beginning of the current substep (false) - - logical, parameter :: allow_lenient_lastiter = .true. ! If this is true, when the newton iteration - ! reaches its last allowed attempt, the - ! error tolerance will be increased (the bar lowered) by 10x - - - - 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_prev => site_hydr%th_node_prev, & - 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() - - - ! This NaN's the scratch arrays - call site_hydr%FlushSiteScratch() - - ! This is the maximum number of iterations needed for this cohort - ! (each soil layer has a different number, this saves the max) - cohort_hydr%iterh1 = 0 - cohort_hydr%iterh2 = 0 - - ! These are output fluxes from the subroutine, total integrated - ! mass fluxes [kg] over the time-step. sapflow is the integrated - ! flux between the transporting root and the 1st stem compartment. - ! The rootuptake is the integrated flux between the 1st rhizosphere - ! and absorbing roots - sapflow = 0._r8 - rootuptake(:) = 0._r8 - - ! Chnage in water content, over all substeps [m3/m3] - dth_node(:) = 0._r8 - - ! Transfer node heights, volumes and initial water contents for - ! the transporting root and above ground compartments to the - ! complete node vector - - 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 - - ! 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 + + ! 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 + j = node_layer(k) + 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 - ! Total water mass in the plant at the beginning of this solve [kg h2o] - w_tot_beg = sum(th_node_init(:)*v_node(:))*denh2o - - - ! Initialize variables and flags that track - ! the progress of the solve - - tm = 0 - nsteps = 0 - th_node_prev(:) = th_node_init(:) - th_node(:) = th_node_init(:) - dtime = tmx - rlfx_plnt0 = rlfx_plnt_init - rlfx_soil0 = rlfx_soil_init - rlfx_plnt = rlfx_plnt0 - rlfx_soil = rlfx_soil0 - - outerloop: do while( tm < tmx ) - - ! The solve may reduce the time-step, the shorter - ! time-steps may not be perfectly divisible into - ! the remaining time. If so, then make sure we - ! don't overshoot - - dtime = min(dtime,tmx-tm) - - ! Advance time forward - tm = tm + dtime - ! 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 - - ! Complete failure to converge even with re-trying - ! iterations with smaller timesteps - - 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.' - write(fates_log(),*) 'pft: ',ft,' dbh: ',cohort%dbh - call endrun(msg=errMsg(sourcefile, __LINE__)) - - endif - - - ! This is the newton search loop - - continue_search = .true. - nwtn_iter = 0 - newtonloop: do while(continue_search) - - 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) + denh2o*v_node(k)*(th_node(k) - th_node_prev(k))/dtime - - 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)) - - ! 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)) - - 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 - j = node_layer(k) - 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 - - - ! 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) - ! This should be used for the down-stream on thr second index) - 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 mass balance - ajac(id_dn,id_dn) = ajac(id_dn,id_dn) + dqflx_dpsi_dn - - ! Down-stream node's contribution to the up-stream node's mass balance - ajac(id_up,id_dn) = ajac(id_up,id_dn) - dqflx_dpsi_dn - - ! Up-stream node's contribution to the down-stream node's mass balance - ajac(id_dn,id_up) = ajac(id_dn,id_up) + dqflx_dpsi_up - - ! Up-stream node's contribution to the up-stream node's mass balance - 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 - - - ! 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 - if ( nwtn_iter > max_newton_iter) then - icnv = icnv_fail_round - write(fates_log(),*) 'Newton hydraulics solve failed',residual_amax,nsd,tm - endif - - ! Three scenarios: - ! 1) the residual is 0, everything is great, leave iteration loop - ! 2) the residual is not 0, but we have not taken too many steps - ! and the matrix solve did not fail. Perform an inversion and keep - ! searching. - ! 3) the residual is not 0, and either - ! we have taken too many newton steps or the solver won't return - ! a real solution. - ! Shorten time-step, reset time to 0, reset relaxation factors - ! and try a new round of newton (if not exceeded) - - - if( icnv == icnv_fail_round ) then - - ! If the newton iteration fails, we go back - ! to restart the time-stepping loop with shorter sub-steps. - ! Therefore, we set the time elapsed (tm) to zero, - ! shorten the timstep (dtime) and re-initialize the water - ! contents to the starting amount. - - if(reset_on_fail) then - tm = 0._r8 - th_node(:) = th_node_init(:) - th_node_prev(:) = th_node_init(:) - cohort_hydr%iterh1 = 0 - else - tm = tm - dtime - th_node(:) = th_node_prev(:) - !* No need to update the th_node_prev, it is the - ! same since we are just re-starting the current - ! step - end if - nsteps = nsteps + 1 - dtime = dtime * dtime_rf - rlfx_plnt0 = rlfx_plnt_init*rlfx_plnt_shrink**real(nsteps,r8) - rlfx_soil0 = rlfx_soil_init*rlfx_soil_shrink**real(nsteps,r8) - rlfx_plnt = rlfx_plnt0 - rlfx_soil = rlfx_soil0 - nwtn_iter = 0 - cohort_hydr%iterh1 = cohort_hydr%iterh1 + 1 - cycle outerloop - - else - - ! On the last iteration, we temporarily lower the bar (if opted for) - ! and allow a pass if the residual is within 10x of the typical allowed residual - if ( allow_lenient_lastiter ) then - if ( nwtn_iter == max_newton_iter .and. residual_amax < 10*max_allowed_residual ) then - exit newtonloop - end if - end if - - if( sum(residual(:)) < max_allowed_residual .and. residual_amax < max_allowed_residual ) then - - ! We have succesffully found a solution - ! in this newton iteration. - exit newtonloop - else - ! Move ahead and calculate another solution - ! and continue the search. Residual isn't zero - ! but no reason not to continue searching - - ! Record that we performed a solve (this is total iterations) - cohort_hydr%iterh2 = cohort_hydr%iterh2 + 1 - - ! --------------------------------------------------------------------------- - ! 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. - ! --------------------------------------------------------------------------- - !cohort_hydr%iterh2 = cohort_hydr%iterh2 - - call DGESV(site_hydr%num_nodes,1,ajac,site_hydr%num_nodes,ipiv,residual,site_hydr%num_nodes,info) - - - if ( info < 0 ) then - write(fates_log(),*) 'illegal value generated in DGESV() linear' - write(fates_log(),*) 'system solver, see node: ',-info - 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 - - ! Update the previous water content state to be the current - ! th_node_prev(:) = th_node(:) - - ! 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 - j = node_layer(k) - if(abs(residual(k)) < dpsi_scap) then - psi_node(k) = psi_node(k) + residual(k) * rlfx_soil - else - psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_scap,residual(k)) - dpsi_scap*dpsi_scap/residual(k) - endif - th_node(k) = site_hydr%wrf_soil(j)%p%th_from_psi(psi_node(k)) - else - if(abs(residual(k)) < dpsi_pcap) then - psi_node(k) = psi_node(k) + residual(k) * rlfx_plnt - else - psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_pcap,residual(k)) - dpsi_pcap*dpsi_pcap/residual(k) - endif - th_node(k) = wrf_plant(pm_node(k),ft)%p%th_from_psi(psi_node(k)) - endif - - enddo - - ! Increase relaxation factors for next iteration - rlfx_plnt = min(1._r8,rlfx_plnt0 + & - (1.0-rlfx_plnt0)*real(nwtn_iter,r8)/real(max_newton_iter-3,r8)) - rlfx_soil = min(1._r8,rlfx_soil0 + & - (1.0-rlfx_soil0)*real(nwtn_iter,r8)/real(max_newton_iter-3,r8)) + ! 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. - end if - end if + call SetMaxCondConnections(site_hydr, cohort_hydr, h_node, kmax_dn, kmax_up) - end do newtonloop + ! calculate boundary fluxes + do icnx=1,site_hydr%num_connections - ! If we are here, that means we succesfully finished - ! a solve with minimal error. More substeps may be required though - ! ------------------------------------------------------------------------------ + id_dn = conn_dn(icnx) + id_up = conn_up(icnx) - ! If there are any sub-steps left, we need to update - ! the initial water content - th_node_prev(:) = th_node(:) - + ! 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 - ! Reset relaxation factors - rlfx_plnt = rlfx_plnt0 - rlfx_soil = rlfx_soil0 + 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) - end do outerloop + q_flux(icnx) = k_eff*(h_node(id_up)-h_node(id_dn)) - if(cohort_hydr%iterh1>1._r8) then - write(fates_log(),*) "hydro solve info: i1: ",cohort_hydr%iterh1,"i2: ",cohort_hydr%iterh2 - end if + ! 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) + ! This should be used for the down-stream on thr second index) + 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 mass balance + ajac(id_dn,id_dn) = ajac(id_dn,id_dn) + dqflx_dpsi_dn + + ! Down-stream node's contribution to the up-stream node's mass balance + ajac(id_up,id_dn) = ajac(id_up,id_dn) - dqflx_dpsi_dn + + ! Up-stream node's contribution to the down-stream node's mass balance + ajac(id_dn,id_up) = ajac(id_dn,id_up) + dqflx_dpsi_up + + ! Up-stream node's contribution to the up-stream node's mass balance + ajac(id_up,id_up) = ajac(id_up,id_up) - dqflx_dpsi_up - ! Save flux diagnostics - ! ------------------------------------------------------ - - sapflow = sapflow + q_flux(n_hypool_ag)*tmx - 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)*tmx - enddo - - ! Update the total change in water content - dth_node(:) = dth_node(:) + (th_node(:) - th_node_init(:)) - - ! 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, 1 + nshell - 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*tmx)-(w_tot_beg-w_tot_end) + ! 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) - end associate + residual(1) = residual(1) + qtop - return - end subroutine MatSolve2D - ! ===================================================================================== - - function SumBetweenDepths(site_hydr,depth_t,depth_b,array_in) result(depth_sum) - - ! This function sums the quantity in array_in between depth_t (top) - ! and depth_b. It assumes many things. Firstly, that the depth coordinates - ! for array_in do match site_hydr%zi_rhiz (on rhizosphere layers), and that - ! those coordinates are positive down. - - type(ed_site_hydr_type), intent(in) :: site_hydr - real(r8),intent(in) :: depth_t ! Top Depth (positive coordinate) - real(r8),intent(in) :: depth_b ! Bottom depth (positive coordinate) - real(r8),intent(in) :: array_in(:) ! Quantity to be summed (flux?mass?) - real(r8) :: depth_sum ! The summed result we return in units (/depth) - integer :: i_rhiz_t ! Layer index of top full layer - integer :: i_rhiz_b ! layer index of bottom full layer - integer :: nlevrhiz ! Number of rhizosphere layers (not shells) - real(r8) :: frac ! Fraction of partial layer, by depth - - i_rhiz_t = count((site_hydr%zi_rhiz-site_hydr%dz_rhiz)nlevrhiz) then - return - end if - - ! Sum all fully encased layers - if(i_rhiz_b>=i_rhiz_t)then - depth_sum = depth_sum + sum(array_in(i_rhiz_t:i_rhiz_b)) - end if - - ! Find fraction contribution from top partial layer (if any) - if(i_rhiz_t>1) then - frac = (site_hydr%zi_rhiz(i_rhiz_t-1)-depth_t)/site_hydr%dz_rhiz(i_rhiz_t-1) - depth_sum = depth_sum + frac*array_in(i_rhiz_t-1) - end if - - ! Find fraction contribution from bottom partial layer (if any) - if(i_rhiz_b residual_amax ) then + residual_amax = rsdx + nsd = k + endif + enddo + if ( nwtn_iter > max_newton_iter) then + icnv = icnv_fail_round + write(fates_log(),*) 'Newton hydraulics solve failed',residual_amax,nsd,tm + endif + + ! Three scenarios: + ! 1) the residual is 0, everything is great, leave iteration loop + ! 2) the residual is not 0, but we have not taken too many steps + ! and the matrix solve did not fail. Perform an inversion and keep + ! searching. + ! 3) the residual is not 0, and either + ! we have taken too many newton steps or the solver won't return + ! a real solution. + ! Shorten time-step, reset time to 0, reset relaxation factors + ! and try a new round of newton (if not exceeded) + + + if( icnv == icnv_fail_round ) then + + ! If the newton iteration fails, we go back + ! to restart the time-stepping loop with shorter sub-steps. + ! Therefore, we set the time elapsed (tm) to zero, + ! shorten the timstep (dtime) and re-initialize the water + ! contents to the starting amount. + + if(reset_on_fail) then + tm = 0._r8 + th_node(:) = th_node_init(:) + th_node_prev(:) = th_node_init(:) + cohort_hydr%iterh1 = 0 + else + tm = tm - dtime + th_node(:) = th_node_prev(:) + !* No need to update the th_node_prev, it is the + ! same since we are just re-starting the current + ! step + end if + nsteps = nsteps + 1 + dtime = dtime * dtime_rf + rlfx_plnt0 = rlfx_plnt_init*rlfx_plnt_shrink**real(nsteps,r8) + rlfx_soil0 = rlfx_soil_init*rlfx_soil_shrink**real(nsteps,r8) + rlfx_plnt = rlfx_plnt0 + rlfx_soil = rlfx_soil0 + nwtn_iter = 0 + cohort_hydr%iterh1 = cohort_hydr%iterh1 + 1 + cycle outerloop + + else + + ! On the last iteration, we temporarily lower the bar (if opted for) + ! and allow a pass if the residual is within 10x of the typical allowed residual + if ( allow_lenient_lastiter ) then + if ( nwtn_iter == max_newton_iter .and. residual_amax < 10*max_allowed_residual ) then + exit newtonloop + end if + end if - end subroutine SetMaxCondConnections - - ! ===================================================================================== + if( sum(residual(:)) < max_allowed_residual .and. residual_amax < max_allowed_residual ) then + + ! We have succesffully found a solution + ! in this newton iteration. + exit newtonloop + else + ! Move ahead and calculate another solution + ! and continue the search. Residual isn't zero + ! but no reason not to continue searching + + ! Record that we performed a solve (this is total iterations) + cohort_hydr%iterh2 = cohort_hydr%iterh2 + 1 + + ! --------------------------------------------------------------------------- + ! 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. + ! --------------------------------------------------------------------------- + !cohort_hydr%iterh2 = cohort_hydr%iterh2 + + call DGESV(site_hydr%num_nodes,1,ajac,site_hydr%num_nodes,ipiv,residual,site_hydr%num_nodes,info) + + + if ( info < 0 ) then + write(fates_log(),*) 'illegal value generated in DGESV() linear' + write(fates_log(),*) 'system solver, see node: ',-info + 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 - subroutine InitHydroGlobals() - - ! This routine allocates the Water Transfer Functions (WTFs) - ! which include both water retention functions (WRFs) - ! as well as the water conductance (K) functions (WKFs) - ! But, this is only for plants! These functions have specific - ! parameters, potentially, for each plant functional type and - ! each organ (pft x organ), but this can be used globally (across - ! all sites on the node (machine) to save memory. These functions - ! are also applied to soils, but since soil properties vary with - ! soil layer and location, those functions are bound to the site - ! structure, and are therefore not "global". - - ! Define - class(wrf_type_vg), pointer :: wrf_vg - class(wkf_type_vg), pointer :: wkf_vg - class(wrf_type_cch), pointer :: wrf_cch - class(wkf_type_tfs), pointer :: wkf_tfs - class(wrf_type_tfs), pointer :: wrf_tfs - - integer :: ft ! PFT index - integer :: pm ! plant media index - integer :: inode ! compartment node index - real(r8) :: cap_corr ! correction for nonzero psi0x (TFS) - real(r8) :: cap_slp ! slope of capillary region of curve - real(r8) :: cap_int ! intercept of capillary region of curve - - if(hlm_use_planthydro.eq.ifalse) return - - ! we allocate from stomata_p_media, which should be zero - - allocate(wrf_plant(stomata_p_media:n_plant_media,numpft)) - allocate(wkf_plant(stomata_p_media:n_plant_media,numpft)) - - ! ----------------------------------------------------------------------------------- - ! Initialize the Water Retention Functions - ! ----------------------------------------------------------------------------------- + ! Update the previous water content state to be the current + ! th_node_prev(:) = th_node(:) + + ! 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 + j = node_layer(k) + if(abs(residual(k)) < dpsi_scap) then + psi_node(k) = psi_node(k) + residual(k) * rlfx_soil + else + psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_scap,residual(k)) - dpsi_scap*dpsi_scap/residual(k) + endif + th_node(k) = site_hydr%wrf_soil(j)%p%th_from_psi(psi_node(k)) + else + if(abs(residual(k)) < dpsi_pcap) then + psi_node(k) = psi_node(k) + residual(k) * rlfx_plnt + else + psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_pcap,residual(k)) - dpsi_pcap*dpsi_pcap/residual(k) + endif + th_node(k) = wrf_plant(pm_node(k),ft)%p%th_from_psi(psi_node(k)) + endif + + enddo + + ! Increase relaxation factors for next iteration + rlfx_plnt = min(1._r8,rlfx_plnt0 + & + (1.0-rlfx_plnt0)*real(nwtn_iter,r8)/real(max_newton_iter-3,r8)) + rlfx_soil = min(1._r8,rlfx_soil0 + & + (1.0-rlfx_soil0)*real(nwtn_iter,r8)/real(max_newton_iter-3,r8)) - select case(plant_wrf_type) - case(van_genuchten_type) - do ft = 1,numpft - do pm = 1, n_plant_media - allocate(wrf_vg) - wrf_plant(pm,ft)%p => wrf_vg - call wrf_vg%set_wrf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg]) - end do - end do - case(campbell_type) - do ft = 1,numpft - do pm = 1,n_plant_media - allocate(wrf_cch) - wrf_plant(pm,ft)%p => wrf_cch - call wrf_cch%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & - EDPftvarcon_inst%hydr_pinot_node(ft,pm), & - 9._r8]) - end do - end do - case(tfs_type) - do ft = 1,numpft - do pm = 1,n_plant_media - allocate(wrf_tfs) - wrf_plant(pm,ft)%p => wrf_tfs - - if (pm.eq.leaf_p_media) then ! Leaf tissue - cap_slp = 0.0_r8 - cap_int = 0.0_r8 - cap_corr = 1.0_r8 - else ! Non leaf tissues - cap_slp = (hydr_psi0 - hydr_psicap )/(1.0_r8 - rwccap(pm)) - cap_int = -cap_slp + hydr_psi0 - cap_corr = -cap_int/cap_slp - end if - - call wrf_tfs%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & - EDPftvarcon_inst%hydr_resid_node(ft,pm), & - EDPftvarcon_inst%hydr_pinot_node(ft,pm), & - EDPftvarcon_inst%hydr_epsil_node(ft,pm), & - rwcft(pm), & - cap_corr, & - cap_int, & - cap_slp,real(pm,r8)]) - end do - end do + end if + end if - end select + end do newtonloop - ! ----------------------------------------------------------------------------------- - ! Initialize the Water Conductance (K) Functions - ! ----------------------------------------------------------------------------------- + ! If we are here, that means we succesfully finished + ! a solve with minimal error. More substeps may be required though + ! ------------------------------------------------------------------------------ - 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 + ! If there are any sub-steps left, we need to update + ! the initial water content + th_node_prev(:) = th_node(:) - ! There is only 1 stomata conductance hypothesis which uses the p50 and - ! vulnerability parameters - ! ----------------------------------------------------------------------------------- - do ft = 1,numpft - allocate(wkf_tfs) - wkf_plant(stomata_p_media,ft)%p => wkf_tfs - call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_gs(ft), & - EDPftvarcon_inst%hydr_avuln_gs(ft)]) + ! Reset relaxation factors + rlfx_plnt = rlfx_plnt0 + rlfx_soil = rlfx_soil0 + +end do outerloop + +if(cohort_hydr%iterh1>1._r8) then + write(fates_log(),*) "hydro solve info: i1: ",cohort_hydr%iterh1,"i2: ",cohort_hydr%iterh2 +end if + +! Save flux diagnostics +! ------------------------------------------------------ + +sapflow = sapflow + q_flux(n_hypool_ag)*tmx + +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)*tmx +enddo + + +! Update the total change in water content +dth_node(:) = dth_node(:) + (th_node(:) - th_node_init(:)) + +! 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, 1 + nshell + 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*tmx)-(w_tot_beg-w_tot_end) + + +end associate + +return +end subroutine MatSolve2D + +! ===================================================================================== + +function SumBetweenDepths(site_hydr,depth_t,depth_b,array_in) result(depth_sum) + + ! This function sums the quantity in array_in between depth_t (top) + ! and depth_b. It assumes many things. Firstly, that the depth coordinates + ! for array_in do match site_hydr%zi_rhiz (on rhizosphere layers), and that + ! those coordinates are positive down. + +type(ed_site_hydr_type), intent(in) :: site_hydr +real(r8),intent(in) :: depth_t ! Top Depth (positive coordinate) +real(r8),intent(in) :: depth_b ! Bottom depth (positive coordinate) +real(r8),intent(in) :: array_in(:) ! Quantity to be summed (flux?mass?) +real(r8) :: depth_sum ! The summed result we return in units (/depth) +integer :: i_rhiz_t ! Layer index of top full layer +integer :: i_rhiz_b ! layer index of bottom full layer +integer :: nlevrhiz ! Number of rhizosphere layers (not shells) +real(r8) :: frac ! Fraction of partial layer, by depth + +i_rhiz_t = count((site_hydr%zi_rhiz-site_hydr%dz_rhiz)nlevrhiz) then + return +end if + +! Sum all fully encased layers +if(i_rhiz_b>=i_rhiz_t)then + depth_sum = depth_sum + sum(array_in(i_rhiz_t:i_rhiz_b)) +end if + +! Find fraction contribution from top partial layer (if any) +if(i_rhiz_t>1) then + frac = (site_hydr%zi_rhiz(i_rhiz_t-1)-depth_t)/site_hydr%dz_rhiz(i_rhiz_t-1) + depth_sum = depth_sum + frac*array_in(i_rhiz_t-1) +end if + +! Find fraction contribution from bottom partial layer (if any) +if(i_rhiz_b 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 - - 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 + call wrf_tfs%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & + EDPftvarcon_inst%hydr_resid_node(ft,pm), & + EDPftvarcon_inst%hydr_pinot_node(ft,pm), & + EDPftvarcon_inst%hydr_epsil_node(ft,pm), & + rwcft(pm), & + cap_corr, & + cap_int, & + cap_slp,real(pm,r8)]) + end do + end do + +end select + +! ----------------------------------------------------------------------------------- +! Initialize the Water Conductance (K) Functions +! ----------------------------------------------------------------------------------- + +select case(plant_wkf_type) +case(van_genuchten_type) + do ft = 1,numpft + do pm = 1, n_plant_media + allocate(wkf_vg) + wkf_plant(pm,ft)%p => wkf_vg + call wkf_vg%set_wkf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg, tort_vg]) + end do + + end do +case(campbell_type) + write(fates_log(),*) 'campbell/clapp-hornberger conductance not used in plants' + call endrun(msg=errMsg(sourcefile, __LINE__)) +case(tfs_type) + do ft = 1,numpft + do pm = 1, n_plant_media + allocate(wkf_tfs) + wkf_plant(pm,ft)%p => wkf_tfs + call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_node(ft,pm), & + EDPftvarcon_inst%hydr_avuln_node(ft,pm)]) + end do + end do +end select + +! There is only 1 stomata conductance hypothesis which uses the p50 and +! vulnerability parameters +! ----------------------------------------------------------------------------------- + +do ft = 1,numpft + allocate(wkf_tfs) + wkf_plant(stomata_p_media,ft)%p => wkf_tfs + call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_gs(ft), & + EDPftvarcon_inst%hydr_avuln_gs(ft)]) +end do + + +return +end subroutine InitHydroGlobals + +!! subroutine UpdateLWPMemFLCMin(ccohort_hydr) + +! This code may be re-introduced at a later date (rgk 08-2019) + +! SET COHORT-LEVEL BTRAN FOR USE IN NEXT TIMESTEP +! first update the leaf water potential memory +!! do t=2, numLWPmem +!!ccohort_hydr%lwp_mem(t-1) = ccohort_hydr%lwp_mem(t) +!!end do +!!ccohort_hydr%lwp_mem(numLWPmem) = ccohort_hydr%psi_ag(1) +!!call flc_gs_from_psi(cCohort, ccohort_hydr%psi_ag(1)) + +!!refill_rate = -log(0.5)/(ccohort_hydr%refill_days*24._r8*3600._r8) ! s-1 +!!do k=1,n_hypool_ag +!!ccohort_hydr%flc_min_ag(k) = min(ccohort_hydr%flc_min_ag(k), ccohort_hydr%flc_ag(k)) +!!if(ccohort_hydr%psi_ag(k) >= ccohort_hydr%refill_thresh .and. & +!! ccohort_hydr%flc_ag(k) > ccohort_hydr%flc_min_ag(k)) then ! then refilling +!! ccohort_hydr%flc_min_ag(k) = ccohort_hydr%flc_ag(k) - & +!! (ccohort_hydr%flc_ag(k) - ccohort_hydr%flc_min_ag(k))*exp(-refill_rate*dtime) +!!end if +!!end do +!!do k=1,n_hypool_troot +!!ccohort_hydr%flc_min_troot(k) = min(ccohort_hydr%flc_min_troot(k), ccohort_hydr%flc_troot(k)) +!!if(ccohort_hydr%psi_troot(k) >= ccohort_hydr%refill_thresh .and. & +!! ccohort_hydr%flc_troot(k) > ccohort_hydr%flc_min_troot(k)) then ! then refilling +!! ccohort_hydr%flc_min_troot(k) = ccohort_hydr%flc_troot(k) - & +!! (ccohort_hydr%flc_troot(k) - ccohort_hydr%flc_min_troot(k))*exp(-refill_rate*dtime) +!!end if +!!end do +!!do j=1,site_hydr%nlevrhiz +!!ccohort_hydr%flc_min_aroot(j) = min(ccohort_hydr%flc_min_aroot(j), ccohort_hydr%flc_aroot(j)) +!!if(ccohort_hydr%psi_aroot(j) >= ccohort_hydr%refill_thresh .and. & +!! ccohort_hydr%flc_aroot(j) > ccohort_hydr%flc_min_aroot(j)) then ! then refilling +!! ccohort_hydr%flc_min_aroot(j) = ccohort_hydr%flc_aroot(j) - & +!! (ccohort_hydr%flc_aroot(j) - ccohort_hydr%flc_min_aroot(j))*exp(-refill_rate*dtime) +!!end if +!!end do +!!end subroutine UpdateLWPMemFLCMin From 8b553d46e592c8719b225da074585e11cefa6710 Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Wed, 25 Nov 2020 17:15:59 +0100 Subject: [PATCH 172/578] Update main/EDInitMod.F90 CDK8 Co-authored-by: Charlie Koven --- main/EDInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index f010574ac8..f13994e8ea 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -333,7 +333,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) sites(s)%area_pft(ft)=0.0_r8 ! remove tiny patches to prevent numerical errors in terminate patches - endif + endif if(sites(s)%area_pft(ft).lt.0._r8)then write(fates_log(),*) 'negative area',s,ft,sites(s)%area_pft(ft) call endrun(msg=errMsg(sourcefile, __LINE__)) From 6dbca8894f9a0c7ba7fa0790a2e92da164d2bae2 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 09:21:21 -0700 Subject: [PATCH 173/578] auto indenting all of FatesPlantRespPhotosynthMod.F90 --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 3576 ++++++++++---------- 1 file changed, 1788 insertions(+), 1788 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 6f74e95979..e7a0de9bfb 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -1,81 +1,81 @@ module FATESPlantRespPhotosynthMod - - !------------------------------------------------------------------------------------- - ! !DESCRIPTION: - ! Calculates the plant respiration and photosynthetic fluxes for the FATES model - ! This code is similar to and was originally based off of the 'photosynthesis' - ! subroutine in the CLM model. - ! - ! Parameter for activation and deactivation energies were taken from: - ! Activation energy, from: - ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 - ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 - ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 - ! High temperature deactivation, from: - ! Leuning (2002) Plant, Cell and Environment 25:1205-1210 - ! The factor "c" scales the deactivation to a value of 1.0 at 25C - ! Photosynthesis and stomatal conductance parameters, from: - ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 - ! ------------------------------------------------------------------------------------ - - ! !USES: - - use FatesGlobals, only : endrun => fates_endrun - use FatesGlobals, only : fates_log - use FatesConstantsMod, only : r8 => fates_r8 - use FatesConstantsMod, only : itrue - use FatesConstantsMod, only : nearzero - 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 - use PRTGenericMod, only : max_nleafage - use EDTypesMod, only : do_fates_salinity - use EDParamsMod, only : q10_mr - use PRTGenericMod, only : prt_carbon_allom_hyp - use PRTGenericMod, only : prt_cnp_flex_allom_hyp - use PRTGenericMod, only : all_carbon_elements - use PRTGenericMod, only : nitrogen_element - use PRTGenericMod, only : leaf_organ - use PRTGenericMod, only : fnrt_organ - use PRTGenericMod, only : sapw_organ - use PRTGenericMod, only : store_organ - use PRTGenericMod, only : repro_organ - use PRTGenericMod, only : struct_organ - use EDParamsMod, only : ED_val_base_mr_20, stomatal_model - use PRTParametersMod, only : prt_params - - ! CIME Globals - use shr_log_mod , only : errMsg => shr_log_errMsg - - implicit none - private - - public :: FatesPlantRespPhotosynthDrive ! Called by the HLM-Fates interface - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !------------------------------------------------------------------------------------- - - ! maximum stomatal resistance [s/m] (used across several procedures) - real(r8),parameter :: rsmax0 = 2.e8_r8 - - logical :: debug = .false. - !------------------------------------------------------------------------------------- - - ! Ratio of H2O/CO2 gas diffusion in stomatal airspace (approximate) - real(r8),parameter :: h2o_co2_stoma_diffuse_ratio = 1.6_r8 - - ! Ratio of H2O/CO2 gass diffusion in the leaf boundary layer (approximate) - real(r8),parameter :: h2o_co2_bl_diffuse_ratio = 1.4_r8 + + !------------------------------------------------------------------------------------- + ! !DESCRIPTION: + ! Calculates the plant respiration and photosynthetic fluxes for the FATES model + ! This code is similar to and was originally based off of the 'photosynthesis' + ! subroutine in the CLM model. + ! + ! Parameter for activation and deactivation energies were taken from: + ! Activation energy, from: + ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 + ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 + ! High temperature deactivation, from: + ! Leuning (2002) Plant, Cell and Environment 25:1205-1210 + ! The factor "c" scales the deactivation to a value of 1.0 at 25C + ! Photosynthesis and stomatal conductance parameters, from: + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + ! ------------------------------------------------------------------------------------ + + ! !USES: + + use FatesGlobals, only : endrun => fates_endrun + use FatesGlobals, only : fates_log + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : itrue + use FatesConstantsMod, only : nearzero + 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 + use PRTGenericMod, only : max_nleafage + use EDTypesMod, only : do_fates_salinity + use EDParamsMod, only : q10_mr + use PRTGenericMod, only : prt_carbon_allom_hyp + use PRTGenericMod, only : prt_cnp_flex_allom_hyp + use PRTGenericMod, only : all_carbon_elements + use PRTGenericMod, only : nitrogen_element + use PRTGenericMod, only : leaf_organ + use PRTGenericMod, only : fnrt_organ + use PRTGenericMod, only : sapw_organ + use PRTGenericMod, only : store_organ + use PRTGenericMod, only : repro_organ + use PRTGenericMod, only : struct_organ + use EDParamsMod, only : ED_val_base_mr_20, stomatal_model + use PRTParametersMod, only : prt_params + + ! CIME Globals + use shr_log_mod , only : errMsg => shr_log_errMsg + + implicit none + private + + public :: FatesPlantRespPhotosynthDrive ! Called by the HLM-Fates interface + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------------------- + + ! maximum stomatal resistance [s/m] (used across several procedures) + real(r8),parameter :: rsmax0 = 2.e8_r8 + + logical :: debug = .false. + !------------------------------------------------------------------------------------- + + ! Ratio of H2O/CO2 gas diffusion in stomatal airspace (approximate) + real(r8),parameter :: h2o_co2_stoma_diffuse_ratio = 1.6_r8 + + ! Ratio of H2O/CO2 gass diffusion in the leaf boundary layer (approximate) + real(r8),parameter :: h2o_co2_bl_diffuse_ratio = 1.4_r8 contains - + !-------------------------------------------------------------------------------------- - + subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! ----------------------------------------------------------------------------------- @@ -105,7 +105,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use FatesConstantsMod, only : rgas => rgas_J_K_kmol use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm use FatesParameterDerivedMod, only : param_derived - + use FatesAllometryMod, only : bleaf, bstore_allom use FatesAllometryMod, only : storage_fraction_of_target use FatesAllometryMod, only : set_root_fraction @@ -149,21 +149,21 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! net leaf photosynthesis averaged over sun and shade leaves. [umol CO2/m**2/s] real(r8) :: anet_av_z(nlevleaf,maxpft,nclmax) - + ! Mask used to determine which leaf-layer biophysical rates have been ! used already logical :: rate_mask_z(nlevleaf,maxpft,nclmax) real(r8) :: vcmax_z ! leaf layer maximum rate of carboxylation - ! (umol co2/m**2/s) + ! (umol co2/m**2/s) real(r8) :: jmax_z ! leaf layer maximum electron transport rate - ! (umol electrons/m**2/s) + ! (umol electrons/m**2/s) real(r8) :: tpu_z ! leaf layer triose phosphate utilization rate - ! (umol CO2/m**2/s) + ! (umol CO2/m**2/s) real(r8) :: kp_z ! leaf layer initial slope of CO2 response - ! curve (C4 plants) + ! curve (C4 plants) real(r8) :: c13disc_z(nclmax,maxpft,nlevleaf) ! carbon 13 in newly assimilated carbon at leaf level - + real(r8) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) real(r8) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) real(r8) :: co2_cpoint ! CO2 compensation point (Pa) @@ -177,12 +177,12 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: leaf_frac ! ratio of to leaf biomass to total alive biomass real(r8) :: tcsoi ! Temperature response function for root respiration. real(r8) :: tcwood ! Temperature response function for wood - + real(r8) :: elai ! exposed LAI (patch scale) real(r8) :: live_stem_n ! Live stem (above-ground sapwood) - ! nitrogen content (kgN/plant) + ! nitrogen content (kgN/plant) real(r8) :: live_croot_n ! Live coarse root (below-ground sapwood) - ! nitrogen content (kgN/plant) + ! nitrogen content (kgN/plant) real(r8) :: sapw_c ! Sapwood carbon (kgC/plant) real(r8) :: store_c_target ! Target storage carbon (kgC/plant) real(r8) :: fnrt_c ! Fine root carbon (kgC/plant) @@ -190,29 +190,29 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: leaf_c ! Leaf carbon (kgC/plant) real(r8) :: leaf_n ! leaf nitrogen content (kgN/plant) real(r8) :: g_sb_leaves ! Mean combined (stomata+boundary layer) leaf conductance [m/s] - ! over all of the patch's leaves. The "sb" refers to the combined - ! "s"tomatal and "b"oundary layer. - ! This quantity is relevant on leaf surfaces. It does not - ! have units of /m2 leaf per say, but is implicitly on leaf surfaces + ! over all of the patch's leaves. The "sb" refers to the combined + ! "s"tomatal and "b"oundary layer. + ! This quantity is relevant on leaf surfaces. It does not + ! have units of /m2 leaf per say, but is implicitly on leaf surfaces real(r8) :: r_sb_leaves ! Mean leaf resistance over all the patch's leaves [s/m] - ! This is the direct reciprocal of g_sb_leaves + ! This is the direct reciprocal of g_sb_leaves real(r8) :: r_stomata ! Mean stomatal resistance across all leaves in the patch [s/m] real(r8) :: maintresp_reduction_factor ! factor by which to reduce maintenance - ! respiration when storage pools are low + ! respiration when storage pools are low real(r8) :: b_leaf ! leaf biomass kgC real(r8) :: frac ! storage pool as a fraction of target leaf biomass real(r8) :: check_elai ! This is a check on the effective LAI that is calculated - ! over each cohort x layer. + ! over each cohort x layer. real(r8) :: cohort_eleaf_area ! This is the effective leaf area [m2] reported by each cohort real(r8) :: lnc_top ! Leaf nitrogen content per unit area at canopy top [gN/m2] real(r8) :: lmr25top ! canopy top leaf maint resp rate at 25C - ! for this plant or pft (umol CO2/m**2/s) + ! for this plant or pft (umol CO2/m**2/s) real(r8) :: leaf_inc ! LAI-only portion of the vegetation increment of dinc_ed real(r8) :: lai_canopy_above ! the LAI in the canopy layers above the layer of interest real(r8) :: lai_layers_above ! the LAI in the leaf layers, within the current canopy, - ! above the leaf layer of interest + ! above the leaf layer of interest real(r8) :: lai_current ! the LAI in the current leaf layer real(r8) :: cumulative_lai ! the cumulative LAI, top down, to the leaf layer of interest @@ -250,1742 +250,1742 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) associate( & c3psn => EDPftvarcon_inst%c3psn , & slatop => prt_params%slatop , & ! specific leaf area at top of canopy, - ! projected area basis [m^2/gC] + ! projected area basis [m^2/gC] woody => prt_params%woody, & ! Is vegetation woody or not? stomatal_intercept => EDPftvarcon_inst%stomatal_intercept ) !Unstressed minimum stomatal conductance - do s = 1,nsites - - ! Multi-layer parameters scaled by leaf nitrogen profile. - ! Loop through each canopy layer to calculate nitrogen profile using - ! cumulative lai at the midpoint of the layer - - - - ! Pre-process some variables that are PFT dependent - ! but not environmentally dependent - ! ------------------------------------------------------------------------ - - allocate(rootfr_ft(numpft, bc_in(s)%nlevsoil)) - - do ft = 1,numpft - call set_root_fraction(rootfr_ft(ft,:), ft, & - bc_in(s)%zi_sisl) - end do - - - ifp = 0 - currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) - if(currentpatch%nocomp_pft_label.ne.0)then - ifp = ifp+1 - NCL_p = currentPatch%NCL_p - - ! Part I. Zero output boundary conditions - ! --------------------------------------------------------------------------- - bc_out(s)%rssun_pa(ifp) = 0._r8 - bc_out(s)%rssha_pa(ifp) = 0._r8 - - g_sb_leaves = 0._r8 - check_elai = 0._r8 - - ! Part II. Filter out patches - ! 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 already - ! --------------------------------------------------------------------------- - if(bc_in(s)%filter_photo_pa(ifp)==2)then - - - ! Part III. Calculate the number of sublayers for each pft and layer. - ! And then identify which layer/pft combinations have things in them. - ! Output: - ! currentPatch%ncan(:,:) - ! currentPatch%canopy_mask(:,:) - call UpdateCanopyNCanNRadPresent(currentPatch) - - - ! Part IV. Identify some environmentally derived parameters: - ! These quantities are biologically irrelevant - ! Michaelis-Menten constant for CO2 (Pa) - ! Michaelis-Menten constant for O2 (Pa) - ! CO2 compensation point (Pa) - ! leaf boundary layer conductance of h20 - ! constrained vapor pressure - call GetCanopyGasParameters(bc_in(s)%forc_pbot, & ! in - bc_in(s)%oair_pa(ifp), & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - bc_in(s)%tgcm_pa(ifp), & ! in - bc_in(s)%eair_pa(ifp), & ! in - bc_in(s)%esat_tv_pa(ifp), & ! in - bc_in(s)%rb_pa(ifp), & ! in - mm_kco2, & ! out - mm_ko2, & ! out - co2_cpoint, & ! out - cf, & ! out - gb_mol, & ! out - ceair) ! out - - - - - ! ------------------------------------------------------------------------ - ! Part VI: Loop over all leaf layers. - ! The concept of leaf layers is a result of the radiative transfer scheme. - ! A leaf layer has uniform radiation environment. Leaf layers are a group - ! of vegetation surfaces (stems and leaves) which inhabit the same - ! canopy-layer "CL", have the same functional type "ft" and within those - ! two partitions are further partitioned into vertical layers where - ! downwelling radiation attenuates in order. - ! In this phase we loop over the leaf layers and calculate the - ! photosynthesis and respiration of the layer (since all biophysical - ! properties are homogeneous). After this step, we can loop through - ! our cohort list, associate each cohort with its list of leaf-layers - ! and transfer these quantities to the cohort. - ! With plant hydraulics, we must realize that photosynthesis and - ! respiration will be different for leaves of each cohort in the leaf - ! layers, as they will have there own hydraulic limitations. - ! NOTE: Only need to flush mask on the number of used pfts, not the whole - ! scratch space. - ! ------------------------------------------------------------------------ - rate_mask_z(:,1:numpft,:) = .false. - - if(currentPatch%countcohorts > 0.0)then ! Ignore empty patches - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) ! Cohort loop - - ! Identify the canopy layer (cl), functional type (ft) - ! and the leaf layer (IV) for this cohort - ft = currentCohort%pft - cl = currentCohort%canopy_layer - - call bleaf(currentCohort%dbh,currentCohort%pft,currentCohort%canopy_trim,store_c_target) -! call bstore_allom(currentCohort%dbh,currentCohort%pft, & -! currentCohort%canopy_trim,store_c_target) - - call storage_fraction_of_target(store_c_target, & + do s = 1,nsites + + ! Multi-layer parameters scaled by leaf nitrogen profile. + ! Loop through each canopy layer to calculate nitrogen profile using + ! cumulative lai at the midpoint of the layer + + + + ! Pre-process some variables that are PFT dependent + ! but not environmentally dependent + ! ------------------------------------------------------------------------ + + allocate(rootfr_ft(numpft, bc_in(s)%nlevsoil)) + + do ft = 1,numpft + call set_root_fraction(rootfr_ft(ft,:), ft, & + bc_in(s)%zi_sisl) + end do + + + ifp = 0 + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + if(currentpatch%nocomp_pft_label.ne.0)then + ifp = ifp+1 + NCL_p = currentPatch%NCL_p + + ! Part I. Zero output boundary conditions + ! --------------------------------------------------------------------------- + bc_out(s)%rssun_pa(ifp) = 0._r8 + bc_out(s)%rssha_pa(ifp) = 0._r8 + + g_sb_leaves = 0._r8 + check_elai = 0._r8 + + ! Part II. Filter out patches + ! 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 already + ! --------------------------------------------------------------------------- + if(bc_in(s)%filter_photo_pa(ifp)==2)then + + + ! Part III. Calculate the number of sublayers for each pft and layer. + ! And then identify which layer/pft combinations have things in them. + ! Output: + ! currentPatch%ncan(:,:) + ! currentPatch%canopy_mask(:,:) + call UpdateCanopyNCanNRadPresent(currentPatch) + + + ! Part IV. Identify some environmentally derived parameters: + ! These quantities are biologically irrelevant + ! Michaelis-Menten constant for CO2 (Pa) + ! Michaelis-Menten constant for O2 (Pa) + ! CO2 compensation point (Pa) + ! leaf boundary layer conductance of h20 + ! constrained vapor pressure + call GetCanopyGasParameters(bc_in(s)%forc_pbot, & ! in + bc_in(s)%oair_pa(ifp), & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + bc_in(s)%tgcm_pa(ifp), & ! in + bc_in(s)%eair_pa(ifp), & ! in + bc_in(s)%esat_tv_pa(ifp), & ! in + bc_in(s)%rb_pa(ifp), & ! in + mm_kco2, & ! out + mm_ko2, & ! out + co2_cpoint, & ! out + cf, & ! out + gb_mol, & ! out + ceair) ! out + + + + + ! ------------------------------------------------------------------------ + ! Part VI: Loop over all leaf layers. + ! The concept of leaf layers is a result of the radiative transfer scheme. + ! A leaf layer has uniform radiation environment. Leaf layers are a group + ! of vegetation surfaces (stems and leaves) which inhabit the same + ! canopy-layer "CL", have the same functional type "ft" and within those + ! two partitions are further partitioned into vertical layers where + ! downwelling radiation attenuates in order. + ! In this phase we loop over the leaf layers and calculate the + ! photosynthesis and respiration of the layer (since all biophysical + ! properties are homogeneous). After this step, we can loop through + ! our cohort list, associate each cohort with its list of leaf-layers + ! and transfer these quantities to the cohort. + ! With plant hydraulics, we must realize that photosynthesis and + ! respiration will be different for leaves of each cohort in the leaf + ! layers, as they will have there own hydraulic limitations. + ! NOTE: Only need to flush mask on the number of used pfts, not the whole + ! scratch space. + ! ------------------------------------------------------------------------ + rate_mask_z(:,1:numpft,:) = .false. + + if(currentPatch%countcohorts > 0.0)then ! Ignore empty patches + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) ! Cohort loop + + ! Identify the canopy layer (cl), functional type (ft) + ! and the leaf layer (IV) for this cohort + ft = currentCohort%pft + cl = currentCohort%canopy_layer + + call bleaf(currentCohort%dbh,currentCohort%pft,currentCohort%canopy_trim,store_c_target) + ! call bstore_allom(currentCohort%dbh,currentCohort%pft, & + ! currentCohort%canopy_trim,store_c_target) + + call storage_fraction_of_target(store_c_target, & currentCohort%prt%GetState(store_organ, all_carbon_elements), & frac) - call lowstorage_maintresp_reduction(frac,currentCohort%pft, & - maintresp_reduction_factor) - - ! are there any leaves of this pft in this layer? - if(currentPatch%canopy_mask(cl,ft) == 1)then - - ! Loop over leaf-layers - do iv = 1,currentCohort%nv - - ! ------------------------------------------------------------ - ! If we are doing plant hydro-dynamics (or any run-type - ! where cohorts may generate different photosynthetic rates - ! of other cohorts in the same canopy-pft-layer combo), - ! we re-calculate the leaf biophysical rates for the - ! cohort-layer combo of interest. - ! but in the vanilla case, we only re-calculate if it has - ! not been done yet. - ! Other cases where we need to solve for every cohort - ! in every leaf layer: nutrient dynamic mode, multiple leaf - ! age classes - ! ------------------------------------------------------------ - - if ( .not.rate_mask_z(iv,ft,cl) .or. & + call lowstorage_maintresp_reduction(frac,currentCohort%pft, & + maintresp_reduction_factor) + + ! are there any leaves of this pft in this layer? + if(currentPatch%canopy_mask(cl,ft) == 1)then + + ! Loop over leaf-layers + do iv = 1,currentCohort%nv + + ! ------------------------------------------------------------ + ! If we are doing plant hydro-dynamics (or any run-type + ! where cohorts may generate different photosynthetic rates + ! of other cohorts in the same canopy-pft-layer combo), + ! we re-calculate the leaf biophysical rates for the + ! cohort-layer combo of interest. + ! but in the vanilla case, we only re-calculate if it has + ! not been done yet. + ! Other cases where we need to solve for every cohort + ! in every leaf layer: nutrient dynamic mode, multiple leaf + ! age classes + ! ------------------------------------------------------------ + + if ( .not.rate_mask_z(iv,ft,cl) .or. & (hlm_use_planthydro.eq.itrue) .or. & (nleafage > 1) .or. & (hlm_parteh_mode .ne. prt_carbon_allom_hyp ) ) then - + if (hlm_use_planthydro.eq.itrue ) then - - stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(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 - ! ------------------------------------------------------ - leaf_inc = dinc_ed * & - currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) - - ! Now calculate the cumulative top-down lai of the current layer's midpoint - lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) - lai_layers_above = leaf_inc * (iv-1) - lai_current = min(leaf_inc, currentCohort%treelai - lai_layers_above) - cumulative_lai = lai_canopy_above + lai_layers_above + 0.5*lai_current - - else - - stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentPatch%btran_ft(ft) ) - - btran_eff = currentPatch%btran_ft(ft) - ! For consistency sake, we use total LAI here, and not exposed - ! if the plant is under-snow, it will be effectively dormant for - ! the purposes of nscaler - - cumulative_lai = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + & - sum(currentPatch%tlai_profile(cl,ft,1:iv-1)) + & - 0.5*currentPatch%tlai_profile(cl,ft,iv) - - - end if - - if(do_fates_salinity)then - btran_eff = btran_eff*currentPatch%bstress_sal_ft(ft) - endif - - - ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 used - ! kn = 0.11. Here, derive kn from vcmax25 as in Lloyd et al - ! (2010) Biogeosciences, 7, 1833-1859 - - kn = decay_coeff_kn(ft,currentCohort%vcmax25top) - - ! Scale for leaf nitrogen profile - nscaler = exp(-kn * cumulative_lai) - - ! Leaf maintenance respiration to match the base rate used in CN - ! but with the new temperature functions for C3 and C4 plants. - - ! CN respiration has units: g C / g N [leaf] / s. This needs to be - ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s - - ! Then scale this value at the top of the canopy for canopy depth - ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp) - - lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) - - case (prt_cnp_flex_allom_hyp) - - leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) - if( (leaf_c*slatop(ft)) > nearzero) then - leaf_n = currentCohort%prt%GetState(leaf_organ, nitrogen_element) - lnc_top = leaf_n / (slatop(ft) * leaf_c ) - else - lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) - end if - - ! If one wants to break coupling with dynamic N conentrations, - ! use the stoichiometry parameter - ! lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) - - end select - - lmr25top = 2.525e-6_r8 * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) - lmr25top = lmr25top * lnc_top / (umolC_to_kgC * g_per_kg) - - - ! Part VII: Calculate dark respiration (leaf maintenance) for this layer - call LeafLayerMaintenanceRespiration( lmr25top, & ! in - nscaler, & ! in - ft, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - lmr_z(iv,ft,cl)) ! out - - ! Part VII: Calculate (1) maximum rate of carboxylation (vcmax), - ! (2) maximum electron transport rate, (3) triose phosphate - ! utilization rate and (4) the initial slope of CO2 response curve - ! (C4 plants). Earlier we calculated their base rates as dictated - ! by their plant functional type and some simple scaling rules for - ! nitrogen limitation baesd on canopy position (not prognostic). - ! These rates are the specific rates used in the actual photosynthesis - ! calculations that take localized environmental effects (temperature) - ! into consideration. - - - - call LeafLayerBiophysicalRates(currentPatch%ed_parsun_z(cl,ft,iv), & ! in - ft, & ! in - currentCohort%vcmax25top, & ! in - currentCohort%jmax25top, & ! in - currentCohort%tpu25top, & ! in - currentCohort%kp25top, & ! in - nscaler, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - btran_eff, & ! in - vcmax_z, & ! out - jmax_z, & ! out - tpu_z, & ! out - kp_z ) ! out - - ! Part IX: This call calculates the actual photosynthesis for the - ! leaf layer, as well as the stomatal resistance and the net assimilated carbon. - - call LeafLayerPhotosynthesis(currentPatch%f_sun(cl,ft,iv), & ! in - currentPatch%ed_parsun_z(cl,ft,iv), & ! in - currentPatch%ed_parsha_z(cl,ft,iv), & ! in - currentPatch%ed_laisun_z(cl,ft,iv), & ! in - currentPatch%ed_laisha_z(cl,ft,iv), & ! in - currentPatch%canopy_area_profile(cl,ft,iv), & ! in - ft, & ! in - vcmax_z, & ! in - jmax_z, & ! in - tpu_z, & ! in - kp_z, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - bc_in(s)%esat_tv_pa(ifp), & ! in - bc_in(s)%forc_pbot, & ! in - bc_in(s)%cair_pa(ifp), & ! in - bc_in(s)%oair_pa(ifp), & ! in - btran_eff, & ! in - stomatal_intercept_btran, & ! in - cf, & ! in - gb_mol, & ! in - ceair, & ! in - mm_kco2, & ! in - mm_ko2, & ! in - co2_cpoint, & ! in - lmr_z(iv,ft,cl), & ! in - currentPatch%psn_z(cl,ft,iv), & ! out - rs_z(iv,ft,cl), & ! out - anet_av_z(iv,ft,cl), & ! out - c13disc_z(cl,ft,iv)) ! out - - rate_mask_z(iv,ft,cl) = .true. - end if - end do - - ! Zero cohort flux accumulators. - currentCohort%npp_tstep = 0.0_r8 - currentCohort%resp_tstep = 0.0_r8 - currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rdark = 0.0_r8 - currentCohort%resp_m = 0.0_r8 - currentCohort%ts_net_uptake = 0.0_r8 - currentCohort%c13disc_clm = 0.0_r8 - - ! --------------------------------------------------------------- - ! Part VII: Transfer leaf flux rates (like maintenance respiration, - ! carbon assimilation and conductance) that are defined by the - ! leaf layer (which is area independent, ie /m2) onto each cohort - ! (where the rates become per cohort, ie /individual). Most likely - ! a sum over layers. - ! --------------------------------------------------------------- - nv = currentCohort%nv - call ScaleLeafLayerFluxToCohort(nv, & !in - currentPatch%psn_z(cl,ft,1:nv), & !in - lmr_z(1:nv,ft,cl), & !in - rs_z(1:nv,ft,cl), & !in - currentPatch%elai_profile(cl,ft,1:nv), & !in - c13disc_z(cl, ft, 1:nv), & !in - currentCohort%c_area, & !in - currentCohort%n, & !in - bc_in(s)%rb_pa(ifp), & !in - maintresp_reduction_factor, & !in - currentCohort%g_sb_laweight, & !out - currentCohort%gpp_tstep, & !out - currentCohort%rdark, & !out - currentCohort%c13disc_clm, & !out - cohort_eleaf_area) !out - - ! Net Uptake does not need to be scaled, just transfer directly - currentCohort%ts_net_uptake(1:nv) = anet_av_z(1:nv,ft,cl) * umolC_to_kgC - - else - - ! In this case, the cohort had no leaves, - ! so no productivity,conductance, transpiration uptake - ! or dark respiration - cohort_eleaf_area = 0.0_r8 - currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rdark = 0.0_r8 - currentCohort%g_sb_laweight = 0.0_r8 - currentCohort%ts_net_uptake(:) = 0.0_r8 - - end if ! if(currentPatch%canopy_mask(cl,ft) == 1)then - - - ! ------------------------------------------------------------------ - ! Part VIII: Calculate maintenance respiration in the sapwood and - ! fine root pools. - ! ------------------------------------------------------------------ - - ! Calculate the amount of nitrogen in the above and below ground - ! stem and root pools, used for maint resp - ! We are using the fine-root C:N ratio as an approximation for - ! the sapwood pools. - ! Units are in (kgN/plant) - ! ------------------------------------------------------------------ - - sapw_c = currentCohort%prt%GetState(sapw_organ, all_carbon_elements) - fnrt_c = currentCohort%prt%GetState(fnrt_organ, all_carbon_elements) - - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp) - - live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & + + stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(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 + ! ------------------------------------------------------ + leaf_inc = dinc_ed * & + currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) + + ! Now calculate the cumulative top-down lai of the current layer's midpoint + lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + lai_layers_above = leaf_inc * (iv-1) + lai_current = min(leaf_inc, currentCohort%treelai - lai_layers_above) + cumulative_lai = lai_canopy_above + lai_layers_above + 0.5*lai_current + + else + + stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentPatch%btran_ft(ft) ) + + btran_eff = currentPatch%btran_ft(ft) + ! For consistency sake, we use total LAI here, and not exposed + ! if the plant is under-snow, it will be effectively dormant for + ! the purposes of nscaler + + cumulative_lai = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + & + sum(currentPatch%tlai_profile(cl,ft,1:iv-1)) + & + 0.5*currentPatch%tlai_profile(cl,ft,iv) + + + end if + + if(do_fates_salinity)then + btran_eff = btran_eff*currentPatch%bstress_sal_ft(ft) + endif + + + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 used + ! kn = 0.11. Here, derive kn from vcmax25 as in Lloyd et al + ! (2010) Biogeosciences, 7, 1833-1859 + + kn = decay_coeff_kn(ft,currentCohort%vcmax25top) + + ! Scale for leaf nitrogen profile + nscaler = exp(-kn * cumulative_lai) + + ! Leaf maintenance respiration to match the base rate used in CN + ! but with the new temperature functions for C3 and C4 plants. + + ! CN respiration has units: g C / g N [leaf] / s. This needs to be + ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s + + ! Then scale this value at the top of the canopy for canopy depth + ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp) + + lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) + + case (prt_cnp_flex_allom_hyp) + + leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) + if( (leaf_c*slatop(ft)) > nearzero) then + leaf_n = currentCohort%prt%GetState(leaf_organ, nitrogen_element) + lnc_top = leaf_n / (slatop(ft) * leaf_c ) + else + lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) + end if + + ! If one wants to break coupling with dynamic N conentrations, + ! use the stoichiometry parameter + ! lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) + + end select + + lmr25top = 2.525e-6_r8 * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) + lmr25top = lmr25top * lnc_top / (umolC_to_kgC * g_per_kg) + + + ! Part VII: Calculate dark respiration (leaf maintenance) for this layer + call LeafLayerMaintenanceRespiration( lmr25top, & ! in + nscaler, & ! in + ft, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + lmr_z(iv,ft,cl)) ! out + + ! Part VII: Calculate (1) maximum rate of carboxylation (vcmax), + ! (2) maximum electron transport rate, (3) triose phosphate + ! utilization rate and (4) the initial slope of CO2 response curve + ! (C4 plants). Earlier we calculated their base rates as dictated + ! by their plant functional type and some simple scaling rules for + ! nitrogen limitation baesd on canopy position (not prognostic). + ! These rates are the specific rates used in the actual photosynthesis + ! calculations that take localized environmental effects (temperature) + ! into consideration. + + + + call LeafLayerBiophysicalRates(currentPatch%ed_parsun_z(cl,ft,iv), & ! in + ft, & ! in + currentCohort%vcmax25top, & ! in + currentCohort%jmax25top, & ! in + currentCohort%tpu25top, & ! in + currentCohort%kp25top, & ! in + nscaler, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + btran_eff, & ! in + vcmax_z, & ! out + jmax_z, & ! out + tpu_z, & ! out + kp_z ) ! out + + ! Part IX: This call calculates the actual photosynthesis for the + ! leaf layer, as well as the stomatal resistance and the net assimilated carbon. + + call LeafLayerPhotosynthesis(currentPatch%f_sun(cl,ft,iv), & ! in + currentPatch%ed_parsun_z(cl,ft,iv), & ! in + currentPatch%ed_parsha_z(cl,ft,iv), & ! in + currentPatch%ed_laisun_z(cl,ft,iv), & ! in + currentPatch%ed_laisha_z(cl,ft,iv), & ! in + currentPatch%canopy_area_profile(cl,ft,iv), & ! in + ft, & ! in + vcmax_z, & ! in + jmax_z, & ! in + tpu_z, & ! in + kp_z, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + bc_in(s)%esat_tv_pa(ifp), & ! in + bc_in(s)%forc_pbot, & ! in + bc_in(s)%cair_pa(ifp), & ! in + bc_in(s)%oair_pa(ifp), & ! in + btran_eff, & ! in + stomatal_intercept_btran, & ! in + cf, & ! in + gb_mol, & ! in + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr_z(iv,ft,cl), & ! in + currentPatch%psn_z(cl,ft,iv), & ! out + rs_z(iv,ft,cl), & ! out + anet_av_z(iv,ft,cl), & ! out + c13disc_z(cl,ft,iv)) ! out + + rate_mask_z(iv,ft,cl) = .true. + end if + end do + + ! Zero cohort flux accumulators. + currentCohort%npp_tstep = 0.0_r8 + currentCohort%resp_tstep = 0.0_r8 + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rdark = 0.0_r8 + currentCohort%resp_m = 0.0_r8 + currentCohort%ts_net_uptake = 0.0_r8 + currentCohort%c13disc_clm = 0.0_r8 + + ! --------------------------------------------------------------- + ! Part VII: Transfer leaf flux rates (like maintenance respiration, + ! carbon assimilation and conductance) that are defined by the + ! leaf layer (which is area independent, ie /m2) onto each cohort + ! (where the rates become per cohort, ie /individual). Most likely + ! a sum over layers. + ! --------------------------------------------------------------- + nv = currentCohort%nv + call ScaleLeafLayerFluxToCohort(nv, & !in + currentPatch%psn_z(cl,ft,1:nv), & !in + lmr_z(1:nv,ft,cl), & !in + rs_z(1:nv,ft,cl), & !in + currentPatch%elai_profile(cl,ft,1:nv), & !in + c13disc_z(cl, ft, 1:nv), & !in + currentCohort%c_area, & !in + currentCohort%n, & !in + bc_in(s)%rb_pa(ifp), & !in + maintresp_reduction_factor, & !in + currentCohort%g_sb_laweight, & !out + currentCohort%gpp_tstep, & !out + currentCohort%rdark, & !out + currentCohort%c13disc_clm, & !out + cohort_eleaf_area) !out + + ! Net Uptake does not need to be scaled, just transfer directly + currentCohort%ts_net_uptake(1:nv) = anet_av_z(1:nv,ft,cl) * umolC_to_kgC + + else + + ! In this case, the cohort had no leaves, + ! so no productivity,conductance, transpiration uptake + ! or dark respiration + cohort_eleaf_area = 0.0_r8 + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rdark = 0.0_r8 + currentCohort%g_sb_laweight = 0.0_r8 + currentCohort%ts_net_uptake(:) = 0.0_r8 + + end if ! if(currentPatch%canopy_mask(cl,ft) == 1)then + + + ! ------------------------------------------------------------------ + ! Part VIII: Calculate maintenance respiration in the sapwood and + ! fine root pools. + ! ------------------------------------------------------------------ + + ! Calculate the amount of nitrogen in the above and below ground + ! stem and root pools, used for maint resp + ! We are using the fine-root C:N ratio as an approximation for + ! the sapwood pools. + ! Units are in (kgN/plant) + ! ------------------------------------------------------------------ + + sapw_c = currentCohort%prt%GetState(sapw_organ, all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ, all_carbon_elements) + + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp) + + live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) - - live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & + + live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) - fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,fnrt_organ) - - case(prt_cnp_flex_allom_hyp) - - live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & - currentCohort%prt%GetState(sapw_organ, nitrogen_element) - - live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & - currentCohort%prt%GetState(sapw_organ, nitrogen_element) - - fnrt_n = currentCohort%prt%GetState(fnrt_organ, nitrogen_element) - - ! If one wants to break coupling with dynamic N conentrations, - ! use the stoichiometry parameter - ! - ! live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & - ! sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) - ! live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & - ! sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) - ! fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,fnrt_organ) - - - case default - - - end select - - !------------------------------------------------------------------------------ - ! Calculate Whole Plant Respiration - ! (this doesn't really need to be in this iteration at all, surely?) - ! Response: (RGK 12-2016): I think the positioning of these calls is - ! appropriate as of now. Maintenance calculations in sapwood and roots - ! vary by cohort and with changing temperature at the minimum, and there are - ! no sub-pools chopping up those pools any finer that need to be dealt with. - !------------------------------------------------------------------------------ - - ! Live stem MR (kgC/plant/s) (above ground sapwood) - ! ------------------------------------------------------------------ - if ( int(woody(ft)) == itrue) then - tcwood = q10_mr**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) - ! kgC/s = kgN * kgC/kgN/s - currentCohort%livestem_mr = live_stem_n * ED_val_base_mr_20 * tcwood * maintresp_reduction_factor - else - currentCohort%livestem_mr = 0._r8 - end if - - - ! Fine Root MR (kgC/plant/s) - ! ------------------------------------------------------------------ - currentCohort%froot_mr = 0._r8 - do j = 1,bc_in(s)%nlevsoil - tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) - currentCohort%froot_mr = currentCohort%froot_mr + & + fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,fnrt_organ) + + case(prt_cnp_flex_allom_hyp) + + live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & + currentCohort%prt%GetState(sapw_organ, nitrogen_element) + + live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & + currentCohort%prt%GetState(sapw_organ, nitrogen_element) + + fnrt_n = currentCohort%prt%GetState(fnrt_organ, nitrogen_element) + + ! If one wants to break coupling with dynamic N conentrations, + ! use the stoichiometry parameter + ! + ! live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & + ! sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) + ! live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & + ! sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) + ! fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,fnrt_organ) + + + case default + + + end select + + !------------------------------------------------------------------------------ + ! Calculate Whole Plant Respiration + ! (this doesn't really need to be in this iteration at all, surely?) + ! Response: (RGK 12-2016): I think the positioning of these calls is + ! appropriate as of now. Maintenance calculations in sapwood and roots + ! vary by cohort and with changing temperature at the minimum, and there are + ! no sub-pools chopping up those pools any finer that need to be dealt with. + !------------------------------------------------------------------------------ + + ! Live stem MR (kgC/plant/s) (above ground sapwood) + ! ------------------------------------------------------------------ + if ( int(woody(ft)) == itrue) then + tcwood = q10_mr**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) + ! kgC/s = kgN * kgC/kgN/s + currentCohort%livestem_mr = live_stem_n * ED_val_base_mr_20 * tcwood * maintresp_reduction_factor + else + currentCohort%livestem_mr = 0._r8 + end if + + + ! Fine Root MR (kgC/plant/s) + ! ------------------------------------------------------------------ + currentCohort%froot_mr = 0._r8 + do j = 1,bc_in(s)%nlevsoil + tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) + currentCohort%froot_mr = currentCohort%froot_mr + & fnrt_n * ED_val_base_mr_20 * tcsoi * rootfr_ft(ft,j) * maintresp_reduction_factor - enddo - - ! Coarse Root MR (kgC/plant/s) (below ground sapwood) - ! ------------------------------------------------------------------ - if ( int(woody(ft)) == itrue) then - currentCohort%livecroot_mr = 0._r8 - do j = 1,bc_in(s)%nlevsoil - ! Soil temperature used to adjust base rate of MR - tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) - currentCohort%livecroot_mr = currentCohort%livecroot_mr + & + enddo + + ! Coarse Root MR (kgC/plant/s) (below ground sapwood) + ! ------------------------------------------------------------------ + if ( int(woody(ft)) == itrue) then + currentCohort%livecroot_mr = 0._r8 + do j = 1,bc_in(s)%nlevsoil + ! Soil temperature used to adjust base rate of MR + tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) + currentCohort%livecroot_mr = currentCohort%livecroot_mr + & live_croot_n * ED_val_base_mr_20 * tcsoi * & rootfr_ft(ft,j) * maintresp_reduction_factor - enddo - else - currentCohort%livecroot_mr = 0._r8 - end if - - - ! ------------------------------------------------------------------ - ! Part IX: Perform some unit conversions (rate to integrated) and - ! calcualate some fluxes that are sums and nets of the base fluxes - ! ------------------------------------------------------------------ - - if ( debug ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m - if ( debug ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark - if ( debug ) write(fates_log(),*) 'EDPhoto 906 ', currentCohort%livestem_mr - if ( debug ) write(fates_log(),*) 'EDPhoto 907 ', currentCohort%livecroot_mr - if ( debug ) write(fates_log(),*) 'EDPhoto 908 ', currentCohort%froot_mr - - - - ! add on whole plant respiration values in kgC/indiv/s-1 - currentCohort%resp_m = currentCohort%livestem_mr + & - currentCohort%livecroot_mr + & - currentCohort%froot_mr - - ! no drought response right now.. something like: - ! resp_m = resp_m * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft) * & - ! EDPftvarcon_inst%resp_drought_response(ft)) - - currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark - - ! convert from kgC/indiv/s to kgC/indiv/timestep - currentCohort%resp_m = currentCohort%resp_m * dtime - currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime - currentCohort%ts_net_uptake = currentCohort%ts_net_uptake * dtime - - if ( debug ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep - if ( debug ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep - if ( debug ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m - - - currentCohort%resp_g_tstep = prt_params%grperc(ft) * & - (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) - - - currentCohort%resp_tstep = currentCohort%resp_m + & - currentCohort%resp_g_tstep ! kgC/indiv/ts - currentCohort%npp_tstep = currentCohort%gpp_tstep - & - currentCohort%resp_tstep ! kgC/indiv/ts - - ! Accumulate the combined conductance (stomatal+leaf boundary layer) - ! Note that currentCohort%g_sb_laweight is weighted by the leaf area - ! of each cohort and has units of [m/s] * [m2 leaf] - - g_sb_leaves = g_sb_leaves + currentCohort%g_sb_laweight - - ! Accumulate the total effective leaf area from all cohorts - ! in this patch. Normalize by canopy area outside the loop - check_elai = check_elai + cohort_eleaf_area - - currentCohort => currentCohort%shorter - - enddo ! end cohort loop. - end if !count_cohorts is more than zero. - - check_elai = check_elai / currentPatch%total_canopy_area - elai = calc_areaindex(currentPatch,'elai') - - ! Normalize canopy total conductance by the effective LAI - ! The value here was integrated over each cohort x leaf layer - ! and was weighted by m2 of effective leaf area for each layer - - if(check_elai>tiny(check_elai)) then - - ! Normalize the leaf-area weighted canopy conductance - ! The denominator is the total effective leaf area in the canopy, - ! units of [m/s]*[m2] / [m2] = [m/s] - g_sb_leaves = g_sb_leaves / (elai*currentPatch%total_canopy_area) - - if( g_sb_leaves > (1._r8/rsmax0) ) then - - ! Combined mean leaf resistance is the inverse of mean leaf conductance - r_sb_leaves = 1.0_r8/g_sb_leaves - - if (r_sb_leaves currentPatch%younger - end do - - deallocate(rootfr_ft) - - end do !site loop - - end associate - end subroutine FatesPlantRespPhotosynthDrive - - ! ======================================================================================= - - subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in - parsun_lsl, & ! in - parsha_lsl, & ! in - laisun_lsl, & ! in - laisha_lsl, & ! in - canopy_area_lsl, & ! in - ft, & ! in - vcmax, & ! in - jmax, & ! in - tpu, & ! in - co2_rcurve_islope, & ! in - veg_tempk, & ! in - veg_esat, & ! in - can_press, & ! in - can_co2_ppress, & ! in - can_o2_ppress, & ! in - btran, & ! in - stomatal_intercept_btran, & ! in - cf, & ! in - gb_mol, & ! in - ceair, & ! in - mm_kco2, & ! in - mm_ko2, & ! in - co2_cpoint, & ! in - lmr, & ! in - psn_out, & ! out - rstoma_out, & ! out - anet_av_out, & ! out - c13disc_z) ! out - - ! ------------------------------------------------------------------------------------ - ! This subroutine calculates photosynthesis and stomatal conductance within each leaf - ! sublayer. - ! A note on naming conventions: As this subroutine is called for every - ! leaf-sublayer, many of the arguments are specific to that "leaf sub layer" - ! (LSL), those variables are given a dimension tag "_lsl" - ! Other arguments or variables may be indicative of scales broader than the LSL. - ! ------------------------------------------------------------------------------------ - - use EDPftvarcon , only : EDPftvarcon_inst - - - ! Arguments - ! ------------------------------------------------------------------------------------ - real(r8), intent(in) :: f_sun_lsl ! - real(r8), intent(in) :: parsun_lsl ! Absorbed PAR in sunlist leaves - real(r8), intent(in) :: parsha_lsl ! Absorved PAR in shaded leaves - real(r8), intent(in) :: laisun_lsl ! LAI in sunlit leaves - real(r8), intent(in) :: laisha_lsl ! LAI in shaded leaves - real(r8), intent(in) :: canopy_area_lsl ! - integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8), intent(in) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8), intent(in) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) - real(r8), intent(in) :: tpu ! triose phosphate utilization rate (umol CO2/m**2/s) - real(r8), intent(in) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) - real(r8), intent(in) :: veg_tempk ! vegetation temperature - real(r8), intent(in) :: veg_esat ! saturation vapor pressure at veg_tempk (Pa) - - ! Important Note on the following gas pressures. This photosynthesis scheme will iteratively - ! solve for the co2 partial pressure at the leaf surface (ie in the stomata). The reference - ! point for these input values are NOT within that boundary layer that separates the stomata from - ! the canopy air space. The reference point for these is on the outside of that boundary - ! layer. This routine, which operates at the leaf scale, makes no assumptions about what the - ! scale of the refernce is, it could be lower atmosphere, it could be within the canopy - ! but most likely it is the closest value one can get to the edge of the leaf's boundary - ! layer. We use the convention "can_" because a reference point of within the canopy - ! ia a best reasonable scenario of where we can get that information from. - - real(r8), intent(in) :: can_press ! Air pressure NEAR the surface of the leaf (Pa) - real(r8), intent(in) :: can_co2_ppress ! Partial pressure of CO2 NEAR the leaf surface (Pa) - real(r8), intent(in) :: can_o2_ppress ! Partial pressure of O2 NEAR the leaf surface (Pa) - real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) - real(r8), intent(in) :: stomatal_intercept_btran !water-stressed minimum stomatal conductance (umol H2O/m**2/s) - real(r8), intent(in) :: cf ! s m**2/umol -> s/m (ideal gas conversion) [umol/m3] - real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol /m**2/s) - real(r8), intent(in) :: ceair ! vapor pressure of air, constrained (Pa) - real(r8), intent(in) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) - real(r8), intent(in) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) - real(r8), intent(in) :: co2_cpoint ! CO2 compensation point (Pa) - real(r8), intent(in) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) - - real(r8), intent(out) :: psn_out ! carbon assimilated in this leaf layer umolC/m2/s - real(r8), intent(out) :: rstoma_out ! stomatal resistance (1/gs_lsl) (s/m) - real(r8), intent(out) :: anet_av_out ! net leaf photosynthesis (umol CO2/m**2/s) - ! averaged over sun and shade leaves. - real(r8), intent(out) :: c13disc_z ! carbon 13 in newly assimilated carbon - - ! Locals - ! ------------------------------------------------------------------------ - integer :: c3c4_path_index ! Index for which photosynthetic pathway - ! is active. C4 = 0, C3 = 1 - integer :: sunsha ! Index for differentiating sun and shade - real(r8) :: gstoma ! Stomatal Conductance of this leaf layer (m/s) - real(r8) :: agross ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) - real(r8) :: anet ! net leaf photosynthesis (umol CO2/m**2/s) - real(r8) :: je ! electron transport rate (umol electrons/m**2/s) - real(r8) :: qabs ! PAR absorbed by PS II (umol photons/m**2/s) - real(r8) :: aquad,bquad,cquad ! terms for quadratic equations - real(r8) :: r1,r2 ! roots of quadratic equation - real(r8) :: co2_inter_c ! intercellular leaf CO2 (Pa) - real(r8) :: co2_inter_c_old ! intercellular leaf CO2 (Pa) (previous iteration) - logical :: loop_continue ! Loop control variable - integer :: niter ! iteration loop index - real(r8) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) - real(r8) :: gs ! leaf stomatal conductance (m/s) - real(r8) :: hs ! fractional humidity at leaf surface (dimensionless) - real(r8) :: gs_mol_err ! gs_mol for error check - real(r8) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) - real(r8) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) - real(r8) :: ap ! product-limited (C3) or CO2-limited - ! (C4) gross photosynthesis (umol CO2/m**2/s) - real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) - real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) - real(r8) :: init_co2_inter_c ! First guess intercellular co2 specific to C path - real(r8) :: term ! intermediate variable in Medlyn stomatal conductance model - real(r8) :: vpd ! water vapor deficit in Medlyn stomatal model (KPa) - - - ! Parameters - ! ------------------------------------------------------------------------ - ! Fraction of light absorbed by non-photosynthetic pigments - real(r8),parameter :: fnps = 0.15_r8 - - ! For plants with no leaves, a miniscule amount of conductance - ! can happen through the stems, at a partial rate of cuticular conductance - real(r8),parameter :: stem_cuticle_loss_frac = 0.1_r8 - - ! empirical curvature parameter for electron transport rate - real(r8),parameter :: theta_psii = 0.7_r8 - - ! First guess on ratio between intercellular co2 and the atmosphere - ! an iterator converges on actual - real(r8),parameter :: init_a2l_co2_c3 = 0.7_r8 - real(r8),parameter :: init_a2l_co2_c4 = 0.4_r8 - - ! quantum efficiency, used only for C4 (mol CO2 / mol photons) (index 0) - real(r8),parameter,dimension(0:1) :: quant_eff = [0.05_r8,0.0_r8] - - ! empirical curvature parameter for ac, aj photosynthesis co-limitation. - ! Changed theta_cj and theta_ip to 0.999 to effectively remove smoothing logic - ! following Anthony Walker's findings from MAAT. - real(r8),parameter,dimension(0:1) :: theta_cj = [0.999_r8,0.999_r8] - - ! empirical curvature parameter for ap photosynthesis co-limitation - real(r8),parameter :: theta_ip = 0.999_r8 - - associate( bb_slope => EDPftvarcon_inst%bb_slope ,& ! slope of BB relationship, unitless - medlyn_slope=> EDPftvarcon_inst%medlyn_slope , & ! Slope for Medlyn stomatal conductance model method, the unit is KPa^0.5 - stomatal_intercept=> EDPftvarcon_inst%stomatal_intercept ) !Unstressed minimum stomatal conductance, the unit is umol/m**2/s - - ! photosynthetic pathway: 0. = c4, 1. = c3 - c3c4_path_index = nint(EDPftvarcon_inst%c3psn(ft)) - - if (c3c4_path_index == 1) then - init_co2_inter_c = init_a2l_co2_c3 * can_co2_ppress - else - init_co2_inter_c = init_a2l_co2_c4 * can_co2_ppress - end if - - ! Part III: Photosynthesis and Conductance - ! ---------------------------------------------------------------------------------- - - if ( parsun_lsl <= 0._r8 ) then ! night time - - anet_av_out = -lmr - psn_out = 0._r8 + enddo + else + currentCohort%livecroot_mr = 0._r8 + end if - ! The cuticular conductance already factored in maximum resistance as a bound - ! no need to re-bound it - - rstoma_out = cf/stomatal_intercept_btran - - c13disc_z = 0.0_r8 !carbon 13 discrimination in night time carbon flux, note value of 1.0 is used in CLM - - else ! day time (a little bit more complicated ...) - - !is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) - if ( laisun_lsl + laisha_lsl > 0._r8 ) then - - !Loop aroun shaded and unshaded leaves - psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. - rstoma_out = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. - anet_av_out = 0._r8 - gstoma = 0._r8 - - do sunsha = 1,2 - ! Electron transport rate for C3 plants. - ! Convert par from W/m2 to umol photons/m**2/s using the factor 4.6 - ! Convert from units of par absorbed per unit ground area to par - ! absorbed per unit leaf area. - - if(sunsha == 1)then !sunlit - if(( laisun_lsl * canopy_area_lsl) > 0.0000000001_r8)then - - qabs = parsun_lsl / (laisun_lsl * canopy_area_lsl ) - qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 - - else - qabs = 0.0_r8 - end if - else - qabs = parsha_lsl / (laisha_lsl * canopy_area_lsl) + ! ------------------------------------------------------------------ + ! Part IX: Perform some unit conversions (rate to integrated) and + ! calcualate some fluxes that are sums and nets of the base fluxes + ! ------------------------------------------------------------------ + + if ( debug ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m + if ( debug ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark + if ( debug ) write(fates_log(),*) 'EDPhoto 906 ', currentCohort%livestem_mr + if ( debug ) write(fates_log(),*) 'EDPhoto 907 ', currentCohort%livecroot_mr + if ( debug ) write(fates_log(),*) 'EDPhoto 908 ', currentCohort%froot_mr + + + + ! add on whole plant respiration values in kgC/indiv/s-1 + currentCohort%resp_m = currentCohort%livestem_mr + & + currentCohort%livecroot_mr + & + currentCohort%froot_mr + + ! no drought response right now.. something like: + ! resp_m = resp_m * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft) * & + ! EDPftvarcon_inst%resp_drought_response(ft)) + + currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark + + ! convert from kgC/indiv/s to kgC/indiv/timestep + currentCohort%resp_m = currentCohort%resp_m * dtime + currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime + currentCohort%ts_net_uptake = currentCohort%ts_net_uptake * dtime + + if ( debug ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep + if ( debug ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep + if ( debug ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m + + + currentCohort%resp_g_tstep = prt_params%grperc(ft) * & + (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) + + + currentCohort%resp_tstep = currentCohort%resp_m + & + currentCohort%resp_g_tstep ! kgC/indiv/ts + currentCohort%npp_tstep = currentCohort%gpp_tstep - & + currentCohort%resp_tstep ! kgC/indiv/ts + + ! Accumulate the combined conductance (stomatal+leaf boundary layer) + ! Note that currentCohort%g_sb_laweight is weighted by the leaf area + ! of each cohort and has units of [m/s] * [m2 leaf] + + g_sb_leaves = g_sb_leaves + currentCohort%g_sb_laweight + + ! Accumulate the total effective leaf area from all cohorts + ! in this patch. Normalize by canopy area outside the loop + check_elai = check_elai + cohort_eleaf_area + + currentCohort => currentCohort%shorter + + enddo ! end cohort loop. + end if !count_cohorts is more than zero. + + check_elai = check_elai / currentPatch%total_canopy_area + elai = calc_areaindex(currentPatch,'elai') + + ! Normalize canopy total conductance by the effective LAI + ! The value here was integrated over each cohort x leaf layer + ! and was weighted by m2 of effective leaf area for each layer + + if(check_elai>tiny(check_elai)) then + + ! Normalize the leaf-area weighted canopy conductance + ! The denominator is the total effective leaf area in the canopy, + ! units of [m/s]*[m2] / [m2] = [m/s] + g_sb_leaves = g_sb_leaves / (elai*currentPatch%total_canopy_area) + + if( g_sb_leaves > (1._r8/rsmax0) ) then + + ! Combined mean leaf resistance is the inverse of mean leaf conductance + r_sb_leaves = 1.0_r8/g_sb_leaves + + if (r_sb_leaves currentPatch%younger + end do + + deallocate(rootfr_ft) + + end do !site loop + + end associate +end subroutine FatesPlantRespPhotosynthDrive + +! ======================================================================================= + +subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in + parsun_lsl, & ! in + parsha_lsl, & ! in + laisun_lsl, & ! in + laisha_lsl, & ! in + canopy_area_lsl, & ! in + ft, & ! in + vcmax, & ! in + jmax, & ! in + tpu, & ! in + co2_rcurve_islope, & ! in + veg_tempk, & ! in + veg_esat, & ! in + can_press, & ! in + can_co2_ppress, & ! in + can_o2_ppress, & ! in + btran, & ! in + stomatal_intercept_btran, & ! in + cf, & ! in + gb_mol, & ! in + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr, & ! in + psn_out, & ! out + rstoma_out, & ! out + anet_av_out, & ! out + c13disc_z) ! out + + ! ------------------------------------------------------------------------------------ + ! This subroutine calculates photosynthesis and stomatal conductance within each leaf + ! sublayer. + ! A note on naming conventions: As this subroutine is called for every + ! leaf-sublayer, many of the arguments are specific to that "leaf sub layer" + ! (LSL), those variables are given a dimension tag "_lsl" + ! Other arguments or variables may be indicative of scales broader than the LSL. + ! ------------------------------------------------------------------------------------ + + use EDPftvarcon , only : EDPftvarcon_inst + + + ! Arguments + ! ------------------------------------------------------------------------------------ + real(r8), intent(in) :: f_sun_lsl ! + real(r8), intent(in) :: parsun_lsl ! Absorbed PAR in sunlist leaves + real(r8), intent(in) :: parsha_lsl ! Absorved PAR in shaded leaves + real(r8), intent(in) :: laisun_lsl ! LAI in sunlit leaves + real(r8), intent(in) :: laisha_lsl ! LAI in shaded leaves + real(r8), intent(in) :: canopy_area_lsl ! + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) + real(r8), intent(in) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) + real(r8), intent(in) :: tpu ! triose phosphate utilization rate (umol CO2/m**2/s) + real(r8), intent(in) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(in) :: veg_esat ! saturation vapor pressure at veg_tempk (Pa) + + ! Important Note on the following gas pressures. This photosynthesis scheme will iteratively + ! solve for the co2 partial pressure at the leaf surface (ie in the stomata). The reference + ! point for these input values are NOT within that boundary layer that separates the stomata from + ! the canopy air space. The reference point for these is on the outside of that boundary + ! layer. This routine, which operates at the leaf scale, makes no assumptions about what the + ! scale of the refernce is, it could be lower atmosphere, it could be within the canopy + ! but most likely it is the closest value one can get to the edge of the leaf's boundary + ! layer. We use the convention "can_" because a reference point of within the canopy + ! ia a best reasonable scenario of where we can get that information from. + + real(r8), intent(in) :: can_press ! Air pressure NEAR the surface of the leaf (Pa) + real(r8), intent(in) :: can_co2_ppress ! Partial pressure of CO2 NEAR the leaf surface (Pa) + real(r8), intent(in) :: can_o2_ppress ! Partial pressure of O2 NEAR the leaf surface (Pa) + real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) + real(r8), intent(in) :: stomatal_intercept_btran !water-stressed minimum stomatal conductance (umol H2O/m**2/s) + real(r8), intent(in) :: cf ! s m**2/umol -> s/m (ideal gas conversion) [umol/m3] + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol /m**2/s) + real(r8), intent(in) :: ceair ! vapor pressure of air, constrained (Pa) + real(r8), intent(in) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) + real(r8), intent(in) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) + real(r8), intent(in) :: co2_cpoint ! CO2 compensation point (Pa) + real(r8), intent(in) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) + + real(r8), intent(out) :: psn_out ! carbon assimilated in this leaf layer umolC/m2/s + real(r8), intent(out) :: rstoma_out ! stomatal resistance (1/gs_lsl) (s/m) + real(r8), intent(out) :: anet_av_out ! net leaf photosynthesis (umol CO2/m**2/s) + ! averaged over sun and shade leaves. + real(r8), intent(out) :: c13disc_z ! carbon 13 in newly assimilated carbon + + ! Locals + ! ------------------------------------------------------------------------ + integer :: c3c4_path_index ! Index for which photosynthetic pathway + ! is active. C4 = 0, C3 = 1 + integer :: sunsha ! Index for differentiating sun and shade + real(r8) :: gstoma ! Stomatal Conductance of this leaf layer (m/s) + real(r8) :: agross ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: anet ! net leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: je ! electron transport rate (umol electrons/m**2/s) + real(r8) :: qabs ! PAR absorbed by PS II (umol photons/m**2/s) + real(r8) :: aquad,bquad,cquad ! terms for quadratic equations + real(r8) :: r1,r2 ! roots of quadratic equation + real(r8) :: co2_inter_c ! intercellular leaf CO2 (Pa) + real(r8) :: co2_inter_c_old ! intercellular leaf CO2 (Pa) (previous iteration) + logical :: loop_continue ! Loop control variable + integer :: niter ! iteration loop index + real(r8) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) + real(r8) :: gs ! leaf stomatal conductance (m/s) + real(r8) :: hs ! fractional humidity at leaf surface (dimensionless) + real(r8) :: gs_mol_err ! gs_mol for error check + real(r8) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + real(r8) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) + real(r8) :: ap ! product-limited (C3) or CO2-limited + ! (C4) gross photosynthesis (umol CO2/m**2/s) + real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) + real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) + real(r8) :: init_co2_inter_c ! First guess intercellular co2 specific to C path + real(r8) :: term ! intermediate variable in Medlyn stomatal conductance model + real(r8) :: vpd ! water vapor deficit in Medlyn stomatal model (KPa) + + + ! Parameters + ! ------------------------------------------------------------------------ + ! Fraction of light absorbed by non-photosynthetic pigments + real(r8),parameter :: fnps = 0.15_r8 + + ! For plants with no leaves, a miniscule amount of conductance + ! can happen through the stems, at a partial rate of cuticular conductance + real(r8),parameter :: stem_cuticle_loss_frac = 0.1_r8 + + ! empirical curvature parameter for electron transport rate + real(r8),parameter :: theta_psii = 0.7_r8 + + ! First guess on ratio between intercellular co2 and the atmosphere + ! an iterator converges on actual + real(r8),parameter :: init_a2l_co2_c3 = 0.7_r8 + real(r8),parameter :: init_a2l_co2_c4 = 0.4_r8 + + ! quantum efficiency, used only for C4 (mol CO2 / mol photons) (index 0) + real(r8),parameter,dimension(0:1) :: quant_eff = [0.05_r8,0.0_r8] + + ! empirical curvature parameter for ac, aj photosynthesis co-limitation. + ! Changed theta_cj and theta_ip to 0.999 to effectively remove smoothing logic + ! following Anthony Walker's findings from MAAT. + real(r8),parameter,dimension(0:1) :: theta_cj = [0.999_r8,0.999_r8] + + ! empirical curvature parameter for ap photosynthesis co-limitation + real(r8),parameter :: theta_ip = 0.999_r8 + + associate( bb_slope => EDPftvarcon_inst%bb_slope ,& ! slope of BB relationship, unitless + medlyn_slope=> EDPftvarcon_inst%medlyn_slope , & ! Slope for Medlyn stomatal conductance model method, the unit is KPa^0.5 + stomatal_intercept=> EDPftvarcon_inst%stomatal_intercept ) !Unstressed minimum stomatal conductance, the unit is umol/m**2/s + + ! photosynthetic pathway: 0. = c4, 1. = c3 + c3c4_path_index = nint(EDPftvarcon_inst%c3psn(ft)) + + if (c3c4_path_index == 1) then + init_co2_inter_c = init_a2l_co2_c3 * can_co2_ppress + else + init_co2_inter_c = init_a2l_co2_c4 * can_co2_ppress + end if + + ! Part III: Photosynthesis and Conductance + ! ---------------------------------------------------------------------------------- + + if ( parsun_lsl <= 0._r8 ) then ! night time + + anet_av_out = -lmr + psn_out = 0._r8 + + ! The cuticular conductance already factored in maximum resistance as a bound + ! no need to re-bound it + + rstoma_out = cf/stomatal_intercept_btran + + c13disc_z = 0.0_r8 !carbon 13 discrimination in night time carbon flux, note value of 1.0 is used in CLM + + else ! day time (a little bit more complicated ...) + + !is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) + if ( laisun_lsl + laisha_lsl > 0._r8 ) then + + !Loop aroun shaded and unshaded leaves + psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. + rstoma_out = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. + anet_av_out = 0._r8 + gstoma = 0._r8 + + do sunsha = 1,2 + ! Electron transport rate for C3 plants. + ! Convert par from W/m2 to umol photons/m**2/s using the factor 4.6 + ! Convert from units of par absorbed per unit ground area to par + ! absorbed per unit leaf area. + + if(sunsha == 1)then !sunlit + if(( laisun_lsl * canopy_area_lsl) > 0.0000000001_r8)then + + qabs = parsun_lsl / (laisun_lsl * canopy_area_lsl ) qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 + else + qabs = 0.0_r8 end if + else - !convert the absorbed par into absorbed par per m2 of leaf, - ! so it is consistant with the vcmax and lmr numbers. - aquad = theta_psii - bquad = -(qabs + jmax) - cquad = qabs * jmax - call quadratic_f (aquad, bquad, cquad, r1, r2) - je = min(r1,r2) - - ! Initialize intercellular co2 - co2_inter_c = init_co2_inter_c - - niter = 0 - loop_continue = .true. - do while(loop_continue) - ! Increment iteration counter. Stop if too many iterations - niter = niter + 1 - - ! Save old co2_inter_c - co2_inter_c_old = co2_inter_c - - ! Photosynthesis limitation rate calculations - if (c3c4_path_index == 1)then - - ! C3: Rubisco-limited photosynthesis - ac = vcmax * max(co2_inter_c-co2_cpoint, 0._r8) / & - (co2_inter_c+mm_kco2 * (1._r8+can_o2_ppress / mm_ko2 )) - - ! C3: RuBP-limited photosynthesis - aj = je * max(co2_inter_c-co2_cpoint, 0._r8) / & - (4._r8*co2_inter_c+8._r8*co2_cpoint) - - ! C3: Product-limited photosynthesis - ap = 3._r8 * tpu - - else - - ! C4: Rubisco-limited photosynthesis - ac = vcmax - - ! C4: RuBP-limited photosynthesis - if(sunsha == 1)then !sunlit - !guard against /0's in the night. - if((laisun_lsl * canopy_area_lsl) > 0.0000000001_r8) then - aj = quant_eff(c3c4_path_index) * parsun_lsl * 4.6_r8 - !convert from per cohort to per m2 of leaf) - aj = aj / (laisun_lsl * canopy_area_lsl) - else - aj = 0._r8 - end if - else - aj = quant_eff(c3c4_path_index) * parsha_lsl * 4.6_r8 - aj = aj / (laisha_lsl * canopy_area_lsl) - end if + qabs = parsha_lsl / (laisha_lsl * canopy_area_lsl) + qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 - ! C4: PEP carboxylase-limited (CO2-limited) - ap = co2_rcurve_islope * max(co2_inter_c, 0._r8) / can_press - - end if + end if - ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap - aquad = theta_cj(c3c4_path_index) - bquad = -(ac + aj) - cquad = ac * aj - call quadratic_f (aquad, bquad, cquad, r1, r2) - ai = min(r1,r2) + !convert the absorbed par into absorbed par per m2 of leaf, + ! so it is consistant with the vcmax and lmr numbers. + aquad = theta_psii + bquad = -(qabs + jmax) + cquad = qabs * jmax + call quadratic_f (aquad, bquad, cquad, r1, r2) + je = min(r1,r2) - aquad = theta_ip - bquad = -(ai + ap) - cquad = ai * ap - call quadratic_f (aquad, bquad, cquad, r1, r2) - agross = min(r1,r2) + ! Initialize intercellular co2 + co2_inter_c = init_co2_inter_c - ! Net carbon assimilation. Exit iteration if an < 0 - anet = agross - lmr - if (anet < 0._r8) then - loop_continue = .false. - end if + niter = 0 + loop_continue = .true. + do while(loop_continue) + ! Increment iteration counter. Stop if too many iterations + niter = niter + 1 - ! Quadratic gs_mol calculation with an known. Valid for an >= 0. - ! With an <= 0, then gs_mol = stomatal_intercept_btran - leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press - leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) - if ( stomatal_model == 2 ) then - !stomatal conductance calculated from Medlyn et al. (2011), the numerical & - !implementation was adapted from the equations in CLM5.0 - vpd = max((veg_esat - ceair), 50._r8) * 0.001_r8 !addapted from CLM5. Put some constraint on VPD - !when Medlyn stomatal conductance is being used, the unit is KPa. Ignoring the constraint will cause errors when model runs. - term = h2o_co2_stoma_diffuse_ratio * anet / (leaf_co2_ppress / can_press) - aquad = 1.0_r8 - bquad = -(2.0 * (stomatal_intercept_btran+ term) + (medlyn_slope(ft) * term)**2 / & - (gb_mol * vpd )) - cquad = stomatal_intercept_btran*stomatal_intercept_btran + & - (2.0*stomatal_intercept_btran + term * & - (1.0 - medlyn_slope(ft)* medlyn_slope(ft) / vpd)) * term - - call quadratic_f (aquad, bquad, cquad, r1, r2) - gs_mol = max(r1,r2) - - else if ( stomatal_model == 1 ) then !stomatal conductance calculated from Ball et al. (1987) - aquad = leaf_co2_ppress - bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * anet * can_press - cquad = -gb_mol*(leaf_co2_ppress*stomatal_intercept_btran + & - bb_slope(ft)*anet*can_press * ceair/ veg_esat ) + ! Save old co2_inter_c + co2_inter_c_old = co2_inter_c + + ! Photosynthesis limitation rate calculations + if (c3c4_path_index == 1)then + + ! C3: Rubisco-limited photosynthesis + ac = vcmax * max(co2_inter_c-co2_cpoint, 0._r8) / & + (co2_inter_c+mm_kco2 * (1._r8+can_o2_ppress / mm_ko2 )) + + ! C3: RuBP-limited photosynthesis + aj = je * max(co2_inter_c-co2_cpoint, 0._r8) / & + (4._r8*co2_inter_c+8._r8*co2_cpoint) + + ! C3: Product-limited photosynthesis + ap = 3._r8 * tpu - call quadratic_f (aquad, bquad, cquad, r1, r2) - gs_mol = max(r1,r2) - end if - ! Derive new estimate for co2_inter_c - co2_inter_c = can_co2_ppress - anet * can_press * & - (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - - ! Check for co2_inter_c convergence. Delta co2_inter_c/pair = mol/mol. - ! Multiply by 10**6 to convert to umol/mol (ppm). Exit iteration if - ! convergence criteria of +/- 1 x 10**-6 ppm is met OR if at least ten - ! iterations (niter=10) are completed - - if ((abs(co2_inter_c-co2_inter_c_old)/can_press*1.e06_r8 <= 2.e-06_r8) & - .or. niter == 5) then - loop_continue = .false. - end if - end do !iteration loop - - ! End of co2_inter_c iteration. Check for an < 0, in which case - ! gs_mol =stomatal_intercept_btran - if (anet < 0._r8) then - gs_mol = stomatal_intercept_btran - end if - - ! Final estimates for leaf_co2_ppress and co2_inter_c - ! (needed for early exit of co2_inter_c iteration when an < 0) - leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press - leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) - co2_inter_c = can_co2_ppress - anet * can_press * & - (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - - ! Convert gs_mol (umol /m**2/s) to gs (m/s) and then to rs (s/m) - gs = gs_mol / cf - - ! estimate carbon 13 discrimination in leaf level carbon - ! flux Liang WEI and Hang ZHOU 2018, based on - ! Ubierna and Farquhar, 2014 doi:10.1111/pce.12346, using the simplified model: - ! $\Delta ^{13} C = \alpha_s + (b - \alpha_s) \cdot \frac{C_i}{C_a}$ - ! just hard code b and \alpha_s for now, might move to parameter set in future - ! b = 27.0 alpha_s = 4.4 - ! TODO, not considering C4 or CAM right now, may need to address this - ! note co2_inter_c is intracelluar CO2, not intercelluar - c13disc_z = 4.4_r8 + (27.0_r8 - 4.4_r8) * & - min (can_co2_ppress, max (co2_inter_c, 0._r8)) / can_co2_ppress - - ! Accumulate total photosynthesis umol/m2 ground/s-1. - ! weight per unit sun and sha leaves. - if(sunsha == 1)then !sunlit - psn_out = psn_out + agross * f_sun_lsl - anet_av_out = anet_av_out + anet * f_sun_lsl - gstoma = gstoma + 1._r8/(min(1._r8/gs, rsmax0)) * f_sun_lsl else - psn_out = psn_out + agross * (1.0_r8-f_sun_lsl) - anet_av_out = anet_av_out + anet * (1.0_r8-f_sun_lsl) - gstoma = gstoma + & - 1._r8/(min(1._r8/gs, rsmax0)) * (1.0_r8-f_sun_lsl) - end if - - ! Make sure iterative solution is correct - if (gs_mol < 0._r8) then - write (fates_log(),*)'Negative stomatal conductance:' - write (fates_log(),*)'gs_mol= ',gs_mol - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Compare with Medlyn model: gs_mol = 1.6*(1+m/sqrt(vpd)) * an/leaf_co2_ppress*p + b - if ( stomatal_model == 2 ) then - gs_mol_err = h2o_co2_stoma_diffuse_ratio*(1 + medlyn_slope(ft)/sqrt(vpd))*max(anet,0._r8)/leaf_co2_ppress*can_press + stomatal_intercept_btran - ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress*p + b - else if ( stomatal_model == 1 ) then - hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) - gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/leaf_co2_ppress*can_press + stomatal_intercept_btran - end if - if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then - write (fates_log(),*) 'Stomatal model error check - stomatal conductance error:' - write (fates_log(),*) gs_mol, gs_mol_err - end if - - enddo !sunsha loop - - ! This is the stomatal resistance of the leaf layer - rstoma_out = 1._r8/gstoma - - else - - ! No leaf area. This layer is present only because of stems. - ! Net assimilation is zero, not negative because there are - ! no leaves to even respire - ! (leaves are off, or have reduced to 0) - - psn_out = 0._r8 - anet_av_out = 0._r8 - - rstoma_out = min(rsmax0,cf/(stem_cuticle_loss_frac*stomatal_intercept(ft))) - c13disc_z = 0.0_r8 - - end if !is there leaf area? - - - end if ! night or day - - - end associate - return - end subroutine LeafLayerPhotosynthesis - - ! ===================================================================================== - - subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv - psn_llz, & ! in %psn_z(1:currentCohort%nv,ft,cl) - lmr_llz, & ! in lmr_z(1:currentCohort%nv,ft,cl) - rs_llz, & ! in rs_z(1:currentCohort%nv,ft,cl) - elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) - c13disc_llz, & ! in c13disc_z(cl, ft, 1:currentCohort%nv) - c_area, & ! in currentCohort%c_area - nplant, & ! in currentCohort%n - rb, & ! in bc_in(s)%rb_pa(ifp) - maintresp_reduction_factor, & ! in - g_sb_laweight, & ! out currentCohort%g_sb_laweight [m/s] [m2-leaf] - gpp, & ! out currentCohort%gpp_tstep - rdark, & ! out currentCohort%rdark - c13disc_clm, & ! out currentCohort%c13disc_clm - cohort_eleaf_area ) ! out [m2] - - ! ------------------------------------------------------------------------------------ - ! This subroutine effectively integrates leaf carbon fluxes over the - ! leaf layers to give cohort totals. - ! Some arguments have the suffix "_llz". This indicates that the vector - ! is stratefied in the leaf-layer (ll) dimension, and is a portion of the calling - ! array which has the "_z" tag, thus "llz". - ! ------------------------------------------------------------------------------------ - - use FatesConstantsMod, only : umolC_to_kgC - - ! Arguments - integer, intent(in) :: nv ! number of active leaf layers - real(r8), intent(in) :: psn_llz(nv) ! layer photosynthesis rate (GPP) [umolC/m2leaf/s] - real(r8), intent(in) :: lmr_llz(nv) ! layer dark respiration rate [umolC/m2leaf/s] - real(r8), intent(in) :: rs_llz(nv) ! leaf layer stomatal resistance [s/m] - real(r8), intent(in) :: elai_llz(nv) ! exposed LAI per layer [m2 leaf/ m2 pft footprint] - real(r8), intent(in) :: c13disc_llz(nv) ! leaf layer c13 discrimination, weighted mean - real(r8), intent(in) :: c_area ! crown area m2/m2 - real(r8), intent(in) :: nplant ! indiv/m2 - real(r8), intent(in) :: rb ! leaf boundary layer resistance (s/m) - real(r8), intent(in) :: maintresp_reduction_factor ! factor by which to reduce maintenance respiration - real(r8), intent(out) :: g_sb_laweight ! Combined conductance (stomatal + boundary layer) for the cohort - ! weighted by leaf area [m/s]*[m2] - real(r8), intent(out) :: gpp ! GPP (kgC/indiv/s) - real(r8), intent(out) :: rdark ! Dark Leaf Respiration (kgC/indiv/s) - real(r8), intent(out) :: cohort_eleaf_area ! Effective leaf area of the cohort [m2] - real(r8), intent(out) :: c13disc_clm ! unpacked Cohort level c13 discrimination - real(r8) :: sum_weight ! sum of weight for unpacking d13c flux (c13disc_z) from - ! (canopy_layer, pft, leaf_layer) matrix to cohort (c13disc_clm) - - ! GPP IN THIS SUBROUTINE IS A RATE. THE CALLING ARGUMENT IS GPP_TSTEP. AFTER THIS - ! CALL THE RATE WILL BE MULTIPLIED BY THE INTERVAL TO GIVE THE INTEGRATED QUANT. - - ! Locals - integer :: il ! leaf layer index - real(r8) :: cohort_layer_eleaf_area ! the effective leaf area of the cohort's current layer [m2] - - cohort_eleaf_area = 0.0_r8 - g_sb_laweight = 0.0_r8 - gpp = 0.0_r8 - rdark = 0.0_r8 - - do il = 1, nv ! Loop over the leaf layers this cohort participates in - - - ! Cohort's total effective leaf area in this layer [m2] - ! leaf area index of the layer [m2/m2 ground] * [m2 ground] - ! elai_llz is the LAI for the whole PFT. Multiplying this by the ground - ! area this cohort contributes, give the cohort's portion of the leaf - ! area in this layer - cohort_layer_eleaf_area = elai_llz(il) * c_area - - ! Increment the cohort's total effective leaf area [m2] - cohort_eleaf_area = cohort_eleaf_area + cohort_layer_eleaf_area - - ! Leaf conductance (stomatal and boundary layer) - ! This should be the weighted average over the leaf surfaces. - ! Since this is relevant to the stomata, its weighting should be based - ! on total leaf area, and not really footprint area - ! [m/s] * [m2 cohort's leaf layer] - g_sb_laweight = g_sb_laweight + 1.0_r8/(rs_llz(il)+rb) * cohort_layer_eleaf_area - - ! GPP [umolC/m2leaf/s] * [m2 leaf ] -> [umolC/s] (This is cohort group sum) - gpp = gpp + psn_llz(il) * cohort_layer_eleaf_area - - ! Dark respiration - ! [umolC/m2leaf/s] * [m2 leaf] (This is the cohort group sum) - rdark = rdark + lmr_llz(il) * cohort_layer_eleaf_area - - end do - - - - if (nv > 1) then - ! cohort%c13disc_clm as weighted mean of d13c flux at all related leave layers - sum_weight = sum(psn_llz(1:nv-1) * elai_llz(1:nv-1)) - if (sum_weight .eq. 0.0_r8) then - c13disc_clm = 0.0 - else - c13disc_clm = sum(c13disc_llz(1:nv-1) * psn_llz(1:nv-1) * elai_llz(1:nv-1)) / sum_weight - end if - - end if + ! C4: Rubisco-limited photosynthesis + ac = vcmax + ! C4: RuBP-limited photosynthesis + if(sunsha == 1)then !sunlit + !guard against /0's in the night. + if((laisun_lsl * canopy_area_lsl) > 0.0000000001_r8) then + aj = quant_eff(c3c4_path_index) * parsun_lsl * 4.6_r8 + !convert from per cohort to per m2 of leaf) + aj = aj / (laisun_lsl * canopy_area_lsl) + else + aj = 0._r8 + end if + else + aj = quant_eff(c3c4_path_index) * parsha_lsl * 4.6_r8 + aj = aj / (laisha_lsl * canopy_area_lsl) + end if - ! ----------------------------------------------------------------------------------- - ! We DO NOT normalize g_sb_laweight. - ! The units that we are passing back are [m/s] * [m2 effective leaf] - ! We will add these up over the whole patch, and then normalized - ! by the patch's total leaf area in the calling routine - ! ----------------------------------------------------------------------------------- + ! C4: PEP carboxylase-limited (CO2-limited) + ap = co2_rcurve_islope * max(co2_inter_c, 0._r8) / can_press - ! ----------------------------------------------------------------------------------- - ! Convert dark respiration and GPP from [umol/s] to [kgC/plant/s] - ! Also, apply the maintenance respiration reduction factor - ! ----------------------------------------------------------------------------------- - - rdark = rdark * umolC_to_kgC * maintresp_reduction_factor / nplant - gpp = gpp * umolC_to_kgC / nplant - - if ( debug ) then - write(fates_log(),*) 'EDPhoto 816 ', gpp - write(fates_log(),*) 'EDPhoto 817 ', psn_llz(1:nv) - write(fates_log(),*) 'EDPhoto 820 ', nv - write(fates_log(),*) 'EDPhoto 821 ', elai_llz(1:nv) - write(fates_log(),*) 'EDPhoto 843 ', rdark - write(fates_log(),*) 'EDPhoto 873 ', nv - write(fates_log(),*) 'EDPhoto 874 ', cohort_eleaf_area - endif - - return - end subroutine ScaleLeafLayerFluxToCohort - - ! ===================================================================================== - - function ft1_f(tl, ha) result(ans) - ! - !!DESCRIPTION: - ! photosynthesis temperature response - ! - ! !REVISION HISTORY - ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - !!USES - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - ! - ! !ARGUMENTS: - real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) - real(r8), intent(in) :: ha ! activation energy in photosynthesis temperature function (J/mol) - ! - ! !LOCAL VARIABLES: - real(r8) :: ans - !------------------------------------------------------------------------------- + end if - ans = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) + ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap + aquad = theta_cj(c3c4_path_index) + bquad = -(ac + aj) + cquad = ac * aj + call quadratic_f (aquad, bquad, cquad, r1, r2) + ai = min(r1,r2) - return - end function ft1_f + aquad = theta_ip + bquad = -(ai + ap) + cquad = ai * ap + call quadratic_f (aquad, bquad, cquad, r1, r2) + agross = min(r1,r2) - ! ===================================================================================== - - function fth_f(tl,hd,se,scaleFactor) result(ans) - ! - !!DESCRIPTION: - !photosynthesis temperature inhibition - ! - ! !REVISION HISTORY - ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + ! Net carbon assimilation. Exit iteration if an < 0 + anet = agross - lmr + if (anet < 0._r8) then + loop_continue = .false. + end if - ! - ! !ARGUMENTS: - real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temp function (K) - real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) - real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) - real(r8), intent(in) :: scaleFactor ! scaling factor for high temp inhibition (25 C = 1.0) - ! - ! !LOCAL VARIABLES: - real(r8) :: ans - !------------------------------------------------------------------------------- + ! Quadratic gs_mol calculation with an known. Valid for an >= 0. + ! With an <= 0, then gs_mol = stomatal_intercept_btran + leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + if ( stomatal_model == 2 ) then + !stomatal conductance calculated from Medlyn et al. (2011), the numerical & + !implementation was adapted from the equations in CLM5.0 + vpd = max((veg_esat - ceair), 50._r8) * 0.001_r8 !addapted from CLM5. Put some constraint on VPD + !when Medlyn stomatal conductance is being used, the unit is KPa. Ignoring the constraint will cause errors when model runs. + term = h2o_co2_stoma_diffuse_ratio * anet / (leaf_co2_ppress / can_press) + aquad = 1.0_r8 + bquad = -(2.0 * (stomatal_intercept_btran+ term) + (medlyn_slope(ft) * term)**2 / & + (gb_mol * vpd )) + cquad = stomatal_intercept_btran*stomatal_intercept_btran + & + (2.0*stomatal_intercept_btran + term * & + (1.0 - medlyn_slope(ft)* medlyn_slope(ft) / vpd)) * term - ans = scaleFactor / ( 1._r8 + exp( (-hd+se*tl) / (rgas*1.e-3_r8*tl) ) ) + call quadratic_f (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) - return - end function fth_f + else if ( stomatal_model == 1 ) then !stomatal conductance calculated from Ball et al. (1987) + aquad = leaf_co2_ppress + bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * anet * can_press + cquad = -gb_mol*(leaf_co2_ppress*stomatal_intercept_btran + & + bb_slope(ft)*anet*can_press * ceair/ veg_esat ) - ! ===================================================================================== + call quadratic_f (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) + end if + ! Derive new estimate for co2_inter_c + co2_inter_c = can_co2_ppress - anet * can_press * & + (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - function fth25_f(hd,se)result(ans) - ! - !!DESCRIPTION: - ! scaling factor for photosynthesis temperature inhibition - ! - ! !REVISION HISTORY: - ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - !!USES + ! Check for co2_inter_c convergence. Delta co2_inter_c/pair = mol/mol. + ! Multiply by 10**6 to convert to umol/mol (ppm). Exit iteration if + ! convergence criteria of +/- 1 x 10**-6 ppm is met OR if at least ten + ! iterations (niter=10) are completed + + if ((abs(co2_inter_c-co2_inter_c_old)/can_press*1.e06_r8 <= 2.e-06_r8) & + .or. niter == 5) then + loop_continue = .false. + end if + end do !iteration loop + + ! End of co2_inter_c iteration. Check for an < 0, in which case + ! gs_mol =stomatal_intercept_btran + if (anet < 0._r8) then + gs_mol = stomatal_intercept_btran + end if + + ! Final estimates for leaf_co2_ppress and co2_inter_c + ! (needed for early exit of co2_inter_c iteration when an < 0) + leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + co2_inter_c = can_co2_ppress - anet * can_press * & + (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) + + ! Convert gs_mol (umol /m**2/s) to gs (m/s) and then to rs (s/m) + gs = gs_mol / cf + + ! estimate carbon 13 discrimination in leaf level carbon + ! flux Liang WEI and Hang ZHOU 2018, based on + ! Ubierna and Farquhar, 2014 doi:10.1111/pce.12346, using the simplified model: + ! $\Delta ^{13} C = \alpha_s + (b - \alpha_s) \cdot \frac{C_i}{C_a}$ + ! just hard code b and \alpha_s for now, might move to parameter set in future + ! b = 27.0 alpha_s = 4.4 + ! TODO, not considering C4 or CAM right now, may need to address this + ! note co2_inter_c is intracelluar CO2, not intercelluar + c13disc_z = 4.4_r8 + (27.0_r8 - 4.4_r8) * & + min (can_co2_ppress, max (co2_inter_c, 0._r8)) / can_co2_ppress + + ! Accumulate total photosynthesis umol/m2 ground/s-1. + ! weight per unit sun and sha leaves. + if(sunsha == 1)then !sunlit + psn_out = psn_out + agross * f_sun_lsl + anet_av_out = anet_av_out + anet * f_sun_lsl + gstoma = gstoma + 1._r8/(min(1._r8/gs, rsmax0)) * f_sun_lsl + else + psn_out = psn_out + agross * (1.0_r8-f_sun_lsl) + anet_av_out = anet_av_out + anet * (1.0_r8-f_sun_lsl) + gstoma = gstoma + & + 1._r8/(min(1._r8/gs, rsmax0)) * (1.0_r8-f_sun_lsl) + end if + + ! Make sure iterative solution is correct + if (gs_mol < 0._r8) then + write (fates_log(),*)'Negative stomatal conductance:' + write (fates_log(),*)'gs_mol= ',gs_mol + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Compare with Medlyn model: gs_mol = 1.6*(1+m/sqrt(vpd)) * an/leaf_co2_ppress*p + b + if ( stomatal_model == 2 ) then + gs_mol_err = h2o_co2_stoma_diffuse_ratio*(1 + medlyn_slope(ft)/sqrt(vpd))*max(anet,0._r8)/leaf_co2_ppress*can_press + stomatal_intercept_btran + ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress*p + b + else if ( stomatal_model == 1 ) then + hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) + gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/leaf_co2_ppress*can_press + stomatal_intercept_btran + end if + + if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then + write (fates_log(),*) 'Stomatal model error check - stomatal conductance error:' + write (fates_log(),*) gs_mol, gs_mol_err + end if + + enddo !sunsha loop + + ! This is the stomatal resistance of the leaf layer + rstoma_out = 1._r8/gstoma - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - - ! - ! !ARGUMENTS: - real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) - real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) - ! - ! !LOCAL VARIABLES: - real(r8) :: ans - !------------------------------------------------------------------------------- - - ans = 1._r8 + exp( (-hd+se*(tfrz+25._r8)) / (rgas*1.e-3_r8*(tfrz+25._r8)) ) - - return - end function fth25_f - - ! ===================================================================================== - - subroutine quadratic_f (a, b, c, r1, r2) - ! - ! !DESCRIPTION: - !==============================================================================! - !----------------- Solve quadratic equation for its two roots -----------------! - !==============================================================================! - ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific - ! Computing (Cambridge University Press, Cambridge), pp. 145. - ! - ! !REVISION HISTORY: - ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - ! !USES: - ! - ! !ARGUMENTS: - real(r8), intent(in) :: a,b,c ! Terms for quadratic equation - real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation - ! - ! !LOCAL VARIABLES: - real(r8) :: q ! Temporary term for quadratic solution - !------------------------------------------------------------------------------ - - if (a == 0._r8) then - write (fates_log(),*) 'Quadratic solution error: a = ',a - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if (b >= 0._r8) then - q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) - else - q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) - end if - - r1 = q / a - if (q /= 0._r8) then - r2 = c / q - else - r2 = 1.e36_r8 - end if - - end subroutine quadratic_f - - ! ==================================================================================== - - subroutine quadratic_fast (a, b, c, r1, r2) - ! - ! !DESCRIPTION: - !==============================================================================! - !----------------- Solve quadratic equation for its two roots -----------------! - ! THIS METHOD SIMPLY REMOVES THE DIV0 CHECK AND ERROR REPORTING ! - !==============================================================================! - ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific - ! Computing (Cambridge University Press, Cambridge), pp. 145. - ! - ! !REVISION HISTORY: - ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - ! !USES: - ! - ! !ARGUMENTS: - real(r8), intent(in) :: a,b,c ! Terms for quadratic equation - real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation - ! - ! !LOCAL VARIABLES: - real(r8) :: q ! Temporary term for quadratic solution - !------------------------------------------------------------------------------ - - ! if (a == 0._r8) then - ! write (fates_log(),*) 'Quadratic solution error: a = ',a - ! call endrun(msg=errMsg(sourcefile, __LINE__)) - ! end if - - if (b >= 0._r8) then - q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) else - q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) - end if - - r1 = q / a - ! if (q /= 0._r8) then - r2 = c / q - ! else - ! r2 = 1.e36_r8 - ! end if - - end subroutine quadratic_fast - - - ! ==================================================================================== - - subroutine UpdateCanopyNCanNRadPresent(currentPatch) - - ! --------------------------------------------------------------------------------- - ! This subroutine calculates two patch level quanities: - ! currentPatch%ncan and - ! currentPatch%canopy_mask - ! - ! currentPatch%ncan(:,:) is a two dimensional array that indicates - ! the total number of leaf layers (including those that are not exposed to light) - ! in each canopy layer and for each functional type. - ! - ! currentPatch%nrad(:,:) is a two dimensional array that indicates - ! the total number of EXPOSED leaf layers, but for all intents and purposes - ! in the photosynthesis routine, this appears to be the same as %ncan... - ! - ! currentPatch%canopy_mask(:,:) has the same dimensions, is binary, and - ! indicates whether or not leaf layers are present (by evaluating the canopy area - ! profile). - ! --------------------------------------------------------------------------------- - - - use EDTypesMod , only : ed_patch_type - use EDTypesMod , only : ed_cohort_type - - ! Arguments - type(ed_patch_type), target :: currentPatch - type(ed_cohort_type), pointer :: currentCohort - - ! Locals - integer :: cl ! Canopy Layer Index - integer :: ft ! Function Type Index - integer :: iv ! index of the exposed leaf layer for each canopy layer and pft - - ! Loop through the cohorts in this patch, associate each cohort with a layer and PFT - ! and use the cohort's memory of how many layer's it takes up to assign the maximum - ! of the layer/pft index it is in - ! --------------------------------------------------------------------------------- - - currentPatch%ncan(:,:) = 0 - ! redo the canopy structure algorithm to get round a - ! bug that is happening for site 125, FT13. - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) - - currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft) = & - max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft), & - currentCohort%NV) - - currentCohort => currentCohort%shorter - - enddo !cohort - - ! NRAD = NCAN ... - currentPatch%nrad = currentPatch%ncan - - ! Now loop through and identify which layer and pft combo has scattering elements - do cl = 1,nclmax - do ft = 1,numpft - currentPatch%canopy_mask(cl,ft) = 0 - do iv = 1, currentPatch%nrad(cl,ft); - if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then - currentPatch%canopy_mask(cl,ft) = 1 - end if - end do !iv - enddo !ft - enddo !cl - - return - end subroutine UpdateCanopyNCanNRadPresent - - ! ==================================================================================== - - subroutine GetCanopyGasParameters(can_press, & - can_o2_partialpress, & - veg_tempk, & - air_tempk, & - air_vpress, & - veg_esat, & - rb, & - mm_kco2, & - mm_ko2, & - co2_cpoint, & - cf, & - gb_mol, & - ceair) - - ! --------------------------------------------------------------------------------- - ! This subroutine calculates the specific Michaelis Menten Parameters (pa) for CO2 - ! and O2, as well as the CO2 compentation point. - ! --------------------------------------------------------------------------------- - - use FatesConstantsMod, only: umol_per_mol - use FatesConstantsMod, only: mmol_per_mol - use FatesConstantsMod, only: umol_per_kmol - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - - ! Arguments - real(r8), intent(in) :: can_press ! Air pressure within the canopy (Pa) - real(r8), intent(in) :: can_o2_partialpress ! Partial press of o2 in the canopy (Pa) - real(r8), intent(in) :: veg_tempk ! The temperature of the vegetation (K) - real(r8), intent(in) :: air_tempk ! Temperature of canopy air (K) - real(r8), intent(in) :: air_vpress ! Vapor pressure of canopy air (Pa) - real(r8), intent(in) :: veg_esat ! Saturated vapor pressure at veg surf (Pa) - real(r8), intent(in) :: rb ! Leaf Boundary layer resistance (s/m) - - real(r8), intent(out) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) - real(r8), intent(out) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) - real(r8), intent(out) :: co2_cpoint ! CO2 compensation point (Pa) - real(r8), intent(out) :: cf ! conversion factor between molar form and velocity form - ! of conductance and resistance: [umol/m3] - real(r8), intent(out) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) - real(r8), intent(out) :: ceair ! vapor pressure of air, constrained (Pa) - - ! Locals - real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) - real(r8) :: ko25 ! Michaelis-Menten constant for O2 at 25C (Pa) - real(r8) :: sco ! relative specificity of rubisco - real(r8) :: cp25 ! CO2 compensation point at 25C (Pa) - - ! --------------------------------------------------------------------------------- - ! Intensive values (per mol of air) - ! kc, ko, currentPatch, from: Bernacchi et al (2001) - ! Plant, Cell and Environment 24:253-259 - ! --------------------------------------------------------------------------------- - - real(r8), parameter :: mm_kc25_umol_per_mol = 404.9_r8 - real(r8), parameter :: mm_ko25_mmol_per_mol = 278.4_r8 - real(r8), parameter :: co2_cpoint_umol_per_mol = 42.75_r8 - - ! Activation energy, from: - ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 - ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 - ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 - - real(r8), parameter :: kcha = 79430._r8 ! activation energy for kc (J/mol) - real(r8), parameter :: koha = 36380._r8 ! activation energy for ko (J/mol) - real(r8), parameter :: cpha = 37830._r8 ! activation energy for cp (J/mol) - - - ! Derive sco from currentPatch and O2 using present-day O2 (0.209 mol/mol) and re-calculate - ! currentPatch to account for variation in O2 using currentPatch = 0.5 O2 / sco - - ! FIXME (RGK 11-30-2016 THere are more constants here, but I don't have enough information - ! about what they are or do, so I can't give them more descriptive names. Someone please - ! fill this in when possible) - - kc25 = ( mm_kc25_umol_per_mol / umol_per_mol ) * can_press - ko25 = ( mm_ko25_mmol_per_mol / mmol_per_mol ) * can_press - sco = 0.5_r8 * 0.209_r8 / (co2_cpoint_umol_per_mol / umol_per_mol ) - cp25 = 0.5_r8 * can_o2_partialpress / sco - - if( veg_tempk.gt.150_r8 .and. veg_tempk.lt.350_r8 )then - mm_kco2 = kc25 * ft1_f(veg_tempk, kcha) - mm_ko2 = ko25 * ft1_f(veg_tempk, koha) - co2_cpoint = cp25 * ft1_f(veg_tempk, cpha) - else - mm_kco2 = 1.0_r8 - mm_ko2 = 1.0_r8 - co2_cpoint = 1.0_r8 - end if - - ! --------------------------------------------------------------------------------- - ! - ! cf is the conversion factor between molar form and velocity form - ! of conductance and resistance: [umol/m3] - ! - ! i.e. - ! [m/s] * [umol/m3] -> [umol/m2/s] - ! - ! Breakdown of the conversion factor: [ umol / m3 ] - ! - ! Rgas [J /K /kmol] - ! Air Potential Temperature [ K ] - ! Canopy Pressure [ Pa ] - ! conversion: umol/kmol = 1e9 - ! - ! [ Pa * K * kmol umol/kmol / J K ] = [ Pa * umol / J ] - ! since: 1 Pa = 1 N / m2 - ! [ Pa * umol / J ] = [ N * umol / J m2 ] - ! since: 1 J = 1 N * m - ! [ N * umol / J m2 ] = [ N * umol / N m3 ] - ! [ umol / m3 ] - ! - ! -------------------------------------------------------------------------------- - - cf = can_press/(rgas * air_tempk )*umol_per_kmol - gb_mol = (1._r8/ rb) * cf - - ! Constrain eair >= 0.05*esat_tv so that solution does not blow up. This ensures - ! that hs does not go to zero. Also eair <= veg_esat so that hs <= 1 - ceair = min( max(air_vpress, 0.05_r8*veg_esat ),veg_esat ) - - - - return - end subroutine GetCanopyGasParameters - - ! ==================================================================================== - - subroutine LeafLayerMaintenanceRespiration(lmr25top_ft, & - nscaler, & - ft, & - veg_tempk, & - lmr) - - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - use EDPftvarcon , only : EDPftvarcon_inst - - ! Arguments - real(r8), intent(in) :: lmr25top_ft ! canopy top leaf maint resp rate at 25C - ! for this pft (umol CO2/m**2/s) - integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile - real(r8), intent(in) :: veg_tempk ! vegetation temperature - real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) - - ! Locals - real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) - - ! Parameter - real(r8), parameter :: lmrha = 46390._r8 ! activation energy for lmr (J/mol) - real(r8), parameter :: lmrhd = 150650._r8 ! deactivation energy for lmr (J/mol) - real(r8), parameter :: lmrse = 490._r8 ! entropy term for lmr (J/mol/K) - real(r8), parameter :: lmrc = 1.15912391_r8 ! scaling factor for high - ! temperature inhibition (25 C = 1.0) - - - - - - ! Part I: Leaf Maintenance respiration: umol CO2 / m**2 [leaf] / s - ! ---------------------------------------------------------------------------------- - lmr25 = lmr25top_ft * nscaler - - if ( nint(EDpftvarcon_inst%c3psn(ft)) == 1)then - lmr = lmr25 * ft1_f(veg_tempk, lmrha) * & - fth_f(veg_tempk, lmrhd, lmrse, lmrc) - else - lmr = lmr25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) - lmr = lmr / (1._r8 + exp( 1.3_r8*(veg_tempk-(tfrz+55._r8)) )) - end if - - ! Any hydrodynamic limitations could go here, currently none - ! lmr = lmr * (nothing) - - end subroutine LeafLayerMaintenanceRespiration - - ! ==================================================================================== - - subroutine LeafLayerBiophysicalRates( parsun_lsl, & - ft, & - vcmax25top_ft, & - jmax25top_ft, & - tpu25top_ft, & - co2_rcurve_islope25top_ft, & - nscaler, & - veg_tempk, & - btran, & - vcmax, & - jmax, & - tpu, & - co2_rcurve_islope ) - - ! --------------------------------------------------------------------------------- - ! This subroutine calculates the localized rates of several key photosynthesis - ! rates. By localized, we mean specific to the plant type and leaf layer, - ! which factors in leaf physiology, as well as environmental effects. - ! This procedure should be called prior to iterative solvers, and should - ! have pre-calculated the reference rates for the pfts before this. - ! - ! The output biophysical rates are: - ! vcmax: maximum rate of carboxilation, - ! jmax: maximum electron transport rate, - ! tpu: triose phosphate utilization rate and - ! co2_rcurve_islope: initial slope of CO2 response curve (C4 plants) - ! --------------------------------------------------------------------------------- - - use EDPftvarcon , only : EDPftvarcon_inst - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - - ! Arguments - ! ------------------------------------------------------------------------------ - - real(r8), intent(in) :: parsun_lsl ! PAR absorbed in sunlit leaves for this layer - integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile - real(r8), intent(in) :: vcmax25top_ft ! canopy top maximum rate of carboxylation at 25C - ! for this pft (umol CO2/m**2/s) - real(r8), intent(in) :: jmax25top_ft ! canopy top maximum electron transport rate at 25C - ! for this pft (umol electrons/m**2/s) - real(r8), intent(in) :: tpu25top_ft ! canopy top triose phosphate utilization rate at 25C - ! for this pft (umol CO2/m**2/s) - real(r8), intent(in) :: co2_rcurve_islope25top_ft ! initial slope of CO2 response curve - ! (C4 plants) at 25C, canopy top, this pft - real(r8), intent(in) :: veg_tempk ! vegetation temperature - real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) - - real(r8), intent(out) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8), intent(out) :: jmax ! maximum electron transport rate - ! (umol electrons/m**2/s) - real(r8), intent(out) :: tpu ! triose phosphate utilization rate - ! (umol CO2/m**2/s) - real(r8), intent(out) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) - - ! Locals - ! ------------------------------------------------------------------------------- - real(r8) :: vcmax25 ! leaf layer: maximum rate of carboxylation at 25C - ! (umol CO2/m**2/s) - real(r8) :: jmax25 ! leaf layer: maximum electron transport rate at 25C - ! (umol electrons/m**2/s) - real(r8) :: tpu25 ! leaf layer: triose phosphate utilization rate at 25C - ! (umol CO2/m**2/s) - real(r8) :: co2_rcurve_islope25 ! leaf layer: Initial slope of CO2 response curve - ! (C4 plants) at 25C - - - ! Parameters - ! --------------------------------------------------------------------------------- - real(r8) :: vcmaxha ! activation energy for vcmax (J/mol) - real(r8) :: jmaxha ! activation energy for jmax (J/mol) - real(r8) :: tpuha ! activation energy for tpu (J/mol) - real(r8) :: vcmaxhd ! deactivation energy for vcmax (J/mol) - real(r8) :: jmaxhd ! deactivation energy for jmax (J/mol) - real(r8) :: tpuhd ! deactivation energy for tpu (J/mol) - real(r8) :: vcmaxse ! entropy term for vcmax (J/mol/K) - real(r8) :: jmaxse ! entropy term for jmax (J/mol/K) - real(r8) :: tpuse ! entropy term for tpu (J/mol/K) - real(r8) :: vcmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) - real(r8) :: jmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) - real(r8) :: tpuc ! scaling factor for high temperature inhibition (25 C = 1.0) - - vcmaxha = EDPftvarcon_inst%vcmaxha(FT) - jmaxha = EDPftvarcon_inst%jmaxha(FT) - tpuha = EDPftvarcon_inst%tpuha(FT) - - vcmaxhd = EDPftvarcon_inst%vcmaxhd(FT) - jmaxhd = EDPftvarcon_inst%jmaxhd(FT) - tpuhd = EDPftvarcon_inst%tpuhd(FT) - - vcmaxse = EDPftvarcon_inst%vcmaxse(FT) - jmaxse = EDPftvarcon_inst%jmaxse(FT) - tpuse = EDPftvarcon_inst%tpuse(FT) - - vcmaxc = fth25_f(vcmaxhd, vcmaxse) - jmaxc = fth25_f(jmaxhd, jmaxse) - tpuc = fth25_f(tpuhd, tpuse) - - if ( parsun_lsl <= 0._r8) then ! night time - vcmax = 0._r8 - jmax = 0._r8 - tpu = 0._r8 - co2_rcurve_islope = 0._r8 - else ! day time - - ! Vcmax25top was already calculated to derive the nscaler function - vcmax25 = vcmax25top_ft * nscaler - jmax25 = jmax25top_ft * nscaler - tpu25 = tpu25top_ft * nscaler - co2_rcurve_islope25 = co2_rcurve_islope25top_ft * nscaler - - ! Adjust for temperature - vcmax = vcmax25 * ft1_f(veg_tempk, vcmaxha) * fth_f(veg_tempk, vcmaxhd, vcmaxse, vcmaxc) - jmax = jmax25 * ft1_f(veg_tempk, jmaxha) * fth_f(veg_tempk, jmaxhd, jmaxse, jmaxc) - tpu = tpu25 * ft1_f(veg_tempk, tpuha) * fth_f(veg_tempk, tpuhd, tpuse, tpuc) - - if (nint(EDPftvarcon_inst%c3psn(ft)) /= 1) then - vcmax = vcmax25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) - vcmax = vcmax / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-veg_tempk ) )) - vcmax = vcmax / (1._r8 + exp( 0.3_r8*(veg_tempk-(tfrz+40._r8)) )) + + ! No leaf area. This layer is present only because of stems. + ! Net assimilation is zero, not negative because there are + ! no leaves to even respire + ! (leaves are off, or have reduced to 0) + + psn_out = 0._r8 + anet_av_out = 0._r8 + + rstoma_out = min(rsmax0,cf/(stem_cuticle_loss_frac*stomatal_intercept(ft))) + c13disc_z = 0.0_r8 + + end if !is there leaf area? + + + end if ! night or day + + +end associate +return +end subroutine LeafLayerPhotosynthesis + +! ===================================================================================== + +subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv + psn_llz, & ! in %psn_z(1:currentCohort%nv,ft,cl) + lmr_llz, & ! in lmr_z(1:currentCohort%nv,ft,cl) + rs_llz, & ! in rs_z(1:currentCohort%nv,ft,cl) + elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) + c13disc_llz, & ! in c13disc_z(cl, ft, 1:currentCohort%nv) + c_area, & ! in currentCohort%c_area + nplant, & ! in currentCohort%n + rb, & ! in bc_in(s)%rb_pa(ifp) + maintresp_reduction_factor, & ! in + g_sb_laweight, & ! out currentCohort%g_sb_laweight [m/s] [m2-leaf] + gpp, & ! out currentCohort%gpp_tstep + rdark, & ! out currentCohort%rdark + c13disc_clm, & ! out currentCohort%c13disc_clm + cohort_eleaf_area ) ! out [m2] + + ! ------------------------------------------------------------------------------------ + ! This subroutine effectively integrates leaf carbon fluxes over the + ! leaf layers to give cohort totals. + ! Some arguments have the suffix "_llz". This indicates that the vector + ! is stratefied in the leaf-layer (ll) dimension, and is a portion of the calling + ! array which has the "_z" tag, thus "llz". + ! ------------------------------------------------------------------------------------ + +use FatesConstantsMod, only : umolC_to_kgC + +! Arguments +integer, intent(in) :: nv ! number of active leaf layers +real(r8), intent(in) :: psn_llz(nv) ! layer photosynthesis rate (GPP) [umolC/m2leaf/s] +real(r8), intent(in) :: lmr_llz(nv) ! layer dark respiration rate [umolC/m2leaf/s] +real(r8), intent(in) :: rs_llz(nv) ! leaf layer stomatal resistance [s/m] +real(r8), intent(in) :: elai_llz(nv) ! exposed LAI per layer [m2 leaf/ m2 pft footprint] +real(r8), intent(in) :: c13disc_llz(nv) ! leaf layer c13 discrimination, weighted mean +real(r8), intent(in) :: c_area ! crown area m2/m2 +real(r8), intent(in) :: nplant ! indiv/m2 +real(r8), intent(in) :: rb ! leaf boundary layer resistance (s/m) +real(r8), intent(in) :: maintresp_reduction_factor ! factor by which to reduce maintenance respiration +real(r8), intent(out) :: g_sb_laweight ! Combined conductance (stomatal + boundary layer) for the cohort +! weighted by leaf area [m/s]*[m2] +real(r8), intent(out) :: gpp ! GPP (kgC/indiv/s) +real(r8), intent(out) :: rdark ! Dark Leaf Respiration (kgC/indiv/s) +real(r8), intent(out) :: cohort_eleaf_area ! Effective leaf area of the cohort [m2] +real(r8), intent(out) :: c13disc_clm ! unpacked Cohort level c13 discrimination +real(r8) :: sum_weight ! sum of weight for unpacking d13c flux (c13disc_z) from +! (canopy_layer, pft, leaf_layer) matrix to cohort (c13disc_clm) + +! GPP IN THIS SUBROUTINE IS A RATE. THE CALLING ARGUMENT IS GPP_TSTEP. AFTER THIS +! CALL THE RATE WILL BE MULTIPLIED BY THE INTERVAL TO GIVE THE INTEGRATED QUANT. + +! Locals +integer :: il ! leaf layer index +real(r8) :: cohort_layer_eleaf_area ! the effective leaf area of the cohort's current layer [m2] + +cohort_eleaf_area = 0.0_r8 +g_sb_laweight = 0.0_r8 +gpp = 0.0_r8 +rdark = 0.0_r8 + +do il = 1, nv ! Loop over the leaf layers this cohort participates in + + + ! Cohort's total effective leaf area in this layer [m2] + ! leaf area index of the layer [m2/m2 ground] * [m2 ground] + ! elai_llz is the LAI for the whole PFT. Multiplying this by the ground + ! area this cohort contributes, give the cohort's portion of the leaf + ! area in this layer + cohort_layer_eleaf_area = elai_llz(il) * c_area + + ! Increment the cohort's total effective leaf area [m2] + cohort_eleaf_area = cohort_eleaf_area + cohort_layer_eleaf_area + + ! Leaf conductance (stomatal and boundary layer) + ! This should be the weighted average over the leaf surfaces. + ! Since this is relevant to the stomata, its weighting should be based + ! on total leaf area, and not really footprint area + ! [m/s] * [m2 cohort's leaf layer] + g_sb_laweight = g_sb_laweight + 1.0_r8/(rs_llz(il)+rb) * cohort_layer_eleaf_area + + ! GPP [umolC/m2leaf/s] * [m2 leaf ] -> [umolC/s] (This is cohort group sum) + gpp = gpp + psn_llz(il) * cohort_layer_eleaf_area + + ! Dark respiration + ! [umolC/m2leaf/s] * [m2 leaf] (This is the cohort group sum) + rdark = rdark + lmr_llz(il) * cohort_layer_eleaf_area + +end do + + + +if (nv > 1) then + ! cohort%c13disc_clm as weighted mean of d13c flux at all related leave layers + sum_weight = sum(psn_llz(1:nv-1) * elai_llz(1:nv-1)) + if (sum_weight .eq. 0.0_r8) then + c13disc_clm = 0.0 + else + c13disc_clm = sum(c13disc_llz(1:nv-1) * psn_llz(1:nv-1) * elai_llz(1:nv-1)) / sum_weight + end if + +end if + + +! ----------------------------------------------------------------------------------- +! We DO NOT normalize g_sb_laweight. +! The units that we are passing back are [m/s] * [m2 effective leaf] +! We will add these up over the whole patch, and then normalized +! by the patch's total leaf area in the calling routine +! ----------------------------------------------------------------------------------- + +! ----------------------------------------------------------------------------------- +! Convert dark respiration and GPP from [umol/s] to [kgC/plant/s] +! Also, apply the maintenance respiration reduction factor +! ----------------------------------------------------------------------------------- + +rdark = rdark * umolC_to_kgC * maintresp_reduction_factor / nplant +gpp = gpp * umolC_to_kgC / nplant + +if ( debug ) then + write(fates_log(),*) 'EDPhoto 816 ', gpp + write(fates_log(),*) 'EDPhoto 817 ', psn_llz(1:nv) + write(fates_log(),*) 'EDPhoto 820 ', nv + write(fates_log(),*) 'EDPhoto 821 ', elai_llz(1:nv) + write(fates_log(),*) 'EDPhoto 843 ', rdark + write(fates_log(),*) 'EDPhoto 873 ', nv + write(fates_log(),*) 'EDPhoto 874 ', cohort_eleaf_area +endif + +return +end subroutine ScaleLeafLayerFluxToCohort + +! ===================================================================================== + +function ft1_f(tl, ha) result(ans) + ! + !!DESCRIPTION: + ! photosynthesis temperature response + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + !!USES +use FatesConstantsMod, only : rgas => rgas_J_K_kmol +use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm +! +! !ARGUMENTS: +real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) +real(r8), intent(in) :: ha ! activation energy in photosynthesis temperature function (J/mol) +! +! !LOCAL VARIABLES: +real(r8) :: ans +!------------------------------------------------------------------------------- + +ans = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) + +return +end function ft1_f + +! ===================================================================================== + +function fth_f(tl,hd,se,scaleFactor) result(ans) + ! + !!DESCRIPTION: + !photosynthesis temperature inhibition + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! +use FatesConstantsMod, only : rgas => rgas_J_K_kmol +use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + +! +! !ARGUMENTS: +real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temp function (K) +real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) +real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) +real(r8), intent(in) :: scaleFactor ! scaling factor for high temp inhibition (25 C = 1.0) +! +! !LOCAL VARIABLES: +real(r8) :: ans +!------------------------------------------------------------------------------- + +ans = scaleFactor / ( 1._r8 + exp( (-hd+se*tl) / (rgas*1.e-3_r8*tl) ) ) + +return +end function fth_f + +! ===================================================================================== + +function fth25_f(hd,se)result(ans) + ! + !!DESCRIPTION: + ! scaling factor for photosynthesis temperature inhibition + ! + ! !REVISION HISTORY: + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + !!USES + +use FatesConstantsMod, only : rgas => rgas_J_K_kmol +use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + +! +! !ARGUMENTS: +real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) +real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) +! +! !LOCAL VARIABLES: +real(r8) :: ans +!------------------------------------------------------------------------------- + +ans = 1._r8 + exp( (-hd+se*(tfrz+25._r8)) / (rgas*1.e-3_r8*(tfrz+25._r8)) ) + +return +end function fth25_f + +! ===================================================================================== + +subroutine quadratic_f (a, b, c, r1, r2) + ! + ! !DESCRIPTION: + !==============================================================================! + !----------------- Solve quadratic equation for its two roots -----------------! + !==============================================================================! + ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific + ! Computing (Cambridge University Press, Cambridge), pp. 145. + ! + ! !REVISION HISTORY: + ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + ! !USES: + ! + ! !ARGUMENTS: +real(r8), intent(in) :: a,b,c ! Terms for quadratic equation +real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation +! +! !LOCAL VARIABLES: +real(r8) :: q ! Temporary term for quadratic solution +!------------------------------------------------------------------------------ + +if (a == 0._r8) then + write (fates_log(),*) 'Quadratic solution error: a = ',a + call endrun(msg=errMsg(sourcefile, __LINE__)) +end if + +if (b >= 0._r8) then + q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) +else + q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) +end if + +r1 = q / a +if (q /= 0._r8) then + r2 = c / q +else + r2 = 1.e36_r8 +end if + +end subroutine quadratic_f + +! ==================================================================================== + +subroutine quadratic_fast (a, b, c, r1, r2) + ! + ! !DESCRIPTION: + !==============================================================================! + !----------------- Solve quadratic equation for its two roots -----------------! + ! THIS METHOD SIMPLY REMOVES THE DIV0 CHECK AND ERROR REPORTING ! + !==============================================================================! + ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific + ! Computing (Cambridge University Press, Cambridge), pp. 145. + ! + ! !REVISION HISTORY: + ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + ! !USES: + ! + ! !ARGUMENTS: +real(r8), intent(in) :: a,b,c ! Terms for quadratic equation +real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation +! +! !LOCAL VARIABLES: +real(r8) :: q ! Temporary term for quadratic solution +!------------------------------------------------------------------------------ + +! if (a == 0._r8) then +! write (fates_log(),*) 'Quadratic solution error: a = ',a +! call endrun(msg=errMsg(sourcefile, __LINE__)) +! end if + +if (b >= 0._r8) then + q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) +else + q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) +end if + +r1 = q / a +! if (q /= 0._r8) then +r2 = c / q +! else +! r2 = 1.e36_r8 +! end if + +end subroutine quadratic_fast + + +! ==================================================================================== + +subroutine UpdateCanopyNCanNRadPresent(currentPatch) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates two patch level quanities: + ! currentPatch%ncan and + ! currentPatch%canopy_mask + ! + ! currentPatch%ncan(:,:) is a two dimensional array that indicates + ! the total number of leaf layers (including those that are not exposed to light) + ! in each canopy layer and for each functional type. + ! + ! currentPatch%nrad(:,:) is a two dimensional array that indicates + ! the total number of EXPOSED leaf layers, but for all intents and purposes + ! in the photosynthesis routine, this appears to be the same as %ncan... + ! + ! currentPatch%canopy_mask(:,:) has the same dimensions, is binary, and + ! indicates whether or not leaf layers are present (by evaluating the canopy area + ! profile). + ! --------------------------------------------------------------------------------- + + +use EDTypesMod , only : ed_patch_type +use EDTypesMod , only : ed_cohort_type + +! Arguments +type(ed_patch_type), target :: currentPatch +type(ed_cohort_type), pointer :: currentCohort + +! Locals +integer :: cl ! Canopy Layer Index +integer :: ft ! Function Type Index +integer :: iv ! index of the exposed leaf layer for each canopy layer and pft + +! Loop through the cohorts in this patch, associate each cohort with a layer and PFT +! and use the cohort's memory of how many layer's it takes up to assign the maximum +! of the layer/pft index it is in +! --------------------------------------------------------------------------------- + +currentPatch%ncan(:,:) = 0 +! redo the canopy structure algorithm to get round a +! bug that is happening for site 125, FT13. +currentCohort => currentPatch%tallest +do while(associated(currentCohort)) + + currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft) = & + max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft), & + currentCohort%NV) + + currentCohort => currentCohort%shorter + +enddo !cohort + +! NRAD = NCAN ... +currentPatch%nrad = currentPatch%ncan + +! Now loop through and identify which layer and pft combo has scattering elements +do cl = 1,nclmax + do ft = 1,numpft + currentPatch%canopy_mask(cl,ft) = 0 + do iv = 1, currentPatch%nrad(cl,ft); + if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then + currentPatch%canopy_mask(cl,ft) = 1 end if - !q10 response of product limited psn. - co2_rcurve_islope = co2_rcurve_islope25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) - end if - - ! Adjust for water limitations - vcmax = vcmax * btran - - return - end subroutine LeafLayerBiophysicalRates - - subroutine lowstorage_maintresp_reduction(frac, pft, maintresp_reduction_factor) - - ! This subroutine reduces maintenance respiration rates when storage pool is low. The premise - ! of this is that mortality of plants increases when storage is low because they are not able - ! to repair tissues, generate defense compounds, etc. This reduction is reflected in a reduced - ! maintenance demand. The output of this function takes the form of a curve between 0 and 1, - ! and the curvature of the function is determined by a parameter. - - ! Uses - use EDPftvarcon , only : EDPftvarcon_inst - - ! Arguments - ! ------------------------------------------------------------------------------ - real(r8), intent(in) :: frac ! ratio of storage to target leaf biomass - integer, intent(in) :: pft ! what pft is this cohort? - real(r8), intent(out) :: maintresp_reduction_factor ! the factor by which to reduce maintenance respiration - - ! -------------------------------------------------------------------------------- - ! Parameters are at the PFT level: - ! fates_maintresp_reduction_curvature controls the curvature of this. - ! If this parameter is zero, then there is no reduction until the plant dies at storage = 0. - ! If this parameter is one, then there is a linear reduction in respiration below the storage point. - ! Intermediate values will give some (concave-downwards) curvature. - ! - ! maintresp_reduction_intercept controls the maximum amount of throttling. - ! zero means no throttling at any point, so it turns this mechanism off completely and so - ! allows an entire cohort to die via negative carbon-induced termination mortality. - ! one means complete throttling, so no maintenance respiration at all, when out of carbon. - ! --------------------------------------------------------------------------------- - - if( frac .lt. 1._r8 )then - if ( EDPftvarcon_inst%maintresp_reduction_curvature(pft) .ne. 1._r8 ) then - maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & - EDPftvarcon_inst%maintresp_reduction_intercept(pft) * & - (1._r8 - EDPftvarcon_inst%maintresp_reduction_curvature(pft)**frac) & - / (1._r8-EDPftvarcon_inst%maintresp_reduction_curvature(pft)) - else ! avoid nan answer for linear case - maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & - EDPftvarcon_inst%maintresp_reduction_intercept(pft) * frac - endif - - else - maintresp_reduction_factor = 1._r8 - endif - - - end subroutine lowstorage_maintresp_reduction - - end module FATESPlantRespPhotosynthMod + end do !iv + enddo !ft +enddo !cl + +return +end subroutine UpdateCanopyNCanNRadPresent + +! ==================================================================================== + +subroutine GetCanopyGasParameters(can_press, & + can_o2_partialpress, & + veg_tempk, & + air_tempk, & + air_vpress, & + veg_esat, & + rb, & + mm_kco2, & + mm_ko2, & + co2_cpoint, & + cf, & + gb_mol, & + ceair) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates the specific Michaelis Menten Parameters (pa) for CO2 + ! and O2, as well as the CO2 compentation point. + ! --------------------------------------------------------------------------------- + +use FatesConstantsMod, only: umol_per_mol +use FatesConstantsMod, only: mmol_per_mol +use FatesConstantsMod, only: umol_per_kmol +use FatesConstantsMod, only : rgas => rgas_J_K_kmol + +! Arguments +real(r8), intent(in) :: can_press ! Air pressure within the canopy (Pa) +real(r8), intent(in) :: can_o2_partialpress ! Partial press of o2 in the canopy (Pa) +real(r8), intent(in) :: veg_tempk ! The temperature of the vegetation (K) +real(r8), intent(in) :: air_tempk ! Temperature of canopy air (K) +real(r8), intent(in) :: air_vpress ! Vapor pressure of canopy air (Pa) +real(r8), intent(in) :: veg_esat ! Saturated vapor pressure at veg surf (Pa) +real(r8), intent(in) :: rb ! Leaf Boundary layer resistance (s/m) + +real(r8), intent(out) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) +real(r8), intent(out) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) +real(r8), intent(out) :: co2_cpoint ! CO2 compensation point (Pa) +real(r8), intent(out) :: cf ! conversion factor between molar form and velocity form +! of conductance and resistance: [umol/m3] +real(r8), intent(out) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) +real(r8), intent(out) :: ceair ! vapor pressure of air, constrained (Pa) + +! Locals +real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) +real(r8) :: ko25 ! Michaelis-Menten constant for O2 at 25C (Pa) +real(r8) :: sco ! relative specificity of rubisco +real(r8) :: cp25 ! CO2 compensation point at 25C (Pa) + +! --------------------------------------------------------------------------------- +! Intensive values (per mol of air) +! kc, ko, currentPatch, from: Bernacchi et al (2001) +! Plant, Cell and Environment 24:253-259 +! --------------------------------------------------------------------------------- + +real(r8), parameter :: mm_kc25_umol_per_mol = 404.9_r8 +real(r8), parameter :: mm_ko25_mmol_per_mol = 278.4_r8 +real(r8), parameter :: co2_cpoint_umol_per_mol = 42.75_r8 + +! Activation energy, from: +! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 +! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 +! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 + +real(r8), parameter :: kcha = 79430._r8 ! activation energy for kc (J/mol) +real(r8), parameter :: koha = 36380._r8 ! activation energy for ko (J/mol) +real(r8), parameter :: cpha = 37830._r8 ! activation energy for cp (J/mol) + + +! Derive sco from currentPatch and O2 using present-day O2 (0.209 mol/mol) and re-calculate +! currentPatch to account for variation in O2 using currentPatch = 0.5 O2 / sco + +! FIXME (RGK 11-30-2016 THere are more constants here, but I don't have enough information +! about what they are or do, so I can't give them more descriptive names. Someone please +! fill this in when possible) + +kc25 = ( mm_kc25_umol_per_mol / umol_per_mol ) * can_press +ko25 = ( mm_ko25_mmol_per_mol / mmol_per_mol ) * can_press +sco = 0.5_r8 * 0.209_r8 / (co2_cpoint_umol_per_mol / umol_per_mol ) +cp25 = 0.5_r8 * can_o2_partialpress / sco + +if( veg_tempk.gt.150_r8 .and. veg_tempk.lt.350_r8 )then + mm_kco2 = kc25 * ft1_f(veg_tempk, kcha) + mm_ko2 = ko25 * ft1_f(veg_tempk, koha) + co2_cpoint = cp25 * ft1_f(veg_tempk, cpha) +else + mm_kco2 = 1.0_r8 + mm_ko2 = 1.0_r8 + co2_cpoint = 1.0_r8 +end if + +! --------------------------------------------------------------------------------- +! +! cf is the conversion factor between molar form and velocity form +! of conductance and resistance: [umol/m3] +! +! i.e. +! [m/s] * [umol/m3] -> [umol/m2/s] +! +! Breakdown of the conversion factor: [ umol / m3 ] +! +! Rgas [J /K /kmol] +! Air Potential Temperature [ K ] +! Canopy Pressure [ Pa ] +! conversion: umol/kmol = 1e9 +! +! [ Pa * K * kmol umol/kmol / J K ] = [ Pa * umol / J ] +! since: 1 Pa = 1 N / m2 +! [ Pa * umol / J ] = [ N * umol / J m2 ] +! since: 1 J = 1 N * m +! [ N * umol / J m2 ] = [ N * umol / N m3 ] +! [ umol / m3 ] +! +! -------------------------------------------------------------------------------- + +cf = can_press/(rgas * air_tempk )*umol_per_kmol +gb_mol = (1._r8/ rb) * cf + +! Constrain eair >= 0.05*esat_tv so that solution does not blow up. This ensures +! that hs does not go to zero. Also eair <= veg_esat so that hs <= 1 +ceair = min( max(air_vpress, 0.05_r8*veg_esat ),veg_esat ) + + + +return +end subroutine GetCanopyGasParameters + +! ==================================================================================== + +subroutine LeafLayerMaintenanceRespiration(lmr25top_ft, & + nscaler, & + ft, & + veg_tempk, & + lmr) + +use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm +use EDPftvarcon , only : EDPftvarcon_inst + +! Arguments +real(r8), intent(in) :: lmr25top_ft ! canopy top leaf maint resp rate at 25C +! for this pft (umol CO2/m**2/s) +integer, intent(in) :: ft ! (plant) Functional Type Index +real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile +real(r8), intent(in) :: veg_tempk ! vegetation temperature +real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) + +! Locals +real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + +! Parameter +real(r8), parameter :: lmrha = 46390._r8 ! activation energy for lmr (J/mol) +real(r8), parameter :: lmrhd = 150650._r8 ! deactivation energy for lmr (J/mol) +real(r8), parameter :: lmrse = 490._r8 ! entropy term for lmr (J/mol/K) +real(r8), parameter :: lmrc = 1.15912391_r8 ! scaling factor for high +! temperature inhibition (25 C = 1.0) + + + + + +! Part I: Leaf Maintenance respiration: umol CO2 / m**2 [leaf] / s +! ---------------------------------------------------------------------------------- +lmr25 = lmr25top_ft * nscaler + +if ( nint(EDpftvarcon_inst%c3psn(ft)) == 1)then + lmr = lmr25 * ft1_f(veg_tempk, lmrha) * & + fth_f(veg_tempk, lmrhd, lmrse, lmrc) +else + lmr = lmr25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + lmr = lmr / (1._r8 + exp( 1.3_r8*(veg_tempk-(tfrz+55._r8)) )) +end if + +! Any hydrodynamic limitations could go here, currently none +! lmr = lmr * (nothing) + +end subroutine LeafLayerMaintenanceRespiration + +! ==================================================================================== + +subroutine LeafLayerBiophysicalRates( parsun_lsl, & + ft, & + vcmax25top_ft, & + jmax25top_ft, & + tpu25top_ft, & + co2_rcurve_islope25top_ft, & + nscaler, & + veg_tempk, & + btran, & + vcmax, & + jmax, & + tpu, & + co2_rcurve_islope ) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates the localized rates of several key photosynthesis + ! rates. By localized, we mean specific to the plant type and leaf layer, + ! which factors in leaf physiology, as well as environmental effects. + ! This procedure should be called prior to iterative solvers, and should + ! have pre-calculated the reference rates for the pfts before this. + ! + ! The output biophysical rates are: + ! vcmax: maximum rate of carboxilation, + ! jmax: maximum electron transport rate, + ! tpu: triose phosphate utilization rate and + ! co2_rcurve_islope: initial slope of CO2 response curve (C4 plants) + ! --------------------------------------------------------------------------------- + +use EDPftvarcon , only : EDPftvarcon_inst +use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + +! Arguments +! ------------------------------------------------------------------------------ + +real(r8), intent(in) :: parsun_lsl ! PAR absorbed in sunlit leaves for this layer +integer, intent(in) :: ft ! (plant) Functional Type Index +real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile +real(r8), intent(in) :: vcmax25top_ft ! canopy top maximum rate of carboxylation at 25C +! for this pft (umol CO2/m**2/s) +real(r8), intent(in) :: jmax25top_ft ! canopy top maximum electron transport rate at 25C +! for this pft (umol electrons/m**2/s) +real(r8), intent(in) :: tpu25top_ft ! canopy top triose phosphate utilization rate at 25C +! for this pft (umol CO2/m**2/s) +real(r8), intent(in) :: co2_rcurve_islope25top_ft ! initial slope of CO2 response curve +! (C4 plants) at 25C, canopy top, this pft +real(r8), intent(in) :: veg_tempk ! vegetation temperature +real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) + +real(r8), intent(out) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) +real(r8), intent(out) :: jmax ! maximum electron transport rate +! (umol electrons/m**2/s) +real(r8), intent(out) :: tpu ! triose phosphate utilization rate +! (umol CO2/m**2/s) +real(r8), intent(out) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) + +! Locals +! ------------------------------------------------------------------------------- +real(r8) :: vcmax25 ! leaf layer: maximum rate of carboxylation at 25C +! (umol CO2/m**2/s) +real(r8) :: jmax25 ! leaf layer: maximum electron transport rate at 25C +! (umol electrons/m**2/s) +real(r8) :: tpu25 ! leaf layer: triose phosphate utilization rate at 25C +! (umol CO2/m**2/s) +real(r8) :: co2_rcurve_islope25 ! leaf layer: Initial slope of CO2 response curve +! (C4 plants) at 25C + + +! Parameters +! --------------------------------------------------------------------------------- +real(r8) :: vcmaxha ! activation energy for vcmax (J/mol) +real(r8) :: jmaxha ! activation energy for jmax (J/mol) +real(r8) :: tpuha ! activation energy for tpu (J/mol) +real(r8) :: vcmaxhd ! deactivation energy for vcmax (J/mol) +real(r8) :: jmaxhd ! deactivation energy for jmax (J/mol) +real(r8) :: tpuhd ! deactivation energy for tpu (J/mol) +real(r8) :: vcmaxse ! entropy term for vcmax (J/mol/K) +real(r8) :: jmaxse ! entropy term for jmax (J/mol/K) +real(r8) :: tpuse ! entropy term for tpu (J/mol/K) +real(r8) :: vcmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) +real(r8) :: jmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) +real(r8) :: tpuc ! scaling factor for high temperature inhibition (25 C = 1.0) + +vcmaxha = EDPftvarcon_inst%vcmaxha(FT) +jmaxha = EDPftvarcon_inst%jmaxha(FT) +tpuha = EDPftvarcon_inst%tpuha(FT) + +vcmaxhd = EDPftvarcon_inst%vcmaxhd(FT) +jmaxhd = EDPftvarcon_inst%jmaxhd(FT) +tpuhd = EDPftvarcon_inst%tpuhd(FT) + +vcmaxse = EDPftvarcon_inst%vcmaxse(FT) +jmaxse = EDPftvarcon_inst%jmaxse(FT) +tpuse = EDPftvarcon_inst%tpuse(FT) + +vcmaxc = fth25_f(vcmaxhd, vcmaxse) +jmaxc = fth25_f(jmaxhd, jmaxse) +tpuc = fth25_f(tpuhd, tpuse) + +if ( parsun_lsl <= 0._r8) then ! night time + vcmax = 0._r8 + jmax = 0._r8 + tpu = 0._r8 + co2_rcurve_islope = 0._r8 +else ! day time + + ! Vcmax25top was already calculated to derive the nscaler function + vcmax25 = vcmax25top_ft * nscaler + jmax25 = jmax25top_ft * nscaler + tpu25 = tpu25top_ft * nscaler + co2_rcurve_islope25 = co2_rcurve_islope25top_ft * nscaler + + ! Adjust for temperature + vcmax = vcmax25 * ft1_f(veg_tempk, vcmaxha) * fth_f(veg_tempk, vcmaxhd, vcmaxse, vcmaxc) + jmax = jmax25 * ft1_f(veg_tempk, jmaxha) * fth_f(veg_tempk, jmaxhd, jmaxse, jmaxc) + tpu = tpu25 * ft1_f(veg_tempk, tpuha) * fth_f(veg_tempk, tpuhd, tpuse, tpuc) + + if (nint(EDPftvarcon_inst%c3psn(ft)) /= 1) then + vcmax = vcmax25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + vcmax = vcmax / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-veg_tempk ) )) + vcmax = vcmax / (1._r8 + exp( 0.3_r8*(veg_tempk-(tfrz+40._r8)) )) + end if + !q10 response of product limited psn. + co2_rcurve_islope = co2_rcurve_islope25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) +end if + +! Adjust for water limitations +vcmax = vcmax * btran + +return +end subroutine LeafLayerBiophysicalRates + +subroutine lowstorage_maintresp_reduction(frac, pft, maintresp_reduction_factor) + + ! This subroutine reduces maintenance respiration rates when storage pool is low. The premise + ! of this is that mortality of plants increases when storage is low because they are not able + ! to repair tissues, generate defense compounds, etc. This reduction is reflected in a reduced + ! maintenance demand. The output of this function takes the form of a curve between 0 and 1, + ! and the curvature of the function is determined by a parameter. + + ! Uses +use EDPftvarcon , only : EDPftvarcon_inst + +! Arguments +! ------------------------------------------------------------------------------ +real(r8), intent(in) :: frac ! ratio of storage to target leaf biomass +integer, intent(in) :: pft ! what pft is this cohort? +real(r8), intent(out) :: maintresp_reduction_factor ! the factor by which to reduce maintenance respiration + +! -------------------------------------------------------------------------------- +! Parameters are at the PFT level: +! fates_maintresp_reduction_curvature controls the curvature of this. +! If this parameter is zero, then there is no reduction until the plant dies at storage = 0. +! If this parameter is one, then there is a linear reduction in respiration below the storage point. +! Intermediate values will give some (concave-downwards) curvature. +! +! maintresp_reduction_intercept controls the maximum amount of throttling. +! zero means no throttling at any point, so it turns this mechanism off completely and so +! allows an entire cohort to die via negative carbon-induced termination mortality. +! one means complete throttling, so no maintenance respiration at all, when out of carbon. +! --------------------------------------------------------------------------------- + +if( frac .lt. 1._r8 )then + if ( EDPftvarcon_inst%maintresp_reduction_curvature(pft) .ne. 1._r8 ) then + maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & + EDPftvarcon_inst%maintresp_reduction_intercept(pft) * & + (1._r8 - EDPftvarcon_inst%maintresp_reduction_curvature(pft)**frac) & + / (1._r8-EDPftvarcon_inst%maintresp_reduction_curvature(pft)) + else ! avoid nan answer for linear case + maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & + EDPftvarcon_inst%maintresp_reduction_intercept(pft) * frac + endif + +else + maintresp_reduction_factor = 1._r8 +endif + + +end subroutine lowstorage_maintresp_reduction + +end module FATESPlantRespPhotosynthMod From ba597bd052c64339ca029f29330bc6c156013522 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 25 Nov 2020 09:25:38 -0700 Subject: [PATCH 174/578] ading comments on arbitrary initialization in SP mode --- main/EDInitMod.F90 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index f13994e8ea..64e3fe87bf 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -1,4 +1,4 @@ -module EDInitMod +1;95;0cmodule EDInitMod ! ============================================================================ ! Contains all modules to set up the ED structure. @@ -717,6 +717,9 @@ subroutine init_cohorts( site_in, patch_in, bc_in) if(hlm_use_sp.eq.itrue)then init = itrue + ! At this point, we do not know the bc_in values of tlai tsai and htop, + ! so this is initializing to an arbitrary value for the very first timestep. + ! Not sure if there's a way around this or not. call assign_cohort_SP_properties(temp_cohort, 0.5_r8,0.2_r8, 0.1_r8,patch_in%area,init,c_leaf) else From b6bdea99c3d1a3024098a9fba9c786c4c85d0ff3 Mon Sep 17 00:00:00 2001 From: Jacquelyn Shuman Date: Wed, 25 Nov 2020 15:38:16 -0700 Subject: [PATCH 175/578] Add ref to original equations --- fire/SFMainMod.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index ab6fdf25b1..f043e7d31d 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -766,11 +766,12 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) if (currentPatch%effect_wspeed < 16.67_r8) then !16.67m/min = 1km/hr lb = 1.0_r8 else - if (tree_fraction_patch > 0.55_r8) then !benchmark for forest cover per Staver 2010 - lb = (1.0_r8 + (8.729_r8 * & - ((1.0_r8 -(exp(-0.03_r8 * wind_convert * currentPatch%effect_wspeed)))**2.155_r8))) - else - lb = (1.1_r8+((wind_convert * currentPatch%effect_wspeed)**0.0464)) + if (tree_fraction_patch > 0.55_r8) then !benchmark forest cover, Staver 2010 + ! EQ 79 forest fuels (Canadian Forest Fire Behavior Prediction System Ont.Inf.Rep. ST-X-3, 1992) + lb = (1.0_r8 + (8.729_r8 * & + ((1.0_r8 -(exp(-0.03_r8 * wind_convert * currentPatch%effect_wspeed)))**2.155_r8))) + else ! EQ 80 grass fuels (CFFBPS Ont.Inf.Rep. ST-X-3, 1992) + lb = (1.1_r8+((wind_convert * currentPatch%effect_wspeed)**0.0464)) endif endif From 29d528b42d1bfeb3aba520a81ef71c289b7f5f19 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 26 Nov 2020 07:11:58 -0700 Subject: [PATCH 176/578] comments on pft_areafracweighting from HT --- biogeochem/EDPhysiologyMod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index b624167af9..13ab71d25f 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1409,6 +1409,7 @@ subroutine satellite_phenology(currentSite, bc_in) end do !hlm_pft ! weight for total area in each patch/fates_pft + ! this is needed because the area of pft_areafrac does not need to sum to 1.0 if(currentPatch%area.gt.0.0_r8)then currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) & /(currentPatch%area/area) From 9f1d7e5aadf3ff7e9dbbe8ec015ddeec607e9d4e Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 26 Nov 2020 07:12:32 -0700 Subject: [PATCH 177/578] removing type in EDInit --- main/EDInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 64e3fe87bf..06185a4669 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -1,4 +1,4 @@ -1;95;0cmodule EDInitMod +module EDInitMod ! ============================================================================ ! Contains all modules to set up the ED structure. From d1e75c925a6363b8ff93773db9eeed214688c80b Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 1 Dec 2020 15:28:58 -0700 Subject: [PATCH 178/578] fixing typos in lb calc --- fire/SFMainMod.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index b81cb58bd1..ef48cf96f7 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -694,7 +694,7 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) integer :: iofp ! index of oldest fates patch real(r8), parameter :: pot_hmn_ign_counts_alpha = 0.0035_r8 ! Potential human ignition counts (alpha in Li et al. 2012) (#/person/month) real(r8), parameter :: km2_to_m2 = 1000000.0_r8 !area conversion for square km to square m - real(r8), parameter :: wind_convert = 0.06_r8 ! convert wind speed from m/min to km/hr + real(r8), parameter :: m_per_min__to__km_per_hour = 0.06_r8 ! convert wind speed from m/min to km/hr ! ---initialize site parameters to zero--- currentSite%frac_burnt(:) = 0.0_r8 @@ -763,15 +763,15 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) write(fates_log(),*) 'SF AREA ',AREA endif - if (currentPatch%effect_wspeed < 16.67_r8) then !16.67m/min = 1km/hr + if ((currentPatch%effect_wspeed*m_per_min__to__km_per_hour) < 1._r8) then !16.67m/min = 1km/hr lb = 1.0_r8 else if (tree_fraction_patch > 0.55_r8) then !benchmark forest cover, Staver 2010 ! EQ 79 forest fuels (Canadian Forest Fire Behavior Prediction System Ont.Inf.Rep. ST-X-3, 1992) lb = (1.0_r8 + (8.729_r8 * & - ((1.0_r8 -(exp(-0.03_r8 * wind_convert * currentPatch%effect_wspeed)))**2.155_r8))) - else ! EQ 80 grass fuels (CFFBPS Ont.Inf.Rep. ST-X-3, 1992) - lb = (1.1_r8+((wind_convert * currentPatch%effect_wspeed)**0.0464)) + ((1.0_r8 -(exp(-0.03_r8 * m_per_min__to__km_per_hour * currentPatch%effect_wspeed)))**2.155_r8))) + else ! EQ 80 grass fuels (CFFBPS Ont.Inf.Rep. ST-X-3, 1992, but with a correction in Information Report GLC-X-10 by Bottom et al., 2009) + lb = (1.1_r8*((m_per_min__to__km_per_hour * currentPatch%effect_wspeed)**0.464_r8)) endif endif From abcf30e7db4fe72be782e4fe2a1fab0c7875b851 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 1 Dec 2020 16:00:04 -0700 Subject: [PATCH 179/578] changing a pi-like number to pi --- fire/SFMainMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index ef48cf96f7..8cef4007f8 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -7,6 +7,7 @@ module SFMainMod use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse + use FatesConstantsMod , only : pi_const use FatesInterfaceTypesMod , only : hlm_masterproc ! 1= master process, 0=not master process use EDTypesMod , only : numWaterMem use FatesGlobals , only : fates_log @@ -791,7 +792,7 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) ! AB = AB *3.0_r8 !size of fire = equation 14 Arora and Boer JGR 2005 - size_of_fire = ((3.1416_r8/(4.0_r8*lb))*((df+db)**2.0_r8)) + size_of_fire = ((pi_const/(4.0_r8*lb))*((df+db)**2.0_r8)) !AB = daily area burnt = size fires in m2 * num ignitions per day per km2 * prob ignition starts fire !AB = m2 per km2 per day From 3b0d8b14cb3411971b046c831939c7217bd033d6 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 2 Dec 2020 21:43:38 -0500 Subject: [PATCH 180/578] Initial code prep for logistic function to affect the cn_scalar in FATES-ECA, will be keyed off storage --- biogeochem/FatesSoilBGCFluxMod.F90 | 23 ++++++++++++++++++++--- main/FatesHistoryInterfaceMod.F90 | 12 ++++++++++-- 2 files changed, 30 insertions(+), 5 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index fc6ce19ba6..59ca4c4162 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -919,7 +919,7 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) ! patch litt => currentPatch%litter(el) area_frac = currentPatch%area/area - + do ic = 1, ncwd do id = 1,nlev_eff_decomp @@ -961,7 +961,6 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) do j = 1, nlev_eff_soil id = bc_in%decomp_id(j) - flux_lab_si(id) = flux_lab_si(id) + & litt%root_fines_frag(ilabile,j) * area_frac flux_cel_si(id) = flux_cel_si(id) + & @@ -987,7 +986,6 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) end do ! do elements - return end subroutine FluxIntoLitterPools @@ -1043,7 +1041,9 @@ function ECACScalar(ccohort, element_id) result(c_scalar) integer, parameter :: cnp_scalar_method1 = 1 integer, parameter :: cnp_scalar_method2 = 2 integer, parameter :: cnp_scalar_method3 = 3 + integer, parameter :: cnp_scalar_logi_store = 4 integer, parameter :: cnp_scalar_method = cnp_scalar_method3 + real(r8), parameter :: cn_stoich_var=0.2 ! variability of CN ratio real(r8), parameter :: cp_stoich_var=0.4 ! variability of CP ratio @@ -1115,6 +1115,23 @@ function ECACScalar(ccohort, element_id) result(c_scalar) c_scalar = 1 + case(cnp_scalar_logi_store) + + ! In this method, we define the c_scalar term + ! with a logistic function that goes to 1 (full need) + ! as the plant's nutrien storage hits a low threshold + ! and goes to 0, no demand, as the plant's nutrient + ! storage approaches it's maximum holding capacity. + + ! nutrient concentration matches 95%tile of scalar + ! 0.95 = 1._r8/(1._r8 + exp(-logi_k*( 0.95*(nc_ideal-x0) ))) + ! logi_k = -log(1._r8-0.95/0.95)/ ( 0.95*(nc_ideal-x0) ) + ! bc_out%cn_scalar(icomp) = 1._r8/(1._r8 + exp(-logi_k*(nc_actual-x0))) + + print*,"not coded yet" + stop + + end select end function ECACScalar diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index ec3060a810..cbf1eda487 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -290,7 +290,8 @@ module FatesHistoryInterfaceMod ! Indices to (site) variables integer :: ih_nep_si - + integer :: ih_hr_si + integer :: ih_c_stomata_si integer :: ih_c_lblayer_si @@ -3315,7 +3316,8 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) 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_nep_si => this%hvars(ih_nep_si)%r81d, & + hio_nep_si => this%hvars(ih_nep_si)%r81d, & + hio_hr_si => this%hvars(ih_hr_si)%r81d, & hio_ar_si_scpf => this%hvars(ih_ar_si_scpf)%r82d, & hio_ar_grow_si_scpf => this%hvars(ih_ar_grow_si_scpf)%r82d, & hio_ar_maint_si_scpf => this%hvars(ih_ar_maint_si_scpf)%r82d, & @@ -3391,6 +3393,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) io_soipa = io_pa1-1 hio_nep_si(io_si) = -bc_in(s)%tot_het_resp ! (gC/m2/s) + hio_hr_si(io_si) = bc_in(s)%tot_het_resp ipa = 0 cpatch => sites(s)%oldest_patch @@ -5793,6 +5796,11 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_nep_si ) + call this%set_history_var(vname='FATES_HR', units='gC/m^2/s', & + long='heterotrophic respiration', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_hr_si ) + call this%set_history_var(vname='Fire_Closs', units='gC/m^2/s', & long='ED/SPitfire Carbon loss to atmosphere', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & From e1bf0a3c44af3d898379ee3f4be1e423a9cbad03 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 2 Dec 2020 22:17:42 -0500 Subject: [PATCH 181/578] Updated cn_scalar calculations and nutrient storage target --- biogeochem/FatesSoilBGCFluxMod.F90 | 20 +++++++++++--------- parteh/PRTAllometricCNPMod.F90 | 8 ++++---- 2 files changed, 15 insertions(+), 13 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 59ca4c4162..a4b3540f45 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -1027,7 +1027,9 @@ function ECACScalar(ccohort, element_id) result(c_scalar) real(r8) :: cx_actual ! Actual C:X ratio of plant real(r8) :: cx_ideal ! Ideal C:X ratio of plant real(r8) :: c_stoich_var ! effective variance of the CN or CP ratio - + real(r8) :: store_frac ! Current nutrient storage relative to max + real(r8) :: store_max ! Maximum nutrient storable by plant + ! We are still testing different functional relationships for c_scalar, thus ! three methods. Methods 1 and 2 are subtly different, but both increase neediness ! as a plants NC or PC ratio decreases, and vice versa. The variance @@ -1042,13 +1044,17 @@ function ECACScalar(ccohort, element_id) result(c_scalar) integer, parameter :: cnp_scalar_method2 = 2 integer, parameter :: cnp_scalar_method3 = 3 integer, parameter :: cnp_scalar_logi_store = 4 - integer, parameter :: cnp_scalar_method = cnp_scalar_method3 + integer, parameter :: cnp_scalar_method = cnp_scalar_logi_store real(r8), parameter :: cn_stoich_var=0.2 ! variability of CN ratio real(r8), parameter :: cp_stoich_var=0.4 ! variability of CP ratio + real(r8), parameter :: logi_k = 20.0_r8 ! logistic function k + real(r8), parameter :: store_x0 = 0.65 ! storage fraction inflection point + real(r8), parameter :: logi_min = 0.1_r8 ! minimum cn_scalar for logistic + ! Target leaf biomass according to allometry and trimming call bleaf(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,target_leaf_c) call bstore_allom(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,target_store_c) @@ -1123,14 +1129,10 @@ function ECACScalar(ccohort, element_id) result(c_scalar) ! and goes to 0, no demand, as the plant's nutrient ! storage approaches it's maximum holding capacity. - ! nutrient concentration matches 95%tile of scalar - ! 0.95 = 1._r8/(1._r8 + exp(-logi_k*( 0.95*(nc_ideal-x0) ))) - ! logi_k = -log(1._r8-0.95/0.95)/ ( 0.95*(nc_ideal-x0) ) - ! bc_out%cn_scalar(icomp) = 1._r8/(1._r8 + exp(-logi_k*(nc_actual-x0))) + store_max = ccohort%prt%GetNutrientTarget(element_id,store_organ,stoich_max) + store_frac = ccohort%prt%GetState(store_organ, element_id)/store_max - print*,"not coded yet" - stop - + c_scalar = logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))) end select diff --git a/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 index a31b7895fd..b296d9e2d1 100644 --- a/parteh/PRTAllometricCNPMod.F90 +++ b/parteh/PRTAllometricCNPMod.F90 @@ -1793,14 +1793,14 @@ function GetNutrientTarget(this,element_id,organ_id,stoich_mode) result(target_m target_c = & leaf_c_target*prt_params%nitr_stoich_p2(ipft,leaf_organ)+ & fnrt_c_target*prt_params%nitr_stoich_p2(ipft,fnrt_organ)+ & - sapw_c_target*prt_params%nitr_stoich_p2(ipft,sapw_organ)+ & - struct_c_target*prt_params%nitr_stoich_p2(ipft,struct_organ) + sapw_c_target*prt_params%nitr_stoich_p2(ipft,sapw_organ)!+ & +! struct_c_target*prt_params%nitr_stoich_p2(ipft,struct_organ) else target_c = & leaf_c_target*prt_params%phos_stoich_p2(ipft,leaf_organ)+ & fnrt_c_target*prt_params%phos_stoich_p2(ipft,fnrt_organ)+ & - sapw_c_target*prt_params%phos_stoich_p2(ipft,sapw_organ)+ & - struct_c_target*prt_params%phos_stoich_p2(ipft,struct_organ) + sapw_c_target*prt_params%phos_stoich_p2(ipft,sapw_organ) !+ & +! struct_c_target*prt_params%phos_stoich_p2(ipft,struct_organ) end if From 671286f361426e2522a74708b023b3f51338a4d2 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 4 Dec 2020 17:29:15 -0700 Subject: [PATCH 182/578] some code cleanup and documentation --- fire/SFMainMod.F90 | 50 +++++++++++++++++++++++++++++++-------------- main/EDTypesMod.F90 | 4 ++-- 2 files changed, 37 insertions(+), 17 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 8cef4007f8..dccf1a0e62 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -451,10 +451,22 @@ subroutine rate_of_spread ( currentSite ) do while(associated(currentPatch)) - ! ---initialise parameters to zero.--- - beta_ratio = 0.0_r8; q_ig = 0.0_r8; eps = 0.0_r8; a = 0.0_r8; b = 0.0_r8; c = 0.0_r8; e = 0.0_r8 - phi_wind = 0.0_r8; xi = 0.0_r8; reaction_v_max = 0.0_r8; reaction_v_opt = 0.0_r8; mw_weight = 0.0_r8 - moist_damp = 0.0_r8; ir = 0.0_r8; a_beta = 0.0_r8; + ! ---initialise parameters to zero.--- + beta_ratio = 0.0_r8 + q_ig = 0.0_r8 + eps = 0.0_r8 + a = 0.0_r8 + b = 0.0_r8 + c = 0.0_r8 + e = 0.0_r8 + phi_wind = 0.0_r8 + xi = 0.0_r8 + reaction_v_max = 0.0_r8 + reaction_v_opt = 0.0_r8 + mw_weight = 0.0_r8 + moist_damp = 0.0_r8 + ir = 0.0_r8 + a_beta = 0.0_r8 currentPatch%ROS_front = 0.0_r8 ! remove mineral content from net fuel load per Thonicke 2010 for ir calculation @@ -493,11 +505,11 @@ subroutine rate_of_spread ( currentSite ) ! ---effective heating number--- ! Equation A3 in Thonicke et al. 2010. eps = exp(-4.528_r8 / currentPatch%fuel_sav) - ! Equation A7 in Thonicke et al. 2010 + ! Equation A7 in Thonicke et al. 2010 / eqn 49 from Rothermel 1972 b = 0.15988_r8 * (currentPatch%fuel_sav**0.54_r8) - ! Equation A8 in Thonicke et al. 2010 + ! Equation A8 in Thonicke et al. 2010 / eqn 48 from Rothermel 1972 c = 7.47_r8 * (exp(-0.8711_r8 * (currentPatch%fuel_sav**0.55_r8))) - ! Equation A9 in Thonicke et al. 2010. + ! Equation A9 in Thonicke et al. 2010. (which appears to have a typo, using the coefficient from Rothermel 1972 eqn. 50 instead) e = 0.715_r8 * (exp(-0.01094_r8 * currentPatch%fuel_sav)) if (debug) then @@ -587,7 +599,7 @@ subroutine ground_fuel_consumption ( currentSite ) real(r8) :: moist !effective fuel moisture real(r8) :: tau_b(nfsc) !lethal heating rates for each fuel class (min) - real(r8) :: fc_ground(nfsc) !proportion of fuel consumed + real(r8) :: fc_ground(nfsc) !total amount of fuel consumed per area of burned ground (kg C / m2 of burned area) integer :: c @@ -668,7 +680,7 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) !currentSite%FDI probability that an ignition will start a fire !currentSite%NF number of lighting strikes per day per km2 !currentPatch%ROS_front forward ROS (m/min) - !currentPatch%TFC_ROS total fuel consumed by flaming front (kgC/m2) + !currentPatch%TFC_ROS total fuel consumed by flaming front (kgC/m2 of burned area) use FatesInterfaceTypesMod, only : hlm_spitfire_mode use EDParamsMod, only : ED_val_nignitions @@ -791,24 +803,31 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) ! Equation 16 in arora and boer model JGR 2005 ! AB = AB *3.0_r8 - !size of fire = equation 14 Arora and Boer JGR 2005 + !size of fire = equation 14 Arora and Boer JGR 2005 (area of an ellipse) size_of_fire = ((pi_const/(4.0_r8*lb))*((df+db)**2.0_r8)) - !AB = daily area burnt = size fires in m2 * num ignitions per day per km2 * prob ignition starts fire - !AB = m2 per km2 per day + ! AB = daily area burnt = size fires in m2 * num ignitions per day per km2 * prob ignition starts fire + ! AB = m2 per km2 per day + ! the denominator in the units of currentSite%NF is total gridcell area, but since we assume that ignitions + ! are equally probable across patches, currentSite%NF is equivalently per area of a given patch + ! thus AB has units of m2 burned area per km2 patch area per day AB = size_of_fire * currentSite%NF * currentSite%FDI - !frac_burnt + ! frac_burnt + ! just a unit conversion from AB, to become area burned per area patch per day, + ! or just the fraction of the patch burned on that day currentPatch%frac_burnt = (min(0.99_r8, AB / km2_to_m2)) if(write_SF == itrue)then if ( hlm_masterproc == itrue ) write(fates_log(),*) 'frac_burnt',currentPatch%frac_burnt endif + else + currentPatch%frac_burnt = 0._r8 endif ! lb ROS = currentPatch%ROS_front / 60.0_r8 !m/min to m/sec - W = currentPatch%TFC_ROS / 0.45_r8 !kgC/m2 to kgbiomass/m2 + W = currentPatch%TFC_ROS / 0.45_r8 !kgC/m2 of burned area to kgbiomass/m2 of burned area ! EQ 15 Thonicke et al 2010 !units of fire intensity = (kJ/kg)*(kgBiomass/m2)*(m/min) @@ -825,7 +844,8 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) currentSite%NF_successful = currentSite%NF_successful + & currentSite%NF * currentSite%FDI * currentPatch%area / area ! - ! accumulate frac_burnt % at site level + ! accumulate frac_burnt % at site level. this is purely being tracked as a diagnostic + ! since patch%frac_burnt * patch%area changes due to the fire before history output currentSite%frac_burnt(currentPatch%age_class) = currentSite%frac_burnt(currentPatch%age_class) + & currentPatch%frac_burnt * currentPatch%area / area ! diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index bca591f303..9177fda013 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -556,8 +556,8 @@ module EDTypesMod ! FIRE EFFECTS real(r8) :: scorch_ht(maxpft) ! scorch height: m real(r8) :: frac_burnt ! fraction burnt: frac patch/day - real(r8) :: tfc_ros ! total fuel consumed - no trunks. KgC/m2/day - real(r8) :: burnt_frac_litter(nfsc) ! fraction of each litter pool burned:- + real(r8) :: tfc_ros ! total intensity-relevant fuel consumed - no trunks. KgC/m2 of burned ground/day + real(r8) :: burnt_frac_litter(nfsc) ! fraction of each litter pool burned, conditional on it being burned ! PLANT HYDRAULICS (not currently used in hydraulics RGK 03-2018) From b9dd836c2fb3ec692f17046cc4f7321893a0131f Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 4 Dec 2020 17:35:32 -0700 Subject: [PATCH 183/578] rerouting seed decay to roots instead of leaves --- biogeochem/EDPhysiologyMod.F90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 6d4aa312b8..e468365bf9 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -2201,19 +2201,20 @@ subroutine SeedDecayToFines(litt) ! ! !LOCAL VARIABLES: integer :: pft + integer, parameter :: seedlev = 2 - ! Add decaying seeds to the leaf litter + ! Add decaying seeds to a single level of root litter ! ----------------------------------------------------------------------------------- do pft = 1,numpft - litt%leaf_fines_in(ilabile) = litt%leaf_fines_in(ilabile) + & + litt%root_fines_in(ilabile,seedlev) = litt%root_fines_in(ilabile,seedlev) + & (litt%seed_decay(pft) + litt%seed_germ_decay(pft)) * EDPftvarcon_inst%lf_flab(pft) - litt%leaf_fines_in(icellulose) = litt%leaf_fines_in(icellulose) + & + litt%root_fines_in(icellulose,seedlev) = litt%root_fines_in(icellulose,seedlev) + & (litt%seed_decay(pft) + litt%seed_germ_decay(pft)) * EDPftvarcon_inst%lf_fcel(pft) - litt%leaf_fines_in(ilignin) = litt%leaf_fines_in(ilignin) + & + litt%root_fines_in(ilignin,seedlev) = litt%root_fines_in(ilignin,seedlev) + & (litt%seed_decay(pft) + litt%seed_germ_decay(pft)) * EDPftvarcon_inst%lf_flig(pft) enddo From 1766ba4f16a951fd3f8fa076159d33089cb8cd95 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 7 Dec 2020 20:53:06 -0700 Subject: [PATCH 184/578] turned on HLM decomp scalar again --- biogeochem/EDPhysiologyMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index e468365bf9..0d08c2755e 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -2249,7 +2249,7 @@ subroutine fragmentation_scaler( currentPatch, bc_in) ! ! !LOCAL VARIABLES: logical :: use_century_tfunc = .false. - logical :: use_hlm_soil_scalar = .false. ! Use hlm input decomp fraction scalars + logical :: use_hlm_soil_scalar = .true. ! Use hlm input decomp fraction scalars integer :: j integer :: ifp ! Index of a FATES Patch "ifp" real(r8) :: t_scalar ! temperature scalar From c8778be187b120362e35c539164f436c7701da74 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 8 Dec 2020 15:51:38 -0500 Subject: [PATCH 185/578] Updates to CNP storage and cn_scalar --- biogeochem/FatesSoilBGCFluxMod.F90 | 23 ++++++++++++----------- parteh/PRTAllometricCNPMod.F90 | 10 ++++++---- parteh/PRTGenericMod.F90 | 20 ++++++++++++++++++-- 3 files changed, 36 insertions(+), 17 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index a4b3540f45..4a43a9b86d 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -31,6 +31,7 @@ module FatesSoilBGCFluxMod use PRTGenericMod , only : repro_organ use PRTGenericMod , only : struct_organ use PRTGenericMod , only : SetState + use PRTAllometricCNPMod,only : stoich_max use FatesAllometryMod, only : set_root_fraction use FatesAllometryMod , only : h_allom use FatesAllometryMod , only : h2d_allom @@ -73,7 +74,7 @@ module FatesSoilBGCFluxMod use FatesLitterMod , only : icellulose use PRTParametersMod , only : prt_params use EDPftvarcon , only : EDPftvarcon_inst - + implicit none private @@ -440,7 +441,6 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) integer :: j ! soil layer index integer :: id ! decomp index (might == j) integer :: pft ! plant functional type - integer :: nlev_eff_soil ! number of active soil layers type(ed_patch_type), pointer :: cpatch ! current patch pointer type(ed_cohort_type), pointer :: ccohort ! current cohort pointer real(r8) :: fnrt_c ! fine-root carbon [kg] @@ -480,10 +480,6 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) end if end if - - ! This is the number of effective soil layers to transfer from - nlev_eff_soil = max(bc_in%max_rooting_depth_index_col, 1) - ! ECA Specific Parameters ! -------------------------------------------------------------------------------- if(trim(hlm_nu_com).eq.'ECA')then @@ -529,8 +525,8 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) ! Map the soil layers to the decomposition layers ! (which may be synonomous) ! veg_rootc in units: [g/m3] = [kgC/plant] * [plant/ha] * [ha/ 10k m2] * [1000 g / kg] * [1/m] - - do j = 1, nlev_eff_soil + + do j = 1, bc_in%nlevdecomp id = bc_in%decomp_id(j) ! Map from soil layer to decomp layer veg_rootc = fnrt_c * ccohort%n * csite%rootfrac_scr(j) * AREA_INV * g_per_kg / csite%dz_soil(j) bc_out%veg_rootc(icomp,id) = bc_out%veg_rootc(icomp,id) + veg_rootc @@ -1039,10 +1035,15 @@ function ECACScalar(ccohort, element_id) result(c_scalar) ! method 1: cn_scalar = (nc_ideal - nc_actual + variance*nc_min)/(nc_ideal - nc_min + variance*nc_min) ! ! method 2: cn_scalar = (1/nc_actual - (1-variance)/nc_ideal)/(variance/nc_ideal) - + ! + ! method force1: force the cn_scalar = 1 (100% need) for all situations + ! + ! method logi_store: cn_scalar follows a logistic function starting at 1 and dropping to a minimum value + ! as nutrient storage fraction of maximum goes from 0 to 1 + integer, parameter :: cnp_scalar_method1 = 1 integer, parameter :: cnp_scalar_method2 = 2 - integer, parameter :: cnp_scalar_method3 = 3 + integer, parameter :: cnp_scalar_force1 = 3 integer, parameter :: cnp_scalar_logi_store = 4 integer, parameter :: cnp_scalar_method = cnp_scalar_logi_store @@ -1117,7 +1118,7 @@ function ECACScalar(ccohort, element_id) result(c_scalar) c_scalar = min(1._r8,max(0._r8, & (cx_actual - cx_ideal*(1._r8-c_stoich_var))/(cx_ideal*c_stoich_var))) - case(cnp_scalar_method3) + case(cnp_scalar_force1) c_scalar = 1 diff --git a/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 index b296d9e2d1..d8ee2a2f70 100644 --- a/parteh/PRTAllometricCNPMod.F90 +++ b/parteh/PRTAllometricCNPMod.F90 @@ -205,13 +205,13 @@ module PRTAllometricCNPMod procedure :: DailyPRT => DailyPRTAllometricCNP procedure :: FastPRT => FastPRTAllometricCNP - + procedure :: GetNutrientTarget => GetNutrientTargetCNP + ! Extended functions specific to Allometric CNP procedure :: CNPPrioritizedReplacement procedure :: CNPStatureGrowth procedure :: CNPAllocateRemainder procedure :: GetDeficit - procedure :: GetNutrientTarget procedure :: GrowEquivC procedure :: NAndPToMatchC end type cnp_allom_prt_vartypes @@ -1748,7 +1748,7 @@ end function GetDeficit ! ===================================================================================== - function GetNutrientTarget(this,element_id,organ_id,stoich_mode) result(target_m) + function GetNutrientTargetCNP(this,element_id,organ_id,stoich_mode) result(target_m) class(cnp_allom_prt_vartypes) :: this integer, intent(in) :: element_id @@ -1831,8 +1831,10 @@ function GetNutrientTarget(this,element_id,organ_id,stoich_mode) result(target_m end if return - end function GetNutrientTarget + end function GetNutrientTargetCNP + + ! ===================================================================================== subroutine ProportionalNutrAllocation(state_m, deficit_m, gain_m, element_id, list) diff --git a/parteh/PRTGenericMod.F90 b/parteh/PRTGenericMod.F90 index 9c6f9db2e2..01866ca22a 100644 --- a/parteh/PRTGenericMod.F90 +++ b/parteh/PRTGenericMod.F90 @@ -241,7 +241,8 @@ module PRTGenericMod procedure :: DailyPRT => DailyPRTBase procedure :: FastPRT => FastPRTBase - + procedure :: GetNutrientTarget => GetNutrientTargetBase + ! These are generic functions that should work on all hypotheses procedure, non_overridable :: InitAllocate @@ -1384,6 +1385,21 @@ subroutine AgeLeaves(this,ipft,period_sec) end do end subroutine AgeLeaves - + + + function GetNutrientTargetBase(this,element_id,organ_id,stoich_mode) result(target_m) + + class(prt_vartypes) :: this + integer, intent(in) :: element_id + integer, intent(in) :: organ_id + integer, intent(in) :: stoich_mode + real(r8) :: target_m ! Target amount of nutrient for this organ [kg] + + write(fates_log(),*)'GetNutrientTargetBase must be extended by a child class.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + return + end function GetNutrientTargetBase + end module PRTGenericMod From 93da0f6c46ffbe7b8cf6a74a73678393ff152de9 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 8 Dec 2020 16:30:06 -0700 Subject: [PATCH 186/578] rerouting seed_decay flux straight to HLM surface litter pools --- biogeochem/EDPhysiologyMod.F90 | 40 ++---------------------------- biogeochem/FatesSoilBGCFluxMod.F90 | 22 +++++++++++++++- 2 files changed, 23 insertions(+), 39 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 0d08c2755e..32671e082e 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -227,10 +227,6 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! Calculate loss rate of viable seeds to litter call SeedDecay(litt) - ! Send those decaying seeds in the previous call - ! to the litter input flux - call SeedDecayToFines(litt) - ! Calculate seed germination rate, the status flags prevent ! germination from occuring when the site is in a drought ! (for drought deciduous) or too cold (for cold deciduous) @@ -254,7 +250,8 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! Fragmentation flux to soil decomposition model [kg/site/day] site_mass%frag_out = site_mass%frag_out + currentPatch%area * & ( sum(litt%ag_cwd_frag) + sum(litt%bg_cwd_frag) + & - sum(litt%leaf_fines_frag) + sum(litt%root_fines_frag)) + sum(litt%leaf_fines_frag) + sum(litt%root_fines_frag) + & + sum(litt%seed_decay) + sum(litt%seed_germ_decay)) end do @@ -2195,39 +2192,6 @@ end subroutine CWDInput ! ===================================================================================== - subroutine SeedDecayToFines(litt) - - type(litter_type) :: litt - ! - ! !LOCAL VARIABLES: - integer :: pft - integer, parameter :: seedlev = 2 - - ! Add decaying seeds to a single level of root litter - ! ----------------------------------------------------------------------------------- - - do pft = 1,numpft - - litt%root_fines_in(ilabile,seedlev) = litt%root_fines_in(ilabile,seedlev) + & - (litt%seed_decay(pft) + litt%seed_germ_decay(pft)) * EDPftvarcon_inst%lf_flab(pft) - - litt%root_fines_in(icellulose,seedlev) = litt%root_fines_in(icellulose,seedlev) + & - (litt%seed_decay(pft) + litt%seed_germ_decay(pft)) * EDPftvarcon_inst%lf_fcel(pft) - - litt%root_fines_in(ilignin,seedlev) = litt%root_fines_in(ilignin,seedlev) + & - (litt%seed_decay(pft) + litt%seed_germ_decay(pft)) * EDPftvarcon_inst%lf_flig(pft) - - enddo - - - return - end subroutine SeedDecayToFines - - - - - - ! ===================================================================================== subroutine fragmentation_scaler( currentPatch, bc_in) ! diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 258c37e847..a09dc3725b 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -772,7 +772,6 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) ! into the soil/decomposition ! layers. It exponentially decays real(r8) :: surface_prof_tot ! normalizes the surface_prof array - integer :: ft ! PFT number integer :: nlev_eff_soil ! number of effective soil layers integer :: nlev_eff_decomp ! number of effective decomp layers real(r8) :: area_frac ! fraction of site's area of current patch @@ -782,6 +781,7 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) integer :: j ! Soil layer index integer :: id ! Decomposition layer index integer :: ic ! CWD type index + integer :: ipft ! PFT index ! NOTE(rgk, 201705) this parameter was brought over from SoilBiogeochemVerticalProfile ! how steep profile is for surface components (1/ e_folding depth) (1/m) @@ -930,6 +930,26 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) end do + + ! decaying seeds from the litter pool + do ipft = 1,numpft + do id = 1,nlev_eff_decomp + + flux_lab_si(id) = flux_lab_si(id) + & + (litt%seed_decay(ipft) + litt%seed_germ_decay(ipft)) * & + EDPftvarcon_inst%lf_flab(ipft) * area_frac* surface_prof(id) + + flux_cel_si(id) = flux_cel_si(id) + & + (litt%seed_decay(ipft) + litt%seed_germ_decay(ipft)) * & + EDPftvarcon_inst%lf_fcel(ipft) * area_frac* surface_prof(id) + + flux_lig_si(id) = flux_lig_si(id) + & + (litt%seed_decay(ipft) + litt%seed_germ_decay(ipft)) * & + EDPftvarcon_inst%lf_flig(ipft) * area_frac* surface_prof(id) + end do + end do + + do j = 1, nlev_eff_soil id = bc_in%decomp_id(j) From 6c02677facd2a77bd134d84336a7a6aaf93b5bcf Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 8 Dec 2020 18:11:42 -0700 Subject: [PATCH 187/578] pulled grassland/forest tree coverage threshold as a named constant --- fire/SFMainMod.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index dccf1a0e62..4696442fd9 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -708,6 +708,7 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) real(r8), parameter :: pot_hmn_ign_counts_alpha = 0.0035_r8 ! Potential human ignition counts (alpha in Li et al. 2012) (#/person/month) real(r8), parameter :: km2_to_m2 = 1000000.0_r8 !area conversion for square km to square m real(r8), parameter :: m_per_min__to__km_per_hour = 0.06_r8 ! convert wind speed from m/min to km/hr + real(r8), parameter :: forest_grassland_lengthtobreadth_threshold = 0.55_r8 ! tree canopy cover below which to use grassland length-to-breadth eqn ! ---initialize site parameters to zero--- currentSite%frac_burnt(:) = 0.0_r8 @@ -779,11 +780,12 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) if ((currentPatch%effect_wspeed*m_per_min__to__km_per_hour) < 1._r8) then !16.67m/min = 1km/hr lb = 1.0_r8 else - if (tree_fraction_patch > 0.55_r8) then !benchmark forest cover, Staver 2010 + if (tree_fraction_patch > forest_grassland_lengthtobreadth_threshold) then !benchmark forest cover, Staver 2010 ! EQ 79 forest fuels (Canadian Forest Fire Behavior Prediction System Ont.Inf.Rep. ST-X-3, 1992) lb = (1.0_r8 + (8.729_r8 * & ((1.0_r8 -(exp(-0.03_r8 * m_per_min__to__km_per_hour * currentPatch%effect_wspeed)))**2.155_r8))) - else ! EQ 80 grass fuels (CFFBPS Ont.Inf.Rep. ST-X-3, 1992, but with a correction in Information Report GLC-X-10 by Bottom et al., 2009) + else ! EQ 80 grass fuels (CFFBPS Ont.Inf.Rep. ST-X-3, 1992, but with a correction from an errata published within + ! Information Report GLC-X-10 by Bottom et al., 2009 because there is a typo in CFFBPS Ont.Inf.Rep. ST-X-3, 1992) lb = (1.1_r8*((m_per_min__to__km_per_hour * currentPatch%effect_wspeed)**0.464_r8)) endif endif From f2ead9f622d88e701ed422be6cfd29d8b2a19908 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 9 Dec 2020 12:05:04 -0700 Subject: [PATCH 188/578] added pft-resolved gpp and npp hist vars, and fixed/improved units on some other hist vars --- main/FatesHistoryInterfaceMod.F90 | 32 +++++++++++++++++++++++++------ 1 file changed, 26 insertions(+), 6 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index f0cbaddef3..d9dab3a6c8 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -506,6 +506,8 @@ module FatesHistoryInterfaceMod integer :: ih_mortality_si_pft integer :: ih_crownarea_si_pft integer :: ih_canopycrownarea_si_pft + integer :: ih_gpp_si_pft + integer :: ih_npp_si_pft ! indices to (site x patch-age) variables integer :: ih_area_si_age @@ -1810,6 +1812,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_mortality_si_pft => this%hvars(ih_mortality_si_pft)%r82d, & hio_crownarea_si_pft => this%hvars(ih_crownarea_si_pft)%r82d, & hio_canopycrownarea_si_pft => this%hvars(ih_canopycrownarea_si_pft)%r82d, & + hio_gpp_si_pft => this%hvars(ih_gpp_si_pft)%r82d, & + hio_npp_si_pft => this%hvars(ih_npp_si_pft)%r82d, & hio_nesterov_fire_danger_si => this%hvars(ih_nesterov_fire_danger_si)%r81d, & hio_fire_nignitions_si => this%hvars(ih_fire_nignitions_si)%r81d, & hio_fire_fdi_si => this%hvars(ih_fire_fdi_si)%r81d, & @@ -2375,14 +2379,20 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! Update PFT crown area hio_crownarea_si_pft(io_si, ft) = hio_crownarea_si_pft(io_si, ft) + & - ccohort%c_area + ccohort%c_area * AREA_INV if (ccohort%canopy_layer .eq. 1) then ! Update PFT canopy crown area hio_canopycrownarea_si_pft(io_si, ft) = hio_canopycrownarea_si_pft(io_si, ft) + & - ccohort%c_area + ccohort%c_area * AREA_INV end if + ! update pft-resolved NPP and GPP fluxes + hio_gpp_si_pft(io_si, ft) = hio_gpp_si_pft(io_si, ft) + & + ccohort%gpp_acc_hold * n_perm2 + + hio_npp_si_pft(io_si, ft) = hio_npp_si_pft(io_si, ft) + & + ccohort%npp_acc_hold * n_perm2 ! Site by Size-Class x PFT (SCPF) @@ -4202,12 +4212,12 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_trimming_si) - call this%set_history_var(vname='AREA_PLANT', units='m2', & + call this%set_history_var(vname='AREA_PLANT', units='m2/m2', & long='area occupied by all plants', use_default='active', & 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', & + call this%set_history_var(vname='AREA_TREES', units='m2/m2', & long='area occupied by woody plants', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_area_trees_si) @@ -4293,16 +4303,26 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_storebiomass_si_pft ) - call this%set_history_var(vname='PFTcrownarea', units='m2/ha', & + call this%set_history_var(vname='PFTcrownarea', units='m2/m2', & long='total PFT level crown area', use_default='inactive', & avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_crownarea_si_pft ) - call this%set_history_var(vname='PFTcanopycrownarea', units='m2/ha', & + call this%set_history_var(vname='PFTcanopycrownarea', units='m2/m2', & long='total PFT-level canopy-layer crown area', use_default='inactive', & avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_canopycrownarea_si_pft ) + call this%set_history_var(vname='PFTgpp', units='kg C m-2 y-1', & + long='total PFT-level GPP', use_default='active', & + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_gpp_si_pft ) + + call this%set_history_var(vname='PFTnpp', units='kg C m-2 y-1', & + long='total PFT-level NPP', use_default='active', & + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_npp_si_pft ) + call this%set_history_var(vname='PFTnindivs', units='indiv / m2', & long='total PFT level number of individuals', use_default='active', & avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & From 13fb39824c3c9e3a0eef88953c1aa5c3182b84e6 Mon Sep 17 00:00:00 2001 From: Jacquelyn Shuman Date: Fri, 11 Dec 2020 17:09:57 -0700 Subject: [PATCH 189/578] Comments and refs for MEF equation SPITFIRE --- fire/SFMainMod.F90 | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 4696442fd9..3ab30e4094 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -244,7 +244,15 @@ subroutine charecteristics_of_fuel ( currentSite ) lg_sf,currentPatch%livegrass,currentPatch%sum_fuel endif - currentPatch%fuel_frac(lg_sf) = currentPatch%livegrass / currentPatch%sum_fuel + currentPatch%fuel_frac(lg_sf) = currentPatch%livegrass / currentPatch%sum_fuel + + ! MEF (moisure of extinction) depends on compactness of fuel, depth, particle size, wind, slope + ! MEF: pine needles=0.30 (text near EQ 28 Rothermal 1972) + ! Table II-1 NFFL mixed fuels models from Rothermal 1983 Gen. Tech. Rep. INT-143 + ! MEF: short grass=0.12,tall grass=0.25,chaparral=0.20,closed timber litter=0.30,hardwood litter=0.25 + ! Thonicke 2010 SAV give MEF:tw=0.45, sb=0.4874, lb=0.5245, tr=0.57, dg=0.404, lg=0.404 + ! no reference for MEF eqn. in Thonicke 2010 + ! Lasslop 2014 Table 1 MEF PFT level:grass=0.2,shrubs=0.3,TropEverGrnTree=0.2,TropDecid Tree=0.3, Extra-trop Tree=0.3 MEF(1:nfsc) = 0.524_r8 - 0.066_r8 * log10(SF_val_SAV(1:nfsc)) !--- weighted average of relative moisture content--- @@ -505,11 +513,11 @@ subroutine rate_of_spread ( currentSite ) ! ---effective heating number--- ! Equation A3 in Thonicke et al. 2010. eps = exp(-4.528_r8 / currentPatch%fuel_sav) - ! Equation A7 in Thonicke et al. 2010 / eqn 49 from Rothermel 1972 + ! Equation A7 in Thonicke et al. 2010 per eqn 49 from Rothermel 1972 b = 0.15988_r8 * (currentPatch%fuel_sav**0.54_r8) - ! Equation A8 in Thonicke et al. 2010 / eqn 48 from Rothermel 1972 + ! Equation A8 in Thonicke et al. 2010 per eqn 48 from Rothermel 1972 c = 7.47_r8 * (exp(-0.8711_r8 * (currentPatch%fuel_sav**0.55_r8))) - ! Equation A9 in Thonicke et al. 2010. (which appears to have a typo, using the coefficient from Rothermel 1972 eqn. 50 instead) + ! Equation A9 in Thonicke et al. 2010. (appears to have typo, using coefficient eqn.50 Rothermel 1972) e = 0.715_r8 * (exp(-0.01094_r8 * currentPatch%fuel_sav)) if (debug) then From 64f9e7b1f2ca86dcc63469831a9428179a330ca9 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 11 Dec 2020 18:10:45 -0700 Subject: [PATCH 190/578] removed site%frac_burnt variable as no tneeded --- fire/SFMainMod.F90 | 7 ------- main/EDInitMod.F90 | 4 ---- main/EDTypesMod.F90 | 1 - main/FatesHistoryInterfaceMod.F90 | 10 ---------- 4 files changed, 22 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 3ab30e4094..dec68185c0 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -719,7 +719,6 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) real(r8), parameter :: forest_grassland_lengthtobreadth_threshold = 0.55_r8 ! tree canopy cover below which to use grassland length-to-breadth eqn ! ---initialize site parameters to zero--- - currentSite%frac_burnt(:) = 0.0_r8 currentSite%NF_successful = 0._r8 ! Equation 7 from Venevsky et al GCB 2002 (modification of equation 8 in Thonicke et al. 2010) @@ -854,15 +853,9 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) currentSite%NF_successful = currentSite%NF_successful + & currentSite%NF * currentSite%FDI * currentPatch%area / area ! - ! accumulate frac_burnt % at site level. this is purely being tracked as a diagnostic - ! since patch%frac_burnt * patch%area changes due to the fire before history output - currentSite%frac_burnt(currentPatch%age_class) = currentSite%frac_burnt(currentPatch%age_class) + & - currentPatch%frac_burnt * currentPatch%area / area - ! else currentPatch%fire = 0 ! No fire... :-/ currentPatch%FD = 0.0_r8 - currentPatch%frac_burnt = 0.0_r8 endif endif! NF ignitions check diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index bb09d13704..27652d9ed9 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -120,8 +120,6 @@ subroutine init_site_vars( site_in, bc_in ) allocate(site_in%mass_balance(1:num_elements)) allocate(site_in%flux_diags(1:num_elements)) - allocate(site_in%frac_burnt(1:nlevage)) - site_in%nlevsoil = bc_in%nlevsoil allocate(site_in%rootfrac_scr(site_in%nlevsoil)) allocate(site_in%zi_soil(0:site_in%nlevsoil)) @@ -190,7 +188,6 @@ subroutine zero_site( site_in ) site_in%acc_ni = 0.0_r8 ! daily nesterov index accumulating over time. time unlimited theoretically. site_in%NF = 0.0_r8 ! daily lightning strikes per km2 site_in%NF_successful = 0.0_r8 ! daily successful iginitions per km2 - site_in%frac_burnt(:) = 0.0_r8 ! burn area do el=1,num_elements ! Zero the state variables used for checking mass conservation @@ -301,7 +298,6 @@ subroutine set_site_properties( nsites, sites,bc_in ) sites(s)%acc_NI = acc_NI sites(s)%NF = 0.0_r8 sites(s)%NF_successful = 0.0_r8 - sites(s)%frac_burnt(:) = 0.0_r8 ! PLACEHOLDER FOR PFT AREA DATA MOVED ACROSS INTERFACE if(hlm_use_fixed_biogeog.eq.itrue)then diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 9177fda013..1a29410fa2 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -731,7 +731,6 @@ module EDTypesMod real(r8) :: fdi ! daily probability an ignition event will start a fire real(r8) :: NF ! daily ignitions in km2 real(r8) :: NF_successful ! daily ignitions in km2 that actually lead to fire - real(r8), allocatable :: frac_burnt(:) ! fraction of gridcell area burnt in this day. indexed by patch age bins ! PLANT HYDRAULICS type(ed_site_hydr_type), pointer :: si_hydr diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index d9dab3a6c8..3dd391b9b1 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -524,7 +524,6 @@ module FatesHistoryInterfaceMod integer :: ih_agesince_anthrodist_si_age integer :: ih_secondaryforest_area_si_age integer :: ih_area_burnt_si_age - integer :: ih_area_burnt2_si_age ! integer :: ih_fire_rate_of_spread_front_si_age integer :: ih_fire_intensity_si_age integer :: ih_fire_sum_fuel_si_age @@ -2006,7 +2005,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) 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_area_burnt2_si_age => this%hvars(ih_area_burnt2_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, & @@ -2886,8 +2884,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_ncl_si_age(io_si, ipa2) = 0._r8 endif - hio_area_burnt2_si_age(io_si,ipa2) = sites(s)%frac_burnt(ipa2) - end do ! pass the cohort termination mortality as a flux to the history, and then reset the termination mortality buffer @@ -4534,12 +4530,6 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_area_burnt_si_age ) - call this%set_history_var(vname='AREA_BURNT2_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_burnt2_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', & From 372bfe4d55a113ca4fb75dfd955df28132c726c6 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 11 Dec 2020 18:37:54 -0700 Subject: [PATCH 191/578] fixed units on burned area --- main/FatesHistoryInterfaceMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 3dd391b9b1..ed98301ee4 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -4472,7 +4472,7 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_fire_intensity_area_product_si ) - call this%set_history_var(vname='FIRE_AREA', units='fraction', & + call this%set_history_var(vname='FIRE_AREA', units='fraction/day', & long='spitfire fire area burn fraction', 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_area_si ) @@ -4524,7 +4524,7 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_agefuel_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_fuel_amount_age_fuel ) - call this%set_history_var(vname='AREA_BURNT_BY_PATCH_AGE', units='m2/m2', & + call this%set_history_var(vname='AREA_BURNT_BY_PATCH_AGE', units='m2/m2/day', & 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, & From e590cd356d34990293334f046a0667809d2e1389 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 17 Dec 2020 11:18:06 -0700 Subject: [PATCH 192/578] updated MEF eqn and description --- fire/SFMainMod.F90 | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index dec68185c0..a508d27283 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -247,13 +247,14 @@ subroutine charecteristics_of_fuel ( currentSite ) currentPatch%fuel_frac(lg_sf) = currentPatch%livegrass / currentPatch%sum_fuel ! MEF (moisure of extinction) depends on compactness of fuel, depth, particle size, wind, slope + ! Eqn here is eqn 27 from Peterson and Ryan (1986) "Modeling Postfire Conifer Mortality for Long-Range Planning" + ! but lots of other approaches in use out there... ! MEF: pine needles=0.30 (text near EQ 28 Rothermal 1972) ! Table II-1 NFFL mixed fuels models from Rothermal 1983 Gen. Tech. Rep. INT-143 ! MEF: short grass=0.12,tall grass=0.25,chaparral=0.20,closed timber litter=0.30,hardwood litter=0.25 - ! Thonicke 2010 SAV give MEF:tw=0.45, sb=0.4874, lb=0.5245, tr=0.57, dg=0.404, lg=0.404 - ! no reference for MEF eqn. in Thonicke 2010 + ! Thonicke 2010 SAV values propagated thru P&R86 eqn below gives MEF:tw=0.355, sb=0.44, lb=0.525, tr=0.63, dg=0.248, lg=0.248 ! Lasslop 2014 Table 1 MEF PFT level:grass=0.2,shrubs=0.3,TropEverGrnTree=0.2,TropDecid Tree=0.3, Extra-trop Tree=0.3 - MEF(1:nfsc) = 0.524_r8 - 0.066_r8 * log10(SF_val_SAV(1:nfsc)) + MEF(1:nfsc) = 0.524_r8 - 0.066_r8 * log(SF_val_SAV(1:nfsc)) !--- weighted average of relative moisture content--- ! Equation 6 in Thonicke et al. 2010. across twig, small branch, large branch, and dead leaves From e01e8731cffc123bca48fd56bab18bdfefd2bd26 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 17 Dec 2020 13:45:58 -0700 Subject: [PATCH 193/578] added some units info to EDTypesMod.F90 and fates_params_default.cdl --- main/EDTypesMod.F90 | 4 ++-- parameter_files/fates_params_default.cdl | 10 +++++----- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 1a29410fa2..110673f94a 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -534,9 +534,9 @@ module EDTypesMod real(r8) :: sum_fuel ! total ground fuel related to ros (omits 1000hr fuels): KgC/m2 real(r8) :: fuel_frac(nfsc) ! fraction of each litter class in the ros_fuel:-. real(r8) :: livegrass ! total aboveground grass biomass in patch. KgC/m2 - real(r8) :: fuel_bulkd ! average fuel bulk density of the ground fuel + real(r8) :: fuel_bulkd ! average fuel bulk density of the ground fuel. kgBiomass/m3 ! (incl. live grasses. omits 1000hr fuels). KgC/m3 - real(r8) :: fuel_sav ! average surface area to volume ratio of the ground fuel + real(r8) :: fuel_sav ! average surface area to volume ratio of the ground fuel. cm-1 ! (incl. live grasses. omits 1000hr fuels). real(r8) :: fuel_mef ! average moisture of extinction factor ! of the ground fuel (incl. live grasses. omits 1000hr fuels). diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 1f813c4b4e..600b97ac00 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -164,7 +164,7 @@ variables: fates_eca_vmax_ptase:units = "gP/m2/s" ; fates_eca_vmax_ptase:long_name = "maximum production rate for biochemical P (per m2) (ECA)" ; double fates_fire_alpha_SH(fates_pft) ; - fates_fire_alpha_SH:units = "NA" ; + fates_fire_alpha_SH:units = "m / (kw/m)**(2/3)" ; fates_fire_alpha_SH:long_name = "spitfire parameter, alpha scorch height, Equation 16 Thonicke et al 2010" ; double fates_fire_bark_scaler(fates_pft) ; fates_fire_bark_scaler:units = "fraction" ; @@ -501,8 +501,8 @@ variables: fates_z0mr:units = "unitless" ; fates_z0mr:long_name = "Ratio of momentum roughness length to canopy top height" ; double fates_fire_FBD(fates_litterclass) ; - fates_fire_FBD:units = "NA" ; - fates_fire_FBD:long_name = "spitfire parameter related to fuel bulk density, see SFMain.F90" ; + fates_fire_FBD:units = "kg Biomass/m3" ; + fates_fire_FBD:long_name = "fuel bulk density" ; double fates_fire_low_moisture_Coeff(fates_litterclass) ; fates_fire_low_moisture_Coeff:units = "NA" ; fates_fire_low_moisture_Coeff:long_name = "spitfire parameter, equation B1 Thonicke et al 2010" ; @@ -522,8 +522,8 @@ variables: fates_fire_min_moisture:units = "NA" ; fates_fire_min_moisture:long_name = "spitfire litter moisture threshold to be considered very dry" ; double fates_fire_SAV(fates_litterclass) ; - fates_fire_SAV:units = "NA" ; - fates_fire_SAV:long_name = "spitfire parameter related to surface area to volume ratio, see SFMain.F90" ; + fates_fire_SAV:units = "cm-1" ; + fates_fire_SAV:long_name = "fuel surface area to volume ratio" ; double fates_max_decomp(fates_litterclass) ; fates_max_decomp:units = "yr-1" ; fates_max_decomp:long_name = "maximum rate of litter & CWD transfer from non-decomposing class into decomposing class" ; From ea97d55c6de484863e8076ee1867c84d1571a28b Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 17 Dec 2020 16:10:53 -0700 Subject: [PATCH 194/578] initing patch fire variables with nans instead of zeros, and removing some unnecessary zeroing --- biogeochem/EDPatchDynamicsMod.F90 | 36 +++++++++++++------------- fire/SFMainMod.F90 | 42 +++---------------------------- 2 files changed, 22 insertions(+), 56 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index ea0b2918db..6f686f418d 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2108,31 +2108,31 @@ subroutine zero_patch(cp_p) ! FIRE - currentPatch%litter_moisture(:) = 0.0_r8 ! litter moisture - currentPatch%fuel_eff_moist = 0.0_r8 ! average fuel moisture content of the ground fuel + currentPatch%litter_moisture(:) = nan ! litter moisture + currentPatch%fuel_eff_moist = nan ! average fuel moisture content of the ground fuel ! (incl. live grasses. omits 1000hr fuels) - currentPatch%livegrass = 0.0_r8 ! total ag grass biomass in patch. 1=c3 grass, 2=c4 grass. gc/m2 - currentPatch%sum_fuel = 0.0_r8 ! total ground fuel related to ros (omits 1000hr fuels). gc/m2 - currentPatch%fuel_bulkd = 0.0_r8 ! average fuel bulk density of the ground fuel + currentPatch%livegrass = nan ! total ag grass biomass in patch. 1=c3 grass, 2=c4 grass. gc/m2 + currentPatch%sum_fuel = nan ! total ground fuel related to ros (omits 1000hr fuels). gc/m2 + currentPatch%fuel_bulkd = nan ! average fuel bulk density of the ground fuel ! (incl. live grasses. omits 1000hr fuels). kgc/m3 - currentPatch%fuel_sav = 0.0_r8 ! average surface area to volume ratio of the ground fuel + currentPatch%fuel_sav = nan ! average surface area to volume ratio of the ground fuel ! (incl. live grasses. omits 1000hr fuels). - currentPatch%fuel_mef = 0.0_r8 ! average moisture of extinction factor of the ground fuel + currentPatch%fuel_mef = nan ! average moisture of extinction factor of the ground fuel ! (incl. live grasses. omits 1000hr fuels). - currentPatch%ros_front = 0.0_r8 ! average rate of forward spread of each fire in the patch. m/min. - currentPatch%effect_wspeed = 0.0_r8 ! dailywind modified by fraction of relative grass and tree cover. m/min. - currentPatch%tau_l = 0.0_r8 ! mins p&r(1986) - currentPatch%fuel_frac(:) = 0.0_r8 ! fraction of each litter class in the sum_fuel + currentPatch%ros_front = nan ! average rate of forward spread of each fire in the patch. m/min. + currentPatch%effect_wspeed = nan ! dailywind modified by fraction of relative grass and tree cover. m/min. + currentPatch%tau_l = nan ! mins p&r(1986) + currentPatch%fuel_frac(:) = nan ! fraction of each litter class in the sum_fuel !- for purposes of calculating weighted averages. - currentPatch%tfc_ros = 0.0_r8 ! used in fi calc - currentPatch%fi = 0._r8 ! average fire intensity of flaming front during day. + currentPatch%tfc_ros = nan ! used in fi calc + currentPatch%fi = nan ! average fire intensity of flaming front during day. ! backward ros plays no role. kj/m/s or kw/m. currentPatch%fire = 999 ! sr decide_fire.1=fire hot enough to proceed. 0=stop everything- no fires today - currentPatch%fd = 0.0_r8 ! fire duration (mins) - currentPatch%ros_back = 0.0_r8 ! backward ros (m/min) - currentPatch%scorch_ht(:) = 0.0_r8 ! scorch height of flames on a given PFT - currentPatch%frac_burnt = 0.0_r8 ! fraction burnt daily - currentPatch%burnt_frac_litter(:) = 0.0_r8 + currentPatch%fd = nan ! fire duration (mins) + currentPatch%ros_back = nan ! backward ros (m/min) + currentPatch%scorch_ht(:) = nan ! scorch height of flames on a given PFT + currentPatch%frac_burnt = nan ! fraction burnt daily + currentPatch%burnt_frac_litter(:) = nan currentPatch%btran_ft(:) = 0.0_r8 currentPatch%canopy_layer_tlai(:) = 0.0_r8 diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index a508d27283..01bbc84ac0 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -206,20 +206,11 @@ subroutine charecteristics_of_fuel ( currentSite ) ! NCWD =4 NFSC = 6 ! tw_sf = 1, lb_sf = 3, tr_sf = 4, dl_sf = 5, lg_sf = 6, - ! zero fire arrays. - currentPatch%fuel_eff_moist = 0.0_r8 - currentPatch%fuel_bulkd = 0.0_r8 !this is kgBiomass/m3 for use in rate of spread equations - currentPatch%fuel_sav = 0.0_r8 - currentPatch%fuel_frac(:) = 0.0_r8 - currentPatch%fuel_mef = 0.0_r8 - currentPatch%sum_fuel = 0.0_r8 - currentPatch%fuel_frac = 0.0_r8 if(write_sf == itrue)then if ( hlm_masterproc == itrue ) write(fates_log(),*) ' leaf_litter1 ',sum(litt_c%leaf_fines(:)) if ( hlm_masterproc == itrue ) write(fates_log(),*) ' leaf_litter2 ',sum(litt_c%ag_cwd(:)) if ( hlm_masterproc == itrue ) write(fates_log(),*) ' leaf_litter3 ',currentPatch%livegrass - if ( hlm_masterproc == itrue ) write(fates_log(),*) ' sum fuel', currentPatch%sum_fuel endif currentPatch%sum_fuel = sum(litt_c%leaf_fines(:)) + & @@ -238,8 +229,6 @@ subroutine charecteristics_of_fuel ( currentSite ) currentPatch%fuel_frac(tw_sf:tr_sf) = litt_c%ag_cwd(:) / currentPatch%sum_fuel if(write_sf == itrue)then - if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ff1 ',currentPatch%fuel_frac - if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ff2 ',currentPatch%fuel_frac if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ff2a ', & lg_sf,currentPatch%livegrass,currentPatch%sum_fuel endif @@ -323,7 +312,6 @@ subroutine charecteristics_of_fuel ( currentSite ) currentPatch%fuel_frac(:) = 0.0000000001_r8 currentPatch%fuel_mef = 0.0000000001_r8 currentPatch%sum_fuel = 0.0000000001_r8 - currentPatch%fuel_frac = 0.0000000001_r8 endif ! check values. @@ -460,24 +448,6 @@ subroutine rate_of_spread ( currentSite ) do while(associated(currentPatch)) - ! ---initialise parameters to zero.--- - beta_ratio = 0.0_r8 - q_ig = 0.0_r8 - eps = 0.0_r8 - a = 0.0_r8 - b = 0.0_r8 - c = 0.0_r8 - e = 0.0_r8 - phi_wind = 0.0_r8 - xi = 0.0_r8 - reaction_v_max = 0.0_r8 - reaction_v_opt = 0.0_r8 - mw_weight = 0.0_r8 - moist_damp = 0.0_r8 - ir = 0.0_r8 - a_beta = 0.0_r8 - currentPatch%ROS_front = 0.0_r8 - ! remove mineral content from net fuel load per Thonicke 2010 for ir calculation currentPatch%sum_fuel = currentPatch%sum_fuel * (1.0_r8 - SF_val_miner_total) !net of minerals @@ -563,11 +533,6 @@ subroutine rate_of_spread ( currentSite ) moist_damp = max(0.0_r8,(1.0_r8 - (2.59_r8 * mw_weight) + (5.11_r8 * (mw_weight**2.0_r8)) - & (3.52_r8*(mw_weight**3.0_r8)))) - ! FIX(SPM, 040114) ask RF if this should be an endrun - ! if(write_SF == itrue)then - ! write(fates_log(),*) 'moist_damp' ,moist_damp,mw_weight,currentPatch%fuel_eff_moist,currentPatch%fuel_mef - ! endif - ! ir = reaction intenisty in kJ/m2/min ! currentPatch%sum_fuel converted from kgC/m2 to kgBiomass/m2 for ir calculation ir = reaction_v_opt*(currentPatch%sum_fuel/0.45_r8)*SF_val_fuel_energy*moist_damp*SF_val_miner_damp @@ -615,7 +580,7 @@ subroutine ground_fuel_consumption ( currentSite ) currentPatch => currentSite%oldest_patch; do while(associated(currentPatch)) - currentPatch%burnt_frac_litter = 1.0_r8 + currentPatch%burnt_frac_litter(:) = 1.0_r8 ! Calculate fraction of litter is burnt for all classes. ! Equation B1 in Thonicke et al. 2010--- do c = 1, nfsc !work out the burnt fraction for all pools, even if those pools dont exist. @@ -644,8 +609,9 @@ subroutine ground_fuel_consumption ( currentSite ) ! we can't ever kill -all- of the grass. currentPatch%burnt_frac_litter(lg_sf) = min(0.8_r8,currentPatch%burnt_frac_litter(lg_sf )) + ! reduce burnt amount for mineral content. - currentPatch%burnt_frac_litter = currentPatch%burnt_frac_litter * (1.0_r8-SF_val_miner_total) + currentPatch%burnt_frac_litter(:) = currentPatch%burnt_frac_litter(:) * (1.0_r8-SF_val_miner_total) !---Calculate amount of fuel burnt.--- @@ -758,11 +724,11 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) currentPatch => currentSite%oldest_patch; do while(associated(currentPatch)) ! ---initialize patch parameters to zero--- + currentPatch%FI = 0._r8 currentPatch%fire = 0 currentPatch%FD = 0.0_r8 currentPatch%frac_burnt = 0.0_r8 - if (currentSite%NF > 0.0_r8) then ! Equation 14 in Thonicke et al. 2010 From 32620d77d874357c7302253685d8e48206b4245a Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 6 Jan 2021 21:47:43 -0700 Subject: [PATCH 195/578] zeroing patch fire vars for first timestep --- main/EDInitMod.F90 | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 27652d9ed9..19a9d2cb00 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -357,6 +357,7 @@ subroutine init_patches( nsites, sites, bc_in) type(ed_site_type), pointer :: sitep type(ed_patch_type), pointer :: newp + type(ed_patch_type), pointer :: currentPatch ! List out some nominal patch values that are used for Near Bear Ground initializations ! as well as initializing inventory @@ -437,6 +438,35 @@ subroutine init_patches( nsites, sites, bc_in) end if + ! zero all the patch fire variables for the first timestep + do s = 1, nsites + currentPatch => sites(s)%youngest_patch + do while(associated(currentPatch)) + + currentPatch%litter_moisture(:) = 0._r8 + currentPatch%fuel_eff_moist = 0._r8 + currentPatch%livegrass = 0._r8 + currentPatch%sum_fuel = 0._r8 + currentPatch%fuel_bulkd = 0._r8 + currentPatch%fuel_sav = 0._r8 + currentPatch%fuel_mef = 0._r8 + currentPatch%ros_front = 0._r8 + currentPatch%effect_wspeed = 0._r8 + currentPatch%tau_l = 0._r8 + currentPatch%fuel_frac(:) = 0._r8 + currentPatch%tfc_ros = 0._r8 + currentPatch%fi = 0._r8 + currentPatch%fire = 0 + currentPatch%fd = 0._r8 + currentPatch%ros_back = 0._r8 + currentPatch%scorch_ht(:) = 0._r8 + currentPatch%frac_burnt = 0._r8 + currentPatch%burnt_frac_litter(:) = 0._r8 + + currentPatch => currentPatch%older + enddo + enddo + ! This sets the rhizosphere shells based on the plant initialization ! The initialization of the plant-relevant hydraulics variables ! were set from a call inside of the init_cohorts()->create_cohort() subroutine From cc3b16faf5a05122b5d0dd4876da06630d14d59c Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 6 Jan 2021 22:49:10 -0700 Subject: [PATCH 196/578] zeroing patch fire fluxes upon new patch creation --- biogeochem/EDPatchDynamicsMod.F90 | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 6f686f418d..5a49695d15 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2034,6 +2034,23 @@ subroutine create_patch(currentSite, new_patch, age, areap, label) new_patch%fabi_sha_z(:,:,:) = 0._r8 new_patch%scorch_ht(:) = 0._r8 new_patch%frac_burnt = 0._r8 + new_patch%litter_moisture(:) = 0._r8 + new_patch%fuel_eff_moist = 0._r8 + new_patch%livegrass = 0._r8 + new_patch%sum_fuel = 0._r8 + new_patch%fuel_bulkd = 0._r8 + new_patch%fuel_sav = 0._r8 + new_patch%fuel_mef = 0._r8 + new_patch%ros_front = 0._r8 + new_patch%effect_wspeed = 0._r8 + new_patch%tau_l = 0._r8 + new_patch%fuel_frac(:) = 0._r8 + new_patch%tfc_ros = 0._r8 + new_patch%fi = 0._r8 + new_patch%fd = 0._r8 + new_patch%ros_back = 0._r8 + new_patch%scorch_ht(:) = 0._r8 + new_patch%burnt_frac_litter(:) = 0._r8 new_patch%total_tree_area = 0.0_r8 new_patch%NCL_p = 1 From c0f3957e58288d27500f7aff909873a1cae2b74d Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 12 Jan 2021 20:20:46 -0700 Subject: [PATCH 197/578] re-added patch%frac_burnt=0 when below threshold intensity --- fire/SFMainMod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 01bbc84ac0..127dfa43f9 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -823,6 +823,7 @@ subroutine area_burnt_intensity ( currentSite, bc_in ) else currentPatch%fire = 0 ! No fire... :-/ currentPatch%FD = 0.0_r8 + currentPatch%frac_burnt = 0.0_r8 endif endif! NF ignitions check From 74c320bb350d901e6d060a8f4406d8da240a9d09 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 24 Jan 2021 15:04:05 -0500 Subject: [PATCH 198/578] Updated regulating function for N storage recovering --- biogeochem/FatesSoilBGCFluxMod.F90 | 7 +++---- parteh/PRTAllometricCNPMod.F90 | 4 ++-- 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 4a43a9b86d..a87c8c2845 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -1051,10 +1051,9 @@ function ECACScalar(ccohort, element_id) result(c_scalar) real(r8), parameter :: cn_stoich_var=0.2 ! variability of CN ratio real(r8), parameter :: cp_stoich_var=0.4 ! variability of CP ratio - real(r8), parameter :: logi_k = 20.0_r8 ! logistic function k - real(r8), parameter :: store_x0 = 0.65 ! storage fraction inflection point - real(r8), parameter :: logi_min = 0.1_r8 ! minimum cn_scalar for logistic - + real(r8), parameter :: logi_k = 35.0_r8 ! logistic function k + real(r8), parameter :: store_x0 = 0.85 ! storage fraction inflection point + real(r8), parameter :: logi_min = 0.001_r8 ! minimum cn_scalar for logistic ! Target leaf biomass according to allometry and trimming call bleaf(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,target_leaf_c) diff --git a/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 index d8ee2a2f70..5c866f9512 100644 --- a/parteh/PRTAllometricCNPMod.F90 +++ b/parteh/PRTAllometricCNPMod.F90 @@ -94,9 +94,9 @@ module PRTAllometricCNPMod ! Global identifiers for the two stoichiometry values - integer, parameter :: stoich_growth_min = 1 ! Flag for stoichiometry associated with + integer,public, parameter :: stoich_growth_min = 1 ! Flag for stoichiometry associated with ! minimum needed for growth - integer, parameter :: stoich_max = 2 ! Flag for stoichiometry associated with + integer,public, parameter :: stoich_max = 2 ! Flag for stoichiometry associated with ! maximum for that organ From 941bd8fc7c033cdfd5005f442c47543af321a963 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 27 Jan 2021 17:21:51 -0500 Subject: [PATCH 199/578] Refactored parameter file to remove reproductive and storage organs from nutrient based 2d arrays --- biogeochem/EDPhysiologyMod.F90 | 64 +- biogeochem/FatesSoilBGCFluxMod.F90 | 152 +-- biogeophys/FatesPlantRespPhotosynthMod.F90 | 18 +- main/EDInitMod.F90 | 23 +- main/EDTypesMod.F90 | 3 +- main/FatesInterfaceMod.F90 | 5 +- main/FatesInventoryInitMod.F90 | 46 +- parameter_files/fates_params_default.cdl | 54 +- parameter_files/fates_params_new.cdl | 1369 ++++++++++++++++++++ parteh/PRTAllometricCNPMod.F90 | 158 ++- parteh/PRTLossFluxesMod.F90 | 35 +- parteh/PRTParametersMod.F90 | 37 +- parteh/PRTParamsFATESMod.F90 | 587 ++++++--- tools/FatesPFTIndexSwapper.py | 8 +- 14 files changed, 2080 insertions(+), 479 deletions(-) create mode 100644 parameter_files/fates_params_new.cdl diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 1525133dff..0dad9109b3 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -59,6 +59,7 @@ module EDPhysiologyMod use EDTypesMod , only : phen_dstat_moistoff use EDTypesMod , only : phen_dstat_moiston use EDTypesMod , only : phen_dstat_timeon + use EDTypesMod , only : init_recruit_trim use shr_log_mod , only : errMsg => shr_log_errMsg use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun @@ -120,8 +121,6 @@ module EDPhysiologyMod integer, parameter :: dleafon_drycheck = 100 ! Drought deciduous leaves max days on check parameter - - ! ============================================================================ @@ -1450,9 +1449,9 @@ subroutine SeedIn( currentSite, bc_in ) case(carbon12_element) seed_stoich = 1._r8 case(nitrogen_element) - seed_stoich = prt_params%nitr_stoich_p2(pft,repro_organ) + seed_stoich = prt_params%nitr_recr_stoich(pft) case(phosphorus_element) - seed_stoich = prt_params%phos_stoich_p2(pft,repro_organ) + seed_stoich = prt_params%phos_recr_stoich(pft) case default write(fates_log(), *) 'undefined element specified' write(fates_log(), *) 'while defining forced external seed mass flux' @@ -1566,7 +1565,7 @@ end subroutine SeedGermination - + ! ===================================================================================== @@ -1623,7 +1622,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) do ft = 1,numpft if(currentSite%use_this_pft(ft).eq.itrue)then - temp_cohort%canopy_trim = 0.8_r8 !starting with the canopy not fully expanded + temp_cohort%canopy_trim = init_recruit_trim temp_cohort%pft = ft temp_cohort%hite = EDPftvarcon_inst%hgt_min(ft) temp_cohort%coage = 0.0_r8 @@ -1689,7 +1688,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) if ( (hlm_use_ed_prescribed_phys .eq. ifalse) .or. & (EDPftvarcon_inst%prescribed_recruitment(ft) .lt. 0._r8) ) then - temp_cohort%n = 1.e10_r8 + temp_cohort%n = 1.e20_r8 do el = 1,num_elements @@ -1697,24 +1696,25 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) select case(element_id) case(carbon12_element) - mass_demand = (c_struct+c_leaf+c_fnrt+c_sapw+c_store) + mass_demand = c_struct+c_leaf+c_fnrt+c_sapw+c_store case(nitrogen_element) - - mass_demand = (1._r8 + prt_params%nitr_stoich_p1(ft,store_organ)) * & - (c_struct*prt_params%nitr_stoich_p1(ft,struct_organ) + & - c_leaf*prt_params%nitr_stoich_p1(ft,leaf_organ) + & - c_fnrt*prt_params%nitr_stoich_p1(ft,fnrt_organ) + & - c_sapw*prt_params%nitr_stoich_p1(ft,sapw_organ)) + + mass_demand = & + c_struct*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + & + (1._r8 + prt_params%nitr_store_ratio(ft)) * & + (c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & + c_fnrt*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & + c_sapw*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) ) case(phosphorus_element) - mass_demand = (1._r8 + prt_params%phos_stoich_p1(ft,store_organ)) * & - (c_struct*prt_params%phos_stoich_p1(ft,struct_organ) + & - c_leaf*prt_params%phos_stoich_p1(ft,leaf_organ) + & - c_fnrt*prt_params%phos_stoich_p1(ft,fnrt_organ) + & - c_sapw*prt_params%phos_stoich_p1(ft,sapw_organ)) - + mass_demand = & + c_struct*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + & + (1._r8 + prt_params%phos_store_ratio(ft)) * & + (c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & + c_fnrt*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & + c_sapw*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) ) case default write(fates_log(),*) 'Undefined element type in recruitment' @@ -1768,22 +1768,22 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) case(nitrogen_element) - m_struct = c_struct*prt_params%nitr_stoich_p1(ft,struct_organ) - m_leaf = c_leaf*prt_params%nitr_stoich_p1(ft,leaf_organ) - m_fnrt = c_fnrt*prt_params%nitr_stoich_p1(ft,fnrt_organ) - m_sapw = c_sapw*prt_params%nitr_stoich_p1(ft,sapw_organ) - m_store = prt_params%nitr_stoich_p1(ft,store_organ) * & - (m_struct+m_leaf+m_fnrt+m_sapw) + m_struct = c_struct*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + m_leaf = c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + m_fnrt = c_fnrt*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + m_sapw = c_sapw*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) + m_store = prt_params%nitr_store_ratio(ft) * & + (m_leaf+m_fnrt+m_sapw) m_repro = 0._r8 case(phosphorus_element) - m_struct = c_struct*prt_params%phos_stoich_p1(ft,struct_organ) - m_leaf = c_leaf*prt_params%phos_stoich_p1(ft,leaf_organ) - m_fnrt = c_fnrt*prt_params%phos_stoich_p1(ft,fnrt_organ) - m_sapw = c_sapw*prt_params%phos_stoich_p1(ft,sapw_organ) - m_store = prt_params%phos_stoich_p1(ft,store_organ) * & - (m_struct+m_leaf+m_fnrt+m_sapw) + m_struct = c_struct*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + m_leaf = c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + m_fnrt = c_fnrt*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + m_sapw = c_sapw*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) + m_store = prt_params%phos_store_ratio(ft) * & + (m_leaf+m_fnrt+m_sapw) m_repro = 0._r8 end select diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index a87c8c2845..e238180aba 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -137,22 +137,21 @@ function GetPlantDemand(ccohort,element_id) result(plant_demand) if(ccohort%isnew) then if(element_id.eq.nitrogen_element) then - plant_max_x = & - ccohort%prt%GetState(leaf_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,leaf_organ) + & - ccohort%prt%GetState(fnrt_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,fnrt_organ) + & - ccohort%prt%GetState(store_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,store_organ) + & - ccohort%prt%GetState(sapw_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,sapw_organ) + & - ccohort%prt%GetState(struct_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,struct_organ) + & - ccohort%prt%GetState(repro_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,repro_organ) + plant_max_x = & + (1._r8 + prt_params%nitr_store_ratio(pft)) * & + (ccohort%prt%GetState(leaf_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(leaf_organ)) + & + ccohort%prt%GetState(fnrt_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(fnrt_organ)) + & + ccohort%prt%GetState(sapw_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(sapw_organ))) + & + ccohort%prt%GetState(struct_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(struct_organ)) + elseif(element_id.eq.phosphorus_element) then plant_max_x = & - ccohort%prt%GetState(leaf_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,leaf_organ) + & - ccohort%prt%GetState(fnrt_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,fnrt_organ) + & - ccohort%prt%GetState(store_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,store_organ) + & - ccohort%prt%GetState(sapw_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,sapw_organ) + & - ccohort%prt%GetState(struct_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,struct_organ) + & - ccohort%prt%GetState(repro_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,repro_organ) + (1._r8 + prt_params%phos_store_ratio(pft)) * & + (ccohort%prt%GetState(leaf_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(leaf_organ)) + & + ccohort%prt%GetState(fnrt_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(fnrt_organ)) + & + ccohort%prt%GetState(sapw_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(sapw_organ))) + & + ccohort%prt%GetState(struct_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(struct_organ)) end if @@ -1011,130 +1010,25 @@ function ECACScalar(ccohort, element_id) result(c_scalar) real(r8) :: c_scalar ! Locals - - real(r8) :: target_leaf_c ! maximum leaf C for this dbh [kg] - real(r8) :: target_store_c ! maximum store C for this dbh [kg] - ! - ! Where X is the element of interest: - real(r8) :: leaf_store_x ! Mass of current element in leaf and storage - real(r8) :: xc_actual ! Actual X:C ratio of plant - real(r8) :: xc_min ! Minimum allowable X:C ratio to build tissue - real(r8) :: xc_ideal ! Plant's ideal X:C ratio - real(r8) :: cx_actual ! Actual C:X ratio of plant - real(r8) :: cx_ideal ! Ideal C:X ratio of plant - real(r8) :: c_stoich_var ! effective variance of the CN or CP ratio real(r8) :: store_frac ! Current nutrient storage relative to max real(r8) :: store_max ! Maximum nutrient storable by plant - ! We are still testing different functional relationships for c_scalar, thus - ! three methods. Methods 1 and 2 are subtly different, but both increase neediness - ! as a plants NC or PC ratio decreases, and vice versa. The variance - ! parameter acts as a buffer on the steepness of the relationship. - ! Method 3 turns off neediness and sets it to 1 (always fully needy) - ! - ! method 1: cn_scalar = (nc_ideal - nc_actual + variance*nc_min)/(nc_ideal - nc_min + variance*nc_min) - ! - ! method 2: cn_scalar = (1/nc_actual - (1-variance)/nc_ideal)/(variance/nc_ideal) - ! - ! method force1: force the cn_scalar = 1 (100% need) for all situations - ! - ! method logi_store: cn_scalar follows a logistic function starting at 1 and dropping to a minimum value - ! as nutrient storage fraction of maximum goes from 0 to 1 - - integer, parameter :: cnp_scalar_method1 = 1 - integer, parameter :: cnp_scalar_method2 = 2 - integer, parameter :: cnp_scalar_force1 = 3 - integer, parameter :: cnp_scalar_logi_store = 4 - integer, parameter :: cnp_scalar_method = cnp_scalar_logi_store - - - real(r8), parameter :: cn_stoich_var=0.2 ! variability of CN ratio - real(r8), parameter :: cp_stoich_var=0.4 ! variability of CP ratio - real(r8), parameter :: logi_k = 35.0_r8 ! logistic function k real(r8), parameter :: store_x0 = 0.85 ! storage fraction inflection point real(r8), parameter :: logi_min = 0.001_r8 ! minimum cn_scalar for logistic - ! Target leaf biomass according to allometry and trimming - call bleaf(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,target_leaf_c) - call bstore_allom(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,target_store_c) - - leaf_store_x = max(rsnbl_math_prec,ccohort%prt%GetState(leaf_organ, element_id) + & - ccohort%prt%GetState(store_organ, element_id)) - - ! Calculate the ideal CN or CP ratio for leaves and storage organs - - if(element_id==nitrogen_element)then - - xc_ideal = ((target_leaf_c*prt_params%nitr_stoich_p2(ccohort%pft,leaf_organ)) + & - (target_store_c*prt_params%nitr_stoich_p2(ccohort%pft,store_organ))) / & - (target_leaf_c+target_store_c) - xc_min = ((target_leaf_c*prt_params%nitr_stoich_p1(ccohort%pft,leaf_organ)) + & - (target_store_c*prt_params%nitr_stoich_p1(ccohort%pft,store_organ))) / & - (target_leaf_c+target_store_c) - - xc_actual = max(leaf_store_x/(target_leaf_c+target_store_c),rsnbl_math_prec) - - c_stoich_var = cn_stoich_var - - elseif(element_id==phosphorus_element) then - - xc_ideal = ((target_leaf_c*prt_params%phos_stoich_p2(ccohort%pft,leaf_organ)) + & - (target_store_c*prt_params%phos_stoich_p2(ccohort%pft,store_organ))) / & - (target_leaf_c+target_store_c) - xc_min = ((target_leaf_c*prt_params%phos_stoich_p1(ccohort%pft,leaf_organ)) + & - (target_store_c*prt_params%phos_stoich_p1(ccohort%pft,store_organ))) / & - (target_leaf_c+target_store_c) - - xc_actual = max(leaf_store_x/(target_leaf_c+target_store_c),rsnbl_math_prec) - - c_stoich_var = cp_stoich_var - - else - write(fates_log(), *) 'attempted to call ECACScalar() for unknown element',element_id - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - select case(cnp_scalar_method) - case(cnp_scalar_method1) - - ! To-do: Add a logistic function here, with a - ! shape parameter so that 95%tile of - ! nutrient concentration matches 95%tile of scalar - ! 0.95 = 1._r8/(1._r8 + exp(-logi_k*( 0.95*(nc_ideal-x0) ))) - ! logi_k = -log(1._r8-0.95/0.95)/ ( 0.95*(nc_ideal-x0) ) - ! bc_out%cn_scalar(icomp) = 1._r8/(1._r8 + exp(-logi_k*(nc_actual-x0))) - - c_scalar = min(1._r8,max(0._r8, & - (xc_ideal - xc_actual + c_stoich_var*xc_min) / & - (xc_ideal - xc_min + c_stoich_var*xc_min))) - - case(cnp_scalar_method2) - - cx_ideal = 1._r8/xc_ideal - cx_actual = 1._r8/xc_actual - c_scalar = min(1._r8,max(0._r8, & - (cx_actual - cx_ideal*(1._r8-c_stoich_var))/(cx_ideal*c_stoich_var))) - - case(cnp_scalar_force1) - - c_scalar = 1 - - case(cnp_scalar_logi_store) - - ! In this method, we define the c_scalar term - ! with a logistic function that goes to 1 (full need) - ! as the plant's nutrien storage hits a low threshold - ! and goes to 0, no demand, as the plant's nutrient - ! storage approaches it's maximum holding capacity. - - store_max = ccohort%prt%GetNutrientTarget(element_id,store_organ,stoich_max) - store_frac = ccohort%prt%GetState(store_organ, element_id)/store_max - - c_scalar = logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))) + ! In this method, we define the c_scalar term + ! with a logistic function that goes to 1 (full need) + ! as the plant's nutrien storage hits a low threshold + ! and goes to 0, no demand, as the plant's nutrient + ! storage approaches it's maximum holding capacity. + + store_max = ccohort%prt%GetNutrientTarget(element_id,store_organ,stoich_max) + store_frac = ccohort%prt%GetState(store_organ, element_id)/store_max + + c_scalar = logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))) - end select + end function ECACScalar diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index bfe01d25be..41596c4f5e 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -456,7 +456,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) select case(hlm_parteh_mode) case (prt_carbon_allom_hyp) - lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) + lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) case (prt_cnp_flex_allom_hyp) @@ -465,12 +465,12 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) leaf_n = currentCohort%prt%GetState(leaf_organ, nitrogen_element) lnc_top = leaf_n / (slatop(ft) * leaf_c ) else - lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) + lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) end if ! If one wants to break coupling with dynamic N conentrations, ! use the stoichiometry parameter - ! lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) + ! lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) end select @@ -617,12 +617,12 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) case (prt_carbon_allom_hyp) live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & - sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) + sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & - sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) + sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) - fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,fnrt_organ) + fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(fnrt_organ)) case(prt_cnp_flex_allom_hyp) @@ -638,10 +638,10 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! use the stoichiometry parameter ! ! live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & - ! sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) + ! sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) ! live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & - ! sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) - ! fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,fnrt_organ) + ! sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) + ! fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(fnrt_organ)) case default diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 0b1b7490f4..c049e6ef69 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -589,21 +589,24 @@ subroutine init_cohorts( site_in, patch_in, bc_in) case(nitrogen_element) - m_struct = c_struct*prt_params%nitr_stoich_p2(pft,struct_organ) - m_leaf = c_leaf*prt_params%nitr_stoich_p2(pft,leaf_organ) - m_fnrt = c_fnrt*prt_params%nitr_stoich_p2(pft,fnrt_organ) - m_sapw = c_sapw*prt_params%nitr_stoich_p2(pft,sapw_organ) - m_store = c_store*prt_params%nitr_stoich_p2(pft,store_organ) + m_struct = c_struct*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(struct_organ)) + m_leaf = c_leaf*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(leaf_organ)) + m_fnrt = c_fnrt*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(fnrt_organ)) + m_sapw = c_sapw*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(sapw_organ)) + m_store = prt_params%nitr_store_ratio(pft) * & + (m_leaf+m_fnrt+m_sapw) m_repro = 0._r8 case(phosphorus_element) - m_struct = c_struct*prt_params%phos_stoich_p2(pft,struct_organ) - m_leaf = c_leaf*prt_params%phos_stoich_p2(pft,leaf_organ) - m_fnrt = c_fnrt*prt_params%phos_stoich_p2(pft,fnrt_organ) - m_sapw = c_sapw*prt_params%phos_stoich_p2(pft,sapw_organ) - m_store = c_store*prt_params%phos_stoich_p2(pft,store_organ) + m_struct = c_struct*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(struct_organ)) + m_leaf = c_leaf*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(leaf_organ)) + m_fnrt = c_fnrt*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(fnrt_organ)) + m_sapw = c_sapw*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(sapw_organ)) + m_store = prt_params%phos_store_ratio(pft) * & + (m_leaf+m_fnrt+m_sapw) m_repro = 0._r8 + end select select case(hlm_parteh_mode) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 4373ef24c0..52ecc1d4cd 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -41,7 +41,8 @@ module EDTypesMod ! space and output arrays. - + real(r8), parameter, public :: init_recruit_trim = 0.8_r8 ! This is the initial trimming value that + ! new recruits start with ! ------------------------------------------------------------------------------------- ! Radiation parameters diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index f84f6b5231..facd017357 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -63,7 +63,7 @@ module FatesInterfaceMod use PRTGenericMod , only : leaf_organ, fnrt_organ, store_organ use PRTGenericMod , only : sapw_organ, struct_organ, repro_organ use PRTParametersMod , only : prt_params - use PRTInitParamsFatesMod , only : PRTCheckParams + use PRTInitParamsFatesMod , only : PRTCheckParams, PRTDerivedParams use PRTAllometricCarbonMod , only : InitPRTGlobalAllometricCarbon use PRTAllometricCNPMod , only : InitPRTGlobalAllometricCNP @@ -1703,9 +1703,12 @@ subroutine FatesReportParameters(masterproc) call FatesReportPFTParams(masterproc) call FatesReportParams(masterproc) call FatesCheckParams(masterproc) ! Check general fates parameters + call PRTDerivedParams() ! Update PARTEH derived constants call PRTCheckParams(masterproc) ! Check PARTEH parameters call SpitFireCheckParams(masterproc) + + return end subroutine FatesReportParameters diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 74d88d7e9b..15e980cfa3 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -1086,21 +1086,47 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & case(nitrogen_element) - m_struct = c_struct*prt_params%nitr_stoich_p1(temp_cohort%pft,struct_organ) - m_leaf = c_leaf*prt_params%nitr_stoich_p1(temp_cohort%pft,leaf_organ) - m_fnrt = c_fnrt*prt_params%nitr_stoich_p1(temp_cohort%pft,fnrt_organ) - m_sapw = c_sapw*prt_params%nitr_stoich_p1(temp_cohort%pft,sapw_organ) - m_store = c_store*prt_params%nitr_stoich_p1(temp_cohort%pft,store_organ) + ! For inventory runs, initialize nutrient contents half way between max and min stoichiometries + m_struct = c_struct * 0.5_r8 * & + (prt_params%nitr_stoich_p1(temp_cohort%pft,prt_params%organ_param_id(struct_organ)) + & + prt_params%nitr_stoich_p2(temp_cohort%pft,prt_params%organ_param_id(struct_organ))) + + m_leaf = c_leaf * 0.5_r8 * & + (prt_params%nitr_stoich_p1(temp_cohort%pft,prt_params%organ_param_id(leaf_organ)) + & + prt_params%nitr_stoich_p2(temp_cohort%pft,prt_params%organ_param_id(leaf_organ))) + + m_fnrt = c_fnrt * 0.5_r8 * & + (prt_params%nitr_stoich_p1(temp_cohort%pft,prt_params%organ_param_id(fnrt_organ)) + & + prt_params%nitr_stoich_p2(temp_cohort%pft,prt_params%organ_param_id(fnrt_organ))) + + m_sapw = c_sapw * 0.5_r8 * & + (prt_params%nitr_stoich_p1(temp_cohort%pft,prt_params%organ_param_id(sapw_organ)) + & + prt_params%nitr_stoich_p2(temp_cohort%pft,prt_params%organ_param_id(sapw_organ))) + + m_store = prt_params%nitr_store_ratio(temp_cohort%pft) * (m_leaf+m_fnrt+m_sapw) m_repro = 0._r8 case(phosphorus_element) + + m_struct = c_struct * 0.5_r8 * & + (prt_params%phos_stoich_p1(temp_cohort%pft,prt_params%organ_param_id(struct_organ)) + & + prt_params%phos_stoich_p2(temp_cohort%pft,prt_params%organ_param_id(struct_organ))) + + m_leaf = c_leaf * 0.5_r8 * & + (prt_params%phos_stoich_p1(temp_cohort%pft,prt_params%organ_param_id(leaf_organ)) + & + prt_params%phos_stoich_p2(temp_cohort%pft,prt_params%organ_param_id(leaf_organ))) + + m_fnrt = c_fnrt * 0.5_r8 * & + (prt_params%phos_stoich_p1(temp_cohort%pft,prt_params%organ_param_id(fnrt_organ)) + & + prt_params%phos_stoich_p2(temp_cohort%pft,prt_params%organ_param_id(fnrt_organ))) + + m_sapw = c_sapw * 0.5_r8 * & + (prt_params%phos_stoich_p1(temp_cohort%pft,prt_params%organ_param_id(sapw_organ)) + & + prt_params%phos_stoich_p2(temp_cohort%pft,prt_params%organ_param_id(sapw_organ))) - m_struct = c_struct*prt_params%phos_stoich_p1(temp_cohort%pft,struct_organ) - m_leaf = c_leaf*prt_params%phos_stoich_p1(temp_cohort%pft,leaf_organ) - m_fnrt = c_fnrt*prt_params%phos_stoich_p1(temp_cohort%pft,fnrt_organ) - m_sapw = c_sapw*prt_params%phos_stoich_p1(temp_cohort%pft,sapw_organ) - m_store = c_store*prt_params%phos_stoich_p1(temp_cohort%pft,store_organ) + m_store = prt_params%phos_store_ratio(temp_cohort%pft) * (m_leaf+m_fnrt+m_sapw) m_repro = 0._r8 + end select select case(hlm_parteh_mode) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 1f813c4b4e..9de08b775c 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -9,7 +9,7 @@ dimensions: fates_leafage_class = 1 ; fates_litterclass = 6 ; fates_pft = 12 ; - fates_prt_organs = 6 ; + fates_prt_organs = 4 ; fates_string_length = 60 ; variables: double fates_history_ageclass_bin_edges(fates_history_age_bins) ; @@ -29,7 +29,10 @@ variables: fates_pftname:long_name = "Description of plant type" ; char fates_prt_organ_name(fates_prt_organs, fates_string_length) ; fates_prt_organ_name:units = "unitless - string" ; - fates_prt_organ_name:long_name = "Plant organ name (order must match PRTGenericMod.F90)" ; + fates_prt_organ_name:long_name = "Name of plant organs (order must match PRTGenericMod.F90)" ; + double fates_prt_organ_id(fates_prt_organs) ; + fates_prt_organ_id:units = "index, unitless" ; + fates_prt_organ_id:long_name = "This is the global index the organ in this file is associated with in PRTGenericMod.F90" ; double fates_alloc_storage_cushion(fates_pft) ; fates_alloc_storage_cushion:units = "fraction" ; fates_alloc_storage_cushion:long_name = "maximum size of storage C pool, relative to maximum size of leaf C pool" ; @@ -389,17 +392,17 @@ variables: fates_prescribed_npp_understory:units = "kgC / m^2 / yr" ; fates_prescribed_npp_understory:long_name = "NPP per unit crown area of understory trees for prescribed physiology mode" ; double fates_prescribed_nuptake(fates_pft) ; - fates_prescribed_nuptake:units = "fraction" ; - fates_prescribed_nuptake:long_name = "Nitrogen uptake flux as fraction of NPP demand. 0=fully coupled simulation" ; + fates_prescribed_nuptake:units = "fraction" ; + fates_prescribed_nuptake:long_name = "Prescribed N uptake flux. 0=fully coupled simulation >0=prescribed (experimental)" ; double fates_prescribed_puptake(fates_pft) ; fates_prescribed_puptake:units = "fraction" ; - fates_prescribed_puptake:long_name = "Phosphorus uptake flux as fraction of NPP demand. 0=fully coupled simulation" ; + fates_prescribed_puptake:long_name = "Prescribed P uptake flux. 0=fully coupled simulation, >0=prescribed (experimental)" ; double fates_prescribed_recruitment(fates_pft) ; fates_prescribed_recruitment:units = "n/yr" ; fates_prescribed_recruitment:long_name = "recruitment rate for prescribed physiology mode" ; double fates_prt_alloc_priority(fates_prt_organs, fates_pft) ; fates_prt_alloc_priority:units = "index (0-fates_prt_organs)" ; - fates_prt_alloc_priority:long_name = "Priority order for allocation" ; + fates_prt_alloc_priority:long_name = "Priority order for allocation (C storage=2)" ; double fates_prt_nitr_stoich_p1(fates_prt_organs, fates_pft) ; fates_prt_nitr_stoich_p1:units = "(gN/gC)" ; fates_prt_nitr_stoich_p1:long_name = "nitrogen stoichiometry, parameter 1" ; @@ -412,6 +415,13 @@ variables: double fates_prt_phos_stoich_p2(fates_prt_organs, fates_pft) ; fates_prt_phos_stoich_p2:units = "(gP/gC)" ; fates_prt_phos_stoich_p2:long_name = "phosphorous stoichiometry, parameter 2" ; + double fates_nitr_store_ratio(fates_pft) ; + fates_nitr_store_ratio:units = "(gN/gN)" ; + fates_nitr_store_ratio:long_name = "ratio of storeable N, to functional N bound in cell structures of leaf,root,sap" ; + double fates_phos_store_ratio(fates_pft) ; + fates_phos_store_ratio:units = "(gP/gP)" ; + fates_phos_store_ratio:long_name = "ratio of storeable P, to functional P bound in cell structures of leaf,root,sap" ; + double fates_recruit_hgt_min(fates_pft) ; fates_recruit_hgt_min:units = "m" ; fates_recruit_hgt_min:long_name = "the minimum height (ie starting height) of a newly recruited plant" ; @@ -718,10 +728,10 @@ data: "leaf ", "fine root ", "sapwood ", - "storage ", - "reproduction ", "structure " ; + fates_prt_organ_id = 1, 2, 3, 6 ; + fates_alloc_storage_cushion = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2 ; @@ -1071,9 +1081,9 @@ data: fates_prescribed_npp_understory = 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125 ; - fates_prescribed_nuptake = 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0 ; + fates_prescribed_nuptake = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ; - fates_prescribed_puptake = 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0 ; + fates_prescribed_puptake = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ; fates_prescribed_recruitment = 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02 ; @@ -1082,8 +1092,6 @@ data: 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 ; fates_prt_nitr_stoich_p1 = @@ -1092,9 +1100,6 @@ data: 0.024, 0.024, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, - 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, - 1e-08, 1e-08, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047 ; @@ -1104,9 +1109,6 @@ data: 0.024, 0.024, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, - 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, - 1e-08, 1e-08, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047 ; @@ -1117,9 +1119,6 @@ data: 0.0024, 0.0024, 0.0024, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, - 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, - 1e-09, 1e-09, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047 ; @@ -1130,12 +1129,13 @@ data: 0.0024, 0.0024, 0.0024, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, - 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, - 1e-09, 1e-09, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047 ; + fates_nitr_store_ratio = 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3; + + fates_phos_store_ratio = 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3; + fates_recruit_hgt_min = 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 0.75, 0.75, 0.75, 0.125, 0.125, 0.125 ; @@ -1196,8 +1196,6 @@ data: fates_trim_limit = 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3 ; fates_turnover_carb_retrans = - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, @@ -1207,16 +1205,12 @@ data: 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.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_turnover_phos_retrans = 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.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_turnover_retrans_mode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; diff --git a/parameter_files/fates_params_new.cdl b/parameter_files/fates_params_new.cdl new file mode 100644 index 0000000000..dbfb966bb2 --- /dev/null +++ b/parameter_files/fates_params_new.cdl @@ -0,0 +1,1369 @@ +netcdf fates_params_default { +dimensions: + fates_NCWD = 4 ; + fates_history_age_bins = 7 ; + fates_history_height_bins = 6 ; + fates_history_size_bins = 13 ; + fates_history_coage_bins = 2 ; + fates_hydr_organs = 4 ; + fates_leafage_class = 1 ; + fates_litterclass = 6 ; + fates_pft = 12 ; + fates_prt_organs = 4 ; + fates_string_length = 60 ; +variables: + double fates_history_ageclass_bin_edges(fates_history_age_bins) ; + fates_history_ageclass_bin_edges:units = "yr" ; + fates_history_ageclass_bin_edges:long_name = "Lower edges for age class bins used in age-resolved patch history output" ; + double fates_history_coageclass_bin_edges(fates_history_coage_bins) ; + fates_history_coageclass_bin_edges:units = "years" ; + fates_history_coageclass_bin_edges:long_name = "Lower edges for cohort age class bins used in cohort age resolved history output" ; + double fates_history_height_bin_edges(fates_history_height_bins) ; + fates_history_height_bin_edges:units = "m" ; + fates_history_height_bin_edges:long_name = "Lower edges for height bins used in height-resolved history output" ; + double fates_history_sizeclass_bin_edges(fates_history_size_bins) ; + fates_history_sizeclass_bin_edges:units = "cm" ; + fates_history_sizeclass_bin_edges:long_name = "Lower edges for DBH size class bins used in size-resolved cohort history output" ; + char fates_pftname(fates_pft, fates_string_length) ; + fates_pftname:units = "unitless - string" ; + fates_pftname:long_name = "Description of plant type" ; + char fates_prt_organ_name(fates_prt_organs, fates_string_length) ; + fates_prt_organ_name:units = "unitless - string" ; + fates_prt_organ_name:long_name = "Name of plant organs (order must match PRTGenericMod.F90)" ; + double fates_prt_organ_id(fates_prt_organs) ; + fates_prt_organ_id:units = "index, unitless" ; + fates_prt_organ_id:long_name = "This is the global index the organ in this file is associated with in PRTGenericMod.F90" ; + double fates_alloc_storage_cushion(fates_pft) ; + fates_alloc_storage_cushion:units = "fraction" ; + fates_alloc_storage_cushion:long_name = "maximum size of storage C pool, relative to maximum size of leaf C pool" ; + double fates_allom_agb1(fates_pft) ; + fates_allom_agb1:units = "variable" ; + fates_allom_agb1:long_name = "Parameter 1 for agb allometry" ; + double fates_allom_agb2(fates_pft) ; + fates_allom_agb2:units = "variable" ; + fates_allom_agb2:long_name = "Parameter 2 for agb allometry" ; + double fates_allom_agb3(fates_pft) ; + fates_allom_agb3:units = "variable" ; + fates_allom_agb3:long_name = "Parameter 3 for agb allometry" ; + double fates_allom_agb4(fates_pft) ; + fates_allom_agb4:units = "variable" ; + fates_allom_agb4:long_name = "Parameter 4 for agb allometry" ; + double fates_allom_agb_frac(fates_pft) ; + fates_allom_agb_frac:units = "fraction" ; + fates_allom_agb_frac:long_name = "Fraction of woody biomass that is above ground" ; + double fates_allom_amode(fates_pft) ; + fates_allom_amode:units = "index" ; + fates_allom_amode:long_name = "AGB allometry function index." ; + fates_allom_amode:possible_values = "1: Saldarriaga 1998; 2: 2 parameter power law; 3: Chave 2014" ; + double fates_allom_blca_expnt_diff(fates_pft) ; + fates_allom_blca_expnt_diff:units = "unitless" ; + fates_allom_blca_expnt_diff:long_name = "difference between allometric DBH:bleaf and DBH:crown area exponents" ; + double fates_allom_cmode(fates_pft) ; + fates_allom_cmode:units = "index" ; + fates_allom_cmode:long_name = "coarse root biomass allometry function index." ; + fates_allom_cmode:possible_values = "1: Constant fraction on AGB" ; + double fates_allom_d2bl1(fates_pft) ; + fates_allom_d2bl1:units = "variable" ; + fates_allom_d2bl1:long_name = "Parameter 1 for d2bl allometry" ; + double fates_allom_d2bl2(fates_pft) ; + fates_allom_d2bl2:units = "variable" ; + fates_allom_d2bl2:long_name = "Parameter 2 for d2bl allometry" ; + double fates_allom_d2bl3(fates_pft) ; + fates_allom_d2bl3:units = "unitless" ; + fates_allom_d2bl3:long_name = "Parameter 3 for d2bl allometry" ; + double fates_allom_d2ca_coefficient_max(fates_pft) ; + fates_allom_d2ca_coefficient_max:units = "m2 cm^(-1/beta)" ; + fates_allom_d2ca_coefficient_max:long_name = "max (savanna) dbh to area multiplier factor where: area = n*d2ca_coeff*dbh^beta" ; + double fates_allom_d2ca_coefficient_min(fates_pft) ; + fates_allom_d2ca_coefficient_min:units = "m2 cm^(-1/beta)" ; + fates_allom_d2ca_coefficient_min:long_name = "min (forest) dbh to area multiplier factor where: area = n*d2ca_coeff*dbh^beta" ; + double fates_allom_d2h1(fates_pft) ; + fates_allom_d2h1:units = "variable" ; + fates_allom_d2h1:long_name = "Parameter 1 for d2h allometry (intercept, or c)" ; + double fates_allom_d2h2(fates_pft) ; + fates_allom_d2h2:units = "variable" ; + fates_allom_d2h2:long_name = "Parameter 2 for d2h allometry (slope, or m)" ; + double fates_allom_d2h3(fates_pft) ; + fates_allom_d2h3:units = "variable" ; + fates_allom_d2h3:long_name = "Parameter 3 for d2h allometry (optional)" ; + double fates_allom_dbh_maxheight(fates_pft) ; + fates_allom_dbh_maxheight:units = "cm" ; + fates_allom_dbh_maxheight:long_name = "the diameter (if any) corresponding to maximum height, diameters may increase beyond this" ; + double fates_allom_fmode(fates_pft) ; + fates_allom_fmode:units = "index" ; + fates_allom_fmode:long_name = "fine root biomass allometry function index." ; + fates_allom_fmode:possible_values = "1: constant fraction of trimmed bleaf; 2: constant fraction of untrimmed bleaf." ; + double fates_allom_frbstor_repro(fates_pft) ; + fates_allom_frbstor_repro:units = "fraction" ; + fates_allom_frbstor_repro:long_name = "fraction of bstore goes to reproduction after plant dies" ; + double fates_allom_hmode(fates_pft) ; + fates_allom_hmode:units = "index" ; + fates_allom_hmode:long_name = "height allometry function index." ; + fates_allom_hmode:possible_values = "1: OBrien 1995; 2: Poorter 2006; 3: 2 parameter power law; 4: Chave 2014; 5: Martinez-Cano 2019." ; + double fates_allom_l2fr(fates_pft) ; + fates_allom_l2fr:units = "gC/gC" ; + fates_allom_l2fr:long_name = "Allocation parameter: fine root C per leaf C" ; + double fates_allom_la_per_sa_int(fates_pft) ; + fates_allom_la_per_sa_int:units = "m2/cm2" ; + fates_allom_la_per_sa_int:long_name = "Leaf area per sapwood area, intercept" ; + double fates_allom_la_per_sa_slp(fates_pft) ; + fates_allom_la_per_sa_slp:units = "m2/cm2/m" ; + fates_allom_la_per_sa_slp:long_name = "Leaf area per sapwood area rate of change with height, slope (optional)" ; + double fates_allom_lmode(fates_pft) ; + fates_allom_lmode:units = "index" ; + fates_allom_lmode:long_name = "leaf biomass allometry function index." ; + fates_allom_lmode:possible_values = "1: Saldarriaga 1998 (capped-dbh power law); 2: generic power law; 3: generic capped-dbh power law." ; + double fates_allom_sai_scaler(fates_pft) ; + fates_allom_sai_scaler:units = "m2/m2" ; + fates_allom_sai_scaler:long_name = "allometric ratio of SAI per LAI" ; + double fates_allom_smode(fates_pft) ; + fates_allom_smode:units = "index" ; + fates_allom_smode:long_name = "sapwood allometry function index." ; + fates_allom_smode:possible_values = "1: sapwood area proportional to leaf area based on target leaf biomass" ; + double fates_allom_stmode(fates_pft) ; + fates_allom_stmode:units = "index" ; + fates_allom_stmode:long_name = "storage allometry function index." ; + fates_allom_stmode:possible_values = "1: target storage proportional to trimmed maximum leaf biomass." ; + double fates_branch_turnover(fates_pft) ; + fates_branch_turnover:units = "yr" ; + fates_branch_turnover:long_name = "turnover time of branches" ; + double fates_c2b(fates_pft) ; + fates_c2b:units = "ratio" ; + fates_c2b:long_name = "Carbon to biomass multiplier of bulk structural tissues" ; + double fates_displar(fates_pft) ; + fates_displar:units = "unitless" ; + fates_displar:long_name = "Ratio of displacement height to canopy top height" ; + double fates_eca_alpha_ptase(fates_pft) ; + fates_eca_alpha_ptase:units = "g/m3" ; + fates_eca_alpha_ptase:long_name = "fraction of P from ptase activity sent directly to plant (ECA)" ; + double fates_eca_decompmicc(fates_pft) ; + fates_eca_decompmicc:units = "gC/m3" ; + fates_eca_decompmicc:long_name = "mean soil microbial decomposer biomass (ECA)" ; + double fates_eca_km_nh4(fates_pft) ; + fates_eca_km_nh4:units = "gN/m3" ; + fates_eca_km_nh4:long_name = "half-saturation constant for plant nh4 uptake (ECA)" ; + double fates_eca_km_no3(fates_pft) ; + fates_eca_km_no3:units = "gN/m3" ; + fates_eca_km_no3:long_name = "half-saturation constant for plant no3 uptake (ECA)" ; + double fates_eca_km_p(fates_pft) ; + fates_eca_km_p:units = "gP/m3" ; + fates_eca_km_p:long_name = "half-saturation constant for plant p uptake (ECA)" ; + double fates_eca_km_ptase(fates_pft) ; + fates_eca_km_ptase:units = "gP/m3" ; + fates_eca_km_ptase:long_name = "half-saturation constant for biochemical P (ECA)" ; + double fates_eca_lambda_ptase(fates_pft) ; + fates_eca_lambda_ptase:units = "g/m3" ; + fates_eca_lambda_ptase:long_name = "critical value for biochemical production (ECA)" ; + double fates_eca_vmax_nh4(fates_pft) ; + fates_eca_vmax_nh4:units = "gN/gC/s" ; + fates_eca_vmax_nh4:long_name = "maximum production rate for plant nh4 uptake (ECA)" ; + double fates_eca_vmax_no3(fates_pft) ; + fates_eca_vmax_no3:units = "gN/gC/s" ; + fates_eca_vmax_no3:long_name = "maximum production rate for plant no3 uptake (ECA)" ; + double fates_eca_vmax_p(fates_pft) ; + fates_eca_vmax_p:units = "gP/gC/s" ; + fates_eca_vmax_p:long_name = "maximum production rate for plant p uptake (ECA)" ; + double fates_eca_vmax_ptase(fates_pft) ; + fates_eca_vmax_ptase:units = "gP/m2/s" ; + fates_eca_vmax_ptase:long_name = "maximum production rate for biochemical P (per m2) (ECA)" ; + double fates_fire_alpha_SH(fates_pft) ; + fates_fire_alpha_SH:units = "NA" ; + fates_fire_alpha_SH:long_name = "spitfire parameter, alpha scorch height, Equation 16 Thonicke et al 2010" ; + double fates_fire_bark_scaler(fates_pft) ; + fates_fire_bark_scaler:units = "fraction" ; + fates_fire_bark_scaler:long_name = "the thickness of a cohorts bark as a fraction of its dbh" ; + double fates_fire_crown_depth_frac(fates_pft) ; + fates_fire_crown_depth_frac:units = "fraction" ; + fates_fire_crown_depth_frac:long_name = "the depth of a cohorts crown as a fraction of its height" ; + double fates_fire_crown_kill(fates_pft) ; + fates_fire_crown_kill:units = "NA" ; + fates_fire_crown_kill:long_name = "fire parameter, see equation 22 in Thonicke et al 2010" ; + double fates_fnrt_prof_a(fates_pft) ; + fates_fnrt_prof_a:units = "unitless" ; + fates_fnrt_prof_a:long_name = "Fine root profile function, parameter a" ; + double fates_fnrt_prof_b(fates_pft) ; + fates_fnrt_prof_b:units = "unitless" ; + fates_fnrt_prof_b:long_name = "Fine root profile function, parameter b" ; + double fates_fnrt_prof_mode(fates_pft) ; + fates_fnrt_prof_mode:units = "index" ; + fates_fnrt_prof_mode:long_name = "Index to select fine root profile function: 1) Jackson Beta, 2) 1-param exponential 3) 2-param exponential" ; + double fates_fr_fcel(fates_pft) ; + fates_fr_fcel:units = "fraction" ; + fates_fr_fcel:long_name = "Fine root litter cellulose fraction" ; + double fates_fr_flab(fates_pft) ; + fates_fr_flab:units = "fraction" ; + fates_fr_flab:long_name = "Fine root litter labile fraction" ; + double fates_fr_flig(fates_pft) ; + fates_fr_flig:units = "fraction" ; + fates_fr_flig:long_name = "Fine root litter lignin fraction" ; + double fates_grperc(fates_pft) ; + fates_grperc:units = "unitless" ; + fates_grperc:long_name = "Growth respiration factor" ; + double fates_hydr_avuln_gs(fates_pft) ; + fates_hydr_avuln_gs:units = "unitless" ; + fates_hydr_avuln_gs:long_name = "shape parameter for stomatal control of water vapor exiting leaf" ; + double fates_hydr_avuln_node(fates_hydr_organs, fates_pft) ; + fates_hydr_avuln_node:units = "unitless" ; + fates_hydr_avuln_node:long_name = "xylem vulnerability curve shape parameter" ; + double fates_hydr_epsil_node(fates_hydr_organs, fates_pft) ; + fates_hydr_epsil_node:units = "MPa" ; + 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 non-residual water that is capillary in source" ; + double fates_hydr_kmax_node(fates_hydr_organs, fates_pft) ; + fates_hydr_kmax_node:units = "kg/MPa/m/s" ; + fates_hydr_kmax_node:long_name = "maximum xylem conductivity per unit conducting xylem area" ; + double fates_hydr_p50_gs(fates_pft) ; + fates_hydr_p50_gs:units = "MPa" ; + fates_hydr_p50_gs:long_name = "water potential at 50% loss of stomatal conductance" ; + double fates_hydr_p50_node(fates_hydr_organs, fates_pft) ; + fates_hydr_p50_node:units = "MPa" ; + fates_hydr_p50_node:long_name = "xylem water potential at 50% loss of conductivity" ; + double fates_hydr_p_taper(fates_pft) ; + fates_hydr_p_taper:units = "unitless" ; + fates_hydr_p_taper:long_name = "xylem taper exponent" ; + double fates_hydr_pinot_node(fates_hydr_organs, fates_pft) ; + fates_hydr_pinot_node:units = "MPa" ; + fates_hydr_pinot_node:long_name = "osmotic potential at full turgor" ; + double fates_hydr_pitlp_node(fates_hydr_organs, fates_pft) ; + 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 = "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" ; + double fates_hydr_rs2(fates_pft) ; + fates_hydr_rs2:units = "m" ; + fates_hydr_rs2:long_name = "absorbing root radius" ; + double fates_hydr_srl(fates_pft) ; + fates_hydr_srl:units = "m g-1" ; + fates_hydr_srl:long_name = "specific root length" ; + double fates_hydr_thetas_node(fates_hydr_organs, fates_pft) ; + fates_hydr_thetas_node:units = "cm3/cm3" ; + fates_hydr_thetas_node:long_name = "saturated water content" ; + double fates_leaf_c3psn(fates_pft) ; + fates_leaf_c3psn:units = "flag" ; + fates_leaf_c3psn:long_name = "Photosynthetic pathway (1=c3, 0=c4)" ; + double fates_leaf_clumping_index(fates_pft) ; + fates_leaf_clumping_index:units = "fraction (0-1)" ; + fates_leaf_clumping_index:long_name = "factor describing how much self-occlusion of leaf scattering elements decreases light interception" ; + double fates_leaf_diameter(fates_pft) ; + fates_leaf_diameter:units = "m" ; + fates_leaf_diameter:long_name = "Characteristic leaf dimension" ; + double fates_leaf_flnr(fates_pft) ; + fates_leaf_flnr:units = "gN Rubisco / gN leaf" + fates_leaf_flnr:long_name = "(NOT ACTIVE) when leaf_photo_model = 2, fraction of leaf N in the Rubisco enzyme" + double fates_leaf_vcmax_np1(fates_leafage_class,fates_pft) ; + fates_leaf_vcmax_np1:units = "" + fates_leaf_vcmax_np1:long_name = "(NOT ACTIVE) when leaf_photo_model = 2, vcmax~np relationship coefficient" + double fates_leaf_vcmax_np2(fates_leafage_class,fates_pft) ; + fates_leaf_vcmax_np2:units = "" + fates_leaf_vcmax_np2:long_name = "(NOT ACTIVE) when leaf_photo_model = 2, vcmax~np relationship coefficient" + double fates_leaf_vcmax_np3(fates_leafage_class,fates_pft) ; + fates_leaf_vcmax_np3:units = "" + fates_leaf_vcmax_np3:long_name = "(NOT ACTIVE) when leaf_photo_model = 2, vcmax~np relationship coefficient" + double fates_leaf_vcmax_np4(fates_leafage_class,fates_pft) ; + fates_leaf_vcmax_np4:units = "" + fates_leaf_vcmax_np4:long_name = "(NOT ACTIVE) when leaf_photo_model = 2, vcmax~np relationship coefficient" + double fates_leaf_jmaxha(fates_pft) ; + fates_leaf_jmaxha:units = "J/mol" ; + fates_leaf_jmaxha:long_name = "activation energy for jmax" ; + double fates_leaf_jmaxhd(fates_pft) ; + fates_leaf_jmaxhd:units = "J/mol" ; + fates_leaf_jmaxhd:long_name = "deactivation energy for jmax" ; + double fates_leaf_jmaxse(fates_pft) ; + fates_leaf_jmaxse:units = "J/mol/K" ; + fates_leaf_jmaxse:long_name = "entropy term for jmax" ; + double fates_leaf_long(fates_leafage_class, fates_pft) ; + fates_leaf_long:units = "yr" ; + fates_leaf_long:long_name = "Leaf longevity (ie turnover timescale)" ; + double fates_leaf_slamax(fates_pft) ; + fates_leaf_slamax:units = "m^2/gC" ; + fates_leaf_slamax:long_name = "Maximum Specific Leaf Area (SLA), even if under a dense canopy" ; + double fates_leaf_slatop(fates_pft) ; + fates_leaf_slatop:units = "m^2/gC" ; + fates_leaf_slatop:long_name = "Specific Leaf Area (SLA) at top of canopy, projected area basis" ; + double fates_leaf_stomatal_intercept(fates_pft) ; + fates_leaf_stomatal_intercept:units = "umol H2O/m**2/s" ; + fates_leaf_stomatal_intercept:long_name = "Minimum unstressed stomatal conductance for Ball-Berry model and Medlyn model" ; + double fates_leaf_stomatal_slope_ballberry(fates_pft) ; + fates_leaf_stomatal_slope_ballberry:units = "unitless" ; + fates_leaf_stomatal_slope_ballberry:long_name = "stomatal slope parameter, as per Ball-Berry" ; + double fates_leaf_stomatal_slope_medlyn(fates_pft) ; + fates_leaf_stomatal_slope_medlyn:units = "KPa**0.5" ; + fates_leaf_stomatal_slope_medlyn:long_name = "stomatal slope parameter, as per Medlyn" ; + double fates_leaf_stor_priority(fates_pft) ; + fates_leaf_stor_priority:units = "unitless" ; + fates_leaf_stor_priority:long_name = "factor governing priority of replacing storage with NPP" ; + double fates_leaf_tpuha(fates_pft) ; + fates_leaf_tpuha:units = "J/mol" ; + fates_leaf_tpuha:long_name = "activation energy for tpu" ; + double fates_leaf_tpuhd(fates_pft) ; + fates_leaf_tpuhd:units = "J/mol" ; + fates_leaf_tpuhd:long_name = "deactivation energy for tpu" ; + double fates_leaf_tpuse(fates_pft) ; + fates_leaf_tpuse:units = "J/mol/K" ; + fates_leaf_tpuse:long_name = "entropy term for tpu" ; + double fates_leaf_vcmax25top(fates_leafage_class, fates_pft) ; + fates_leaf_vcmax25top:units = "umol CO2/m^2/s" ; + fates_leaf_vcmax25top:long_name = "maximum carboxylation rate of Rub. at 25C, canopy top" ; + double fates_leaf_vcmaxha(fates_pft) ; + fates_leaf_vcmaxha:units = "J/mol" ; + fates_leaf_vcmaxha:long_name = "activation energy for vcmax" ; + double fates_leaf_vcmaxhd(fates_pft) ; + fates_leaf_vcmaxhd:units = "J/mol" ; + fates_leaf_vcmaxhd:long_name = "deactivation energy for vcmax" ; + double fates_leaf_vcmaxse(fates_pft) ; + fates_leaf_vcmaxse:units = "J/mol/K" ; + fates_leaf_vcmaxse:long_name = "entropy term for vcmax" ; + double fates_leaf_xl(fates_pft) ; + fates_leaf_xl:units = "unitless" ; + fates_leaf_xl:long_name = "Leaf/stem orientation index" ; + double fates_lf_fcel(fates_pft) ; + fates_lf_fcel:units = "fraction" ; + fates_lf_fcel:long_name = "Leaf litter cellulose fraction" ; + double fates_lf_flab(fates_pft) ; + fates_lf_flab:units = "fraction" ; + fates_lf_flab:long_name = "Leaf litter labile fraction" ; + double fates_lf_flig(fates_pft) ; + fates_lf_flig:units = "fraction" ; + fates_lf_flig:long_name = "Leaf litter lignin fraction" ; + double fates_maintresp_reduction_curvature(fates_pft) ; + fates_maintresp_reduction_curvature:units = "unitless (0-1)" ; + fates_maintresp_reduction_curvature:long_name = "curvature of MR reduction as f(carbon storage), 1=linear, 0=very curved" ; + double fates_maintresp_reduction_intercept(fates_pft) ; + fates_maintresp_reduction_intercept:units = "unitless (0-1)" ; + fates_maintresp_reduction_intercept:long_name = "intercept of MR reduction as f(carbon storage), 0=no throttling, 1=max throttling" ; + double fates_mort_bmort(fates_pft) ; + fates_mort_bmort:units = "1/yr" ; + fates_mort_bmort:long_name = "background mortality rate" ; + double fates_mort_freezetol(fates_pft) ; + fates_mort_freezetol:units = "degrees C" ; + fates_mort_freezetol:long_name = "minimum temperature tolerance" ; + double fates_mort_hf_flc_threshold(fates_pft) ; + fates_mort_hf_flc_threshold:units = "fraction" ; + fates_mort_hf_flc_threshold:long_name = "plant fractional loss of conductivity at which drought mortality begins for hydraulic model" ; + double fates_mort_hf_sm_threshold(fates_pft) ; + fates_mort_hf_sm_threshold:units = "unitless" ; + fates_mort_hf_sm_threshold:long_name = "soil moisture (btran units) at which drought mortality begins for non-hydraulic model" ; + double fates_mort_ip_age_senescence(fates_pft) ; + fates_mort_ip_age_senescence:units = "years" ; + fates_mort_ip_age_senescence:long_name = "Mortality cohort age senescence inflection point. If _ this mortality term is off. Setting this value turns on age dependent mortality. " ; + double fates_mort_ip_size_senescence(fates_pft) ; + fates_mort_ip_size_senescence:units = "dbh cm" ; + fates_mort_ip_size_senescence:long_name = "Mortality dbh senescence inflection point. If _ this mortality term is off. Setting this value turns on size dependent mortality" ; + double fates_mort_r_age_senescence(fates_pft) ; + fates_mort_r_age_senescence:units = "mortality rate year^-1" ; + fates_mort_r_age_senescence:long_name = "Mortality age senescence rate of change. Sensible range is around 0.03-0.06. Larger values givesteeper mortality curves." ; + double fates_mort_r_size_senescence(fates_pft) ; + fates_mort_r_size_senescence:units = "mortality rate dbh^-1" ; + fates_mort_r_size_senescence:long_name = "Mortality dbh senescence rate of change. Sensible range is around 0.03-0.06. Larger values give steeper mortality curves." ; + double fates_mort_scalar_coldstress(fates_pft) ; + fates_mort_scalar_coldstress:units = "1/yr" ; + fates_mort_scalar_coldstress:long_name = "maximum mortality rate from cold stress" ; + double fates_mort_scalar_cstarvation(fates_pft) ; + fates_mort_scalar_cstarvation:units = "1/yr" ; + fates_mort_scalar_cstarvation:long_name = "maximum mortality rate from carbon starvation" ; + double fates_mort_scalar_hydrfailure(fates_pft) ; + fates_mort_scalar_hydrfailure:units = "1/yr" ; + fates_mort_scalar_hydrfailure:long_name = "maximum mortality rate from hydraulic failure" ; + double fates_nfix1(fates_pft) ; + fates_nfix1:units = "NA" ; + fates_nfix1:long_name = "place-holder for future n-fixation parameter (NOT IMPLEMENTED)" ; + double fates_nfix2(fates_pft) ; + fates_nfix2:units = "NA" ; + fates_nfix2:long_name = "place-holder for future n-fixation parameter (NOT IMPLEMENTED)" ; + double fates_phen_cold_size_threshold(fates_pft) ; + fates_phen_cold_size_threshold:units = "cm" ; + fates_phen_cold_size_threshold:long_name = "the dbh size above which will lead to phenology-related stem and leaf drop" ; + double fates_phen_evergreen(fates_pft) ; + fates_phen_evergreen:units = "logical flag" ; + fates_phen_evergreen:long_name = "Binary flag for evergreen leaf habit" ; + double fates_phen_season_decid(fates_pft) ; + fates_phen_season_decid:units = "logical flag" ; + fates_phen_season_decid:long_name = "Binary flag for seasonal-deciduous leaf habit" ; + double fates_phen_stem_drop_fraction(fates_pft) ; + fates_phen_stem_drop_fraction:units = "fraction" ; + fates_phen_stem_drop_fraction:long_name = "fraction of stems to drop for non-woody species during drought/cold" ; + double fates_phen_stress_decid(fates_pft) ; + fates_phen_stress_decid:units = "logical flag" ; + fates_phen_stress_decid:long_name = "Binary flag for stress-deciduous leaf habit" ; + double fates_phenflush_fraction(fates_pft) ; + fates_phenflush_fraction:units = "fraction" ; + fates_phenflush_fraction:long_name = "Upon bud-burst, the maximum fraction of storage carbon used for flushing leaves" ; + double fates_prescribed_mortality_canopy(fates_pft) ; + fates_prescribed_mortality_canopy:units = "1/yr" ; + fates_prescribed_mortality_canopy:long_name = "mortality rate of canopy trees for prescribed physiology mode" ; + double fates_prescribed_mortality_understory(fates_pft) ; + fates_prescribed_mortality_understory:units = "1/yr" ; + fates_prescribed_mortality_understory:long_name = "mortality rate of understory trees for prescribed physiology mode" ; + double fates_prescribed_npp_canopy(fates_pft) ; + fates_prescribed_npp_canopy:units = "kgC / m^2 / yr" ; + fates_prescribed_npp_canopy:long_name = "NPP per unit crown area of canopy trees for prescribed physiology mode" ; + double fates_prescribed_npp_understory(fates_pft) ; + fates_prescribed_npp_understory:units = "kgC / m^2 / yr" ; + fates_prescribed_npp_understory:long_name = "NPP per unit crown area of understory trees for prescribed physiology mode" ; + double fates_prescribed_nuptake(fates_pft) ; + fates_prescribed_nuptake:units = "fraction" ; + fates_prescribed_nuptake:long_name = "Prescribed N uptake flux. 0=fully coupled simulation >0=prescribed (experimental)" ; + double fates_prescribed_puptake(fates_pft) ; + fates_prescribed_puptake:units = "fraction" ; + fates_prescribed_puptake:long_name = "Prescribed P uptake flux. 0=fully coupled simulation, >0=prescribed (experimental)" ; + double fates_prescribed_recruitment(fates_pft) ; + fates_prescribed_recruitment:units = "n/yr" ; + fates_prescribed_recruitment:long_name = "recruitment rate for prescribed physiology mode" ; + double fates_prt_alloc_priority(fates_prt_organs, fates_pft) ; + fates_prt_alloc_priority:units = "index (0-fates_prt_organs)" ; + fates_prt_alloc_priority:long_name = "Priority order for allocation (C storage=2)" ; + double fates_prt_nitr_stoich_p1(fates_prt_organs, fates_pft) ; + fates_prt_nitr_stoich_p1:units = "(gN/gC)" ; + fates_prt_nitr_stoich_p1:long_name = "nitrogen stoichiometry, parameter 1" ; + double fates_prt_nitr_stoich_p2(fates_prt_organs, fates_pft) ; + fates_prt_nitr_stoich_p2:units = "(gN/gC)" ; + fates_prt_nitr_stoich_p2:long_name = "nitrogen stoichiometry, parameter 2" ; + double fates_prt_phos_stoich_p1(fates_prt_organs, fates_pft) ; + fates_prt_phos_stoich_p1:units = "(gP/gC)" ; + fates_prt_phos_stoich_p1:long_name = "phosphorous stoichiometry, parameter 1" ; + double fates_prt_phos_stoich_p2(fates_prt_organs, fates_pft) ; + fates_prt_phos_stoich_p2:units = "(gP/gC)" ; + fates_prt_phos_stoich_p2:long_name = "phosphorous stoichiometry, parameter 2" ; + double fates_nitr_store_ratio(fates_pft) ; + fates_nitr_store_ratio:units = "(gN/gN)" ; + fates_nitr_store_ratio:long_name = "ratio of storeable N, to functional N bound in cell structures of leaf,root,sap" ; + double fates_phos_store_ratio(fates_pft) ; + fates_phos_store_ratio:units = "(gP/gP)" ; + fates_phos_store_ratio:long_name = "ratio of storeable P, to functional P bound in cell structures of leaf,root,sap" ; + + double fates_recruit_hgt_min(fates_pft) ; + fates_recruit_hgt_min:units = "m" ; + fates_recruit_hgt_min:long_name = "the minimum height (ie starting height) of a newly recruited plant" ; + double fates_recruit_initd(fates_pft) ; + fates_recruit_initd:units = "stems/m2" ; + fates_recruit_initd:long_name = "initial seedling density for a cold-start near-bare-ground simulation" ; + double fates_rholnir(fates_pft) ; + fates_rholnir:units = "fraction" ; + fates_rholnir:long_name = "Leaf reflectance: near-IR" ; + double fates_rholvis(fates_pft) ; + fates_rholvis:units = "fraction" ; + fates_rholvis:long_name = "Leaf reflectance: visible" ; + double fates_rhosnir(fates_pft) ; + fates_rhosnir:units = "fraction" ; + fates_rhosnir:long_name = "Stem reflectance: near-IR" ; + double fates_rhosvis(fates_pft) ; + fates_rhosvis:units = "fraction" ; + fates_rhosvis:long_name = "Stem reflectance: visible" ; + double fates_root_long(fates_pft) ; + fates_root_long:units = "yr" ; + fates_root_long:long_name = "root longevity (alternatively, turnover time)" ; + double fates_seed_alloc(fates_pft) ; + fates_seed_alloc:units = "fraction" ; + fates_seed_alloc:long_name = "fraction of available carbon balance allocated to seeds" ; + double fates_seed_alloc_mature(fates_pft) ; + fates_seed_alloc_mature:units = "fraction" ; + fates_seed_alloc_mature:long_name = "fraction of available carbon balance allocated to seeds in mature plants (adds to fates_seed_alloc)" ; + double fates_seed_dbh_repro_threshold(fates_pft) ; + fates_seed_dbh_repro_threshold:units = "cm" ; + fates_seed_dbh_repro_threshold:long_name = "the diameter (if any) where the plant will start extra clonal allocation to the seed pool" ; + double fates_seed_decay_rate(fates_pft) ; + fates_seed_decay_rate:units = "yr-1" ; + fates_seed_decay_rate:long_name = "fraction of seeds that decay per year" ; + double fates_seed_germination_rate(fates_pft) ; + fates_seed_germination_rate:units = "yr-1" ; + fates_seed_germination_rate:long_name = "fraction of seeds that germinate per year" ; + double fates_seed_suppl(fates_pft) ; + fates_seed_suppl:units = "KgC/m2/yr" ; + fates_seed_suppl:long_name = "Supplemental external seed rain source term (non-mass conserving)" ; + double fates_senleaf_long_fdrought(fates_pft) ; + fates_senleaf_long_fdrought:units = "unitless[0-1]" ; + fates_senleaf_long_fdrought:long_name = "multiplication factor for leaf longevity of senescent leaves during drought" ; + double fates_smpsc(fates_pft) ; + fates_smpsc:units = "mm" ; + fates_smpsc:long_name = "Soil water potential at full stomatal closure" ; + double fates_smpso(fates_pft) ; + fates_smpso:units = "mm" ; + fates_smpso:long_name = "Soil water potential at full stomatal opening" ; + double fates_taulnir(fates_pft) ; + fates_taulnir:units = "fraction" ; + fates_taulnir:long_name = "Leaf transmittance: near-IR" ; + double fates_taulvis(fates_pft) ; + fates_taulvis:units = "fraction" ; + fates_taulvis:long_name = "Leaf transmittance: visible" ; + double fates_tausnir(fates_pft) ; + fates_tausnir:units = "fraction" ; + fates_tausnir:long_name = "Stem transmittance: near-IR" ; + double fates_tausvis(fates_pft) ; + fates_tausvis:units = "fraction" ; + fates_tausvis:long_name = "Stem transmittance: visible" ; + double fates_trim_inc(fates_pft) ; + fates_trim_inc:units = "m2/m2" ; + fates_trim_inc:long_name = "Arbitrary incremental change in trimming function." ; + double fates_trim_limit(fates_pft) ; + fates_trim_limit:units = "m2/m2" ; + fates_trim_limit:long_name = "Arbitrary limit to reductions in leaf area with stress" ; + double fates_turnover_carb_retrans(fates_prt_organs, fates_pft) ; + fates_turnover_carb_retrans:units = "-" ; + fates_turnover_carb_retrans:long_name = "retranslocation fraction of carbon in turnover" ; + double fates_turnover_nitr_retrans(fates_prt_organs, fates_pft) ; + fates_turnover_nitr_retrans:units = "-" ; + fates_turnover_nitr_retrans:long_name = "retranslocation fraction of nitrogen in turnover" ; + double fates_turnover_phos_retrans(fates_prt_organs, fates_pft) ; + fates_turnover_phos_retrans:units = "-" ; + fates_turnover_phos_retrans:long_name = "retranslocation fraction of phosphorous in turnover, parameter 1" ; + double fates_turnover_retrans_mode(fates_pft) ; + fates_turnover_retrans_mode:units = "index" ; + fates_turnover_retrans_mode:long_name = "retranslocation method for leaf/fineroot turnover." ; + fates_turnover_retrans_mode:possible_values = "1: constant fraction." ; + double fates_wood_density(fates_pft) ; + fates_wood_density:units = "g/cm3" ; + fates_wood_density:long_name = "mean density of woody tissue in plant" ; + double fates_woody(fates_pft) ; + fates_woody:units = "logical flag" ; + fates_woody:long_name = "Binary woody lifeform flag" ; + double fates_z0mr(fates_pft) ; + fates_z0mr:units = "unitless" ; + fates_z0mr:long_name = "Ratio of momentum roughness length to canopy top height" ; + double fates_fire_FBD(fates_litterclass) ; + fates_fire_FBD:units = "NA" ; + fates_fire_FBD:long_name = "spitfire parameter related to fuel bulk density, see SFMain.F90" ; + double fates_fire_low_moisture_Coeff(fates_litterclass) ; + fates_fire_low_moisture_Coeff:units = "NA" ; + fates_fire_low_moisture_Coeff:long_name = "spitfire parameter, equation B1 Thonicke et al 2010" ; + double fates_fire_low_moisture_Slope(fates_litterclass) ; + fates_fire_low_moisture_Slope:units = "NA" ; + fates_fire_low_moisture_Slope:long_name = "spitfire parameter, equation B1 Thonicke et al 2010" ; + double fates_fire_mid_moisture(fates_litterclass) ; + fates_fire_mid_moisture:units = "NA" ; + fates_fire_mid_moisture:long_name = "spitfire litter moisture threshold to be considered medium dry" ; + double fates_fire_mid_moisture_Coeff(fates_litterclass) ; + fates_fire_mid_moisture_Coeff:units = "NA" ; + fates_fire_mid_moisture_Coeff:long_name = "spitfire parameter, equation B1 Thonicke et al 2010" ; + double fates_fire_mid_moisture_Slope(fates_litterclass) ; + fates_fire_mid_moisture_Slope:units = "NA" ; + fates_fire_mid_moisture_Slope:long_name = "spitfire parameter, equation B1 Thonicke et al 2010" ; + double fates_fire_min_moisture(fates_litterclass) ; + fates_fire_min_moisture:units = "NA" ; + fates_fire_min_moisture:long_name = "spitfire litter moisture threshold to be considered very dry" ; + double fates_fire_SAV(fates_litterclass) ; + fates_fire_SAV:units = "NA" ; + fates_fire_SAV:long_name = "spitfire parameter related to surface area to volume ratio, see SFMain.F90" ; + double fates_max_decomp(fates_litterclass) ; + fates_max_decomp:units = "yr-1" ; + fates_max_decomp:long_name = "maximum rate of litter & CWD transfer from non-decomposing class into decomposing class" ; + double fates_CWD_frac(fates_NCWD) ; + fates_CWD_frac:units = "fraction" ; + fates_CWD_frac:long_name = "fraction of woody (bdead+bsw) biomass destined for CWD pool" ; + double fates_base_mr_20 ; + fates_base_mr_20:units = "gC/gN/s" ; + fates_base_mr_20:long_name = "Base maintenance respiration rate for plant tissues, using Ryan 1991" ; + double fates_canopy_closure_thresh ; + fates_canopy_closure_thresh:units = "unitless" ; + fates_canopy_closure_thresh:long_name = "tree canopy coverage at which crown area allometry changes from savanna to forest value" ; + double fates_cohort_age_fusion_tol ; + fates_cohort_age_fusion_tol:units = "unitless" ; + fates_cohort_age_fusion_tol:long_name = "minimum fraction in differece in cohort age between cohorts." ; + double fates_cohort_size_fusion_tol ; + fates_cohort_size_fusion_tol:units = "unitless" ; + fates_cohort_size_fusion_tol:long_name = "minimum fraction in difference in dbh between cohorts" ; + double fates_comp_excln ; + fates_comp_excln:units = "none" ; + fates_comp_excln:long_name = "IF POSITIVE: weighting factor (exponent on dbh) for canopy layer exclusion and promotion, IF NEGATIVE: switch to use deterministic height sorting" ; + double fates_cwd_fcel ; + fates_cwd_fcel:units = "unitless" ; + fates_cwd_fcel:long_name = "Cellulose fraction for CWD" ; + double fates_cwd_flig ; + fates_cwd_flig:units = "unitless" ; + fates_cwd_flig:long_name = "Lignin fraction of coarse woody debris" ; + double fates_eca_plant_escalar ; + fates_eca_plant_escalar:units = "" ; + fates_eca_plant_escalar:long_name = "scaling factor for plant fine root biomass to calculate nutrient carrier enzyme abundance (ECA)" ; + double fates_fire_active_crown_fire ; + fates_fire_active_crown_fire:units = "0 or 1" ; + fates_fire_active_crown_fire:long_name = "flag, 1=active crown fire 0=no active crown fire" ; + double fates_fire_cg_strikes ; + fates_fire_cg_strikes:units = "fraction (0-1)" ; + fates_fire_cg_strikes:long_name = "fraction of cloud to ground lightning strikes" ; + double fates_fire_drying_ratio ; + fates_fire_drying_ratio:units = "NA" ; + fates_fire_drying_ratio:long_name = "spitfire parameter, fire drying ratio for fuel moisture, alpha_FMC EQ 6 Thonicke et al 2010" ; + double fates_fire_durat_slope ; + fates_fire_durat_slope:units = "NA" ; + fates_fire_durat_slope:long_name = "spitfire parameter, fire max duration slope, Equation 14 Thonicke et al 2010" ; + double fates_fire_fdi_a ; + fates_fire_fdi_a:units = "NA" ; + fates_fire_fdi_a:long_name = "spitfire parameter, fire danger index, EQ 5 Thonicke et al 2010" ; + double fates_fire_fdi_alpha ; + fates_fire_fdi_alpha:units = "NA" ; + fates_fire_fdi_alpha:long_name = "spitfire parameter, EQ 7 Venevsky et al. GCB 2002,(modified EQ 8 Thonicke et al. 2010) " ; + double fates_fire_fdi_b ; + fates_fire_fdi_b:units = "NA" ; + fates_fire_fdi_b:long_name = "spitfire parameter, fire danger index, EQ 5 Thonicke et al 2010 " ; + double fates_fire_fuel_energy ; + fates_fire_fuel_energy:units = "kJ/kg" ; + fates_fire_fuel_energy:long_name = "spitfire parameter, heat content of fuel" ; + double fates_fire_max_durat ; + fates_fire_max_durat:units = "minutes" ; + fates_fire_max_durat:long_name = "spitfire parameter, fire maximum duration, Equation 14 Thonicke et al 2010" ; + double fates_fire_miner_damp ; + fates_fire_miner_damp:units = "NA" ; + fates_fire_miner_damp:long_name = "spitfire parameter, mineral-dampening coefficient EQ A1 Thonicke et al 2010 " ; + double fates_fire_miner_total ; + fates_fire_miner_total:units = "fraction" ; + fates_fire_miner_total:long_name = "spitfire parameter, total mineral content, Table A1 Thonicke et al 2010" ; + double fates_fire_nignitions ; + fates_fire_nignitions:units = "ignitions per year per km2" ; + fates_fire_nignitions:long_name = "number of annual ignitions per square km" ; + double fates_fire_part_dens ; + fates_fire_part_dens:units = "kg/m2" ; + fates_fire_part_dens:long_name = "spitfire parameter, oven dry particle density, Table A1 Thonicke et al 2010" ; + double fates_fire_threshold ; + fates_fire_threshold:units = "kW/m" ; + fates_fire_threshold:long_name = "spitfire parameter, fire intensity threshold for tracking fires that spread" ; + double fates_hydr_kmax_rsurf1 ; + fates_hydr_kmax_rsurf1:units = "kg water/m2 root area/Mpa/s" ; + fates_hydr_kmax_rsurf1:long_name = "maximum conducitivity for unit root surface (into root)" ; + double fates_hydr_kmax_rsurf2 ; + fates_hydr_kmax_rsurf2:units = "kg water/m2 root area/Mpa/s" ; + fates_hydr_kmax_rsurf2:long_name = "maximum conducitivity for unit root surface (out of root)" ; + double fates_hydr_psi0 ; + fates_hydr_psi0:units = "MPa" ; + fates_hydr_psi0:long_name = "sapwood water potential at saturation" ; + double fates_hydr_psicap ; + fates_hydr_psicap:units = "MPa" ; + fates_hydr_psicap:long_name = "sapwood water potential at which capillary reserves exhausted" ; + double fates_init_litter ; + fates_init_litter:units = "NA" ; + fates_init_litter:long_name = "Initialization value for litter pool in cold-start (NOT USED)" ; + double fates_leaf_photo_model ; + fates_leaf_photo_model:units = "unitless" ; + fates_leaf_photo_model:long_name = "(NOT ACTIVE) switch for choosing photosynthesis model, (1) constant nitrogen and (2) Walker et al. dynamic vcmax" ; + double fates_leaf_stomatal_model ; + fates_leaf_stomatal_model:units = "unitless" ; + fates_leaf_stomatal_model:long_name = "switch for choosing between Ball-Berry (1) stomatal conductance model and Medlyn (2) model" ; + double fates_logging_coll_under_frac ; + fates_logging_coll_under_frac:units = "fraction" ; + fates_logging_coll_under_frac:long_name = "Fraction of stems killed in the understory when logging generates disturbance" ; + double fates_logging_collateral_frac ; + fates_logging_collateral_frac:units = "fraction" ; + fates_logging_collateral_frac:long_name = "Fraction of large stems in upperstory that die from logging collateral damage" ; + double fates_logging_dbhmax ; + fates_logging_dbhmax:units = "cm" ; + fates_logging_dbhmax:long_name = "Maximum dbh below which logging is applied (unset values flag this to be unused)" ; + double fates_logging_dbhmax_infra ; + fates_logging_dbhmax_infra:units = "cm" ; + fates_logging_dbhmax_infra:long_name = "Tree diameter, above which infrastructure from logging does not impact damage or mortality." ; + double fates_logging_dbhmin ; + fates_logging_dbhmin:units = "cm" ; + fates_logging_dbhmin:long_name = "Minimum dbh at which logging is applied" ; + double fates_logging_direct_frac ; + fates_logging_direct_frac:units = "fraction" ; + fates_logging_direct_frac:long_name = "Fraction of stems logged directly per event" ; + double fates_logging_event_code ; + fates_logging_event_code:units = "unitless" ; + fates_logging_event_code:long_name = "Integer code that options how logging events are structured" ; + double fates_logging_export_frac ; + fates_logging_export_frac:units = "fraction" ; + fates_logging_export_frac:long_name = "fraction of trunk product being shipped offsite, the leftovers will be left onsite as large CWD" ; + double fates_logging_mechanical_frac ; + fates_logging_mechanical_frac:units = "fraction" ; + fates_logging_mechanical_frac:long_name = "Fraction of stems killed due infrastructure an other mechanical means" ; + double fates_mort_disturb_frac ; + fates_mort_disturb_frac:units = "fraction" ; + fates_mort_disturb_frac:long_name = "fraction of canopy mortality that results in disturbance (i.e. transfer of area from new to old patch)" ; + double fates_mort_understorey_death ; + fates_mort_understorey_death:units = "fraction" ; + fates_mort_understorey_death:long_name = "fraction of plants in understorey cohort impacted by overstorey tree-fall" ; + double fates_patch_fusion_tol ; + fates_patch_fusion_tol:units = "unitless" ; + fates_patch_fusion_tol:long_name = "minimum fraction in difference in profiles between patches" ; + double fates_phen_a ; + fates_phen_a:units = "none" ; + fates_phen_a:long_name = "GDD accumulation function, intercept parameter: gdd_thesh = a + b exp(c*ncd)" ; + double fates_phen_b ; + fates_phen_b:units = "none" ; + fates_phen_b:long_name = "GDD accumulation function, multiplier parameter: gdd_thesh = a + b exp(c*ncd)" ; + double fates_phen_c ; + fates_phen_c:units = "none" ; + 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 for vegetation" ; + double fates_phen_coldtemp ; + fates_phen_coldtemp:units = "degrees C" ; + 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" ; + double fates_phen_drought_threshold ; + fates_phen_drought_threshold:units = "m3/m3" ; + fates_phen_drought_threshold:long_name = "liquid volume in soil layer, threashold for drought phenology" ; + double fates_phen_mindayson ; + fates_phen_mindayson:units = "days" ; + fates_phen_mindayson:long_name = "day threshold compared against days since leaves became on-allometry" ; + double fates_phen_ncolddayslim ; + fates_phen_ncolddayslim:units = "days" ; + fates_phen_ncolddayslim:long_name = "day threshold exceedance for temperature leaf-drop" ; + double fates_q10_froz ; + fates_q10_froz:units = "unitless" ; + fates_q10_froz:long_name = "Q10 for frozen-soil respiration rates" ; + double fates_q10_mr ; + fates_q10_mr:units = "unitless" ; + fates_q10_mr:long_name = "Q10 for maintenance respiration" ; + double fates_soil_salinity ; + fates_soil_salinity:units = "ppt" ; + fates_soil_salinity:long_name = "soil salinity used for model when not coupled to dynamic soil salinity" ; + +// global attributes: + :history = "This parameter file is maintained in version control\nSee https://github.com/NGEET/fates/blob/master/parameter_files/fates_params_default.cdl \nFor changes, use git blame \n" ; +data: + + fates_history_ageclass_bin_edges = 0, 1, 2, 5, 10, 20, 50 ; + + fates_history_coageclass_bin_edges = 0, 5 ; + + fates_history_height_bin_edges = 0, 0.1, 0.3, 1, 3, 10 ; + + fates_history_sizeclass_bin_edges = 0, 5, 10, 15, 20, 30, 40, 50, 60, 70, + 80, 90, 100 ; + + fates_pftname = + "broadleaf_evergreen_tropical_tree ", + "needleleaf_evergreen_extratrop_tree ", + "needleleaf_colddecid_extratrop_tree ", + "broadleaf_evergreen_extratrop_tree ", + "broadleaf_hydrodecid_tropical_tree ", + "broadleaf_colddecid_extratrop_tree ", + "broadleaf_evergreen_extratrop_shrub ", + "broadleaf_hydrodecid_extratrop_shrub ", + "broadleaf_colddecid_extratrop_shrub ", + "arctic_c3_grass ", + "cool_c3_grass ", + "c4_grass " ; + + fates_prt_organ_name = + "leaf ", + "fine root ", + "sapwood ", + "structure " ; + + fates_prt_organ_id = 1, 2, 3, 6 ; + + fates_alloc_storage_cushion = 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_allom_agb1 = 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, + 0.06896, 0.06896, 0.06896, 0.01, 0.01, 0.01 ; + + fates_allom_agb2 = 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, + 0.572, 0.572, 0.572, 0.572 ; + + fates_allom_agb3 = 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, + 1.94, 1.94, 1.94 ; + + fates_allom_agb4 = 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, + 0.931, 0.931, 0.931, 0.931 ; + + fates_allom_agb_frac = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, + 0.6, 0.6 ; + + fates_allom_amode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_blca_expnt_diff = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_allom_cmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_d2bl1 = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, + 0.07, 0.07, 0.07 ; + + fates_allom_d2bl2 = 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, + 1.3 ; + + fates_allom_d2bl3 = 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, + 0.55, 0.55, 0.55 ; + + fates_allom_d2ca_coefficient_max = 0.6568464, 0.6568464, 0.6568464, + 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464, + 0.6568464, 0.6568464, 0.6568464 ; + + fates_allom_d2ca_coefficient_min = 0.3381119, 0.3381119, 0.3381119, + 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119, + 0.3381119, 0.3381119, 0.3381119 ; + + fates_allom_d2h1 = 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, + 0.64, 0.64, 0.64 ; + + fates_allom_d2h2 = 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, + 0.37, 0.37, 0.37 ; + + fates_allom_d2h3 = -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, + -999.9, -999.9, -999.9, -999.9, -999.9 ; + + fates_allom_dbh_maxheight = 90, 90, 90, 90, 90, 90, 3, 3, 2, 0.35, 0.35, 0.35 ; + + fates_allom_fmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_frbstor_repro = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_allom_hmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_l2fr = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_la_per_sa_int = 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, + 0.8, 0.8, 0.8 ; + + fates_allom_la_per_sa_slp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_allom_lmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_sai_scaler = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + 0.1, 0.1 ; + + fates_allom_smode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_allom_stmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_branch_turnover = 150, 150, 150, 150, 150, 150, 150, 150, 150, 0, 0, 0 ; + + fates_c2b = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 ; + + fates_displar = 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, + 0.67, 0.67 ; + + fates_eca_alpha_ptase = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5 ; + + fates_eca_decompmicc = 280, 280, 280, 280, 280, 280, 280, 280, 280, 280, + 280, 280 ; + + fates_eca_km_nh4 = 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, + 0.14, 0.14, 0.14 ; + + fates_eca_km_no3 = 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, + 0.27, 0.27, 0.27 ; + + fates_eca_km_p = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 ; + + fates_eca_km_ptase = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_eca_lambda_ptase = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_eca_vmax_nh4 = 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, + 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07 ; + + fates_eca_vmax_no3 = 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, + 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08 ; + + fates_eca_vmax_p = 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, + 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09 ; + + fates_eca_vmax_ptase = 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, + 5e-09, 5e-09, 5e-09, 5e-09, 5e-09 ; + + fates_fire_alpha_SH = 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, + 0.2 ; + + fates_fire_bark_scaler = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, + 0.07, 0.07, 0.07, 0.07 ; + + fates_fire_crown_depth_frac = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.95, 0.95, + 0.95, 1, 1, 1 ; + + fates_fire_crown_kill = 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, + 0.775, 0.775, 0.775, 0.775, 0.775 ; + + fates_fnrt_prof_a = 7, 7, 7, 7, 6, 6, 7, 7, 7, 11, 11, 11 ; + + fates_fnrt_prof_b = 1, 2, 2, 1, 2, 2, 1.5, 1.5, 1.5, 2, 2, 2 ; + + fates_fnrt_prof_mode = 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3 ; + + fates_fr_fcel = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; + + fates_fr_flab = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0.25, 0.25 ; + + fates_fr_flig = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0.25, 0.25 ; + + fates_grperc = 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_avuln_gs = 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, + 2.5 ; + + fates_hydr_avuln_node = + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 ; + + fates_hydr_epsil_node = + 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, 12, + 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, + 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8 ; + + fates_hydr_fcap_node = + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, + 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_hydr_kmax_node = + -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, + -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999 ; + + fates_hydr_p50_gs = -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, + -1.5, -1.5, -1.5 ; + + fates_hydr_p50_node = + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25, + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25, + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25, + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25 ; + + fates_hydr_p_taper = 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, + 0.333, 0.333, 0.333, 0.333 ; + + fates_hydr_pinot_node = + -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, + -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, + -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, + -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, + -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, + -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, + -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, + -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478 ; + + fates_hydr_pitlp_node = + -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, + -1.67, -1.67, + -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, + -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, + -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.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 ; + + fates_hydr_rs2 = 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, + 0.0001, 0.0001, 0.0001, 0.0001, 0.0001 ; + + fates_hydr_srl = 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25 ; + + fates_hydr_thetas_node = + 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, + 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, + 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, + 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75 ; + + fates_leaf_c3psn = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0 ; + + fates_leaf_clumping_index = 0.85, 0.85, 0.8, 0.85, 0.85, 0.9, 0.85, 0.9, + 0.9, 0.75, 0.75, 0.75 ; + + fates_leaf_diameter = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, + 0.04, 0.04, 0.04 ; + + fates_leaf_jmaxha = 43540, 43540, 43540, 43540, 43540, 43540, 43540, 43540, + 43540, 43540, 43540, 43540 ; + + fates_leaf_jmaxhd = 152040, 152040, 152040, 152040, 152040, 152040, 152040, + 152040, 152040, 152040, 152040, 152040 ; + + fates_leaf_jmaxse = 495, 495, 495, 495, 495, 495, 495, 495, 495, 495, 495, + 495 ; + + fates_leaf_long = + 1.5, 4, 1, 1.5, 1, 1, 1.5, 1, 1, 1, 1, 1 ; + + fates_leaf_slamax = 0.0954, 0.0954, 0.0954, 0.0954, 0.0954, 0.0954, 0.012, + 0.03, 0.03, 0.03, 0.03, 0.03 ; + + fates_leaf_slatop = 0.012, 0.01, 0.024, 0.012, 0.03, 0.03, 0.012, 0.03, + 0.03, 0.03, 0.03, 0.03 ; + + fates_leaf_stomatal_intercept = 10000, 10000, 10000, 10000, 10000, 10000, + 10000, 10000, 10000, 10000, 10000, 40000 ; + + fates_leaf_stomatal_slope_ballberry = 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8 ; + + fates_leaf_stomatal_slope_medlyn = 4.1, 2.3, 2.3, 4.1, 4.4, 4.4, 4.7, 4.7, + 4.7, 2.2, 5.3, 1.6 ; + + fates_leaf_stor_priority = 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, + 0.8, 0.8 ; + + fates_leaf_tpuha = 53100, 53100, 53100, 53100, 53100, 53100, 53100, 53100, + 53100, 53100, 53100, 53100 ; + + fates_leaf_tpuhd = 150650, 150650, 150650, 150650, 150650, 150650, 150650, + 150650, 150650, 150650, 150650, 150650 ; + + fates_leaf_tpuse = 490, 490, 490, 490, 490, 490, 490, 490, 490, 490, 490, 490 ; + + fates_leaf_vcmax25top = + 50, 65, 39, 62, 41, 58, 62, 54, 54, 78, 78, 78 ; + + fates_leaf_vcmaxha = 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330, + 65330, 65330, 65330, 65330 ; + + fates_leaf_vcmaxhd = 149250, 149250, 149250, 149250, 149250, 149250, 149250, + 149250, 149250, 149250, 149250, 149250 ; + + fates_leaf_vcmaxse = 485, 485, 485, 485, 485, 485, 485, 485, 485, 485, 485, + 485 ; + + fates_leaf_xl = 0.1, 0.01, 0.01, 0.1, 0.01, 0.25, 0.01, 0.25, 0.25, -0.3, + -0.3, -0.3 ; + + fates_lf_fcel = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; + + fates_lf_flab = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0.25, 0.25 ; + + fates_lf_flig = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0.25, 0.25 ; + + fates_maintresp_reduction_curvature = 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, + 0.01, 0.01, 0.01, 0.01, 0.01, 0.01 ; + + fates_maintresp_reduction_intercept = 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1 ; + + fates_mort_bmort = 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, + 0.014, 0.014, 0.014, 0.014 ; + + fates_mort_freezetol = 2.5, -55, -80, -30, 2.5, -30, -60, -10, -80, -80, + -20, 2.5 ; + + fates_mort_hf_flc_threshold = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5 ; + + fates_mort_hf_sm_threshold = 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, + 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06 ; + + fates_mort_ip_age_senescence = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_mort_ip_size_senescence = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_mort_r_age_senescence = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_mort_r_size_senescence = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_mort_scalar_coldstress = 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3 ; + + fates_mort_scalar_cstarvation = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, + 0.6, 0.6, 0.6 ; + + fates_mort_scalar_hydrfailure = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, + 0.6, 0.6, 0.6 ; + + fates_nfix1 = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_nfix2 = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_phen_cold_size_threshold = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_phen_evergreen = 1, 1, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0 ; + + fates_phen_season_decid = 0, 0, 1, 0, 0, 1, 0, 0, 1, 1, 0, 0 ; + + fates_phen_stem_drop_fraction = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_phen_stress_decid = 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 1 ; + + fates_phenflush_fraction = _, _, 0.5, _, 0.5, 0.5, _, 0.5, 0.5, 0.5, 0.5, 0.5 ; + + fates_prescribed_mortality_canopy = 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, + 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194 ; + + fates_prescribed_mortality_understory = 0.025, 0.025, 0.025, 0.025, 0.025, + 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025 ; + + fates_prescribed_npp_canopy = 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, + 0.4, 0.4, 0.4 ; + + fates_prescribed_npp_understory = 0.03125, 0.03125, 0.03125, 0.03125, + 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125 ; + + fates_prescribed_nuptake = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ; + + fates_prescribed_puptake = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ; + + fates_prescribed_recruitment = 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, + 0.02, 0.02, 0.02, 0.02, 0.02 ; + + fates_prt_alloc_priority = + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 ; + + fates_prt_nitr_stoich_p1 = + 0.033, 0.029, 0.04, 0.033, 0.04, 0.04, 0.033, 0.04, 0.04, 0.04, 0.04, 0.04, + 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, + 0.024, 0.024, + 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, + 1e-08, 1e-08, + 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, + 0.0047, 0.0047, 0.0047 ; + + fates_prt_nitr_stoich_p2 = + 0.033, 0.029, 0.04, 0.033, 0.04, 0.04, 0.033, 0.04, 0.04, 0.04, 0.04, 0.04, + 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, + 0.024, 0.024, + 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, + 1e-08, 1e-08, + 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, + 0.0047, 0.0047, 0.0047 ; + + fates_prt_phos_stoich_p1 = + 0.0033, 0.0029, 0.004, 0.0033, 0.004, 0.004, 0.0033, 0.004, 0.004, 0.004, + 0.004, 0.004, + 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, + 0.0024, 0.0024, 0.0024, + 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, + 1e-09, 1e-09, + 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, + 0.00047, 0.00047, 0.00047, 0.00047 ; + + fates_prt_phos_stoich_p2 = + 0.0033, 0.0029, 0.004, 0.0033, 0.004, 0.004, 0.0033, 0.004, 0.004, 0.004, + 0.004, 0.004, + 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, + 0.0024, 0.0024, 0.0024, + 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, + 1e-09, 1e-09, + 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, + 0.00047, 0.00047, 0.00047, 0.00047 ; + + fates_nitr_store_ratio = 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3; + + fates_phos_store_ratio = 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3; + + fates_recruit_hgt_min = 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 0.75, 0.75, 0.75, + 0.125, 0.125, 0.125 ; + + fates_recruit_initd = 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, + 0.2 ; + + fates_rholnir = 0.45, 0.35, 0.35, 0.45, 0.45, 0.45, 0.35, 0.45, 0.45, 0.35, + 0.35, 0.35 ; + + fates_rholvis = 0.1, 0.07, 0.07, 0.1, 0.1, 0.1, 0.07, 0.1, 0.1, 0.1, 0.1, 0.1 ; + + fates_rhosnir = 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.53, + 0.53, 0.53 ; + + fates_rhosvis = 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.31, + 0.31, 0.31 ; + + fates_root_long = 1, 2, 1, 1.5, 1, 1, 1.5, 1, 1, 1, 1, 1 ; + + fates_seed_alloc = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 ; + + fates_seed_alloc_mature = 0, 0, 0, 0, 0, 0, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9 ; + + fates_seed_dbh_repro_threshold = 150, 90, 90, 90, 90, 90, 3, 3, 2, 1.47, + 1.47, 1.47 ; + + fates_seed_decay_rate = 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, + 0.51, 0.51, 0.51, 0.51 ; + + fates_seed_germination_rate = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5 ; + + fates_seed_suppl = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_senleaf_long_fdrought = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_smpsc = -255000, -255000, -255000, -255000, -255000, -255000, -255000, + -255000, -255000, -255000, -255000, -255000 ; + + fates_smpso = -66000, -66000, -66000, -66000, -66000, -66000, -66000, + -66000, -66000, -66000, -66000, -66000 ; + + fates_taulnir = 0.25, 0.1, 0.1, 0.25, 0.25, 0.25, 0.1, 0.25, 0.25, 0.34, + 0.34, 0.34 ; + + fates_taulvis = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, + 0.05, 0.05 ; + + fates_tausnir = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, + 0.001, 0.25, 0.25, 0.25 ; + + fates_tausvis = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, + 0.001, 0.12, 0.12, 0.12 ; + + fates_trim_inc = 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, + 0.03, 0.03 ; + + fates_trim_limit = 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3 ; + + fates_turnover_carb_retrans = + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_turnover_nitr_retrans = + 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.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_turnover_phos_retrans = + 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.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_turnover_retrans_mode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + + fates_wood_density = 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, + 0.7 ; + + fates_woody = 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0 ; + + fates_z0mr = 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, + 0.055, 0.055, 0.055 ; + + fates_fire_FBD = 15.4, 16.8, 19.6, 999, 4, 4 ; + + fates_fire_low_moisture_Coeff = 1.12, 1.09, 0.98, 0.8, 1.15, 1.15 ; + + fates_fire_low_moisture_Slope = 0.62, 0.72, 0.85, 0.8, 0.62, 0.62 ; + + fates_fire_mid_moisture = 0.72, 0.51, 0.38, 1, 0.8, 0.8 ; + + fates_fire_mid_moisture_Coeff = 2.35, 1.47, 1.06, 0.8, 3.2, 3.2 ; + + fates_fire_mid_moisture_Slope = 2.35, 1.47, 1.06, 0.8, 3.2, 3.2 ; + + fates_fire_min_moisture = 0.18, 0.12, 0, 0, 0.24, 0.24 ; + + fates_fire_SAV = 13, 3.58, 0.98, 0.2, 66, 66 ; + + fates_max_decomp = 0.52, 0.383, 0.383, 0.19, 1, 999 ; + + fates_CWD_frac = 0.045, 0.075, 0.21, 0.67 ; + + fates_base_mr_20 = 2.52e-06 ; + + fates_canopy_closure_thresh = 0.8 ; + + fates_cohort_age_fusion_tol = 0.08 ; + + fates_cohort_size_fusion_tol = 0.08 ; + + fates_comp_excln = 3 ; + + fates_cwd_fcel = 0.76 ; + + fates_cwd_flig = 0.24 ; + + fates_eca_plant_escalar = 1.25e-05 ; + + fates_fire_active_crown_fire = 0 ; + + fates_fire_cg_strikes = 0.2 ; + + fates_fire_drying_ratio = 66000 ; + + fates_fire_durat_slope = -11.06 ; + + fates_fire_fdi_a = 17.62 ; + + fates_fire_fdi_alpha = 0.00037 ; + + fates_fire_fdi_b = 243.12 ; + + fates_fire_fuel_energy = 18000 ; + + fates_fire_max_durat = 240 ; + + fates_fire_miner_damp = 0.41739 ; + + fates_fire_miner_total = 0.055 ; + + fates_fire_nignitions = 15 ; + + fates_fire_part_dens = 513 ; + + fates_fire_threshold = 50 ; + + fates_hydr_kmax_rsurf1 = 20 ; + + fates_hydr_kmax_rsurf2 = 0.0001 ; + + fates_hydr_psi0 = 0 ; + + fates_hydr_psicap = -0.6 ; + + fates_init_litter = 0.05 ; + + fates_leaf_photo_model = 1 ; + + fates_leaf_stomatal_model = 1 ; + + fates_logging_coll_under_frac = 0.55983 ; + + fates_logging_collateral_frac = 0.05 ; + + fates_logging_dbhmax = _ ; + + fates_logging_dbhmax_infra = 35 ; + + fates_logging_dbhmin = 50 ; + + fates_logging_direct_frac = 0.15 ; + + fates_logging_event_code = -30 ; + + fates_logging_export_frac = 0.8 ; + + fates_logging_mechanical_frac = 0.05 ; + + fates_mort_disturb_frac = 1 ; + + fates_mort_understorey_death = 0.55983 ; + + fates_patch_fusion_tol = 0.05 ; + + fates_phen_a = -68 ; + + fates_phen_b = 638 ; + + fates_phen_c = -0.01 ; + + fates_phen_chiltemp = 5 ; + + fates_phen_coldtemp = 7.5 ; + + fates_phen_doff_time = 100 ; + + fates_phen_drought_threshold = 0.15 ; + + fates_phen_mindayson = 90 ; + + fates_phen_ncolddayslim = 5 ; + + fates_q10_froz = 1.5 ; + + fates_q10_mr = 1.5 ; + + fates_soil_salinity = 0.4 ; +} diff --git a/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 index 5c866f9512..925f5aedc7 100644 --- a/parteh/PRTAllometricCNPMod.F90 +++ b/parteh/PRTAllometricCNPMod.F90 @@ -784,16 +784,18 @@ subroutine CNPPrioritizedReplacement(this, & ! If it is, then we track the variable ids associated with that pool for each CNP ! species. It "should" work fine if there are NO priority=1 pools... ! ----------------------------------------------------------------------------------- - curpri_org(:) = fates_unset_int ! reset "current-priority" organ ids i = 0 do ii = 1, num_organs + ! The following logic bars any organs that were not given allocation priority + if( prt_params%organ_param_id(organ_list(ii)) < 1 ) cycle + deficit_c(ii) = max(0._r8,this%GetDeficit(carbon12_element,organ_list(ii),target_c(ii))) ! The priority code associated with this organ - priority_code = int(prt_params%alloc_priority(ipft, organ_list(ii))) + priority_code = int(prt_params%alloc_priority(ipft, prt_params%organ_param_id(organ_list(ii)))) ! Don't allow allocation to leaves if they are in an "off" status. ! Also, dont allocate to replace turnover if this is not evergreen @@ -939,7 +941,7 @@ subroutine CNPPrioritizedReplacement(this, & ! Bring all pools, in priority order, up to allometric targets if possible ! ----------------------------------------------------------------------------------- - do i_pri = 1, n_max_priority + priority_loop: do i_pri = 1, n_max_priority curpri_org(:) = fates_unset_int ! "current-priority" organ indices @@ -947,7 +949,13 @@ subroutine CNPPrioritizedReplacement(this, & do ii = 1, num_organs ! The priority code associated with this organ - priority_code = int(prt_params%alloc_priority(ipft, organ_list(ii))) + if ( organ_list(ii).ne.repro_organ ) then + if( organ_list(ii).eq.store_organ ) then + priority_code = 2 + else + priority_code = int(prt_params%alloc_priority(ipft, prt_params%organ_param_id(organ_list(ii)))) + end if + end if ! Don't allow allocation to leaves if they are in an "off" status. ! (this prevents accidental re-flushing on the day they drop) @@ -1067,7 +1075,7 @@ subroutine CNPPrioritizedReplacement(this, & p_gain, phosphorus_element, curpri_org(1:n_curpri_org)) - end do + end do priority_loop return end subroutine CNPPrioritizedReplacement @@ -1553,35 +1561,52 @@ subroutine CNPStatureGrowth(this,c_gain, n_gain, p_gain, & end do do_solve_check + + target_n = this%GetNutrientTarget(nitrogen_element,repro_organ,stoich_growth_min) + deficit_n(repro_id) = this%GetDeficit(nitrogen_element,repro_organ,target_n) + + target_p = this%GetNutrientTarget(phosphorus_element,repro_organ,stoich_growth_min) + deficit_p(repro_id) = this%GetDeficit(phosphorus_element,repro_organ,target_p) + + ! Nitrogen for + call ProportionalNutrAllocation(state_n, deficit_n, n_gain, nitrogen_element,[repro_id]) + + ! Phosphorus + call ProportionalNutrAllocation(state_p, deficit_p, p_gain, phosphorus_element,[repro_id]) + + ! ----------------------------------------------------------------------------------- ! Nutrient Fluxes proportionally to each pool (these should be fully actualized) ! (this also removes from the gain pools) ! ----------------------------------------------------------------------------------- - sum_n_demand = 0._r8 ! For error checking - sum_p_demand = 0._r8 ! For error checking - do ii = 1, n_mask_organs - i = mask_organs(ii) - if(organ_list(i).ne.store_organ)then - ! Update the nitrogen deficits (which are based off of carbon actual..) - ! Note that the nitrogen target is tied to the stoichiometry of thegrowing pool only - target_n = this%GetNutrientTarget(nitrogen_element,organ_list(i),stoich_growth_min) - deficit_n(i) = this%GetDeficit(nitrogen_element,organ_list(i),target_n) - sum_n_demand = sum_n_demand+max(0._r8,deficit_n(i)) - - ! Update the nitrogen deficits (which are based off of carbon actual..) - ! Note that the nitrogen target is tied to the stoichiometry of thegrowing pool only - target_p = this%GetNutrientTarget(phosphorus_element,organ_list(i),stoich_growth_min) - deficit_p(i) = this%GetDeficit(phosphorus_element,organ_list(i),target_p) - sum_p_demand = sum_p_demand+max(0._r8,deficit_p(i)) - else - deficit_n(i) = 0._r8 - deficit_p(i) = 0._r8 - end if - - end do + sum_n_demand = 0._r8 ! For error checking + sum_p_demand = 0._r8 ! For error checking + do ii = 1, n_mask_organs + i = mask_organs(ii) + if(organ_list(i).ne.store_organ)then + ! Update the nitrogen deficits (which are based off of carbon actual..) + ! Note that the nitrogen target is tied to the stoichiometry of thegrowing pool only + target_n = this%GetNutrientTarget(nitrogen_element,organ_list(i),stoich_growth_min) + deficit_n(i) = this%GetDeficit(nitrogen_element,organ_list(i),target_n) + sum_n_demand = sum_n_demand+max(0._r8,deficit_n(i)) + + ! Update the nitrogen deficits (which are based off of carbon actual..) + ! Note that the nitrogen target is tied to the stoichiometry of thegrowing pool only + target_p = this%GetNutrientTarget(phosphorus_element,organ_list(i),stoich_growth_min) + deficit_p(i) = this%GetDeficit(phosphorus_element,organ_list(i),target_p) + sum_p_demand = sum_p_demand+max(0._r8,deficit_p(i)) + else + deficit_n(i) = 0._r8 + deficit_p(i) = 0._r8 + end if + + end do + + + ! Nitrogen call ProportionalNutrAllocation(state_n,deficit_n, & n_gain, nitrogen_element,mask_organs(1:n_mask_organs)) @@ -1790,46 +1815,61 @@ function GetNutrientTargetCNP(this,element_id,organ_id,stoich_mode) result(targe ! non-reproductive organs if( element_id == nitrogen_element) then + target_c = & - leaf_c_target*prt_params%nitr_stoich_p2(ipft,leaf_organ)+ & - fnrt_c_target*prt_params%nitr_stoich_p2(ipft,fnrt_organ)+ & - sapw_c_target*prt_params%nitr_stoich_p2(ipft,sapw_organ)!+ & -! struct_c_target*prt_params%nitr_stoich_p2(ipft,struct_organ) + leaf_c_target*prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(leaf_organ))+ & + fnrt_c_target*prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(fnrt_organ))+ & + sapw_c_target*prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(sapw_organ)) + + target_m = target_c * prt_params%nitr_store_ratio(ipft) + else + target_c = & - leaf_c_target*prt_params%phos_stoich_p2(ipft,leaf_organ)+ & - fnrt_c_target*prt_params%phos_stoich_p2(ipft,fnrt_organ)+ & - sapw_c_target*prt_params%phos_stoich_p2(ipft,sapw_organ) !+ & -! struct_c_target*prt_params%phos_stoich_p2(ipft,struct_organ) + leaf_c_target*prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(leaf_organ))+ & + fnrt_c_target*prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(fnrt_organ))+ & + sapw_c_target*prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(sapw_organ)) + + target_m = target_c * prt_params%phos_store_ratio(ipft) end if + + elseif(organ_id == repro_organ) then + + target_c = this%variables(i_cvar)%val(1) + if( element_id == nitrogen_element) then + target_m = target_c * prt_params%nitr_recr_stoich(ipft) + else + target_m = target_c * prt_params%phos_recr_stoich(ipft) + end if else + ! In all cases, we want the first index because for non-leaves ! that is the only index, and for leaves, that is the newly ! growing index. target_c = this%variables(i_cvar)%val(1) - end if - if( stoich_mode == stoich_growth_min ) then - if( element_id == nitrogen_element) then - target_m = target_c * prt_params%nitr_stoich_p1(ipft,organ_id) - else - target_m = target_c * prt_params%phos_stoich_p1(ipft,organ_id) - end if - elseif( stoich_mode == stoich_max ) then - if( element_id == nitrogen_element) then - target_m = target_c * prt_params%nitr_stoich_p2(ipft,organ_id) + if( stoich_mode == stoich_growth_min ) then + if( element_id == nitrogen_element) then + target_m = target_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(organ_id)) + else + target_m = target_c * prt_params%phos_stoich_p1(ipft,prt_params%organ_param_id(organ_id)) + end if + elseif( stoich_mode == stoich_max ) then + if( element_id == nitrogen_element) then + target_m = target_c * prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(organ_id)) + else + target_m = target_c * prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(organ_id)) + end if else - target_m = target_c * prt_params%phos_stoich_p2(ipft,organ_id) + write(fates_log(),*) 'invalid stoichiometry mode specified while getting' + write(fates_log(),*) 'nutrient targets' + write(fates_log(),*) 'stoich_mode: ',stoich_mode + call endrun(msg=errMsg(sourcefile, __LINE__)) end if - else - write(fates_log(),*) 'invalid stoichiometry mode specified while getting' - write(fates_log(),*) 'nutrient targets' - write(fates_log(),*) 'stoich_mode: ',stoich_mode - call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + return end function GetNutrientTargetCNP @@ -1851,7 +1891,7 @@ subroutine ProportionalNutrAllocation(state_m, deficit_m, gain_m, element_id, li ! over some arbitrary set of organs real(r8),intent(inout) :: deficit_m(:) ! Nutrient mass deficit of species ! over set of organs - integer, intent(in) :: list(:)! List of indices if sparse + integer, intent(in) :: list(:) ! List of indices if sparse real(r8),intent(inout) :: gain_m ! Total nutrient mass gain to ! work with integer,intent(in) :: element_id ! Element global index (for debugging) @@ -2028,10 +2068,10 @@ subroutine GrowEquivC(this,carbon_gain,nitrogen_gain,phosphorus_gain, & ! Calculate gains from Nitrogen ! ----------------------------------------------------------------------------------- - if(prt_params%nitr_stoich_p1(ipft,organ_id)>nearzero)then + if(prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(organ_id))>nearzero)then ! The amount of C we could match with N in the aquisition pool - c_from_n_gain = nitrogen_gain * alloc_frac / prt_params%nitr_stoich_p1(ipft,organ_id) + c_from_n_gain = nitrogen_gain * alloc_frac / prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(organ_id)) ! It is possible that the nutrient pool of interest is already above the minimum ! requirement. In this case, we add that into the amount that the equivalent @@ -2041,7 +2081,7 @@ subroutine GrowEquivC(this,carbon_gain,nitrogen_gain,phosphorus_gain, & n_target = this%GetNutrientTarget(nitrogen_element,organ_id,stoich_growth_min) c_from_n_headstart = max(0.0_r8, sum(this%variables(n_var_id)%val(:),dim=1) - n_target ) / & - prt_params%nitr_stoich_p1(ipft,organ_id) + prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(organ_id)) ! Increment the amount of C that we could match with N, as the minimum @@ -2057,10 +2097,10 @@ subroutine GrowEquivC(this,carbon_gain,nitrogen_gain,phosphorus_gain, & ! Calculate gains from phosphorus ! ----------------------------------------------------------------------------------- - if(prt_params%phos_stoich_p1(ipft,organ_id)>nearzero) then + if(prt_params%phos_stoich_p1(ipft,prt_params%organ_param_id(organ_id))>nearzero) then - c_from_p_gain = phosphorus_gain * alloc_frac / prt_params%phos_stoich_p1(ipft,organ_id) + c_from_p_gain = phosphorus_gain * alloc_frac / prt_params%phos_stoich_p1(ipft,prt_params%organ_param_id(organ_id)) ! It is possible that the nutrient pool of interest is already above the minimum ! requirement. In this case, we add that into the amount that the equivalent @@ -2070,7 +2110,7 @@ subroutine GrowEquivC(this,carbon_gain,nitrogen_gain,phosphorus_gain, & p_target = this%GetNutrientTarget(phosphorus_element,organ_id,stoich_growth_min) c_from_p_headstart = max(0.0_r8,sum(this%variables(p_var_id)%val(:),dim=1) - p_target ) / & - prt_params%phos_stoich_p1(ipft,organ_id) + prt_params%phos_stoich_p1(ipft,prt_params%organ_param_id(organ_id)) ! Increment the amount of C that we could match with P, as the minimum ! of what C could do itself, and what P could do. We need this minimum diff --git a/parteh/PRTLossFluxesMod.F90 b/parteh/PRTLossFluxesMod.F90 index 526613b37d..e144f228e3 100644 --- a/parteh/PRTLossFluxesMod.F90 +++ b/parteh/PRTLossFluxesMod.F90 @@ -117,6 +117,14 @@ subroutine PRTPhenologyFlush(prt, ipft, organ_id, c_store_transfer_frac) call endrun(msg=errMsg(__FILE__, __LINE__)) end if + if(prt_params%organ_param_id(organ_id)<1) then + write(fates_log(),*) 'Attempting to flush an organ that does not have a stoichiometry defined' + write(fates_log(),*) 'global organ id (fyi, leaf=1):',organ_id + write(fates_log(),*) 'prt_params%organ_param_id(:):',prt_params%organ_param_id(:) + write(fates_log(),*) 'Exiting' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + if(prt_global%hyp_id .le. 2) then i_leaf_pos = 1 ! also used for sapwood and structural for grass i_store_pos = 1 ! hypothesis 1/2 only have @@ -222,9 +230,9 @@ subroutine PRTPhenologyFlush(prt, ipft, organ_id, c_store_transfer_frac) ! Calculate the stoichiometry with C for this element if( element_id == nitrogen_element ) then - target_stoich = prt_params%nitr_stoich_p1(ipft,organ_id) + target_stoich = prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(organ_id)) else if( element_id == phosphorus_element ) then - target_stoich = prt_params%phos_stoich_p1(ipft,organ_id) + target_stoich = prt_params%phos_stoich_p1(ipft,prt_params%organ_param_id(organ_id)) else write(fates_log(),*) ' Trying to calculate nutrient flushing target' write(fates_log(),*) ' for element that DNE' @@ -505,13 +513,15 @@ subroutine DeciduousTurnoverSimpleRetranslocation(prt,ipft,organ_id,mass_fractio i_var = organ_map(organ_id)%var_id(i_var_of_organ) element_id = prt_global%state_descriptor(i_var)%element_id - + + + if ( any(element_id == carbon_elements_list) ) then - retrans = prt_params%turnover_carb_retrans(ipft,organ_id) + retrans = prt_params%turnover_carb_retrans(ipft,prt_params%organ_param_id(organ_id)) else if( element_id == nitrogen_element ) then - retrans = prt_params%turnover_nitr_retrans(ipft,organ_id) + retrans = prt_params%turnover_nitr_retrans(ipft,prt_params%organ_param_id(organ_id)) else if( element_id == phosphorus_element ) then - retrans = prt_params%turnover_phos_retrans(ipft,organ_id) + retrans = prt_params%turnover_phos_retrans(ipft,prt_params%organ_param_id(organ_id)) else write(fates_log(),*) 'Please add a new re-translocation clause to your ' write(fates_log(),*) ' organ x element combination' @@ -707,16 +717,20 @@ subroutine MaintTurnoverSimpleRetranslocation(prt,ipft,is_drought) base_turnover(repro_organ) = 0.0_r8 do i_var = 1, prt_global%num_vars - + organ_id = prt_global%state_descriptor(i_var)%organ_id element_id = prt_global%state_descriptor(i_var)%element_id + ! If this organ does not have a retranslocation rate + ! then it is not valid for turnover + if( prt_params%organ_param_id(organ_id) < 1 ) cycle + if ( any(element_id == carbon_elements_list) ) then - retrans_frac = prt_params%turnover_carb_retrans(ipft,organ_id) + retrans_frac = prt_params%turnover_carb_retrans(ipft,prt_params%organ_param_id(organ_id)) else if( element_id == nitrogen_element ) then - retrans_frac = prt_params%turnover_nitr_retrans(ipft,organ_id) + retrans_frac = prt_params%turnover_nitr_retrans(ipft,prt_params%organ_param_id(organ_id)) else if( element_id == phosphorus_element ) then - retrans_frac = prt_params%turnover_phos_retrans(ipft,organ_id) + retrans_frac = prt_params%turnover_phos_retrans(ipft,prt_params%organ_param_id(organ_id)) else write(fates_log(),*) 'Please add a new re-translocation clause to your ' write(fates_log(),*) ' organ x element combination' @@ -790,7 +804,6 @@ subroutine MaintTurnoverSimpleRetranslocation(prt,ipft,is_drought) end do end do - return end subroutine MaintTurnoverSimpleRetranslocation diff --git a/parteh/PRTParametersMod.F90 b/parteh/PRTParametersMod.F90 index 2acb706f8d..6e2c17ac66 100644 --- a/parteh/PRTParametersMod.F90 +++ b/parteh/PRTParametersMod.F90 @@ -13,9 +13,9 @@ module PRTParametersMod ! The following three PFT classes ! are mutually exclusive - real(r8), allocatable :: stress_decid(:) ! Is the plant stress deciduous? (1=yes, 0=no) - real(r8), allocatable :: season_decid(:) ! Is the plant seasonally deciduous (1=yes, 0=no) - real(r8), allocatable :: evergreen(:) ! Is the plant an evergreen (1=yes, 0=no) + integer, allocatable :: stress_decid(:) ! Is the plant stress deciduous? (1=yes, 0=no) + integer, allocatable :: season_decid(:) ! Is the plant seasonally deciduous (1=yes, 0=no) + integer, allocatable :: evergreen(:) ! Is the plant an evergreen (1=yes, 0=no) ! Growth and Turnover Parameters @@ -48,7 +48,23 @@ module PRTParametersMod real(r8), allocatable :: nitr_stoich_p1(:,:) ! Parameter 1 for nitrogen stoichiometry (pft x organ) real(r8), allocatable :: nitr_stoich_p2(:,:) ! Parameter 2 for nitrogen stoichiometry (pft x organ) real(r8), allocatable :: phos_stoich_p1(:,:) ! Parameter 1 for phosphorus stoichiometry (pft x organ) - real(r8), allocatable :: phos_stoich_p2(:,:) ! Parameter 2 for phosphorus stoichiometry (pft x organ) + real(r8), allocatable :: phos_stoich_p2(:,:) ! Parameter 2 for phosphorus stoichiometry (pft x organ) + + real(r8), allocatable :: nitr_store_ratio(:) ! This is the ratio of the target nitrogen stored per + ! target nitrogen that is bound into the tissues + ! of leaves, fine-roots and sapwood + + + real(r8), allocatable :: phos_store_ratio(:) ! This is the ratio of the target phosphorus stored per + ! target phosphorus is bound into the tissues + ! of leaves, fine-roots and sapwood + + integer, allocatable :: organ_id(:) ! Mapping of the organ index in the parameter file, to the + ! global list of organs found in PRTGenericMod.F90 + + + + real(r8), allocatable :: alloc_priority(:,:) ! Allocation priority for each organ (pft x organ) [integer 0-6] real(r8), allocatable :: cushion(:) ! labile carbon storage target as multiple of leaf pool. real(r8), allocatable :: leaf_stor_priority(:) ! leaf turnover vs labile carbon use prioritisation @@ -59,6 +75,19 @@ module PRTParametersMod real(r8), allocatable :: seed_alloc(:) ! fraction of carbon balance allocated to seeds. + ! Derived parameters + + integer, allocatable :: organ_param_id(:) ! This is the sparse reverse lookup index map. This is dimensioned + ! by all the possible organs in parteh, and each index + ! may point to the index in the parameter file, or will be -1 + + real(r8), allocatable :: nitr_recr_stoich(:) ! This is the N:C ratio of newly recruited plants that are + ! on allometry at their recruitment diameter + + real(r8), allocatable :: phos_recr_stoich(:) ! This is the P:C ratio of newly recruited plants that are + ! on allometry at their recruitment diameter + + ! Allometry Parameters ! -------------------------------------------------------------------------------------------- diff --git a/parteh/PRTParamsFATESMod.F90 b/parteh/PRTParamsFATESMod.F90 index 3b56c571ff..56fdd1b71c 100644 --- a/parteh/PRTParamsFATESMod.F90 +++ b/parteh/PRTParamsFATESMod.F90 @@ -12,10 +12,25 @@ module PRTInitParamsFatesMod use PRTGenericMod, only : num_organ_types use PRTGenericMod, only : leaf_organ, fnrt_organ, store_organ use PRTGenericMod, only : sapw_organ, struct_organ, repro_organ + use PRTGenericMod, only : nitrogen_element, phosphorus_element use FatesGlobals, only : endrun => fates_endrun use FatesGlobals, only : fates_log use shr_log_mod, only : errMsg => shr_log_errMsg + use EDPftvarcon, only : EDPftvarcon_inst use PRTGenericMod, only : prt_cnp_flex_allom_hyp,prt_carbon_allom_hyp + use FatesAllometryMod , only : h_allom + use FatesAllometryMod , only : h2d_allom + use FatesAllometryMod , only : bagw_allom + use FatesAllometryMod , only : bsap_allom + use FatesAllometryMod , only : bleaf + use FatesAllometryMod , only : bfineroot + use FatesAllometryMod , only : bdead_allom + use FatesAllometryMod , only : bstore_allom + use FatesAllometryMod , only : bbgw_allom + use FatesAllometryMod , only : carea_allom + use FatesAllometryMod , only : CheckIntegratedAllometries + use FatesAllometryMod, only : set_root_fraction + use EDTypesMod, only : init_recruit_trim ! ! !PUBLIC TYPES: @@ -33,6 +48,7 @@ module PRTInitParamsFatesMod public :: PRTRegisterParams public :: PRTReceiveParams public :: PRTCheckParams + public :: PRTDerivedParams !----------------------------------------------------------------------- contains @@ -51,7 +67,8 @@ subroutine PRTRegisterParams(fates_params) call PRTRegisterPFTOrgans(fates_params) call PRTRegisterPFTLeafAge(fates_params) call Register_PFT_nvariants(fates_params) - + call PRTRegisterOrgan(fates_params) + end subroutine PRTRegisterParams !----------------------------------------------------------------------- @@ -67,10 +84,59 @@ subroutine PRTReceiveParams(fates_params) call PRTReceivePFTOrgans(fates_params) call PRTReceivePFTLeafAge(fates_params) call Receive_PFT_nvariants(fates_params) + call PRTReceiveOrgan(fates_params) end subroutine PRTReceiveParams - !----------------------------------------------------------------------- + ! ===================================================================================== + + subroutine PRTRegisterOrgan(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + use FatesParametersInterface, only : dimension_name_prt_organs, dimension_shape_1d + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_prt_organs/) + integer, parameter :: dim_lower_bound(1) = (/ lower_bound_general /) + character(len=param_string_length) :: name + + name = 'fates_prt_organ_id' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + end subroutine PRTRegisterOrgan + + ! ===================================================================================== + + subroutine PRTReceiveOrgan(fates_params) + + ! Make sure to call this after PRTRegisterPFTOrgans + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length) :: name + + real(r8), allocatable :: tmpreal(:) ! Temporary variable to hold floats + + name = 'fates_prt_organ_id' + call fates_params%RetreiveParameterAllocate(name=name, & + data=tmpreal) + print*,'organ_id' + allocate(prt_params%organ_id(size(tmpreal,dim=1))) + call ArrayNint(tmpreal,prt_params%organ_id) + deallocate(tmpreal) + + end subroutine PRTReceiveOrgan + + ! ===================================================================================== + subroutine PRTRegisterPFT(fates_params) use FatesParametersInterface, only : fates_parameters_type, param_string_length @@ -97,11 +163,6 @@ subroutine PRTRegisterPFT(fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - - !X! name = '' - !X! call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - !X! dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_fnrt_prof_a' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -277,6 +338,16 @@ subroutine PRTRegisterPFT(fates_params) name = 'fates_branch_turnover' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) + + + + name = 'fates_nitr_store_ratio' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_phos_store_ratio' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) end subroutine PRTRegisterPFT @@ -292,25 +363,38 @@ subroutine PRTReceivePFT(fates_params) character(len=param_string_length) :: name + real(r8), allocatable :: tmpreal(:) ! Temporary variable to hold floats + ! that are converted to ints !X! name = '' !X! call fates_params%RetreiveParameter(name=name, & !X! data=prt_params%) + name = 'fates_leaf_slamax' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%slamax) + + !allocate(tmpreal(size(prt_params%slamax,dim=1))) + name = 'fates_phen_stress_decid' call fates_params%RetreiveParameterAllocate(name=name, & - data=prt_params%stress_decid) - + data=tmpreal) + allocate(prt_params%stress_decid(size(tmpreal,dim=1))) + call ArrayNint(tmpreal,prt_params%stress_decid) + deallocate(tmpreal) + name = 'fates_phen_season_decid' call fates_params%RetreiveParameterAllocate(name=name, & - data=prt_params%season_decid) - + data=tmpreal) + allocate(prt_params%season_decid(size(tmpreal,dim=1))) + call ArrayNint(tmpreal,prt_params%season_decid) + deallocate(tmpreal) + name = 'fates_phen_evergreen' call fates_params%RetreiveParameterAllocate(name=name, & - data=prt_params%evergreen) - - name = 'fates_leaf_slamax' - call fates_params%RetreiveParameterAllocate(name=name, & - data=prt_params%slamax) + data=tmpreal) + allocate(prt_params%evergreen(size(tmpreal,dim=1))) + call ArrayNint(tmpreal,prt_params%evergreen) + deallocate(tmpreal) name = 'fates_leaf_slatop' call fates_params%RetreiveParameterAllocate(name=name, & @@ -484,7 +568,15 @@ subroutine PRTReceivePFT(fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=prt_params%turnover_retrans_mode) - + name = 'fates_nitr_store_ratio' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%nitr_store_ratio) + + name = 'fates_phos_store_ratio' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%phos_store_ratio) + + end subroutine PRTReceivePFT !----------------------------------------------------------------------- @@ -513,6 +605,29 @@ subroutine PRTRegisterPFTLeafAge(fates_params) return end subroutine PRTRegisterPFTLeafAge + ! ===================================================================================== + + subroutine ArrayNint(realarr,intarr) + + real(r8),intent(in) :: realarr(:) + integer,intent(out) :: intarr(:) + integer :: i + + !print*,size(realarr,dim=1) + !print*,size(intarr) + !print*,realarr + + !allocate(intarr(size(realarr,dim=1))) + + do i = 1,size(realarr,dim=1) + intarr(i) = nint(realarr(i)) + end do + + !deallocate(realarray) + + return + end subroutine ArrayNint + ! ===================================================================================== subroutine Register_PFT_nvariants(fates_params) @@ -760,12 +875,56 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'turnover_carb_retrans = ',prt_params%turnover_carb_retrans write(fates_log(),fmt0) 'turnover_nitr_retrans = ',prt_params%turnover_nitr_retrans write(fates_log(),fmt0) 'turnover_phos_retrans = ',prt_params%turnover_phos_retrans + write(fates_log(),fmt0) 'organ_id = ',prt_params%organ_id + write(fates_log(),fmt0) 'nitr_store_ratio = ',prt_params%nitr_store_ratio + write(fates_log(),fmt0) 'phos_store_ratio = ',prt_params%phos_store_ratio write(fates_log(),*) '-------------------------------------------------' end if end subroutine FatesReportPFTParams + ! ===================================================================================== + + subroutine PRTDerivedParams() + + integer :: npft ! number of PFTs + integer :: ft ! pft index + integer :: norgans ! number of organs in the parameter file + integer :: i, io ! generic loop index and organ loop index + + norgans = size(prt_params%organ_id,1) + npft = size(prt_params%evergreen,1) + + ! Set the reverse lookup map for organs to the parameter file index + allocate(prt_params%organ_param_id(num_organ_types)) + allocate(prt_params%nitr_recr_stoich(npft)) + allocate(prt_params%phos_recr_stoich(npft)) + + ! Initialize them as invalid + prt_params%organ_param_id(:) = -1 + + do i = 1,norgans + prt_params%organ_param_id(prt_params%organ_id(i)) = i + end do + + + ! Calculate the stoichiometry of a new recruit, and use this for defining + ! seed stoichiometry and + + do ft = 1,npft + + prt_params%nitr_recr_stoich(ft) = NewRecruitTotalStoichiometry(ft,nitrogen_element) + prt_params%phos_recr_stoich(ft) = NewRecruitTotalStoichiometry(ft,phosphorus_element) + + end do + + + + + return + end subroutine PRTDerivedParams + ! ===================================================================================== subroutine PRTCheckParams(is_master) @@ -793,37 +952,53 @@ subroutine PRTCheckParams(is_master) integer :: norgans ! size of the plant organ dimension integer :: i, io ! generic loop index and organ loop index - - integer, parameter,dimension(6) :: cnpflex_organs = & - [leaf_organ, fnrt_organ, sapw_organ, store_organ, repro_organ, struct_organ] - - npft = size(prt_params%evergreen,1) ! Prior to performing checks copy grperc to the ! organ dimensioned version - norgans = size(prt_params%nitr_stoich_p1,2) + norgans = size(prt_params%organ_id,1) if(.not.is_master) return - - - if (norgans .ne. num_organ_types) then - write(fates_log(),*) 'The size of the organ dimension for PRT parameters' - write(fates_log(),*) 'as specified in the parameter file is incompatible.' - write(fates_log(),*) 'All currently acceptable hypothesese are using' - write(fates_log(),*) 'the full set of num_organ_types = ',num_organ_types - write(fates_log(),*) 'The parameter file listed ',norgans - write(fates_log(),*) 'Exiting' + if( any(prt_params%organ_id(:)<1) .or. & + any(prt_params%organ_id(:)>num_organ_types) ) then + write(fates_log(),*) 'prt_organ_ids should match the global ids' + write(fates_log(),*) 'of organ types found in PRTGenericMod.F90' + write(fates_log(),*) 'organ_ids: ',prt_params%organ_id(:) + write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + ! Check to make sure the organ ids are valid if this is the + ! cnp_flex_allom_hypothesis + if ((hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) .or. & + (hlm_parteh_mode .eq. prt_carbon_allom_hyp) ) then + + do io = 1,norgans + if(prt_params%organ_id(io) == repro_organ) then + write(fates_log(),*) 'with flexible cnp or c-only alloc hypothesese' + write(fates_log(),*) 'reproductive tissues are a special case' + write(fates_log(),*) 'and therefore should not be included in' + write(fates_log(),*) 'the parameter file organ list' + write(fates_log(),*) 'fates_prt_organ_id: ',prt_params%organ_id(:) + write(fates_log(),*) 'Aborting' + end if + if(prt_params%organ_id(io) == store_organ) then + write(fates_log(),*) 'with flexible cnp or c-only alloc hypothesese' + write(fates_log(),*) 'storage is a special case' + write(fates_log(),*) 'and therefore should not be included in' + write(fates_log(),*) 'the parameter file organ list' + write(fates_log(),*) 'fates_prt_organ_id: ',prt_params%organ_id(:) + write(fates_log(),*) 'Aborting' + end if + + end do + end if - do ipft = 1,npft - + pftloop: do ipft = 1,npft + ! Check to see if evergreen, deciduous flags are mutually exclusive ! ---------------------------------------------------------------------------------- @@ -912,134 +1087,116 @@ subroutine PRTCheckParams(is_master) ! should not be re-translocating mass upon turnover. ! Note to advanced users. Feel free to remove these checks... ! ------------------------------------------------------------------- - - if ( (prt_params%turnover_carb_retrans(ipft,repro_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of reproductive tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,repro_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((prt_params%turnover_nitr_retrans(ipft,repro_organ) > nearzero) .or. & - (prt_params%turnover_phos_retrans(ipft,repro_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of reproductive tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,repro_organ) - write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,repro_organ) - write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,repro_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if ((prt_params%turnover_carb_retrans(ipft,sapw_organ) > nearzero)) then - write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,sapw_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((prt_params%turnover_nitr_retrans(ipft,sapw_organ) > nearzero) .or. & - (prt_params%turnover_phos_retrans(ipft,sapw_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,sapw_organ) - write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,sapw_organ) - write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,sapw_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - if ((prt_params%turnover_carb_retrans(ipft,struct_organ) > nearzero)) then - write(fates_log(),*) ' Retranslocation of structural(dead) tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,struct_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((prt_params%turnover_nitr_retrans(ipft,struct_organ) > nearzero) .or. & - (prt_params%turnover_phos_retrans(ipft,struct_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of structural(dead) tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,struct_organ) - write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,struct_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + if ((hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) .or. & + (hlm_parteh_mode .eq. prt_carbon_allom_hyp) ) then + + do i = 1,norgans + io = prt_params%organ_id(i) + + if(io == sapw_organ) then + if ((prt_params%turnover_carb_retrans(ipft,i) > nearzero)) then + write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon retrans: ',prt_params%turnover_carb_retrans(ipft,i) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + elseif(io == struct_organ) then + if ((prt_params%turnover_carb_retrans(ipft,i) > nearzero)) then + write(fates_log(),*) ' Retranslocation of structural tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon retrans: ',prt_params%turnover_carb_retrans(ipft,i) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! Otherwise, all other retranslocations should be between 0 and 1 + if ( (prt_params%turnover_carb_retrans(ipft,i) > 1.0_r8) .or. & + (prt_params%turnover_carb_retrans(ipft,i) < 0.0_r8) ) then + write(fates_log(),*) ' Retranslocation rates should be between 0 and 1.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' parameter file index: ',i,' global index: ',io + write(fates_log(),*) ' retranslocation rate: ',prt_params%turnover_carb_retrans(ipft,i) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end do end if - ! Leaf retranslocation should be between 0 and 1 - if ( (prt_params%turnover_carb_retrans(ipft,leaf_organ) > 1.0_r8) .or. & - (prt_params%turnover_carb_retrans(ipft,leaf_organ) < 0.0_r8) ) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,leaf_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((prt_params%turnover_nitr_retrans(ipft,leaf_organ) > 1.0_r8) .or. & - (prt_params%turnover_phos_retrans(ipft,leaf_organ) > 1.0_r8) .or. & - (prt_params%turnover_nitr_retrans(ipft,leaf_organ) < 0.0_r8) .or. & - (prt_params%turnover_phos_retrans(ipft,leaf_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,leaf_organ) - write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,leaf_organ) - write(fates_log(),*) ' Aborting' + + ! Make sure nutrient storage fractions are positive + if( prt_params%nitr_store_ratio(ipft) < 0._r8 ) then + write(fates_log(),*) 'With parteh allometric CNP hypothesis' + write(fates_log(),*) 'nitr_store_ratio must be > 0' + write(fates_log(),*) 'PFT#: ',ipft + write(fates_log(),*) 'nitr_store_ratio = ',prt_params%nitr_store_ratio(ipft) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - end if - - ! Fineroot retranslocation should be between 0-1 - if ((prt_params%turnover_carb_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & - (prt_params%turnover_carb_retrans(ipft,fnrt_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,fnrt_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((prt_params%turnover_nitr_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & - (prt_params%turnover_phos_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & - (prt_params%turnover_nitr_retrans(ipft,fnrt_organ) < 0.0_r8) .or. & - (prt_params%turnover_phos_retrans(ipft,fnrt_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,fnrt_organ) - write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,fnrt_organ) - write(fates_log(),*) ' Aborting' + if( prt_params%phos_store_ratio(ipft) < 0._r8 ) then + write(fates_log(),*) 'With parteh allometric CNP hypothesis' + write(fates_log(),*) 'phos_store_ratio must be > 0' + write(fates_log(),*) 'PFT#: ',ipft + write(fates_log(),*) 'nitr_store_ratio = ',prt_params%phos_store_ratio(ipft) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - end if - ! Storage retranslocation should be between 0-1 (storage retrans seems weird, but who knows) - if ((prt_params%turnover_carb_retrans(ipft,store_organ) > 1.0_r8) .or. & - (prt_params%turnover_carb_retrans(ipft,store_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,store_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((prt_params%turnover_nitr_retrans(ipft,store_organ) > 1.0_r8) .or. & - (prt_params%turnover_phos_retrans(ipft,store_organ) > 1.0_r8) .or. & - (prt_params%turnover_nitr_retrans(ipft,store_organ) < 0.0_r8) .or. & - (prt_params%turnover_phos_retrans(ipft,store_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,store_organ) - write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,store_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + do i = 1,norgans + io = prt_params%organ_id(i) + + if(io == sapw_organ) then + if ((prt_params%turnover_nitr_retrans(ipft,i) > nearzero)) then + write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' nitrogen retrans: ',prt_params%turnover_nitr_retrans(ipft,i) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if ((prt_params%turnover_phos_retrans(ipft,i) > nearzero)) then + write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' phosphorus retrans: ',prt_params%turnover_nitr_retrans(ipft,i) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + elseif(io == struct_organ) then + if ((prt_params%turnover_nitr_retrans(ipft,i) > nearzero)) then + write(fates_log(),*) ' Retranslocation of structural tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon retrans: ',prt_params%turnover_nitr_retrans(ipft,i) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if ((prt_params%turnover_phos_retrans(ipft,i) > nearzero)) then + write(fates_log(),*) ' Retranslocation of structural tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' phosphorus retrans: ',prt_params%turnover_nitr_retrans(ipft,i) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! Otherwise, all other retranslocations should be between 0 and 1 + if ((prt_params%turnover_nitr_retrans(ipft,i) > 1.0_r8) .or. & + (prt_params%turnover_phos_retrans(ipft,i) > 1.0_r8) .or. & + (prt_params%turnover_nitr_retrans(ipft,i) < 0.0_r8) .or. & + (prt_params%turnover_phos_retrans(ipft,i) < 0.0_r8)) then + write(fates_log(),*) ' Retranslocation should range from 0 to 1.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' parameter file organ index: ',i,' global index: ',io + write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,i) + write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,i) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end do + end if + ! Growth respiration ! if (parteh_mode .eq. prt_carbon_allom_hyp) then @@ -1060,30 +1217,30 @@ subroutine PRTCheckParams(is_master) ! end if ! end if - - ! The first nitrogen stoichiometry is used in all cases - if ( (any(prt_params%nitr_stoich_p1(ipft,:) < 0.0_r8)) .or. & - (any(prt_params%nitr_stoich_p1(ipft,:) >= 1.0_r8))) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' N per C stoichiometry must bet between 0-1' - write(fates_log(),*) prt_params%nitr_stoich_p1(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) + if ((hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) .or. & + (hlm_parteh_mode .eq. prt_carbon_allom_hyp) ) then + ! The first nitrogen stoichiometry is used in all cases + if ( (any(prt_params%nitr_stoich_p1(ipft,:) < 0.0_r8)) .or. & + (any(prt_params%nitr_stoich_p1(ipft,:) >= 1.0_r8))) then + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' N per C stoichiometry must bet between 0-1' + write(fates_log(),*) prt_params%nitr_stoich_p1(ipft,:) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if end if - if(hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then - do i = 1,size(cnpflex_organs,dim=1) - io = cnpflex_organs(i) - if ( (prt_params%nitr_stoich_p1(ipft,io) < 0._r8) .or. & - (prt_params%nitr_stoich_p2(ipft,io) < 0._r8) .or. & - (prt_params%phos_stoich_p1(ipft,io) < 0._r8) .or. & - (prt_params%phos_stoich_p2(ipft,io) < 0._r8) .or. & - (prt_params%nitr_stoich_p1(ipft,io) > 1._r8) .or. & - (prt_params%nitr_stoich_p2(ipft,io) > 1._r8) .or. & - (prt_params%phos_stoich_p1(ipft,io) > 1._r8) .or. & - (prt_params%phos_stoich_p2(ipft,io) > 1._r8) ) then + do i = 1,norgans + if ( (prt_params%nitr_stoich_p1(ipft,i) < 0._r8) .or. & + (prt_params%nitr_stoich_p2(ipft,i) < 0._r8) .or. & + (prt_params%phos_stoich_p1(ipft,i) < 0._r8) .or. & + (prt_params%phos_stoich_p2(ipft,i) < 0._r8) .or. & + (prt_params%nitr_stoich_p1(ipft,i) > 1._r8) .or. & + (prt_params%nitr_stoich_p2(ipft,i) > 1._r8) .or. & + (prt_params%phos_stoich_p1(ipft,i) > 1._r8) .or. & + (prt_params%phos_stoich_p2(ipft,i) > 1._r8) ) then write(fates_log(),*) 'When the C,N,P allocation hypothesis with flexible' write(fates_log(),*) 'stoichiometry is turned on (prt_cnp_flex_allom_hyp),' write(fates_log(),*) 'all stoichiometries must be greater than or equal to zero,' @@ -1093,10 +1250,10 @@ subroutine PRTCheckParams(is_master) write(fates_log(),*) 'You specified an organ/pft less than zero.' write(fates_log(),*) 'PFT: ',ipft write(fates_log(),*) 'organ index (see head of PRTGenericMod): ',io - write(fates_log(),*) 'nitr_stoich_p1: ',prt_params%nitr_stoich_p1(ipft,io) - write(fates_log(),*) 'nitr_stoich_p2: ',prt_params%phos_stoich_p1(ipft,io) - write(fates_log(),*) 'phos_stoich_p1: ',prt_params%nitr_stoich_p2(ipft,io) - write(fates_log(),*) 'phos_stoich_p2: ',prt_params%phos_stoich_p2(ipft,io) + write(fates_log(),*) 'nitr_stoich_p1: ',prt_params%nitr_stoich_p1(ipft,i) + write(fates_log(),*) 'nitr_stoich_p2: ',prt_params%phos_stoich_p1(ipft,i) + write(fates_log(),*) 'phos_stoich_p1: ',prt_params%nitr_stoich_p2(ipft,i) + write(fates_log(),*) 'phos_stoich_p2: ',prt_params%phos_stoich_p2(ipft,i) write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1114,8 +1271,6 @@ subroutine PRTCheckParams(is_master) end if - - ! Check turnover time-scales nleafage = size(prt_params%leaf_long,dim=2) @@ -1224,11 +1379,83 @@ subroutine PRTCheckParams(is_master) end if - end do + end do pftloop return end subroutine PRTCheckParams + ! ==================================================================================== + + function NewRecruitTotalStoichiometry(ft,element_id) result(recruit_stoich) + + ! ---------------------------------------------------------------------------------- + ! This function calculates the total N:C or P:C ratio for a newly recruited plant + ! It does this by first identifying the dbh of a new plant, then uses + ! allometry to calculate the starting amount of carbon, and then uses + ! the stoichiometry parameters to determine the proportional mass of N or P + ! + ! This process only has to be called once, and is then stored in parameter + ! constants for each PFT. These values are used for determining nutrient + ! fluxes into seed pools (on plant), and also from germinated seed polls (on ground) + ! into new recruits. + ! ---------------------------------------------------------------------------------- + + + integer,intent(in) :: ft + integer,intent(in) :: element_id + real(r8) :: recruit_stoich ! nutrient to carbon ratio of recruit + + real(r8) :: dbh ! dbh of the new recruit [cm] + real(r8) :: c_leaf ! target leaf biomass [kgC] + real(r8) :: c_fnrt ! target fine root biomass [kgC] + real(r8) :: c_sapw ! target sapwood biomass [kgC] + real(r8) :: a_sapw ! target sapwood cross section are [m2] (dummy) + real(r8) :: c_agw ! target Above ground biomass [kgC] + real(r8) :: c_bgw ! target Below ground biomass [kgC] + real(r8) :: c_struct ! target Structural biomass [kgc] + real(r8) :: c_store ! target Storage biomass [kgC] + real(r8) :: c_total ! total target carbon + real(r8) :: nutr_total ! total target nutrient + + call h2d_allom(EDPftvarcon_inst%hgt_min(ft),ft,dbh) + call bleaf(dbh,ft,init_recruit_trim,c_leaf) + call bfineroot(dbh,ft,init_recruit_trim,c_fnrt) + call bsap_allom(dbh,ft,init_recruit_trim,a_sapw, c_sapw) + call bagw_allom(dbh,ft,c_agw) + call bbgw_allom(dbh,ft,c_bgw) + call bdead_allom(c_agw,c_bgw,c_sapw,ft,c_struct) + call bstore_allom(dbh,ft,init_recruit_trim,c_store) + + ! Total carbon in a newly recruited plant + c_total = c_leaf + c_fnrt + c_sapw + c_struct + c_store + + ! Total nutrient in a newly recruited plant + select case(element_id) + case(nitrogen_element) + + nutr_total = & + c_struct*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + & + (1._r8 + prt_params%nitr_store_ratio(ft)) * & + (c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & + c_fnrt*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & + c_sapw*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) ) + + case(phosphorus_element) + + nutr_total = & + c_struct*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + & + (1._r8 + prt_params%phos_store_ratio(ft)) * & + (c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & + c_fnrt*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & + c_sapw*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) ) + + end select + + recruit_stoich = nutr_total/c_total + + + return + end function NewRecruitTotalStoichiometry end module PRTInitParamsFatesMod diff --git a/tools/FatesPFTIndexSwapper.py b/tools/FatesPFTIndexSwapper.py index a42d95da10..9e0830d626 100755 --- a/tools/FatesPFTIndexSwapper.py +++ b/tools/FatesPFTIndexSwapper.py @@ -207,13 +207,15 @@ def main(argv): out_var[:] = np.empty([num_pft_out,dim2_len], dtype="S{}".format(dim2_len)) for id,ipft in enumerate(donor_pft_indices): out_var[id] = fp_in.variables.get(key).data[ipft-1] - - + elif( (prt_dim_found==0) & (pft_dim_len==2) ): # fates_prt_organs - string_length out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] - + elif( prt_dim_found==0 ): + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + else: print('This variable has a dimensioning that we have not considered yet.') print('Please add this condition to the logic above this statement.') From e19ed476c08d5cbf035a9f197e835a822d1efee1 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 28 Jan 2021 13:29:27 -0500 Subject: [PATCH 200/578] scaling fixes fixes --- parteh/PRTAllometricCNPMod.F90 | 28 ++++++++++++++++++++-------- parteh/PRTParamsFATESMod.F90 | 26 +++++--------------------- 2 files changed, 25 insertions(+), 29 deletions(-) diff --git a/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 index 925f5aedc7..920938f07d 100644 --- a/parteh/PRTAllometricCNPMod.F90 +++ b/parteh/PRTAllometricCNPMod.F90 @@ -949,13 +949,16 @@ subroutine CNPPrioritizedReplacement(this, & do ii = 1, num_organs ! The priority code associated with this organ - if ( organ_list(ii).ne.repro_organ ) then - if( organ_list(ii).eq.store_organ ) then - priority_code = 2 - else - priority_code = int(prt_params%alloc_priority(ipft, prt_params%organ_param_id(organ_list(ii)))) - end if + ! Storage has a special hard-coded priority level of 2 + ! Note that it is also implicitly part of step 1 + + if( organ_list(ii).eq.store_organ ) then + priority_code = 2 + else + if( prt_params%organ_param_id(organ_list(ii)) <1 ) cycle + priority_code = int(prt_params%alloc_priority(ipft, prt_params%organ_param_id(organ_list(ii)))) end if + ! Don't allow allocation to leaves if they are in an "off" status. ! (this prevents accidental re-flushing on the day they drop) @@ -1391,7 +1394,11 @@ subroutine CNPStatureGrowth(this,c_gain, n_gain, p_gain, & case(3) - ! HACK, ALLOW FULL C ALLOCATION AND LET REST OF ALGORITHM LIMIT + ! No mathematical co-limitation of growth + ! This assumes that limitations will prevent + ! organs from allowing the growth step to even occur + ! and thus from an algorithmic level limit growth + c_gstature = c_gain @@ -1559,8 +1566,13 @@ subroutine CNPStatureGrowth(this,c_gain, n_gain, p_gain, & end if if_completed_solve end do do_solve_check - + ! Prioritize nutrient transfer to the reproductive pool + ! Note, that if we do not keep reproductive tissues on stoichiometry, the seed + ! pool for that pft will be off stoichiometry, and one of C,N or P will limit + ! recruitment. Per the current model formulation, new recruits are forced to + ! have their maximum stoichiometry in each organ. The total stoichiometry + ! of the recruits should match the stoichiometry of the seeds target_n = this%GetNutrientTarget(nitrogen_element,repro_organ,stoich_growth_min) deficit_n(repro_id) = this%GetDeficit(nitrogen_element,repro_organ,target_n) diff --git a/parteh/PRTParamsFATESMod.F90 b/parteh/PRTParamsFATESMod.F90 index 56fdd1b71c..035f101176 100644 --- a/parteh/PRTParamsFATESMod.F90 +++ b/parteh/PRTParamsFATESMod.F90 @@ -128,7 +128,6 @@ subroutine PRTReceiveOrgan(fates_params) name = 'fates_prt_organ_id' call fates_params%RetreiveParameterAllocate(name=name, & data=tmpreal) - print*,'organ_id' allocate(prt_params%organ_id(size(tmpreal,dim=1))) call ArrayNint(tmpreal,prt_params%organ_id) deallocate(tmpreal) @@ -364,17 +363,8 @@ subroutine PRTReceivePFT(fates_params) character(len=param_string_length) :: name real(r8), allocatable :: tmpreal(:) ! Temporary variable to hold floats - ! that are converted to ints - !X! name = '' - !X! call fates_params%RetreiveParameter(name=name, & - !X! data=prt_params%) + ! that are converted to ints - name = 'fates_leaf_slamax' - call fates_params%RetreiveParameterAllocate(name=name, & - data=prt_params%slamax) - - !allocate(tmpreal(size(prt_params%slamax,dim=1))) - name = 'fates_phen_stress_decid' call fates_params%RetreiveParameterAllocate(name=name, & data=tmpreal) @@ -395,6 +385,10 @@ subroutine PRTReceivePFT(fates_params) allocate(prt_params%evergreen(size(tmpreal,dim=1))) call ArrayNint(tmpreal,prt_params%evergreen) deallocate(tmpreal) + + name = 'fates_leaf_slamax' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%slamax) name = 'fates_leaf_slatop' call fates_params%RetreiveParameterAllocate(name=name, & @@ -613,17 +607,9 @@ subroutine ArrayNint(realarr,intarr) integer,intent(out) :: intarr(:) integer :: i - !print*,size(realarr,dim=1) - !print*,size(intarr) - !print*,realarr - - !allocate(intarr(size(realarr,dim=1))) - do i = 1,size(realarr,dim=1) intarr(i) = nint(realarr(i)) end do - - !deallocate(realarray) return end subroutine ArrayNint @@ -919,8 +905,6 @@ subroutine PRTDerivedParams() end do - - return end subroutine PRTDerivedParams From e50d027610e70d553b3d3fd23ee8c99fa7c1638c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 29 Jan 2021 13:23:29 -0500 Subject: [PATCH 201/578] Tweaked some order of operations in CNP allocation module --- parteh/PRTAllometricCNPMod.F90 | 39 +++++++++++++++++----------------- 1 file changed, 19 insertions(+), 20 deletions(-) diff --git a/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 index 920938f07d..d57c131894 100644 --- a/parteh/PRTAllometricCNPMod.F90 +++ b/parteh/PRTAllometricCNPMod.F90 @@ -788,15 +788,15 @@ subroutine CNPPrioritizedReplacement(this, & curpri_org(:) = fates_unset_int ! reset "current-priority" organ ids i = 0 do ii = 1, num_organs + + deficit_c(ii) = max(0._r8,this%GetDeficit(carbon12_element,organ_list(ii),target_c(ii))) ! The following logic bars any organs that were not given allocation priority if( prt_params%organ_param_id(organ_list(ii)) < 1 ) cycle - - deficit_c(ii) = max(0._r8,this%GetDeficit(carbon12_element,organ_list(ii),target_c(ii))) - + ! The priority code associated with this organ priority_code = int(prt_params%alloc_priority(ipft, prt_params%organ_param_id(organ_list(ii)))) - + ! Don't allow allocation to leaves if they are in an "off" status. ! Also, dont allocate to replace turnover if this is not evergreen ! (this prevents accidental re-flushing on the day they drop) @@ -955,8 +955,11 @@ subroutine CNPPrioritizedReplacement(this, & if( organ_list(ii).eq.store_organ ) then priority_code = 2 else - if( prt_params%organ_param_id(organ_list(ii)) <1 ) cycle - priority_code = int(prt_params%alloc_priority(ipft, prt_params%organ_param_id(organ_list(ii)))) + if( prt_params%organ_param_id(organ_list(ii)) <1 ) then + priority_code = -1 + else + priority_code = int(prt_params%alloc_priority(ipft,prt_params%organ_param_id(organ_list(ii)))) + end if end if @@ -1574,17 +1577,17 @@ subroutine CNPStatureGrowth(this,c_gain, n_gain, p_gain, & ! have their maximum stoichiometry in each organ. The total stoichiometry ! of the recruits should match the stoichiometry of the seeds - target_n = this%GetNutrientTarget(nitrogen_element,repro_organ,stoich_growth_min) - deficit_n(repro_id) = this%GetDeficit(nitrogen_element,repro_organ,target_n) + !!target_n = this%GetNutrientTarget(nitrogen_element,repro_organ,stoich_growth_min) + !!deficit_n(repro_id) = this%GetDeficit(nitrogen_element,repro_organ,target_n) - target_p = this%GetNutrientTarget(phosphorus_element,repro_organ,stoich_growth_min) - deficit_p(repro_id) = this%GetDeficit(phosphorus_element,repro_organ,target_p) + !!target_p = this%GetNutrientTarget(phosphorus_element,repro_organ,stoich_growth_min) + !!deficit_p(repro_id) = this%GetDeficit(phosphorus_element,repro_organ,target_p) ! Nitrogen for - call ProportionalNutrAllocation(state_n, deficit_n, n_gain, nitrogen_element,[repro_id]) + !!call ProportionalNutrAllocation(state_n, deficit_n, n_gain, nitrogen_element,[repro_id]) ! Phosphorus - call ProportionalNutrAllocation(state_p, deficit_p, p_gain, phosphorus_element,[repro_id]) + !!call ProportionalNutrAllocation(state_p, deficit_p, p_gain, phosphorus_element,[repro_id]) ! ----------------------------------------------------------------------------------- @@ -1614,10 +1617,6 @@ subroutine CNPStatureGrowth(this,c_gain, n_gain, p_gain, & end if end do - - - - ! Nitrogen call ProportionalNutrAllocation(state_n,deficit_n, & @@ -1828,21 +1827,21 @@ function GetNutrientTargetCNP(this,element_id,organ_id,stoich_mode) result(targe if( element_id == nitrogen_element) then - target_c = & + target_m = & leaf_c_target*prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(leaf_organ))+ & fnrt_c_target*prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(fnrt_organ))+ & sapw_c_target*prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(sapw_organ)) - target_m = target_c * prt_params%nitr_store_ratio(ipft) + target_m = target_m * prt_params%nitr_store_ratio(ipft) else - target_c = & + target_m = & leaf_c_target*prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(leaf_organ))+ & fnrt_c_target*prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(fnrt_organ))+ & sapw_c_target*prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(sapw_organ)) - target_m = target_c * prt_params%phos_store_ratio(ipft) + target_m = target_m * prt_params%phos_store_ratio(ipft) end if From d6ab00c8cae370453e50ab3b4bc95bd9b8de9105 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 29 Jan 2021 14:24:59 -0500 Subject: [PATCH 202/578] Placed cap on N/P storage fraction when calculating CN_scalar --- biogeochem/FatesSoilBGCFluxMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index e238180aba..3bcc485d1c 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -1024,7 +1024,8 @@ function ECACScalar(ccohort, element_id) result(c_scalar) ! storage approaches it's maximum holding capacity. store_max = ccohort%prt%GetNutrientTarget(element_id,store_organ,stoich_max) - store_frac = ccohort%prt%GetState(store_organ, element_id)/store_max + + store_frac = min(1.0_r8,ccohort%prt%GetState(store_organ, element_id)/store_max) c_scalar = logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))) From 8e10af7ff6ea5d89f06de0ffb423cad77cfa3f46 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sat, 30 Jan 2021 11:33:41 -0500 Subject: [PATCH 203/578] Removed N+P efflux from CNP model, as uptake downregulation will now suppress overshooting. Adjust logistic function to be only 1 parameter (k) --- biogeochem/FatesSoilBGCFluxMod.F90 | 10 +++++----- parteh/PRTAllometricCNPMod.F90 | 17 +++++++++++++---- 2 files changed, 18 insertions(+), 9 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 3bcc485d1c..f37f86abe2 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -1013,9 +1013,9 @@ function ECACScalar(ccohort, element_id) result(c_scalar) real(r8) :: store_frac ! Current nutrient storage relative to max real(r8) :: store_max ! Maximum nutrient storable by plant - real(r8), parameter :: logi_k = 35.0_r8 ! logistic function k - real(r8), parameter :: store_x0 = 0.85 ! storage fraction inflection point - real(r8), parameter :: logi_min = 0.001_r8 ! minimum cn_scalar for logistic + real(r8), parameter :: logi_k = 25.0_r8 ! logistic function k + real(r8), parameter :: store_x0 = 1.0_r8 ! storage fraction inflection point + real(r8), parameter :: logi_min = 0.0_r8 ! minimum cn_scalar for logistic ! In this method, we define the c_scalar term ! with a logistic function that goes to 1 (full need) @@ -1025,9 +1025,9 @@ function ECACScalar(ccohort, element_id) result(c_scalar) store_max = ccohort%prt%GetNutrientTarget(element_id,store_organ,stoich_max) - store_frac = min(1.0_r8,ccohort%prt%GetState(store_organ, element_id)/store_max) + store_frac = min(2.0_r8,ccohort%prt%GetState(store_organ, element_id)/store_max) - c_scalar = logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))) + c_scalar = max(0._r8,min(1._r8,logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))))) diff --git a/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 index d57c131894..5b37004f7c 100644 --- a/parteh/PRTAllometricCNPMod.F90 +++ b/parteh/PRTAllometricCNPMod.F90 @@ -1699,6 +1699,15 @@ subroutine CNPAllocateRemainder(this,c_gain, n_gain, p_gain, & p_gain, phosphorus_element, all_organs) + ! If any N or P is still hanging around, put it in storage + + state_n(store_id)%ptr = state_n(store_id)%ptr + n_gain + state_p(store_id)%ptr = state_p(store_id)%ptr + p_gain + + n_gain = 0._r8 + p_gain = 0._r8 + + ! ----------------------------------------------------------------------------------- ! If carbon is still available, lets cram some into storage overflow ! We will do this last, because we wanted the non-overflow storage @@ -1729,13 +1738,13 @@ subroutine CNPAllocateRemainder(this,c_gain, n_gain, p_gain, & ! ----------------------------------------------------------------------------------- c_efflux = max(0.0_r8,c_gain) - n_efflux = max(0.0_r8,n_gain) - p_efflux = max(0.0_r8,p_gain) +! n_efflux = max(0.0_r8,n_gain) +! p_efflux = max(0.0_r8,p_gain) c_gain = 0.0_r8 - n_gain = 0.0_r8 - p_gain = 0.0_r8 +! n_gain = 0.0_r8 +! p_gain = 0.0_r8 return end subroutine CNPAllocateRemainder From 66f3d4c1f3fb2c62efdc28c3616cc793d59216d6 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 15 Feb 2021 14:29:01 -0500 Subject: [PATCH 204/578] parteh updates: 1) new downregulation (linear and CN) functions for ECA uptake, 2) new storage fraction diagnostics, 3) function calls to get storage targets and 4) some code cleaning related to defining need --- biogeochem/EDPhysiologyMod.F90 | 38 +++--- biogeochem/FatesSoilBGCFluxMod.F90 | 87 ++++++++---- main/EDInitMod.F90 | 8 +- main/FatesHistoryInterfaceMod.F90 | 94 ++++++++++++- main/FatesInventoryInitMod.F90 | 11 +- parteh/PRTAllometricCNPMod.F90 | 210 ++++++++++++++--------------- parteh/PRTGenericMod.F90 | 2 +- 7 files changed, 286 insertions(+), 164 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 0dad9109b3..388a50da4f 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -102,8 +102,10 @@ module EDPhysiologyMod use PRTLossFluxesMod, only : PRTPhenologyFlush use PRTLossFluxesMod, only : PRTDeciduousTurnover use PRTLossFluxesMod, only : PRTReproRelease + use PRTAllometricCNPMod, only : StorageNutrientTarget - + implicit none + private public :: trim_canopy public :: phenology @@ -1700,22 +1702,30 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) case(nitrogen_element) - mass_demand = & - c_struct*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + & - (1._r8 + prt_params%nitr_store_ratio(ft)) * & - (c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & - c_fnrt*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & - c_sapw*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) ) + mass_demand = & + c_struct*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + & + c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & + c_fnrt*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & + c_sapw*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) + & + StorageNutrientTarget(ft, element_id, & + c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)), & + c_fnrt*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)), & + c_sapw*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)), & + c_struct*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(struct_organ))) case(phosphorus_element) mass_demand = & c_struct*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + & - (1._r8 + prt_params%phos_store_ratio(ft)) * & - (c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & + c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & c_fnrt*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & - c_sapw*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) ) - + c_sapw*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) + & + StorageNutrientTarget(ft, element_id, & + c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)), & + c_fnrt*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)), & + c_sapw*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)), & + c_struct*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(struct_organ))) + case default write(fates_log(),*) 'Undefined element type in recruitment' call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1772,8 +1782,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) m_leaf = c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) m_fnrt = c_fnrt*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) m_sapw = c_sapw*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) - m_store = prt_params%nitr_store_ratio(ft) * & - (m_leaf+m_fnrt+m_sapw) + m_store = StorageNutrientTarget(ft, element_id, m_leaf, m_fnrt, m_sapw, m_struct ) m_repro = 0._r8 case(phosphorus_element) @@ -1782,8 +1791,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) m_leaf = c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) m_fnrt = c_fnrt*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) m_sapw = c_sapw*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) - m_store = prt_params%phos_store_ratio(ft) * & - (m_leaf+m_fnrt+m_sapw) + m_store = StorageNutrientTarget(ft, element_id, m_leaf, m_fnrt, m_sapw, m_struct ) m_repro = 0._r8 end select diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index f37f86abe2..a8076c90be 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -74,7 +74,8 @@ module FatesSoilBGCFluxMod use FatesLitterMod , only : icellulose use PRTParametersMod , only : prt_params use EDPftvarcon , only : EDPftvarcon_inst - + use PRTAllometricCNPMod, only : StorageNutrientTarget + implicit none private @@ -116,8 +117,9 @@ function GetPlantDemand(ccohort,element_id) result(plant_demand) real(r8) :: plant_max_x ! Maximum mass for element of interest [kg] integer :: pft real(r8) :: dbh + real(r8) :: leafm,fnrtm,sapwm,structm,storem - real(r8), parameter :: smth_fac = 0.8_r8 ! Smoothing factor for updating + real(r8), parameter :: smth_fac = 0.1_r8 ! Smoothing factor for updating ! demand. real(r8), parameter :: init_demand_frac = 0.1_r8 ! Newly recruited plants ! will specify a demand @@ -137,25 +139,28 @@ function GetPlantDemand(ccohort,element_id) result(plant_demand) if(ccohort%isnew) then if(element_id.eq.nitrogen_element) then - plant_max_x = & - (1._r8 + prt_params%nitr_store_ratio(pft)) * & - (ccohort%prt%GetState(leaf_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(leaf_organ)) + & - ccohort%prt%GetState(fnrt_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(fnrt_organ)) + & - ccohort%prt%GetState(sapw_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(sapw_organ))) + & - ccohort%prt%GetState(struct_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(struct_organ)) + + leafm = ccohort%prt%GetState(leaf_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(leaf_organ)) + fnrtm = ccohort%prt%GetState(fnrt_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(fnrt_organ)) + sapwm = ccohort%prt%GetState(sapw_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(sapw_organ)) + structm = ccohort%prt%GetState(struct_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(struct_organ)) + storem = StorageNutrientTarget(pft, element_id, leafm,fnrtm,sapwm,structm) + plant_max_x = leafm+fnrtm+sapwm+structm+storem elseif(element_id.eq.phosphorus_element) then - plant_max_x = & - (1._r8 + prt_params%phos_store_ratio(pft)) * & - (ccohort%prt%GetState(leaf_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(leaf_organ)) + & - ccohort%prt%GetState(fnrt_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(fnrt_organ)) + & - ccohort%prt%GetState(sapw_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(sapw_organ))) + & - ccohort%prt%GetState(struct_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(struct_organ)) + + leafm = ccohort%prt%GetState(leaf_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(leaf_organ)) + fnrtm = ccohort%prt%GetState(fnrt_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(fnrt_organ)) + sapwm = ccohort%prt%GetState(sapw_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(sapw_organ)) + structm = ccohort%prt%GetState(struct_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(struct_organ)) + storem = StorageNutrientTarget(pft, element_id, leafm,fnrtm,sapwm,structm) + + plant_max_x = leafm+fnrtm+sapwm+structm+storem end if - plant_demand = init_demand_frac*plant_max_x + plant_demand = 0._r8 ! (let the storage handle the first day) init_demand_frac*plant_max_x return end if @@ -1012,23 +1017,57 @@ function ECACScalar(ccohort, element_id) result(c_scalar) ! Locals real(r8) :: store_frac ! Current nutrient storage relative to max real(r8) :: store_max ! Maximum nutrient storable by plant + real(r8) :: store_c ! Current storage carbon + real(r8) :: store_c_max ! Current maximum storage carbon + + integer, parameter :: downreg_linear = 1 + integer, parameter :: downreg_logi = 2 + integer, parameter :: downreg_CN_logi = 3 + + integer, parameter :: downreg_type = downreg_linear + real(r8), parameter :: logi_k = 25.0_r8 ! logistic function k real(r8), parameter :: store_x0 = 1.0_r8 ! storage fraction inflection point real(r8), parameter :: logi_min = 0.0_r8 ! minimum cn_scalar for logistic - - ! In this method, we define the c_scalar term - ! with a logistic function that goes to 1 (full need) - ! as the plant's nutrien storage hits a low threshold - ! and goes to 0, no demand, as the plant's nutrient - ! storage approaches it's maximum holding capacity. - - store_max = ccohort%prt%GetNutrientTarget(element_id,store_organ,stoich_max) + ! This is the storage fraction where downregulation starts if using + ! a linear function + real(r8), parameter :: store_frac0 = 0.5_r8 + + store_max = ccohort%prt%GetNutrientTarget(element_id,store_organ,stoich_max) store_frac = min(2.0_r8,ccohort%prt%GetState(store_organ, element_id)/store_max) - c_scalar = max(0._r8,min(1._r8,logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))))) + if(downreg_type == downreg_linear) then + c_scalar = min(1.0_r8,max(0._r8,1.0 - (store_frac - store_frac0)/(1.0_r8-store_frac0))) + + elseif(downreg_type == downreg_logi) then + + ! In this method, we define the c_scalar term + ! with a logistic function that goes to 1 (full need) + ! as the plant's nutrien storage hits a low threshold + ! and goes to 0, no demand, as the plant's nutrient + ! storage approaches it's maximum holding capacity + + c_scalar = max(0._r8,min(1._r8,logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))))) + + else + + store_c = ccohort%prt%GetState(store_organ, carbon12_element) + call bstore_allom(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,store_c_max) + + ! Fraction of N per fraction of C + ! If this is greater than 1, then we have more N in storage than + ! we have C, so we downregulate. If this is less than 1, then + ! we have less N in storage than we have C, so up-regulate + + store_frac = store_frac / (store_c/store_c_max) + + c_scalar = max(0._r8,min(1._r8,logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))))) + + + end if end function ECACScalar diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index c049e6ef69..787431898d 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -52,7 +52,7 @@ module EDInitMod use FatesAllometryMod , only : bsap_allom use FatesAllometryMod , only : bdead_allom use FatesAllometryMod , only : bstore_allom - + use PRTAllometricCNPMod , only : StorageNutrientTarget use FatesInterfaceTypesMod, only : hlm_parteh_mode use PRTGenericMod, only : prt_carbon_allom_hyp use PRTGenericMod, only : prt_cnp_flex_allom_hyp @@ -593,9 +593,8 @@ subroutine init_cohorts( site_in, patch_in, bc_in) m_leaf = c_leaf*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(leaf_organ)) m_fnrt = c_fnrt*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(fnrt_organ)) m_sapw = c_sapw*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(sapw_organ)) - m_store = prt_params%nitr_store_ratio(pft) * & - (m_leaf+m_fnrt+m_sapw) m_repro = 0._r8 + m_store = StorageNutrientTarget(pft,element_id,m_leaf,m_fnrt,m_sapw,m_struct) case(phosphorus_element) @@ -603,9 +602,8 @@ subroutine init_cohorts( site_in, patch_in, bc_in) m_leaf = c_leaf*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(leaf_organ)) m_fnrt = c_fnrt*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(fnrt_organ)) m_sapw = c_sapw*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(sapw_organ)) - m_store = prt_params%phos_store_ratio(pft) * & - (m_leaf+m_fnrt+m_sapw) m_repro = 0._r8 + m_store = StorageNutrientTarget(pft,element_id,m_leaf,m_fnrt,m_sapw,m_struct) end select diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index cbf1eda487..b3ea47d39b 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -8,6 +8,7 @@ module FatesHistoryInterfaceMod use FatesConstantsMod , only : calloc_abs_error use FatesConstantsMod , only : mg_per_kg use FatesConstantsMod , only : pi_const + use FatesConstantsMod , only : nearzero use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun use EDTypesMod , only : nclmax @@ -153,6 +154,7 @@ module FatesHistoryInterfaceMod integer :: ih_totvegc_si integer :: ih_storen_si + integer :: ih_storentfrac_si integer :: ih_leafn_si integer :: ih_sapwn_si integer :: ih_fnrtn_si @@ -160,6 +162,7 @@ module FatesHistoryInterfaceMod integer :: ih_totvegn_si integer :: ih_storep_si + integer :: ih_storeptfrac_si integer :: ih_leafp_si integer :: ih_sapwp_si integer :: ih_fnrtp_si @@ -212,6 +215,7 @@ module FatesHistoryInterfaceMod integer :: ih_leafn_scpf integer :: ih_fnrtn_scpf integer :: ih_storen_scpf + integer :: ih_storentfrac_scpf integer :: ih_sapwn_scpf integer :: ih_repron_scpf integer :: ih_nuptake_scpf @@ -231,6 +235,7 @@ module FatesHistoryInterfaceMod integer :: ih_fnrtp_scpf integer :: ih_reprop_scpf integer :: ih_storep_scpf + integer :: ih_storeptfrac_scpf integer :: ih_sapwp_scpf integer :: ih_puptake_scpf integer :: ih_pefflux_scpf @@ -1712,7 +1717,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) integer :: ageclass_since_anthrodist ! what is the equivalent age class for ! time-since-anthropogenic-disturbance of secondary forest - + real(r8) :: store_max ! The target nutrient mass for storage element of interest [kg] real(r8) :: n_perm2 ! individuals per m2 for the whole column real(r8) :: dbh ! diameter ("at breast height") real(r8) :: coage ! cohort age @@ -2235,6 +2240,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) store_m = ccohort%prt%GetState(store_organ, element_list(el)) repro_m = ccohort%prt%GetState(repro_organ, element_list(el)) + alive_m = leaf_m + fnrt_m + sapw_m total_m = alive_m + store_m + struct_m @@ -2293,8 +2299,12 @@ subroutine update_history_dyn(this,nc,nsites,sites) elseif(element_list(el).eq.nitrogen_element)then + store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) + this%hvars(ih_storen_si)%r81d(io_si) = & this%hvars(ih_storen_si)%r81d(io_si) + ccohort%n * store_m + this%hvars(ih_storentfrac_si)%r81d(io_si) = & + this%hvars(ih_storentfrac_si)%r81d(io_si) + ccohort%n * store_max this%hvars(ih_leafn_si)%r81d(io_si) = & this%hvars(ih_leafn_si)%r81d(io_si) + ccohort%n * leaf_m this%hvars(ih_fnrtn_si)%r81d(io_si) = & @@ -2308,9 +2318,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) elseif(element_list(el).eq.phosphorus_element) then + + store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) this%hvars(ih_storep_si)%r81d(io_si) = & this%hvars(ih_storep_si)%r81d(io_si) + ccohort%n * store_m + this%hvars(ih_storeptfrac_si)%r81d(io_si) = & + this%hvars(ih_storeptfrac_si)%r81d(io_si) + ccohort%n * store_max this%hvars(ih_leafp_si)%r81d(io_si) = & this%hvars(ih_leafp_si)%r81d(io_si) + ccohort%n * leaf_m this%hvars(ih_fnrtp_si)%r81d(io_si) = & @@ -2325,7 +2339,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) end if end do - + ! Update PFT crown area @@ -2912,6 +2926,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! while in this loop, pass the fusion-induced growth rate flux to history hio_growthflux_fusion_si_scpf(io_si,i_scpf) = hio_growthflux_fusion_si_scpf(io_si,i_scpf) + & sites(s)%growthflux_fusion(i_scls, i_pft) * days_per_year + + + + + end do end do ! @@ -3055,6 +3074,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_fnrtn_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_sapwn_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_storen_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storentfrac_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_repron_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_nuptake_scpf)%r82d(io_si,:) = & @@ -3082,6 +3102,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_fnrtp_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_sapwp_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_storep_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storeptfrac_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_reprop_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_puptake_scpf)%r82d(io_si,:) = & @@ -3166,6 +3187,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) repro_m = ccohort%prt%GetState(repro_organ, element_list(el)) total_m = sapw_m+struct_m+leaf_m+fnrt_m+store_m+repro_m + i_scpf = ccohort%size_by_pft_class if(element_list(el).eq.carbon12_element)then @@ -3182,6 +3204,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) + repro_m * ccohort%n elseif(element_list(el).eq.nitrogen_element)then + + store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) + this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) + total_m * ccohort%n this%hvars(ih_leafn_scpf)%r82d(io_si,i_scpf) = & @@ -3194,7 +3219,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) + store_m * ccohort%n this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) + repro_m * ccohort%n + this%hvars(ih_storentfrac_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storentfrac_scpf)%r82d(io_si,i_scpf) + store_max * ccohort%n + elseif(element_list(el).eq.phosphorus_element)then + + store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) + this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) + total_m * ccohort%n this%hvars(ih_leafp_scpf)%r82d(io_si,i_scpf) = & @@ -3207,6 +3238,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) + store_m * ccohort%n this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) + repro_m * ccohort%n + this%hvars(ih_storeptfrac_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storeptfrac_scpf)%r82d(io_si,i_scpf) + store_max * ccohort%n end if ccohort => ccohort%shorter @@ -3216,10 +3249,42 @@ subroutine update_history_dyn(this,nc,nsites,sites) end do end do - - + ! Normalize nutrient storage fractions + do el = 1, num_elements + if(element_list(el).eq.nitrogen_element)then + if( this%hvars(ih_storentfrac_si)%r81d(io_si)>nearzero ) then + this%hvars(ih_storentfrac_si)%r81d(io_si) = this%hvars(ih_storen_si)%r81d(io_si) / & + this%hvars(ih_storentfrac_si)%r81d(io_si) + end if + do i_pft = 1, numpft + do i_scls = 1,nlevsclass + i_scpf = (i_pft-1)*nlevsclass + i_scls + if( this%hvars(ih_storentfrac_scpf)%r82d(io_si,i_scpf)>nearzero ) then + this%hvars(ih_storentfrac_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) / & + this%hvars(ih_storentfrac_scpf)%r82d(io_si,i_scpf) + end if + end do + end do + elseif(element_list(el).eq.phosphorus_element)then + if( this%hvars(ih_storeptfrac_si)%r81d(io_si)>nearzero ) then + this%hvars(ih_storeptfrac_si)%r81d(io_si) = this%hvars(ih_storep_si)%r81d(io_si) / & + this%hvars(ih_storeptfrac_si)%r81d(io_si) + end if + do i_pft = 1, numpft + do i_scls = 1,nlevsclass + i_scpf = (i_pft-1)*nlevsclass + i_scls + if( this%hvars(ih_storeptfrac_scpf)%r82d(io_si,i_scpf)>nearzero ) then + this%hvars(ih_storeptfrac_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) / & + this%hvars(ih_storeptfrac_scpf)%r82d(io_si,i_scpf) + end if + end do + end do + end if + end do ! pass demotion rates and associated carbon fluxes to history do i_scls = 1,nlevsclass @@ -4562,6 +4627,11 @@ subroutine define_history_vars(this, initialize_variables) long='Total nitrogen in live plant storage', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_storen_si ) + + call this%set_history_var(vname='STOREN_TFRAC', units='-', & + long='Storage N fraction of target', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_storentfrac_si ) call this%set_history_var(vname='TOTVEGN', units='kgN ha-1', & long='Total nitrogen in live plants', use_default='active', & @@ -4611,6 +4681,11 @@ subroutine define_history_vars(this, initialize_variables) long='Total phosphorus in live plant storage', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_storep_si ) + + call this%set_history_var(vname='STOREP_TFRAC', units='fraction', & + long='Storage P fraction of target', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_storeptfrac_si ) call this%set_history_var(vname='TOTVEGP', units='kgP ha-1', & long='Total phosphorus in live plants', use_default='active', & @@ -5910,6 +5985,11 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storen_scpf ) + call this%set_history_var(vname='STOREN_TFRAC_SCPF', units='kgN/ha', & + long='storage nitrogen fraction of target by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storentfrac_scpf ) + call this%set_history_var(vname='REPRON_SCPF', units='kgN/ha', & long='reproductive nitrogen mass (on plant) by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & @@ -5959,6 +6039,12 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storep_scpf ) + call this%set_history_var(vname='STOREP_TFRAC_SCPF', units='kgN/ha', & + long='storage phosphorus fraction of target by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storeptfrac_scpf ) + + call this%set_history_var(vname='REPROP_SCPF', units='kgP/ha', & long='reproductive phosphorus mass (on plant) by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 15e980cfa3..8a2b588023 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -62,7 +62,8 @@ module FatesInventoryInitMod use PRTGenericMod, only : phosphorus_element use PRTGenericMod, only : SetState use FatesConstantsMod, only : primaryforest - + use PRTAllometricCNPMod, only : StorageNutrientTarget + implicit none private @@ -1103,9 +1104,10 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & (prt_params%nitr_stoich_p1(temp_cohort%pft,prt_params%organ_param_id(sapw_organ)) + & prt_params%nitr_stoich_p2(temp_cohort%pft,prt_params%organ_param_id(sapw_organ))) - m_store = prt_params%nitr_store_ratio(temp_cohort%pft) * (m_leaf+m_fnrt+m_sapw) m_repro = 0._r8 + m_store = StorageNutrientTarget(temp_cohort%pft, element_id, m_leaf, m_fnrt, m_sapw, m_struct) + case(phosphorus_element) m_struct = c_struct * 0.5_r8 * & @@ -1124,9 +1126,10 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & (prt_params%phos_stoich_p1(temp_cohort%pft,prt_params%organ_param_id(sapw_organ)) + & prt_params%phos_stoich_p2(temp_cohort%pft,prt_params%organ_param_id(sapw_organ))) - m_store = prt_params%phos_store_ratio(temp_cohort%pft) * (m_leaf+m_fnrt+m_sapw) m_repro = 0._r8 - + + m_store = StorageNutrientTarget(temp_cohort%pft, element_id, m_leaf, m_fnrt, m_sapw, m_struct) + end select select case(hlm_parteh_mode) diff --git a/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 index 5b37004f7c..a43981e469 100644 --- a/parteh/PRTAllometricCNPMod.F90 +++ b/parteh/PRTAllometricCNPMod.F90 @@ -165,6 +165,8 @@ module PRTAllometricCNPMod integer, parameter :: num_bc_out = 5 ! Total number of + + ! ------------------------------------------------------------------------------------- ! Define the size of the coorindate vector. For this hypothesis, there is only ! one pool per each species x organ combination, except for leaves (WHICH HAVE AGE) @@ -232,7 +234,7 @@ module PRTAllometricCNPMod logical, parameter :: debug = .false. public :: InitPRTGlobalAllometricCNP - + public :: StorageNutrientTarget contains @@ -383,11 +385,6 @@ subroutine DailyPRTAllometricCNP(this) real(r8) :: target_n,target_p real(r8) :: sum_c ! error checking sum - integer, parameter :: unrstr_cgrow_nutr_need = 1 - integer, parameter :: refill_store_nutr_need = 2 - integer, parameter :: nutr_need_mode = refill_store_nutr_need - - ! integrator variables ! Copy the input only boundary conditions into readable local variables @@ -476,68 +473,6 @@ subroutine DailyPRTAllometricCNP(this) end do - assess_need_if: if(nutr_need_mode.eq.unrstr_cgrow_nutr_need) then - - ! =================================================================================== - ! Step 1. Prioritized allocation to replace tissues from turnover, and/or pay - ! any un-paid maintenance respiration from storage. - ! =================================================================================== - - call this%CNPPrioritizedReplacement(maint_r_def, c_gain_unl, n_gain_unl, p_gain_unl, & - state_c, state_n, state_p, target_c) - - ! Uncomment to see intermediate n and p needs - !n_grow = n_gain_unl0 - n_gain_unl - !p_grow = p_gain_unl0 - p_gain_unl - - ! =================================================================================== - ! Step 2. Grow out the stature of the plant by allocating to tissues beyond - ! current targets. - ! Attempts have been made to get all pools and species closest to allometric - ! targets based on prioritized relative demand and allometry functions. - ! =================================================================================== - - call this%CNPStatureGrowth(c_gain_unl, n_gain_unl, p_gain_unl, & - state_c, state_n, state_p, target_c, target_dcdd, cnp_limiter) - - ! =================================================================================== - ! Step 3. - ! At this point, 1 of the 3 resources (C,N,P) has been used up for stature growth. - ! Allocate the remaining resources, or as a last resort, efflux them. - ! =================================================================================== - - call this%CNPAllocateRemainder(c_gain_unl, n_gain_unl, p_gain_unl, & - state_c, state_n, state_p, c_efflux, n_efflux, p_efflux) - - n_need = max(n_gain_unl0 - n_efflux,0._r8) - p_need = max(p_gain_unl0 - p_efflux,0._r8) - - ! We must now reset the state so that we can perform nutrient limited allocation - ! Note: Even if there is more than 1 leaf pool, allocation only modifies - ! the first pool, so no need to reset the others - do i_org = 1,num_organs - - i_var = prt_global%sp_organ_map(organ_list(i_org),carbon12_element) - this%variables(i_var)%val(1) = state_c0(i_org) - state_c(i_org)%ptr => this%variables(i_var)%val(1) - - i_var = prt_global%sp_organ_map(organ_list(i_org),nitrogen_element) - this%variables(i_var)%val(1) = state_n0(i_org) - state_n(i_org)%ptr => this%variables(i_var)%val(1) - - i_var = prt_global%sp_organ_map(organ_list(i_org),phosphorus_element) - this%variables(i_var)%val(1) = state_p0(i_org) - state_p(i_org)%ptr => this%variables(i_var)%val(1) - - end do - - ! Reset the maintenance respiration deficit and the growth - ! respiration - maint_r_def = maint_r_def0 - dbh = dbh0 - - end if assess_need_if - ! =================================================================================== ! Step 0. Transfer all stored nutrient into the daily uptake pool. ! Storage in nutrients does not need to have a buffer like @@ -652,9 +587,6 @@ subroutine DailyPRTAllometricCNP(this) allocated_p = allocated_p + (state_p(i_org)%ptr - state_p0(i_org)) end do - - - if(debug) then @@ -677,31 +609,11 @@ subroutine DailyPRTAllometricCNP(this) end if end if - ! Alternative need hypothesis, need is based simply on storage deficit - ! at end of time-step - if(nutr_need_mode.eq.refill_store_nutr_need) then - - target_n = this%GetNutrientTarget(nitrogen_element,store_organ,stoich_max) - target_p = this%GetNutrientTarget(phosphorus_element,store_organ,stoich_max) - - n_need = max(target_n - state_n(store_id)%ptr,0._r8) - p_need = max(target_p - state_p(store_id)%ptr,0._r8) - -! print*,"================" -! allocated_n = (state_n(leaf_id)%ptr - state_n0(leaf_id)) + & -! (state_n(fnrt_id)%ptr - state_n0(fnrt_id)) + & -! (state_n(sapw_id)%ptr - state_n0(sapw_id)) + & -! (state_n(repro_id)%ptr - state_n0(repro_id)) + & -! (state_n(struct_id)%ptr - state_n0(struct_id)) - -! print*,"dbh: ",dbh -! print*,"need:",n_need -! print*,"max storage:",target_n -! print*,"allocated: ",allocated_n -! print*,"alloc/max: ",allocated_n/target_n - - - end if + target_n = this%GetNutrientTarget(nitrogen_element,store_organ) + target_p = this%GetNutrientTarget(phosphorus_element,store_organ) + + n_need = max(target_n - state_n(store_id)%ptr,0._r8) + p_need = max(target_p - state_p(store_id)%ptr,0._r8) deallocate(state_c) deallocate(state_n) @@ -1798,7 +1710,7 @@ function GetNutrientTargetCNP(this,element_id,organ_id,stoich_mode) result(targe class(cnp_allom_prt_vartypes) :: this integer, intent(in) :: element_id integer, intent(in) :: organ_id - integer, intent(in) :: stoich_mode + integer, intent(in),optional :: stoich_mode real(r8) :: target_m ! Target amount of nutrient for this organ [kg] real(r8) :: target_c @@ -1810,6 +1722,8 @@ function GetNutrientTargetCNP(this,element_id,organ_id,stoich_mode) result(targe real(r8) :: leaf_c_target,fnrt_c_target real(r8) :: sapw_c_target,agw_c_target real(r8) :: bgw_c_target,struct_c_target + + dbh => this%bc_inout(acnp_bc_inout_id_dbh)%rval @@ -1835,23 +1749,20 @@ function GetNutrientTargetCNP(this,element_id,organ_id,stoich_mode) result(targe ! non-reproductive organs if( element_id == nitrogen_element) then - - target_m = & - leaf_c_target*prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(leaf_organ))+ & - fnrt_c_target*prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(fnrt_organ))+ & - sapw_c_target*prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(sapw_organ)) - - target_m = target_m * prt_params%nitr_store_ratio(ipft) + target_m = StorageNutrientTarget(ipft, element_id, & + leaf_c_target*prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(leaf_organ)), & + fnrt_c_target*prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(fnrt_organ)), & + sapw_c_target*prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(sapw_organ)), & + struct_c_target*prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(struct_organ))) else - - target_m = & - leaf_c_target*prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(leaf_organ))+ & - fnrt_c_target*prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(fnrt_organ))+ & - sapw_c_target*prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(sapw_organ)) - target_m = target_m * prt_params%phos_store_ratio(ipft) - + target_m = StorageNutrientTarget(ipft, element_id, & + leaf_c_target*prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(leaf_organ)), & + fnrt_c_target*prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(fnrt_organ)), & + sapw_c_target*prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(sapw_organ)), & + struct_c_target*prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(struct_organ))) + end if elseif(organ_id == repro_organ) then @@ -1865,6 +1776,13 @@ function GetNutrientTargetCNP(this,element_id,organ_id,stoich_mode) result(targe else + + if(.not.present(stoich_mode))then + write(fates_log(),*) 'Must specify if nutrient target is growthmin or max' + write(fates_log(),*) 'for non-reproductive and non-storage organs' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + ! In all cases, we want the first index because for non-leaves ! that is the only index, and for leaves, that is the newly ! growing index. @@ -2384,5 +2302,75 @@ subroutine TargetAllometryCheck(bleaf,bfroot,bsap,bstore,bdead, & end if end subroutine TargetAllometryCheck + ! ==================================================================================== + + function StorageNutrientTarget(pft, element_id, leaf_target, fnrt_target, sapw_target, struct_target) result(store_target) + + integer :: pft + integer :: element_id + real(r8) :: leaf_target ! Target leaf nutrient mass [kg] + real(r8) :: fnrt_target ! Target fineroot nutrient mass [kg] + real(r8) :: sapw_target ! Target sapwood nutrient mass [kg] + real(r8) :: struct_target ! Target structural nutrient mass [kg] + + real(r8) :: store_target ! Output: Target storage nutrient mass [kg] + + + ! ------------------------------------------------------------------------------------- + ! Choice of how nutrient storage target is proportioned to + ! Each choice makes the nutrient storage proportional the the "in-tissue" + ! total nitrogen content of 1 or more sets of organs + ! ------------------------------------------------------------------------------------- + + integer, parameter :: lfs_store_prop = 1 ! leaf-fnrt-sapw proportional storage + integer, parameter :: lfss_store_prop = 2 ! leaf-fnrt-sapw-struct proportional storage + integer, parameter :: fnrt_store_prop = 3 ! fineroot proportional storage + integer, parameter :: store_prop = fnrt_store_prop + + + select case(element_id) + case(carbon12_element) + write(fates_log(),*) 'Cannot call StorageNutrientTarget() for carbon' + write(fates_log(),*) 'exiting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + case(nitrogen_element) + + if (store_prop == lfs_store_prop) then + + store_target = prt_params%nitr_store_ratio(pft) * (leaf_target + fnrt_target + sapw_target) + + elseif(store_prop==lfss_store_prop) then + + store_target = prt_params%nitr_store_ratio(pft) * (leaf_target + fnrt_target + sapw_target + struct_target) + + elseif(store_prop==fnrt_store_prop) then + + store_target = prt_params%nitr_store_ratio(pft) * fnrt_target + + end if + + + case(phosphorus_element) + + if (store_prop == lfs_store_prop) then + + store_target = prt_params%phos_store_ratio(pft) * (leaf_target + fnrt_target + sapw_target) + + elseif(store_prop==lfss_store_prop) then + + store_target = prt_params%nitr_store_ratio(pft) * (leaf_target + fnrt_target + sapw_target + struct_target) + + elseif(store_prop==fnrt_store_prop) then + + store_target = prt_params%phos_store_ratio(pft) * fnrt_target + + end if + end select + + + end function StorageNutrientTarget + + end module PRTAllometricCNPMod diff --git a/parteh/PRTGenericMod.F90 b/parteh/PRTGenericMod.F90 index 01866ca22a..d7e1001d3e 100644 --- a/parteh/PRTGenericMod.F90 +++ b/parteh/PRTGenericMod.F90 @@ -1392,7 +1392,7 @@ function GetNutrientTargetBase(this,element_id,organ_id,stoich_mode) result(targ class(prt_vartypes) :: this integer, intent(in) :: element_id integer, intent(in) :: organ_id - integer, intent(in) :: stoich_mode + integer, intent(in),optional :: stoich_mode real(r8) :: target_m ! Target amount of nutrient for this organ [kg] write(fates_log(),*)'GetNutrientTargetBase must be extended by a child class.' From bd8632a499cea02bee1fa5781b75d28f831cfc97 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 18 Feb 2021 16:27:23 -0500 Subject: [PATCH 205/578] Updates to history variables, adding NH4 and NO3 uptake diagnostics. Started initial work towards making history diagnostics decentralized --- biogeochem/EDCohortDynamicsMod.F90 | 20 ++++-- biogeochem/FatesSoilBGCFluxMod.F90 | 42 +++++++---- main/EDMainMod.F90 | 44 +++++++++--- main/EDTypesMod.F90 | 16 +++-- main/FatesHistoryInterfaceMod.F90 | 108 ++++++++++------------------- main/FatesInterfaceMod.F90 | 12 ++-- main/FatesInterfaceTypesMod.F90 | 6 +- main/FatesRestartInterfaceMod.F90 | 26 ++++--- parteh/PRTAllometricCNPMod.F90 | 15 ++-- 9 files changed, 165 insertions(+), 124 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 8d5188a0af..3621ceec1b 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -91,7 +91,7 @@ module EDCohortDynamicsMod use PRTAllometricCNPMod, only : acnp_bc_in_id_pft, acnp_bc_in_id_ctrim use PRTAllometricCNPMod, only : acnp_bc_in_id_lstat, acnp_bc_inout_id_dbh use PRTAllometricCNPMod, only : acnp_bc_inout_id_rmaint_def, acnp_bc_in_id_netdc - use PRTAllometricCNPMod, only : acnp_bc_in_id_netdn, acnp_bc_in_id_netdp + use PRTAllometricCNPMod, only : acnp_bc_in_id_netdnh4, acnp_bc_in_id_netdno3, acnp_bc_in_id_netdp use PRTAllometricCNPMod, only : acnp_bc_out_id_cefflux, acnp_bc_out_id_nefflux use PRTAllometricCNPMod, only : acnp_bc_out_id_pefflux use PRTAllometricCNPMod, only : acnp_bc_out_id_nneed @@ -400,7 +400,8 @@ subroutine InitPRTBoundaryConditions(new_cohort) call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_ctrim,bc_rval = new_cohort%canopy_trim) call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_lstat,bc_ival = new_cohort%status_coh) call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdc, bc_rval = new_cohort%npp_acc) - call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdn, bc_rval = new_cohort%daily_n_uptake) + call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdnh4, bc_rval = new_cohort%daily_nh4_uptake) + call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdno3, bc_rval = new_cohort%daily_no3_uptake) call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdp, bc_rval = new_cohort%daily_p_uptake) call new_cohort%prt%RegisterBCInOut(acnp_bc_inout_id_dbh,bc_rval = new_cohort%dbh) @@ -557,7 +558,8 @@ subroutine nan_cohort(cc_p) currentCohort%resp_acc = nan ! RESP: kGC/cohort/day ! Fluxes from nutrient allocation - currentCohort%daily_n_uptake = nan + currentCohort%daily_nh4_uptake = nan + currentCohort%daily_no3_uptake = nan currentCohort%daily_p_uptake = nan currentCohort%daily_c_efflux = nan currentCohort%daily_n_efflux = nan @@ -674,7 +676,8 @@ subroutine zero_cohort(cc_p) ! after allocation. These variables exist in ! carbon-only mode but are not used. - currentCohort%daily_n_uptake = 0._r8 + currentCohort%daily_nh4_uptake = 0._r8 + currentCohort%daily_no3_uptake = 0._r8 currentCohort%daily_p_uptake = 0._r8 currentCohort%daily_c_efflux = 0._r8 @@ -1390,8 +1393,10 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) currentCohort%frmort = (currentCohort%n*currentCohort%frmort + nextc%n*nextc%frmort)/newn ! Nutrient fluxes - currentCohort%daily_n_uptake = (currentCohort%n*currentCohort%daily_n_uptake + & - nextc%n*nextc%daily_n_uptake)/newn + currentCohort%daily_nh4_uptake = (currentCohort%n*currentCohort%daily_nh4_uptake + & + nextc%n*nextc%daily_nh4_uptake)/newn + currentCohort%daily_no3_uptake = (currentCohort%n*currentCohort%daily_no3_uptake + & + nextc%n*nextc%daily_no3_uptake)/newn currentCohort%daily_p_uptake = (currentCohort%n*currentCohort%daily_p_uptake + & nextc%n*nextc%daily_p_uptake)/newn @@ -1806,7 +1811,8 @@ subroutine copy_cohort( currentCohort,copyc ) n%year_net_uptake = o%year_net_uptake n%ts_net_uptake = o%ts_net_uptake - n%daily_n_uptake = o%daily_n_uptake + n%daily_nh4_uptake = o%daily_nh4_uptake + n%daily_no3_uptake = o%daily_no3_uptake n%daily_p_uptake = o%daily_p_uptake n%daily_c_efflux = o%daily_c_efflux n%daily_n_efflux = o%daily_n_efflux diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index a8076c90be..fc68161d9d 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -75,6 +75,7 @@ module FatesSoilBGCFluxMod use PRTParametersMod , only : prt_params use EDPftvarcon , only : EDPftvarcon_inst use PRTAllometricCNPMod, only : StorageNutrientTarget + use FatesUtilsMod, only : check_var_real implicit none private @@ -171,11 +172,11 @@ function GetPlantDemand(ccohort,element_id) result(plant_demand) if(element_id.eq.nitrogen_element) then - plant_demand = smth_fac*ccohort%daily_n_demand + (1._r8-smth_fac)*ccohort%daily_n_need + plant_demand = smth_fac*ccohort%daily_n_demand + (1._r8-smth_fac)*max(0._r8,ccohort%daily_n_need) elseif(element_id.eq.phosphorus_element) then - plant_demand = smth_fac*ccohort%daily_p_demand + (1._r8-smth_fac)*ccohort%daily_p_need + plant_demand = smth_fac*ccohort%daily_p_demand + (1._r8-smth_fac)*max(0._r8,ccohort%daily_p_need) end if @@ -226,7 +227,8 @@ subroutine UnPackNutrientAquisitionBCs(sites, bc_in) do while (associated(cpatch)) ccohort => cpatch%tallest do while (associated(ccohort)) - ccohort%daily_n_uptake = 0._r8 + ccohort%daily_nh4_uptake = 0._r8 + ccohort%daily_no3_uptake = 0._r8 ccohort%daily_p_uptake = 0._r8 ccohort => ccohort%shorter end do @@ -239,7 +241,8 @@ subroutine UnPackNutrientAquisitionBCs(sites, bc_in) if(hlm_parteh_mode.eq.prt_carbon_allom_hyp) then ! These can now be zero'd do s = 1, nsites - bc_in(s)%plant_n_uptake_flux(:,:) = 0._r8 + bc_in(s)%plant_nh4_uptake_flux(:,:) = 0._r8 + bc_in(s)%plant_no3_uptake_flux(:,:) = 0._r8 bc_in(s)%plant_p_uptake_flux(:,:) = 0._r8 end do return @@ -262,8 +265,9 @@ subroutine UnPackNutrientAquisitionBCs(sites, bc_in) pft = ccohort%pft ccohort%daily_n_demand = GetPlantDemand(ccohort,nitrogen_element) - ccohort%daily_n_uptake = EDPftvarcon_inst%prescribed_nuptake(pft) * ccohort%daily_n_demand - + ccohort%daily_nh4_uptake = EDPftvarcon_inst%prescribed_nuptake(pft) * ccohort%daily_n_demand + ccohort%daily_no3_uptake = 0._r8 + ccohort => ccohort%shorter end do cpatch => cpatch%younger @@ -337,8 +341,10 @@ subroutine UnPackNutrientAquisitionBCs(sites, bc_in) do while (associated(ccohort)) icomp = icomp+1 ! N Uptake: Convert g/m2/day -> kg/plant/day - ccohort%daily_n_uptake = ccohort%daily_n_uptake + & - sum(bc_in(s)%plant_n_uptake_flux(icomp,:))*kg_per_g*AREA/ccohort%n + ccohort%daily_nh4_uptake = ccohort%daily_nh4_uptake + & + sum(bc_in(s)%plant_nh4_uptake_flux(icomp,:))*kg_per_g*AREA/ccohort%n + ccohort%daily_no3_uptake = ccohort%daily_no3_uptake + & + sum(bc_in(s)%plant_no3_uptake_flux(icomp,:))*kg_per_g*AREA/ccohort%n ccohort => ccohort%shorter end do cpatch => cpatch%younger @@ -357,8 +363,11 @@ subroutine UnPackNutrientAquisitionBCs(sites, bc_in) ! Loop through soil layers, add up the uptake this cohort gets from each layer do id = 1,bc_in(s)%nlevdecomp - ccohort%daily_n_uptake = ccohort%daily_n_uptake + & - bc_in(s)%plant_n_uptake_flux(pft,id) * & + ccohort%daily_nh4_uptake = ccohort%daily_nh4_uptake + & + bc_in(s)%plant_nh4_uptake_flux(pft,id) * & + (fnrt_c/fnrt_c_pft(pft))*kg_per_g*AREA/ccohort%n + ccohort%daily_no3_uptake = ccohort%daily_no3_uptake + & + bc_in(s)%plant_no3_uptake_flux(pft,id) * & (fnrt_c/fnrt_c_pft(pft))*kg_per_g*AREA/ccohort%n end do @@ -416,7 +425,8 @@ subroutine UnPackNutrientAquisitionBCs(sites, bc_in) end if n_or_p_coupled_if ! These can now be zero'd - bc_in(s)%plant_n_uptake_flux(:,:) = 0._r8 + bc_in(s)%plant_nh4_uptake_flux(:,:) = 0._r8 + bc_in(s)%plant_no3_uptake_flux(:,:) = 0._r8 bc_in(s)%plant_p_uptake_flux(:,:) = 0._r8 end do @@ -1019,12 +1029,13 @@ function ECACScalar(ccohort, element_id) result(c_scalar) real(r8) :: store_max ! Maximum nutrient storable by plant real(r8) :: store_c ! Current storage carbon real(r8) :: store_c_max ! Current maximum storage carbon + integer :: icode ! real variable checking code integer, parameter :: downreg_linear = 1 integer, parameter :: downreg_logi = 2 integer, parameter :: downreg_CN_logi = 3 - integer, parameter :: downreg_type = downreg_linear + integer, parameter :: downreg_type = downreg_logi real(r8), parameter :: logi_k = 25.0_r8 ! logistic function k @@ -1052,6 +1063,13 @@ function ECACScalar(ccohort, element_id) result(c_scalar) c_scalar = max(0._r8,min(1._r8,logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))))) + call check_var_real(c_scalar,'c_scalar',icode) + if (icode .ne. 0) then + write(fates_log(),*) 'c_scalar is invalid, element: ',element_id + write(fates_log(),*) 'ending' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + else store_c = ccohort%prt%GetState(store_organ, carbon12_element) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index e1e122e88f..8b8eb4aa24 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -88,12 +88,13 @@ module EDMainMod use PRTGenericMod, only : store_organ use PRTGenericMod, only : repro_organ use PRTGenericMod, only : struct_organ - use PRTLossFluxesMod, only : PRTMaintTurnover use PRTLossFluxesMod, only : PRTReproRelease - use EDPftvarcon, only : EDPftvarcon_inst - + use FatesHistoryInterfaceMod, only : ih_nh4uptake_si, ih_no3uptake_si, ih_puptake_si + use FatesHistoryInterfaceMod, only : ih_nh4uptake_scpf, ih_no3uptake_scpf, ih_puptake_scpf + use FatesHistoryInterfaceMod, only : fates_hist + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) @@ -311,6 +312,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) integer :: c ! Counter for litter size class integer :: ft ! Counter for PFT + integer :: io_si ! global site index for history writing integer :: iscpf ! index for the size-class x pft multiplexed bins integer :: el ! Counter for element type (c,n,p,etc) real(r8) :: cohort_biomass_store ! remembers the biomass in the cohort for balance checking @@ -438,7 +440,8 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! Mass balance for N uptake currentSite%mass_balance(element_pos(nitrogen_element))%net_root_uptake = & currentSite%mass_balance(element_pos(nitrogen_element))%net_root_uptake + & - (currentCohort%daily_n_uptake-currentCohort%daily_n_efflux)*currentCohort%n + (currentCohort%daily_nh4_uptake+currentCohort%daily_no3_uptake- & + currentCohort%daily_n_efflux)*currentCohort%n ! Mass balance for P uptake currentSite%mass_balance(element_pos(phosphorus_element))%net_root_uptake = & @@ -454,13 +457,33 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) iscpf = currentCohort%size_by_pft_class ! Diagnostics for uptake, by size and pft, [kgX/ha/day] - currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_uptake_scpf(iscpf) = & - currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_uptake_scpf(iscpf) + & - currentCohort%daily_n_uptake*currentCohort%n + + io_si = currentSite%h_gid + + fates_hist%hvars(ih_nh4uptake_scpf)%r82d(io_si,iscpf) = & + fates_hist%hvars(ih_nh4uptake_scpf)%r82d(io_si,iscpf) + & + currentCohort%daily_nh4_uptake*currentCohort%n + + fates_hist%hvars(ih_no3uptake_scpf)%r82d(io_si,iscpf) = & + fates_hist%hvars(ih_no3uptake_scpf)%r82d(io_si,iscpf) + & + currentCohort%daily_no3_uptake*currentCohort%n + + fates_hist%hvars(ih_puptake_scpf)%r82d(io_si,iscpf) = & + fates_hist%hvars(ih_puptake_scpf)%r82d(io_si,iscpf) + & + currentCohort%daily_p_uptake*currentCohort%n - currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_uptake_scpf(iscpf) = & - currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_uptake_scpf(iscpf) + & + fates_hist%hvars(ih_nh4uptake_si)%r81d(io_si) = & + fates_hist%hvars(ih_nh4uptake_si)%r81d(io_si) + & + currentCohort%daily_nh4_uptake*currentCohort%n + + fates_hist%hvars(ih_no3uptake_si)%r81d(io_si) = & + fates_hist%hvars(ih_no3uptake_si)%r81d(io_si) + & + currentCohort%daily_no3_uptake*currentCohort%n + + fates_hist%hvars(ih_puptake_si)%r81d(io_si) = & + fates_hist%hvars(ih_puptake_si)%r81d(io_si) + & currentCohort%daily_p_uptake*currentCohort%n + ! Diagnostics on efflux, size and pft [kgX/ha/day] currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_efflux_scpf(iscpf) = & @@ -820,7 +843,8 @@ subroutine TotalBalanceCheck (currentSite, call_index ) write(fates_log(),*) 'resp m def: ',currentCohort%resp_m_def*currentCohort%n if(element_list(el).eq.nitrogen_element) then - write(fates_log(),*) 'N uptake: ',currentCohort%daily_n_uptake*currentCohort%n + write(fates_log(),*) 'NH4 uptake: ',currentCohort%daily_nh4_uptake*currentCohort%n + write(fates_log(),*) 'NO3 uptake: ',currentCohort%daily_no3_uptake*currentCohort%n write(fates_log(),*) 'N efflux: ',currentCohort%daily_n_efflux*currentCohort%n elseif(element_list(el).eq.phosphorus_element) then write(fates_log(),*) 'P uptake: ',currentCohort%daily_p_uptake*currentCohort%n diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 52ecc1d4cd..2ad8cf74aa 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -283,7 +283,8 @@ module EDTypesMod ! Nutrient Fluxes (if N, P, etc. are turned on) - real(r8) :: daily_n_uptake ! integrated daily uptake of mineralized N through competitive acquisition in soil [kg N / plant/ day] + real(r8) :: daily_nh4_uptake ! integrated daily uptake of mineralized ammonium through competitive acquisition in soil [kg N / plant/ day] + real(r8) :: daily_no3_uptake ! integrated daily uptake of mineralized nitrate through competitive acquisition in soil [kg N / plant/ day] real(r8) :: daily_p_uptake ! integrated daily uptake of mineralized P through competitive acquisition in soil [kg P / plant/ day] real(r8) :: daily_c_efflux ! daily mean efflux of excess carbon from roots into labile pool [kg C/plant/day] @@ -660,11 +661,6 @@ module EDTypesMod procedure :: ZeroMassBalFlux end type site_massbal_type - - - - - !************************************ @@ -681,7 +677,15 @@ module EDTypesMod type (ed_resources_management_type) :: resources_management ! resources_management at the site + ! If this simulation uses shared memory then the sites need to know what machine + ! index they are on. This index is (currently) only used to identify the sites + ! position in history output fields + !integer :: clump_id + ! Global index of this site in the history output file + integer :: h_gid + + ! INDICES real(r8) :: lat ! latitude: degrees real(r8) :: lon ! longitude: degrees diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index b3ea47d39b..ece609c12c 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -169,8 +169,9 @@ module FatesHistoryInterfaceMod integer :: ih_reprop_si integer :: ih_totvegp_si - integer :: ih_nuptake_si - integer :: ih_puptake_si + integer,public :: ih_nh4uptake_si + integer,public :: ih_no3uptake_si + integer,public :: ih_puptake_si integer :: ih_cefflux_si integer :: ih_nefflux_si integer :: ih_pefflux_si @@ -218,7 +219,8 @@ module FatesHistoryInterfaceMod integer :: ih_storentfrac_scpf integer :: ih_sapwn_scpf integer :: ih_repron_scpf - integer :: ih_nuptake_scpf + integer,public :: ih_nh4uptake_scpf + integer,public :: ih_no3uptake_scpf integer :: ih_nefflux_scpf integer :: ih_nneed_scpf @@ -237,7 +239,7 @@ module FatesHistoryInterfaceMod integer :: ih_storep_scpf integer :: ih_storeptfrac_scpf integer :: ih_sapwp_scpf - integer :: ih_puptake_scpf + integer,public :: ih_puptake_scpf integer :: ih_pefflux_scpf integer :: ih_pneed_scpf @@ -630,17 +632,6 @@ module FatesHistoryInterfaceMod integer, parameter, public :: fates_history_num_dimensions = 50 integer, parameter, public :: fates_history_num_dim_kinds = 50 - ! This structure is allocated by thread, and must be calculated after the FATES - ! sites are allocated, and their mapping to the HLM is identified. This structure - ! is not combined with iovar_bounds, because that one is multi-instanced. This - ! structure is used more during the update phase, wherease _bounds is used - ! more for things like flushing - type, public :: iovar_map_type - integer, allocatable :: site_index(:) ! maps site indexes to the HIO site position - integer, allocatable :: patch1_index(:) ! maps site index to the HIO patch 1st position - end type iovar_map_type - - type, public :: fates_history_interface_type ! Instance of the list of history output varialbes @@ -657,9 +648,6 @@ module FatesHistoryInterfaceMod ! allocated, but is unlikely to change...? type(fates_io_dimension_type) :: dim_bounds(fates_history_num_dimensions) - type(iovar_map_type), pointer :: iovar_map(:) - - !! THESE WERE EXPLICITLY PRIVATE WHEN TYPE WAS PUBLIC integer, private :: patch_index_, column_index_, levgrnd_index_, levscpf_index_ integer, private :: levscls_index_, levpft_index_, levage_index_ @@ -714,8 +702,6 @@ module FatesHistoryInterfaceMod procedure, private :: set_history_var procedure, private :: init_dim_kinds_maps procedure, private :: set_dim_indices - procedure, private :: flush_hvars - procedure, private :: set_patch_index procedure, private :: set_column_index procedure, private :: set_levgrnd_index @@ -740,12 +726,19 @@ module FatesHistoryInterfaceMod procedure, private :: set_levelcwd_index procedure, private :: set_levelage_index - + procedure, public :: flush_hvars + end type fates_history_interface_type character(len=*), parameter :: sourcefile = & __FILE__ + + ! The instance of the type + + type(fates_history_interface_type), public :: fates_hist + + contains ! ====================================================================== @@ -881,11 +874,6 @@ subroutine Init(this, num_threads, fates_bounds) call this%dim_bounds(dim_count)%Init(levelage, num_threads, & fates_bounds%elage_begin, fates_bounds%elage_end) - - ! FIXME(bja, 2016-10) assert(dim_count == FatesHistorydimensionmod::num_dimension_types) - - ! Allocate the mapping between FATES indices and the IO indices - allocate(this%iovar_map(num_threads)) end subroutine Init @@ -1695,9 +1683,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) integer :: s ! The local site index integer :: io_si ! The site index of the IO array integer :: ipa, ipa2 ! 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 :: io_soipa 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 @@ -1889,7 +1874,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m10_si_scls => this%hvars(ih_m10_si_scls)%r82d, & hio_m10_si_cacls => this%hvars(ih_m10_si_cacls)%r82d, & - hio_c13disc_si_scpf => this%hvars(ih_c13disc_si_scpf)%r82d, & + hio_c13disc_si_scpf => this%hvars(ih_c13disc_si_scpf)%r82d, & hio_cwd_elcwd => this%hvars(ih_cwd_elcwd)%r82d, & hio_cwd_ag_elem => this%hvars(ih_cwd_ag_elem)%r82d, & @@ -2001,11 +1986,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_err_fates_si => this%hvars(ih_err_fates_si)%r82d ) - ! --------------------------------------------------------------------------------- - ! Flush arrays to values defined by %flushval (see registry entry in - ! subroutine define_history_vars() - ! --------------------------------------------------------------------------------- - call this%flush_hvars(nc,upfreq_in=1) + ! If we don't have dynamics turned on, we just abort these diagnostics @@ -2018,11 +1999,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! --------------------------------------------------------------------------------- do s = 1,nsites - - io_si = this%iovar_map(nc)%site_index(s) - io_pa1 = this%iovar_map(nc)%patch1_index(s) - io_soipa = io_pa1-1 + io_si = sites(s)%h_gid + ! 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 @@ -2113,8 +2092,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - io_pa = io_pa1 + ipa - ! Increment the number of patches per site hio_npatches_si(io_si) = hio_npatches_si(io_si) + 1._r8 @@ -3077,9 +3054,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_storentfrac_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_repron_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_nuptake_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_uptake_scpf(:) - this%hvars(ih_nefflux_scpf)%r82d(io_si,:) = & sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) @@ -3089,9 +3063,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_nneed_si)%r81d(io_si) = & sum(sites(s)%flux_diags(el)%nutrient_need_scpf(:),dim=1) - this%hvars(ih_nuptake_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_uptake_scpf(:),dim=1) - this%hvars(ih_nefflux_si)%r81d(io_si) = & sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) @@ -3105,9 +3076,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_storeptfrac_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_reprop_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_puptake_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_uptake_scpf(:) - this%hvars(ih_pefflux_scpf)%r82d(io_si,:) = & sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) @@ -3116,9 +3084,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_pneed_si)%r81d(io_si) = & sum(sites(s)%flux_diags(el)%nutrient_need_scpf(:),dim=1) - - this%hvars(ih_puptake_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_uptake_scpf(:),dim=1) this%hvars(ih_pefflux_si)%r81d(io_si) = & sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) @@ -3354,9 +3319,6 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) 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 :: io_soipa 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 @@ -3453,9 +3415,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) do s = 1,nsites - io_si = this%iovar_map(nc)%site_index(s) - io_pa1 = this%iovar_map(nc)%patch1_index(s) - io_soipa = io_pa1-1 + io_si = sites(s)%h_gid hio_nep_si(io_si) = -bc_in(s)%tot_het_resp ! (gC/m2/s) hio_hr_si(io_si) = bc_in(s)%tot_het_resp @@ -3468,8 +3428,6 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) do while(associated(cpatch)) - io_pa = io_pa1 + ipa - patch_area_by_age(cpatch%age_class) = & patch_area_by_age(cpatch%age_class) + cpatch%area @@ -3887,7 +3845,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) jr1 = site_hydr%i_rhiz_t jr2 = site_hydr%i_rhiz_b - io_si = this%iovar_map(nc)%site_index(s) + io_si = sites(s)%h_gid hio_h2oveg_si(io_si) = site_hydr%h2oveg hio_h2oveg_hydro_err_si(io_si) = site_hydr%h2oveg_hydro_err @@ -4658,11 +4616,16 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_repron_si ) - call this%set_history_var(vname='NUPTAKE', units='kgN d-1 ha-1', & - long='Total nitrogen uptake by plants per sq meter per day', use_default='active', & + call this%set_history_var(vname='NH4UPTAKE', units='kgN d-1 ha-1', & + long='Ammonium uptake rate by plants', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_nuptake_si ) + ivar=ivar, initialize=initialize_variables, index = ih_nh4uptake_si ) + call this%set_history_var(vname='NO3UPTAKE', units='kgN d-1 ha-1', & + long='Nitrate uptake rate by plants', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_no3uptake_si ) + call this%set_history_var(vname='NEFFLUX', units='kgN d-1 ha-1', & long='Nitrogen effluxed from plant (unused)', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & @@ -4713,7 +4676,7 @@ subroutine define_history_vars(this, initialize_variables) ivar=ivar, initialize=initialize_variables, index = ih_reprop_si ) call this%set_history_var(vname='PUPTAKE', units='kgP ha-1 d-1', & - long='Total phosphorus uptake by plants per sq meter per day', use_default='active', & + long='Mineralized phosphorus uptake rate of plants', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_puptake_si ) @@ -5995,10 +5958,15 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_repron_scpf ) - call this%set_history_var(vname='NUPTAKE_SCPF', units='kgN d-1 ha-1', & - long='nitrogen uptake, soil to root, by size-class x pft', use_default='inactive', & + call this%set_history_var(vname='NH4UPTAKE_SCPF', units='kgN d-1 ha-1', & + long='Ammonium uptake rate by plants, size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nh4uptake_scpf ) + + call this%set_history_var(vname='NO3UPTAKE_SCPF', units='kgN d-1 ha-1', & + long='Nitrate uptake rate by plants, size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nuptake_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_no3uptake_scpf ) call this%set_history_var(vname='NEFFLUX_SCPF', units='kgN d-1 ha-1', & long='nitrogen efflux, root to soil, by size-class x pft', use_default='inactive', & @@ -6051,7 +6019,7 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_reprop_scpf ) call this%set_history_var(vname='PUPTAKE_SCPF', units='kg/ha/day', & - long='phosphorus uptake, soil to root, by size-class x pft', use_default='inactive', & + long='phosphorus uptake rate by plants, by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_puptake_scpf ) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index facd017357..fba80293d2 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -254,7 +254,8 @@ subroutine zero_bcs(fates,s) fates%bc_out(s)%litt_flux_lab_c_si(:) = 0._r8 case(prt_cnp_flex_allom_hyp) - fates%bc_in(s)%plant_n_uptake_flux(:,:) = 0._r8 + fates%bc_in(s)%plant_nh4_uptake_flux(:,:) = 0._r8 + fates%bc_in(s)%plant_no3_uptake_flux(:,:) = 0._r8 fates%bc_in(s)%plant_p_uptake_flux(:,:) = 0._r8 fates%bc_out(s)%source_p(:) = 0._r8 fates%bc_out(s)%source_nh4(:) = 0._r8 @@ -381,14 +382,17 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then - allocate(bc_in%plant_n_uptake_flux(max_comp_per_site,1)) + allocate(bc_in%plant_nh4_uptake_flux(max_comp_per_site,1)) + allocate(bc_in%plant_no3_uptake_flux(max_comp_per_site,1)) allocate(bc_in%plant_p_uptake_flux(max_comp_per_site,1)) else - allocate(bc_in%plant_n_uptake_flux(max_comp_per_site,bc_in%nlevdecomp)) + allocate(bc_in%plant_nh4_uptake_flux(max_comp_per_site,bc_in%nlevdecomp)) + allocate(bc_in%plant_no3_uptake_flux(max_comp_per_site,bc_in%nlevdecomp)) allocate(bc_in%plant_p_uptake_flux(max_comp_per_site,bc_in%nlevdecomp)) end if else - allocate(bc_in%plant_n_uptake_flux(1,1)) + allocate(bc_in%plant_nh4_uptake_flux(1,1)) + allocate(bc_in%plant_no3_uptake_flux(1,1)) allocate(bc_in%plant_p_uptake_flux(1,1)) end if diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 7dc2d4ce22..74fdc277f8 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -371,8 +371,12 @@ module FatesInterfaceTypesMod ! Note 1: If these are indexed by COHORT, they don't also need to be indexed ! by decomposition layer. So it is allocated with 2nd dim=1. ! Note 2: Has it's own zero'ing call - real(r8), pointer :: plant_n_uptake_flux(:,:) ! Nitrogen input flux for + real(r8), pointer :: plant_nh4_uptake_flux(:,:) ! Ammonium uptake flux for ! each competitor [gN/m2/day] + + real(r8), pointer :: plant_no3_uptake_flux(:,:) ! Nitrate uptake flux for + ! each competitor [gN/m2/day] + real(r8), pointer :: plant_p_uptake_flux(:,:) ! Phosphorus input flux for ! each competitor [gP/m2/day] diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index c39893e5f3..0d8e07f67f 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -114,7 +114,8 @@ module FatesRestartInterfaceMod integer :: ir_smort_co integer :: ir_asmort_co - integer :: ir_daily_n_uptake_co + integer :: ir_daily_nh4_uptake_co + integer :: ir_daily_no3_uptake_co integer :: ir_daily_p_uptake_co integer :: ir_daily_c_efflux_co integer :: ir_daily_n_efflux_co @@ -756,10 +757,15 @@ subroutine define_restart_vars(this, initialize_variables) units='/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cmort_co ) - call this%set_restart_var(vname='fates_daily_n_uptake', vtype=cohort_r8, & - long_name='fates cohort- daily nitrogen uptake', & + call this%set_restart_var(vname='fates_daily_nh4_uptake', vtype=cohort_r8, & + long_name='fates cohort- daily ammonium [NH4] uptake', & units='kg/plant/day', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_uptake_co ) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_nh4_uptake_co ) + + call this%set_restart_var(vname='fates_daily_no3_uptake', vtype=cohort_r8, & + long_name='fates cohort- daily ammonium [NO3] uptake', & + units='kg/plant/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_no3_uptake_co ) call this%set_restart_var(vname='fates_daily_p_uptake', vtype=cohort_r8, & long_name='fates cohort- daily phosphorus uptake', & @@ -1627,7 +1633,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & - rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & + rio_daily_nh4_uptake_co => this%rvars(ir_daily_nh4_uptake_co)%r81d, & + rio_daily_no3_uptake_co => this%rvars(ir_daily_no3_uptake_co)%r81d, & rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & @@ -1872,7 +1879,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_frmort_co(io_idx_co) = ccohort%frmort ! Nutrient uptake/efflux - rio_daily_n_uptake_co(io_idx_co) = ccohort%daily_n_uptake + rio_daily_no3_uptake_co(io_idx_co) = ccohort%daily_no3_uptake + rio_daily_nh4_uptake_co(io_idx_co) = ccohort%daily_nh4_uptake rio_daily_p_uptake_co(io_idx_co) = ccohort%daily_p_uptake rio_daily_c_efflux_co(io_idx_co) = ccohort%daily_c_efflux @@ -2415,7 +2423,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & - rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & + rio_daily_nh4_uptake_co => this%rvars(ir_daily_nh4_uptake_co)%r81d, & + rio_daily_no3_uptake_co => this%rvars(ir_daily_no3_uptake_co)%r81d, & rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & @@ -2620,7 +2629,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%frmort = rio_frmort_co(io_idx_co) ! Nutrient uptake / efflux - ccohort%daily_n_uptake = rio_daily_n_uptake_co(io_idx_co) + ccohort%daily_nh4_uptake = rio_daily_nh4_uptake_co(io_idx_co) + ccohort%daily_no3_uptake = rio_daily_no3_uptake_co(io_idx_co) ccohort%daily_p_uptake = rio_daily_p_uptake_co(io_idx_co) ccohort%daily_c_efflux = rio_daily_c_efflux_co(io_idx_co) ccohort%daily_n_efflux = rio_daily_n_efflux_co(io_idx_co) diff --git a/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 index a43981e469..3ca51ca03a 100644 --- a/parteh/PRTAllometricCNPMod.F90 +++ b/parteh/PRTAllometricCNPMod.F90 @@ -146,11 +146,12 @@ module PRTAllometricCNPMod integer, public, parameter :: acnp_bc_in_id_ctrim = 2 ! Index for the canopy trim function integer, public, parameter :: acnp_bc_in_id_lstat = 3 ! phenology status logical integer, public, parameter :: acnp_bc_in_id_netdc = 4 ! Index for the net daily C input BC - integer, public, parameter :: acnp_bc_in_id_netdn = 5 ! Index for the net daily N input BC - integer, public, parameter :: acnp_bc_in_id_netdp = 6 ! Index for the net daily P input BC + integer, public, parameter :: acnp_bc_in_id_netdnh4 = 5 ! Index for the net daily NH4 input BC + integer, public, parameter :: acnp_bc_in_id_netdno3 = 6 ! Index for the net daily NO3 input BC + integer, public, parameter :: acnp_bc_in_id_netdp = 7 ! Index for the net daily P input BC ! 0=leaf off, 1=leaf on - integer, parameter :: num_bc_in = 6 + integer, parameter :: num_bc_in = 7 ! ------------------------------------------------------------------------------------- ! Output Boundary Indices (These are public) @@ -393,7 +394,9 @@ subroutine DailyPRTAllometricCNP(this) ! for checking and resetting if needed ! ----------------------------------------------------------------------------------- c_gain = this%bc_in(acnp_bc_in_id_netdc)%rval; c_gain0 = c_gain - n_gain = this%bc_in(acnp_bc_in_id_netdn)%rval; n_gain0 = n_gain + n_gain = this%bc_in(acnp_bc_in_id_netdnh4)%rval + & + this%bc_in(acnp_bc_in_id_netdno3)%rval + n_gain0 = n_gain p_gain = this%bc_in(acnp_bc_in_id_netdp)%rval; p_gain0 = p_gain canopy_trim = this%bc_in(acnp_bc_in_id_ctrim)%rval ipft = this%bc_in(acnp_bc_in_id_pft)%ival @@ -612,8 +615,8 @@ subroutine DailyPRTAllometricCNP(this) target_n = this%GetNutrientTarget(nitrogen_element,store_organ) target_p = this%GetNutrientTarget(phosphorus_element,store_organ) - n_need = max(target_n - state_n(store_id)%ptr,0._r8) - p_need = max(target_p - state_p(store_id)%ptr,0._r8) + n_need = target_n - state_n(store_id)%ptr + p_need = target_p - state_p(store_id)%ptr deallocate(state_c) deallocate(state_n) From cf623b036e12a85d0735c7a0886fb3a67693952f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 21 Feb 2021 15:45:03 -0500 Subject: [PATCH 206/578] bug fix on calculation of cn_scalar and cp_scalar for eca --- biogeochem/FatesSoilBGCFluxMod.F90 | 47 +++++++++++++++++------------- 1 file changed, 27 insertions(+), 20 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index fc68161d9d..d74682dc19 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -473,25 +473,26 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) real(r8), parameter :: decompmicc_lambda = 2.5_r8 ! Depth attenuation exponent for decomposer biomass real(r8), parameter :: decompmicc_zmax = 7.0e-2_r8 ! Depth of maximum decomposer biomass - - ! Determine the scaling approach if((hlm_parteh_mode.eq.prt_cnp_flex_allom_hyp) .and. & ((n_uptake_mode.eq.coupled_n_uptake) .or. & (p_uptake_mode.eq.coupled_p_uptake))) then comp_scaling = fates_np_comp_scaling else + comp_scaling = trivial_np_comp_scaling - bc_out%num_plant_comps = 1 - if(trim(hlm_nu_com).eq.'ECA')then - bc_out%ft_index(1) = 1 - bc_out%cn_scalar(1) = 0._r8 - bc_out%cp_scalar(1) = 0._r8 - elseif(trim(hlm_nu_com).eq.'RD') then + + ! Note: With ECA, we still need to update the + ! decomp microbe density even if we are not + ! fully coupled, so can't exit yet + + if(trim(hlm_nu_com).eq.'RD') then + bc_out%num_plant_comps = 1 bc_out%n_demand(1) = 0._r8 bc_out%p_demand(1) = 0._r8 return end if + end if ! ECA Specific Parameters @@ -500,13 +501,15 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) bc_out%veg_rootc(:,:) = 0._r8 ! Zero this, it will be incremented bc_out%decompmicc(:) = 0._r8 + bc_out%cn_scalar(:) = 0._r8 + bc_out%cp_scalar(:) = 0._r8 bc_out%ft_index(:) = -1 ! Loop over all patches and sum up the seed input for each PFT icomp = 0 comp_per_pft(:) = 0 ! This counts how many competitors per - - ! pft, used for averaging + ! pft, used for averaging + cpatch => csite%oldest_patch do while (associated(cpatch)) @@ -519,11 +522,8 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) ! with ECA, then we send 1 token ! competitor with plant root biomass, but no ! uptake affinity - - if(comp_scaling.eq.trivial_np_comp_scaling) then - icomp = 1 - bc_out%ft_index(icomp) = 1 ! Trivial (not used) - elseif(comp_scaling.eq.cohort_np_comp_scaling) then + + if(comp_scaling.eq.cohort_np_comp_scaling) then icomp = icomp+1 bc_out%ft_index(icomp) = pft else @@ -534,7 +534,7 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) call set_root_fraction(csite%rootfrac_scr, pft, csite%zi_soil) - fnrt_c = ccohort%prt%GetState(fnrt_organ, all_carbon_elements) + fnrt_c = ccohort%prt%GetState(fnrt_organ, carbon12_element) ! Map the soil layers to the decomposition layers ! (which may be synonomous) @@ -543,6 +543,7 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) do j = 1, bc_in%nlevdecomp id = bc_in%decomp_id(j) ! Map from soil layer to decomp layer veg_rootc = fnrt_c * ccohort%n * csite%rootfrac_scr(j) * AREA_INV * g_per_kg / csite%dz_soil(j) + bc_out%veg_rootc(icomp,id) = bc_out%veg_rootc(icomp,id) + veg_rootc ! We use a 3 parameter exponential attenuation function to estimate decomposer biomass @@ -567,16 +568,15 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) bc_out%decompmicc(id) = bc_out%decompmicc(id) / & max(nearzero,sum(bc_out%veg_rootc(:,id),dim=1)) end do - if(comp_scaling.eq.cohort_np_comp_scaling) then bc_out%num_plant_comps = icomp elseif(comp_scaling.eq.pft_np_comp_scaling) then bc_out%num_plant_comps = numpft - else + elseif(comp_scaling.eq.trivial_np_comp_scaling) then bc_out%num_plant_comps = 1 - bc_out%cn_scalar(:) = 0._r8 - bc_out%cp_scalar(:) = 0._r8 + ! Now that the microbial density is calculated + ! we can exit the trivial case return end if @@ -1062,7 +1062,14 @@ function ECACScalar(ccohort, element_id) result(c_scalar) ! storage approaches it's maximum holding capacity c_scalar = max(0._r8,min(1._r8,logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))))) + +! if(element_id==nitrogen_element) then +! print*,"DBH, N STOREFRAC: ",ccohort%dbh,c_scalar,store_frac,ccohort%prt%GetState(store_organ, element_id),store_max +! else +! print*,"DBH, P STOREFRAC: ",ccohort%dbh,c_scalar,store_frac,ccohort%prt%GetState(store_organ, element_id),store_max +! end if + call check_var_real(c_scalar,'c_scalar',icode) if (icode .ne. 0) then write(fates_log(),*) 'c_scalar is invalid, element: ',element_id From 1d1b87fd93088ac074a5fa5ff9e59d90e1433faf Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 3 Mar 2021 17:12:44 -0500 Subject: [PATCH 207/578] First pass at adding classes and procedures for the running-mean type --- main/FatesRunningMeanMod.F90 | 232 +++++++++++++++++++++++++++++++++++ 1 file changed, 232 insertions(+) create mode 100644 main/FatesRunningMeanMod.F90 diff --git a/main/FatesRunningMeanMod.F90 b/main/FatesRunningMeanMod.F90 new file mode 100644 index 0000000000..f7b6ca611d --- /dev/null +++ b/main/FatesRunningMeanMod.F90 @@ -0,0 +1,232 @@ +module FatesRunningMeanMod + + + use FatesConstantsMod, only : nearzero + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + use shr_log_mod, only : errMsg => shr_log_errMsg + use FatesGlobals, only : endrun => fates_endrun + + + integer, parameter :: maxlen_varname = 8 + + type, public :: rmean_type + + real(r8), allocatable(:) :: mem_rmean ! Array storing the memory of the mean + real(r8) :: c_rmean ! The current mean value from the + ! available memory, as of the last update + integer :: c_index ! The current memory index as per the + ! last update + integer :: n_mem ! Total number of memory indices + logical :: filled ! Has enough time elapsed so all memory filled? + character(len=maxlen_varname) :: var_name ! A short name for this variable + ! for diagnostic purposes + + contains + + procedure :: InitRMean + procedure :: UpdateRMean + procedure :: FuseRMean + + end type rmean_type + +contains + + + subroutine InitRMean(this,name,mem_period,up_period) + + class(rmean_type) :: this + character(len=maxlen_varname) :: name ! The name of the new variable + real(r8) :: mem_period ! The period length in seconds that must be remembered + real(r8) :: up_period ! The period length in seconds that memory is updated + ! (i.e. the resolution of the memory) + + this%name = name + this%n_mem = nint(mem_period/up_period) + + if( abs(real(this%n_mem,r8)-mem_period/up_period) > nearzero ) then + write(fates_log(), *) 'While defining a running mean variable: ',this%var_name + write(fates_log(), *) 'an update and total memory period was specified' + write(fates_log(), *) 'where the update period is not an exact fraction of the period' + write(fates_log(), *) 'mem_period: ',mem_period + write(fates_log(), *) 'up_period: ',up_period + write(fates_log(), *) 'exiting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Otherwise we allocate + allocate(this%mem_rmean(this%n_mem)) + + ! Initialize with nonsense numbers + this%mem_rmean(:) = nan + + ! There are no memory spots filled with valid datapoints + this%filled = .false + + ! The current index of the memory is zero + this%c_index = 0 + + return + end subroutine InitRMean + + ! ===================================================================================== + + subroutine UpdateRMean(this, new_value) + + class(rmean_type) :: this + real(r8) :: new_value ! The newest value added to the running mean + + this%c_index = this%c_index + 1 + + ! Update the index of the memory array + ! and, determine if we have filled the memory yet + ! If this index is greater than our memory slots, + ! go back to the first + if(this%c_index==this%n_mem) then + this%filled = .true. + end if + + if(this%c_index>this%n_mem) this%c_index = 1 + + this%mem_rmean(this%c_index) = new_value + + ! Update the running mean value. It will return a value + ! if we have not filled in all the memory slots. To do this + ! it will take a mean over what is available + + if(this%filled) then + this%c_rmean = sum(this%mem_rmean)/real(this%n_mem,r8) + else + this%c_rmean = sum(this%mem_rmean(1:this%c_index))/real(this%c_index,r8) + end if + + + return + end subroutine UpdateRmean + + ! ===================================================================================== + + subroutine FuseRMean(this,donor,recip_wgt) + + ! When fusing the running mean of two entities, it is possible that they + ! may have a different amount of memory spaces filled (at least in FATES). This + ! is typical for newly created patches or cohorts, that litteraly just spawned + ! So what generally happens is we walk backwards from the current memory index + ! of both and take means where we can. In places where one entity has more + ! memory than the other, than we just use the value from the one that is there + + class(rmean_type) :: this + class(rmean_type), pointer :: donor + real(r8),intent(in) :: recip_wgt ! Weighting factor for recipient (0-1) + + integer :: r_id ! Loop index counter for the recipient (this) + integer :: d_id ! Loop index counter for the donor + + + if(this%n_mem .ne. donor%n_mem) then + write(fates_log(), *) 'memory size is somehow different during fusion' + write(fates_log(), *) 'of two running mean variables: ',this%name,donor%name + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(this%filled .and. donor%filled) then + + ! Both are filled, take averages of each and be sure to use relative positions + + d_id = donor%c_index + do r_id = 1,this%n_mem + this%mem_rmean(r_id) = this%mem_rmean(r_id)*(recip_wgt) + & + donor%mem_rmean(d_id)*(1._r8-recip_wgt) + d_id = d_id+ipos + if(d_id>donor%n_mem) d_id = 1 + end do + + elseif(this%filled .and. .not.donor%filled) then + + ! Here, we have only partial memory from the donor + ! we we iterate through the donor's memory + ! and average between the two in those spaces. Then + ! we leave the rest untouched because we accept + ! the values from the recipient. Also, keep the + ! recipient's index. + + r_id = this%c_index + do d_id = donor%c_index,1,-1 + this%mem_rmean(r_id) = this%mem_rmean(r_id)*(recip_wgt) + donor%mem_rmean(d_id)*(1._r8-recip_wgt) + r_id = r_id - 1 + if(r_id==0) r_id = this%n_mem + end do + + + elseif(.not.this%filled .and. donor%filled) then + + ! Here we only have partial memory from the recipient + ! so we iterate through the recipient's memory + ! and average between the two. Then we copy + ! over the values from the donor for the indices that we + ! didn't average because the donor has valid values + + d_id = donor%c_index + do r_id = this%c_index,1,-1 + this%mem_rmean(r_id) = this%mem_rmean(r_id)*(recip_wgt) + donor%mem_rmean(d_id)*(1._r8-recip_wgt) + d_id = d_id - 1 + if(d_id==0) d_id = donor%n_mem + end do + + do r_id = this%n_mem,this%c_index+1,-1 + this%mem_rmean(r_id) = donor%mem_rmean(d_id + d_id = d_id - 1 + end do + ! Pass the current index of the donor since that was filled + ! And also update the status to filled since it now + ! has all memory filled from the donor + this%c_index = donor%c_index + this%filled = .true. + + elseif(.not.this%filled .and. .not.donor%filled) then + + ! Here, neither is completely filled + + if( this%c_index>donor%c_index ) then + + ! In this case, leave all data as the recipient + ! except for where there is donor. Keep the recipient's + ! index and status, since it is larger and should remain unchanged + + r_id = this%c_index + do d_id = donor%c_index,1,-1 + this%mem_rmean(r_id) = this%mem_rmean(r_id)*(recip_wgt) + donor%mem_rmean(d_id)*(1._r8-recip_wgt) + end do + + else + + ! In this case, we do the same thing as the previous + ! clause, but just switch the roles, then + ! copy the donor to the recipient + ! Also transfer the index from the donor, since that was + ! higher and now reflects the filled memory + + d_id = donor%c_index + do r_id = this%c_index,1,-1 + donor%mem_rmean(r_id) = this%mem_rmean(r_id)*(recip_wgt) + donor%mem_rmean(d_id)*(1._r8-recip_wgt) + end do + this%mem_rmean(:) = donor%mem_reman + this%c_index = donor%c_index + end if + + + + end if + + + + ! take the mean of each + + + + + + return + end subroutine FuseRMean + + +end module FatesRunningMeanMod From 228039b44434aed4c05f9767c04f9e59b7cfa435 Mon Sep 17 00:00:00 2001 From: Joshua Rady Date: Sun, 7 Mar 2021 16:24:50 -0500 Subject: [PATCH 208/578] Replace tolerace threshold with rsnbl_math_prec. --- biogeochem/EDPatchDynamicsMod.F90 | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 9b2ffdbe8e..472c8eb48c 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -447,7 +447,8 @@ subroutine spawn_patches( currentSite, bc_in) ! !USES: use EDParamsMod , only : ED_val_understorey_death, logging_coll_under_frac - use EDCohortDynamicsMod , only : zero_cohort, copy_cohort, terminate_cohorts + use EDCohortDynamicsMod , only : zero_cohort, copy_cohort, terminate_cohorts + use FatesConstantsMod , only : rsnbl_math_prec ! ! !ARGUMENTS: @@ -481,8 +482,6 @@ subroutine spawn_patches( currentSite, bc_in) ! for both woody and grass species real(r8) :: leaf_m ! leaf mass during partial burn calculations logical :: found_youngest_primary ! logical for finding the first primary forest patch - - real(r8), parameter :: disturb_tolerance = 1.0e-14_r8 ! Allow for small precision errors. !--------------------------------------------------------------------- storesmallcohort => null() ! storage of the smallest cohort for insertion routine @@ -502,7 +501,7 @@ subroutine spawn_patches( currentSite, bc_in) do while(associated(currentPatch)) - if(currentPatch%disturbance_rate > (1.0_r8 + disturb_tolerance)) then + if(currentPatch%disturbance_rate > (1.0_r8 + rsnbl_math_prec)) then write(fates_log(),*) 'patch disturbance rate > 1 ?',currentPatch%disturbance_rate call dump_patch(currentPatch) call endrun(msg=errMsg(sourcefile, __LINE__)) From 8b22f95f80cf6cfd508564b6448dad06a242be8f Mon Sep 17 00:00:00 2001 From: Yilin Fang Date: Thu, 11 Mar 2021 20:18:46 -0800 Subject: [PATCH 209/578] Smooth approximation of campbell model --- biogeophys/FatesHydroWTFMod.F90 | 649 ++++++++++++++++++++++++- biogeophys/FatesPlantHydraulicsMod.F90 | 105 +++- 2 files changed, 738 insertions(+), 16 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 85b4965a0a..4d09263bff 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -28,7 +28,9 @@ module FatesHydroWTFMod __FILE__ - real(r8), parameter :: min_ftc = 0.00001_r8 ! Minimum allowed fraction of total conductance +! real(r8), parameter :: min_ftc = 0.00001_r8 ! Minimum allowed fraction of total conductance +! The above cause negative organ water content + real(r8), parameter :: min_ftc = 0.00001e1_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" @@ -163,6 +165,36 @@ module FatesHydroWTFMod procedure :: dftcdpsi_from_psi => dftcdpsi_from_psi_cch procedure :: set_wkf_param => set_wkf_param_cch end type wkf_type_cch + ! ===================================================================================== + ! Type1 Smooth approximation of Clapp-Hornberger and Campbell (CCH) water retention and conductivity functions + ! Bisht et al. Geosci. Model Dev., 11, 4085–4102, 2018 + ! ===================================================================================== + + ! Water Retention Function + type, public, extends(wrf_type) :: wrf_type_smooth_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) :: scch_pu, scch_ps, scch_b2, scch_b3 + contains + procedure :: th_from_psi => th_from_psi_smooth_cch + procedure :: psi_from_th => psi_from_th_smooth_cch + procedure :: dpsidth_from_th => dpsidth_from_th_smooth_cch + procedure :: set_wrf_param => set_wrf_param_smooth_cch + procedure :: get_thsat => get_thsat_smooth_cch + end type wrf_type_smooth_cch + + ! Water Conductivity Function + type, public, extends(wkf_type) :: wkf_type_smooth_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) :: scch_pu, scch_ps, scch_b2, scch_b3 + contains + procedure :: ftc_from_psi => ftc_from_psi_smooth_cch + procedure :: dftcdpsi_from_psi => dftcdpsi_from_psi_smooth_cch + procedure :: set_wkf_param => set_wkf_param_smooth_cch + end type wkf_type_smooth_cch ! ===================================================================================== ! TFS functions @@ -450,6 +482,8 @@ function th_from_psi_vg(this,psi) result(th) end if + th = max(th,this%th_res) + th = min(th,this%th_sat) end function th_from_psi_vg @@ -461,13 +495,14 @@ function psi_from_th_vg(this,th) result(psi) ! volumetric water content (theta). class(wrf_type_vg) :: this - real(r8),intent(in) :: th + real(r8), intent(in) :: th real(r8) :: psi ! matric potential [MPa] real(r8) :: m ! inverse of psd real(r8) :: satfrac ! saturated fraction real(r8) :: th_interp ! theta where we start interpolation real(r8) :: psi_interp ! psi at interpolation point real(r8) :: dpsidth_interp + real(r8) :: thx !------------------------------------------------------------------------------------ ! saturation fraction is the origial equation in vg 1980, we just @@ -479,20 +514,20 @@ function psi_from_th_vg(this,th) result(psi) ! ! *also modified to accomodate linear pressure regime for super-saturation ! ----------------------------------------------------------------------------------- - + thx = max(th, this%th_res+1e-6) - if(th>this%th_max)then + if(thx>this%th_max)then - psi = this%psi_linear_sat(th) + psi = this%psi_linear_sat(thx) - elseif(th= 0.d0 ) then + write(fates_log(),*) 'set_wrf_param_smooth_cch b2 <= 0' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + this%scch_b3 = 0.d0 + + endif + ! Set DERIVED constants + ! used for interpolating in extreme ranges + this%th_max = max_sf_interp*this%th_sat + this%psi_max = this%psi_from_th(this%th_max-tiny(this%th_max)) + this%dpsidth_max = this%dpsidth_from_th(this%th_max-tiny(this%th_max)) + this%th_min = 1.e-8_r8 + this%psi_min = fates_unset_r8 + this%dpsidth_min = fates_unset_r8 + + return + end subroutine set_wrf_param_smooth_cch + + + + ! ===================================================================================== + + subroutine set_wkf_param_smooth_cch(this,params_in) + + class(wkf_type_smooth_cch) :: this + real(r8), intent(in) :: params_in(:) + integer :: styp + real(r8) :: pu + real(r8) :: bcAtPu + real(r8) :: lambdaDeltaPuOnPu + real(r8) :: oneOnDeltaPu + real(r8) :: lambda + real(r8) :: alpha + real(r8) :: ps + + this%th_sat = params_in(1) + this%psi_sat = params_in(2) + this%beta = params_in(3) + styp = int(params_in(4)) + + + alpha = -1._r8/this%psi_sat + lambda = 1.0_r8/this%beta + ps = -0.9_r8/alpha + this%scch_ps = ps + ! Choose `pu` that forces `scch_b2 = 0`. + if(styp == 1) then + pu = findGu_SBC_zeroCoeff(lambda, 3, -alpha*ps) / (-alpha) + this%scch_pu = pu + + ! Find helper constants. + bcAtPu = (-alpha*pu)**(-lambda) + lambdaDeltaPuOnPu = lambda * (1.d0 - ps/pu) + oneOnDeltaPu = 1.d0 / (pu - ps) + + ! Store coefficients for cubic function. + this%scch_b2 = 0.d0 + this%scch_b3 = (2.d0 - bcAtPu*(2.d0+lambdaDeltaPuOnPu)) * oneOnDeltaPu * oneOnDeltaPu * oneOnDeltaPu + if( this%scch_b3 <= 0.d0 ) then + write(fates_log(),*) 'set_wrf_param_smooth_cch b3 <=0',pu,ps,alpha,lambda,oneOnDeltaPu,lambdaDeltaPuOnPu,bcAtPu,this%psi_sat + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + else + ! Choose `pu` that forces `sbc_b3 = 0`. + pu = findGu_SBC_zeroCoeff(lambda, 2, -alpha*ps) / (-alpha) + this%scch_pu = pu + + ! Find helper constants. + bcAtPu = (-alpha*pu)**(-lambda) + lambdaDeltaPuOnPu = lambda * (1.d0 - ps/pu) + oneOnDeltaPu = 1.d0 / (pu - ps) + + ! Store coefficients for cubic function. + this%scch_b2 = -(3.d0 - bcAtPu*(3.d0+lambdaDeltaPuOnPu)) * oneOnDeltaPu* oneOnDeltaPu + if( this%scch_b2 >= 0.d0 ) then + write(fates_log(),*) 'set_wrf_param_smooth_cch b2 <= 0' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + this%scch_b3 = 0.d0 + + endif + return + end subroutine set_wkf_param_smooth_cch + + ! ===================================================================================== + + function get_thsat_smooth_cch(this) result(th_sat) + class(wrf_type_smooth_cch) :: this + real(r8) :: th_sat + + th_sat = this%th_sat + + end function get_thsat_smooth_cch + + ! ===================================================================================== + + function th_from_psi_smooth_cch(this,psi) result(th) + + class(wrf_type_smooth_cch) :: this + real(r8), intent(in) :: psi + real(r8) :: th + + real(r8) :: alpha + real(r8) :: lambda + real(r8) :: sat + real(r8) :: pc + real(r8) :: ps + real(r8) :: deltaPc + real(r8) :: dSe_dpc + + alpha = -1._r8/this%psi_sat + lambda = 1._r8/this%beta + pc = psi + + if( pc <= this%scch_pu ) then + ! Unsaturated full Brooks-Corey regime. + ! Here, `pc <= pu < 0`. + sat = (-alpha*pc)**(-lambda) + elseif( pc < this%scch_ps ) then + ! Cubic smoothing regime. + ! Here, `pu < pc < ps <= 0`. + deltaPc = pc - this%scch_ps + sat = 1.d0 + deltaPc*deltaPc*(this%scch_b2 + deltaPc*this%scch_b3) + else + ! Saturated regime. + ! Here, `pc >= ps`. + sat = 1.d0 + endif + th = sat * this%th_sat + + + return + end function th_from_psi_smooth_cch + + ! ===================================================================================== + + function psi_from_th_smooth_cch(this,th) result(psi) + + class(wrf_type_smooth_cch) :: this + real(r8),intent(in) :: th + real(r8) :: psi + + real(r8) :: sat_res + real(r8) :: alpha + real(r8) :: lambda + real(r8) :: Se + real(r8) :: sat + real(r8) :: pc + real(r8) :: xL + real(r8) :: xc + real(r8) :: xR + real(r8) :: resid + real(r8) :: dx + real(r8), parameter :: relTol = 1.d-9 + + sat_res = 0._r8 + alpha = -1._r8/this%psi_sat + lambda = 1._r8/this%beta + + sat = max(1.e-6,th/this%th_sat) + if( sat < 1.d0 ) then + ! Find the `pc` that satisfies the unmodified Brooks-Corey function. + Se = sat + pc = -(Se**(-1.d0/lambda)) / alpha + if( pc > this%scch_pu ) then + ! Here, solution is in the cubic smoothing regime. + if( this%scch_b2 == 0.d0 ) then + ! Note know `b3 > 0`. + pc = this%scch_ps - ((1.d0 - Se) / this%scch_b3)**(1.d0/3.d0) + elseif( this%scch_b3 == 0.d0 ) then + ! Note know `b2 < 0`. + pc = this%scch_ps - sqrt((Se - 1.d0) / this%scch_b2) + else + ! Here, want to solve general cubic + ! `1 + b2*x^2 + b3*x^3 = Se` + ! where `x = pc - pu`. + ! Write as residual function + ! `r = x^2 * (b2 + b3*x) + (1 - Se)`. + ! Perform a Newton-Raphson search on `x`. + ! Have + ! `dr/dx = x*(2*b2 + 3*b3*x)` + ! And Newton-Raphson sets + ! `x[i+1] = x[i] - r[i]/(dr/dx[i])`. + ! Note that r{0} = 1 - Se > 0. + ! Therefore maintain the right bracket as having a positive + ! residual, and the left bracket as having a negative residual. + ! Note that it is possible, due to numerical effects with `pc` + ! very close to `pu`, to get an `xL` with a positive residual. + ! However, in this case also have `xc` very close to `xL`, and + ! the Newton-Raphson search will converge after a single step. + ! Therefore do not insert a special test to catch the case here. + xL = this%scch_pu - this%scch_ps + xR = 0.d0 + xc = pc - this%scch_ps + ! write(unit=*, fmt='("SatFunc_SatToPc_SBC: NR search:", + ! 6(a,g15.6))') & + ! ' pu', scch_pu, ' ps', scch_ps, & + ! ' xL', xL, ' xR', xR, & + ! ' r{xL}', xL*xL*(scch_b2 + scch_b3*xL) + + ! 1.d0 - Se, & + ! ' r{xR}', xR*xR*(scch_b2 + scch_b3*xR) + + ! 1.d0 - Se + do + ! Here, assume: + ! + Have a bracket on the root, between `xL` and `xR`. + ! + The residual `r{xL} < 0` and `r{xR} > 0`. + ! + Have a current guess `xc` at the root. However, that guess + ! might not lie in the bracket. + + ! Reset `xc` using bisection if necessary. + if( xc<=xL .or. xc>=xR ) then + ! write(unit=*, fmt='("Bisecting")') + xc = xL + 0.5d0*(xR - xL) + endif + + ! Find NR step. + dx = this%scch_b3 * xc + resid = xc*xc*(this%scch_b2 + dx) + 1.d0 - Se + dx = resid / (xc*(2.d0*this%scch_b2 + 3.d0*dx)) + + ! Update bracket. + if( resid > 0.d0 ) then + xR = xc + else + xL = xc + endif + + ! Take the Newton-Raphson step. + xc = xc - dx + ! write(unit=*, fmt='(6(a,g15.6))') & + ! ' xL', xL, ' xc', xc, ' xR', xR, & + ! ' r{xL}', xL*xL*(scch_b2 + scch_b3*xL) + + ! 1.d0 - Se, & + ! ' r{xc}', xc*xc*(scch_b2 + scch_b3*xc) + + ! 1.d0 - Se, & + ! ' r{xR}', xR*xR*(scch_b2 + scch_b3*xR) + + ! 1.d0 - Se + + ! Test for convergence. + ! Note this test implicitly also tests `resid == 0`. + if( abs(dx) < -relTol*this%scch_pu ) then + exit + endif + enddo + + ! Here, have `xc = pc - ps`. + pc = xc + this%scch_ps + endif + endif + else + pc = 0.d0 + endif + psi = pc + + + end function psi_from_th_smooth_cch + + ! ===================================================================================== + + function dpsidth_from_th_smooth_cch(this,th) result(dpsidth) + + class(wrf_type_smooth_cch) :: this + real(r8),intent(in) :: th + real(r8) :: dpsidth + + + real(r8) :: pc + real(r8) :: sat + real(r8) :: dsat_dP + ! + ! !LOCAL VARIABLES: + real(r8) :: sat_res + real(r8) :: alpha + real(r8) :: lambda + real(r8) :: Se + real(r8) :: deltaPc + real(r8) :: dSe_dpc + + sat_res = 0._r8 + alpha = -1._r8/this%psi_sat + lambda = 1._r8/this%beta + + pc = 1._r8 * this%psi_from_th(th) + if( pc <= this%scch_pu ) then + ! Unsaturated full Brooks-Corey regime. + ! Here, `pc <= pu < 0`. + Se = (-alpha*pc)**(-lambda) + sat = sat_res + (1.d0 - sat_res)*Se + + dSe_dpc = -lambda*Se/pc + dsat_dp = (1.d0 - sat_res)*dSe_dpc + dpsidth = 1._r8/(dsat_dp * this%th_sat) + elseif( pc < this%scch_ps ) then + ! Cubic smoothing regime. + ! Here, `pu < pc < ps <= 0`. + deltaPc = pc - this%scch_ps + Se = 1.d0 + deltaPc*deltaPc*(this%scch_b2 + deltaPc*this%scch_b3) + sat = sat_res + (1.d0 - sat_res)*Se + + dSe_dpc = deltaPc*(2*this%scch_b2 + 3*deltaPc*this%scch_b3) + dsat_dp = (1.d0 - sat_res)*dSe_dpc + dpsidth = 1._r8/(dsat_dp * this%th_sat) + else + ! Saturated regime. + ! Here, `pc >= ps`. + + dpsidth = this%dpsidth_max + endif + + + end function dpsidth_from_th_smooth_cch + + ! ===================================================================================== + + function ftc_from_psi_smooth_cch(this,psi) result(ftc) + + class(wkf_type_smooth_cch) :: this + real(r8),intent(in) :: psi + real(r8) :: ftc + + real(r8) :: pc + real(r8) :: kr + real(r8) :: dkr_dP + ! + real(r8) :: sat_res + real(r8) :: alpha + real(r8) :: lambda + real(r8) :: Se + real(r8) :: deltaPc + real(r8) :: dSe_dpc + real(r8) :: dkr_dSe + + pc = psi + sat_res = 0._r8 + alpha = -1._r8/this%psi_sat + lambda = 1._r8/this%beta + + if( pc <= this%scch_pu ) then + ! Unsaturated full Brooks-Corey regime. + ! Here, `pc <= pu < 0`. + Se = (-alpha*pc)**(-lambda) + kr = Se ** (3._r8+2._r8/lambda) + + elseif( pc < this%scch_ps ) then + ! Cubic smoothing regime. + ! Here, `pu < pc < ps <= 0`. + deltaPc = pc - this%scch_ps + Se = 1.d0 + deltaPc*deltaPc*(this%scch_b2 + deltaPc*this%scch_b3) + kr = Se ** (3._r8+2._r8/lambda) + + else + ! Saturated regime. + ! Here, `pc >= ps`. + kr = 1.d0 + endif + ftc = max(kr, min_ftc) + + + end function ftc_from_psi_smooth_cch + + ! ==================================================================================== + + function dftcdpsi_from_psi_smooth_cch(this,psi) result(dftcdpsi) + + class(wkf_type_smooth_cch) :: this + real(r8),intent(in) :: psi + real(r8) :: dftcdpsi ! change in frac total cond wrt psi + + real(r8) :: pc + real(r8) :: kr + real(r8) :: dkr_dP + ! + real(r8) :: sat_res + real(r8) :: alpha + real(r8) :: lambda + real(r8) :: Se + real(r8) :: deltaPc + real(r8) :: dSe_dpc + real(r8) :: dkr_dSe + + pc = psi + sat_res = 0._r8 + alpha = -1._r8/this%psi_sat + lambda = 1._r8/this%beta + + if( pc <= this%scch_pu ) then + ! Unsaturated full Brooks-Corey regime. + ! Here, `pc <= pu < 0`. + Se = (-alpha*pc)**(-lambda) + + dSe_dpc = -lambda*Se/pc + + kr = Se ** (3.d0 + 2.d0/lambda) + + dkr_dSe = (3.d0 + 2.d0/lambda)*kr/Se + dkr_dp = dkr_dSe*dSe_dpc + elseif( pc < this%scch_ps ) then + ! Cubic smoothing regime. + ! Here, `pu < pc < ps <= 0`. + deltaPc = pc - this%scch_ps + Se = 1.d0 + deltaPc*deltaPc*(this%scch_b2 + deltaPc*this%scch_b3) + + dSe_dpc = deltaPc*(2*this%scch_b2 + 3*deltaPc*this%scch_b3) + + kr = Se ** (2.5d0 + 2.d0/lambda) + + dkr_dSe = (2.5d0 + 2.d0/lambda)*kr/Se + dkr_dp = dkr_dSe*dSe_dpc + else + ! Saturated regime. + ! Here, `pc >= ps`. + kr = 1.d0 + dkr_dP = 0.d0 + endif + dftcdpsi = dkr_dP + if(kr<=min_ftc) then + dftcdpsi = 0._r8 + endif + + + end function dftcdpsi_from_psi_smooth_cch + + + !------------------------------------------------------------------------ + ! Find `pu` that forces a coefficient of the smoothing cubic polynomial to zero. + ! Bisht et al. Geosci. Model Dev., 11, 4085–4102, 2018, coded in VSFM + ! + ! Work in terms of multipliers of `pc0`: + ! + ! + Argument `gs` satisfies `ps = gs*pc0`. + ! + Return `gu` such that `pu = gu*pc0`. + ! + ! Argument `AA`: + ! + ! + To set `b2 = 0`, let `A = 3`. + ! + To set `b3 = 0`, let `A = 2`. + ! + real(r8) function findGu_SBC_zeroCoeff(lambda, AA, gs) + ! + ! !DESCRIPTION: + ! + ! + implicit none + ! + ! !ARGUMENTS + real(r8) , intent(in) :: lambda + real(r8) , intent(in) :: gs + integer , intent(in) :: AA + ! + ! !LOCAL VARIABLES: + real(r8) :: guLeft, gu, guRight ! Bracketed search. + real(r8) :: deltaGu, resid, dr_dGu ! Newton-Raphson search. + real(r8) :: guInv, guToMinusLam, gsOnGu ! Helper variables. + real(r8), parameter :: relTol = 1.d-12 + + ! Check arguments. + ! Note this is more for documentation than anything else-- this + ! fcn should only get used internally, by trusted callers. + if( lambda<=0.d0 .or. lambda>=2.d0 & + .or. (AA/=2 .and. AA/=3) & + .or. gs>=1.d0 .or. gs<0.d0 ) then + write(fates_log(),*) 'findGu_SBC_zeroCoeff: bad param' + call endrun(msg=errMsg(__FILE__, __LINE__)) + endif + + ! Approach: + ! + Bracketed Newton-Raphson search. + ! + Note expect `1 < gu <= gu{gs=0}`. + ! + Note if this was a critical inner loop, could try solving for + ! `gui == 1/gu`, rather than for `gu`, in order to avoid division. + ! Could also try using Ridder's method, since the residual here + ! has a strong exponential component. + + ! Initialize. + gu = (AA / (AA + lambda))**(-1.d0/lambda) ! Solution if `gs = 0`. + + ! Search for root, using bracketed Newton-Raphson. + ! Not necessary if `gs = 0`. + if( gs > 0.d0 ) then + guLeft = 1.d0 + guRight = gu + do + ! Here, assume: + ! + Have an bracket on the root, between `guLeft` and `guRight`. + ! + The derivative `dr/d{gu} > 0`. + ! + The residual `r{guLeft} < 0`, and `r{guRight} > 0`. + ! + Have a current guess `gu` at the root. However, that guess + ! might not lie in the bracket (and does not at first iteration). + + ! Reset `gu` using bisection if necessary. + if( gu<=guLeft .or. gu>=guRight ) then + gu = guLeft + 0.5d0*(guRight - guLeft) + endif + + ! Find residual. + guInv = 1.d0 / gu + guToMinusLam = gu**(-lambda) ! Could also do `guInv**lambda`; not sure if any numerical consequences. + gsOnGu = gs * guInv + resid = AA - guToMinusLam*(AA + lambda - lambda*gsOnGu) + + ! Update bracket. + if( resid < 0.d0 ) then + guLeft = gu + else + guRight = gu + endif + + ! Find next guess using Newton-Raphson's method. + dr_dGu = (1.d0 + lambda) * (1.d0 - gsOnGu) + (AA - 1) + dr_dGu = lambda * guToMinusLam * guInv * dr_dGu + deltaGu = resid / dr_dGu + ! write(unit=*, fmt='("findGu_SBC_zeroCoeff, NR step: ", 6(a,g15.6))') & + ! 'guLeft', guLeft, 'gu', gu, 'guRight', guRight, & + ! 'deltaGu', deltaGu, 'resid', resid, 'dr_dGu', dr_dGu + gu = gu - deltaGu + + ! Test for convergence. + ! Note this test implicitly also tests `resid == 0`. + if( abs(deltaGu) < relTol*abs(gu) ) then + exit + endif + enddo + endif + + ! Finish up. + ! Note assuming the last Newton-Raphson step landed in the bracket, + ! and had a smaller residual than either of the bracket points. This + ! seems a safe enough assumption, compared to cost of tracking residuals. + findGu_SBC_zeroCoeff = gu + if(gu /= gu) then + print *,AA,gs + endif + + end function findGu_SBC_zeroCoeff + ! ===================================================================================== ! TFS style functions ! ===================================================================================== diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 359ad16515..30b9618363 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -102,8 +102,10 @@ module FatesPlantHydraulicsMod use FatesHydroWTFMod, only : wrf_arr_type use FatesHydroWTFMod, only : wkf_arr_type - use FatesHydroWTFMod, only : wrf_type, wrf_type_vg, wrf_type_cch, wrf_type_tfs - use FatesHydroWTFMod, only : wkf_type, wkf_type_vg, wkf_type_cch, wkf_type_tfs + use FatesHydroWTFMod, only : wrf_type, wrf_type_vg, wrf_type_cch,wrf_type_tfs, & + wrf_type_smooth_cch + use FatesHydroWTFMod, only : wkf_type, wkf_type_vg, wkf_type_cch,wkf_type_tfs, & + wkf_type_smooth_cch ! CIME Globals @@ -190,12 +192,18 @@ module FatesPlantHydraulicsMod integer, public, parameter :: van_genuchten_type = 1 integer, public, parameter :: campbell_type = 2 + integer, public, parameter :: smooth1_campbell_type = 21 + integer, public, parameter :: smooth2_campbell_type = 22 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 + !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 + integer, parameter :: plant_wrf_type = van_genuchten_type + integer, parameter :: plant_wkf_type = van_genuchten_type + integer, parameter :: soil_wrf_type = smooth1_campbell_type + integer, parameter :: soil_wkf_type = smooth1_campbell_type ! Define the global object that holds the water retention functions @@ -325,6 +333,8 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) class(wkf_type_vg), pointer :: wkf_vg class(wrf_type_cch), pointer :: wrf_cch class(wkf_type_cch), pointer :: wkf_cch + class(wrf_type_smooth_cch), pointer :: wrf_smooth_cch + class(wkf_type_smooth_cch), pointer :: wkf_smooth_cch do s = 1,nsites csite_hydr=>sites(s)%si_hydr @@ -387,6 +397,24 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) (-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(smooth1_campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 + allocate(wrf_smooth_cch) + sites(s)%si_hydr%wrf_soil(j)%p => wrf_smooth_cch + call wrf_smooth_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),1._r8]) + end do + case(smooth2_campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 + allocate(wrf_smooth_cch) + sites(s)%si_hydr%wrf_soil(j)%p => wrf_smooth_cch + call wrf_smooth_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),2._r8]) + end do case(tfs_type) write(fates_log(),*) 'TFS water retention curves not available for soil' call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -413,6 +441,24 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) (-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(smooth1_campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 + allocate(wkf_smooth_cch) + sites(s)%si_hydr%wkf_soil(j)%p => wkf_smooth_cch + call wkf_smooth_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),1._r8]) + end do + case(smooth2_campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + j_bc = j+csite_hydr%i_rhiz_t-1 + allocate(wkf_smooth_cch) + sites(s)%si_hydr%wkf_soil(j)%p => wkf_smooth_cch + call wkf_smooth_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),2._r8]) + end do case(tfs_type) write(fates_log(),*) 'TFS conductance not used in soil' call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1290,7 +1336,8 @@ subroutine InitHydrSites(sites,bc_in) ! Calculate the number of rhizosphere ! layers used if(ignore_layer1) then - csite_hydr%i_rhiz_t = 2 + !csite_hydr%i_rhiz_t = 2 + csite_hydr%i_rhiz_t = 6 csite_hydr%i_rhiz_b = bc_in(s)%nlevsoil else csite_hydr%i_rhiz_t = 1 @@ -1331,6 +1378,8 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) class(wkf_type_vg), pointer :: wkf_vg class(wrf_type_cch), pointer :: wrf_cch class(wkf_type_cch), pointer :: wkf_cch + class(wrf_type_smooth_cch), pointer :: wrf_smooth_cch + class(wkf_type_smooth_cch), pointer :: wkf_smooth_cch nsites = ubound(sites,1) @@ -1379,6 +1428,24 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) (-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(smooth1_campbell_type) + do j=1,site_hydr%nlevrhiz + j_bc=j+site_hydr%i_rhiz_t-1 + allocate(wrf_smooth_cch) + site_hydr%wrf_soil(j)%p => wrf_smooth_cch + call wrf_smooth_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),1._r8]) + end do + case(smooth2_campbell_type) + do j=1,site_hydr%nlevrhiz + j_bc=j+site_hydr%i_rhiz_t-1 + allocate(wrf_smooth_cch) + site_hydr%wrf_soil(j)%p => wrf_smooth_cch + call wrf_smooth_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),2._r8]) + end do case(tfs_type) write(fates_log(),*) 'TFS water retention curves not available for soil' call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1404,6 +1471,24 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) (-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(smooth1_campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + j_bc=j+site_hydr%i_rhiz_t-1 + allocate(wkf_smooth_cch) + site_hydr%wkf_soil(j)%p => wkf_smooth_cch + call wkf_smooth_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),1._r8]) + end do + case(smooth2_campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + j_bc=j+site_hydr%i_rhiz_t-1 + allocate(wkf_smooth_cch) + site_hydr%wkf_soil(j)%p => wkf_smooth_cch + call wkf_smooth_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),2._r8]) + end do case(tfs_type) write(fates_log(),*) 'TFS conductance not used in soil' call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -4201,6 +4286,8 @@ subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_s !----------------------------------------------------------------------- + ! for patches with no cohorts + if( l_aroot == 0._r8) return nshells = size(r_out_shell,dim=1) ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) @@ -5118,6 +5205,10 @@ function SumBetweenDepths(site_hydr,depth_t,depth_b,array_in) result(depth_sum) if(i_rhiz_b>=i_rhiz_t)then depth_sum = depth_sum + sum(array_in(i_rhiz_t:i_rhiz_b)) end if + ! The bottom depth is deeper than depth_b + if(i_rhiz_b == 0) then + return + end if ! Find fraction contribution from top partial layer (if any) if(i_rhiz_t>1) then From 915440da268c9c553fe8b1bad161b9878a362144 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 12 Mar 2021 13:36:00 -0500 Subject: [PATCH 210/578] Adding running mean functions --- biogeochem/EDMortalityFunctionsMod.F90 | 5 +- biogeochem/EDPatchDynamicsMod.F90 | 14 +++- biogeochem/EDPhysiologyMod.F90 | 16 ++-- fire/SFMainMod.F90 | 2 +- main/EDInitMod.F90 | 1 - main/EDTypesMod.F90 | 8 +- main/FatesInterfaceMod.F90 | 64 +++++++++++--- main/FatesInterfaceTypesMod.F90 | 17 ++-- main/FatesRunningMeanMod.F90 | 111 +++++++++++++++---------- 9 files changed, 156 insertions(+), 82 deletions(-) diff --git a/biogeochem/EDMortalityFunctionsMod.F90 b/biogeochem/EDMortalityFunctionsMod.F90 index fa0b933fc5..f188963767 100644 --- a/biogeochem/EDMortalityFunctionsMod.F90 +++ b/biogeochem/EDMortalityFunctionsMod.F90 @@ -62,7 +62,6 @@ subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort,smort,asmor real(r8),intent(out) :: smort ! size dependent senescence term real(r8),intent(out) :: asmort ! age dependent senescence term - integer :: ifp real(r8) :: frac ! relativised stored carbohydrate real(r8) :: leaf_c_target ! target leaf biomass kgC real(r8) :: store_c @@ -173,8 +172,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 - ifp = cohort_in%patchptr%patchno - temp_in_C = bc_in%t_veg24_pa(ifp) - tfrz + temp_in_C = cohort_in%patchptr%tveg24%get_mean() - tfrz + temp_dep_fraction = max(0.0_r8, min(1.0_r8, 1.0_r8 - (temp_in_C - & EDPftvarcon_inst%freezetol(cohort_in%pft))/frost_mort_buffer) ) frmort = EDPftvarcon_inst%mort_scalar_coldstress(cohort_in%pft) * temp_dep_fraction diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 5a49695d15..c7bc37ede7 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -45,6 +45,7 @@ module EDPatchDynamicsMod use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_days_per_year use FatesInterfaceTypesMod , only : numpft + use FatesInterfaceTypesMod , only : hlm_stepsize use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse @@ -560,7 +561,7 @@ subroutine spawn_patches( currentSite, bc_in) allocate(new_patch_primary) call create_patch(currentSite, new_patch_primary, age, & - site_areadis_primary, primaryforest) + site_areadis_primary, primaryforest ) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -1977,6 +1978,8 @@ subroutine create_patch(currentSite, new_patch, age, areap, label) allocate(new_patch%sabs_dif(hlm_numSWb)) allocate(new_patch%fragmentation_scaler(currentSite%nlevsoil)) + allocate(new_patch%tveg24) + call new_patch%tveg24%InitRMean(mem_period=86400._r8,up_period=hlm_stepsize) ! Litter ! Allocate, Zero Fluxes, and Initialize to "unset" values @@ -2478,6 +2481,9 @@ subroutine fuse_2_patches(csite, dp, rp) write(fates_log(),*) 'trying to fuse patches with different anthro_disturbance_label values' call endrun(msg=errMsg(sourcefile, __LINE__)) endif + + ! Weighted mean of the running means + call rp%tveg24%FuseRMean(dp%tveg24,rp%area*inv_sum_area) rp%fuel_eff_moist = (dp%fuel_eff_moist*dp%area + rp%fuel_eff_moist*rp%area) * inv_sum_area rp%livegrass = (dp%livegrass*dp%area + rp%livegrass*rp%area) * inv_sum_area @@ -2814,9 +2820,13 @@ subroutine dealloc_patch(cpatch) deallocate(cpatch%sabs_dir) deallocate(cpatch%sabs_dif) deallocate(cpatch%fragmentation_scaler) - end if + + ! Deallocate any running means + deallocate(cpatch%tveg24%mem) + deallocate(cpatch%tveg24) + return end subroutine dealloc_patch diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 32671e082e..0bf7f32df2 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -748,6 +748,7 @@ subroutine phenology( currentSite, bc_in ) ! Use the following layer index to calculate drought conditions ilayer_swater = minloc(abs(bc_in%z_sisl(:)-dphen_soil_depth),dim=1) + ! Parameter of drought decid leaf loss in mm in top layer...FIX(RF,032414) ! - this is arbitrary and poorly understood. Needs work. ED_ @@ -756,8 +757,8 @@ subroutine phenology( currentSite, bc_in ) 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 + do while(associated(cpatch)) + temp_in_C = temp_in_C + cpatch%tveg24%get_mean()*cpatch%area cpatch => cpatch%younger end do temp_in_C = temp_in_C * area_inv - tfrz @@ -2215,7 +2216,6 @@ subroutine fragmentation_scaler( currentPatch, bc_in) logical :: use_century_tfunc = .false. logical :: use_hlm_soil_scalar = .true. ! Use hlm input decomp fraction scalars integer :: j - integer :: ifp ! Index of a FATES Patch "ifp" real(r8) :: t_scalar ! temperature scalar real(r8) :: w_scalar ! moisture scalar real(r8) :: catanf ! hyperbolic temperature function from CENTURY @@ -2226,8 +2226,6 @@ subroutine fragmentation_scaler( currentPatch, bc_in) catanf(t1) = 11.75_r8 +(29.7_r8 / pi) * atan( pi * 0.031_r8 * ( t1 - 15.4_r8 )) catanf_30 = catanf(30._r8) - ifp = currentPatch%patchno - ! Use the hlm temp and moisture decomp fractions by default if ( use_hlm_soil_scalar ) then @@ -2239,17 +2237,17 @@ 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. - if (bc_in%t_veg24_pa(ifp) >= tfrz) then - t_scalar = q10_mr**((bc_in%t_veg24_pa(ifp)-(tfrz+25._r8))/10._r8) + if (currentPatch%tveg24%get_mean() >= tfrz) then + t_scalar = q10_mr**((currentPatch%tveg24%get_mean()-(tfrz+25._r8))/10._r8) ! Q10**((t_soisno(c,j)-(tfrz+25._r8))/10._r8) else - t_scalar = (q10_mr**(-25._r8/10._r8))*(q10_froz**((bc_in%t_veg24_pa(ifp)-tfrz)/10._r8)) + t_scalar = (q10_mr**(-25._r8/10._r8))*(q10_froz**((currentPatch%tveg24%get_mean()-tfrz)/10._r8)) !Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-tfrz)/10._r8) endif else ! original century uses an arctangent function to calculate the ! temperature dependence of decomposition - t_scalar = max(catanf(bc_in%t_veg24_pa(ifp)-tfrz)/catanf_30,0.01_r8) + t_scalar = max(catanf(currentPatch%tveg24%get_mean()-tfrz)/catanf_30,0.01_r8) endif !Moisture Limitations diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 127dfa43f9..155f6dc88d 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -142,7 +142,7 @@ subroutine fire_danger_index ( currentSite, bc_in) iofp = currentSite%oldest_patch%patchno - temp_in_C = bc_in%t_veg24_pa(iofp) - tfrz + temp_in_C = currentSite%oldest_patch%tveg24%get_mean() - tfrz rainfall = bc_in%precip24_pa(iofp)*sec_per_day rh = bc_in%relhumid24_pa(iofp) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 19a9d2cb00..951c041d60 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -462,7 +462,6 @@ subroutine init_patches( nsites, sites, bc_in) currentPatch%scorch_ht(:) = 0._r8 currentPatch%frac_burnt = 0._r8 currentPatch%burnt_frac_litter(:) = 0._r8 - currentPatch => currentPatch%older enddo enddo diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 110673f94a..94c4d77fcf 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -18,6 +18,7 @@ module EDTypesMod use FatesLitterMod, only : ncwd use FatesConstantsMod, only : n_anthro_disturbance_categories use FatesConstantsMod, only : days_per_year + use FatesRunningMeanMod, only : rmean_type implicit none private ! By default everything is private @@ -411,6 +412,12 @@ module EDTypesMod integer :: anthro_disturbance_label ! patch label for anthropogenic disturbance classification real(r8) :: age_since_anthro_disturbance ! average age for secondary forest since last anthropogenic disturbance + + ! Running means + !class(rmean_type), pointer :: t2m ! Place-holder for 2m air temperature (variable window-size) + class(rmean_type), pointer :: tveg24 ! 24-hour mean vegetation temperature (K) + + ! LEAF ORGANIZATION real(r8) :: pft_agb_profile(maxpft,n_dbh_bins) ! binned above ground biomass, for patch fusion: KgC/m2 real(r8) :: canopy_layer_tlai(nclmax) ! total leaf area index of each canopy layer @@ -684,7 +691,6 @@ module EDTypesMod type (ed_resources_management_type) :: resources_management ! resources_management at the site - ! INDICES real(r8) :: lat ! latitude: degrees real(r8) :: lon ! longitude: degrees diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 48aef9deed..244555616d 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -21,6 +21,8 @@ module FatesInterfaceMod use EDTypesMod , only : do_fates_salinity use EDTypesMod , only : numWaterMem use EDTypesMod , only : numlevsoil_max + use EDTypesMod , only : ed_site_type + use EDTypesMod , only : ed_patch_type use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue,ifalse use FatesConstantsMod , only : nearzero @@ -96,7 +98,8 @@ module FatesInterfaceMod public :: set_bcpconst public :: zero_bcs public :: set_bcs - + public :: UpdateFatesRMeansTStep + contains ! ==================================================================================== @@ -196,13 +199,13 @@ subroutine zero_bcs(fates,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)%lightning24(:) = 0.0_r8 fates%bc_in(s)%pop_density(:) = 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)%tveg_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 @@ -403,15 +406,13 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) allocate(bc_in%t_scalar_sisl(nlevsoil_in)) ! Lightning (or successful ignitions) and population density + ! Fire related variables allocate(bc_in%lightning24(maxPatchesPerSite)) allocate(bc_in%pop_density(maxPatchesPerSite)) - - ! Vegetation Dynamics - allocate(bc_in%t_veg24_pa(maxPatchesPerSite)) - allocate(bc_in%wind24_pa(maxPatchesPerSite)) allocate(bc_in%relhumid24_pa(maxPatchesPerSite)) allocate(bc_in%precip24_pa(maxPatchesPerSite)) + allocate(bc_in%tveg_pa(maxPatchesPerSite)) ! Radiation allocate(bc_in%solad_parb(maxPatchesPerSite,hlm_numSWb)) @@ -429,6 +430,8 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) allocate(bc_in%salinity_sl(nlevsoil_in)) endif + + ! Photosynthesis allocate(bc_in%filter_photo_pa(maxPatchesPerSite)) allocate(bc_in%dayl_factor_pa(maxPatchesPerSite)) @@ -1153,6 +1156,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_numlevgrnd = unset_int hlm_name = 'unset' hlm_hio_ignore_val = unset_double + hlm_stepsize = unset_double hlm_masterproc = unset_int hlm_ipedof = unset_int hlm_nu_com = 'unset' @@ -1360,6 +1364,14 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if( abs(hlm_stepsize-unset_double) sites(s)%oldest_patch + do while(associated(cpatch)) + ifp=ifp+1 + call cpatch%tveg24%UpdateRMean(bc_in(s)%tveg_pa(ifp)) + cpatch => cpatch%younger + enddo + enddo + + return + end subroutine UpdateFatesRMeansTStep + end module FatesInterfaceMod diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 5b069709cc..67b36d7e6a 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -69,7 +69,9 @@ module FatesInterfaceTypesMod ! 0: none ! 1: p is on - + real(r8), public :: hlm_stepsize ! The step-size of the host land model (s) + ! moreover, this is the shortest main-model timestep + ! at which fates will be called on the main model integration loop real(r8), public :: hlm_hio_ignore_val ! This value can be flushed to history ! diagnostics, such that the @@ -335,23 +337,19 @@ module FatesInterfaceTypesMod real(r8),allocatable :: w_scalar_sisl(:) ! fraction by which decomposition is limited by moisture availability real(r8),allocatable :: t_scalar_sisl(:) ! fraction by which decomposition is limited by temperature - - ! Vegetation Dynamics - ! --------------------------------------------------------------------------------- + ! Fire Model ! 24-hour lightning or ignitions [#/km2/day] real(r8),allocatable :: lightning24(:) ! Population density [#/km2] real(r8),allocatable :: pop_density(:) - - ! 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(:) + + ! Patch Vegetation temperature (K) + real(r8),allocatable :: tveg_pa(:) ! Average relative humidity over past 24 hours [-] real(r8), allocatable :: relhumid24_pa(:) @@ -359,7 +357,6 @@ module FatesInterfaceTypesMod ! Patch 24-hour running mean of wind (m/s ?) real(r8), allocatable :: wind24_pa(:) - ! Radiation variables for calculating sun/shade fractions ! --------------------------------------------------------------------------------- diff --git a/main/FatesRunningMeanMod.F90 b/main/FatesRunningMeanMod.F90 index f7b6ca611d..27e27ff573 100644 --- a/main/FatesRunningMeanMod.F90 +++ b/main/FatesRunningMeanMod.F90 @@ -1,50 +1,74 @@ module FatesRunningMeanMod - use FatesConstantsMod, only : nearzero - use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) - use shr_log_mod, only : errMsg => shr_log_errMsg - use FatesGlobals, only : endrun => fates_endrun + use FatesConstantsMod, only : nearzero + use FatesConstantsMod, only : r8 => fates_r8 + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + use shr_log_mod, only : errMsg => shr_log_errMsg + use FatesGlobals, only : endrun => fates_endrun + use FatesGlobals, only : fates_log + implicit none + private integer, parameter :: maxlen_varname = 8 type, public :: rmean_type - real(r8), allocatable(:) :: mem_rmean ! Array storing the memory of the mean - real(r8) :: c_rmean ! The current mean value from the + real(r8), allocatable :: mem(:) ! Array storing the memory of the mean + real(r8) :: c_mean ! The current mean value from the ! available memory, as of the last update integer :: c_index ! The current memory index as per the ! last update integer :: n_mem ! Total number of memory indices logical :: filled ! Has enough time elapsed so all memory filled? - character(len=maxlen_varname) :: var_name ! A short name for this variable - ! for diagnostic purposes + !character(len=maxlen_varname) :: var_name ! A short name for this variable + ! ! for diagnostic purposes contains - + + procedure :: get_mean procedure :: InitRMean procedure :: UpdateRMean procedure :: FuseRMean end type rmean_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ contains - subroutine InitRMean(this,name,mem_period,up_period) + function get_mean(this) class(rmean_type) :: this - character(len=maxlen_varname) :: name ! The name of the new variable + real(r8) :: get_mean + + if(this%c_index == 0) then + write(fates_log(), *) 'attempting to get a running mean from a variable' + write(fates_log(), *) 'that has not experienced any time to accumluate memory' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + get_mean = this%c_mean + + end function get_mean + + + subroutine InitRMean(this,mem_period,up_period) !,init_value) + + class(rmean_type) :: this + !character(len=maxlen_varname) :: name ! The name of the new variable real(r8) :: mem_period ! The period length in seconds that must be remembered real(r8) :: up_period ! The period length in seconds that memory is updated - ! (i.e. the resolution of the memory) - - this%name = name + ! (i.e. the resolution of the memory) + !real(r8) :: init_value ! The first value to put in memory + + !this%name = name this%n_mem = nint(mem_period/up_period) if( abs(real(this%n_mem,r8)-mem_period/up_period) > nearzero ) then - write(fates_log(), *) 'While defining a running mean variable: ',this%var_name + write(fates_log(), *) 'While defining a running mean variable: '!,this%var_name write(fates_log(), *) 'an update and total memory period was specified' write(fates_log(), *) 'where the update period is not an exact fraction of the period' write(fates_log(), *) 'mem_period: ',mem_period @@ -54,17 +78,20 @@ subroutine InitRMean(this,name,mem_period,up_period) end if ! Otherwise we allocate - allocate(this%mem_rmean(this%n_mem)) + allocate(this%mem(this%n_mem)) ! Initialize with nonsense numbers - this%mem_rmean(:) = nan + this%mem(:) = nan ! There are no memory spots filled with valid datapoints - this%filled = .false + this%filled = .false. - ! The current index of the memory is zero + ! The current index of the memory is one this%c_index = 0 + !this%mem(1) = init_value + + return end subroutine InitRMean @@ -76,7 +103,7 @@ subroutine UpdateRMean(this, new_value) real(r8) :: new_value ! The newest value added to the running mean this%c_index = this%c_index + 1 - + ! Update the index of the memory array ! and, determine if we have filled the memory yet ! If this index is greater than our memory slots, @@ -87,19 +114,18 @@ subroutine UpdateRMean(this, new_value) if(this%c_index>this%n_mem) this%c_index = 1 - this%mem_rmean(this%c_index) = new_value + this%mem(this%c_index) = new_value ! Update the running mean value. It will return a value ! if we have not filled in all the memory slots. To do this ! it will take a mean over what is available if(this%filled) then - this%c_rmean = sum(this%mem_rmean)/real(this%n_mem,r8) + this%c_mean = sum(this%mem)/real(this%n_mem,r8) else - this%c_rmean = sum(this%mem_rmean(1:this%c_index))/real(this%c_index,r8) + this%c_mean = sum(this%mem(1:this%c_index))/real(this%c_index,r8) end if - - + return end subroutine UpdateRmean @@ -124,7 +150,7 @@ subroutine FuseRMean(this,donor,recip_wgt) if(this%n_mem .ne. donor%n_mem) then write(fates_log(), *) 'memory size is somehow different during fusion' - write(fates_log(), *) 'of two running mean variables: ',this%name,donor%name + write(fates_log(), *) 'of two running mean variables: '!,this%name,donor%name call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -134,9 +160,9 @@ subroutine FuseRMean(this,donor,recip_wgt) d_id = donor%c_index do r_id = 1,this%n_mem - this%mem_rmean(r_id) = this%mem_rmean(r_id)*(recip_wgt) + & - donor%mem_rmean(d_id)*(1._r8-recip_wgt) - d_id = d_id+ipos + this%mem(r_id) = this%mem(r_id)*(recip_wgt) + & + donor%mem(d_id)*(1._r8-recip_wgt) + d_id = d_id+1 if(d_id>donor%n_mem) d_id = 1 end do @@ -151,7 +177,7 @@ subroutine FuseRMean(this,donor,recip_wgt) r_id = this%c_index do d_id = donor%c_index,1,-1 - this%mem_rmean(r_id) = this%mem_rmean(r_id)*(recip_wgt) + donor%mem_rmean(d_id)*(1._r8-recip_wgt) + this%mem(r_id) = this%mem(r_id)*(recip_wgt) + donor%mem(d_id)*(1._r8-recip_wgt) r_id = r_id - 1 if(r_id==0) r_id = this%n_mem end do @@ -167,13 +193,13 @@ subroutine FuseRMean(this,donor,recip_wgt) d_id = donor%c_index do r_id = this%c_index,1,-1 - this%mem_rmean(r_id) = this%mem_rmean(r_id)*(recip_wgt) + donor%mem_rmean(d_id)*(1._r8-recip_wgt) + this%mem(r_id) = this%mem(r_id)*(recip_wgt) + donor%mem(d_id)*(1._r8-recip_wgt) d_id = d_id - 1 if(d_id==0) d_id = donor%n_mem end do do r_id = this%n_mem,this%c_index+1,-1 - this%mem_rmean(r_id) = donor%mem_rmean(d_id + this%mem(r_id) = donor%mem(d_id) d_id = d_id - 1 end do ! Pass the current index of the donor since that was filled @@ -194,7 +220,7 @@ subroutine FuseRMean(this,donor,recip_wgt) r_id = this%c_index do d_id = donor%c_index,1,-1 - this%mem_rmean(r_id) = this%mem_rmean(r_id)*(recip_wgt) + donor%mem_rmean(d_id)*(1._r8-recip_wgt) + this%mem(r_id) = this%mem(r_id)*(recip_wgt) + donor%mem(d_id)*(1._r8-recip_wgt) end do else @@ -207,22 +233,21 @@ subroutine FuseRMean(this,donor,recip_wgt) d_id = donor%c_index do r_id = this%c_index,1,-1 - donor%mem_rmean(r_id) = this%mem_rmean(r_id)*(recip_wgt) + donor%mem_rmean(d_id)*(1._r8-recip_wgt) + donor%mem(r_id) = this%mem(r_id)*(recip_wgt) + donor%mem(d_id)*(1._r8-recip_wgt) end do - this%mem_rmean(:) = donor%mem_reman + this%mem(:) = donor%mem this%c_index = donor%c_index end if - - end if - - - ! take the mean of each - - - + ! Update the mean based on the fusion + if(this%filled) then + this%c_mean = sum(this%mem)/real(this%n_mem,r8) + else + if(this%c_index>0) this%c_mean = & + sum(this%mem(1:this%c_index))/real(this%c_index,r8) + end if return From 7cf61e2a53344d4f42d76538453ee49faa23b9ee Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 15 Mar 2021 14:09:45 -0400 Subject: [PATCH 211/578] Added seed germination pool flux for hydrologic limiations on recruitement --- biogeophys/FatesPlantHydraulicsMod.F90 | 73 +++++++++++++++++++------- 1 file changed, 54 insertions(+), 19 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 359ad16515..efba13d8ad 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -90,10 +90,12 @@ module FatesPlantHydraulicsMod use FatesHydraulicsMemMod, only: rwccap, rwcft use FatesHydraulicsMemMod, only: ignore_layer1 - use PRTGenericMod, only : all_carbon_elements + use PRTGenericMod, only : carbon12_element use PRTGenericMod, only : leaf_organ, fnrt_organ, sapw_organ use PRTGenericMod, only : store_organ, repro_organ, struct_organ - + use PRTGenericMod, only : num_elements + use PRTGenericMod, only : element_list + use clm_time_manager , only : get_step_size, get_nstep use EDPftvarcon, only : EDPftvarcon_inst @@ -832,10 +834,10 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) 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) + leaf_c = ccohort%prt%GetState(leaf_organ, carbon12_element) + sapw_c = ccohort%prt%GetState(sapw_organ, carbon12_element) + fnrt_c = ccohort%prt%GetState(fnrt_organ, carbon12_element) + struct_c = ccohort%prt%GetState(struct_organ, carbon12_element) roota = prt_params%fnrt_prof_a(ft) rootb = prt_params%fnrt_prof_b(ft) @@ -1612,16 +1614,24 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) ! Locals type(ed_cohort_hydr_type), pointer :: ccohort_hydr type(ed_site_hydr_type), pointer :: csite_hydr + type(ed_patch_type), pointer :: cpatch 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) :: 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) :: 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) :: 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 + integer :: el ! element loop index + integer :: element_id ! global element identifier index + real(r8) :: leaf_m, store_m, sapw_m ! Element mass in organ tissues + real(r8) :: fnrt_m, struct_m, repro_m ! Element mass in organ tissues + + + cpatch => ccohort%patchptr csite_hydr => csite%si_hydr ccohort_hydr =>ccohort%co_hydr recruitw = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & @@ -1651,8 +1661,33 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) nmin = min(n, nmin) endif end do - ccohort%n = min (ccohort%n, nmin) + ! If the minimum number of plants is less than what was dictated by the + ! carbon-nitrogen-phosphorus availability, then we appy a reduction. + ! We also have to add back in what had been taken, to the germination seed pool + + if(nmin < ccohort%n) then + + do el = 1,num_elements + + element_id = element_list(el) + + leaf_m = ccohort%prt%GetState(leaf_organ, element_id) + store_m = ccohort%prt%GetState(store_organ, element_id) + sapw_m = ccohort%prt%GetState(sapw_organ, element_id) + fnrt_m = ccohort%prt%GetState(fnrt_organ, element_id) + struct_m = ccohort%prt%GetState(struct_organ, element_id) + repro_m = ccohort%prt%GetState(repro_organ, element_id) + + cpatch%litter(el)%seed_germ(ccohort%pft) = cpatch%litter(el)%seed_germ(ccohort%pft) + & + (ccohort%n-nmin)/cpatch%area * & + (leaf_m+store_m+sapw_m+fnrt_m+struct_m+repro_m) + + end do + ccohort%n = nmin + end if + + return end subroutine ConstrainRecruitNumber @@ -2028,9 +2063,9 @@ subroutine BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) 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%prt%GetState(fnrt_organ, carbon12_element) + & + cCohort%prt%GetState(sapw_organ, carbon12_element) + & + cCohort%prt%GetState(leaf_organ, carbon12_element))* ccohort%n ccohort => ccohort%shorter enddo !cohort @@ -2039,9 +2074,9 @@ subroutine BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) 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%prt%GetState(fnrt_organ, carbon12_element) + & + cCohort%prt%GetState(sapw_organ, carbon12_element) + & + cCohort%prt%GetState(leaf_organ, carbon12_element)) * & ccohort%n / balive_patch ccohort => ccohort%shorter enddo !cohort From bb64f1bc8dbeac59b78fd345cda0ef0e43e86388 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 15 Mar 2021 14:58:47 -0600 Subject: [PATCH 212/578] re-added PEP carboxylase-limitation for C4 --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 33 ++++++++++++++++------ 1 file changed, 25 insertions(+), 8 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index bbbea43c12..b3576cb989 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -1060,7 +1060,14 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! C3: RuBP-limited photosynthesis aj = je * max(co2_inter_c-co2_cpoint, 0._r8) / & (4._r8*co2_inter_c+8._r8*co2_cpoint) - + + ! Gross photosynthesis smoothing calculations. Co-limit ac and aj. + aquad = theta_cj(c3c4_path_index) + bquad = -(ac + aj) + cquad = ac * aj + call quadratic_f (aquad, bquad, cquad, r1, r2) + agross = min(r1,r2) + else ! C4: Rubisco-limited photosynthesis @@ -1081,14 +1088,24 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in aj = aj / (laisha_lsl * canopy_area_lsl) end if - end if + ! C4: PEP carboxylase-limited (CO2-limited) + ap = co2_rcurve_islope * max(co2_inter_c, 0._r8) / can_press - ! Gross photosynthesis smoothing calculations. - aquad = theta_cj(c3c4_path_index) - bquad = -(ac + aj) - cquad = ac * aj - call quadratic_f (aquad, bquad, cquad, r1, r2) - agross = min(r1,r2) + ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap + + aquad = theta_cj(c3c4_path_index) + bquad = -(ac + aj) + cquad = ac * aj + call quadratic_f (aquad, bquad, cquad, r1, r2) + ai = min(r1,r2) + + aquad = theta_ip + bquad = -(ai + ap) + cquad = ai * ap + call quadratic_f (aquad, bquad, cquad, r1, r2) + agross = min(r1,r2) + + end if ! Net carbon assimilation. Exit iteration if an < 0 anet = agross - lmr From b18d8e689aff08328b87c234db28127100095891 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 15 Mar 2021 15:14:59 -0600 Subject: [PATCH 213/578] removed TPU parameters --- main/EDPftvarcon.F90 | 30 ------------------------ parameter_files/fates_params_default.cdl | 17 -------------- 2 files changed, 47 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 0a91c6a2ee..61f095a758 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -95,13 +95,10 @@ module EDPftvarcon real(r8), allocatable :: hf_flc_threshold(:) real(r8), allocatable :: vcmaxha(:) real(r8), allocatable :: jmaxha(:) - real(r8), allocatable :: tpuha(:) real(r8), allocatable :: vcmaxhd(:) real(r8), allocatable :: jmaxhd(:) - real(r8), allocatable :: tpuhd(:) real(r8), allocatable :: vcmaxse(:) real(r8), allocatable :: jmaxse(:) - real(r8), allocatable :: tpuse(:) real(r8), allocatable :: germination_rate(:) ! Fraction of seed mass germinating per year (yr-1) real(r8), allocatable :: seed_decay_rate(:) ! Fraction of seed mass (both germinated and ! ungerminated), decaying per year (yr-1) @@ -496,10 +493,6 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_leaf_tpuha' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_leaf_vcmaxhd' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -508,10 +501,6 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_leaf_tpuhd' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_leaf_vcmaxse' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -520,10 +509,6 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_leaf_tpuse' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_seed_germination_rate' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -839,10 +824,6 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%jmaxha) - name = 'fates_leaf_tpuha' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%tpuha) - name = 'fates_leaf_vcmaxhd' call fates_params%RetreiveParameterAllocate(name=name, & data=this%vcmaxhd) @@ -851,10 +832,6 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%jmaxhd) - name = 'fates_leaf_tpuhd' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%tpuhd) - name = 'fates_leaf_vcmaxse' call fates_params%RetreiveParameterAllocate(name=name, & data=this%vcmaxse) @@ -863,10 +840,6 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%jmaxse) - name = 'fates_leaf_tpuse' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%tpuse) - name = 'fates_seed_germination_rate' call fates_params%RetreiveParameterAllocate(name=name, & data=this%germination_rate) @@ -1351,13 +1324,10 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'hf_flc_threshold = ',EDPftvarcon_inst%hf_flc_threshold write(fates_log(),fmt0) 'vcmaxha = ',EDPftvarcon_inst%vcmaxha write(fates_log(),fmt0) 'jmaxha = ',EDPftvarcon_inst%jmaxha - write(fates_log(),fmt0) 'tpuha = ',EDPftvarcon_inst%tpuha write(fates_log(),fmt0) 'vcmaxhd = ',EDPftvarcon_inst%vcmaxhd write(fates_log(),fmt0) 'jmaxhd = ',EDPftvarcon_inst%jmaxhd - write(fates_log(),fmt0) 'tpuhd = ',EDPftvarcon_inst%tpuhd write(fates_log(),fmt0) 'vcmaxse = ',EDPftvarcon_inst%vcmaxse write(fates_log(),fmt0) 'jmaxse = ',EDPftvarcon_inst%jmaxse - write(fates_log(),fmt0) 'tpuse = ',EDPftvarcon_inst%tpuse write(fates_log(),fmt0) 'germination_timescale = ',EDPftvarcon_inst%germination_rate write(fates_log(),fmt0) 'seed_decay_turnover = ',EDPftvarcon_inst%seed_decay_rate write(fates_log(),fmt0) 'trim_limit = ',EDPftvarcon_inst%trim_limit diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 600b97ac00..333167ef5d 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -280,15 +280,6 @@ variables: double fates_leaf_stor_priority(fates_pft) ; fates_leaf_stor_priority:units = "unitless" ; fates_leaf_stor_priority:long_name = "factor governing priority of replacing storage with NPP" ; - double fates_leaf_tpuha(fates_pft) ; - fates_leaf_tpuha:units = "J/mol" ; - fates_leaf_tpuha:long_name = "activation energy for tpu" ; - double fates_leaf_tpuhd(fates_pft) ; - fates_leaf_tpuhd:units = "J/mol" ; - fates_leaf_tpuhd:long_name = "deactivation energy for tpu" ; - double fates_leaf_tpuse(fates_pft) ; - fates_leaf_tpuse:units = "J/mol/K" ; - fates_leaf_tpuse:long_name = "entropy term for tpu" ; double fates_leaf_vcmax25top(fates_leafage_class, fates_pft) ; fates_leaf_vcmax25top:units = "umol CO2/m^2/s" ; fates_leaf_vcmax25top:long_name = "maximum carboxylation rate of Rub. at 25C, canopy top" ; @@ -979,14 +970,6 @@ data: fates_leaf_stor_priority = 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 ; - fates_leaf_tpuha = 53100, 53100, 53100, 53100, 53100, 53100, 53100, 53100, - 53100, 53100, 53100, 53100 ; - - fates_leaf_tpuhd = 150650, 150650, 150650, 150650, 150650, 150650, 150650, - 150650, 150650, 150650, 150650, 150650 ; - - fates_leaf_tpuse = 490, 490, 490, 490, 490, 490, 490, 490, 490, 490, 490, 490 ; - fates_leaf_vcmax25top = 50, 65, 39, 62, 41, 58, 62, 54, 54, 78, 78, 78 ; From cc30d6e5324fad3c6c936d8707d3f1033212cae3 Mon Sep 17 00:00:00 2001 From: Yilin Fang Date: Mon, 15 Mar 2021 20:17:49 -0700 Subject: [PATCH 214/578] Resolve restart issue for patches without cohorts --- biogeophys/FatesPlantHydraulicsMod.F90 | 13 +++++++-- main/FatesHistoryInterfaceMod.F90 | 38 ++++++++++++++++++-------- 2 files changed, 37 insertions(+), 14 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 30b9618363..73ecf12cc5 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -1807,6 +1807,8 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) enddo !cohort cPatch => cPatch%older enddo !patch + !patch without cohorts + if(sum(csite_hydr%l_aroot_layer) == 0._r8) return ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) do j = 1,nlevrhiz @@ -2198,7 +2200,8 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) ! BOC: This was previously in HydrologyDrainage: csite_hydr => sites(s)%si_hydr - + ! patch without cohorts + if( sum(csite_hydr%l_aroot_layer) == 0._r8 ) cycle do j = 1,csite_hydr%nlevrhiz j_bc = j+csite_hydr%i_rhiz_t-1 @@ -2381,6 +2384,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) do s = 1, nsites site_hydr => sites(s)%si_hydr + if( sum(site_hydr%l_aroot_layer) == 0._r8 ) cycle nlevrhiz = site_hydr%nlevrhiz @@ -4287,7 +4291,12 @@ subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_s ! for patches with no cohorts - if( l_aroot == 0._r8) return + if( l_aroot == 0._r8) then + r_out_shell = 0._r8 + r_node_shell = 0._r8 + v_shell = 0._r8 + return + endif nshells = size(r_out_shell,dim=1) ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index ed98301ee4..208b3df9ad 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3916,26 +3916,40 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) 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 + !patch with cohorts + if(site_hydr%l_aroot_layer(jrhiz) > 0._r8) then + 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 + endif hio_soilmatpot_sl(io_si,jsoil) = psi hio_soilvwc_sl(io_si,jsoil) = vwc hio_soilvwcsat_sl(io_si,jsoil) = vwc_sat end do + if(sum(site_hydr%l_aroot_layer) == 0._r8) then + !to avoid nan for patch without cohorts + hio_rootwgt_soilvwc_si(io_si) = 0._r8 + hio_rootwgt_soilvwcsat_si(io_si) = 0._r8 + hio_rootwgt_soilmatpot_si(io_si) = 0._r8 - 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) = 0._r8 + hio_rootuptake_sl(io_si,:) = 0._r8 + hio_rootuptake_sl(io_si,jr1:jr2) = 0._r8 + hio_rootuptake_si(io_si) = 0._r8 + else + 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) + 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) + endif ! Normalization counters nplant_scpf(:) = 0._r8 From 6ba0849e1f986ce57eef247ea071da09351d5421 Mon Sep 17 00:00:00 2001 From: Yilin Fang Date: Wed, 17 Mar 2021 09:40:54 -0700 Subject: [PATCH 215/578] Add Ryan's fix for issue #721 --- biogeophys/FatesPlantHydraulicsMod.F90 | 99 ++++++++++++++++++++++++++ 1 file changed, 99 insertions(+) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 73ecf12cc5..51300bbb95 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -94,6 +94,9 @@ module FatesPlantHydraulicsMod use PRTGenericMod, only : leaf_organ, fnrt_organ, sapw_organ use PRTGenericMod, only : store_organ, repro_organ, struct_organ + use PRTGenericMod, only : num_elements + use PRTGenericMod, only : element_list + use clm_time_manager , only : get_step_size, get_nstep use EDPftvarcon, only : EDPftvarcon_inst @@ -1681,6 +1684,7 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) end subroutine RecruitWUptake +#if 0 !===================================================================================== subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) @@ -1739,6 +1743,101 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) ccohort%n = min (ccohort%n, nmin) end subroutine ConstrainRecruitNumber +#endif + + !===================================================================================== + 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 + ! --------------------------------------------------------------------------- + + ! 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 + type(ed_patch_type), pointer :: cpatch + 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) :: 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 + + integer :: el ! element loop index + integer :: element_id ! global element identifier index + real(r8) :: leaf_m, store_m, sapw_m ! Element mass in organ tissues + real(r8) :: fnrt_m, struct_m, repro_m ! Element mass in organ tissues + + + cpatch => ccohort%patchptr + 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 + + ! If the minimum number of plants is less than what was dictated by the + ! carbon-nitrogen-phosphorus availability, then we appy a reduction. + ! We also have to add back in what had been taken, to the germination seed + ! pool + + if(nmin < ccohort%n) then + + do el = 1,num_elements + + element_id = element_list(el) + + leaf_m = ccohort%prt%GetState(leaf_organ, element_id) + store_m = ccohort%prt%GetState(store_organ, element_id) + sapw_m = ccohort%prt%GetState(sapw_organ, element_id) + fnrt_m = ccohort%prt%GetState(fnrt_organ, element_id) + struct_m = ccohort%prt%GetState(struct_organ, element_id) + repro_m = ccohort%prt%GetState(repro_organ, element_id) + + cpatch%litter(el)%seed_germ(ccohort%pft) = cpatch%litter(el)%seed_germ(ccohort%pft) + & + (ccohort%n-nmin)/cpatch%area * & + (leaf_m+store_m+sapw_m+fnrt_m+struct_m+repro_m) + + end do + ccohort%n = nmin + end if + + return + end subroutine ConstrainRecruitNumber ! ===================================================================================== From e6ea9b24f0651b22a560c1b40583c0acd586390a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 19 Mar 2021 15:12:00 -0400 Subject: [PATCH 216/578] Re-worked the running mean functions: 1) abandoned maintaining all memory (ie simple moving average) in a window in favor of the exponential moving window, 2) added fixed window capabilities. --- biogeochem/EDPatchDynamicsMod.F90 | 6 +- main/FatesInterfaceMod.F90 | 16 +- main/FatesRunningMeanMod.F90 | 371 +++++++++++++++++------------- 3 files changed, 223 insertions(+), 170 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index c7bc37ede7..0b45d1b12c 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -85,7 +85,8 @@ module EDPatchDynamicsMod use SFParamsMod, only : SF_VAL_CWD_FRAC use EDParamsMod, only : logging_event_code use EDParamsMod, only : logging_export_frac - + use FatesRunningMeanMod, only : ema_24hr + ! CIME globals use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) use shr_log_mod , only : errMsg => shr_log_errMsg @@ -1979,7 +1980,7 @@ subroutine create_patch(currentSite, new_patch, age, areap, label) allocate(new_patch%fragmentation_scaler(currentSite%nlevsoil)) allocate(new_patch%tveg24) - call new_patch%tveg24%InitRMean(mem_period=86400._r8,up_period=hlm_stepsize) + call new_patch%tveg24%InitRMean(ema_24hr) ! No initial value ! Litter ! Allocate, Zero Fluxes, and Initialize to "unset" values @@ -2824,7 +2825,6 @@ subroutine dealloc_patch(cpatch) ! Deallocate any running means - deallocate(cpatch%tveg24%mem) deallocate(cpatch%tveg24) return diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 244555616d..d2656ef5ce 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -26,6 +26,7 @@ module FatesInterfaceMod use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue,ifalse use FatesConstantsMod , only : nearzero + use FatesConstantsMod , only : sec_per_day use FatesGlobals , only : fates_global_verbose use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun @@ -68,8 +69,11 @@ module FatesInterfaceMod use PRTInitParamsFatesMod , only : PRTCheckParams use PRTAllometricCarbonMod , only : InitPRTGlobalAllometricCarbon use PRTAllometricCNPMod , only : InitPRTGlobalAllometricCNP - - + use FatesRunningMeanMod , only : ema_24hr + use FatesRunningMeanMod , only : fixed_24hr + use FatesRunningMeanMod , only : moving_ema_window + use FatesRunningMeanMod , only : fixed_window + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) @@ -797,6 +801,14 @@ subroutine SetFatesGlobalElements(use_fates) ! These will not be used if use_ed or use_fates is false call fates_history_maps() + + ! Instantiate the time-averaging method globals + allocate(ema_24hr) + call ema_24hr%define(sec_per_day, hlm_stepsize, moving_ema_window) + allocate(fixed_24hr) + call fixed_24hr%define(sec_per_day, hlm_stepsize, fixed_window) + + else ! If we are not using FATES, the cohort dimension is still diff --git a/main/FatesRunningMeanMod.F90 b/main/FatesRunningMeanMod.F90 index 27e27ff573..60fa1b0850 100644 --- a/main/FatesRunningMeanMod.F90 +++ b/main/FatesRunningMeanMod.F90 @@ -12,18 +12,64 @@ module FatesRunningMeanMod private integer, parameter :: maxlen_varname = 8 + + ! These are flags that specify how the averaging window works. + ! Moving windows (default) can have an arbitrary size and update frequency) + ! and it is technically never reset, it just averages indefinitely. + ! But hourly, six-hourly, daily, monthly and yearly windows have pre-set + ! window sizes associated with their namesake, and more importantly, they + ! are zero'd at the beginning of the interval, and get equal average weighting + ! over their construction period. + + + integer, public, parameter :: moving_ema_window = 0 + integer, public, parameter :: fixed_window = 1 + + ! This type defines a type of mean. It does not + ! define the variable, but it defines how + ! often it is updated, how long its + ! memory period is, and if it should be zero'd + ! These are globally defined on the proc. + + type, public :: rmean_def_type + + real(r8) :: mem_period ! The total integration period (s) + real(r8) :: up_period ! The period between updates (s) + integer :: n_mem ! How many updates per integration period? + integer :: method ! Is this a fixed or moving window? + + contains + + procedure :: define + + end type rmean_def_type + + + ! This holds the time varying information for the mean + ! which is instantiated on sites, patches, and cohorts type, public :: rmean_type - real(r8), allocatable :: mem(:) ! Array storing the memory of the mean - real(r8) :: c_mean ! The current mean value from the - ! available memory, as of the last update - integer :: c_index ! The current memory index as per the - ! last update - integer :: n_mem ! Total number of memory indices - logical :: filled ! Has enough time elapsed so all memory filled? - !character(len=maxlen_varname) :: var_name ! A short name for this variable - ! ! for diagnostic purposes + real(r8) :: c_mean ! The current mean value, if this + ! is a moving window, its is the mean. + ! If this is a fixed window, it is only a partial mean + ! as the value uses equal update weights and is not + ! necessarily fully constructed. + + real(r8) :: l_mean ! The latest reportable mean value + ! this value is actually the same + ! as c_mean for moving windows, and for fixed windows + ! it is the mean value when the time integratino window + ! last completed. + + integer :: c_index ! The number of values that have + ! been added to the mean so far + ! once this is >= n_mem then + ! the ema weight hits its cap + + ! This points to the global structure that + ! defines the nature of this mean/avg + type(rmean_def_type), pointer :: def_type contains @@ -34,42 +80,31 @@ module FatesRunningMeanMod end type rmean_type + character(len=*), parameter, private :: sourcefile = & __FILE__ - -contains - function get_mean(this) + ! Define the time methods that we want to have available to us + + class(rmean_def_type), public, pointer :: ema_24hr + class(rmean_def_type), public, pointer :: fixed_24hr + +contains - class(rmean_type) :: this - real(r8) :: get_mean - if(this%c_index == 0) then - write(fates_log(), *) 'attempting to get a running mean from a variable' - write(fates_log(), *) 'that has not experienced any time to accumluate memory' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - get_mean = this%c_mean + subroutine define(this,mem_period,up_period,method) - end function get_mean - + class(rmean_def_type) :: this - subroutine InitRMean(this,mem_period,up_period) !,init_value) + real(r8),intent(in) :: mem_period + real(r8),intent(in) :: up_period + integer,intent(in) :: method - class(rmean_type) :: this - !character(len=maxlen_varname) :: name ! The name of the new variable - real(r8) :: mem_period ! The period length in seconds that must be remembered - real(r8) :: up_period ! The period length in seconds that memory is updated - ! (i.e. the resolution of the memory) - !real(r8) :: init_value ! The first value to put in memory - - !this%name = name - this%n_mem = nint(mem_period/up_period) - - if( abs(real(this%n_mem,r8)-mem_period/up_period) > nearzero ) then - write(fates_log(), *) 'While defining a running mean variable: '!,this%var_name - write(fates_log(), *) 'an update and total memory period was specified' + ! Check the memory and update periods + if( abs(nint(mem_period/up_period)-mem_period/up_period) > nearzero ) then + write(fates_log(), *) 'While defining a running mean definition' + write(fates_log(), *) 'an update and memory period was specified' write(fates_log(), *) 'where the update period is not an exact fraction of the period' write(fates_log(), *) 'mem_period: ',mem_period write(fates_log(), *) 'up_period: ',up_period @@ -77,20 +112,85 @@ subroutine InitRMean(this,mem_period,up_period) !,init_value) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - ! Otherwise we allocate - allocate(this%mem(this%n_mem)) + this%mem_period = mem_period + this%up_period = up_period + this%method = method + this%n_mem = nint(mem_period/up_period) + + return + end subroutine define + + ! ===================================================================================== + + function get_mean(this) + + class(rmean_type) :: this + real(r8) :: get_mean - ! Initialize with nonsense numbers - this%mem(:) = nan + if(this%def_type%method .eq. moving_ema_window) then + if(this%c_index == 0) then + write(fates_log(), *) 'attempting to get a running mean from a variable' + write(fates_log(), *) 'that has been given a value yet' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + else + if(this%c_index .ne. this%def_type%n_mem)then + write(fates_log(), *) 'attempting to get a mean over a fixed window' + write(fates_log(), *) 'at a time where the window has not completed' + write(fates_log(), *) 'its cycle yet' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + get_mean = this%l_mean + + end function get_mean + + ! ===================================================================================== + + subroutine InitRMean(this,rmean_def,init_value,init_offset) + + class(rmean_type) :: this + type(rmean_def_type), target :: rmean_def + real(r8),intent(in),optional :: init_value + real(r8),intent(in),optional :: init_offset - ! There are no memory spots filled with valid datapoints - this%filled = .false. + ! If the initialization happens part-way through a fixed averaging window + ! we need to account for this. The current method moves the position + ! index to match the offset, and then assumes that the init_value provided + ! was a constant over the offset period. - ! The current index of the memory is one - this%c_index = 0 + ! If the first value is offset, such that the we are a portion of the + ! way through the window, we need to account for this. - !this%mem(1) = init_value + ! Point to the averaging type + this%def_type => rmean_def + if(this%def_type%method .eq. fixed_window) then + + if(.not.(present(init_offset).and.present(init_value)) )then + write(fates_log(), *) 'when initializing a temporal mean on a fixed window' + write(fates_log(), *) 'there must be an initial value and a time offset' + write(fates_log(), *) 'specified.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + this%c_index = modulo(nint(init_offset/rmean_def%up_period)+1,rmean_def%n_mem) + this%c_mean = real(this%c_index,r8)/real(rmean_def%n_mem,r8)*init_value + this%l_mean = init_value + + elseif(this%def_type%method .eq. moving_ema_window) then + + if(present(init_value))then + this%c_mean = init_value + this%l_mean = init_value + this%c_index = 1 + else + this%c_mean = nan + this%l_mean = nan + this%c_index = 0 + end if + + end if return end subroutine InitRMean @@ -101,29 +201,41 @@ subroutine UpdateRMean(this, new_value) class(rmean_type) :: this real(r8) :: new_value ! The newest value added to the running mean + real(r8) :: wgt - this%c_index = this%c_index + 1 - - ! Update the index of the memory array - ! and, determine if we have filled the memory yet - ! If this index is greater than our memory slots, - ! go back to the first - if(this%c_index==this%n_mem) then - this%filled = .true. - end if + if(this%def_type%method.eq.moving_ema_window) then - if(this%c_index>this%n_mem) this%c_index = 1 - - this%mem(this%c_index) = new_value + this%c_index = min(this%def_type%n_mem,this%c_index + 1) + + if(this%c_index==1) then + this%c_mean = new_value + else + wgt = 1._r8/real(this%c_index,r8) + this%c_mean = this%c_mean*(1._r8-wgt) + wgt*new_value + end if + + this%l_mean = this%c_mean + + else - ! Update the running mean value. It will return a value - ! if we have not filled in all the memory slots. To do this - ! it will take a mean over what is available + ! If the last time we updated we had hit the + ! end of the averaging memory period, and + ! we are not using an indefinite running + ! average, then zero things out - if(this%filled) then - this%c_mean = sum(this%mem)/real(this%n_mem,r8) - else - this%c_mean = sum(this%mem(1:this%c_index))/real(this%c_index,r8) + if(this%c_index == this%def_type%n_mem) then + this%c_mean = 0._r8 + this%c_index = 0 + end if + + this%c_index = this%c_index + 1 + wgt = this%def_type%up_period/this%def_type%mem_period + this%c_mean = this%c_mean + new_value*wgt + + if(this%c_index == this%def_type%n_mem) then + this%l_mean = this%c_mean + end if + end if return @@ -133,123 +245,52 @@ end subroutine UpdateRmean subroutine FuseRMean(this,donor,recip_wgt) - ! When fusing the running mean of two entities, it is possible that they - ! may have a different amount of memory spaces filled (at least in FATES). This - ! is typical for newly created patches or cohorts, that litteraly just spawned - ! So what generally happens is we walk backwards from the current memory index - ! of both and take means where we can. In places where one entity has more - ! memory than the other, than we just use the value from the one that is there + ! Rules for fusion: + ! If both entities have valid means already, then you simply use the + ! weight provided to combine them. + ! If this is a moving average, then update the index to be the larger of + ! the two. + ! if this is a fixed window, check that the index is the same between + ! both. + class(rmean_type) :: this class(rmean_type), pointer :: donor real(r8),intent(in) :: recip_wgt ! Weighting factor for recipient (0-1) - integer :: r_id ! Loop index counter for the recipient (this) - integer :: d_id ! Loop index counter for the donor - - - if(this%n_mem .ne. donor%n_mem) then + if(this%def_type%n_mem .ne. donor%def_type%n_mem) then write(fates_log(), *) 'memory size is somehow different during fusion' write(fates_log(), *) 'of two running mean variables: '!,this%name,donor%name call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(this%filled .and. donor%filled) then - - ! Both are filled, take averages of each and be sure to use relative positions - - d_id = donor%c_index - do r_id = 1,this%n_mem - this%mem(r_id) = this%mem(r_id)*(recip_wgt) + & - donor%mem(d_id)*(1._r8-recip_wgt) - d_id = d_id+1 - if(d_id>donor%n_mem) d_id = 1 - end do - - elseif(this%filled .and. .not.donor%filled) then - - ! Here, we have only partial memory from the donor - ! we we iterate through the donor's memory - ! and average between the two in those spaces. Then - ! we leave the rest untouched because we accept - ! the values from the recipient. Also, keep the - ! recipient's index. - - r_id = this%c_index - do d_id = donor%c_index,1,-1 - this%mem(r_id) = this%mem(r_id)*(recip_wgt) + donor%mem(d_id)*(1._r8-recip_wgt) - r_id = r_id - 1 - if(r_id==0) r_id = this%n_mem - end do - - - elseif(.not.this%filled .and. donor%filled) then - - ! Here we only have partial memory from the recipient - ! so we iterate through the recipient's memory - ! and average between the two. Then we copy - ! over the values from the donor for the indices that we - ! didn't average because the donor has valid values - - d_id = donor%c_index - do r_id = this%c_index,1,-1 - this%mem(r_id) = this%mem(r_id)*(recip_wgt) + donor%mem(d_id)*(1._r8-recip_wgt) - d_id = d_id - 1 - if(d_id==0) d_id = donor%n_mem - end do - - do r_id = this%n_mem,this%c_index+1,-1 - this%mem(r_id) = donor%mem(d_id) - d_id = d_id - 1 - end do - ! Pass the current index of the donor since that was filled - ! And also update the status to filled since it now - ! has all memory filled from the donor - this%c_index = donor%c_index - this%filled = .true. - - elseif(.not.this%filled .and. .not.donor%filled) then + if(this%def_type%method .eq. fixed_window ) then + if (this%c_index .ne. donor%c_index) then + write(fates_log(), *) 'trying to fuse two fixed-window averages' + write(fates_log(), *) 'that are at different points in the window?' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if - ! Here, neither is completely filled - - if( this%c_index>donor%c_index ) then - - ! In this case, leave all data as the recipient - ! except for where there is donor. Keep the recipient's - ! index and status, since it is larger and should remain unchanged - - r_id = this%c_index - do d_id = donor%c_index,1,-1 - this%mem(r_id) = this%mem(r_id)*(recip_wgt) + donor%mem(d_id)*(1._r8-recip_wgt) - end do - - else + ! This last logic clause just simply prevents us from doing math + ! on uninitialized values. If both are unintiailized, then + ! leave the result as uninitialized + if( .not. (donor%c_index==0) ) then - ! In this case, we do the same thing as the previous - ! clause, but just switch the roles, then - ! copy the donor to the recipient - ! Also transfer the index from the donor, since that was - ! higher and now reflects the filled memory - - d_id = donor%c_index - do r_id = this%c_index,1,-1 - donor%mem(r_id) = this%mem(r_id)*(recip_wgt) + donor%mem(d_id)*(1._r8-recip_wgt) - end do - this%mem(:) = donor%mem + if(this%c_index==0) then + this%c_mean = donor%c_mean + this%l_mean = donor%l_mean this%c_index = donor%c_index + else + ! Take the weighted mean between the two + this%c_mean = this%c_mean*recip_wgt + donor%c_mean*(1._r8-recip_wgt) + this%l_mean = this%l_mean*recip_wgt + donor%l_mean*(1._r8-recip_wgt) + ! Update the index to the larger of the two + this%c_index = max(this%c_index,donor%c_index) end if - - end if - ! Update the mean based on the fusion - if(this%filled) then - this%c_mean = sum(this%mem)/real(this%n_mem,r8) - else - if(this%c_index>0) this%c_mean = & - sum(this%mem(1:this%c_index))/real(this%c_index,r8) end if - - + return end subroutine FuseRMean From 6b393abb7f94293a7fa64e2a1c40634e0baeac45 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 24 Mar 2021 14:08:36 -0400 Subject: [PATCH 217/578] Fixed fusion of hydro cohorts by making water content mass conservative. Removed unnecessary variables, fixed new recruit flag on fusion, added in better and tighter conservation checks --- biogeochem/EDCanopyStructureMod.F90 | 41 ++-- biogeochem/EDPhysiologyMod.F90 | 4 +- biogeophys/FatesPlantHydraulicsMod.F90 | 272 +++++++++++++------------ main/EDMainMod.F90 | 7 - main/FatesHistoryInterfaceMod.F90 | 7 - main/FatesHydraulicsMemMod.F90 | 24 +-- main/FatesRestartInterfaceMod.F90 | 48 ----- 7 files changed, 170 insertions(+), 233 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index bd34ef9bfc..64ca841ade 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -31,7 +31,6 @@ module EDCanopyStructureMod use FatesInterfaceTypesMod , only : numpft use FatesPlantHydraulicsMod, only : UpdateH2OVeg,InitHydrCohort, RecruitWaterStorage use EDTypesMod , only : maxCohortsPerPatch - use PRTGenericMod, only : leaf_organ use PRTGenericMod, only : all_carbon_elements use PRTGenericMod, only : leaf_organ @@ -272,7 +271,7 @@ subroutine canopy_structure( currentSite , bc_in ) enddo write(fates_log(),*) 'lat:',currentSite%lat write(fates_log(),*) 'lon:',currentSite%lon - write(fates_log(),*) 'spread:',currentSite%spread + write(fates_log(),*) 'spread:',currentSite%spread currentCohort => currentPatch%tallest do while (associated(currentCohort)) write(fates_log(),*) 'coh ilayer:',currentCohort%canopy_layer @@ -280,18 +279,18 @@ subroutine canopy_structure( currentSite , bc_in ) write(fates_log(),*) 'coh pft:',currentCohort%pft write(fates_log(),*) 'coh n:',currentCohort%n write(fates_log(),*) 'coh carea:',currentCohort%c_area - ipft=currentCohort%pft - write(fates_log(),*) 'maxh:',prt_params%allom_dbh_maxheight(ipft) + ipft=currentCohort%pft + write(fates_log(),*) 'maxh:',prt_params%allom_dbh_maxheight(ipft) write(fates_log(),*) 'lmode: ',prt_params%allom_lmode(ipft) - write(fates_log(),*) 'd2bl2: ',prt_params%allom_d2bl2(ipft) - write(fates_log(),*) 'd2bl_ediff: ',prt_params%allom_blca_expnt_diff(ipft) - write(fates_log(),*) 'd2ca_min: ',prt_params%allom_d2ca_coefficient_min(ipft) - write(fates_log(),*) 'd2ca_max: ',prt_params%allom_d2ca_coefficient_max(ipft) + write(fates_log(),*) 'd2bl2: ',prt_params%allom_d2bl2(ipft) + write(fates_log(),*) 'd2bl_ediff: ',prt_params%allom_blca_expnt_diff(ipft) + write(fates_log(),*) 'd2ca_min: ',prt_params%allom_d2ca_coefficient_min(ipft) + write(fates_log(),*) 'd2ca_max: ',prt_params%allom_d2ca_coefficient_max(ipft) currentCohort => currentCohort%shorter enddo call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + enddo ! do while(area_not_balanced) @@ -1891,8 +1890,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) real(r8) :: total_patch_area real(r8) :: total_canopy_area real(r8) :: weight ! Weighting for cohort variables in patch - - + do s = 1,nsites ifp = 0 @@ -1981,11 +1979,10 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) else bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 0.0_r8 end if - + currentPatch => currentPatch%younger end do - - + ! Apply patch and canopy area corrections ! If the difference is above reasonable math precision, apply a fix ! If the difference is way above reasonable math precision, gracefully exit @@ -2010,15 +2007,27 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) end do endif + + ! If running hydro, perform a final check to make sure that we + ! have conserved water. Since this is the very end of the dynamics + ! cycle, no water should had been added or lost to the site, however + ! with growth and death, we may had shuffled it around. + ! For recruitment, we initialized their water, but flagged them + ! to not be included in the site level balance yet, for they + ! will demand the water for their initialization on the first hydraulics time-step + + if (hlm_use_planthydro.eq.itrue) then + call UpdateH2OVeg(sites(s),bc_out(s),bc_out(s)%plant_stored_h2o_si,1) + end if end do ! If hydraulics is turned on, update the amount of water bound in vegetation + ! And also perform a check to see if we have conserved total water (we should have) if (hlm_use_planthydro.eq.itrue) then call RecruitWaterStorage(nsites,sites,bc_out) - call UpdateH2OVeg(nsites,sites,bc_out) end if - + end subroutine update_hlm_dynamics diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 32671e082e..9063a33c50 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1736,7 +1736,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) endif ! Only bother allocating a new cohort if there is a reasonable amount of it - if (temp_cohort%n > min_n_safemath )then + any_recruits: if (temp_cohort%n > min_n_safemath )then ! ----------------------------------------------------------------------------- ! PART II. @@ -1855,7 +1855,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) currentSite%recruitment_rate(ft) = currentSite%recruitment_rate(ft) + temp_cohort%n - endif + endif any_recruits endif !use_this_pft enddo !pft loop diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index efba13d8ad..3436646941 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -177,7 +177,8 @@ module FatesPlantHydraulicsMod logical, parameter :: trap_neg_wc = .false. logical, parameter :: trap_supersat_psi = .false. - + real(r8), parameter :: error_thresh = 1.e-5_r8 ! site level conservation error threshold in CLM + ! (mm = kg/m2) real(r8), parameter :: thsat_buff = 0.001_r8 ! Ensure that this amount of buffer ! is left between soil moisture and saturation [m3/m3] @@ -432,9 +433,11 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ! are not perturbed call SavePreviousRhizVolumes(sites(s)) - end do - call UpdateH2OVeg(nsites,sites,bc_out) + call UpdateH2OVeg(sites(s),bc_out(s)) + + end do + return end subroutine RestartHydrStates @@ -556,13 +559,6 @@ subroutine InitPlantHydStates(site, cohort) 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 cohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_ag(1)) @@ -969,9 +965,7 @@ subroutine UpdateSizeDepPlantHydStates(currentSite,ccohort) type(ed_site_hydr_type),pointer :: csite_hydr integer :: j,k,FT ! indices integer :: err_code = 0 - real(r8) :: th_ag_uncorr( n_hypool_ag) ! uncorrected aboveground water content[m3 m-3] - real(r8) :: th_troot_uncorr ! uncorrected transporting root water content[m3 m-3] - real(r8) :: th_aroot_uncorr(currentSite%si_hydr%nlevrhiz) ! uncorrected absorbing root water content[m3 m-3] + real(r8) :: th_uncorr ! Uncorrected water content real(r8), parameter :: small_theta_num = 1.e-7_r8 ! avoids theta values equalling thr or ths [m3 m-3] integer :: nstep !number of time steps @@ -979,6 +973,7 @@ subroutine UpdateSizeDepPlantHydStates(currentSite,ccohort) ccohort_hydr => ccohort%co_hydr FT = cCohort%pft + csite_hydr =>currentSite%si_hydr associate(pm_node => currentSite%si_hydr%pm_node) @@ -991,48 +986,44 @@ subroutine UpdateSizeDepPlantHydStates(currentSite,ccohort) do k=1,n_hypool_leaf if( ccohort_hydr%v_ag(k) > nearzero ) then - th_ag_uncorr(k) = ccohort_hydr%th_ag(k) * & + th_uncorr = 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)) + ccohort_hydr%th_ag(k) = constrain_water_contents(th_uncorr, small_theta_num, ft, leaf_p_media) else - th_ag_uncorr(k) = ccohort_hydr%th_ag(k) + th_uncorr = ccohort_hydr%th_ag(k) end if + + csite_hydr%h2oveg_growturn_err = csite_hydr%h2oveg_growturn_err + & + denh2o*cCohort%n*AREA_INV*(ccohort_hydr%th_ag(k)-th_uncorr)*ccohort_hydr%v_ag(k) end do do k=n_hypool_leaf+1,n_hypool_ag - th_ag_uncorr(k) = ccohort_hydr%th_ag(k) * & + th_uncorr = 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)) + ccohort_hydr%th_ag(k) = constrain_water_contents(th_uncorr, small_theta_num, ft, stem_p_media) + + csite_hydr%h2oveg_growturn_err = csite_hydr%h2oveg_growturn_err + & + denh2o*cCohort%n*AREA_INV*(ccohort_hydr%th_ag(k)-th_uncorr)*ccohort_hydr%v_ag(k) enddo - th_troot_uncorr = ccohort_hydr%th_troot * ccohort_hydr%v_troot_init /ccohort_hydr%v_troot - ccohort_hydr%th_troot = constrain_water_contents(th_troot_uncorr, small_theta_num, ft, pm_node(3)) + th_uncorr = ccohort_hydr%th_troot * ccohort_hydr%v_troot_init /ccohort_hydr%v_troot + ccohort_hydr%th_troot = constrain_water_contents(th_uncorr, small_theta_num, ft, troot_p_media ) + csite_hydr%h2oveg_growturn_err = csite_hydr%h2oveg_growturn_err + & + denh2o*cCohort%n*AREA_INV*(ccohort_hydr%th_troot-th_uncorr)*ccohort_hydr%v_troot + - ccohort_hydr%errh2o_growturn_aroot = 0._r8 do j=1,currentSite%si_hydr%nlevrhiz - th_aroot_uncorr(j) = ccohort_hydr%th_aroot(j) * & + th_uncorr = ccohort_hydr%th_aroot(j) * & ccohort_hydr%v_aroot_layer_init(j)/ccohort_hydr%v_aroot_layer(j) - ccohort_hydr%th_aroot(j) = constrain_water_contents(th_aroot_uncorr(j), small_theta_num, ft, pm_node(4)) - 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) + ccohort_hydr%th_aroot(j) = constrain_water_contents(th_uncorr, small_theta_num, ft, aroot_p_media) + + csite_hydr%h2oveg_growturn_err = csite_hydr%h2oveg_growturn_err + & + denh2o*cCohort%n*AREA_INV*(ccohort_hydr%th_aroot(j)-th_uncorr)*ccohort_hydr%v_aroot_layer(j) + enddo - ! Storing mass balance error - ! + means water created; - means water destroyed - ccohort_hydr%errh2o_growturn_ag(:) = denh2o*cCohort%n*AREA_INV*ccohort_hydr%v_ag(:) * & - (ccohort_hydr%th_ag(:)-th_ag_uncorr(:)) - ccohort_hydr%errh2o_growturn_troot = denh2o*cCohort%n*AREA_INV*ccohort_hydr%v_troot * & - (ccohort_hydr%th_troot-th_troot_uncorr) - - csite_hydr =>currentSite%si_hydr - csite_hydr%h2oveg_growturn_err = csite_hydr%h2oveg_growturn_err + & - sum(ccohort_hydr%errh2o_growturn_ag(:)) + & - ccohort_hydr%errh2o_growturn_troot + & - ccohort_hydr%errh2o_growturn_aroot - - ! UPDATES OF WATER POTENTIALS ARE DONE PRIOR TO RICHARDS' SOLUTION WITHIN FATESPLANTHYDRAULICSMOD.F90 end associate end subroutine UpdateSizeDepPlantHydStates @@ -1123,12 +1114,7 @@ subroutine CopyCohortHydraulics(newCohort, oldCohort) 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 @@ -1152,6 +1138,7 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne 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 + real(r8) :: vol_c1,vol_c2 ! Total water volume in the each cohort integer :: j,k ! indices integer :: ft @@ -1160,12 +1147,44 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne 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 + ft = currentCohort%pft + + ! At this point in the call sequence, we can assume the fused cohort (currentCohort) has + ! and updated size, shape and biomass, make sure this is called after parteh, and the + ! dbh and height are uppdated + + ! Save the old volumes because we need the old volume to calculate the pre-fusion water + ! volume of each cohort + call SavePreviousCompartmentVolumes(ccohort_hydr) + + ! This updates all of the z_node positions + call UpdatePlantHydrNodes(ccohort_hydr,ft,currentCohort%hite,site_hydr) + + ! This updates plant compartment volumes, lengths and + ! maximum conductances. Make sure for already + ! initialized vegetation, that SavePreviousCompartment + ! volumes, and UpdatePlantHydrNodes is called prior to this. + call UpdatePlantHydrLenVol(currentCohort,site_hydr) + + + ! Conserve the total water volume + + do k=1,n_hypool_ag + vol_c1 = currentCohort%n*ccohort_hydr%th_ag(k)*ccohort_hydr%v_ag_init(k) + vol_c2 = nextCohort%n*ncohort_hydr%th_ag(k)*ncohort_hydr%v_ag(k) + ccohort_hydr%th_ag(k) = (vol_c1+vol_c2)/(ccohort_hydr%v_ag(k)*newn) + end do + + vol_c1 = currentCohort%n*ccohort_hydr%th_troot*ccohort_hydr%v_troot_init + vol_c2 = nextCohort%n*ncohort_hydr%th_troot*ncohort_hydr%v_troot + ccohort_hydr%th_troot = (vol_c1+vol_c2)/(ccohort_hydr%v_troot*newn) + + do j=1,site_hydr%nlevrhiz + vol_c1 = currentCohort%n*ccohort_hydr%th_aroot(j)*ccohort_hydr%v_aroot_layer_init(j) + vol_c2 = nextCohort%n*ncohort_hydr%th_aroot(j)*ncohort_hydr%v_aroot_layer(j) + ccohort_hydr%th_aroot(j) = (vol_c1+vol_c2)/(ccohort_hydr%v_aroot_layer(j)*newn) + end do + ccohort_hydr%supsub_flag = 0 ! Only save the iteration counters for the worse of the two cohorts @@ -1175,7 +1194,7 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne 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)) @@ -1202,21 +1221,8 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne 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. + return end subroutine FuseCohortHydraulics ! ===================================================================================== @@ -1413,9 +1419,6 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) end do - ! - !! call UpdateH2OVeg(nsites,sites,bc_out) - ! -------------------------------------------------------------------------------- ! All other ed_Hydr_site_type variables are initialized elsewhere: ! @@ -1444,7 +1447,7 @@ end subroutine HydrSiteColdStart ! ===================================================================================== - subroutine UpdateH2OVeg(nsites,sites,bc_out) + subroutine UpdateH2OVeg(csite,bc_out,prev_site_h2o,icall) ! ---------------------------------------------------------------------------------- ! This subroutine is called following dynamics. After growth has been updated @@ -1453,10 +1456,17 @@ subroutine UpdateH2OVeg(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) + type(ed_site_type), intent(inout), target :: csite + type(bc_out_type), intent(inout) :: bc_out + + ! The total site water balance at a previous point in time. + ! In some cases, like during dynamics + ! we want to conserve total site water, so we check + + real(r8), intent(in),optional :: prev_site_h2o + integer, intent(in), optional :: icall + ! Locals type(ed_cohort_type), pointer :: currentCohort type(ed_patch_type), pointer :: currentPatch @@ -1469,47 +1479,56 @@ subroutine UpdateH2OVeg(nsites,sites,bc_out) !for debug only nstep = get_nstep() - do s = 1,nsites - bc_out(s)%plant_stored_h2o_si = 0.0_r8 - end do + bc_out%plant_stored_h2o_si = 0.0_r8 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(:)) + & - 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_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 + csite_hydr => csite%si_hydr + csite_hydr%h2oveg = 0.0_r8 + currentPatch => csite%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(:)) + & + 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_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%plant_stored_h2o_si = csite_hydr%h2oveg + csite_hydr%h2oveg_dead - & + csite_hydr%h2oveg_growturn_err - & + csite_hydr%h2oveg_hydro_err - end do + ! Perform a conservation check if desired + if(present(prev_site_h2o)) then + + if(abs(bc_out%plant_stored_h2o_si-prev_site_h2o)>error_thresh ) then + write(fates_log(),*) 'Total FATES site level water was not conserved during' + write(fates_log(),*) 'a check where it was supposed to be conserved.' + write(fates_log(),*) 'Most likely during daily dynamics.' + write(fates_log(),*) 'Call index: ',icall + write(fates_log(),*) 'Old mass: ',prev_site_h2o,' [mm/m2]' + write(fates_log(),*) 'New mass: ',bc_out%plant_stored_h2o_si,' [mm/m2]' + write(fates_log(),*) 'diff: ',bc_out%plant_stored_h2o_si-prev_site_h2o + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end if return end subroutine UpdateH2OVeg @@ -1665,7 +1684,6 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) ! If the minimum number of plants is less than what was dictated by the ! carbon-nitrogen-phosphorus availability, then we appy a reduction. ! We also have to add back in what had been taken, to the germination seed pool - if(nmin < ccohort%n) then do el = 1,num_elements @@ -2313,6 +2331,8 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) 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 @@ -2326,8 +2346,12 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) 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) - + if(recruitflag)then + do s = 1, nsites + call UpdateH2OVeg(sites(s),bc_out(s)) + end do + end if + do s = 1, nsites site_hydr => sites(s)%si_hydr @@ -2607,7 +2631,8 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) delta_soil_storage = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & site_hydr%v_shell(:,:)) * denh2o * AREA_INV - prev_h2osoil - if(abs(delta_plant_storage - (root_flux - transp_flux)) > 1.e-3_r8 ) then + if(abs(delta_plant_storage - (root_flux - transp_flux)) > error_thresh ) then + write(fates_log(),*) 'Site plant water balance does not close' write(fates_log(),*) 'balance error: ',abs(delta_plant_storage - (root_flux - transp_flux)) write(fates_log(),*) 'delta plant storage: ',delta_plant_storage,' [kg/m2]' @@ -2641,17 +2666,6 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) wb_check_site = delta_plant_storage+delta_soil_storage+site_runoff+transp_flux -! if( abs(wb_check_site - site_hydr%errh2o_hyd) > 1.e-5_r8 ) then -! write(fates_log(),*) 'FATES hydro water ERROR balance does not add up [kg/m2]:',wb_check_site - site_hydr%errh2o_hyd -! 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 -! call endrun(msg=errMsg(sourcefile, __LINE__)) -! end if - ! Now check on total error if( abs(wb_check_site) > 1.e-4_r8 ) then write(fates_log(),*) 'FATES hydro water balance is not so great [kg/m2]' @@ -2665,13 +2679,11 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) 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 - + + call UpdateH2OVeg(sites(s),bc_out(s)) + enddo !site - + return end subroutine Hydraulics_BC diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 1188802e03..3d70760090 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -157,13 +157,6 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) ! This is limited to a global event until more structured event handling is enabled call IsItLoggingTime(hlm_masterproc,currentSite) - ! ----------------------------------------------------------------------------------- - ! Parse nutrient flux rates - ! The input boundary conditions from the HLM should now have a daily integrated - ! flux. But, that flux still needs to be parsed out to the existing cohorts. - ! ----------------------------------------------------------------------------------- - - !************************************************************************** ! Fire, growth, biogeochemistry. !************************************************************************** diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index ed98301ee4..f9fa005b4c 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -329,7 +329,6 @@ module FatesHistoryInterfaceMod integer :: ih_h2oveg_dead_si integer :: ih_h2oveg_recruit_si integer :: ih_h2oveg_growturn_err_si - integer :: ih_h2oveg_pheno_err_si integer :: ih_h2oveg_hydro_err_si integer :: ih_site_cstatus_si @@ -2124,7 +2123,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_h2oveg_dead_si)%r81d(io_si) = sites(s)%si_hydr%h2oveg_dead this%hvars(ih_h2oveg_recruit_si)%r81d(io_si) = sites(s)%si_hydr%h2oveg_recruit this%hvars(ih_h2oveg_growturn_err_si)%r81d(io_si) = sites(s)%si_hydr%h2oveg_growturn_err - this%hvars(ih_h2oveg_pheno_err_si)%r81d(io_si) = sites(s)%si_hydr%h2oveg_pheno_err end if ! error in primary lands from patch fusion @@ -6298,11 +6296,6 @@ subroutine define_history_vars(this, initialize_variables) long='cumulative net borrowed (+) or lost (-) from plant_stored_h2o due to combined growth & turnover', use_default='inactive', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_growturn_err_si ) - - call this%set_history_var(vname='H2OVEG_PHENO_ERR', units = 'kg/m2', & - long='cumulative net borrowed (+) from plant_stored_h2o due to leaf emergence', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_pheno_err_si ) call this%set_history_var(vname='H2OVEG_HYDRO_ERR', units = 'kg/m2', & long='cumulative net borrowed (+) from plant_stored_h2o due to plant hydrodynamics', use_default='inactive', & diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index d3b71c2847..5de1165a16 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -131,10 +131,6 @@ module FatesHydraulicsMemMod ! tissue volume or too much water is ! available when tissue volume decreases, ! respectively. - real(r8) :: h2oveg_pheno_err ! error water pool (kg/m2) for leaf-on - ! Draw from or add to this pool when - ! insufficient plant water available to - ! support production of new leaves. real(r8) :: h2oveg_hydro_err ! error water pool (kg/m2) for hydrodynamics ! Draw from or add to this pool when ! insufficient plant water available to @@ -294,24 +290,6 @@ module FatesHydraulicsMemMod 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. - ! Draw from or add to this pool when - ! insufficient water available to increase - ! tissue volume or too much water is - ! available when tissue volume decreases, - ! respectively. - real(r8) :: errh2o_pheno_ag(n_hypool_ag) ! error water pool for for leaf-on - ! Draw from or add to this pool when - ! insufficient plant water available to - ! support production of new leaves. - 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 @@ -426,8 +404,8 @@ subroutine InitHydrSite(this,numpft,numlevsclass) 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_pheno_err = 0.0_r8 this%h2oveg_hydro_err = 0.0_r8 ! We have separate water transfer functions and parameters diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 0b621dec0a..bd7f9921b2 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -205,13 +205,9 @@ module FatesRestartInterfaceMod integer :: ir_hydro_th_troot integer :: ir_hydro_th_aroot_covec integer :: ir_hydro_liqvol_shell_si - integer :: ir_hydro_err_growturn_aroot - integer :: ir_hydro_err_growturn_ag_covec - integer :: ir_hydro_err_growturn_troot integer :: ir_hydro_recruit_si integer :: ir_hydro_dead_si integer :: ir_hydro_growturn_err_si - integer :: ir_hydro_pheno_err_si integer :: ir_hydro_hydro_err_si ! The number of variable dim/kind types we have defined (static) @@ -1035,21 +1031,6 @@ subroutine define_restart_vars(this, initialize_variables) units='kg/plant', veclength=nlevsoi_hyd_max, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_aroot_covec) - 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) - - call this%RegisterCohortVector(symbol_base='fates_hydro_err_ag', vtype=cohort_r8, & - long_name_base='error in plant-hydro balance above ground', & - units='kg/plant', veclength=n_hypool_ag, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_ag_covec) - - 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) - ! Site-level volumentric liquid water content (shell x layer) call this%set_restart_var(vname='fates_hydro_liqvol_shell', vtype=cohort_r8, & long_name='Volumetric water content of rhizosphere compartments (layerxshell)', & @@ -1074,12 +1055,6 @@ subroutine define_restart_vars(this, initialize_variables) units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_growturn_err_si ) - ! Site-level water balance error due to phenology? - call this%set_restart_var(vname='fates_hydro_pheno_err', vtype=site_r8, & - long_name='Site level error for hydraulics due to phenology', & - units='kg', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_pheno_err_si ) - ! Site-level water balance error in vegetation call this%set_restart_var(vname='fates_hydro_hydro_err', vtype=site_r8, & long_name='Site level error for hydrodynamics', & @@ -1827,18 +1802,6 @@ subroutine set_restart_vectors(this,nc,nsites,sites) 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 rio_canopy_layer_co(io_idx_co) = ccohort%canopy_layer @@ -2081,7 +2044,6 @@ subroutine set_restart_vectors(this,nc,nsites,sites) this%rvars(ir_hydro_recruit_si)%r81d(io_idx_si) = sites(s)%si_hydr%h2oveg_recruit this%rvars(ir_hydro_dead_si)%r81d(io_idx_si) = sites(s)%si_hydr%h2oveg_dead this%rvars(ir_hydro_growturn_err_si)%r81d(io_idx_si) = sites(s)%si_hydr%h2oveg_growturn_err - this%rvars(ir_hydro_pheno_err_si)%r81d(io_idx_si) = sites(s)%si_hydr%h2oveg_pheno_err 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 @@ -2659,15 +2621,6 @@ subroutine get_restart_vectors(this, nc, nsites, sites) call UpdatePlantPsiFTCFromTheta(ccohort,sites(s)%si_hydr) - - 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, & - ir_hydro_err_growturn_ag_covec,io_idx_co) end if io_idx_co = io_idx_co + 1 @@ -2807,7 +2760,6 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%si_hydr%h2oveg_recruit = this%rvars(ir_hydro_recruit_si)%r81d(io_idx_si) sites(s)%si_hydr%h2oveg_dead = this%rvars(ir_hydro_dead_si)%r81d(io_idx_si) sites(s)%si_hydr%h2oveg_growturn_err = this%rvars(ir_hydro_growturn_err_si)%r81d(io_idx_si) - sites(s)%si_hydr%h2oveg_pheno_err = this%rvars(ir_hydro_pheno_err_si)%r81d(io_idx_si) 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 From c8f8be52d91046d8a28c33ad7d2109fc2236f09d Mon Sep 17 00:00:00 2001 From: Junyan Ding Date: Wed, 24 Mar 2021 13:06:18 -0700 Subject: [PATCH 218/578] dynamic roots --- biogeophys/FatesPlantHydraulicsMod.F90 | 1522 ++++++++++++---------- main/EDPftvarcon.F90 | 66 + parameter_files/fates_params_default.cdl | 25 + 3 files changed, 948 insertions(+), 665 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 359ad16515..6c9b4e9bb4 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -52,20 +52,21 @@ module FatesPlantHydraulicsMod use EDTypesMod , only : ed_patch_type use EDTypesMod , only : ed_cohort_type use EDTypesMod , only : AREA_INV - use EDTypesMod , only : AREA + use EDTypesMod , only : AREA ! representative land unit, currently a constant as 100m x 100m 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 FatesInterfaceMod , only : bc_in_type + use FatesInterfaceMod , only : bc_out_type + use FatesInterfaceMod , only : hlm_use_planthydro + use FatesInterfaceMod , only : hlm_ipedof + use FatesInterfaceMod , only : numpft + use FatesInterfaceMod , only : nlevsclass use 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 @@ -97,8 +98,6 @@ module FatesPlantHydraulicsMod use clm_time_manager , only : get_step_size, get_nstep use EDPftvarcon, only : EDPftvarcon_inst - use PRTParametersMod, only : prt_params - use FatesHydroWTFMod, only : wrf_arr_type use FatesHydroWTFMod, only : wkf_arr_type @@ -109,7 +108,7 @@ module FatesPlantHydraulicsMod ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg use shr_infnan_mod , only : isnan => shr_infnan_isnan - + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) implicit none @@ -165,25 +164,13 @@ module FatesPlantHydraulicsMod - ! These switches are for developers who which to understand if there simulations - ! are ever entering regimes where water contents go negative (yes physically impossible) - ! or water pressures exceed that at saturation (maybe, maybe not likely) - ! These situations are possible/likely due to the nature of the constant flux boundary condition - ! of transpiration, due to the loosely-coupled nature of the hydro-land-energy-photosynthesis - ! system - - logical, parameter :: trap_neg_wc = .false. - logical, parameter :: trap_supersat_psi = .false. - - - 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 - - + logical,parameter :: debug = .true. ! flag to report warning in hydro + logical,public, parameter :: JD_debug = .true. ! Junyan added to debug my modifications + character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -220,7 +207,7 @@ module FatesPlantHydraulicsMod ! 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 + real(r8), parameter :: max_wb_step_err = 2.e-7_r8 ! original is 1.e-7_r8, Junyan changed to 2.e-7_r8 ! ! !PUBLIC MEMBER FUNCTIONS: @@ -250,6 +237,8 @@ module FatesPlantHydraulicsMod public :: ConstrainRecruitNumber public :: InitHydroGlobals + + !------------------------------------------------------------------------------ ! 01/18/16: Created by Brad Christoffersen ! 02/xx/17: Refactoring by Ryan Knox and Brad Christoffersen @@ -473,16 +462,11 @@ subroutine InitPlantHydStates(site, cohort) ! for transporting root node, match the lowest total potential ! in absorbing roots integer, parameter :: init_mode = 2 - class(wrf_arr_type),pointer :: wrfa,wrft - class(wkf_arr_type),pointer :: wkfa,wkft + site_hydr => site%si_hydr cohort_hydr => cohort%co_hydr ft = cohort%pft - wrfa => wrf_plant(aroot_p_media,ft) - wkfa => wkf_plant(aroot_p_media,ft) - wrft => wrf_plant(troot_p_media,ft) - wkft => wkf_plant(troot_p_media,ft) ! Set abosrbing root @@ -491,15 +475,20 @@ subroutine InitPlantHydStates(site, cohort) ! 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)) + ! Junyan added the if statement + if(cohort_hydr%l_aroot_layer(j) > 0) then + ! 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)) + ! 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) = wrfa%p%th_from_psi(cohort_hydr%psi_aroot(j)) - cohort_hydr%ftc_aroot(j) = wkfa%p%ftc_from_psi(cohort_hydr%psi_aroot(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)) + else + cohort_hydr%psi_aroot(j) = psi_aroot_init + cohort_hydr%th_aroot(j) = 0 + end if ! end Junyan addition July 24th. 2020 end do else @@ -508,8 +497,8 @@ subroutine InitPlantHydStates(site, cohort) 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) = wrfa%p%th_from_psi(cohort_hydr%psi_aroot(j)) - cohort_hydr%ftc_aroot(j) = wkfa%p%ftc_from_psi(cohort_hydr%psi_aroot(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 @@ -528,8 +517,8 @@ subroutine InitPlantHydStates(site, cohort) cohort_hydr%psi_troot = h_aroot_mean - & mpa_per_pa*denh2o*grav_earth*cohort_hydr%z_node_troot - dh_dz - cohort_hydr%th_troot = wrft%p%th_from_psi(cohort_hydr%psi_troot) - cohort_hydr%ftc_troot = wkft%p%ftc_from_psi(cohort_hydr%psi_troot) + cohort_hydr%th_troot = wrf_plant(troot_p_media,ft)%p%th_from_psi(cohort_hydr%psi_troot) + cohort_hydr%ftc_troot = wkf_plant(troot_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_troot) ! working our way up a tree, assigning water potentials that are in @@ -674,10 +663,13 @@ subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) ! 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 = prt_params%fnrt_prof_a(ft) - rootb = prt_params%fnrt_prof_b(ft) + + roota = EDPftvarcon_inst%roota_par(ft) + rootb = EDPftvarcon_inst%rootb_par(ft) nlevrhiz = csite_hydr%nlevrhiz - call CrownDepth(plant_height,crown_depth) + + ! call CrownDepth(plant_height,crown_depth) + crown_depth = EDPftvarcon_inst%crown(ft) * plant_height dz_canopy = crown_depth / real(n_hypool_leaf,r8) do k=1,n_hypool_leaf @@ -818,6 +810,21 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) real(r8) :: norm ! total root fraction used <1 integer :: nlevrhiz ! number of rhizosphere levels + ! added by Junyan May 29, 2020 + real(r8) :: dbh ! the dbh of current cohort [m] + real(r8) :: dbh_0 ! the dbh of the sappling at recuitment [m] + + real(r8) :: dbh_max ! the maximum dbh a PFT can have as observed [m] + real(r8) :: dbh_rev ! ratio, similar to RWC* + + real(r8) :: z_fr ! rooting depth of a cohort [m] + real(r8) :: z_fr_0 ! the rooting depth of of the sappling, corresponding to dbh_0 [m] + real(r8) :: z_fr_max ! the maximum rooting depth of a PFT, currently set to the soil depth, but can be a PFT based parameter + real(r8) :: frk ! the exponent parameter of the cohort rooting depth function, a PFT based parameter + + + ! end of Junyan's addition + ! 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 @@ -837,8 +844,20 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) fnrt_c = ccohort%prt%GetState(fnrt_organ, all_carbon_elements) struct_c = ccohort%prt%GetState(struct_organ, all_carbon_elements) - roota = prt_params%fnrt_prof_a(ft) - rootb = prt_params%fnrt_prof_b(ft) + roota = EDPftvarcon_inst%roota_par(ft) + rootb = EDPftvarcon_inst%rootb_par(ft) + + ! added by Junyan May 29, 2020 + dbh_max = EDPftvarcon_inst%allom_dbh_max(ft) + dbh_0 = EDPftvarcon_inst%allom_dbh_0(ft) + z_fr_max = EDPftvarcon_inst%allom_zfr_max(ft) + + z_fr_0 = EDPftvarcon_inst%allom_zfr_0(ft) + frk = EDPftvarcon_inst%allom_frk(ft) + dbh = ccohort%dbh + dbh_rev = (dbh - dbh_0)/(dbh_max - dbh_0) + + ! end of Junyan's addition ! Leaf Volumes ! ----------------------------------------------------------------------------------- @@ -847,10 +866,10 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! but that may not be so forever. ie sla = slatop (RGK-082017) ! m2/gC * cm2/m2 -> cm2/gC - sla = prt_params%slatop(ft) * cm2_per_m2 + sla = EDPftvarcon_inst%slatop(ft) * cm2_per_m2 ! empirical regression data from leaves at Caxiuana (~ 8 spp) - denleaf = -2.3231_r8*sla/prt_params%c2b(ft) + 781.899_r8 + 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 @@ -868,6 +887,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! [kgC] * [kg/kgC] / [kg/m3] -> [m3] + ! Get the target, or rather, maximum leaf carrying capacity of plant ! Lets also avoid super-low targets that have very low trimming functions @@ -875,7 +895,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) 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) * & - prt_params%c2b(ft) / denleaf/ real(n_hypool_leaf,r8) + EDPftvarcon_inst%c2b(ft) / denleaf/ real(n_hypool_leaf,r8) end if ! Step sapwood volume @@ -883,7 +903,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! BOC...may be needed for testing/comparison w/ v_sapwood ! kg / ( g cm-3 * cm3/m3 * kg/g ) -> m3 - ! v_stem = c_stem_biom / (prt_params%wood_density(ft) * kg_per_g * cm3_per_m3 ) + ! v_stem = b_stem_biom / (EDPftvarcon_inst%wood_density(ft) * kg_per_g * cm3_per_m3 ) ! calculate the sapwood cross-sectional area call bsap_allom(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,a_sapwood_target,sapw_c_target) @@ -895,8 +915,8 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! alternative cross section calculation ! a_sapwood = a_leaf_tot / ( 0.001_r8 + 0.025_r8 * ccohort%hite ) * 1.e-4_r8 - call CrownDepth(ccohort%hite,crown_depth) - z_stem = ccohort%hite - crown_depth + crown_depth = EDPftvarcon_inst%crown(ft) * ccohort%hite + z_stem = ccohort%hite - crown_depth * 0.2_r8 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 @@ -905,17 +925,17 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! leaf, fine root) biomass then subtract out the fine root biomass to get ! coarse (transporting) root biomass - woody_bg_c = (1.0_r8-prt_params%allom_agb_frac(ft)) * (sapw_c + struct_c) + woody_bg_c = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(ft)) * (sapw_c + struct_c) - v_troot = woody_bg_c * prt_params%c2b(ft) / & - (prt_params%wood_density(ft)*kg_per_g*cm3_per_m3) + v_troot = woody_bg_c * EDPftvarcon_inst%c2b(ft) / & + (EDPftvarcon_inst%wood_density(ft)*kg_per_g*cm3_per_m3) ! Estimate absorbing root total length (all layers) ! SRL is in m/g ! [m] = [kgC]*1000[g/kg]*[kg/kgC]*[m/g] ! ------------------------------------------------------------------------------ - l_aroot_tot = fnrt_c*g_per_kg*prt_params%c2b(ft)*EDPftvarcon_inst%hydr_srl(ft) + l_aroot_tot = fnrt_c*g_per_kg*EDPftvarcon_inst%c2b(ft)*EDPftvarcon_inst%hydr_srl(ft) ! Estimate absorbing root volume (all layers) @@ -930,22 +950,40 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! Partition the total absorbing root lengths and volumes into the active soil layers ! We have a condition, where we may ignore the first layer ! ------------------------------------------------------------------------------ - + ! modified by Junyan May 29, 2020 + ! norm = 1._r8 - & + ! zeng2001_crootfr(roota, rootb,site_hydr%zi_rhiz(1)-site_hydr%dz_rhiz(1), site_hydr%zi_rhiz(nlevrhiz)) + + + ! set the rooting depth of the cohort, using the logistic functionbelow: + ! z_fr_max/(1 + ((z_fr_max-z_fr_0)/z_fr_0)*exp(-frk*dbh_rev)) + ! which is constrained by the maximum soil depth: site_hydr%zi_rhiz(nlevrhiz) + + z_fr = min(site_hydr%zi_rhiz(nlevrhiz), z_fr_max/(1 + ((z_fr_max-z_fr_0)/z_fr_0)*exp(-frk*dbh_rev))) norm = 1._r8 - & - zeng2001_crootfr(roota, rootb,site_hydr%zi_rhiz(1)-site_hydr%dz_rhiz(1), site_hydr%zi_rhiz(nlevrhiz)) + zeng2001_crootfr(roota, rootb,site_hydr%zi_rhiz(1)-site_hydr%dz_rhiz(1), z_fr) do j=1,nlevrhiz - rootfr = norm*(zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j),site_hydr%zi_rhiz(nlevrhiz)) - & - zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j)-site_hydr%dz_rhiz(j),site_hydr%zi_rhiz(nlevrhiz))) + rootfr = norm * (zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j),z_fr) - & + zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j)-site_hydr%dz_rhiz(j),z_fr)) + if(JD_debug)then + write(fates_log(),*) 'check rooting depth of cohort - Junyan, line 972' + write(fates_log(),*) 'dbh: ',ccohort%dbh,' sice class: ',ccohort%size_class + write(fates_log(),*) 'site_hydr%dz_rhiz(j) is: ', site_hydr%dz_rhiz(j) + write(fates_log(),*) 'z_max cohort: ',z_fr + write(fates_log(),*) 'layer: ',j,' depth (m): ',site_hydr%zi_rhiz(j),' rooting fraction:',rootfr + write(fates_log(),*) 'End of Junyan check' + end if ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot ! This is a hybrid absorbing root and transporting root volume ccohort_hydr%v_aroot_layer(j) = rootfr*(v_aroot_tot + t2aroot_vol_donate_frac*v_troot) end do - + ! end of Junyan's modification + return end subroutine UpdatePlantHydrLenVol @@ -1009,11 +1047,16 @@ subroutine UpdateSizeDepPlantHydStates(currentSite,ccohort) 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, 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) + ! check v_aroot >0, Junyan addition + if (ccohort_hydr%v_aroot_layer(j) > 0) then + th_aroot_uncorr(j) = ccohort_hydr%th_aroot(j) * & + ccohort_hydr%v_aroot_layer_init(j)/ccohort_hydr%v_aroot_layer(j) + ccohort_hydr%th_aroot(j) = constrain_water_contents(th_aroot_uncorr(j), small_theta_num, ft, pm_node(4)) + 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) + else + + endif ! end Junyan addition enddo ! Storing mass balance error @@ -1344,9 +1387,13 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) 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) + ! Junyan added log + if (JD_debug) then + write(fates_log(),*) 'line 1368, initial shell water content' + write(fates_log(),*) 'water content:', h2osoi_liqvol + site_hydr%h2osoi_liqvol_shell(j,1:nshell) = h2osoi_liqvol + site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j_bc) + endif end do @@ -1460,7 +1507,7 @@ subroutine UpdateH2OVeg(nsites,sites,bc_out) type(ed_patch_type), pointer :: currentPatch type(ed_cohort_hydr_type), pointer :: ccohort_hydr type(ed_site_hydr_type), pointer :: csite_hydr - integer :: s + integer :: s,ily real(r8) :: balive_patch integer :: nstep !number of time steps @@ -1483,12 +1530,26 @@ subroutine UpdateH2OVeg(nsites,sites,bc_out) 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 + if(.not.ccohort_hydr%is_newly_recruited) then + ! Junyan added check for nan value + do ily = 1,csite_hydr%nlevrhiz + if(ccohort_hydr%th_aroot(ily)/=ccohort_hydr%th_aroot(ily)) then + ccohort_hydr%th_aroot(ily) = 0 + endif + end do ! end Junyan addition Mar - 12 2021 + + csite_hydr%h2oveg = csite_hydr%h2oveg + & (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 + if (JD_debug) then + write(fates_log(),*) 'Junyan added log info, line 1532' + write(fates_log(),*) 'ccohort_hydr%th_aroot(:):', ccohort_hydr%th_aroot(:) + write(fates_log(),*) 'ccohort_hydr%v_aroot_layer(:):', ccohort_hydr%v_aroot_layer(:) + write(fates_log(),*) + endif endif currentCohort => currentCohort%shorter @@ -1501,6 +1562,14 @@ subroutine UpdateH2OVeg(nsites,sites,bc_out) ! 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) + if (JD_debug) then + write(fates_log(),*) 'check NaN, line 1561' + write(fates_log(),*) 'csite_hydr%h2oveg:',csite_hydr%h2oveg + write(fates_log(),*) 'csite_hydr%h2oveg_dead:',csite_hydr%h2oveg_dead + write(fates_log(),*) 'csite_hydr%h2oveg_growturn_err:', csite_hydr%h2oveg_growturn_err + write(fates_log(),*) 'csite_hydr%h2oveg_hydro_err:', csite_hydr%h2oveg_hydro_err + write(fates_log(),*) 'csite_hydr%h2oveg_pheno_err:', csite_hydr%h2oveg_pheno_err + endif bc_out(s)%plant_stored_h2o_si = csite_hydr%h2oveg + csite_hydr%h2oveg_dead - & csite_hydr%h2oveg_growturn_err - & csite_hydr%h2oveg_pheno_err-& @@ -1522,7 +1591,10 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) ! 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. + ! as the plants pop into existance. + ! Notes by Junyan, July 16. 2020 + ! need to modify the accessable soil layer equal to z_fr_0 + ! ! ---------------------------------------------------------------------------------- ! Arguments @@ -1539,6 +1611,8 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) 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) @@ -1560,6 +1634,8 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) ! 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(:)) + & ccohort_hydr%th_troot*ccohort_hydr%v_troot + & sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & @@ -1602,6 +1678,9 @@ 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 + ! Notes by Junyan, July 16. 2020 + ! need to modify the accessable soil layer equal to z_fr_0 + ! ! --------------------------------------------------------------------------- ! Arguments @@ -1616,12 +1695,17 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) 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(:)) + & @@ -1634,6 +1718,8 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) end do do j=1,csite_hydr%nlevrhiz + ! Junyan add the if statement + if (ccohort_hydr%l_aroot_layer(j)>0.0_r8) then 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,:)) @@ -1641,7 +1727,7 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) !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) - + endif ! end of Junyan addition end do nmin = 1.0e+36 @@ -1677,7 +1763,7 @@ end subroutine SavePreviousRhizVolumes subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) ! - ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. + ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes of the site. ! As fine root biomass (and thus absorbing root length) increases, this characteristic ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains ! the same. @@ -1709,7 +1795,7 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) csite_hydr => currentSite%si_hydr nlevrhiz = csite_hydr%nlevrhiz - + ! Notes by Junyan, here is where the site level ! update cohort-level root length density and accumulate it across cohorts and patches to the column level csite_hydr%l_aroot_layer(:) = 0._r8 cPatch => currentSite%youngest_patch @@ -1725,15 +1811,37 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) 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 + ! proceed only if l_aroot_layer >0 + if( csite_hydr%l_aroot_layer(j) >0 ) then + ! not necessary to skip no root layer, I manipulated shellGeom to incorporate this situation 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? + else + ! Junyan added Mar 11 2021 + ! set the shell geometry to be the same as the upalyer + ! soil layer if there is no root in that layer + csite_hydr%r_out_shell(j,:) = csite_hydr%r_out_shell(j-1,:) + csite_hydr%r_node_shell(j,:) = csite_hydr%r_node_shell(j-1,:) + csite_hydr%v_shell(j,:) = csite_hydr%v_shell(j-1,:) + + end if ! enddo do j = 1,nlevrhiz + ! Junyan added logs + if (JD_debug) then + write(fates_log(),*) 'code line 1793, check shellGeom ' + write(fates_log(),*) ' uncommented line 1786 and 1789 to only get' + write(fates_log(),*) ' shell geometry if there is root in the layer' + write(fates_log(),*) 'j:', j + write(fates_log(),*) 'csite_hydr%r_out_shell(j,:)', csite_hydr%r_out_shell(j,:) + write(fates_log(),*) 'csite_hydr%v_shell(j,:): ' , csite_hydr%v_shell(j,:) + write(fates_log(),*) 'csite_hydr%r_node_shell(j,:)' , csite_hydr%r_node_shell(j,:) + write(fates_log(),*) + write(fates_log(),*) + endif + j_bc = j+csite_hydr%i_rhiz_t-1 ! bc_in%hksat_sisl(j): hydraulic conductivity at saturation (mm H2O /s) @@ -1865,7 +1973,7 @@ subroutine UpdateSizeDepRhizHydStates(currentSite, bc_in) 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 psi_shell_init(j,k) = csite_hydr%wrf_soil(j)%p%psi_from_th(csite_hydr%h2osoi_liqvol_shell(j,k)) end do @@ -2317,6 +2425,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) site_hydr%rootuptake50_scpf(:,:) = 0._r8 site_hydr%rootuptake100_scpf(:,:) = 0._r8 + ! Initialize water mass balancing terms [kg h2o / m2] ! -------------------------------------------------------------------------------- transp_flux = 0._r8 @@ -2408,9 +2517,13 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) !--------------------------------------------------------------------------- + ! 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(bc_in(s),site_hydr,ccohort,ccohort_hydr, & + call MatSolve2D(site_hydr,ccohort,ccohort_hydr, & dtime,qflx_tran_veg_indiv, & sapflow,rootuptake(1:nlevrhiz),wb_err_plant,dwat_plant, & dth_layershell_col) @@ -2455,8 +2568,16 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! Update total site-level stored plant water [kg/m2] ! (this is not zerod, but incremented) - site_hydr%h2oveg = site_hydr%h2oveg + dwat_plant*ccohort%n*AREA_INV + ! check which one is NaN + if (JD_debug) then + write(fates_log(),*) ' line 2535' + write(fates_log(),*) 'dwat_plant', dwat_plant + write(fates_log(),*) 'site_hydr%h2oveg',site_hydr%h2oveg + endif + + site_hydr%h2oveg = site_hydr%h2oveg + dwat_plant*ccohort%n*AREA_INV + sc = ccohort%size_class ! Sapflow diagnostic [kg/ha/s] @@ -2510,16 +2631,35 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! [kg/m2] root_flux = -sum(dth_layershell_col(1:site_hydr%nlevrhiz,:)*site_hydr%v_shell(:,:))*denh2o*AREA_INV + ! Junyan added loginfo + write(fates_log(),*) 'root_flux: ', root_flux - + bc_out(s)%qflx_soil2root_sisl(:) = 0 + bc_out(s)%qflx_ro_sisl(:) = 0 do j=1,site_hydr%nlevrhiz + j_bc = j+site_hydr%i_rhiz_t-1 ! Update the site-level state variable ! rhizosphere shell water content [m3/m3] + ! Junyan added loginfo + if (JD_debug) then + write(fates_log(),*) 'code line 2619' + write(fates_log(),*) 'layer: ', j + write(fates_log(),*) 'dth_layershell_col(j,:):', dth_layershell_col(j,:) + write(fates_log(),*) 'site_hydr%v_shell(j,:):', site_hydr%v_shell(j,:) + write(fates_log(),*) 'site_hydr%h2osoi_liqvol_shell: ', site_hydr%h2osoi_liqvol_shell(j,:) + write(fates_log(),*) 'dth_layershell_col(j,:) ', dth_layershell_col(j,:) + write(fates_log(),*) 'site_hydr%l_aroot_layer(j): ' , site_hydr%l_aroot_layer(j) + endif + + ! Junyan added if statement + if (site_hydr%l_aroot_layer(j) > 0) then + site_hydr%h2osoi_liqvol_shell(j,:) = site_hydr%h2osoi_liqvol_shell(j,:) + & dth_layershell_col(j,:) - + ! Junyan added notes, need to adjust NaN and Infinity values for no root layers to avoid + ! NaN in bc_out bc_out(s)%qflx_soil2root_sisl(j_bc) = & -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:))*denh2o*AREA_INV/dtime) + & @@ -2527,7 +2667,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! Save the amount of liquid soil water known to the model after root uptake - ! This calculation also assumes that 1mm of water is 1kg + ! This calculation also assumes that 1m 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) @@ -2557,7 +2697,8 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) end do bc_out(s)%qflx_ro_sisl(j_bc) = site_runoff/dtime - end if + end if + end if ! line 2604 Junyan addition enddo @@ -2568,21 +2709,24 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) 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-3_r8 ) then + write(fates_log(),*) 'Junyan uncommented all the if and call endrun to degut, line 2684' + + 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(),*) 'balance error: ',abs(delta_plant_storage - (root_flux - transp_flux)) 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 + write(fates_log(),*) ' pre_h2oveg', prev_h2oveg call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(abs(delta_soil_storage + root_flux + site_runoff) > 1.e-3_r8 ) then + 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]' @@ -2606,20 +2750,19 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) wb_check_site = delta_plant_storage+delta_soil_storage+site_runoff+transp_flux -! if( abs(wb_check_site - site_hydr%errh2o_hyd) > 1.e-5_r8 ) then -! write(fates_log(),*) 'FATES hydro water ERROR balance does not add up [kg/m2]:',wb_check_site - site_hydr%errh2o_hyd -! 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 -! call endrun(msg=errMsg(sourcefile, __LINE__)) -! end if + 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 ! Now check on total error - if( abs(wb_check_site) > 1.e-4_r8 ) then - write(fates_log(),*) 'FATES hydro water balance is not so great [kg/m2]' + 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 @@ -2634,7 +2777,18 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) site_hydr%h2oveg_growturn_err - & site_hydr%h2oveg_pheno_err-& site_hydr%h2oveg_hydro_err - + if (JD_debug) then + write(fates_log(),*) 'line 2759, check bc_out' + write(fates_log(),*) 'wb_check_site:', wb_check_site + + write(fates_log(),*) 'bc_out(s)%site plant_stored_h2o:', bc_out(s)%plant_stored_h2o_si + write(fates_log(),*) 'check each term of plant_stored_h2o' + write(fates_log(),*) 'site_hydr%h2oveg',site_hydr%h2oveg + write(fates_log(),*) 'site_hydr%h2oveg_dead',site_hydr%h2oveg_dead + write(fates_log(),*) 'site_hydr%h2oveg_growturn_err',site_hydr%h2oveg_growturn_err + write(fates_log(),*) 'site_hydr%h2oveg_pheno_err',site_hydr%h2oveg_pheno_err + write(fates_log(),*) 'site_hydr%errh2o_hyd',site_hydr%errh2o_hyd, 'this term is correct' + endif enddo !site return @@ -2700,12 +2854,17 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr) ! 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) @@ -2748,17 +2907,17 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr) ! 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(EDPftvarcon_inst%hydr_p_taper(pft), z_upper) * & + 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(EDPftvarcon_inst%hydr_p_taper(pft), z_node) * & + 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(EDPftvarcon_inst%hydr_p_taper(pft), z_lower) * & + xylemtaper(taper_exponent, z_lower) * & a_sapwood / z_lower ! Max conductance over the path of the upper side of the compartment @@ -2787,15 +2946,18 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr) 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(EDPftvarcon_inst%hydr_p_taper(pft), z_node) * & + xylemtaper(taper_exponent, z_node) * & a_sapwood / z_node kmax_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_upper) * & + 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 @@ -2844,7 +3006,8 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr) ! 2) is the path between the boundary of the absorbing root and ! transporting root, with the absorbing root's center node ! (kmax_aroot_upper) - + + ! note: if there is no roots in that layer, from the last line of code, kmax_layer of layer j of the cohort is 0 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 @@ -2915,7 +3078,7 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort,cohort_hydr,ordered, kbg_layer ft = cohort%pft do j=1,site_hydr%nlevrhiz - + if(aroot_frac_plant> 0) then ! Junyan addition of if statement, ! Path is between the absorbing root ! and the first rhizosphere shell nodes ! Special case. Maximum conductance depends on the @@ -2947,30 +3110,36 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort,cohort_hydr,ordered, kbg_layer ! 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 + + if(aroot_frac_plant == 0) then ! Junyan addition of if statement, + kbg_layer(j) = 0._r8 + else + + 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 + kmax_up = site_hydr%kmax_upper_shell(j,k)*aroot_frac_plant + kmax_lo = site_hydr%kmax_lower_shell(j,k)*aroot_frac_plant - psi_shell = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,k)) + psi_shell = 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) + 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 enddo !soil layer kbg_layer = kbg_layer/kbg_tot - ! order soil layers in terms of decreasing volumetric water content + ! order soil layers in terms of decreasing of total hydraulic conductance ! 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 @@ -3087,8 +3256,10 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & 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 + real(r8) :: l_aroot_layer ! total root lengh of a given soil layer of the site , Junyan added integer :: iter ! iteration count for sub-step loops integer, parameter :: imult = 3 ! With each iteration, increase the number of substeps @@ -3167,8 +3338,15 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! 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) + + ! Junyan added if statement to handle zero l_aroot_layer condition + if (site_hydr%l_aroot_layer(ilayer)=5, rhizosphere 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) + if (th_node_init(i) < 0) then ! Junyan added to debug + write(fates_log(),*) 'line 3392, print out shell theta' + write(fates_log(),*) 'layer: ',ilayer, 'shell:', ishell + write(fates_log(),*) 'th_node_init(i) is: ', th_node_init(i) + write(fates_log(),*) 'th_node_init(i) is: ', th_node_init(i) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if ! + end if end do - + if (aroot_frac_plant > 0) then ! Junyan addition Aug 2, to start the interation loop if the aroot_frac_plant of that layer > 0 ! 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 @@ -3408,7 +3598,16 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & end if kmax_up = site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant - + + ! Junyan added the log content for debugging, JD1 + if (JD_debug) then + write(fates_log(),*) 'line 3535, debug 1Dsolve' + write(fates_log(),*) 'iteration:', iter, 'step:', istep + write(fates_log(),*) 'layer: ',jj, 'order',ilayer, 'shell:', 1 + write(fates_log(),*) 'j=',j, 'h_node(j) is: ', h_node(j) + write(fates_log(),*) 'kmax_up: ', kmax_up + write(fates_log(),*) 'kmax_dn: ', kmax_dn + endif call GetImTaylorKAB(kmax_up,kmax_dn, & ftc_node(i_up),ftc_node(i_dn), & h_node(i_up),h_node(i_dn), & @@ -3417,6 +3616,9 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & k_eff(j), & A_term(j), & B_term(j)) + write(fates_log(),*) 'k_eff of', j, 'is : ', k_eff(j) + write(fates_log(),*) 'A_term of', j, 'is : ', A_term(j) + write(fates_log(),*) ' B_term of', j, 'is : ', B_term(j) ! Path is between rhizosphere shells @@ -3506,17 +3708,14 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & error_code = 0 end if - ! If desired, check and trap water contents - ! that are negative - if(trap_neg_wc) then - if( any(th_node(:)<0._r8) ) then - solution_found = .false. - error_code = 3 - error_arr(:) = th_node(:) - exit - 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)) @@ -3525,25 +3724,6 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) end do - ! If desired, check and trap pressures that are supersaturated - if(trap_supersat_psi) then - do i = 1,n_hypool_plant - if(psi_node(i)>wrf_plant(pm_node(i),ft)%p%get_thsat()) then - solution_found = .false. - error_code = 4 - end if - end do - do i = n_hypool_plant+1,n_hypool_tot - if(psi_node(i)>site_hydr%wrf_soil(ilayer)%p%get_thsat()) then - solution_found = .false. - error_code = 4 - end if - end do - if(error_code==4) then - error_arr(:) = th_node(:) - end if - end if - ! Accumulate the water balance error of the layer over the sub-steps ! for diagnostic purposes ! [kg/m2] @@ -3637,9 +3817,9 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & end if ! Save the number of times we refined our sub-step counts (iterh1) - cohort_hydr%iterh1 = max(cohort_hydr%iterh1,real(iter,r8)) + 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,r8)) + cohort_hydr%iterh2 = max(cohort_hydr%iterh2,real(nsteps)) ! Update water contents in the relevant plant compartments [m3/m3] ! ------------------------------------------------------------------------------- @@ -3666,18 +3846,20 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! 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 @@ -3750,6 +3932,10 @@ subroutine Report1DError(cohort, site_hydr, ilayer, z_node, v_node, & 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(),*) 'q_top_eff*dt_step = ',q_top_eff*dt_step + write(fates_log(),*) 'w_tot_beg = ',w_tot_beg + write(fates_log(),*) 'w_tot_end = ',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 @@ -3913,45 +4099,29 @@ subroutine GetKAndDKDPsi(kmax_dn,kmax_up, & ! 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(in) :: ftc_dn ! frac total cond (downstream) [-] - real(r8),intent(in) :: ftc_up ! frac total cond (upstream) [-] - real(r8),intent(in) :: dftc_dpsi_dn ! derivative ftc / theta (downstream) - real(r8),intent(in) :: 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] + 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 - real(r8) :: ftc_dnx ! frac total cond (downstream) [-] (local copy) - real(r8) :: ftc_upx ! frac total cond (upstream) [-] (local copy) - real(r8) :: dftc_dpsi_dnx ! derivative ftc / theta (downstream) (local copy) - real(r8) :: dftc_dpsi_upx ! derivative ftc / theta (upstream) (local copy) - - - - ! We use the local copies of the FTC in our calculations - ! because we don't want to over-write the global values. This prevents - ! us from overwriting FTC on nodes that have more than one connection - - ftc_dnx = ftc_dn - ftc_upx = ftc_up - dftc_dpsi_dnx = dftc_dpsi_dn - dftc_dpsi_upx = dftc_dpsi_up - + 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 @@ -3963,21 +4133,23 @@ subroutine GetKAndDKDPsi(kmax_dn,kmax_up, & if(do_upstream_k) then if (h_diff>0._r8) then - ftc_dnx = ftc_up - dftc_dpsi_dnx = 0._r8 + ftc_dn = ftc_up + dftc_dpsi_dn = 0._r8 else - ftc_upx = ftc_dn - dftc_dpsi_upx = 0._r8 + ftc_up = ftc_dn + dftc_dpsi_up = 0._r8 end if end if ! Calculate total effective conductance over path [kg s-1 MPa-1] - k_eff = 1._r8/(1._r8/(ftc_upx*kmax_up)+1._r8/(ftc_dnx*kmax_dn)) + 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_dnx**(-2._r8) * dftc_dpsi_dnx + + dk_dpsi_dn = k_eff**2._r8 * kmax_dn**(-1._r8) * ftc_dn**(-2._r8) * dftc_dpsi_dn + + dk_dpsi_up = k_eff**2._r8 * kmax_up**(-1._r8) * ftc_up**(-2._r8) * dftc_dpsi_up - dk_dpsi_up = k_eff**2._r8 * kmax_up**(-1._r8) * ftc_upx**(-2._r8) * dftc_dpsi_upx return @@ -4153,6 +4325,10 @@ function zeng2001_crootfr(a, b, z, z_max) result(crootfr) ! root fraction. if(present(z_max))then + ! Junyan added so if the soil depth is larger than the maximum rooting depth of the cohort, + ! then the cumulative root frection of that layer equals that of the maximum rooting depth + crootfr = 1._r8 - .5_r8*(exp(-a*min(z,z_max)) + exp(-b*min(z,z_max))) + ! end of Junyan addition crootfr_max = 1._r8 - .5_r8*(exp(-a*z_max) + exp(-b*z_max)) crootfr = crootfr/crootfr_max end if @@ -4199,35 +4375,49 @@ subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_s integer :: k ! rhizosphere shell indicies integer :: nshells ! We don't use the global because of unit testing !----------------------------------------------------------------------- + if (JD_debug) then + write(fates_log(),*) 'code line 4379, check shellGeom ' + write(fates_log(),*) 'rs1 of a given layer:', rs1 + endif - nshells = size(r_out_shell,dim=1) ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) - r_out_shell(nshells) = (pi_const*l_aroot/(area_site*dz))**(-0.5_r8) ! eqn(8) S98 - if(nshells > 1) then - do k = 1,nshells-1 - r_out_shell(k) = rs1*(r_out_shell(nshells)/rs1)**((real(k,r8))/real(nshells,r8)) ! eqn(7) S98 - enddo - end if + ! Junyan added if statement + if(l_aroot > 0) then + 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)) + ! 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 + 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 + ! 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 + + else + ! set values for zero roots case + ! r_out_shell(1:nshells) = 0 + ! r_node_shell(1:nshells) = 0 + ! v_shell(1:k) = 0 + + end if ! Junyan addition return end subroutine shellGeom @@ -4237,7 +4427,7 @@ end subroutine shellGeom function xylemtaper(p, dz) result(chi_tapnotap) ! !ARGUMENTS: - real(r8) , intent(in) :: p ! Taper exponent (see EDPftvar hydr_p_taper) [-] + 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: @@ -4368,7 +4558,7 @@ end subroutine Hydraulics_Tridiagonal ! ===================================================================================== - subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & + subroutine MatSolve2D(site_hydr,cohort,cohort_hydr, & tmx,qtop, & sapflow,rootuptake,wb_err_plant , dwat_plant, & dth_layershell_site) @@ -4406,7 +4596,6 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ! ARGUMENTS: ! ----------------------------------------------------------------------------------- - type(bc_in_type),intent(in) :: bc_in 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 @@ -4425,7 +4614,6 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & integer :: i ! generic index (sometimes node index) integer :: inode ! node index integer :: k ! generic node index - integer :: j_bc ! layer of bc 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 @@ -4457,14 +4645,12 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & real(r8) :: rlfx_soil ! Pressure update reduction factor for soil compartments real(r8) :: rlfx_plnt ! Pressure update reduction factor for plant comparmtents - real(r8) :: rlfx_soil0 ! Base relaxation factor for the current iteration round - real(r8) :: rlfx_plnt0 ! "" 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] - logical :: continue_search + 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 @@ -4491,58 +4677,32 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ! potentially reducing relaxation factors integer, parameter :: max_newton_rounds = 10 - ! dtime will shrink at the following rate (halving) [s]: - ! 1800,900,450,225,112.5,56.25,28.125,14.0625,7.03125,3.515625, - ! 1.7578125,0.87890625,0.439453125,0.2197265625,0.10986328125, - ! 0.054931640625,0.0274658203125,0.01373291015625,0.006866455078125, - ! 0.0034332275390625,0.00171661376953125, - - ! Maximum number of Newton iterations in each round - integer, parameter :: max_newton_iter = 100 + 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 :: icnv_pass_round = 2 + integer, parameter :: incv_cont_search = 2 + integer, parameter :: icnv_pass_round = 3 + integer, parameter :: icnv_complete_fail = 4 ! Timestep reduction factor when a round of ! newton iterations fail. - real(r8), parameter :: dtime_rf = 0.5_r8 - - ! These are the initial relaxation factors at the beginning - ! of the large time-step. These may or may not shrink on - ! subsequent rounds, and may or may not grow over subsequent - ! iterations within rounds - real(r8), parameter :: rlfx_soil_init = 1.0 ! Initial Pressure update - ! reduction factor for soil compartments - real(r8), parameter :: rlfx_plnt_init = 1.0 ! Initial Pressure update - ! reduction factor for plant comparmtents - real(r8), parameter :: dpsi_scap = 0.2 ! Changes in psi (for soil) larger than this - ! will be subject to a capping routine - real(r8), parameter :: dpsi_pcap = 0.3 ! Change sin psi (for plants) larger than this - ! will be subject to a capping routine - real(r8), parameter :: rlfx_plnt_shrink = 1.0 ! Shrink the starting plant relaxtion factor - ! by this multipliler each round - real(r8), parameter :: rlfx_soil_shrink = 1.0 ! Shrink the starting soil relaxtion factor - ! by this multipliler each round - logical, parameter :: reset_on_fail = .false. ! If a round of Newton iterations is unable - ! to find a solution, you can either reset - ! to the beginning of the large timestep (true), or - ! to the beginning of the current substep (false) - - logical, parameter :: allow_lenient_lastiter = .true. ! If this is true, when the newton iteration - ! reaches its last allowed attempt, the - ! error tolerance will be increased (the bar lowered) by 10x + 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, & @@ -4552,7 +4712,6 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ajac => site_hydr%ajac, & ipiv => site_hydr%ipiv, & th_node => site_hydr%th_node, & - th_node_prev => site_hydr%th_node_prev, & th_node_init => site_hydr%th_node_init, & psi_node => site_hydr%psi_node, & pm_node => site_hydr%pm_node, & @@ -4616,8 +4775,11 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ! folume that this plant's rhizosphere accounts forPath is across the upper an lower rhizosphere comparment ! on each side of the nodes. Since there is no flow across the outer ! node to the edge, we ignore that last half compartment - aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) - + + ! Junyan add the if statement to avoid 0 root length of a layer + if (site_hydr%l_aroot_layer(j)>0._r8) then + 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 @@ -4632,10 +4794,11 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & th_node_init(i) = site_hydr%h2osoi_liqvol_shell(j,kshell) end if enddo - + end if ! Junyan addition enddo - + + ! Total water mass in the plant at the beginning of this solve [kg h2o] w_tot_beg = sum(th_node_init(:)*v_node(:))*denh2o @@ -4643,410 +4806,439 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ! Initialize variables and flags that track ! the progress of the solve - tm = 0 - nsteps = 0 - th_node_prev(:) = th_node_init(:) - th_node(:) = th_node_init(:) - dtime = tmx - rlfx_plnt0 = rlfx_plnt_init - rlfx_soil0 = rlfx_soil_init - rlfx_plnt = rlfx_plnt0 - rlfx_soil = rlfx_soil0 - - outerloop: do while( tm < tmx ) - - ! The solve may reduce the time-step, the shorter - ! time-steps may not be perfectly divisible into - ! the remaining time. If so, then make sure we - ! don't overshoot - - dtime = min(dtime,tmx-tm) - - ! Advance time forward - tm = tm + dtime - ! 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 - - ! Complete failure to converge even with re-trying - ! iterations with smaller timesteps - - 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.' - write(fates_log(),*) 'pft: ',ft,' dbh: ',cohort%dbh - call endrun(msg=errMsg(sourcefile, __LINE__)) - - endif + tm = 0 + nsteps = 0 + outerloop: do while(tm < tmx) - ! This is the newton search loop + ! 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 - continue_search = .true. + ! 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 - newtonloop: do while(continue_search) - nwtn_iter = nwtn_iter + 1 + ! 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 + ! 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) + denh2o*v_node(k)*(th_node(k) - th_node_prev(k))/dtime - - 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)) - - ! 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)) - - 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 - j = node_layer(k) - 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 k=1,site_hydr%num_nodes - - ! 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) - ! This should be used for the down-stream on thr second index) - 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 mass balance - ajac(id_dn,id_dn) = ajac(id_dn,id_dn) + dqflx_dpsi_dn - - ! Down-stream node's contribution to the up-stream node's mass balance - ajac(id_up,id_dn) = ajac(id_up,id_dn) - dqflx_dpsi_dn - - ! Up-stream node's contribution to the down-stream node's mass balance - ajac(id_dn,id_up) = ajac(id_dn,id_up) + dqflx_dpsi_up - - ! Up-stream node's contribution to the up-stream node's mass balance - ajac(id_up,id_up) = ajac(id_up,id_up) - dqflx_dpsi_up + ! 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)) + + 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. - enddo + 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 - ! 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 - - - ! 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 - if ( nwtn_iter > max_newton_iter) then - icnv = icnv_fail_round - write(fates_log(),*) 'Newton hydraulics solve failed',residual_amax,nsd,tm - endif +! 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 + - ! Three scenarios: - ! 1) the residual is 0, everything is great, leave iteration loop - ! 2) the residual is not 0, but we have not taken too many steps - ! and the matrix solve did not fail. Perform an inversion and keep - ! searching. - ! 3) the residual is not 0, and either - ! we have taken too many newton steps or the solver won't return - ! a real solution. - ! Shorten time-step, reset time to 0, reset relaxation factors - ! and try a new round of newton (if not exceeded) + ! 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) - if( icnv == icnv_fail_round ) then - - ! If the newton iteration fails, we go back - ! to restart the time-stepping loop with shorter sub-steps. - ! Therefore, we set the time elapsed (tm) to zero, - ! shorten the timstep (dtime) and re-initialize the water - ! contents to the starting amount. - - if(reset_on_fail) then - tm = 0._r8 - th_node(:) = th_node_init(:) - th_node_prev(:) = th_node_init(:) - cohort_hydr%iterh1 = 0 - else - tm = tm - dtime - th_node(:) = th_node_prev(:) - !* No need to update the th_node_prev, it is the - ! same since we are just re-starting the current - ! step - end if - nsteps = nsteps + 1 - dtime = dtime * dtime_rf - rlfx_plnt0 = rlfx_plnt_init*rlfx_plnt_shrink**real(nsteps,r8) - rlfx_soil0 = rlfx_soil_init*rlfx_soil_shrink**real(nsteps,r8) - rlfx_plnt = rlfx_plnt0 - rlfx_soil = rlfx_soil0 - nwtn_iter = 0 - cohort_hydr%iterh1 = cohort_hydr%iterh1 + 1 - cycle outerloop + ! 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 - else + ! 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 - ! On the last iteration, we temporarily lower the bar (if opted for) - ! and allow a pass if the residual is within 10x of the typical allowed residual - if ( allow_lenient_lastiter ) then - if ( nwtn_iter == max_newton_iter .and. residual_amax < 10*max_allowed_residual ) then - exit newtonloop - end if - end if - - if( sum(residual(:)) < max_allowed_residual .and. residual_amax < max_allowed_residual ) then - - ! We have succesffully found a solution - ! in this newton iteration. - exit newtonloop - else - ! Move ahead and calculate another solution - ! and continue the search. Residual isn't zero - ! but no reason not to continue searching - - ! Record that we performed a solve (this is total iterations) - cohort_hydr%iterh2 = cohort_hydr%iterh2 + 1 - - ! --------------------------------------------------------------------------- - ! 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. - ! --------------------------------------------------------------------------- - !cohort_hydr%iterh2 = cohort_hydr%iterh2 - - call DGESV(site_hydr%num_nodes,1,ajac,site_hydr%num_nodes,ipiv,residual,site_hydr%num_nodes,info) - - - if ( info < 0 ) then - write(fates_log(),*) 'illegal value generated in DGESV() linear' - write(fates_log(),*) 'system solver, see node: ',-info - 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 - - ! Update the previous water content state to be the current - ! th_node_prev(:) = th_node(:) - - ! 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 - j = node_layer(k) - if(abs(residual(k)) < dpsi_scap) then - psi_node(k) = psi_node(k) + residual(k) * rlfx_soil - else - psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_scap,residual(k)) - dpsi_scap*dpsi_scap/residual(k) - endif - th_node(k) = site_hydr%wrf_soil(j)%p%th_from_psi(psi_node(k)) - else - if(abs(residual(k)) < dpsi_pcap) then - psi_node(k) = psi_node(k) + residual(k) * rlfx_plnt - else - psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_pcap,residual(k)) - dpsi_pcap*dpsi_pcap/residual(k) - endif - th_node(k) = wrf_plant(pm_node(k),ft)%p%th_from_psi(psi_node(k)) - endif - - enddo - - ! Increase relaxation factors for next iteration - rlfx_plnt = min(1._r8,rlfx_plnt0 + & - (1.0-rlfx_plnt0)*real(nwtn_iter,r8)/real(max_newton_iter-3,r8)) - rlfx_soil = min(1._r8,rlfx_soil0 + & - (1.0-rlfx_soil0)*real(nwtn_iter,r8)/real(max_newton_iter-3,r8)) - - end if - end if + ! 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 - end do newtonloop + ! 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 - ! If we are here, that means we succesfully finished - ! a solve with minimal error. More substeps may be required though - ! ------------------------------------------------------------------------------ + ! 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 - ! If there are any sub-steps left, we need to update - ! the initial water content - th_node_prev(:) = th_node(:) + ! 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 - ! Reset relaxation factors - rlfx_plnt = rlfx_plnt0 - rlfx_soil = rlfx_soil0 + ! Start off assuming things will pass, then find numerous + ! ways to see if it failed + icnv = icnv_pass_round - end do outerloop + + ! 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 - if(cohort_hydr%iterh1>1._r8) then - write(fates_log(),*) "hydro solve info: i1: ",cohort_hydr%iterh1,"i2: ",cohort_hydr%iterh2 - end if + if(icnv == icnv_fail_round) goto 199 + + ! If the solution is balanced, none of the residuals + ! should be very large, and we can ignore another + ! solve attempt. + if( residual_amax < max_allowed_residual ) then + + goto 201 + + ! In this case, we still have a non-trivially small + ! residual, yet we have exceeded our iteration cap + ! Thus we set error flag to 1, which forces a time-step + ! shortening + elseif( nwtn_iter > max_newton_iter) then + + icnv = icnv_fail_round + goto 199 + + + ! 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 + + ! 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. + ! --------------------------------------------------------------------------- + - ! Save flux diagnostics - ! ------------------------------------------------------ - - sapflow = sapflow + q_flux(n_hypool_ag)*tmx + call DGESV(site_hydr%num_nodes,1,ajac,site_hydr%num_nodes,ipiv,residual,site_hydr%num_nodes,info) - 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)*tmx - enddo + + 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 - - ! Update the total change in water content - dth_node(:) = dth_node(:) + (th_node(:) - th_node_init(:)) +! 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 + + + + + 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 + + + ! If we have reached this point, we have iterated to + ! a stable solution (where residual mass balance = 0) + ! It is possible that we have used a sub-step though, + ! and need to continue the iteration. + +201 continue + + ! Save the number of substeps needed + cohort_hydr%iterh1 = cohort_hydr%iterh1 + 1 + + ! Save the max number of Newton iterations needed + cohort_hydr%iterh2 = max(cohort_hydr%iterh2,real(nwtn_iter)) + + print*,'Completed a newton solve' + print*,psi_node(:) + stop + + ! Save flux diagnostics + ! ------------------------------------------------------ + + sapflow = sapflow + q_flux(n_hypool_ag)*dtime + + 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 + + + ! If there are any sub-steps left, we need to update + ! the initial water content + th_node_init(:) = th_node(:) + + end do outerloop + + + + ! If we have made it here, we have successfully integrated + ! the water content. Transfer this from scratch space + ! into the cohort memory structures for plant compartments, + ! and increment the site-level change in soil moistures + + ! Update state variables in plant compartments cohort_hydr%th_ag(1:n_hypool_ag) = cohort_hydr%th_ag(1:n_hypool_ag) + dth_node(1:n_hypool_ag) cohort_hydr%th_troot = cohort_hydr%th_troot + dth_node(n_hypool_ag+1) @@ -5056,7 +5248,7 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & inode = n_hypool_ag+n_hypool_troot do j = 1,site_hydr%nlevrhiz - do k = 1, 1 + nshell + 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) @@ -5075,9 +5267,9 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & w_tot_end = sum(th_node(:)*v_node(:))*denh2o ! Mass error (flux - change) [kg/m2] - wb_err_plant = (qtop*tmx)-(w_tot_beg-w_tot_end) - + wb_err_plant = (qtop*dtime)-(w_tot_beg-w_tot_end) + end associate return diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 0a91c6a2ee..b399339c24 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -199,6 +199,16 @@ module EDPftvarcon real(r8), allocatable :: hydr_avuln_gs(:) ! shape parameter for stomatal control of water vapor exiting leaf real(r8), allocatable :: hydr_p50_gs(:) ! water potential at 50% loss of stomatal conductance + ! Junyan added the PFT specific parameters for hydru, though some of them are more like allometry parameters + real(r8), allocatable :: allom_dbh_max(:) + real(r8), allocatable :: allom_dbh_0(:) + real(r8), allocatable :: allom_zfr_max(:) + real(r8), allocatable :: allom_zfr_0(:) + real(r8), allocatable :: allom_frk(:) + +! end of Junyan's addition + + ! PFT x Organ Dimension (organs are: 1=leaf, 2=stem, 3=transporting root, 4=absorbing root) real(r8), allocatable :: hydr_avuln_node(:,:) ! xylem vulernability curve shape parameter real(r8), allocatable :: hydr_p50_node(:,:) ! xylem water potential at 50% conductivity loss (MPa) @@ -424,6 +434,37 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) +! Junyan added to register following parameters, May 29, 2020 +! real(r8), allocatable :: allom_dbh_max(:) +! real(r8), allocatable :: allom_dbh_0(:) +! real(r8), allocatable :: allom_zfr_max(:) +! real(r8), allocatable :: allom_zfr_0(:) +! real(r8), allocatable :: allom_frk(:) + + name = 'fates_allom_dbh_max' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_dbh_0' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_zfr_max' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_zfr_0' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_frk' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + +! end of Junyan's addition + + name = 'fates_hydr_p_taper' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -757,6 +798,31 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%allom_frbstor_repro) +! Junyan added below May 29, 2020 + name = 'fates_allom_dbh_max' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%allom_dbh_max) + + name = 'fates_allom_dbh_0' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%allom_dbh_0) + + name = 'fates_allom_zfr_max' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%allom_zfr_max) + + name = 'fates_allom_zfr_0' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%allom_zfr_0) + + name = 'fates_allom_frk' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%allom_frk) + + +! end of Junyan's addition + + name = 'fates_hydr_p_taper' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_p_taper) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 1f813c4b4e..44a7865cdf 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -121,6 +121,21 @@ variables: fates_allom_stmode:units = "index" ; fates_allom_stmode:long_name = "storage allometry function index." ; fates_allom_stmode:possible_values = "1: target storage proportional to trimmed maximum leaf biomass." ; + double fates_allom_dbh_max(fates_pft) ; + fates_allom_dbh_max:units = "cm" ; + fates_allom_dbh_max:long_name = "maximum possible dbh of a PFT" ; + double fates_allom_dbh_0(fates_pft) ; + fates_allom_dbh_0:units = "cm" ; + fates_allom_dbh_0:long_name = "dbh of the smallest cohort of a PFT " ; + double fates_allom_zfr_max(fates_pft) ; + fates_allom_zfr_max:units = "m" ; + fates_allom_zfr_max:long_name = "maximum rooting depth of a PFT" ; + double fates_allom_zfr_0(fates_pft) ; + fates_allom_zfr_0:units = "m" ; + fates_allom_zfr_0:long_name = "rooting depth of sappling of recuitment" ; + double fates_allom_frk(fates_pft) ; + fates_allom_frk:units = "unitless" ; + fates_allom_frk:long_name = "scale coefficient of logistic cohort rooting depth model" ; double fates_branch_turnover(fates_pft) ; fates_branch_turnover:units = "yr" ; fates_branch_turnover:long_name = "turnover time of branches" ; @@ -796,6 +811,16 @@ data: fates_allom_stmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + fates_allom_dbh_max = 100, 100, 100, 100, 100, 100, 2, 2, 2, 2, 2, 2 ; + + fates_allom_dbh_0 = 1, 1, 1, 2.5, 2.5, 2.5, 1, 1, 1, 1, 1, 1 ; + + fates_allom_zfr_max = 9, 9, 9, 9, 8, 8, 1, 1, 1, 1, 1, 1 ; + + fates_allom_zfr_0 = 1, 1, 1, 1, 1, 1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 ; + + fates_allom_frk = 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10 ; + fates_branch_turnover = 150, 150, 150, 150, 150, 150, 150, 150, 150, 0, 0, 0 ; fates_c2b = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 ; From 4d951e1c3ad067c953919acd6fe5d547a8aa1c3f Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Wed, 24 Mar 2021 21:05:36 -0700 Subject: [PATCH 219/578] Update FatesPlantHydraulicsMod.F90 --- biogeophys/FatesPlantHydraulicsMod.F90 | 953 +++++++++++++------------ 1 file changed, 484 insertions(+), 469 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 6c9b4e9bb4..551f285717 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -55,12 +55,12 @@ module FatesPlantHydraulicsMod use EDTypesMod , only : AREA ! representative land unit, currently a constant as 100m x 100m use EDTypesMod , only : leaves_on - use FatesInterfaceMod , only : bc_in_type - use FatesInterfaceMod , only : bc_out_type - use FatesInterfaceMod , only : hlm_use_planthydro - use FatesInterfaceMod , only : hlm_ipedof - use FatesInterfaceMod , only : numpft - use FatesInterfaceMod , only : nlevsclass + use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : bc_out_type + use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_ipedof + use FatesInterfaceTypesMod , only : numpft + use FatesInterfaceTypesMod , only : nlevsclass use FatesAllometryMod, only : bleaf use FatesAllometryMod, only : bsap_allom @@ -98,6 +98,7 @@ module FatesPlantHydraulicsMod use clm_time_manager , only : get_step_size, get_nstep use EDPftvarcon, only : EDPftvarcon_inst + use PRTParametersMod, only : prt_params use FatesHydroWTFMod, only : wrf_arr_type use FatesHydroWTFMod, only : wkf_arr_type @@ -108,7 +109,7 @@ module FatesPlantHydraulicsMod ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg use shr_infnan_mod , only : isnan => shr_infnan_isnan - use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + implicit none @@ -163,13 +164,22 @@ module FatesPlantHydraulicsMod ! proceeds over the entire time-step. + ! These switches are for developers who which to understand if there simulations + ! are ever entering regimes where water contents go negative (yes physically impossible) + ! or water pressures exceed that at saturation (maybe, maybe not likely) + ! These situations are possible/likely due to the nature of the constant flux boundary condition + ! of transpiration, due to the loosely-coupled nature of the hydro-land-energy-photosynthesis + ! system + + logical, parameter :: trap_neg_wc = .false. + logical, parameter :: trap_supersat_psi = .false. real(r8), parameter :: thsat_buff = 0.001_r8 ! Ensure that this amount of buffer ! is left between soil moisture and saturation [m3/m3] ! (if we are going to help purge super-saturation) - logical,parameter :: debug = .true. ! flag to report warning in hydro - logical,public, parameter :: JD_debug = .true. ! Junyan added to debug my modifications + logical,parameter :: debug = .false. ! flag to report warning in hydro + logical,public, parameter :: JD_debug = .false. ! Junyan added to debug my modifications character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -462,11 +472,16 @@ subroutine InitPlantHydStates(site, cohort) ! for transporting root node, match the lowest total potential ! in absorbing roots integer, parameter :: init_mode = 2 - + class(wrf_arr_type),pointer :: wrfa,wrft + class(wkf_arr_type),pointer :: wkfa,wkft site_hydr => site%si_hydr cohort_hydr => cohort%co_hydr ft = cohort%pft + wrfa => wrf_plant(aroot_p_media,ft) + wkfa => wkf_plant(aroot_p_media,ft) + wrft => wrf_plant(troot_p_media,ft) + wkft => wkf_plant(troot_p_media,ft) ! Set abosrbing root @@ -483,8 +498,8 @@ subroutine InitPlantHydStates(site, cohort) ! 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)) + cohort_hydr%th_aroot(j) = wrfa%p%th_from_psi(cohort_hydr%psi_aroot(j)) + cohort_hydr%ftc_aroot(j) = wkfa%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) else cohort_hydr%psi_aroot(j) = psi_aroot_init cohort_hydr%th_aroot(j) = 0 @@ -497,8 +512,8 @@ subroutine InitPlantHydStates(site, cohort) 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)) + cohort_hydr%th_aroot(j) = wrfa%p%th_from_psi(cohort_hydr%psi_aroot(j)) + cohort_hydr%ftc_aroot(j) = wkfa%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) end do end if @@ -517,8 +532,8 @@ subroutine InitPlantHydStates(site, cohort) 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) + cohort_hydr%th_troot = wrfa%p%th_from_psi(cohort_hydr%psi_troot) + cohort_hydr%ftc_troot = wkfa%p%ftc_from_psi(cohort_hydr%psi_troot) ! working our way up a tree, assigning water potentials that are in @@ -664,8 +679,8 @@ subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) ! in special case where n_hypool_leaf = 1, the node height of the canopy ! water pool is 1/2 the distance from the bottom of the canopy to the top of the tree - roota = EDPftvarcon_inst%roota_par(ft) - rootb = EDPftvarcon_inst%rootb_par(ft) + roota = prt_params%fnrt_prof_a(ft) + rootb = prt_params%fnrt_prof_b(ft) nlevrhiz = csite_hydr%nlevrhiz ! call CrownDepth(plant_height,crown_depth) @@ -844,8 +859,8 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) 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 = prt_params%fnrt_prof_a(ft) + rootb = prt_params%fnrt_prof_b(ft) ! added by Junyan May 29, 2020 dbh_max = EDPftvarcon_inst%allom_dbh_max(ft) @@ -866,10 +881,10 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! 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 + sla = prt_params%slatop(ft) * cm2_per_m2 ! empirical regression data from leaves at Caxiuana (~ 8 spp) - denleaf = -2.3231_r8*sla/EDPftvarcon_inst%c2b(ft) + 781.899_r8 + denleaf = -2.3231_r8*sla/prt_params%c2b(ft) + 781.899_r8 ! Leaf volumes ! Note: Leaf volumes of zero is problematic for two reasons. Zero volumes create @@ -895,7 +910,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) 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) + prt_params%c2b(ft) / denleaf/ real(n_hypool_leaf,r8) end if ! Step sapwood volume @@ -915,7 +930,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! alternative cross section calculation ! a_sapwood = a_leaf_tot / ( 0.001_r8 + 0.025_r8 * ccohort%hite ) * 1.e-4_r8 - crown_depth = EDPftvarcon_inst%crown(ft) * ccohort%hite + crown_depth = prt_params%crown(ft) * ccohort%hite z_stem = ccohort%hite - crown_depth * 0.2_r8 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 @@ -925,17 +940,17 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! leaf, fine root) biomass then subtract out the fine root biomass to get ! coarse (transporting) root biomass - woody_bg_c = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(ft)) * (sapw_c + struct_c) + woody_bg_c = (1.0_r8-prt_params%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) + v_troot = woody_bg_c * prt_params%c2b(ft) / & + (prt_params%wood_density(ft)*kg_per_g*cm3_per_m3) ! Estimate absorbing root total length (all layers) ! SRL is in m/g ! [m] = [kgC]*1000[g/kg]*[kg/kgC]*[m/g] ! ------------------------------------------------------------------------------ - l_aroot_tot = fnrt_c*g_per_kg*EDPftvarcon_inst%c2b(ft)*EDPftvarcon_inst%hydr_srl(ft) + l_aroot_tot = fnrt_c*g_per_kg*prt_params%c2b(ft)*EDPftvarcon_inst%hydr_srl(ft) ! Estimate absorbing root volume (all layers) @@ -1634,8 +1649,8 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) ! recruitment water uptake if(ccohort_hydr%is_newly_recruited) then recruitflag = .true. - roota = EDPftvarcon_inst%roota_par(ft) - rootb = EDPftvarcon_inst%rootb_par(ft) + roota = prt_params%fnrt_prof_a(ft) + rootb = prt_params%fnrt_prof_b(ft) recruitw = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & ccohort_hydr%th_troot*ccohort_hydr%v_troot + & sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & @@ -1702,9 +1717,10 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) 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) + roota = prt_params%fnrt_prof_a(ccohort%pft) + rootb = prt_params%fnrt_prof_b(ccohort%pft) + ! roota = EDPftvarcon_inst%roota_par(ccohort%pft) + ! rootb = EDPftvarcon_inst%rootb_par(ccohort%pft) csite_hydr => csite%si_hydr ccohort_hydr =>ccohort%co_hydr @@ -2523,7 +2539,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) if(use_2d_hydrosolve) then - call MatSolve2D(site_hydr,ccohort,ccohort_hydr, & + call MatSolve2D(bc_in(s),site_hydr,ccohort,ccohort_hydr, & dtime,qflx_tran_veg_indiv, & sapflow,rootuptake(1:nlevrhiz),wb_err_plant,dwat_plant, & dth_layershell_col) @@ -2857,15 +2873,16 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr) 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) :: taper_exponent !1._r8/3._r8 , uncomment to use fixed value from 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) - + roota = prt_params%fnrt_prof_a(pft) + rootb = prt_params%fnrt_prof_b(pft) + taper_exponent = EDPftvarcon_inst%hydr_p_taper(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) @@ -4557,8 +4574,8 @@ subroutine Hydraulics_Tridiagonal(a, b, c, r, u, ierr) end subroutine Hydraulics_Tridiagonal ! ===================================================================================== - - subroutine MatSolve2D(site_hydr,cohort,cohort_hydr, & + +subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & tmx,qtop, & sapflow,rootuptake,wb_err_plant , dwat_plant, & dth_layershell_site) @@ -4596,6 +4613,7 @@ subroutine MatSolve2D(site_hydr,cohort,cohort_hydr, & ! ARGUMENTS: ! ----------------------------------------------------------------------------------- + type(bc_in_type),intent(in) :: bc_in 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 @@ -4614,6 +4632,7 @@ subroutine MatSolve2D(site_hydr,cohort,cohort_hydr, & integer :: i ! generic index (sometimes node index) integer :: inode ! node index integer :: k ! generic node index + integer :: j_bc ! layer of bc 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 @@ -4645,12 +4664,14 @@ subroutine MatSolve2D(site_hydr,cohort,cohort_hydr, & real(r8) :: rlfx_soil ! Pressure update reduction factor for soil compartments real(r8) :: rlfx_plnt ! Pressure update reduction factor for plant comparmtents + real(r8) :: rlfx_soil0 ! Base relaxation factor for the current iteration round + real(r8) :: rlfx_plnt0 ! "" 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] - + logical :: continue_search 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 @@ -4677,32 +4698,58 @@ subroutine MatSolve2D(site_hydr,cohort,cohort_hydr, & ! potentially reducing relaxation factors integer, parameter :: max_newton_rounds = 10 + ! dtime will shrink at the following rate (halving) [s]: + ! 1800,900,450,225,112.5,56.25,28.125,14.0625,7.03125,3.515625, + ! 1.7578125,0.87890625,0.439453125,0.2197265625,0.10986328125, + ! 0.054931640625,0.0274658203125,0.01373291015625,0.006866455078125, + ! 0.0034332275390625,0.00171661376953125, + + ! Maximum number of Newton iterations in each round - integer, parameter :: max_newton_iter = 200 + integer, parameter :: max_newton_iter = 100 ! 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 + integer, parameter :: icnv_pass_round = 2 ! 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 - + real(r8), parameter :: dtime_rf = 0.5_r8 + + ! These are the initial relaxation factors at the beginning + ! of the large time-step. These may or may not shrink on + ! subsequent rounds, and may or may not grow over subsequent + ! iterations within rounds + real(r8), parameter :: rlfx_soil_init = 1.0 ! Initial Pressure update + ! reduction factor for soil compartments + real(r8), parameter :: rlfx_plnt_init = 1.0 ! Initial Pressure update + ! reduction factor for plant comparmtents + real(r8), parameter :: dpsi_scap = 0.2 ! Changes in psi (for soil) larger than this + ! will be subject to a capping routine + real(r8), parameter :: dpsi_pcap = 0.3 ! Change sin psi (for plants) larger than this + ! will be subject to a capping routine + real(r8), parameter :: rlfx_plnt_shrink = 1.0 ! Shrink the starting plant relaxtion factor + ! by this multipliler each round + real(r8), parameter :: rlfx_soil_shrink = 1.0 ! Shrink the starting soil relaxtion factor + ! by this multipliler each round + logical, parameter :: reset_on_fail = .false. ! If a round of Newton iterations is unable + ! to find a solution, you can either reset + ! to the beginning of the large timestep (true), or + ! to the beginning of the current substep (false) + + logical, parameter :: allow_lenient_lastiter = .true. ! If this is true, when the newton iteration + ! reaches its last allowed attempt, the + ! error tolerance will be increased (the bar lowered) by 10x + + associate(conn_up => site_hydr%conn_up, & conn_dn => site_hydr%conn_dn, & kmax_up => site_hydr%kmax_up, & @@ -4712,6 +4759,7 @@ subroutine MatSolve2D(site_hydr,cohort,cohort_hydr, & ajac => site_hydr%ajac, & ipiv => site_hydr%ipiv, & th_node => site_hydr%th_node, & + th_node_prev => site_hydr%th_node_prev, & th_node_init => site_hydr%th_node_init, & psi_node => site_hydr%psi_node, & pm_node => site_hydr%pm_node, & @@ -4775,11 +4823,8 @@ subroutine MatSolve2D(site_hydr,cohort,cohort_hydr, & ! folume that this plant's rhizosphere accounts forPath is across the upper an lower rhizosphere comparment ! on each side of the nodes. Since there is no flow across the outer ! node to the edge, we ignore that last half compartment - - ! Junyan add the if statement to avoid 0 root length of a layer - if (site_hydr%l_aroot_layer(j)>0._r8) then - aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) - + aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) + do k = 1, n_hypool_aroot + nshell i = i + 1 if (k==1) then @@ -4794,11 +4839,10 @@ subroutine MatSolve2D(site_hydr,cohort,cohort_hydr, & th_node_init(i) = site_hydr%h2osoi_liqvol_shell(j,kshell) end if enddo - end if ! Junyan addition + enddo - - + ! Total water mass in the plant at the beginning of this solve [kg h2o] w_tot_beg = sum(th_node_init(:)*v_node(:))*denh2o @@ -4806,439 +4850,410 @@ subroutine MatSolve2D(site_hydr,cohort,cohort_hydr, & ! Initialize variables and flags that track ! the progress of the solve - tm = 0 - nsteps = 0 - - outerloop: do while(tm < tmx) - - ! If we are here, then we either are starting the solve, - ! or, we just completed a solve but did not fully integrate - ! the time. Lets update the time-step to be the remainder - ! of the step. - dtime = min(tmx*0.01,tmx-tm) + tm = 0 + nsteps = 0 + th_node_prev(:) = th_node_init(:) + th_node(:) = th_node_init(:) + dtime = tmx + rlfx_plnt0 = rlfx_plnt_init + rlfx_soil0 = rlfx_soil_init + rlfx_plnt = rlfx_plnt0 + rlfx_soil = rlfx_soil0 + + outerloop: do while( tm < tmx ) - ! 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(:) - + ! The solve may reduce the time-step, the shorter + ! time-steps may not be perfectly divisible into + ! the remaining time. If so, then make sure we + ! don't overshoot + + dtime = min(dtime,tmx-tm) + + ! Advance time forward + tm = tm + dtime + ! If we have not exceeded our max number + ! of retrying rounds of Newton iterations, reduce + ! time and try a new round - 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)) - - 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 + if( nsteps > max_newton_rounds ) then + + ! Complete failure to converge even with re-trying + ! iterations with smaller timesteps + + 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.' + write(fates_log(),*) 'pft: ',ft,' dbh: ',cohort%dbh + call endrun(msg=errMsg(sourcefile, __LINE__)) + + endif - ! 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 + ! This is the newton search loop - - ! 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 - - if(icnv == icnv_fail_round) goto 199 - - ! If the solution is balanced, none of the residuals - ! should be very large, and we can ignore another - ! solve attempt. - if( residual_amax < max_allowed_residual ) then - - goto 201 + continue_search = .true. + nwtn_iter = 0 + newtonloop: do while(continue_search) - ! 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 + nwtn_iter = nwtn_iter + 1 - icnv = icnv_fail_round - goto 199 + ! 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) + denh2o*v_node(k)*(th_node(k) - th_node_prev(k))/dtime + + 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)) + + ! 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)) + + 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 + j = node_layer(k) + 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 + + ! 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) + ! This should be used for the down-stream on thr second index) + 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 mass balance + ajac(id_dn,id_dn) = ajac(id_dn,id_dn) + dqflx_dpsi_dn + + ! Down-stream node's contribution to the up-stream node's mass balance + ajac(id_up,id_dn) = ajac(id_up,id_dn) - dqflx_dpsi_dn + + ! Up-stream node's contribution to the down-stream node's mass balance + ajac(id_dn,id_up) = ajac(id_dn,id_up) + dqflx_dpsi_up + + ! Up-stream node's contribution to the up-stream node's mass balance + ajac(id_up,id_up) = ajac(id_up,id_up) - dqflx_dpsi_up - ! 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 - ! 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. - ! --------------------------------------------------------------------------- + enddo - call DGESV(site_hydr%num_nodes,1,ajac,site_hydr%num_nodes,ipiv,residual,site_hydr%num_nodes,info) - - - if ( info < 0 ) then - write(fates_log(),*) 'illegal value generated in DGESV() linear' - write(fates_log(),*) 'system solver, see node: ',-info - 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 + ! 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 + + + ! 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 + if ( nwtn_iter > max_newton_iter) then + icnv = icnv_fail_round + write(fates_log(),*) 'Newton hydraulics solve failed',residual_amax,nsd,tm + endif -! stop - - endif - -199 continue - - if( icnv == icnv_fail_round ) then + ! Three scenarios: + ! 1) the residual is 0, everything is great, leave iteration loop + ! 2) the residual is not 0, but we have not taken too many steps + ! and the matrix solve did not fail. Perform an inversion and keep + ! searching. + ! 3) the residual is not 0, and either + ! we have taken too many newton steps or the solver won't return + ! a real solution. + ! Shorten time-step, reset time to 0, reset relaxation factors + ! and try a new round of newton (if not exceeded) - 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 + if( icnv == icnv_fail_round ) then + + ! If the newton iteration fails, we go back + ! to restart the time-stepping loop with shorter sub-steps. + ! Therefore, we set the time elapsed (tm) to zero, + ! shorten the timstep (dtime) and re-initialize the water + ! contents to the starting amount. + + if(reset_on_fail) then + tm = 0._r8 + th_node(:) = th_node_init(:) + th_node_prev(:) = th_node_init(:) + cohort_hydr%iterh1 = 0 + else + tm = tm - dtime + th_node(:) = th_node_prev(:) + !* No need to update the th_node_prev, it is the + ! same since we are just re-starting the current + ! step + end if + nsteps = nsteps + 1 + dtime = dtime * dtime_rf + rlfx_plnt0 = rlfx_plnt_init*rlfx_plnt_shrink**real(nsteps,r8) + rlfx_soil0 = rlfx_soil_init*rlfx_soil_shrink**real(nsteps,r8) + rlfx_plnt = rlfx_plnt0 + rlfx_soil = rlfx_soil0 + nwtn_iter = 0 + cohort_hydr%iterh1 = cohort_hydr%iterh1 + 1 + cycle outerloop - tm = tm - dtime - nsteps = nsteps + 1 + else - 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 + ! On the last iteration, we temporarily lower the bar (if opted for) + ! and allow a pass if the residual is within 10x of the typical allowed residual + if ( allow_lenient_lastiter ) then + if ( nwtn_iter == max_newton_iter .and. residual_amax < 10*max_allowed_residual ) then + exit newtonloop + end if + end if + + if( sum(residual(:)) < max_allowed_residual .and. residual_amax < max_allowed_residual ) then + + ! We have succesffully found a solution + ! in this newton iteration. + exit newtonloop + else + ! Move ahead and calculate another solution + ! and continue the search. Residual isn't zero + ! but no reason not to continue searching + + ! Record that we performed a solve (this is total iterations) + cohort_hydr%iterh2 = cohort_hydr%iterh2 + 1 + + ! --------------------------------------------------------------------------- + ! 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. + ! --------------------------------------------------------------------------- + !cohort_hydr%iterh2 = cohort_hydr%iterh2 + + call DGESV(site_hydr%num_nodes,1,ajac,site_hydr%num_nodes,ipiv,residual,site_hydr%num_nodes,info) + + + if ( info < 0 ) then + write(fates_log(),*) 'illegal value generated in DGESV() linear' + write(fates_log(),*) 'system solver, see node: ',-info + 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 + + ! Update the previous water content state to be the current + ! th_node_prev(:) = th_node(:) + + ! 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 + j = node_layer(k) + if(abs(residual(k)) < dpsi_scap) then + psi_node(k) = psi_node(k) + residual(k) * rlfx_soil + else + psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_scap,residual(k)) - dpsi_scap*dpsi_scap/residual(k) + endif + th_node(k) = site_hydr%wrf_soil(j)%p%th_from_psi(psi_node(k)) + else + if(abs(residual(k)) < dpsi_pcap) then + psi_node(k) = psi_node(k) + residual(k) * rlfx_plnt + else + psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_pcap,residual(k)) - dpsi_pcap*dpsi_pcap/residual(k) + endif + th_node(k) = wrf_plant(pm_node(k),ft)%p%th_from_psi(psi_node(k)) + endif + + enddo + + ! Increase relaxation factors for next iteration + rlfx_plnt = min(1._r8,rlfx_plnt0 + & + (1.0-rlfx_plnt0)*real(nwtn_iter,r8)/real(max_newton_iter-3,r8)) + rlfx_soil = min(1._r8,rlfx_soil0 + & + (1.0-rlfx_soil0)*real(nwtn_iter,r8)/real(max_newton_iter-3,r8)) + + end if + end if - ! 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 do newtonloop - + ! If we are here, that means we succesfully finished + ! a solve with minimal error. More substeps may be required though + ! ------------------------------------------------------------------------------ + ! If there are any sub-steps left, we need to update + ! the initial water content + th_node_prev(:) = th_node(:) - 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 + ! Reset relaxation factors + rlfx_plnt = rlfx_plnt0 + rlfx_soil = rlfx_soil0 - ! If we have reached this point, we have iterated to - ! a stable solution (where residual mass balance = 0) - ! It is possible that we have used a sub-step though, - ! and need to continue the iteration. - -201 continue - - ! Save the number of substeps needed - cohort_hydr%iterh1 = cohort_hydr%iterh1 + 1 - - ! Save the max number of Newton iterations needed - cohort_hydr%iterh2 = max(cohort_hydr%iterh2,real(nwtn_iter)) - - print*,'Completed a newton solve' - print*,psi_node(:) - stop - - ! Save flux diagnostics - ! ------------------------------------------------------ - - sapflow = sapflow + q_flux(n_hypool_ag)*dtime - - 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 - + end do outerloop - ! If there are any sub-steps left, we need to update - ! the initial water content - th_node_init(:) = th_node(:) - - end do outerloop + if(cohort_hydr%iterh1>1._r8) then + write(fates_log(),*) "hydro solve info: i1: ",cohort_hydr%iterh1,"i2: ",cohort_hydr%iterh2 + end if + ! Save flux diagnostics + ! ------------------------------------------------------ + sapflow = sapflow + q_flux(n_hypool_ag)*tmx - ! 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 + 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)*tmx + enddo + + + ! Update the total change in water content + dth_node(:) = dth_node(:) + (th_node(:) - th_node_init(:)) - ! 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) @@ -5248,7 +5263,7 @@ subroutine MatSolve2D(site_hydr,cohort,cohort_hydr, & inode = n_hypool_ag+n_hypool_troot do j = 1,site_hydr%nlevrhiz - do k = 1, nshell+1 + do k = 1, 1 + nshell inode = inode + 1 if(k==1) then cohort_hydr%th_aroot(j) = cohort_hydr%th_aroot(j)+dth_node(inode) @@ -5267,9 +5282,9 @@ subroutine MatSolve2D(site_hydr,cohort,cohort_hydr, & 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) + wb_err_plant = (qtop*tmx)-(w_tot_beg-w_tot_end) + - end associate return From fc1e17970368bf30f3d7d79630c1f92d853e24c6 Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Wed, 24 Mar 2021 21:07:48 -0700 Subject: [PATCH 220/578] Update FatesPlantHydraulicsMod.F90 Changes to fit into the latest fates version Mar. 24th. 2021 --- biogeophys/FatesPlantHydraulicsMod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 551f285717..db7a3e0d82 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -4796,6 +4796,7 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ! 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 From ddf387085cabc5912ec9ea53914fa188fae0e474 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 25 Mar 2021 09:49:26 -0400 Subject: [PATCH 221/578] comment fixes --- biogeochem/EDCanopyStructureMod.F90 | 7 +++---- biogeophys/FatesPlantHydraulicsMod.F90 | 3 ++- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 64ca841ade..a8b8d6aa5e 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -2010,8 +2010,8 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! If running hydro, perform a final check to make sure that we ! have conserved water. Since this is the very end of the dynamics - ! cycle, no water should had been added or lost to the site, however - ! with growth and death, we may had shuffled it around. + ! cycle. No water should had been added or lost to the site during dynamics. + ! With growth and death, we may have shuffled it around. ! For recruitment, we initialized their water, but flagged them ! to not be included in the site level balance yet, for they ! will demand the water for their initialization on the first hydraulics time-step @@ -2022,8 +2022,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) end do - ! If hydraulics is turned on, update the amount of water bound in vegetation - ! And also perform a check to see if we have conserved total water (we should have) + ! This call is purely for diagnostics and history variables if (hlm_use_planthydro.eq.itrue) then call RecruitWaterStorage(nsites,sites,bc_out) end if diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 3436646941..d9e67be564 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -1508,7 +1508,8 @@ subroutine UpdateH2OVeg(csite,bc_out,prev_site_h2o,icall) ! 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) + ! growturn_err is a term to accomodate error in growth or + ! turnover. need to be improved for future(CX) bc_out%plant_stored_h2o_si = csite_hydr%h2oveg + csite_hydr%h2oveg_dead - & csite_hydr%h2oveg_growturn_err - & csite_hydr%h2oveg_hydro_err From b2e44e262a75077ac9495219571c1a07b0083a12 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 25 Mar 2021 11:21:35 -0400 Subject: [PATCH 222/578] Changed the instantiation of the prt_global to be a class pointer instead of a type, this is because its target is a class. --- parteh/PRTGenericMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parteh/PRTGenericMod.F90 b/parteh/PRTGenericMod.F90 index 9c6f9db2e2..8c348cad50 100644 --- a/parteh/PRTGenericMod.F90 +++ b/parteh/PRTGenericMod.F90 @@ -385,7 +385,7 @@ module PRTGenericMod end type prt_global_type - type(prt_global_type),pointer,public :: prt_global + class(prt_global_type),pointer,public :: prt_global ! Make necessary procedures public public :: GetCoordVal From 12bd879895fe106594ae01eee642f97513e20fca Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 25 Mar 2021 14:35:00 -0600 Subject: [PATCH 223/578] removed min_lai value --- biogeochem/EDCanopyStructureMod.F90 | 5 ----- 1 file changed, 5 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index bd34ef9bfc..16911e163a 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -2040,9 +2040,6 @@ function calc_areaindex(cpatch,ai_type) result(ai) integer :: cl,ft real(r8) :: ai - ! TODO: THIS MIN LAI IS AN ARTIFACT FROM TESTING LONG-AGO AND SHOULD BE REMOVED - ! THIS HAS BEEN KEPT THUS FAR TO MAINTAIN B4B IN TESTING OTHER COMMITS - real(r8),parameter :: ai_min = 0.1_r8 real(r8),pointer :: ai_profile ai = 0._r8 @@ -2080,8 +2077,6 @@ function calc_areaindex(cpatch,ai_type) result(ai) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - ai = max(ai_min,ai) - return end function calc_areaindex From 167fe87be953a3713ad010a4a27f52e2c60097ea Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Thu, 25 Mar 2021 15:36:14 -0700 Subject: [PATCH 224/578] Update FatesPlantHydraulicsMod.F90 --- biogeophys/FatesPlantHydraulicsMod.F90 | 203 +++++++++++++++---------- 1 file changed, 119 insertions(+), 84 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index db7a3e0d82..4cc2016e04 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -490,7 +490,7 @@ subroutine InitPlantHydStates(site, cohort) ! h_aroot_mean = 0._r8 do j=1, site_hydr%nlevrhiz - ! Junyan added the if statement + ! Checking apperance of roots. Only proceed if there is roots in that layer if(cohort_hydr%l_aroot_layer(j) > 0) then ! 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)) @@ -503,7 +503,7 @@ subroutine InitPlantHydStates(site, cohort) else cohort_hydr%psi_aroot(j) = psi_aroot_init cohort_hydr%th_aroot(j) = 0 - end if ! end Junyan addition July 24th. 2020 + end if ! checking having roots end do else @@ -532,8 +532,8 @@ subroutine InitPlantHydStates(site, cohort) cohort_hydr%psi_troot = h_aroot_mean - & mpa_per_pa*denh2o*grav_earth*cohort_hydr%z_node_troot - dh_dz - cohort_hydr%th_troot = wrfa%p%th_from_psi(cohort_hydr%psi_troot) - cohort_hydr%ftc_troot = wkfa%p%ftc_from_psi(cohort_hydr%psi_troot) + cohort_hydr%th_troot = wrft%p%th_from_psi(cohort_hydr%psi_troot) + cohort_hydr%ftc_troot = wkft%p%ftc_from_psi(cohort_hydr%psi_troot) ! working our way up a tree, assigning water potentials that are in @@ -931,7 +931,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! a_sapwood = a_leaf_tot / ( 0.001_r8 + 0.025_r8 * ccohort%hite ) * 1.e-4_r8 crown_depth = prt_params%crown(ft) * ccohort%hite - z_stem = ccohort%hite - crown_depth * 0.2_r8 + 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 @@ -984,7 +984,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j)-site_hydr%dz_rhiz(j),z_fr)) if(JD_debug)then - write(fates_log(),*) 'check rooting depth of cohort - Junyan, line 972' + write(fates_log(),*) 'check rooting depth of cohort - Junyan, line 987' write(fates_log(),*) 'dbh: ',ccohort%dbh,' sice class: ',ccohort%size_class write(fates_log(),*) 'site_hydr%dz_rhiz(j) is: ', site_hydr%dz_rhiz(j) write(fates_log(),*) 'z_max cohort: ',z_fr @@ -997,7 +997,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ccohort_hydr%v_aroot_layer(j) = rootfr*(v_aroot_tot + t2aroot_vol_donate_frac*v_troot) end do - ! end of Junyan's modification + return end subroutine UpdatePlantHydrLenVol @@ -1062,7 +1062,7 @@ subroutine UpdateSizeDepPlantHydStates(currentSite,ccohort) ccohort_hydr%errh2o_growturn_aroot = 0._r8 do j=1,currentSite%si_hydr%nlevrhiz - ! check v_aroot >0, Junyan addition + ! check v_aroot >0 if (ccohort_hydr%v_aroot_layer(j) > 0) then th_aroot_uncorr(j) = ccohort_hydr%th_aroot(j) * & ccohort_hydr%v_aroot_layer_init(j)/ccohort_hydr%v_aroot_layer(j) @@ -1071,7 +1071,7 @@ subroutine UpdateSizeDepPlantHydStates(currentSite,ccohort) denh2o*cCohort%n*AREA_INV*(ccohort_hydr%th_aroot(j)-th_aroot_uncorr(j))*ccohort_hydr%v_aroot_layer(j) else - endif ! end Junyan addition + endif ! end checking v_arrot enddo ! Storing mass balance error @@ -1402,12 +1402,14 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) 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)) - ! Junyan added log + + site_hydr%h2osoi_liqvol_shell(j,1:nshell) = h2osoi_liqvol + site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j_bc) + if (JD_debug) then - write(fates_log(),*) 'line 1368, initial shell water content' + write(fates_log(),*) 'line 1410, initial shell water content' write(fates_log(),*) 'water content:', h2osoi_liqvol - site_hydr%h2osoi_liqvol_shell(j,1:nshell) = h2osoi_liqvol - site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j_bc) + endif end do @@ -1546,12 +1548,12 @@ subroutine UpdateH2OVeg(nsites,sites,bc_out) 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 - ! Junyan added check for nan value + ! check for nan value do ily = 1,csite_hydr%nlevrhiz if(ccohort_hydr%th_aroot(ily)/=ccohort_hydr%th_aroot(ily)) then ccohort_hydr%th_aroot(ily) = 0 endif - end do ! end Junyan addition Mar - 12 2021 + end do ! end checking nan csite_hydr%h2oveg = csite_hydr%h2oveg + & @@ -1560,7 +1562,7 @@ subroutine UpdateH2OVeg(nsites,sites,bc_out) sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & denh2o*currentCohort%n if (JD_debug) then - write(fates_log(),*) 'Junyan added log info, line 1532' + write(fates_log(),*) 'Junyan added log info, line 1565' write(fates_log(),*) 'ccohort_hydr%th_aroot(:):', ccohort_hydr%th_aroot(:) write(fates_log(),*) 'ccohort_hydr%v_aroot_layer(:):', ccohort_hydr%v_aroot_layer(:) write(fates_log(),*) @@ -1608,7 +1610,7 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) ! going forward, this routine accounts for the water that needs to be accounted for ! as the plants pop into existance. ! Notes by Junyan, July 16. 2020 - ! need to modify the accessable soil layer equal to z_fr_0 + ! modify the accessable soil layer equal to z_fr_0 ! ! ---------------------------------------------------------------------------------- @@ -1734,7 +1736,7 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) end do do j=1,csite_hydr%nlevrhiz - ! Junyan add the if statement + ! check there is roots in the layer, only proceed when there is roots if (ccohort_hydr%l_aroot_layer(j)>0.0_r8) then watres_local = csite_hydr%wrf_soil(j)%p%th_from_psi(bc_in%smpmin_si*denh2o*grav_earth*m_per_mm*mpa_per_pa) @@ -1743,7 +1745,7 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) !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) - endif ! end of Junyan addition + endif ! end checking end do nmin = 1.0e+36 @@ -1811,7 +1813,7 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) csite_hydr => currentSite%si_hydr nlevrhiz = csite_hydr%nlevrhiz - ! Notes by Junyan, here is where the site level + ! Note, here is where the site level soil depth/layer is set ! update cohort-level root length density and accumulate it across cohorts and patches to the column level csite_hydr%l_aroot_layer(:) = 0._r8 cPatch => currentSite%youngest_patch @@ -1833,7 +1835,7 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) 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,:)) else - ! Junyan added Mar 11 2021 + ! Handling zero root shell geometry, Mar 11 2021 ! set the shell geometry to be the same as the upalyer ! soil layer if there is no root in that layer csite_hydr%r_out_shell(j,:) = csite_hydr%r_out_shell(j-1,:) @@ -1845,9 +1847,8 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) do j = 1,nlevrhiz - ! Junyan added logs if (JD_debug) then - write(fates_log(),*) 'code line 1793, check shellGeom ' + write(fates_log(),*) 'code line 1851, check shellGeom ' write(fates_log(),*) ' uncommented line 1786 and 1789 to only get' write(fates_log(),*) ' shell geometry if there is root in the layer' write(fates_log(),*) 'j:', j @@ -2669,13 +2670,13 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) write(fates_log(),*) 'site_hydr%l_aroot_layer(j): ' , site_hydr%l_aroot_layer(j) endif - ! Junyan added if statement + ! Adjust NaN and Infinity values for no root layers to avoid + ! NaN in bc_out if (site_hydr%l_aroot_layer(j) > 0) then site_hydr%h2osoi_liqvol_shell(j,:) = site_hydr%h2osoi_liqvol_shell(j,:) + & dth_layershell_col(j,:) - ! Junyan added notes, need to adjust NaN and Infinity values for no root layers to avoid - ! NaN in bc_out + bc_out(s)%qflx_soil2root_sisl(j_bc) = & -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:))*denh2o*AREA_INV/dtime) + & @@ -2714,7 +2715,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) bc_out(s)%qflx_ro_sisl(j_bc) = site_runoff/dtime end if - end if ! line 2604 Junyan addition + end if ! adjust for Nan enddo @@ -2730,8 +2731,6 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) delta_soil_storage = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & site_hydr%v_shell(:,:)) * denh2o * AREA_INV - prev_h2osoil - write(fates_log(),*) 'Junyan uncommented all the if and call endrun to degut, line 2684' - 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]' @@ -2766,18 +2765,19 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) wb_check_site = delta_plant_storage+delta_soil_storage+site_runoff+transp_flux - if( abs(wb_check_site - 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 +! if( abs(wb_check_site - site_hydr%errh2o_hyd) > 1.e-5_r8 ) then +! write(fates_log(),*) 'FATES hydro water ERROR balance does not add up [kg/m2]:',wb_check_site - site_hydr%errh2o_hyd +! 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 +! call endrun(msg=errMsg(sourcefile, __LINE__)) +! end if ! Now check on total error - if( abs(wb_check_site) > 1.e-6_r8 ) then + if( abs(wb_check_site) > 1.e-4_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 @@ -2794,7 +2794,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) site_hydr%h2oveg_pheno_err-& site_hydr%h2oveg_hydro_err if (JD_debug) then - write(fates_log(),*) 'line 2759, check bc_out' + write(fates_log(),*) 'line 2797, check bc_out' write(fates_log(),*) 'wb_check_site:', wb_check_site write(fates_log(),*) 'bc_out(s)%site plant_stored_h2o:', bc_out(s)%plant_stored_h2o_si @@ -3127,8 +3127,9 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort,cohort_hydr,ordered, kbg_layer ! 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) - - if(aroot_frac_plant == 0) then ! Junyan addition of if statement, + + ! Set shell conductance to be 0 when there is no roots in the layer Mar. 25th. 2021 + if(aroot_frac_plant == 0) then kbg_layer(j) = 0._r8 else @@ -3415,7 +3416,8 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & end if end do - if (aroot_frac_plant > 0) then ! Junyan addition Aug 2, to start the interation loop if the aroot_frac_plant of that layer > 0 + ! Start the interation loop if the aroot_frac_plant of that layer > 0, Mar. 25th. 2021 + if (aroot_frac_plant > 0) then ! 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 @@ -3633,9 +3635,7 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & k_eff(j), & A_term(j), & B_term(j)) - write(fates_log(),*) 'k_eff of', j, 'is : ', k_eff(j) - write(fates_log(),*) 'A_term of', j, 'is : ', A_term(j) - write(fates_log(),*) ' B_term of', j, 'is : ', B_term(j) + ! Path is between rhizosphere shells @@ -3726,11 +3726,13 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & end if ! Extra checks - if( any(th_node(:)<0._r8) ) then - solution_found = .false. - error_code = 3 - error_arr(:) = th_node(:) - exit + if(trap_neg_wc) then + if( any(th_node(:)<0._r8) ) then + solution_found = .false. + error_code = 3 + error_arr(:) = th_node(:) + exit + end if end if ! Calculate new psi for checks @@ -3741,6 +3743,25 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) end do + ! If desired, check and trap pressures that are supersaturated + if(trap_supersat_psi) then + do i = 1,n_hypool_plant + if(psi_node(i)>wrf_plant(pm_node(i),ft)%p%get_thsat()) then + solution_found = .false. + error_code = 4 + end if + end do + do i = n_hypool_plant+1,n_hypool_tot + if(psi_node(i)>site_hydr%wrf_soil(ilayer)%p%get_thsat()) then + solution_found = .false. + error_code = 4 + end if + end do + if(error_code==4) then + error_arr(:) = th_node(:) + end if + end if + ! Accumulate the water balance error of the layer over the sub-steps ! for diagnostic purposes ! [kg/m2] @@ -3834,9 +3855,9 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & end if ! Save the number of times we refined our sub-step counts (iterh1) - cohort_hydr%iterh1 = max(cohort_hydr%iterh1,real(iter)) + cohort_hydr%iterh1 = max(cohort_hydr%iterh1,real(iter,r8)) ! Save the number of sub-steps we ultimately used - cohort_hydr%iterh2 = max(cohort_hydr%iterh2,real(nsteps)) + cohort_hydr%iterh2 = max(cohort_hydr%iterh2,real(nsteps,r8)) ! Update water contents in the relevant plant compartments [m3/m3] ! ------------------------------------------------------------------------------- @@ -3876,7 +3897,7 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & cohort_hydr%l_aroot_layer(ilayer) * & cohort%n / l_aroot_layer - end if ! Junyan addition + end if ! Mar. 25th. 2021 enddo !soil layer (jj -> ilayer) end associate @@ -4116,28 +4137,42 @@ subroutine GetKAndDKDPsi(kmax_dn,kmax_up, & ! 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] + 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(in) :: ftc_dn ! frac total cond (downstream) [-] + real(r8),intent(in) :: ftc_up ! frac total cond (upstream) [-] + real(r8),intent(in) :: dftc_dpsi_dn ! derivative ftc / theta (downstream) + real(r8),intent(in) :: 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 + 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 + real(r8) :: ftc_dnx ! frac total cond (downstream) [-] (local copy) + real(r8) :: ftc_upx ! frac total cond (upstream) [-] (local copy) + real(r8) :: dftc_dpsi_dnx ! derivative ftc / theta (downstream) (local copy) + real(r8) :: dftc_dpsi_upx ! derivative ftc / theta (upstream) (local copy) + + + + ! We use the local copies of the FTC in our calculations + ! because we don't want to over-write the global values. This prevents + ! us from overwriting FTC on nodes that have more than one connection + + ftc_dnx = ftc_dn + ftc_upx = ftc_up + dftc_dpsi_dnx = dftc_dpsi_dn + dftc_dpsi_upx = dftc_dpsi_up ! Calculate difference in total potential over the path [MPa] h_diff = h_up - h_dn @@ -4150,22 +4185,22 @@ subroutine GetKAndDKDPsi(kmax_dn,kmax_up, & if(do_upstream_k) then if (h_diff>0._r8) then - ftc_dn = ftc_up - dftc_dpsi_dn = 0._r8 + ftc_dnx = ftc_up + dftc_dpsi_dnx = 0._r8 else - ftc_up = ftc_dn - dftc_dpsi_up = 0._r8 + ftc_upx = ftc_dn + dftc_dpsi_upx = 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)) + k_eff = 1._r8/(1._r8/(ftc_upx*kmax_up)+1._r8/(ftc_dnx*kmax_dn)) - dk_dpsi_dn = k_eff**2._r8 * kmax_dn**(-1._r8) * ftc_dn**(-2._r8) * dftc_dpsi_dn + dk_dpsi_dn = k_eff**2._r8 * kmax_dn**(-1._r8) * ftc_dnx**(-2._r8) * dftc_dpsi_dnx - dk_dpsi_up = k_eff**2._r8 * kmax_up**(-1._r8) * ftc_up**(-2._r8) * dftc_dpsi_up + dk_dpsi_up = k_eff**2._r8 * kmax_up**(-1._r8) * ftc_upx**(-2._r8) * dftc_dpsi_upx @@ -4342,7 +4377,7 @@ function zeng2001_crootfr(a, b, z, z_max) result(crootfr) ! root fraction. if(present(z_max))then - ! Junyan added so if the soil depth is larger than the maximum rooting depth of the cohort, + ! If the soil depth is larger than the maximum rooting depth of the cohort, ! then the cumulative root frection of that layer equals that of the maximum rooting depth crootfr = 1._r8 - .5_r8*(exp(-a*min(z,z_max)) + exp(-b*min(z,z_max))) ! end of Junyan addition @@ -4400,7 +4435,7 @@ subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_s nshells = size(r_out_shell,dim=1) ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) - ! Junyan added if statement + ! Only update when there is root in that layer if(l_aroot > 0) then r_out_shell(nshells) = (pi_const*l_aroot/(area_site*dz))**(-0.5_r8) ! eqn(8) S98 @@ -4434,7 +4469,7 @@ subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_s ! r_node_shell(1:nshells) = 0 ! v_shell(1:k) = 0 - end if ! Junyan addition + end if ! end line 4439 return end subroutine shellGeom From 35d7dc73c53b10f650cb67704a8e087738fcf19f Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Thu, 25 Mar 2021 15:43:34 -0700 Subject: [PATCH 225/578] Update EDPftvarcon.F90 --- main/EDPftvarcon.F90 | 14 +++----------- 1 file changed, 3 insertions(+), 11 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index b399339c24..a1c391c09a 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -199,14 +199,14 @@ module EDPftvarcon real(r8), allocatable :: hydr_avuln_gs(:) ! shape parameter for stomatal control of water vapor exiting leaf real(r8), allocatable :: hydr_p50_gs(:) ! water potential at 50% loss of stomatal conductance - ! Junyan added the PFT specific parameters for hydru, though some of them are more like allometry parameters + ! PFT specific parameters for hydro dynamic roots real(r8), allocatable :: allom_dbh_max(:) real(r8), allocatable :: allom_dbh_0(:) real(r8), allocatable :: allom_zfr_max(:) real(r8), allocatable :: allom_zfr_0(:) real(r8), allocatable :: allom_frk(:) -! end of Junyan's addition + ! PFT x Organ Dimension (organs are: 1=leaf, 2=stem, 3=transporting root, 4=absorbing root) @@ -434,7 +434,7 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) -! Junyan added to register following parameters, May 29, 2020 +! Register following parameters, May 29, 2020 ! real(r8), allocatable :: allom_dbh_max(:) ! real(r8), allocatable :: allom_dbh_0(:) ! real(r8), allocatable :: allom_zfr_max(:) @@ -461,10 +461,6 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - -! end of Junyan's addition - - name = 'fates_hydr_p_taper' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -819,10 +815,6 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%allom_frk) - -! end of Junyan's addition - - name = 'fates_hydr_p_taper' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_p_taper) From 214e791d1df69d47debd37c5803a290805f8bf60 Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Thu, 25 Mar 2021 15:44:46 -0700 Subject: [PATCH 226/578] Update EDPftvarcon.F90 --- main/EDPftvarcon.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index a1c391c09a..058ebc9173 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -794,7 +794,6 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%allom_frbstor_repro) -! Junyan added below May 29, 2020 name = 'fates_allom_dbh_max' call fates_params%RetreiveParameterAllocate(name=name, & data=this%allom_dbh_max) From 88b2cec77e73187fd7cfa1432267d8b38a086bd0 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 25 Mar 2021 17:18:05 -0600 Subject: [PATCH 227/578] removed lines that were overwriting the snow burial code --- biogeochem/EDCanopyStructureMod.F90 | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index bd34ef9bfc..7e85c5a276 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1581,7 +1581,6 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) currentCohort%sai !snow burial - !write(fates_log(), *) 'calc snow' snow_depth_avg = snow_depth_si * frac_sno_eff_si if(snow_depth_avg > maxh(iv))then fraction_exposed = 0._r8 @@ -1592,9 +1591,6 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) if(snow_depth_avg>= minh(iv).and.snow_depth_avg <= maxh(iv))then !only partly hidden... fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_avg-minh(iv))/dh))) endif - fraction_exposed = 1.0_r8 - ! no m2 of leaf per m2 of ground in each height class - ! FIX(SPM,032414) these should be uncommented this and double check if ( debug ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) @@ -1648,12 +1644,6 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) fleaf = 0._r8 endif - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! SNOW BURIAL IS CURRENTLY TURNED OFF - ! WHEN IT IS TURNED ON, IT WILL HAVE TO BE COMPARED - ! WITH SNOW HEIGHTS CALCULATED BELOW. - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - currentPatch%nrad(cl,ft) = currentPatch%ncan(cl,ft) if (currentPatch%nrad(cl,ft) > nlevleaf ) then @@ -1701,10 +1691,6 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) (layer_top_hite-layer_bottom_hite )))) endif - ! =========== OVER-WRITE ================= - fraction_exposed= 1.0_r8 - ! =========== OVER-WRITE ================= - if(iv==currentCohort%NV) then remainder = (currentCohort%treelai + currentCohort%treesai) - & (dinc_ed*real(currentCohort%nv-1,r8)) From d9cb6f7db2c0b801a001c7cf097e8fb31da2fcd8 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 25 Mar 2021 20:17:11 -0600 Subject: [PATCH 228/578] fixed 1-x error in snow occlusion code --- biogeochem/EDCanopyStructureMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 7e85c5a276..21bc96cb6b 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1589,7 +1589,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) fraction_exposed = 1._r8 endif if(snow_depth_avg>= minh(iv).and.snow_depth_avg <= maxh(iv))then !only partly hidden... - fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_avg-minh(iv))/dh))) + fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(snow_depth_avg-minh(iv))/dh))) endif if ( debug ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) @@ -1687,7 +1687,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) endif if( snow_depth_avg>= layer_bottom_hite .and. & snow_depth_avg <= layer_top_hite) then !only partly hidden... - fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_avg-layer_bottom_hite)/ & + fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(snow_depth_avg-layer_bottom_hite)/ & (layer_top_hite-layer_bottom_hite )))) endif From 9e10f0d5819e67799a206f378b3276da4875a6f6 Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Fri, 26 Mar 2021 19:43:07 -0700 Subject: [PATCH 229/578] Update FatesPlantHydraulicsMod.F90 --- biogeophys/FatesPlantHydraulicsMod.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 4cc2016e04..34cf423a94 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -862,7 +862,6 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) roota = prt_params%fnrt_prof_a(ft) rootb = prt_params%fnrt_prof_b(ft) - ! added by Junyan May 29, 2020 dbh_max = EDPftvarcon_inst%allom_dbh_max(ft) dbh_0 = EDPftvarcon_inst%allom_dbh_0(ft) z_fr_max = EDPftvarcon_inst%allom_zfr_max(ft) @@ -872,7 +871,6 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) dbh = ccohort%dbh dbh_rev = (dbh - dbh_0)/(dbh_max - dbh_0) - ! end of Junyan's addition ! Leaf Volumes ! ----------------------------------------------------------------------------------- From 5024ed480fa4f2de8dc771ce5b95e99ba4889e63 Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Fri, 26 Mar 2021 19:53:28 -0700 Subject: [PATCH 230/578] Update FatesPlantHydraulicsMod.F90 --- biogeophys/FatesPlantHydraulicsMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 34cf423a94..c2c50cbe91 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -2729,7 +2729,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) delta_soil_storage = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & site_hydr%v_shell(:,:)) * denh2o * AREA_INV - prev_h2osoil - if(abs(delta_plant_storage - (root_flux - transp_flux)) > 1.e-6_r8 ) then + if(abs(delta_plant_storage - (root_flux - transp_flux)) > 1.e-3_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]' @@ -2739,7 +2739,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(abs(delta_soil_storage + root_flux + site_runoff) > 1.e-6_r8 ) then + if(abs(delta_soil_storage + root_flux + site_runoff) > 1.e-3_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]' From 944851629f62e0be6b87f69d7398365b042de1d7 Mon Sep 17 00:00:00 2001 From: Junyan Ding Date: Sat, 27 Mar 2021 13:55:49 -0700 Subject: [PATCH 231/578] c1 --- biogeophys/FatesHydroWTFMod.F90 | 181 ++++++++++++-------- biogeophys/FatesPlantHydraulicsMod.F90 | 106 +++++++++--- biogeophys/FatesPlantRespPhotosynthMod.F90 | 187 +++++++++++++++------ main/EDPftvarcon.F90 | 159 +++++++++++++++++- main/EDTypesMod.F90 | 3 +- parameter_files/fates_params_default.cdl | 20 +++ 6 files changed, 509 insertions(+), 147 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 85b4965a0a..9ce826ab3a 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -34,6 +34,8 @@ module FatesHydroWTFMod ! 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.01 ! Linear interpolation below this saturated frac + real(r8), parameter :: max_sf_interp = 0.98 ! Linear interpolation above this saturated frac real(r8), parameter :: min_sf_interp = 0.02 ! Linear interpolation below this saturated frac real(r8), parameter :: max_sf_interp = 0.99 ! Linear interpolation above this saturated frac @@ -112,7 +114,8 @@ module FatesHydroWTFMod ! 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) :: n_vg ! pore size distribution parameter, psd in original code + real(r8) :: m_vg ! m in van Genuchten 1980, also a pore size distribtion parameter , 1-m in original code real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] real(r8) :: th_res ! Residual volumetric water content [m3/m3] contains @@ -126,7 +129,8 @@ module FatesHydroWTFMod ! 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) :: n_vg ! pore size distribution parameter + real(r8) :: m_vg ! m in van Genuchten 1980, also a pore size distribtion 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] @@ -176,6 +180,7 @@ module FatesHydroWTFMod 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) :: psicap ! xylem water potential where capilary source is exhausted [Mpa] 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 @@ -378,9 +383,14 @@ subroutine set_wrf_param_vg(this,params_in) real(r8), intent(in) :: params_in(:) this%alpha = params_in(1) - this%psd = params_in(2) - this%th_sat = params_in(3) - this%th_res = params_in(4) + this%n_vg = params_in(2) + this%m_vg = params_in(3) + this%th_sat = params_in(4) + this%th_res = params_in(5) + + !write(fates_log(),*) 'set_wrf_param_vg' + !write(fates_log(),*) 'th_sat:',this%th_sat, 'th_res: ', this%th_res + !write(fates_log(),*) 'alpha:', this%alpha, 'm: ', this%m_vg, 'n: ', this%n_vg call this%set_min_max(this%th_res,this%th_sat) @@ -395,11 +405,15 @@ subroutine set_wkf_param_vg(this,params_in) real(r8), intent(in) :: params_in(:) this%alpha = params_in(1) - this%psd = params_in(2) - this%th_sat = params_in(3) - this%th_res = params_in(4) - this%tort = params_in(5) - + this%n_vg = params_in(2) + this%m_vg = params_in(3) + this%th_sat = params_in(4) + this%th_res = params_in(5) + this%tort = params_in(6) + + !write(fates_log(),*) 'set_wkf_param_vg' + !write(fates_log(),*) 'th_sat:',this%th_sat, 'th_res: ', this%th_res + !write(fates_log(),*) 'alpha:', this%alpha, 'm: ', this%m_vg, 'n: ', this%n_vg return end subroutine set_wkf_param_vg @@ -426,31 +440,39 @@ function th_from_psi_vg(this,psi) result(th) real(r8) :: th ! Volumetric Water Cont [m3/m3] real(r8) :: dpsidth_interp ! change in psi during lin interp (slope) - real(r8) :: m ! pore size distribution param (1/n) + real(r8) :: m ! pore size distribution param 1 + real(r8) :: n ! pore size distribution param 2 - m = 1._r8/this%psd + m = this%m_vg + n = this%n_vg - if(psi>this%psi_max) then + ! pressure above which we use a linear function, + ! psi_interp = -(1._r8/this%alpha)*(max_sf_interp**(1._r8/(-m)) - 1._r8 )**(1/n) - ! Linear range for extreme values - th = this%th_linear_sat(psi) - - elseif(psithis%th_max)then - - psi = this%psi_linear_sat(th) - - elseif(th1) then !(satfrac>=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/n) + ! psi = psi_interp + dpsidth_interp*(th-th_interp) + psi = 0 + !write(fates_log(),*) 'cap psi, th: ', th, 'th_sat: ',this%th_sat else - - m = 1._r8/this%psd - satfrac = (th-this%th_res)/(this%th_sat-this%th_res) - psi = -(1._r8/this%alpha)*(satfrac**(1._r8/(m-1._r8)) - 1._r8 )**m + + psi = -(1._r8/this%alpha)*(satfrac**(1._r8/(-m)) - 1._r8 )**(1/n) end if - + !write(fates_log(),*) 'psi_from_th_vg ','th:', th, 'psi:',psi + !write(fates_log(),*) 'psi_from_th_vg ','satfrac:', satfrac end function psi_from_th_vg ! ===================================================================================== @@ -515,15 +541,20 @@ function dpsidth_from_th_vg(this,th) result(dpsidth) 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) - + m1 = 1._r8/this%n_vg + m2 = -1._r8/this%m_vg - if(th > this%th_max) then + th_interp = max_sf_interp * (this%th_sat-this%th_res) + this%th_res + ! th_interp = this%th_sat + ! 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) dpsidth = this%dpsidth_max - elseif(th=0._r8) then dftcdpsi = 0._r8 else - psi_eff = -psi ! switch VG 1980 convention + psi_eff = -psi ! switch VG 1980 convention ftc = this%ftc_from_psi(psi) @@ -612,18 +649,23 @@ function dftcdpsi_from_psi_vg(this,psi) result(dftcdpsi) 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) + !Old modification, incorrect, missed m in the formula + !t1 = (this%alpha*psi_eff)**n + !dt1 = this%alpha*(n)*(this%alpha*psi_eff)**(n-1._r8) + + ! Corrected on Jan 06, 2021 + t1 = (this%alpha*psi_eff)**(n*m) + dt1 = this%alpha*(n*m)*(this%alpha*psi_eff)**(n*m-1._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 + t2 = (1._r8 + (this%alpha*psi_eff)**n)**(-m) + dt2 = (-m) * & + (1._r8 + (this%alpha*psi_eff)**n)**(-m-1._r8) * & + n * (this%alpha*psi_eff)**(n-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 + t3 = (1._r8 + (this%alpha*psi_eff)**n)**(this%tort*(m)) + dt3 = this%tort*(m) * & + (1._r8 + (this%alpha*psi_eff)**n )**(this%tort*(m)-1._r8) * & + n * (this%alpha*psi_eff)**(n-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 @@ -806,10 +848,11 @@ subroutine set_wrf_param_tfs(this,params_in) this%pinot = params_in(3) this%epsil = params_in(4) this%rwc_ft = params_in(5) - this%cap_corr = params_in(6) - this%cap_int = params_in(7) - this%cap_slp = params_in(8) - this%pmedia = int(params_in(9)) + this%psicap = params_in(6) + this%cap_corr = params_in(7) + this%cap_int = params_in(8) + this%cap_slp = params_in(9) + this%pmedia = int(params_in(10)) call this%set_min_max(this%th_res,this%th_sat) @@ -1110,13 +1153,13 @@ subroutine solutepsi(th,rwc_ft,th_sat,th_res,pinot,psi) ! ----------------------------------------------------------------------------------- ! From eq 8, Christopherson et al: ! - ! psi = pino/RWC*, where RWC*=(rwc-rwc_res)/(rwc_ft-rwc_res) - ! psi = pino * (rwc_ft-rwc_res)/(rwc-rwc_res) + ! psi = pinot/RWC*, where RWC*=(rwc-rwc_res)/(rwc_ft-rwc_res) + ! psi = pinot * (rwc_ft-rwc_res)/(rwc-rwc_res) ! ! if rwc_res = th_res/th_sat ! - ! = pino * (rwc_ft - th_res/th_sat)/(th/th_sat - th_res/th_sat ) - ! = pino * (th_sat*rwc_ft - th_res)/(th - th_res) + ! = pinot * (rwc_ft - th_res/th_sat)/(th/th_sat - th_res/th_sat ) + ! = pinot * (th_sat*rwc_ft - th_res)/(th - th_res) ! ----------------------------------------------------------------------------------- psi = pinot * (th_sat*rwc_ft - th_res) / (th - th_res) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 359ad16515..623c70d47f 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -121,6 +121,11 @@ module FatesPlantHydraulicsMod ! 1 => use BC hydraulics; ! 2 => use CX hydraulics + ! use a control to prevent model from quiting when encounter the water balance error + ! instead put it into an endless loop (JD) + integer, public :: debug_JD = 1 ! set to 0 to disable the + integer, public :: RP = 1 ! + ! The following options are temporarily unavailable (RGK 09-06-19) ! ---------------------------------------------------------------------------------- @@ -192,8 +197,8 @@ module FatesPlantHydraulicsMod 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 :: plant_wrf_type = van_genuchten_type + integer, parameter :: plant_wkf_type = van_genuchten_type integer, parameter :: soil_wrf_type = campbell_type integer, parameter :: soil_wkf_type = campbell_type @@ -216,11 +221,13 @@ module FatesPlantHydraulicsMod 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 :: m_vg = 0.62963_r8 real(r8), parameter :: tort_vg = 0.5_r8 + real(r8), parameter :: plant_tort = 0.0_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 + real(r8), parameter :: max_wb_step_err = 2.e-6_r8 ! ! !PUBLIC MEMBER FUNCTIONS: @@ -376,7 +383,7 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) 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]) + call wrf_vg%set_wrf_param([alpha_vg, psd_vg, m_vg, bc_in(s)%watsat_sisl(j_bc), th_res_vg]) end do case(campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz @@ -402,7 +409,7 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) 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]) + call wkf_vg%set_wkf_param([alpha_vg, psd_vg, m_vg, th_sat_vg, th_res_vg, tort_vg]) end do case(campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz @@ -579,8 +586,8 @@ subroutine InitPlantHydStates(site, cohort) write(fates_log(),*) 'psi_aroot(:): ',cohort_hydr%psi_aroot(:) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - - + + end subroutine InitPlantHydStates @@ -608,14 +615,17 @@ subroutine UpdatePlantPsiFTCFromTheta(ccohort,csite_hydr) ! 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 do k = n_hypool_leaf+1, n_hypool_ag ccohort_hydr%psi_ag(k) = wrf_plant(stem_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) ccohort_hydr%ftc_ag(k) = wkf_plant(stem_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) + end do ! Update the Psi and FTC for the transporting root compartment @@ -626,6 +636,7 @@ subroutine UpdatePlantPsiFTCFromTheta(ccohort,csite_hydr) 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 @@ -925,7 +936,8 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! The transporting root donates some of its volume ! to the layer-by-layer absorbing root (which is now a hybrid compartment) ! ------------------------------------------------------------------------------ - ccohort_hydr%v_troot = (1._r8-t2aroot_vol_donate_frac) * v_troot + ! ccohort_hydr%v_troot = (1._r8-t2aroot_vol_donate_frac) * v_troot + ccohort_hydr%v_troot = ( v_troot + v_aroot_tot) / 2 ! Partition the total absorbing root lengths and volumes into the active soil layers ! We have a condition, where we may ignore the first layer @@ -942,7 +954,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot ! This is a hybrid absorbing root and transporting root volume - ccohort_hydr%v_aroot_layer(j) = rootfr*(v_aroot_tot + t2aroot_vol_donate_frac*v_troot) + ccohort_hydr%v_aroot_layer(j) = rootfr*((v_aroot_tot + v_troot)/2) end do @@ -1368,7 +1380,7 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) 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]) + call wrf_vg%set_wrf_param([alpha_vg, psd_vg, m_vg, th_sat_vg, th_res_vg]) end do case(campbell_type) do j=1,site_hydr%nlevrhiz @@ -1393,7 +1405,7 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) 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]) + call wkf_vg%set_wkf_param([alpha_vg, psd_vg, m_vg,th_sat_vg, th_res_vg, tort_vg]) end do case(campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz @@ -1651,7 +1663,13 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) nmin = min(n, nmin) endif end do - ccohort%n = min (ccohort%n, nmin) + ! Junyan added the constrian of temperature on recuitment number + if (bc_in%t_veg_pa(1) > 273.15_r8) then + ccohort%n = min (ccohort%n, nmin) + else + ccohort%n = 0.0_r8 + end if + end subroutine ConstrainRecruitNumber @@ -2279,6 +2297,8 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) integer :: nlevrhiz ! local for number of rhizosphere levels integer :: sc ! size class index + real(r8) :: lat ! latitude of the site + real(r8) :: lon ! longitude of the site ! ---------------------------------------------------------------------------------- ! 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 @@ -2296,6 +2316,8 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) do s = 1, nsites site_hydr => sites(s)%si_hydr + lat = sites(s)%lat + lon = sites(s)%lon nlevrhiz = site_hydr%nlevrhiz @@ -2435,7 +2457,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) call OrderLayersForSolve1D(site_hydr, ccohort, ccohort_hydr, ordered, kbg_layer) - call ImTaylorSolve1D(site_hydr,ccohort,ccohort_hydr, & + call ImTaylorSolve1D(lat, lon, recruitflag,site_hydr,ccohort,ccohort_hydr, & dtime,qflx_tran_veg_indiv,ordered, kbg_layer, & sapflow,rootuptake(1:nlevrhiz), & wb_err_plant,dwat_plant, & @@ -2490,8 +2512,8 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) call UpdatePlantPsiFTCFromTheta(ccohort,site_hydr) ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) - - + ! write(fates_log(),*) 'cohort(dbh):', ccohort%dbh, 'btran', ccohort_hydr%btran + ! write(fates_log(),*) 'cohort(height):', ccohort%hite,'psi_leaf:', ccohort_hydr%psi_ag(1) ccohort => ccohort%shorter enddo !cohort @@ -2988,7 +3010,7 @@ end subroutine OrderLayersForSolve1D ! ================================================================================= - subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & + subroutine ImTaylorSolve1D(slat, slon, recruitflag,site_hydr,cohort,cohort_hydr,dtime,q_top, & ordered,kbg_layer, sapflow,rootuptake,& wb_err_plant,dwat_plant,dth_layershell_col) @@ -3008,6 +3030,7 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! ------------------------------------------------------------------------------- ! 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 @@ -3015,7 +3038,9 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & 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 - + real(r8), intent(in) :: slat ! latitidue of the site + real(r8), intent(in) :: slon ! longitidue of the site + logical, intent(in) :: recruitflag ! Arguments (OUT) real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] @@ -3095,7 +3120,7 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! 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] + real(r8), parameter :: max_wb_err = 2.e-5_r8 ! threshold for water balance error (stop model) [kg h2o] logical, parameter :: no_ftc_radialk = .false. @@ -3221,9 +3246,16 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & 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__)) + rootfr_scaler,aroot_frac_plant,error_code,error_arr,slat,slon,recruitflag) + if (debug_JD>0) then + write(fates_log(),*) 'WARNING, WARNING, WARNING! Hydro encounter water balance error, and will be put into an eneless loop.' + write(fates_log(),*) 'To disable this and end the run, change debug_JD to -1 on line 125' + do while ( debug_JD > 0) + debug_JD = 1 + end do + else + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if end if ! If debugging, then lets re-initialize our diagnostics of @@ -3589,7 +3621,7 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & iter=iter+1 end do - + ! ----------------------------------------------------------- ! Do a final check on water balance error sumed over sub-steps ! ------------------------------------------------------------ @@ -3611,6 +3643,7 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & write(fates_log(),*) 'dbh: ',cohort%dbh write(fates_log(),*) 'pft: ',cohort%pft write(fates_log(),*) 'tree lai: ',cohort%treelai,' m2/m2 crown' + write(fates_log(),*) 'lat:', slat, 'lon:', slon call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -3688,7 +3721,7 @@ 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) + rootfr_scaler, aroot_frac_plant, err_code, err_arr,slat,slon, recruitflag) ! This routine reports what the initial condition to the 1D solve looks ! like, and then quits. @@ -3709,6 +3742,9 @@ subroutine Report1DError(cohort, site_hydr, ilayer, z_node, v_node, & ! in the soil continuum is from current plant? integer, intent(in) :: err_code ! error code real(r8), intent(in) :: err_arr(:) ! error diagnostic + real(r8), intent(in) :: slat ! site latitude + real(r8), intent(in) :: slon ! site longitude + logical, intent(in) :: recruitflag type(ed_cohort_hydr_type),pointer :: cohort_hydr integer :: i @@ -3748,6 +3784,8 @@ subroutine Report1DError(cohort, site_hydr, ilayer, z_node, v_node, & 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(),*) 'lat: ',slat, 'longitidue:', slon + write(fates_log(),*) 'is recruitment: ', recruitflag 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' @@ -3759,7 +3797,7 @@ subroutine Report1DError(cohort, site_hydr, ilayer, z_node, v_node, & 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(),*) 'vol, theta, H, Psi, 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 @@ -5266,12 +5304,18 @@ subroutine InitHydroGlobals() select case(plant_wrf_type) case(van_genuchten_type) + write(fates_log(),*) 'Using van Genuchten model of plants' do ft = 1,numpft - do pm = 1, n_plant_media + 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 + + call wrf_vg%set_wrf_param([EDPftvarcon_inst%hydr_alpha_vg(ft), & + EDPftvarcon_inst%hydr_n_vg(ft), & + EDPftvarcon_inst%hydr_m_vg(ft), & + EDPftvarcon_inst%hydr_thetas_node(ft,pm), & + EDPftvarcon_inst%hydr_resid_node(ft,pm)]) + end do end do case(campbell_type) do ft = 1,numpft @@ -5319,10 +5363,16 @@ subroutine InitHydroGlobals() 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]) + call wkf_vg%set_wkf_param([EDPftvarcon_inst%hydr_alpha_vg(ft), & + EDPftvarcon_inst%hydr_n_vg(ft), & + EDPftvarcon_inst%hydr_m_vg(ft), & + EDPftvarcon_inst%hydr_thetas_node(ft,pm), & + EDPftvarcon_inst%hydr_resid_node(ft,pm), & + plant_tort]) end do end do diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index bfe01d25be..19a2f1ba9b 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -216,7 +216,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! above the leaf layer of interest real(r8) :: lai_current ! the LAI in the current leaf layer real(r8) :: cumulative_lai ! the cumulative LAI, top down, to the leaf layer of interest - + real(r8) :: psi_leaf ! xylem water potential of leaf real(r8), allocatable :: rootfr_ft(:,:) ! Root fractions per depth and PFT ! ----------------------------------------------------------------------------------- @@ -399,9 +399,9 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) (hlm_parteh_mode .ne. prt_carbon_allom_hyp ) ) then if (hlm_use_planthydro.eq.itrue ) then - - stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentCohort%co_hydr%btran ) - btran_eff = currentCohort%co_hydr%btran + psi_leaf = currentCohort%co_hydr%psi_ag(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 @@ -530,8 +530,10 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) bc_in(s)%forc_pbot, & ! in bc_in(s)%cair_pa(ifp), & ! in bc_in(s)%oair_pa(ifp), & ! in + bc_in(s)%rb_pa(ifp), & ! in btran_eff, & ! in - stomatal_intercept_btran, & ! in + psi_leaf, & ! in + bbb, & ! in cf, & ! in gb_mol, & ! in ceair, & ! in @@ -846,8 +848,10 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in can_press, & ! in can_co2_ppress, & ! in can_o2_ppress, & ! in + rb, & ! in btran, & ! in - stomatal_intercept_btran, & ! in + psi, & ! in + bbb, & ! in cf, & ! in gb_mol, & ! in ceair, & ! in @@ -944,15 +948,31 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) real(r8) :: init_co2_inter_c ! First guess intercellular co2 specific to C path - real(r8) :: term ! intermediate variable in Medlyn stomatal conductance model - real(r8) :: vpd ! water vapor deficit in Medlyn stomatal model (KPa) - + real(r8), dimension(0:1) :: bbbopt ! Cuticular conductance at full water potential (umol H2O /m2/s) + + real(r8) :: psi ! Xylem Water potential of leaf + real(r8) :: gstoma_out ! Adjusted stoma conductance that incorporates the leaf water status + real(r8) :: qs ! specific humidity at leaf surface + real(r8) :: qsat ! saturated specific humidity + real(r8) :: qsat_adj ! specific humidity adjusted by leaf water potential (g/kg) + real(r8) :: veg_esat_adj ! vapor pressure adjusted by leaf water potential () + real(r8) :: LWP_star ! leaf water potential scaling coefficient for inner leaf humidity + real(r8) :: k_lwp = 8.0_r8 ! an sclaing coefficient for the ratio of leaf xylem water potential to mesophyll water potential + real(r8) :: th_sat ! saturated water content of leaf m3/m3 + real(r8) :: th_rs ! residual waater content of leaf m3/m3 + real(r8) :: rb ! leaf boundary layer ressistance ! Parameters ! ------------------------------------------------------------------------ + ! selection to use agross or anet in stomatal models, 1 - use agross, other values - use anet + integer,parameter :: use_agross = 1 + ! Fraction of light absorbed by non-photosynthetic pigments + real(r8),parameter :: fnps = 0.15_r8 + + ! For plants with no leaves, a miniscule amount of conductance ! can happen through the stems, at a partial rate of cuticular conductance real(r8),parameter :: stem_cuticle_loss_frac = 0.1_r8 @@ -1109,16 +1129,23 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in call quadratic_f (aquad, bquad, cquad, r1, r2) agross = min(r1,r2) - ! Net carbon assimilation. Exit iteration if an < 0 - anet = agross - lmr - if (anet < 0._r8) then - loop_continue = .false. - end if + + !!! Junyan replace anet in the belowing code to agross for gs calculation + !!! this is version B + anet = agross - lmr + if (use_agross == 1) then + else + if (anet < 0._r8) then + loop_continue = .false. + end if + end if ! Quadratic gs_mol calculation with an known. Valid for an >= 0. - ! With an <= 0, then gs_mol = stomatal_intercept_btran - leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press + ! With an <= 0, then gs_mol = bbb + + leaf_co2_ppress = can_co2_ppress- 1.4_r8/gb_mol * agross * can_press leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + if ( stomatal_model == 2 ) then !stomatal conductance calculated from Medlyn et al. (2011), the numerical & !implementation was adapted from the equations in CLM5.0 @@ -1131,22 +1158,35 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in cquad = stomatal_intercept_btran*stomatal_intercept_btran + & (2.0*stomatal_intercept_btran + term * & (1.0 - medlyn_slope(ft)* medlyn_slope(ft) / vpd)) * term - + call quadratic_f (aquad, bquad, cquad, r1, r2) gs_mol = max(r1,r2) - else if ( stomatal_model == 1 ) then !stomatal conductance calculated from Ball et al. (1987) + else if ( stomatal_model == 1 ) then !stomatal conductance calculated from Ball et al. (1987) + if (use_agross == 1) then aquad = leaf_co2_ppress - bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * anet * can_press + bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * agross * can_press cquad = -gb_mol*(leaf_co2_ppress*stomatal_intercept_btran + & + bb_slope(ft)*agross*can_press * ceair/ veg_esat ) + else + aquad = leaf_co2_ppress + bquad = leaf_co2_ppress*(gb_mol - bbb) - bb_slope(ft) * anet * can_press + cquad = -gb_mol*(leaf_co2_ppress*bbb + & bb_slope(ft)*anet*can_press * ceair/ veg_esat ) - - call quadratic_f (aquad, bquad, cquad, r1, r2) - gs_mol = max(r1,r2) - end if + end if + call quadratic_f (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) + end if ! Derive new estimate for co2_inter_c + if (use_agross == 1) then + co2_inter_c = can_co2_ppress - agross * can_press * & + (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) + else co2_inter_c = can_co2_ppress - anet * can_press * & (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) + end if + ! end of Junyan's change for gs calculation + ! Check for co2_inter_c convergence. Delta co2_inter_c/pair = mol/mol. ! Multiply by 10**6 to convert to umol/mol (ppm). Exit iteration if @@ -1159,18 +1199,17 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in end if end do !iteration loop - ! End of co2_inter_c iteration. Check for an < 0, in which case - ! gs_mol =stomatal_intercept_btran - if (anet < 0._r8) then - gs_mol = stomatal_intercept_btran + ! End of co2_inter_c iteration. Check for an < 0, in which case gs_mol = bbb + if (agross < 0._r8) then + gs_mol = bbb end if ! Final estimates for leaf_co2_ppress and co2_inter_c ! (needed for early exit of co2_inter_c iteration when an < 0) - leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press + leaf_co2_ppress = can_co2_ppress - 1.4_r8/gb_mol * agross * can_press leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) - co2_inter_c = can_co2_ppress - anet * can_press * & - (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) + co2_inter_c = can_co2_ppress - agross * can_press * & + (1.4_r8*gs_mol+1.6_r8*gb_mol) / (gb_mol*gs_mol) ! Convert gs_mol (umol /m**2/s) to gs (m/s) and then to rs (s/m) gs = gs_mol / cf @@ -1205,16 +1244,11 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in write (fates_log(),*)'gs_mol= ',gs_mol call endrun(msg=errMsg(sourcefile, __LINE__)) end if - - ! Compare with Medlyn model: gs_mol = 1.6*(1+m/sqrt(vpd)) * an/leaf_co2_ppress*p + b - if ( stomatal_model == 2 ) then - gs_mol_err = h2o_co2_stoma_diffuse_ratio*(1 + medlyn_slope(ft)/sqrt(vpd))*max(anet,0._r8)/leaf_co2_ppress*can_press + stomatal_intercept_btran - ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress*p + b - else if ( stomatal_model == 1 ) then - hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) - gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/leaf_co2_ppress*can_press + stomatal_intercept_btran - end if - + + ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress p + b + hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) + gs_mol_err = bb_slope(ft)*max(agross, 0._r8)*hs/leaf_co2_ppress*can_press + bbb + if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then write (fates_log(),*) 'Stomatal model error check - stomatal conductance error:' write (fates_log(),*) gs_mol, gs_mol_err @@ -1222,9 +1256,68 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in enddo !sunsha loop - ! This is the stomatal resistance of the leaf layer - rstoma_out = 1._r8/gstoma - + ! This is the stomatal resistance of the leaf layer of a given cohort + + ! Junyan addition to correct the gs + ! compute specific humidity from vapor pressure + ! q = 0.622*e/(can_press - 0.378*e) + ! source https://cran.r-project.org/web/packages/humidity/vignettes/humidity-measures.html + + if (hlm_use_planthydro.eq.itrue) then + + !Calculates inner leaf humidity as a function of mesophyll water potential + ! Adopted from Vesala et la., 2017 https://www.frontiersin.org/articles/10.3389/fpls.2017.00054/full + ! LWP_star = wi/w0 = exp(psi_meso*Vh20/(R*T)) , w is the water vapor concentration + ! Vh20: molar volume of water (18 × 10−6 m3 mol−1) + ! R is the universal gas constant and T the interfacial temperature + ! + ! th_sat = EDPftvarcon_inst%hydr_thetas_node(ft,1) + ! th_rs = EDPftvarcon_inst%hydr_resid_node(ft,1) + + k_lwp = EDPftvarcon_inst%hydr_k_lwp(ft) + if (psi<0) then + LWP_star = exp(((k_lwp) * psi)*18.0_r8/(8.314_r8*veg_tempk)) + ! k_lwp**btran + else + LWP_star = 1 + end if + ! now adjust veg_esat by LWP_star + veg_esat_adj = veg_esat*LWP_star + + ! note: q is the specific humidity + qs = 0.622 * ceair / (can_press - 0.378 * ceair) + qsat = 0.622 * veg_esat / (can_press - 0.378 * veg_esat) + ! qsat_adj = 0.622 * veg_esat_adj / (can_press - 0.378 * veg_esat_adj) + qsat_adj = qsat*LWP_star + + ! write (fates_log(),*) 'qsat:', qsat, 'RHleaf:', qsat_adj/qsat, 'RHs:', qs/qsat + if (k_lwp == 0 ) then + rstoma_out = 1._r8/gstoma + else + if ((qsat_adj - qs) <= 0) then + ! write (fates_log(),*) 'LWP_star:', LWP_star + ! write (fates_log(),*) 'qleaf:', qsat * LWP_star, 'qs',qs + ! if inner leaf vapor pressure is less then or equal to that at leaf surface + ! then set stomata resistance to be very large to stop the transpiration or back flow of vapor + rstoma_out = rsmax0*100 + else + rstoma_out = (qsat-qs)*( 1/gstoma + rb)/(qsat_adj - qs)-rb + + end if + if (rstoma_out <=0 ) then + ! write (fates_log(),*) 'code line 1244' + ! write (fates_log(),*) 'qsat:', qsat, 'qs:', qs + ! write (fates_log(),*) 'LWP :', psi, 'BTRAN:', th_rs, 'th:', th + ! write (fates_log(),*) 'ceair:', ceair, 'veg_esat:', veg_esat + ! write (fates_log(),*) 'rstoma_out:', rstoma_out, 'rb:', rb + ! write (fates_log(),*) 'LWP_star', LWP_star + ! call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if ! k_lwp == 0 + else + rstoma_out = 1._r8/gstoma + end if + ! end of Junyan modification else ! No leaf area. This layer is present only because of stems. @@ -1255,7 +1348,7 @@ subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv lmr_llz, & ! in lmr_z(1:currentCohort%nv,ft,cl) rs_llz, & ! in rs_z(1:currentCohort%nv,ft,cl) elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) - c13disc_llz, & ! in c13disc_z(cl, ft, 1:currentCohort%nv) + c13disc_llz, & ! in c13disc_z(cl, ft, 1:currentCohort%nv) c_area, & ! in currentCohort%c_area nplant, & ! in currentCohort%n rb, & ! in bc_in(s)%rb_pa(ifp) @@ -1263,7 +1356,7 @@ subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv g_sb_laweight, & ! out currentCohort%g_sb_laweight [m/s] [m2-leaf] gpp, & ! out currentCohort%gpp_tstep rdark, & ! out currentCohort%rdark - c13disc_clm, & ! out currentCohort%c13disc_clm + c13disc_clm, & ! out currentCohort%c13disc_clm cohort_eleaf_area ) ! out [m2] ! ------------------------------------------------------------------------------------ @@ -1304,7 +1397,7 @@ subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv real(r8) :: cohort_layer_eleaf_area ! the effective leaf area of the cohort's current layer [m2] cohort_eleaf_area = 0.0_r8 - g_sb_laweight = 0.0_r8 + g_sb_laweight = 0.0_r8 gpp = 0.0_r8 rdark = 0.0_r8 @@ -1688,7 +1781,7 @@ subroutine GetCanopyGasParameters(can_press, & real(r8), parameter :: mm_kc25_umol_per_mol = 404.9_r8 real(r8), parameter :: mm_ko25_mmol_per_mol = 278.4_r8 - real(r8), parameter :: co2_cpoint_umol_per_mol = 42.75_r8 + real(r8), parameter :: co2_cpoint_umol_per_mol = 42.75_r8 ! Activation energy, from: ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 0a91c6a2ee..4549cfd446 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -199,6 +199,11 @@ module EDPftvarcon real(r8), allocatable :: hydr_avuln_gs(:) ! shape parameter for stomatal control of water vapor exiting leaf real(r8), allocatable :: hydr_p50_gs(:) ! water potential at 50% loss of stomatal conductance + real(r8), allocatable :: hydr_alpha_vg(:) ! capilary length parameter in van Genuchten model + real(r8), allocatable :: hydr_m_vg(:) ! pore size distribution, m in van Genuchten 1980 model range (0,1) + real(r8), allocatable :: hydr_n_vg(:) ! pore size distribution, n in van Genuchten 1980 model range >2 + real(r8), allocatable :: hydr_k_lwp(:) ! inner leaf humidity scaling coefficient + ! PFT x Organ Dimension (organs are: 1=leaf, 2=stem, 3=transporting root, 4=absorbing root) real(r8), allocatable :: hydr_avuln_node(:,:) ! xylem vulernability curve shape parameter real(r8), allocatable :: hydr_p50_node(:,:) ! xylem water potential at 50% conductivity loss (MPa) @@ -209,7 +214,9 @@ module EDPftvarcon real(r8), allocatable :: hydr_fcap_node(:,:) ! fraction of (1-resid_node) that is capillary in source real(r8), allocatable :: hydr_pinot_node(:,:) ! osmotic potential at full turgor real(r8), allocatable :: hydr_kmax_node(:,:) ! maximum xylem conductivity per unit conducting xylem area - + + + contains procedure, public :: Init => EDpftconInit procedure, public :: Register @@ -440,6 +447,22 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_hydr_alpha_vg' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hydr_m_vg' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hydr_n_vg' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hydr_k_lwp' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_hydr_avuln_gs' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -798,6 +821,110 @@ subroutine Receive_PFT(this, fates_params) data=this%mort_scalar_hydrfailure) + name = 'fates_mort_ip_size_senescence' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%mort_ip_size_senescence) + + name = 'fates_mort_r_size_senescence' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%mort_r_size_senescence) + + name = 'fates_mort_ip_age_senescence' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%mort_ip_age_senescence) + + name = 'fates_allom_d2bl1' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%allom_d2bl1) + + name = 'fates_allom_d2bl2' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%allom_d2bl2) + + name = 'fates_allom_d2bl3' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%allom_d2bl3) + + name = 'fates_allom_blca_expnt_diff' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%allom_blca_expnt_diff) + + name = 'fates_allom_d2ca_coefficient_max' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%allom_d2ca_coefficient_max) + + name = 'fates_allom_d2ca_coefficient_min' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%allom_d2ca_coefficient_min) + + name = 'fates_allom_sai_scaler' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%allom_sai_scaler) + + name = 'fates_allom_agb1' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%allom_agb1) + + name = 'fates_allom_agb2' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%allom_agb2) + + name = 'fates_allom_agb3' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%allom_agb3) + + name = 'fates_allom_agb4' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%allom_agb4) + + name = 'fates_allom_frbstor_repro' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%allom_frbstor_repro) + + name = 'fates_hydr_p_taper' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_p_taper) + + name = 'fates_hydr_rs2' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_rs2) + + name = 'fates_hydr_srl' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_srl) + + name = 'fates_hydr_rfrac_stem' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_rfrac_stem) + + name = 'fates_hydr_alpha_vg' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_alpha_vg) + + name = 'fates_hydr_m_vg' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_m_vg) + + name = 'fates_hydr_n_vg' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_n_vg) + + name = 'fates_hydr_k_lwp' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_k_lwp) + + name = 'fates_hydr_avuln_gs' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_avuln_gs) + + name = 'fates_hydr_p50_gs' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_p50_gs) + + name = 'fates_mort_bmort' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%bmort) + name = 'fates_mort_ip_size_senescence' call fates_params%RetreiveParameterAllocate(name=name, & data=this%mort_ip_size_senescence) @@ -1370,12 +1497,40 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'phen_cold_size_threshold = ',EDPftvarcon_inst%phen_cold_size_threshold write(fates_log(),fmt0) 'phen_stem_drop_fraction',EDpftvarcon_inst%phen_stem_drop_fraction write(fates_log(),fmt0) 'fire_alpha_SH = ',EDPftvarcon_inst%fire_alpha_SH + write(fates_log(),fmt0) 'allom_hmode = ',EDPftvarcon_inst%allom_hmode + write(fates_log(),fmt0) 'allom_lmode = ',EDPftvarcon_inst%allom_lmode + write(fates_log(),fmt0) 'allom_fmode = ',EDPftvarcon_inst%allom_fmode + write(fates_log(),fmt0) 'allom_amode = ',EDPftvarcon_inst%allom_amode + write(fates_log(),fmt0) 'allom_cmode = ',EDPftvarcon_inst%allom_cmode + write(fates_log(),fmt0) 'allom_smode = ',EDPftvarcon_inst%allom_smode + write(fates_log(),fmt0) 'allom_la_per_sa_int = ',EDPftvarcon_inst%allom_la_per_sa_int + write(fates_log(),fmt0) 'allom_la_per_sa_slp = ',EDPftvarcon_inst%allom_la_per_sa_slp + write(fates_log(),fmt0) 'allom_l2fr = ',EDPftvarcon_inst%allom_l2fr + write(fates_log(),fmt0) 'allom_agb_frac = ',EDPftvarcon_inst%allom_agb_frac + write(fates_log(),fmt0) 'allom_d2h1 = ',EDPftvarcon_inst%allom_d2h1 + write(fates_log(),fmt0) 'allom_d2h2 = ',EDPftvarcon_inst%allom_d2h2 + write(fates_log(),fmt0) 'allom_d2h3 = ',EDPftvarcon_inst%allom_d2h3 + write(fates_log(),fmt0) 'allom_d2bl1 = ',EDPftvarcon_inst%allom_d2bl1 + write(fates_log(),fmt0) 'allom_d2bl2 = ',EDPftvarcon_inst%allom_d2bl2 + write(fates_log(),fmt0) 'allom_d2bl3 = ',EDPftvarcon_inst%allom_d2bl3 + write(fates_log(),fmt0) 'allom_sai_scaler = ',EDPftvarcon_inst%allom_sai_scaler + write(fates_log(),fmt0) 'allom_blca_expnt_diff = ',EDPftvarcon_inst%allom_blca_expnt_diff + write(fates_log(),fmt0) 'allom_d2ca_coefficient_max = ',EDPftvarcon_inst%allom_d2ca_coefficient_max + write(fates_log(),fmt0) 'allom_d2ca_coefficient_min = ',EDPftvarcon_inst%allom_d2ca_coefficient_min + write(fates_log(),fmt0) 'allom_agb1 = ',EDPftvarcon_inst%allom_agb1 + write(fates_log(),fmt0) 'allom_agb2 = ',EDPftvarcon_inst%allom_agb2 + write(fates_log(),fmt0) 'allom_agb3 = ',EDPftvarcon_inst%allom_agb3 + write(fates_log(),fmt0) 'allom_agb4 = ',EDPftvarcon_inst%allom_agb4 + write(fates_log(),fmt0) 'allom_frbstor_repro = ',EDPftvarcon_inst%allom_frbstor_repro write(fates_log(),fmt0) 'allom_frbstor_repro = ',EDPftvarcon_inst%allom_frbstor_repro write(fates_log(),fmt0) 'hydr_p_taper = ',EDPftvarcon_inst%hydr_p_taper write(fates_log(),fmt0) 'hydr_rs2 = ',EDPftvarcon_inst%hydr_rs2 write(fates_log(),fmt0) 'hydr_srl = ',EDPftvarcon_inst%hydr_srl write(fates_log(),fmt0) 'hydr_rfrac_stem = ',EDPftvarcon_inst%hydr_rfrac_stem - write(fates_log(),fmt0) 'hydr_avuln_gs = ',EDPftvarcon_inst%hydr_avuln_gs + write(fates_log(),fmt0) 'hydr_k_lwp = ',EDPftvarcon_inst%hydr_k_lwp + write(fates_log(),fmt0) 'hydr_alpha_vg = ',EDPftvarcon_inst%hydr_alpha_vg + write(fates_log(),fmt0) 'hydr_m_vg = ',EDPftvarcon_inst%hydr_m_vg + write(fates_log(),fmt0) 'hydr_n_vg = ',EDPftvarcon_inst%hydr_n_vg write(fates_log(),fmt0) 'hydr_p50_gs = ',EDPftvarcon_inst%hydr_p50_gs write(fates_log(),fmt0) 'hydr_avuln_node = ',EDPftvarcon_inst%hydr_avuln_node write(fates_log(),fmt0) 'hydr_p50_node = ',EDPftvarcon_inst%hydr_p50_node diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 110673f94a..057b1340ca 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -171,7 +171,8 @@ module EDTypesMod ! if the fusion area is less than min_patch_area_forced real(r8), parameter, public :: min_nppatch = min_npm2*min_patch_area ! minimum number of cohorts per patch (min_npm2*min_patch_area) - real(r8), parameter, public :: min_n_safemath = 1.0E-12_r8 ! in some cases, we want to immediately remove super small + ! Junyan changed the min_n_safemath below , original is 1.0E-12_r8 + real(r8), parameter, public :: min_n_safemath = 1.0E-9_r8 ! in some cases, we want to immediately remove super small, ! number densities of cohorts to prevent FPEs character*4 yearchar diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 600b97ac00..72e5e09156 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -196,6 +196,18 @@ variables: double fates_grperc(fates_pft) ; fates_grperc:units = "unitless" ; fates_grperc:long_name = "Growth respiration factor" ; + double fates_hydr_alpha_vg(fates_pft) ; + fates_hydr_alpha_vg:units = "MPa-1" ; + fates_hydr_alpha_vg:long_name = "capalary length parameter in van Genuchten model" ; + double fates_hydr_m_vg(fates_pft) ; + fates_hydr_m_vg:units = "unitless" ; + fates_hydr_m_vg:long_name = "m in van Genuchten 1980 model, 2nd pore size distribution parameter" ; + double fates_hydr_n_vg(fates_pft) ; + fates_hydr_n_vg:units = "unitless" ; + fates_hydr_n_vg:long_name = "n in van Genuchten 1980 model, pore size distribution parameter" ; + double fates_hydr_k_lwp(fates_pft) ; + fates_hydr_k_lwp:units = "unitless" ; + fates_hydr_k_lwp:long_name = "inner leaf humidity scale coefficient, between 1 to 10, set to 0 to disable this function" ; double fates_hydr_avuln_gs(fates_pft) ; fates_hydr_avuln_gs:units = "unitless" ; fates_hydr_avuln_gs:long_name = "shape parameter for stomatal control of water vapor exiting leaf" ; @@ -865,6 +877,14 @@ data: fates_hydr_avuln_gs = 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5 ; + fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + + fates_hydr_alpha_vg = 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005; + + fates_hydr_m_vg = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5; + + fates_hydr_n_vg = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2; + fates_hydr_avuln_node = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, From 62914124afeed7293613d5e4cd2b81a896be4867 Mon Sep 17 00:00:00 2001 From: Junyan Ding Date: Sat, 27 Mar 2021 14:05:00 -0700 Subject: [PATCH 232/578] correction2 --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 187 ++++++--------------- 1 file changed, 47 insertions(+), 140 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 19a2f1ba9b..bfe01d25be 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -216,7 +216,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! above the leaf layer of interest real(r8) :: lai_current ! the LAI in the current leaf layer real(r8) :: cumulative_lai ! the cumulative LAI, top down, to the leaf layer of interest - real(r8) :: psi_leaf ! xylem water potential of leaf + real(r8), allocatable :: rootfr_ft(:,:) ! Root fractions per depth and PFT ! ----------------------------------------------------------------------------------- @@ -399,9 +399,9 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) (hlm_parteh_mode .ne. prt_carbon_allom_hyp ) ) then if (hlm_use_planthydro.eq.itrue ) then - psi_leaf = currentCohort%co_hydr%psi_ag(1) - bbb = max( cf/rsmax0, bbbopt(nint(c3psn(ft)))*currentCohort%co_hydr%btran ) - btran_eff = currentCohort%co_hydr%btran + + stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(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 @@ -530,10 +530,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) bc_in(s)%forc_pbot, & ! in bc_in(s)%cair_pa(ifp), & ! in bc_in(s)%oair_pa(ifp), & ! in - bc_in(s)%rb_pa(ifp), & ! in btran_eff, & ! in - psi_leaf, & ! in - bbb, & ! in + stomatal_intercept_btran, & ! in cf, & ! in gb_mol, & ! in ceair, & ! in @@ -848,10 +846,8 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in can_press, & ! in can_co2_ppress, & ! in can_o2_ppress, & ! in - rb, & ! in btran, & ! in - psi, & ! in - bbb, & ! in + stomatal_intercept_btran, & ! in cf, & ! in gb_mol, & ! in ceair, & ! in @@ -948,31 +944,15 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) real(r8) :: init_co2_inter_c ! First guess intercellular co2 specific to C path + real(r8) :: term ! intermediate variable in Medlyn stomatal conductance model + real(r8) :: vpd ! water vapor deficit in Medlyn stomatal model (KPa) + - real(r8), dimension(0:1) :: bbbopt ! Cuticular conductance at full water potential (umol H2O /m2/s) - - real(r8) :: psi ! Xylem Water potential of leaf - real(r8) :: gstoma_out ! Adjusted stoma conductance that incorporates the leaf water status - real(r8) :: qs ! specific humidity at leaf surface - real(r8) :: qsat ! saturated specific humidity - real(r8) :: qsat_adj ! specific humidity adjusted by leaf water potential (g/kg) - real(r8) :: veg_esat_adj ! vapor pressure adjusted by leaf water potential () - real(r8) :: LWP_star ! leaf water potential scaling coefficient for inner leaf humidity - real(r8) :: k_lwp = 8.0_r8 ! an sclaing coefficient for the ratio of leaf xylem water potential to mesophyll water potential - real(r8) :: th_sat ! saturated water content of leaf m3/m3 - real(r8) :: th_rs ! residual waater content of leaf m3/m3 - real(r8) :: rb ! leaf boundary layer ressistance ! Parameters ! ------------------------------------------------------------------------ - ! selection to use agross or anet in stomatal models, 1 - use agross, other values - use anet - integer,parameter :: use_agross = 1 - ! Fraction of light absorbed by non-photosynthetic pigments - real(r8),parameter :: fnps = 0.15_r8 - - ! For plants with no leaves, a miniscule amount of conductance ! can happen through the stems, at a partial rate of cuticular conductance real(r8),parameter :: stem_cuticle_loss_frac = 0.1_r8 @@ -1129,23 +1109,16 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in call quadratic_f (aquad, bquad, cquad, r1, r2) agross = min(r1,r2) - - !!! Junyan replace anet in the belowing code to agross for gs calculation - !!! this is version B - anet = agross - lmr - if (use_agross == 1) then - else - if (anet < 0._r8) then - loop_continue = .false. - end if - end if + ! Net carbon assimilation. Exit iteration if an < 0 + anet = agross - lmr + if (anet < 0._r8) then + loop_continue = .false. + end if ! Quadratic gs_mol calculation with an known. Valid for an >= 0. - ! With an <= 0, then gs_mol = bbb - - leaf_co2_ppress = can_co2_ppress- 1.4_r8/gb_mol * agross * can_press + ! With an <= 0, then gs_mol = stomatal_intercept_btran + leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) - if ( stomatal_model == 2 ) then !stomatal conductance calculated from Medlyn et al. (2011), the numerical & !implementation was adapted from the equations in CLM5.0 @@ -1158,35 +1131,22 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in cquad = stomatal_intercept_btran*stomatal_intercept_btran + & (2.0*stomatal_intercept_btran + term * & (1.0 - medlyn_slope(ft)* medlyn_slope(ft) / vpd)) * term - + call quadratic_f (aquad, bquad, cquad, r1, r2) gs_mol = max(r1,r2) - else if ( stomatal_model == 1 ) then !stomatal conductance calculated from Ball et al. (1987) - if (use_agross == 1) then + else if ( stomatal_model == 1 ) then !stomatal conductance calculated from Ball et al. (1987) aquad = leaf_co2_ppress - bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * agross * can_press + bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * anet * can_press cquad = -gb_mol*(leaf_co2_ppress*stomatal_intercept_btran + & - bb_slope(ft)*agross*can_press * ceair/ veg_esat ) - else - aquad = leaf_co2_ppress - bquad = leaf_co2_ppress*(gb_mol - bbb) - bb_slope(ft) * anet * can_press - cquad = -gb_mol*(leaf_co2_ppress*bbb + & bb_slope(ft)*anet*can_press * ceair/ veg_esat ) - end if - call quadratic_f (aquad, bquad, cquad, r1, r2) - gs_mol = max(r1,r2) - end if + + call quadratic_f (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) + end if ! Derive new estimate for co2_inter_c - if (use_agross == 1) then - co2_inter_c = can_co2_ppress - agross * can_press * & - (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - else co2_inter_c = can_co2_ppress - anet * can_press * & (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - end if - ! end of Junyan's change for gs calculation - ! Check for co2_inter_c convergence. Delta co2_inter_c/pair = mol/mol. ! Multiply by 10**6 to convert to umol/mol (ppm). Exit iteration if @@ -1199,17 +1159,18 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in end if end do !iteration loop - ! End of co2_inter_c iteration. Check for an < 0, in which case gs_mol = bbb - if (agross < 0._r8) then - gs_mol = bbb + ! End of co2_inter_c iteration. Check for an < 0, in which case + ! gs_mol =stomatal_intercept_btran + if (anet < 0._r8) then + gs_mol = stomatal_intercept_btran end if ! Final estimates for leaf_co2_ppress and co2_inter_c ! (needed for early exit of co2_inter_c iteration when an < 0) - leaf_co2_ppress = can_co2_ppress - 1.4_r8/gb_mol * agross * can_press + leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) - co2_inter_c = can_co2_ppress - agross * can_press * & - (1.4_r8*gs_mol+1.6_r8*gb_mol) / (gb_mol*gs_mol) + co2_inter_c = can_co2_ppress - anet * can_press * & + (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) ! Convert gs_mol (umol /m**2/s) to gs (m/s) and then to rs (s/m) gs = gs_mol / cf @@ -1244,11 +1205,16 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in write (fates_log(),*)'gs_mol= ',gs_mol call endrun(msg=errMsg(sourcefile, __LINE__)) end if - - ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress p + b - hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) - gs_mol_err = bb_slope(ft)*max(agross, 0._r8)*hs/leaf_co2_ppress*can_press + bbb - + + ! Compare with Medlyn model: gs_mol = 1.6*(1+m/sqrt(vpd)) * an/leaf_co2_ppress*p + b + if ( stomatal_model == 2 ) then + gs_mol_err = h2o_co2_stoma_diffuse_ratio*(1 + medlyn_slope(ft)/sqrt(vpd))*max(anet,0._r8)/leaf_co2_ppress*can_press + stomatal_intercept_btran + ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress*p + b + else if ( stomatal_model == 1 ) then + hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) + gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/leaf_co2_ppress*can_press + stomatal_intercept_btran + end if + if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then write (fates_log(),*) 'Stomatal model error check - stomatal conductance error:' write (fates_log(),*) gs_mol, gs_mol_err @@ -1256,68 +1222,9 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in enddo !sunsha loop - ! This is the stomatal resistance of the leaf layer of a given cohort - - ! Junyan addition to correct the gs - ! compute specific humidity from vapor pressure - ! q = 0.622*e/(can_press - 0.378*e) - ! source https://cran.r-project.org/web/packages/humidity/vignettes/humidity-measures.html - - if (hlm_use_planthydro.eq.itrue) then - - !Calculates inner leaf humidity as a function of mesophyll water potential - ! Adopted from Vesala et la., 2017 https://www.frontiersin.org/articles/10.3389/fpls.2017.00054/full - ! LWP_star = wi/w0 = exp(psi_meso*Vh20/(R*T)) , w is the water vapor concentration - ! Vh20: molar volume of water (18 × 10−6 m3 mol−1) - ! R is the universal gas constant and T the interfacial temperature - ! - ! th_sat = EDPftvarcon_inst%hydr_thetas_node(ft,1) - ! th_rs = EDPftvarcon_inst%hydr_resid_node(ft,1) - - k_lwp = EDPftvarcon_inst%hydr_k_lwp(ft) - if (psi<0) then - LWP_star = exp(((k_lwp) * psi)*18.0_r8/(8.314_r8*veg_tempk)) - ! k_lwp**btran - else - LWP_star = 1 - end if - ! now adjust veg_esat by LWP_star - veg_esat_adj = veg_esat*LWP_star - - ! note: q is the specific humidity - qs = 0.622 * ceair / (can_press - 0.378 * ceair) - qsat = 0.622 * veg_esat / (can_press - 0.378 * veg_esat) - ! qsat_adj = 0.622 * veg_esat_adj / (can_press - 0.378 * veg_esat_adj) - qsat_adj = qsat*LWP_star - - ! write (fates_log(),*) 'qsat:', qsat, 'RHleaf:', qsat_adj/qsat, 'RHs:', qs/qsat - if (k_lwp == 0 ) then - rstoma_out = 1._r8/gstoma - else - if ((qsat_adj - qs) <= 0) then - ! write (fates_log(),*) 'LWP_star:', LWP_star - ! write (fates_log(),*) 'qleaf:', qsat * LWP_star, 'qs',qs - ! if inner leaf vapor pressure is less then or equal to that at leaf surface - ! then set stomata resistance to be very large to stop the transpiration or back flow of vapor - rstoma_out = rsmax0*100 - else - rstoma_out = (qsat-qs)*( 1/gstoma + rb)/(qsat_adj - qs)-rb - - end if - if (rstoma_out <=0 ) then - ! write (fates_log(),*) 'code line 1244' - ! write (fates_log(),*) 'qsat:', qsat, 'qs:', qs - ! write (fates_log(),*) 'LWP :', psi, 'BTRAN:', th_rs, 'th:', th - ! write (fates_log(),*) 'ceair:', ceair, 'veg_esat:', veg_esat - ! write (fates_log(),*) 'rstoma_out:', rstoma_out, 'rb:', rb - ! write (fates_log(),*) 'LWP_star', LWP_star - ! call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if ! k_lwp == 0 - else - rstoma_out = 1._r8/gstoma - end if - ! end of Junyan modification + ! This is the stomatal resistance of the leaf layer + rstoma_out = 1._r8/gstoma + else ! No leaf area. This layer is present only because of stems. @@ -1348,7 +1255,7 @@ subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv lmr_llz, & ! in lmr_z(1:currentCohort%nv,ft,cl) rs_llz, & ! in rs_z(1:currentCohort%nv,ft,cl) elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) - c13disc_llz, & ! in c13disc_z(cl, ft, 1:currentCohort%nv) + c13disc_llz, & ! in c13disc_z(cl, ft, 1:currentCohort%nv) c_area, & ! in currentCohort%c_area nplant, & ! in currentCohort%n rb, & ! in bc_in(s)%rb_pa(ifp) @@ -1356,7 +1263,7 @@ subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv g_sb_laweight, & ! out currentCohort%g_sb_laweight [m/s] [m2-leaf] gpp, & ! out currentCohort%gpp_tstep rdark, & ! out currentCohort%rdark - c13disc_clm, & ! out currentCohort%c13disc_clm + c13disc_clm, & ! out currentCohort%c13disc_clm cohort_eleaf_area ) ! out [m2] ! ------------------------------------------------------------------------------------ @@ -1397,7 +1304,7 @@ subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv real(r8) :: cohort_layer_eleaf_area ! the effective leaf area of the cohort's current layer [m2] cohort_eleaf_area = 0.0_r8 - g_sb_laweight = 0.0_r8 + g_sb_laweight = 0.0_r8 gpp = 0.0_r8 rdark = 0.0_r8 @@ -1781,7 +1688,7 @@ subroutine GetCanopyGasParameters(can_press, & real(r8), parameter :: mm_kc25_umol_per_mol = 404.9_r8 real(r8), parameter :: mm_ko25_mmol_per_mol = 278.4_r8 - real(r8), parameter :: co2_cpoint_umol_per_mol = 42.75_r8 + real(r8), parameter :: co2_cpoint_umol_per_mol = 42.75_r8 ! Activation energy, from: ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 From b974c17b936352004fb95a3333c149ba54db341b Mon Sep 17 00:00:00 2001 From: Junyan Ding Date: Sat, 27 Mar 2021 21:38:30 -0700 Subject: [PATCH 233/578] update1 --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 187 +++++++++++++++------ 1 file changed, 140 insertions(+), 47 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index bfe01d25be..19a2f1ba9b 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -216,7 +216,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! above the leaf layer of interest real(r8) :: lai_current ! the LAI in the current leaf layer real(r8) :: cumulative_lai ! the cumulative LAI, top down, to the leaf layer of interest - + real(r8) :: psi_leaf ! xylem water potential of leaf real(r8), allocatable :: rootfr_ft(:,:) ! Root fractions per depth and PFT ! ----------------------------------------------------------------------------------- @@ -399,9 +399,9 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) (hlm_parteh_mode .ne. prt_carbon_allom_hyp ) ) then if (hlm_use_planthydro.eq.itrue ) then - - stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentCohort%co_hydr%btran ) - btran_eff = currentCohort%co_hydr%btran + psi_leaf = currentCohort%co_hydr%psi_ag(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 @@ -530,8 +530,10 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) bc_in(s)%forc_pbot, & ! in bc_in(s)%cair_pa(ifp), & ! in bc_in(s)%oair_pa(ifp), & ! in + bc_in(s)%rb_pa(ifp), & ! in btran_eff, & ! in - stomatal_intercept_btran, & ! in + psi_leaf, & ! in + bbb, & ! in cf, & ! in gb_mol, & ! in ceair, & ! in @@ -846,8 +848,10 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in can_press, & ! in can_co2_ppress, & ! in can_o2_ppress, & ! in + rb, & ! in btran, & ! in - stomatal_intercept_btran, & ! in + psi, & ! in + bbb, & ! in cf, & ! in gb_mol, & ! in ceair, & ! in @@ -944,15 +948,31 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) real(r8) :: init_co2_inter_c ! First guess intercellular co2 specific to C path - real(r8) :: term ! intermediate variable in Medlyn stomatal conductance model - real(r8) :: vpd ! water vapor deficit in Medlyn stomatal model (KPa) - + real(r8), dimension(0:1) :: bbbopt ! Cuticular conductance at full water potential (umol H2O /m2/s) + + real(r8) :: psi ! Xylem Water potential of leaf + real(r8) :: gstoma_out ! Adjusted stoma conductance that incorporates the leaf water status + real(r8) :: qs ! specific humidity at leaf surface + real(r8) :: qsat ! saturated specific humidity + real(r8) :: qsat_adj ! specific humidity adjusted by leaf water potential (g/kg) + real(r8) :: veg_esat_adj ! vapor pressure adjusted by leaf water potential () + real(r8) :: LWP_star ! leaf water potential scaling coefficient for inner leaf humidity + real(r8) :: k_lwp = 8.0_r8 ! an sclaing coefficient for the ratio of leaf xylem water potential to mesophyll water potential + real(r8) :: th_sat ! saturated water content of leaf m3/m3 + real(r8) :: th_rs ! residual waater content of leaf m3/m3 + real(r8) :: rb ! leaf boundary layer ressistance ! Parameters ! ------------------------------------------------------------------------ + ! selection to use agross or anet in stomatal models, 1 - use agross, other values - use anet + integer,parameter :: use_agross = 1 + ! Fraction of light absorbed by non-photosynthetic pigments + real(r8),parameter :: fnps = 0.15_r8 + + ! For plants with no leaves, a miniscule amount of conductance ! can happen through the stems, at a partial rate of cuticular conductance real(r8),parameter :: stem_cuticle_loss_frac = 0.1_r8 @@ -1109,16 +1129,23 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in call quadratic_f (aquad, bquad, cquad, r1, r2) agross = min(r1,r2) - ! Net carbon assimilation. Exit iteration if an < 0 - anet = agross - lmr - if (anet < 0._r8) then - loop_continue = .false. - end if + + !!! Junyan replace anet in the belowing code to agross for gs calculation + !!! this is version B + anet = agross - lmr + if (use_agross == 1) then + else + if (anet < 0._r8) then + loop_continue = .false. + end if + end if ! Quadratic gs_mol calculation with an known. Valid for an >= 0. - ! With an <= 0, then gs_mol = stomatal_intercept_btran - leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press + ! With an <= 0, then gs_mol = bbb + + leaf_co2_ppress = can_co2_ppress- 1.4_r8/gb_mol * agross * can_press leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + if ( stomatal_model == 2 ) then !stomatal conductance calculated from Medlyn et al. (2011), the numerical & !implementation was adapted from the equations in CLM5.0 @@ -1131,22 +1158,35 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in cquad = stomatal_intercept_btran*stomatal_intercept_btran + & (2.0*stomatal_intercept_btran + term * & (1.0 - medlyn_slope(ft)* medlyn_slope(ft) / vpd)) * term - + call quadratic_f (aquad, bquad, cquad, r1, r2) gs_mol = max(r1,r2) - else if ( stomatal_model == 1 ) then !stomatal conductance calculated from Ball et al. (1987) + else if ( stomatal_model == 1 ) then !stomatal conductance calculated from Ball et al. (1987) + if (use_agross == 1) then aquad = leaf_co2_ppress - bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * anet * can_press + bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * agross * can_press cquad = -gb_mol*(leaf_co2_ppress*stomatal_intercept_btran + & + bb_slope(ft)*agross*can_press * ceair/ veg_esat ) + else + aquad = leaf_co2_ppress + bquad = leaf_co2_ppress*(gb_mol - bbb) - bb_slope(ft) * anet * can_press + cquad = -gb_mol*(leaf_co2_ppress*bbb + & bb_slope(ft)*anet*can_press * ceair/ veg_esat ) - - call quadratic_f (aquad, bquad, cquad, r1, r2) - gs_mol = max(r1,r2) - end if + end if + call quadratic_f (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) + end if ! Derive new estimate for co2_inter_c + if (use_agross == 1) then + co2_inter_c = can_co2_ppress - agross * can_press * & + (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) + else co2_inter_c = can_co2_ppress - anet * can_press * & (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) + end if + ! end of Junyan's change for gs calculation + ! Check for co2_inter_c convergence. Delta co2_inter_c/pair = mol/mol. ! Multiply by 10**6 to convert to umol/mol (ppm). Exit iteration if @@ -1159,18 +1199,17 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in end if end do !iteration loop - ! End of co2_inter_c iteration. Check for an < 0, in which case - ! gs_mol =stomatal_intercept_btran - if (anet < 0._r8) then - gs_mol = stomatal_intercept_btran + ! End of co2_inter_c iteration. Check for an < 0, in which case gs_mol = bbb + if (agross < 0._r8) then + gs_mol = bbb end if ! Final estimates for leaf_co2_ppress and co2_inter_c ! (needed for early exit of co2_inter_c iteration when an < 0) - leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press + leaf_co2_ppress = can_co2_ppress - 1.4_r8/gb_mol * agross * can_press leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) - co2_inter_c = can_co2_ppress - anet * can_press * & - (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) + co2_inter_c = can_co2_ppress - agross * can_press * & + (1.4_r8*gs_mol+1.6_r8*gb_mol) / (gb_mol*gs_mol) ! Convert gs_mol (umol /m**2/s) to gs (m/s) and then to rs (s/m) gs = gs_mol / cf @@ -1205,16 +1244,11 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in write (fates_log(),*)'gs_mol= ',gs_mol call endrun(msg=errMsg(sourcefile, __LINE__)) end if - - ! Compare with Medlyn model: gs_mol = 1.6*(1+m/sqrt(vpd)) * an/leaf_co2_ppress*p + b - if ( stomatal_model == 2 ) then - gs_mol_err = h2o_co2_stoma_diffuse_ratio*(1 + medlyn_slope(ft)/sqrt(vpd))*max(anet,0._r8)/leaf_co2_ppress*can_press + stomatal_intercept_btran - ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress*p + b - else if ( stomatal_model == 1 ) then - hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) - gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/leaf_co2_ppress*can_press + stomatal_intercept_btran - end if - + + ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress p + b + hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) + gs_mol_err = bb_slope(ft)*max(agross, 0._r8)*hs/leaf_co2_ppress*can_press + bbb + if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then write (fates_log(),*) 'Stomatal model error check - stomatal conductance error:' write (fates_log(),*) gs_mol, gs_mol_err @@ -1222,9 +1256,68 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in enddo !sunsha loop - ! This is the stomatal resistance of the leaf layer - rstoma_out = 1._r8/gstoma - + ! This is the stomatal resistance of the leaf layer of a given cohort + + ! Junyan addition to correct the gs + ! compute specific humidity from vapor pressure + ! q = 0.622*e/(can_press - 0.378*e) + ! source https://cran.r-project.org/web/packages/humidity/vignettes/humidity-measures.html + + if (hlm_use_planthydro.eq.itrue) then + + !Calculates inner leaf humidity as a function of mesophyll water potential + ! Adopted from Vesala et la., 2017 https://www.frontiersin.org/articles/10.3389/fpls.2017.00054/full + ! LWP_star = wi/w0 = exp(psi_meso*Vh20/(R*T)) , w is the water vapor concentration + ! Vh20: molar volume of water (18 × 10−6 m3 mol−1) + ! R is the universal gas constant and T the interfacial temperature + ! + ! th_sat = EDPftvarcon_inst%hydr_thetas_node(ft,1) + ! th_rs = EDPftvarcon_inst%hydr_resid_node(ft,1) + + k_lwp = EDPftvarcon_inst%hydr_k_lwp(ft) + if (psi<0) then + LWP_star = exp(((k_lwp) * psi)*18.0_r8/(8.314_r8*veg_tempk)) + ! k_lwp**btran + else + LWP_star = 1 + end if + ! now adjust veg_esat by LWP_star + veg_esat_adj = veg_esat*LWP_star + + ! note: q is the specific humidity + qs = 0.622 * ceair / (can_press - 0.378 * ceair) + qsat = 0.622 * veg_esat / (can_press - 0.378 * veg_esat) + ! qsat_adj = 0.622 * veg_esat_adj / (can_press - 0.378 * veg_esat_adj) + qsat_adj = qsat*LWP_star + + ! write (fates_log(),*) 'qsat:', qsat, 'RHleaf:', qsat_adj/qsat, 'RHs:', qs/qsat + if (k_lwp == 0 ) then + rstoma_out = 1._r8/gstoma + else + if ((qsat_adj - qs) <= 0) then + ! write (fates_log(),*) 'LWP_star:', LWP_star + ! write (fates_log(),*) 'qleaf:', qsat * LWP_star, 'qs',qs + ! if inner leaf vapor pressure is less then or equal to that at leaf surface + ! then set stomata resistance to be very large to stop the transpiration or back flow of vapor + rstoma_out = rsmax0*100 + else + rstoma_out = (qsat-qs)*( 1/gstoma + rb)/(qsat_adj - qs)-rb + + end if + if (rstoma_out <=0 ) then + ! write (fates_log(),*) 'code line 1244' + ! write (fates_log(),*) 'qsat:', qsat, 'qs:', qs + ! write (fates_log(),*) 'LWP :', psi, 'BTRAN:', th_rs, 'th:', th + ! write (fates_log(),*) 'ceair:', ceair, 'veg_esat:', veg_esat + ! write (fates_log(),*) 'rstoma_out:', rstoma_out, 'rb:', rb + ! write (fates_log(),*) 'LWP_star', LWP_star + ! call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if ! k_lwp == 0 + else + rstoma_out = 1._r8/gstoma + end if + ! end of Junyan modification else ! No leaf area. This layer is present only because of stems. @@ -1255,7 +1348,7 @@ subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv lmr_llz, & ! in lmr_z(1:currentCohort%nv,ft,cl) rs_llz, & ! in rs_z(1:currentCohort%nv,ft,cl) elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) - c13disc_llz, & ! in c13disc_z(cl, ft, 1:currentCohort%nv) + c13disc_llz, & ! in c13disc_z(cl, ft, 1:currentCohort%nv) c_area, & ! in currentCohort%c_area nplant, & ! in currentCohort%n rb, & ! in bc_in(s)%rb_pa(ifp) @@ -1263,7 +1356,7 @@ subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv g_sb_laweight, & ! out currentCohort%g_sb_laweight [m/s] [m2-leaf] gpp, & ! out currentCohort%gpp_tstep rdark, & ! out currentCohort%rdark - c13disc_clm, & ! out currentCohort%c13disc_clm + c13disc_clm, & ! out currentCohort%c13disc_clm cohort_eleaf_area ) ! out [m2] ! ------------------------------------------------------------------------------------ @@ -1304,7 +1397,7 @@ subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv real(r8) :: cohort_layer_eleaf_area ! the effective leaf area of the cohort's current layer [m2] cohort_eleaf_area = 0.0_r8 - g_sb_laweight = 0.0_r8 + g_sb_laweight = 0.0_r8 gpp = 0.0_r8 rdark = 0.0_r8 @@ -1688,7 +1781,7 @@ subroutine GetCanopyGasParameters(can_press, & real(r8), parameter :: mm_kc25_umol_per_mol = 404.9_r8 real(r8), parameter :: mm_ko25_mmol_per_mol = 278.4_r8 - real(r8), parameter :: co2_cpoint_umol_per_mol = 42.75_r8 + real(r8), parameter :: co2_cpoint_umol_per_mol = 42.75_r8 ! Activation energy, from: ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 From 76a9bbb6c4821fdfab963e74cc13a0732a4b6786 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 29 Mar 2021 10:15:25 -0600 Subject: [PATCH 234/578] changing aerodynamic property weighting --- biogeochem/EDCanopyStructureMod.F90 | 43 +++++++++++++++-------------- 1 file changed, 23 insertions(+), 20 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index bd34ef9bfc..cc563e6a19 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1919,28 +1919,31 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) - ! Use leaf area weighting for all cohorts in the patch to define the characteristic - ! leaf width used by the HLM + ! Use canopy-only crown area weighting for all cohorts in the patch to define the characteristic + ! leaf width Roughness length and displacement height used by the HLM ! ---------------------------------------------------------------------------- -! bc_out(s)%dleaf_pa(ifp) = 0.0_r8 -! if(currentPatch%lai>1.0e-9_r8) then -! currentCohort => currentPatch%shortest -! do while(associated(currentCohort)) -! weight = min(1.0_r8,currentCohort%lai/currentPatch%lai) -! bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & -! EDPftvarcon_inst%dleaf(currentCohort%pft)*weight -! currentCohort => currentCohort%taller -! enddo -! end if - - ! Roughness length and displacement height are not PFT properties, they are - ! properties of the canopy assemblage. Defining this needs an appropriate model. - ! Right now z0 and d are pft level parameters. For the time being we will just - ! use the 1st index until a suitable model is defined. (RGK 04-2017) + + if (currentPatch%total_canopy_area > nearzero) then + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + if (currentCohort%canopy_layer .eq. 1) then + weight = min(1.0_r8,currentCohort%c_area/currentPatch%total_canopy_area) + bc_out(s)%z0m_pa(ifp) = bc_out(s)%z0m_pa(ifp) + & + EDPftvarcon_inst%z0mr(currentCohort%pft) * weight + bc_out(s)%displa_pa(ifp) = bc_out(s)%displa_pa(ifp) + & + EDPftvarcon_inst%displar(currentCohort%pft) * weight + bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & + EDPftvarcon_inst%dleaf(currentCohort%pft) * weight + currentCohort => currentCohort%taller + endif + end do + else + ! if no canopy, then use dummy values (first PFT) of aerodynamic properties + bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) + endif ! ----------------------------------------------------------------------------- - bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(1) * bc_out(s)%htop_pa(ifp) - bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) - bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) ! We are assuming here that grass is all located underneath tree canopies. From 343ab78a1eff3efbd95bb760eb2e8aa1c0c16a6c Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 29 Mar 2021 11:22:13 -0600 Subject: [PATCH 235/578] updates on new canopy scaling --- biogeochem/EDCanopyStructureMod.F90 | 53 +++++++++++++++++++++++++---- 1 file changed, 47 insertions(+), 6 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index cc563e6a19..64c4d1f3ff 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1890,6 +1890,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) real(r8) :: bare_frac_area real(r8) :: total_patch_area real(r8) :: total_canopy_area + real(r8) :: total_patch_leaf_stem_area real(r8) :: weight ! Weighting for cohort variables in patch @@ -1899,6 +1900,9 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) total_patch_area = 0._r8 total_canopy_area = 0._r8 bc_out(s)%canopy_fraction_pa(:) = 0._r8 + bc_out(s)%dleaf_pa(:) = 0._r8 + bc_out(s)%z0m_pa(:) = 0._r8 + bc_out(s)%displa_pa(:) = 0._r8 currentPatch => sites(s)%oldest_patch c = fcolumn(s) do while(associated(currentPatch)) @@ -1920,23 +1924,60 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) ! Use canopy-only crown area weighting for all cohorts in the patch to define the characteristic - ! leaf width Roughness length and displacement height used by the HLM + ! Roughness length and displacement height used by the HLM + ! use total LAI + SAI to weight the leaft characteristic dimension ! ---------------------------------------------------------------------------- if (currentPatch%total_canopy_area > nearzero) then - currentCohort => currentPatch%shortest + currentCohort => currentPatch%shortest do while(associated(currentCohort)) if (currentCohort%canopy_layer .eq. 1) then weight = min(1.0_r8,currentCohort%c_area/currentPatch%total_canopy_area) bc_out(s)%z0m_pa(ifp) = bc_out(s)%z0m_pa(ifp) + & - EDPftvarcon_inst%z0mr(currentCohort%pft) * weight + EDPftvarcon_inst%z0mr(currentCohort%pft) * currentCohort%hite * weight bc_out(s)%displa_pa(ifp) = bc_out(s)%displa_pa(ifp) + & - EDPftvarcon_inst%displar(currentCohort%pft) * weight + EDPftvarcon_inst%displar(currentCohort%pft) * currentCohort%hite * weight + endif + currentCohort => currentCohort%taller + end do + + ! for lai, scale to total LAI + SAI in patch. first add up all the LAI and SAI in the patch + total_patch_leaf_stem_area = 0._r8 + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + + ! mkae sure that allometries are correct + call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& + currentCohort%pft,currentCohort%c_area) + + currentCohort%treelai = tree_lai(currentCohort%prt%GetState(leaf_organ, all_carbon_elements), & + currentCohort%pft, currentCohort%c_area, currentCohort%n, & + currentCohort%canopy_layer, currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + + currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & + currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai, currentCohort%treelai , & + currentCohort%vcmax25top,4) + + total_patch_leaf_stem_area = total_patch_leaf_stem_area + & + (currentCohort%treelai + currentCohort%treesai) * currentCohort%c_area + currentCohort => currentCohort%taller + end do + + ! make sure there is some leaf and stem area + if (total_patch_leaf_stem_area > nearzero) then + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + ! weight dleaf by the relative totals of leaf and stem area + weight = (currentCohort%treelai + currentCohort%treesai) * currentCohort%c_area / total_patch_leaf_stem_area bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & EDPftvarcon_inst%dleaf(currentCohort%pft) * weight currentCohort => currentCohort%taller - endif - end do + end do + else + ! dummy case + bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) + endif else ! if no canopy, then use dummy values (first PFT) of aerodynamic properties bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(1) * bc_out(s)%htop_pa(ifp) From 9ab3ae28037a18372f9454d7f8402757336b0f64 Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Mon, 29 Mar 2021 12:41:15 -0700 Subject: [PATCH 236/578] Update FatesPlantRespPhotosynthMod.F90 --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 36 ++++++++++++++-------- 1 file changed, 23 insertions(+), 13 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 19a2f1ba9b..9ddeea3d6e 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -400,7 +400,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) if (hlm_use_planthydro.eq.itrue ) then psi_leaf = currentCohort%co_hydr%psi_ag(1) - bbb = max( cf/rsmax0, bbbopt(nint(c3psn(ft)))*currentCohort%co_hydr%btran ) + stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentCohort%co_hydr%btran ) btran_eff = currentCohort%co_hydr%btran ! dinc_ed is the total vegetation area index of each "leaf" layer @@ -533,7 +533,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) bc_in(s)%rb_pa(ifp), & ! in btran_eff, & ! in psi_leaf, & ! in - bbb, & ! in + stomatal_intercept_btran, & ! in cf, & ! in gb_mol, & ! in ceair, & ! in @@ -851,7 +851,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in rb, & ! in btran, & ! in psi, & ! in - bbb, & ! in + stomatal_intercept_btran, & ! in cf, & ! in gb_mol, & ! in ceair, & ! in @@ -948,7 +948,9 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) real(r8) :: init_co2_inter_c ! First guess intercellular co2 specific to C path - + real(r8) :: term ! intermediate variable in Medlyn stomatal conductance model + real(r8) :: vpd ! water vapor deficit in Medlyn stomatal model (KPa) + real(r8), dimension(0:1) :: bbbopt ! Cuticular conductance at full water potential (umol H2O /m2/s) real(r8) :: psi ! Xylem Water potential of leaf @@ -1130,8 +1132,9 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in agross = min(r1,r2) - !!! Junyan replace anet in the belowing code to agross for gs calculation - !!! this is version B + !!! Calculate anet, only exit iteration with negative anet when using anet in + ! gs + ! this is version B anet = agross - lmr if (use_agross == 1) then else @@ -1143,7 +1146,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! Quadratic gs_mol calculation with an known. Valid for an >= 0. ! With an <= 0, then gs_mol = bbb - leaf_co2_ppress = can_co2_ppress- 1.4_r8/gb_mol * agross * can_press + leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * agross * can_press leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) if ( stomatal_model == 2 ) then @@ -1200,16 +1203,23 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in end do !iteration loop ! End of co2_inter_c iteration. Check for an < 0, in which case gs_mol = bbb - if (agross < 0._r8) then - gs_mol = bbb + if (use_agross == 1) then + if (agross < 0._r8) then + gs_mol = stomatal_intercept_btran + end if + + else + if (anet < 0._r8) then + gs_mol = stomatal_intercept_btran + end if end if - + ! Final estimates for leaf_co2_ppress and co2_inter_c ! (needed for early exit of co2_inter_c iteration when an < 0) - leaf_co2_ppress = can_co2_ppress - 1.4_r8/gb_mol * agross * can_press + leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * agross * can_press leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) co2_inter_c = can_co2_ppress - agross * can_press * & - (1.4_r8*gs_mol+1.6_r8*gb_mol) / (gb_mol*gs_mol) + (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) ! Convert gs_mol (umol /m**2/s) to gs (m/s) and then to rs (s/m) gs = gs_mol / cf @@ -1258,7 +1268,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! This is the stomatal resistance of the leaf layer of a given cohort - ! Junyan addition to correct the gs + ! Adjusting gs (compute a virtual gs) that will be passed to host model ! compute specific humidity from vapor pressure ! q = 0.622*e/(can_press - 0.378*e) ! source https://cran.r-project.org/web/packages/humidity/vignettes/humidity-measures.html From 20679950644626946fa7d1829b37349ddc052774 Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Mon, 29 Mar 2021 12:44:33 -0700 Subject: [PATCH 237/578] Update FatesPlantRespPhotosynthMod.F90 --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 9ddeea3d6e..dbeeea51af 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -1255,10 +1255,14 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in call endrun(msg=errMsg(sourcefile, __LINE__)) end if - ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress p + b - hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) - gs_mol_err = bb_slope(ft)*max(agross, 0._r8)*hs/leaf_co2_ppress*can_press + bbb - + ! Compare with Medlyn model: gs_mol = 1.6*(1+m/sqrt(vpd)) * an/leaf_co2_ppress*p + b + if ( stomatal_model == 2 ) then + gs_mol_err = h2o_co2_stoma_diffuse_ratio*(1 + medlyn_slope(ft)/sqrt(vpd))*max(anet,0._r8)/leaf_co2_ppress*can_press + stomatal_intercept_btran + ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress*p + b + else if ( stomatal_model == 1 ) then + hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) + gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/leaf_co2_ppress*can_press + stomatal_intercept_btran + end if if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then write (fates_log(),*) 'Stomatal model error check - stomatal conductance error:' write (fates_log(),*) gs_mol, gs_mol_err @@ -1358,7 +1362,7 @@ subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv lmr_llz, & ! in lmr_z(1:currentCohort%nv,ft,cl) rs_llz, & ! in rs_z(1:currentCohort%nv,ft,cl) elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) - c13disc_llz, & ! in c13disc_z(cl, ft, 1:currentCohort%nv) + c13disc_llz, & ! in c13disc_z(cl, ft, 1:currentCohort%nv) c_area, & ! in currentCohort%c_area nplant, & ! in currentCohort%n rb, & ! in bc_in(s)%rb_pa(ifp) @@ -1366,7 +1370,7 @@ subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv g_sb_laweight, & ! out currentCohort%g_sb_laweight [m/s] [m2-leaf] gpp, & ! out currentCohort%gpp_tstep rdark, & ! out currentCohort%rdark - c13disc_clm, & ! out currentCohort%c13disc_clm + c13disc_clm, & ! out currentCohort%c13disc_clm cohort_eleaf_area ) ! out [m2] ! ------------------------------------------------------------------------------------ @@ -1407,7 +1411,7 @@ subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv real(r8) :: cohort_layer_eleaf_area ! the effective leaf area of the cohort's current layer [m2] cohort_eleaf_area = 0.0_r8 - g_sb_laweight = 0.0_r8 + g_sb_laweight = 0.0_r8 gpp = 0.0_r8 rdark = 0.0_r8 From 59d43b7d2595017a9165d7cf14d2fea7b03294e1 Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Mon, 29 Mar 2021 12:47:35 -0700 Subject: [PATCH 238/578] Update FatesPlantRespPhotosynthMod.F90 --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index dbeeea51af..0ed6ee3da0 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -1132,8 +1132,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in agross = min(r1,r2) - !!! Calculate anet, only exit iteration with negative anet when using anet in - ! gs + !!! Calculate anet, only exit iteration with negative anet when using anet in calculating gs ! this is version B anet = agross - lmr if (use_agross == 1) then From 1cdb0e7c3f364bb506f77914c3873881bf7e1dfc Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Mon, 29 Mar 2021 13:54:57 -0700 Subject: [PATCH 239/578] Update FatesPlantRespPhotosynthMod.F90 --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 0ed6ee3da0..b58864e0d9 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -1136,16 +1136,19 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! this is version B anet = agross - lmr if (use_agross == 1) then + leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * agross * can_press else if (anet < 0._r8) then loop_continue = .false. end if + ! With an <= 0, then gs_mol = stomatal_intercept_btran, adjusted on L1214 + leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press end if ! Quadratic gs_mol calculation with an known. Valid for an >= 0. ! With an <= 0, then gs_mol = bbb - leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * agross * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) if ( stomatal_model == 2 ) then From dc79307ccc16f9de7e7fe86cbec2639f0121e529 Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Mon, 29 Mar 2021 13:59:57 -0700 Subject: [PATCH 240/578] Update FatesPlantRespPhotosynthMod.F90 --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index b58864e0d9..f937a55aae 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -1205,24 +1205,27 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in end do !iteration loop ! End of co2_inter_c iteration. Check for an < 0, in which case gs_mol = bbb + ! And Final estimates for leaf_co2_ppress and co2_inter_c + ! (needed for early exit of co2_inter_c iteration when an < 0) if (use_agross == 1) then if (agross < 0._r8) then gs_mol = stomatal_intercept_btran end if - + leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * agross * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + co2_inter_c = can_co2_ppress - agross * can_press * & + (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) else if (anet < 0._r8) then gs_mol = stomatal_intercept_btran end if + leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + co2_inter_c = can_co2_ppress - anet * can_press * & + (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) end if - ! Final estimates for leaf_co2_ppress and co2_inter_c - ! (needed for early exit of co2_inter_c iteration when an < 0) - leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * agross * can_press - leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) - co2_inter_c = can_co2_ppress - agross * can_press * & - (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - + ! Convert gs_mol (umol /m**2/s) to gs (m/s) and then to rs (s/m) gs = gs_mol / cf From 7e7b075c446205796785dea8960064fdf6ca1b7b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 30 Mar 2021 11:23:00 -0400 Subject: [PATCH 241/578] Added a copy function, a history variable and restart capabilities to running mean functions --- biogeochem/EDMortalityFunctionsMod.F90 | 2 +- biogeochem/EDPatchDynamicsMod.F90 | 8 ++ biogeochem/EDPhysiologyMod.F90 | 10 +-- fire/SFMainMod.F90 | 2 +- main/FatesHistoryInterfaceMod.F90 | 27 ++++++- main/FatesRestartInterfaceMod.F90 | 108 ++++++++++++++++++++++++- main/FatesRunningMeanMod.F90 | 38 +++++++-- 7 files changed, 178 insertions(+), 17 deletions(-) diff --git a/biogeochem/EDMortalityFunctionsMod.F90 b/biogeochem/EDMortalityFunctionsMod.F90 index f188963767..ff788d8ef2 100644 --- a/biogeochem/EDMortalityFunctionsMod.F90 +++ b/biogeochem/EDMortalityFunctionsMod.F90 @@ -172,7 +172,7 @@ 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 = cohort_in%patchptr%tveg24%get_mean() - tfrz + temp_in_C = cohort_in%patchptr%tveg24%GetMean() - 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) ) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 0b45d1b12c..25c5decc79 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -668,6 +668,14 @@ subroutine spawn_patches( currentSite, bc_in) call mortality_litter_fluxes(currentSite, currentPatch, new_patch, patch_site_areadis) endif + + ! Copy any means or timers from the original patch to the new patch + ! These values will inherit all info from the original patch + ! -------------------------------------------------------------------------- + call new_patch%tveg24%CopyFromDonor(currentPatch%tveg24) + + + ! -------------------------------------------------------------------------- ! The newly formed patch from disturbance (new_patch), has now been given ! some litter from dead plants and pre-existing litter from the donor patches. diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 0bf7f32df2..10a2e98149 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -758,7 +758,7 @@ subroutine phenology( currentSite, bc_in ) temp_in_C = 0._r8 cpatch => CurrentSite%oldest_patch do while(associated(cpatch)) - temp_in_C = temp_in_C + cpatch%tveg24%get_mean()*cpatch%area + temp_in_C = temp_in_C + cpatch%tveg24%GetMean()*cpatch%area cpatch => cpatch%younger end do temp_in_C = temp_in_C * area_inv - tfrz @@ -2237,17 +2237,17 @@ 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. - if (currentPatch%tveg24%get_mean() >= tfrz) then - t_scalar = q10_mr**((currentPatch%tveg24%get_mean()-(tfrz+25._r8))/10._r8) + if (currentPatch%tveg24%GetMean() >= tfrz) then + t_scalar = q10_mr**((currentPatch%tveg24%GetMean()-(tfrz+25._r8))/10._r8) ! Q10**((t_soisno(c,j)-(tfrz+25._r8))/10._r8) else - t_scalar = (q10_mr**(-25._r8/10._r8))*(q10_froz**((currentPatch%tveg24%get_mean()-tfrz)/10._r8)) + t_scalar = (q10_mr**(-25._r8/10._r8))*(q10_froz**((currentPatch%tveg24%GetMean()-tfrz)/10._r8)) !Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-tfrz)/10._r8) endif else ! original century uses an arctangent function to calculate the ! temperature dependence of decomposition - t_scalar = max(catanf(currentPatch%tveg24%get_mean()-tfrz)/catanf_30,0.01_r8) + t_scalar = max(catanf(currentPatch%tveg24%GetMean()-tfrz)/catanf_30,0.01_r8) endif !Moisture Limitations diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 155f6dc88d..9e894df08f 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -142,7 +142,7 @@ subroutine fire_danger_index ( currentSite, bc_in) iofp = currentSite%oldest_patch%patchno - temp_in_C = currentSite%oldest_patch%tveg24%get_mean() - tfrz + temp_in_C = currentSite%oldest_patch%tveg24%GetMean() - tfrz rainfall = bc_in%precip24_pa(iofp)*sec_per_day rh = bc_in%relhumid24_pa(iofp) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index ed98301ee4..fa90a93080 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -527,7 +527,8 @@ module FatesHistoryInterfaceMod ! integer :: ih_fire_rate_of_spread_front_si_age integer :: ih_fire_intensity_si_age integer :: ih_fire_sum_fuel_si_age - + integer :: ih_tveg24_si_age + ! indices to (site x height) variables integer :: ih_canopy_height_dist_si_height integer :: ih_leaf_height_dist_si_height @@ -1763,7 +1764,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) real(r8) :: npp_partition_error ! a check that the NPP partitions sum to carbon allocation real(r8) :: frac_canopy_in_bin ! fraction of a leaf's canopy that is within a given height bin real(r8) :: binbottom,bintop ! edges of height bins - real(r8) :: gpp_cached ! variable used to cache gpp value in previous time step; for C13 discrimination ! The following are all carbon states, turnover and net allocation flux variables @@ -2008,6 +2008,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! hio_fire_rate_of_spread_front_si_age => this%hvars(ih_fire_rate_of_spread_front_si_age)%r82d, & hio_fire_intensity_si_age => this%hvars(ih_fire_intensity_si_age)%r82d, & hio_fire_sum_fuel_si_age => this%hvars(ih_fire_sum_fuel_si_age)%r82d, & + hio_tveg24_si_age => this%hvars(ih_tveg24_si_age)%r82d, & hio_burnt_frac_litter_si_fuel => this%hvars(ih_burnt_frac_litter_si_fuel)%r82d, & hio_fuel_amount_si_fuel => this%hvars(ih_fuel_amount_si_fuel)%r82d, & hio_fuel_amount_age_fuel => this%hvars(ih_fuel_amount_age_fuel)%r82d, & @@ -2214,7 +2215,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) 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 * g_per_kg * cpatch%area * AREA_INV - + + if(cpatch%tveg24%c_index>0) then + hio_tveg24_si_age(io_si, cpatch%age_class) = & + hio_tveg24_si_age(io_si, cpatch%age_class) + & + cpatch%tveg24%GetMean()*cpatch%area + end if + if(associated(cpatch%tallest))then hio_trimming_si(io_si) = hio_trimming_si(io_si) + cpatch%tallest%canopy_trim * cpatch%area * AREA_INV endif @@ -2874,6 +2881,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) if (hio_area_si_age(io_si, ipa2) .gt. tiny) then hio_lai_si_age(io_si, ipa2) = hio_lai_si_age(io_si, ipa2) / (hio_area_si_age(io_si, ipa2)*AREA) hio_ncl_si_age(io_si, ipa2) = hio_ncl_si_age(io_si, ipa2) / (hio_area_si_age(io_si, ipa2)*AREA) + + hio_tveg24_si_age(io_si, ipa2) = hio_tveg24_si_age(io_si, ipa2) / (hio_area_si_age(io_si, ipa2)*AREA) + do i_pft = 1, numpft iagepft = ipa2 + (i_pft-1) * nlevage hio_scorch_height_si_agepft(io_si, iagepft) = & @@ -3498,6 +3508,8 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_c_lblayer_si(io_si) = hio_c_lblayer_si(io_si) + & cpatch%c_lblayer * cpatch%total_canopy_area + + ccohort => cpatch%shortest do while(associated(ccohort)) @@ -4549,6 +4561,15 @@ subroutine define_history_vars(this, initialize_variables) ivar=ivar, initialize=initialize_variables, index = ih_burnt_frac_litter_si_fuel ) + ! Running means + + call this%set_history_var(vname='TVEG24_AGE', units='Kelvin', & + long='24-hr running mean vegetation temperature by patch age', & + use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_tveg24_si_age ) + + ! Litter Variables call this%set_history_var(vname='LITTER_IN', units='gC m-2 s-1', & diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 0b621dec0a..8a608d70d3 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -37,7 +37,7 @@ module FatesRestartInterfaceMod use FatesLitterMod, only : ndcmpy use PRTGenericMod, only : prt_global use PRTGenericMod, only : num_elements - + use FatesRunningMeanMod, only : rmean_type ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg @@ -135,6 +135,8 @@ module FatesRestartInterfaceMod integer :: ir_gnd_alb_dif_pasb integer :: ir_gnd_alb_dir_pasb + ! Running Means + integer :: ir_tveg24patch_pa integer :: ir_ddbhdt_co integer :: ir_resp_tstep_co @@ -291,7 +293,9 @@ module FatesRestartInterfaceMod procedure, private :: GetCohortRealVector procedure, private :: SetCohortRealVector procedure, private :: RegisterCohortVector - + procedure, private :: DefineRMeanRestartVar + procedure, private :: GetRMeanRestartVar + procedure, private :: SetRMeanRestartVar end type fates_restart_interface_type @@ -1205,6 +1209,10 @@ subroutine define_restart_vars(this, initialize_variables) hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_promcflux_si ) + call this%DefineRMeanRestartVar(vname='fates_tveg24patch',vtype=cohort_r8, & + long_name='24-hour patch veg temp', & + units='K', initialize=initialize_variables,ivar=ivar, index = ir_tveg24patch_pa) + ! Register all of the PRT states and fluxes @@ -1218,7 +1226,90 @@ subroutine define_restart_vars(this, initialize_variables) this%num_restart_vars_ = ivar end subroutine define_restart_vars + + ! ===================================================================================== + + subroutine DefineRMeanRestartVar(this,vname,vtype,long_name,units,initialize,ivar,index) + + class(fates_restart_interface_type) :: this + character(len=*),intent(in) :: vname + character(len=*),intent(in) :: vtype + character(len=*),intent(in) :: long_name + character(len=*),intent(in) :: units + logical, intent(in) :: initialize + integer,intent(inout) :: ivar + integer,intent(inout) :: index + + integer :: dummy_index + + call this%set_restart_var(vname= trim(vname)//'_cmean', vtype=vtype, & + long_name=long_name//' current mean', & + units=units, flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize, ivar=ivar, index = index ) + + call this%set_restart_var(vname= trim(vname)//'_lmean', vtype=vtype, & + long_name=long_name//' latest mean', & + units=units, flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize, ivar=ivar, index = dummy_index ) + + call this%set_restart_var(vname= trim(vname)//'_cindex', vtype=vtype, & + long_name=long_name//' index', & + units='index', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize, ivar=ivar, index = dummy_index ) + + + return + end subroutine DefineRMeanRestartVar + + + ! ===================================================================================== + + subroutine GetRMeanRestartVar(this, rmean_var, ir_var_index, position_index) + + class(fates_restart_interface_type) , intent(inout) :: this + class(rmean_type), intent(inout) :: rmean_var + + integer,intent(in) :: ir_var_index + integer,intent(in) :: position_index + + integer :: i_pos ! vector position loop index + integer :: ir_pos_var ! global variable index + + + rmean_var%c_mean = this%rvars(ir_var_index)%r81d(position_index) + + rmean_var%l_mean = this%rvars(ir_var_index+1)%r81d(position_index) + + rmean_var%c_index = nint(this%rvars(ir_var_index+2)%r81d(position_index)) + + return + end subroutine GetRMeanRestartVar + + ! ======================================================================================= + + subroutine SetRMeanRestartVar(this, rmean_var, ir_var_index, position_index) + + class(fates_restart_interface_type) , intent(inout) :: this + class(rmean_type), intent(inout) :: rmean_var + + integer,intent(in) :: ir_var_index + integer,intent(in) :: position_index + + integer :: i_pos ! vector position loop index + integer :: ir_pos_var ! global variable index + + this%rvars(ir_var_index)%r81d(position_index) = rmean_var%c_mean + + this%rvars(ir_var_index+1)%r81d(position_index) = rmean_var%l_mean + + this%rvars(ir_var_index+2)%r81d(position_index) = real(rmean_var%c_index,r8) + + return + end subroutine SetRMeanRestartVar + + + ! ===================================================================================== subroutine DefinePRTRestartVars(this,initialize_variables,ivar) @@ -1410,6 +1501,12 @@ subroutine RegisterCohortVector(this,symbol_base, vtype, long_name_base, & end subroutine RegisterCohortVector + + + + + + ! ===================================================================================== subroutine GetCohortRealVector(this, state_vector, len_state_vector, & @@ -1918,6 +2015,9 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_patchdistturbcat_pa(io_idx_co_1st) = cpatch%anthro_disturbance_label rio_agesinceanthrodist_pa(io_idx_co_1st) = cpatch%age_since_anthro_disturbance rio_area_pa(io_idx_co_1st) = cpatch%area + + ! Patch level running means + call this%SetRMeanRestartVar(cpatch%tveg24, ir_tveg24patch_pa, io_idx_co_1st) ! set cohorts per patch for IO rio_ncohort_pa( io_idx_co_1st ) = cohortsperpatch @@ -2696,6 +2796,10 @@ subroutine get_restart_vectors(this, nc, nsites, sites) cpatch%solar_zenith_flag = ( rio_solar_zenith_flag_pa(io_idx_co_1st) .eq. itrue ) cpatch%solar_zenith_angle = rio_solar_zenith_angle_pa(io_idx_co_1st) + + call this%GetRMeanRestartVar(cpatch%tveg24, ir_tveg24patch_pa, io_idx_co_1st) + + ! set cohorts per patch for IO if ( debug ) then diff --git a/main/FatesRunningMeanMod.F90 b/main/FatesRunningMeanMod.F90 index 60fa1b0850..b535b6b678 100644 --- a/main/FatesRunningMeanMod.F90 +++ b/main/FatesRunningMeanMod.F90 @@ -73,10 +73,11 @@ module FatesRunningMeanMod contains - procedure :: get_mean + procedure :: GetMean procedure :: InitRMean procedure :: UpdateRMean procedure :: FuseRMean + procedure :: CopyFromDonor end type rmean_type @@ -122,10 +123,10 @@ end subroutine define ! ===================================================================================== - function get_mean(this) + function GetMean(this) class(rmean_type) :: this - real(r8) :: get_mean + real(r8) :: GetMean if(this%def_type%method .eq. moving_ema_window) then if(this%c_index == 0) then @@ -141,9 +142,9 @@ function get_mean(this) call endrun(msg=errMsg(sourcefile, __LINE__)) end if end if - get_mean = this%l_mean + GetMean = this%l_mean - end function get_mean + end function GetMean ! ===================================================================================== @@ -195,6 +196,33 @@ subroutine InitRMean(this,rmean_def,init_value,init_offset) return end subroutine InitRMean + + ! ===================================================================================== + + + subroutine CopyFromDonor(this, donor) + + class(rmean_type) :: this + class(rmean_type),intent(in) :: donor + + if( .not.associated(this%def_type)) then + write(fates_log(), *) 'Attempted to copy over running mean' + write(fates_log(), *) 'info from a donor into a new structure' + write(fates_log(), *) 'but the new structure did not have its' + write(fates_log(), *) 'def_type pointer associated' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + this%c_mean = donor%c_mean + this%l_mean = donor%l_mean + this%c_index = donor%c_index + + + return + end subroutine CopyFromDonor + + + ! ===================================================================================== subroutine UpdateRMean(this, new_value) From 621ee885feb872e7e13dbe5634b5ee71043015f9 Mon Sep 17 00:00:00 2001 From: Yilin Fang Date: Wed, 31 Mar 2021 09:40:28 -0700 Subject: [PATCH 242/578] Add aggregated soil layers option for hydro. --- biogeophys/FatesPlantHydraulicsMod.F90 | 220 ++++++++++++++++++++----- main/FatesHistoryInterfaceMod.F90 | 9 +- main/FatesHydraulicsMemMod.F90 | 7 +- 3 files changed, 191 insertions(+), 45 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 51300bbb95..77f9494a28 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -89,6 +89,7 @@ module FatesPlantHydraulicsMod use FatesHydraulicsMemMod, only: recruit_water_avail_layer use FatesHydraulicsMemMod, only: rwccap, rwcft use FatesHydraulicsMemMod, only: ignore_layer1 + use FatesHydraulicsMemMod, only: aggregate_layers use PRTGenericMod, only : all_carbon_elements use PRTGenericMod, only : leaf_organ, fnrt_organ, sapw_organ @@ -386,14 +387,22 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) 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 + if(.not. aggregate_layers) then + j_bc=j+csite_hydr%i_rhiz_t-1 + else + j_bc = csite_hydr%map_r2s(j,2) !assign bottom soil layer parameters to rhizosphere, not accurate, but ok for larger fraction + end if 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 + if(.not. aggregate_layers) then + j_bc=j+csite_hydr%i_rhiz_t-1 + else + j_bc = csite_hydr%map_r2s(j,2) + end if 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), & @@ -402,7 +411,11 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) end do case(smooth1_campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 + if(.not. aggregate_layers) then + j_bc=j+csite_hydr%i_rhiz_t-1 + else + j_bc = csite_hydr%map_r2s(j,2) + end if allocate(wrf_smooth_cch) sites(s)%si_hydr%wrf_soil(j)%p => wrf_smooth_cch call wrf_smooth_cch%set_wrf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -411,7 +424,11 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) end do case(smooth2_campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 + if(.not. aggregate_layers) then + j_bc=j+csite_hydr%i_rhiz_t-1 + else + j_bc = csite_hydr%map_r2s(j,2) + end if allocate(wrf_smooth_cch) sites(s)%si_hydr%wrf_soil(j)%p => wrf_smooth_cch call wrf_smooth_cch%set_wrf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -437,7 +454,11 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) end do case(campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 + if(.not. aggregate_layers) then + j_bc=j+csite_hydr%i_rhiz_t-1 + else + j_bc = csite_hydr%map_r2s(j,2) + end if 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), & @@ -446,7 +467,11 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) end do case(smooth1_campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 + if(.not. aggregate_layers) then + j_bc=j+csite_hydr%i_rhiz_t-1 + else + j_bc = csite_hydr%map_r2s(j,2) + end if allocate(wkf_smooth_cch) sites(s)%si_hydr%wkf_soil(j)%p => wkf_smooth_cch call wkf_smooth_cch%set_wkf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -455,7 +480,11 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) end do case(smooth2_campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 + if(.not. aggregate_layers) then + j_bc=j+csite_hydr%i_rhiz_t-1 + else + j_bc = csite_hydr%map_r2s(j,2) + end if allocate(wkf_smooth_cch) sites(s)%si_hydr%wkf_soil(j)%p => wkf_smooth_cch call wkf_smooth_cch%set_wkf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -1338,7 +1367,12 @@ subroutine InitHydrSites(sites,bc_in) ! Calculate the number of rhizosphere ! layers used - if(ignore_layer1) then + if(aggregate_layers) then + csite_hydr%i_rhiz_t = 7 + csite_hydr%i_rhiz_b = bc_in(s)%nlevsoil + csite_hydr%nlevrhiz = csite_hydr%i_rhiz_b - csite_hydr%i_rhiz_t + 2 !ideally to be read in from the parameter file + + elseif(ignore_layer1) then !csite_hydr%i_rhiz_t = 2 csite_hydr%i_rhiz_t = 6 csite_hydr%i_rhiz_b = bc_in(s)%nlevsoil @@ -1346,16 +1380,31 @@ subroutine InitHydrSites(sites,bc_in) csite_hydr%i_rhiz_t = 1 csite_hydr%i_rhiz_b = bc_in(s)%nlevsoil end if - - csite_hydr%nlevrhiz = csite_hydr%i_rhiz_b-csite_hydr%i_rhiz_t+1 + + if(.not. aggregate_layers) & + 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 + if(.not. aggregate_layers) then + 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 + else + csite_hydr%map_r2s(1,1) = 1 + csite_hydr%map_r2s(1,2) = csite_hydr%i_rhiz_t - 1 + jj = 2 + do j = csite_hydr%i_rhiz_t,csite_hydr%i_rhiz_b + csite_hydr%map_r2s(jj,1:2) = j + jj = jj + 1 + end do + do j=1,csite_hydr%nlevrhiz + csite_hydr%zi_rhiz(j) = 0.5_r8*(bc_in(s)%z_sisl(csite_hydr%map_r2s(j,1)) + bc_in(s)%z_sisl(csite_hydr%map_r2s(j,2))) + csite_hydr%dz_rhiz(j) = sum( bc_in(s)%dz_sisl(csite_hydr%map_r2s(j,1):csite_hydr%map_r2s(j,2)) ) + end do + end if end do @@ -1373,10 +1422,12 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) type(ed_site_hydr_type), pointer :: site_hydr real(r8) :: smp ! matric potential temp real(r8) :: h2osoi_liqvol ! liquid water content (m3/m3) + real(r8) :: eff_por integer :: s integer :: j,j_bc integer :: nsites integer :: nlevrhiz + integer :: r_t,r_b class(wrf_type_vg), pointer :: wrf_vg class(wkf_type_vg), pointer :: wkf_vg class(wrf_type_cch), pointer :: wrf_cch @@ -1393,12 +1444,22 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) 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)) + if(.not. aggregate_layers) then + 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)) + else + r_t = site_hydr%map_r2s(j,1) + r_b = site_hydr%map_r2s(j,2) + eff_por = sum(bc_in(s)%eff_porosity_sl(r_t:r_b)*bc_in(s)%dz_sisl(r_t:r_b))/site_hydr%dz_rhiz(j) + h2osoi_liqvol = min(eff_por, sum(bc_in(s)%h2o_liq_sisl(r_t:r_b)) & + /(site_hydr%dz_rhiz(j)*denh2o)) + site_hydr%h2osoi_liq_prev(j) = sum( bc_in(s)%h2o_liq_sisl(r_t:r_b) ) + end if site_hydr%h2osoi_liqvol_shell(j,1:nshell) = h2osoi_liqvol - site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j_bc) + if(.not. aggregate_layers) & + site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j_bc) end do @@ -1424,7 +1485,11 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) end do case(campbell_type) do j=1,site_hydr%nlevrhiz - j_bc=j+site_hydr%i_rhiz_t-1 + if(.not. aggregate_layers) then + j_bc=j+site_hydr%i_rhiz_t-1 + else + j_bc = site_hydr%map_r2s(j,2) !assign bottom soil layer parameters to rhizosphere, not accurate, but ok for larger fraction + end if allocate(wrf_cch) site_hydr%wrf_soil(j)%p => wrf_cch call wrf_cch%set_wrf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -1433,7 +1498,11 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) end do case(smooth1_campbell_type) do j=1,site_hydr%nlevrhiz - j_bc=j+site_hydr%i_rhiz_t-1 + if(.not. aggregate_layers) then + j_bc=j+site_hydr%i_rhiz_t-1 + else + j_bc = site_hydr%map_r2s(j,2) + end if allocate(wrf_smooth_cch) site_hydr%wrf_soil(j)%p => wrf_smooth_cch call wrf_smooth_cch%set_wrf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -1442,7 +1511,11 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) end do case(smooth2_campbell_type) do j=1,site_hydr%nlevrhiz - j_bc=j+site_hydr%i_rhiz_t-1 + if(.not. aggregate_layers) then + j_bc=j+site_hydr%i_rhiz_t-1 + else + j_bc = site_hydr%map_r2s(j,2) + end if allocate(wrf_smooth_cch) site_hydr%wrf_soil(j)%p => wrf_smooth_cch call wrf_smooth_cch%set_wrf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -1467,7 +1540,11 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) end do case(campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - j_bc=j+site_hydr%i_rhiz_t-1 + if(.not. aggregate_layers) then + j_bc=j+site_hydr%i_rhiz_t-1 + else + j_bc = site_hydr%map_r2s(j,2) + end if allocate(wkf_cch) site_hydr%wkf_soil(j)%p => wkf_cch call wkf_cch%set_wkf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -1476,7 +1553,11 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) end do case(smooth1_campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - j_bc=j+site_hydr%i_rhiz_t-1 + if(.not. aggregate_layers) then + j_bc=j+site_hydr%i_rhiz_t-1 + else + j_bc = site_hydr%map_r2s(j,2) + end if allocate(wkf_smooth_cch) site_hydr%wkf_soil(j)%p => wkf_smooth_cch call wkf_smooth_cch%set_wkf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -1485,7 +1566,11 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) end do case(smooth2_campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - j_bc=j+site_hydr%i_rhiz_t-1 + if(.not. aggregate_layers) then + j_bc=j+site_hydr%i_rhiz_t-1 + else + j_bc = site_hydr%map_r2s(j,2) + end if allocate(wkf_smooth_cch) site_hydr%wkf_soil(j)%p => wkf_smooth_cch call wkf_smooth_cch%set_wkf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -1920,7 +2005,11 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) do j = 1,nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 + if(.not. aggregate_layers) then + j_bc=j+csite_hydr%i_rhiz_t-1 + else + j_bc = csite_hydr%map_r2s(j,2) + end if ! bc_in%hksat_sisl(j): hydraulic conductivity at saturation (mm H2O /s) ! @@ -2112,7 +2201,11 @@ subroutine UpdateSizeDepRhizHydStates(currentSite, bc_in) ! 1st guess at new s based on interpolated psi do j = 1,csite_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 + if(.not. aggregate_layers) then + j_bc=j+csite_hydr%i_rhiz_t-1 + else + j_bc = csite_hydr%map_r2s(j,2) + end if ! proceed only if l_aroot_coh has changed if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then @@ -2125,7 +2218,11 @@ subroutine UpdateSizeDepRhizHydStates(currentSite, bc_in) ! 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 + if(.not. aggregate_layers) then + j_bc=j+csite_hydr%i_rhiz_t-1 + else + j_bc = csite_hydr%map_r2s(j,2) + end if ! 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 @@ -2145,7 +2242,11 @@ subroutine UpdateSizeDepRhizHydStates(currentSite, bc_in) ! estimate delta_s across all shells needed to ensure total water in each layer doesn't change ! BOC...FIX: need to handle special cases where delta_s causes s_shell to go above or below 1 or 0, respectively. do j = 1,csite_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 + if(.not. aggregate_layers) then + j_bc=j+csite_hydr%i_rhiz_t-1 + else + j_bc = csite_hydr%map_r2s(j,2) + end if ! 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)) / & @@ -2155,7 +2256,11 @@ subroutine UpdateSizeDepRhizHydStates(currentSite, bc_in) ! update h2osoi_liqvol_shell and h2osoi_liq_shell do j = 1,csite_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 + if(.not. aggregate_layers) then + j_bc=j+csite_hydr%i_rhiz_t-1 + else + j_bc = csite_hydr%map_r2s(j,2) + end if ! 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 @@ -2173,8 +2278,13 @@ subroutine UpdateSizeDepRhizHydStates(currentSite, bc_in) ! 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(.not. aggregate_layers) then + j_bc=j+csite_hydr%i_rhiz_t-1 + errh2o(j) = h2osoi_liq_col_new(j) - bc_in%h2o_liq_sisl(j_bc) + else + j_bc = csite_hydr%map_r2s(j,2) + errh2o(j) = h2osoi_liq_col_new(j) - sum(bc_in%h2o_liq_sisl(csite_hydr%map_r2s(j,1):csite_hydr%map_r2s(j,2))) + end if if (abs(errh2o(j)) > 1.e-4_r8) then write(fates_log(),*)'WARNING: water balance error ',& ' updating rhizosphere shells: ',j,errh2o(j) @@ -2302,11 +2412,19 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) ! patch without cohorts if( sum(csite_hydr%l_aroot_layer) == 0._r8 ) cycle do j = 1,csite_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 + if(.not. aggregate_layers) then + j_bc=j+csite_hydr%i_rhiz_t-1 + else + j_bc = csite_hydr%map_r2s(j,2) + end if cumShellH2O=sum(csite_hydr%h2osoi_liqvol_shell(j,:) *csite_hydr%v_shell(j,:)) * denh2o*AREA_INV + if(.not. aggregate_layers) then + dwat_kgm2 = bc_in(s)%h2o_liq_sisl(j_bc) - cumShellH2O + else + dwat_kgm2 = sum( bc_in(s)%h2o_liq_sisl(csite_hydr%map_r2s(j,1):j_bc) ) - cumShellH2O + end if - dwat_kgm2 = bc_in(s)%h2o_liq_sisl(j_bc) - cumShellH2O dwat_kg = dwat_kgm2 * AREA @@ -2367,8 +2485,11 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) h2osoi_liq_shell(j,:) = csite_hydr%h2osoi_liqvol_shell(j,:) * & csite_hydr%v_shell(j,:) * denh2o - - errh2o(j) = sum(h2osoi_liq_shell(j,:))*AREA_INV - bc_in(s)%h2o_liq_sisl(j_bc) + if(aggregate_layers) then + errh2o(j) = sum(h2osoi_liq_shell(j,:))*AREA_INV - sum(bc_in(s)%h2o_liq_sisl(csite_hydr%map_r2s(j,1):csite_hydr%map_r2s(j,2)) ) + else + errh2o(j) = sum(h2osoi_liq_shell(j,:))*AREA_INV - bc_in(s)%h2o_liq_sisl(j_bc) + end if if (abs(errh2o(j)) > 1.e-9_r8) then write(fates_log(),*)'WARNING: water balance error in FillDrainRhizShells' @@ -2463,8 +2584,10 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) 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 + real(r8) :: qflx_soil2root_tmp integer :: nlevrhiz ! local for number of rhizosphere levels integer :: sc ! size class index + integer :: jl ! ---------------------------------------------------------------------------------- ! Important note: We are interested in calculating the total fluxes in and out of the @@ -2701,23 +2824,36 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) do j=1,site_hydr%nlevrhiz - j_bc = j+site_hydr%i_rhiz_t-1 + if(.not. aggregate_layers) then + j_bc = j+site_hydr%i_rhiz_t-1 + else + j_bc = site_hydr%map_r2s(j,2) + end if ! 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,:) - - - bc_out(s)%qflx_soil2root_sisl(j_bc) = & + qflx_soil2root_tmp = & -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:))*denh2o*AREA_INV/dtime) + & site_hydr%recruit_w_uptake(j) + if(aggregate_layers) then + do jl = site_hydr%map_r2s(j,1), site_hydr%map_r2s(j,2) + bc_out(s)%qflx_soil2root_sisl(jl) = qflx_soil2root_tmp * & + bc_in(s)%hksat_sisl(jl)*bc_in(s)%dz_sisl(jl)/sum(bc_in(s)%hksat_sisl(site_hydr%map_r2s(j,1):site_hydr%map_r2s(j,2)) * & + bc_in(s)%dz_sisl(site_hydr%map_r2s(j,1):site_hydr%map_r2s(j,2))) + end do + else + 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) + end if ! 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) + dtime*qflx_soil2root_tmp ! We accept that it is possible for gravity to push diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 208b3df9ad..6b7ef45e16 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3781,6 +3781,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) use FatesHydraulicsMemMod, only : ed_cohort_hydr_type, nshell use FatesHydraulicsMemMod, only : ed_site_hydr_type + use FatesHydraulicsMemMod, only : aggregate_layers use EDTypesMod , only : maxpft @@ -3892,6 +3893,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) site_hydr => sites(s)%si_hydr nlevrhiz = site_hydr%nlevrhiz jr1 = site_hydr%i_rhiz_t + if(aggregate_layers) jr1 = jr1 -1 jr2 = site_hydr%i_rhiz_b io_si = this%iovar_map(nc)%site_index(s) @@ -3911,8 +3913,11 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) areaweight = 0._r8 do jrhiz=1,nlevrhiz - - jsoil = jrhiz + jr1-1 + if(.not. aggregate_layers) then + jsoil = jrhiz + jr1-1 + else + jsoil = site_hydr%map_r2s(jrhiz,2) + end if 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) diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index d3b71c2847..8507f7278d 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -63,7 +63,8 @@ module FatesHydraulicsMemMod 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. + logical, parameter, public :: ignore_layer1=.false. + logical, parameter, public :: aggregate_layers=.true. ! Derived parameters @@ -80,6 +81,8 @@ module FatesHydraulicsMemMod 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) + integer, allocatable :: map_s2r(:) ! soil to rhizoshpere level mapping + integer, allocatable :: map_r2s(:,:) ! rhizoshpere to soil level mapping, 1 -top soil layer, 2- bottom soil layer 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] @@ -399,6 +402,8 @@ subroutine InitHydrSite(this,numpft,numlevsclass) allocate(this%zi_rhiz(1:nlevrhiz)); this%zi_rhiz(:) = nan allocate(this%dz_rhiz(1:nlevrhiz)); this%dz_rhiz(:) = nan + allocate(this%map_s2r(1:nlevrhiz)); this%map_s2r(:) = -999 + allocate(this%map_r2s(1:nlevrhiz,1:2)); this%map_r2s(:,:) = -999 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 From 57afe3f905d4e99ff32276ab8e7d859148187813 Mon Sep 17 00:00:00 2001 From: Yilin Fang Date: Wed, 31 Mar 2021 12:49:49 -0700 Subject: [PATCH 243/578] Correction for root fraction calculation for aggregated grid. --- biogeophys/FatesPlantHydraulicsMod.F90 | 22 ++++++++++++++++++---- 1 file changed, 18 insertions(+), 4 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 77f9494a28..8d700f5928 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -1008,14 +1008,28 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! Partition the total absorbing root lengths and volumes into the active soil layers ! We have a condition, where we may ignore the first layer ! ------------------------------------------------------------------------------ - - norm = 1._r8 - & + if(aggregate_layers) then + norm = 1._r8 - & + zeng2001_crootfr(roota, rootb,0._r8, sum(site_hydr%dz_rhiz(1:nlevrhiz)) ) + else + norm = 1._r8 - & zeng2001_crootfr(roota, rootb,site_hydr%zi_rhiz(1)-site_hydr%dz_rhiz(1), site_hydr%zi_rhiz(nlevrhiz)) - + end if + do j=1,nlevrhiz - rootfr = norm*(zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j),site_hydr%zi_rhiz(nlevrhiz)) - & + if(aggregate_layers) then + if(j==1) then + rootfr = norm*(zeng2001_crootfr(roota, rootb,sum(site_hydr%dz_rhiz(1:j)),sum(site_hydr%dz_rhiz(1:nlevrhiz))) - & + zeng2001_crootfr(roota, rootb, 0._r8,sum(site_hydr%dz_rhiz(1:nlevrhiz)))) + else + rootfr = norm*(zeng2001_crootfr(roota, rootb,sum(site_hydr%dz_rhiz(1:j)),sum(site_hydr%dz_rhiz(1:nlevrhiz))) - & + zeng2001_crootfr(roota, rootb, sum(site_hydr%dz_rhiz(1:j-1)),sum(site_hydr%dz_rhiz(1:nlevrhiz)))) + endif + else + rootfr = norm*(zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j),site_hydr%zi_rhiz(nlevrhiz)) - & zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j)-site_hydr%dz_rhiz(j),site_hydr%zi_rhiz(nlevrhiz))) + endif ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot From 8c9e4a47be6d81f393bb87dedaf75bacd7b0df24 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 2 Apr 2021 12:14:36 -0400 Subject: [PATCH 244/578] Added site-level running mean 24-veg temp diagnostic --- main/FatesHistoryInterfaceMod.F90 | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index fa90a93080..79bff307c5 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -528,6 +528,7 @@ module FatesHistoryInterfaceMod integer :: ih_fire_intensity_si_age integer :: ih_fire_sum_fuel_si_age integer :: ih_tveg24_si_age + integer :: ih_tveg24_si ! indices to (site x height) variables integer :: ih_canopy_height_dist_si_height @@ -2009,6 +2010,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) 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_tveg24_si_age => this%hvars(ih_tveg24_si_age)%r82d, & + hio_tveg24_si => this%hvars(ih_tveg24_si)%r81d, & hio_burnt_frac_litter_si_fuel => this%hvars(ih_burnt_frac_litter_si_fuel)%r82d, & hio_fuel_amount_si_fuel => this%hvars(ih_fuel_amount_si_fuel)%r82d, & hio_fuel_amount_age_fuel => this%hvars(ih_fuel_amount_age_fuel)%r82d, & @@ -2152,6 +2154,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_harvest_carbonflux_si(io_si) = sites(s)%harvest_carbon_flux + hio_tveg24_si_age(io_si, :) = 0._r8 + hio_tveg24_si(io_si) = 0._r8 + ipa = 0 cpatch => sites(s)%oldest_patch do while(associated(cpatch)) @@ -2220,6 +2225,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_tveg24_si_age(io_si, cpatch%age_class) = & hio_tveg24_si_age(io_si, cpatch%age_class) + & cpatch%tveg24%GetMean()*cpatch%area + hio_tveg24_si(io_si) = hio_tveg24_si(io_si) + & + cpatch%tveg24%GetMean()*cpatch%area*area_inv end if if(associated(cpatch%tallest))then @@ -4564,11 +4571,16 @@ subroutine define_history_vars(this, initialize_variables) ! Running means call this%set_history_var(vname='TVEG24_AGE', units='Kelvin', & - long='24-hr running mean vegetation temperature by patch age', & + long='fates 24-hr running mean vegetation temperature by patch age', & use_default='active', & avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_tveg24_si_age ) + call this%set_history_var(vname='TVEG24_SI', units='Kelvin', & + long='fates 24-hr running mean vegetation temperature by site', & + use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_tveg24_si ) ! Litter Variables From 2bbe5f99b3ac6a3dfee9bc394e74a4ffa61ef3fa Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 2 Apr 2021 14:06:21 -0400 Subject: [PATCH 245/578] Updated some default parameters for parteh=2 --- parameter_files/fates_params_default.cdl | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 9de08b775c..971ee39992 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -1081,9 +1081,9 @@ data: fates_prescribed_npp_understory = 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125 ; - fates_prescribed_nuptake = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ; + fates_prescribed_nuptake = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0 ; - fates_prescribed_puptake = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ; + fates_prescribed_puptake = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0 ; fates_prescribed_recruitment = 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02 ; @@ -1132,9 +1132,9 @@ data: 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047 ; - fates_nitr_store_ratio = 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3; + fates_nitr_store_ratio = 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5; - fates_phos_store_ratio = 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3; + fates_phos_store_ratio = 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5; fates_recruit_hgt_min = 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 0.75, 0.75, 0.75, 0.125, 0.125, 0.125 ; From 093ef49e5e21713372fd7fdd5b750bbf2288f1d7 Mon Sep 17 00:00:00 2001 From: Junyan Ding Date: Fri, 2 Apr 2021 16:07:27 -0700 Subject: [PATCH 246/578] Fix bugs JD_gs_NGmaster --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 4 ++-- main/EDPftvarcon.F90 | 10 ++++++++++ parameter_files/fates_params_default.cdl | 5 +++++ 3 files changed, 17 insertions(+), 2 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index f937a55aae..5830b4e0a1 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -1175,8 +1175,8 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in bb_slope(ft)*agross*can_press * ceair/ veg_esat ) else aquad = leaf_co2_ppress - bquad = leaf_co2_ppress*(gb_mol - bbb) - bb_slope(ft) * anet * can_press - cquad = -gb_mol*(leaf_co2_ppress*bbb + & + bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * anet * can_press + cquad = -gb_mol*(leaf_co2_ppress*stomatal_intercept_btran + & bb_slope(ft)*anet*can_press * ceair/ veg_esat ) end if call quadratic_f (aquad, bquad, cquad, r1, r2) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 0a91c6a2ee..2ccb5b29ad 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -198,6 +198,7 @@ module EDPftvarcon real(r8), allocatable :: hydr_rfrac_stem(:) ! fraction of total tree resistance from troot to canopy real(r8), allocatable :: hydr_avuln_gs(:) ! shape parameter for stomatal control of water vapor exiting leaf real(r8), allocatable :: hydr_p50_gs(:) ! water potential at 50% loss of stomatal conductance + real(r8), allocatable :: hydr_k_lwp(:) ! inner leaf humidity scaling coefficient ! PFT x Organ Dimension (organs are: 1=leaf, 2=stem, 3=transporting root, 4=absorbing root) real(r8), allocatable :: hydr_avuln_node(:,:) ! xylem vulernability curve shape parameter @@ -440,6 +441,10 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_hydr_k_lwp' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_hydr_avuln_gs' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -773,6 +778,10 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_rfrac_stem) + name = 'fates_hydr_k_lwp' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_k_lwp) + name = 'fates_hydr_avuln_gs' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_avuln_gs) @@ -1376,6 +1385,7 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'hydr_srl = ',EDPftvarcon_inst%hydr_srl write(fates_log(),fmt0) 'hydr_rfrac_stem = ',EDPftvarcon_inst%hydr_rfrac_stem write(fates_log(),fmt0) 'hydr_avuln_gs = ',EDPftvarcon_inst%hydr_avuln_gs + write(fates_log(),fmt0) 'hydr_k_lwp = ',EDPftvarcon_inst%hydr_k_lwp write(fates_log(),fmt0) 'hydr_p50_gs = ',EDPftvarcon_inst%hydr_p50_gs write(fates_log(),fmt0) 'hydr_avuln_node = ',EDPftvarcon_inst%hydr_avuln_node write(fates_log(),fmt0) 'hydr_p50_node = ',EDPftvarcon_inst%hydr_p50_node diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 600b97ac00..10511423cd 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -196,6 +196,9 @@ variables: double fates_grperc(fates_pft) ; fates_grperc:units = "unitless" ; fates_grperc:long_name = "Growth respiration factor" ; + double fates_hydr_k_lwp(fates_pft) ; + fates_hydr_k_lwp:units = "unitless" ; + fates_hydr_k_lwp:long_name = "inner leaf humidity scale coefficient, between 1 to 10, set to 0 to disable this function" ; double fates_hydr_avuln_gs(fates_pft) ; fates_hydr_avuln_gs:units = "unitless" ; fates_hydr_avuln_gs:long_name = "shape parameter for stomatal control of water vapor exiting leaf" ; @@ -865,6 +868,8 @@ data: fates_hydr_avuln_gs = 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5 ; + fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + fates_hydr_avuln_node = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, From 480963914a05286125430e9d30e368b5edf4326e Mon Sep 17 00:00:00 2001 From: Junyan Ding Date: Fri, 2 Apr 2021 22:24:38 -0700 Subject: [PATCH 247/578] bug fixed JD_vg_NGmaster --- biogeophys/FatesHydroWTFMod.F90 | 190 ++++++++++++------------- biogeophys/FatesPlantHydraulicsMod.F90 | 7 +- main/EDPftvarcon.F90 | 147 ++----------------- 3 files changed, 109 insertions(+), 235 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 9ce826ab3a..e1844faa8c 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -28,7 +28,7 @@ module FatesHydroWTFMod __FILE__ - real(r8), parameter :: min_ftc = 0.00001_r8 ! Minimum allowed fraction of total conductance + 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" @@ -36,8 +36,6 @@ module FatesHydroWTFMod real(r8), parameter :: min_sf_interp = 0.01 ! Linear interpolation below this saturated frac real(r8), parameter :: max_sf_interp = 0.98 ! Linear interpolation above this saturated frac - real(r8), parameter :: min_sf_interp = 0.02 ! Linear interpolation below this saturated frac - real(r8), parameter :: max_sf_interp = 0.99 ! Linear interpolation above this saturated frac real(r8), parameter :: quad_a1 = 0.80_r8 ! smoothing factor "A" term ! in the capillary-elastic region @@ -66,9 +64,8 @@ module FatesHydroWTFMod real(r8) :: dpsidth_min ! dpsi_dth where we start min interp real(r8) :: th_min ! vwc matching min_sf_interp where we start linear interp real(r8) :: th_max ! vwc matching max_sf_interp where we start linear interp - - contains - + + 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 @@ -82,7 +79,7 @@ module FatesHydroWTFMod procedure, non_overridable :: th_linear_sat procedure, non_overridable :: th_linear_res procedure, non_overridable :: set_min_max - + end type wrf_type @@ -101,12 +98,15 @@ module FatesHydroWTFMod 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 ! ===================================================================================== @@ -118,6 +118,7 @@ module FatesHydroWTFMod real(r8) :: m_vg ! m in van Genuchten 1980, also a pore size distribtion parameter , 1-m in original code 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 @@ -149,6 +150,7 @@ module FatesHydroWTFMod real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] real(r8) :: psi_sat ! Bubbling pressure (potential at saturation) [Mpa] real(r8) :: beta ! Clapp-Hornberger "beta" parameter [-] + contains procedure :: th_from_psi => th_from_psi_cch procedure :: psi_from_th => psi_from_th_cch @@ -185,12 +187,14 @@ module FatesHydroWTFMod 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 + + 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 :: get_thsat => get_thsat_tfs + procedure :: get_thsat => get_thsat_tfs procedure :: bisect_pv end type wrf_type_tfs @@ -213,14 +217,6 @@ module FatesHydroWTFMod ! Functional definitions follow here ! Start off by writing the base types, which ultimately should never be pointed to. ! ===================================================================================== - - ! Generic Functions usable by all - ! Note that these are linear extrapolations, and are not scientifically - ! valid. They should only be used with the expectation that they will allow - ! for solutions outside the expected range, with the understanding these - ! are temporary pertubations, probably through fluctuations in precision - ! of numerical integration. - ! ============================================================================ subroutine set_min_max(this,th_res,th_sat) @@ -295,9 +291,8 @@ function th_linear_res(this,psi) result(th) th = this%th_min + (psi-this%psi_min)/this%dpsidth_min end function th_linear_res - - ! =========================================================================== - + + !====================================================================================== subroutine set_wrf_param_base(this,params_in) class(wrf_type) :: this real(r8),intent(in) :: params_in(:) @@ -306,6 +301,7 @@ subroutine set_wrf_param_base(this,params_in) write(fates_log(),*) 'check how the class pointer was setup' call endrun(msg=errMsg(sourcefile, __LINE__)) end subroutine set_wrf_param_base + function get_thsat_base(this) result(th_sat) class(wrf_type) :: this real(r8) :: th_sat @@ -313,7 +309,7 @@ function get_thsat_base(this) result(th_sat) 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 get_thsat_base + end function get_thsat_base subroutine set_wkf_param_base(this,params_in) class(wkf_type) :: this real(r8),intent(in) :: params_in(:) @@ -326,7 +322,6 @@ function th_from_psi_base(this,psi) result(th) class(wrf_type) :: this real(r8),intent(in) :: psi real(r8) :: th - th = 0._r8 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' @@ -336,7 +331,6 @@ function psi_from_th_base(this,th) result(psi) class(wrf_type) :: this real(r8),intent(in) :: th real(r8) :: psi - psi = 0._r8 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' @@ -346,7 +340,6 @@ function dpsidth_from_th_base(this,th) result(dpsidth) class(wrf_type) :: this real(r8),intent(in) :: th real(r8) :: dpsidth - dpsidth = 0._r8 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' @@ -356,7 +349,6 @@ function ftc_from_psi_base(this,psi) result(ftc) class(wkf_type) :: this real(r8),intent(in) :: psi real(r8) :: ftc - ftc = 0._r8 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' @@ -366,7 +358,6 @@ function dftcdpsi_from_psi_base(this,psi) result(dftcdpsi) class(wkf_type) :: this real(r8),intent(in) :: psi real(r8) :: dftcdpsi - dftcdpsi = 0._r8 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' @@ -388,12 +379,10 @@ subroutine set_wrf_param_vg(this,params_in) this%th_sat = params_in(4) this%th_res = params_in(5) - !write(fates_log(),*) 'set_wrf_param_vg' - !write(fates_log(),*) 'th_sat:',this%th_sat, 'th_res: ', this%th_res - !write(fates_log(),*) 'alpha:', this%alpha, 'm: ', this%m_vg, 'n: ', this%n_vg + write(fates_log(),*) 'set_wrf_param_vg' + write(fates_log(),*) 'th_sat:',this%th_sat, 'th_res: ', this%th_res + write(fates_log(),*) 'alpha:', this%alpha, 'm: ', this%m_vg, 'n: ', this%n_vg - call this%set_min_max(this%th_res,this%th_sat) - return end subroutine set_wrf_param_vg @@ -411,9 +400,9 @@ subroutine set_wkf_param_vg(this,params_in) this%th_res = params_in(5) this%tort = params_in(6) - !write(fates_log(),*) 'set_wkf_param_vg' - !write(fates_log(),*) 'th_sat:',this%th_sat, 'th_res: ', this%th_res - !write(fates_log(),*) 'alpha:', this%alpha, 'm: ', this%m_vg, 'n: ', this%n_vg + ! write(fates_log(),*) 'set_wkf_param_vg' + ! write(fates_log(),*) 'th_sat:',this%th_sat, 'th_res: ', this%th_res + ! write(fates_log(),*) 'alpha:', this%alpha, 'm: ', this%m_vg, 'n: ', this%n_vg return end subroutine set_wkf_param_vg @@ -426,9 +415,8 @@ function get_thsat_vg(this) result(th_sat) th_sat = this%th_sat end function get_thsat_vg - ! ===================================================================================== - + function th_from_psi_vg(this,psi) result(th) ! Van Genuchten (1980) calculation of volumetric water content (theta) @@ -439,6 +427,8 @@ function th_from_psi_vg(this,psi) result(th) real(r8) :: satfrac ! Saturated fraction [-] real(r8) :: th ! Volumetric Water Cont [m3/m3] + real(r8) :: psi_interp ! psi where we start lin interp [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 real(r8) :: n ! pore size distribution param 2 @@ -452,7 +442,7 @@ function th_from_psi_vg(this,psi) result(th) ! Junyan modified to get rid of the linear interperation psi_interp = 0 - else + if(psith_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/n) ! psi = -a1 * (satfrac**m2 - 1)** m1 ! dpsi dth = -(m1)*a1*(satfrac**m2-1)**(m1-1) * m2*(satfrac)**(m2-1)*dsatfracdth - dpsidth = this%dpsidth_min - - else + ! f(x) = satfrac**m2 -1 + ! g(x) = a1*f(x)**m1 + ! dpsidth = g'(f(x)) f'(x) - satfrac = (th-this%th_res)/(this%th_sat-this%th_res) - dsatfrac_dth = 1._r8/(this%th_sat-this%th_res) + dpsidth = -m1*a1*(satfrac**m2 - 1._r8)**(m1-1._r8) * m2*satfrac**(m2-1._r8)*dsatfrac_dth - ! 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 if end function dpsidth_from_th_vg @@ -648,10 +633,9 @@ function dftcdpsi_from_psi_vg(this,psi) result(dftcdpsi) if(ftc<=min_ftc) then dftcdpsi = 0._r8 ! We cap ftc, so derivative is zero else - - !Old modification, incorrect, missed m in the formula - !t1 = (this%alpha*psi_eff)**n - !dt1 = this%alpha*(n)*(this%alpha*psi_eff)**(n-1._r8) + ! Old modification, incorrect, missed m in the formula + ! t1 = (this%alpha*psi_eff)**n + ! dt1 = this%alpha*(n)*(this%alpha*psi_eff)**(n-1._r8) ! Corrected on Jan 06, 2021 t1 = (this%alpha*psi_eff)**(n*m) @@ -693,13 +677,10 @@ subroutine set_wrf_param_cch(this,params_in) ! Set DERIVED constants ! used for interpolating in extreme ranges - this%th_max = max_sf_interp*this%th_sat - this%psi_max = this%psi_from_th(this%th_max-tiny(this%th_max)) - this%dpsidth_max = this%dpsidth_from_th(this%th_max-tiny(this%th_max)) - this%th_min = fates_unset_r8 - this%psi_min = fates_unset_r8 - this%dpsidth_min = fates_unset_r8 - + th_max = max_sf_interp*this%th_sat-1.e-9_r8 + this%psi_max = this%psi_from_th(th_max) + this%dpsidth_max = this%dpsidth_from_th(th_max) + return end subroutine set_wrf_param_cch @@ -715,7 +696,6 @@ subroutine set_wkf_param_cch(this,params_in) this%beta = params_in(3) return end subroutine set_wkf_param_cch - ! ===================================================================================== function get_thsat_cch(this) result(th_sat) @@ -725,18 +705,18 @@ function get_thsat_cch(this) result(th_sat) th_sat = this%th_sat end function get_thsat_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 = this%th_max + (psi-this%psi_max)/this%dpsidth_max + th = max_sf_interp*this%th_sat + (psi-this%psi_max)/this%dpsidth_max else th = this%th_sat*(psi/this%psi_sat)**(-1.0_r8/this%beta) end if @@ -750,8 +730,10 @@ 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 - if(th>this%th_max) then + 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) @@ -768,11 +750,10 @@ function dpsidth_from_th_cch(this,th) result(dpsidth) real(r8) :: dpsidth ! Differentiate: - if(th>this%th_max) then - dpsidth = this%dpsidth_max - else - dpsidth = -this%beta*this%psi_sat/this%th_sat * (th/this%th_sat)**(-this%beta-1._r8) - end if + ! 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 @@ -785,12 +766,10 @@ function ftc_from_psi_cch(this,psi) result(ftc) real(r8) :: psi_eff real(r8) :: ftc - ! th = th_sat * (psi/psi_sat)^(-1/b) - - ! ftc = (th/th_sat)^(2*b+3) - ! ftc = ( 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) + ! 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) @@ -842,6 +821,8 @@ subroutine set_wrf_param_tfs(this,params_in) class(wrf_type_tfs) :: this real(r8), intent(in) :: params_in(:) + real(r8) :: th_max + real(r8) :: th_min this%th_sat = params_in(1) this%th_res = params_in(2) @@ -854,11 +835,18 @@ subroutine set_wrf_param_tfs(this,params_in) this%cap_slp = params_in(9) this%pmedia = int(params_in(10)) - call this%set_min_max(this%th_res,this%th_sat) - + ! Set DERIVED constants + ! used for interpolating in extreme ranges + th_max=max_sf_interp*(this%th_sat-this%th_res)+this%th_res-1.e-9_r8 + th_min=min_sf_interp*(this%th_sat-this%th_res)+this%th_res+1.e-9_r8 + this%psi_max = this%psi_from_th(th_max) + this%dpsidth_max = this%dpsidth_from_th(th_max) + this%psi_min = this%psi_from_th(th_min) + this%dpsidth_min = this%dpsidth_from_th(th_min) + + return end subroutine set_wrf_param_tfs - ! ===================================================================================== function get_thsat_tfs(this) result(th_sat) @@ -870,7 +858,7 @@ function get_thsat_tfs(this) result(th_sat) end function get_thsat_tfs ! ===================================================================================== - + function th_from_psi_tfs(this,psi) result(th) class(wrf_type_tfs) :: this @@ -890,21 +878,21 @@ function th_from_psi_tfs(this,psi) result(th) if(psi>this%psi_max) then ! Linear range for extreme values - - th = this%th_linear_sat(psi) + th = this%th_res+max_sf_interp*(this%th_sat-this%th_res) + & + (psi-this%psi_max)/this%dpsidth_max elseif(psithis%th_max)then - - psi = this%psi_linear_sat(th) - - elseif(thmax_sf_interp) then + psi = this%psi_max + this%dpsidth_max * & + (th-(max_sf_interp*(this%th_sat-this%th_res)+this%th_res)) + + elseif(satfrac this%th_max) then + satfrac = (th-this%th_res)/(this%th_sat-this%th_res) + if(satfrac>max_sf_interp) then dpsidth = this%dpsidth_max - elseif(th wrf_vg + allocate(wrf_vg) + wrf_plant(pm,ft)%p => wrf_vg - call wrf_vg%set_wrf_param([EDPftvarcon_inst%hydr_alpha_vg(ft), & + call wrf_vg%set_wrf_param([EDPftvarcon_inst%hydr_alpha_vg(ft), & EDPftvarcon_inst%hydr_n_vg(ft), & EDPftvarcon_inst%hydr_m_vg(ft), & EDPftvarcon_inst%hydr_thetas_node(ft,pm), & diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 4549cfd446..6be57a6331 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -796,107 +796,6 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_rfrac_stem) - name = 'fates_hydr_avuln_gs' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%hydr_avuln_gs) - - name = 'fates_hydr_p50_gs' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%hydr_p50_gs) - - name = 'fates_mort_bmort' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%bmort) - - name = 'fates_mort_scalar_coldstress' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%mort_scalar_coldstress) - - name = 'fates_mort_scalar_cstarvation' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%mort_scalar_cstarvation) - - name = 'fates_mort_scalar_hydrfailure' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%mort_scalar_hydrfailure) - - - name = 'fates_mort_ip_size_senescence' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%mort_ip_size_senescence) - - name = 'fates_mort_r_size_senescence' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%mort_r_size_senescence) - - name = 'fates_mort_ip_age_senescence' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%mort_ip_age_senescence) - - name = 'fates_allom_d2bl1' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_d2bl1) - - name = 'fates_allom_d2bl2' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_d2bl2) - - name = 'fates_allom_d2bl3' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_d2bl3) - - name = 'fates_allom_blca_expnt_diff' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_blca_expnt_diff) - - name = 'fates_allom_d2ca_coefficient_max' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_d2ca_coefficient_max) - - name = 'fates_allom_d2ca_coefficient_min' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_d2ca_coefficient_min) - - name = 'fates_allom_sai_scaler' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_sai_scaler) - - name = 'fates_allom_agb1' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_agb1) - - name = 'fates_allom_agb2' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_agb2) - - name = 'fates_allom_agb3' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_agb3) - - name = 'fates_allom_agb4' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_agb4) - - name = 'fates_allom_frbstor_repro' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_frbstor_repro) - - name = 'fates_hydr_p_taper' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%hydr_p_taper) - - name = 'fates_hydr_rs2' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%hydr_rs2) - - name = 'fates_hydr_srl' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%hydr_srl) - - name = 'fates_hydr_rfrac_stem' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%hydr_rfrac_stem) - name = 'fates_hydr_alpha_vg' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_alpha_vg) @@ -909,10 +808,6 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_n_vg) - name = 'fates_hydr_k_lwp' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%hydr_k_lwp) - name = 'fates_hydr_avuln_gs' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_avuln_gs) @@ -925,6 +820,18 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%bmort) + name = 'fates_mort_scalar_coldstress' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%mort_scalar_coldstress) + + name = 'fates_mort_scalar_cstarvation' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%mort_scalar_cstarvation) + + name = 'fates_mort_scalar_hydrfailure' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%mort_scalar_hydrfailure) + name = 'fates_mort_ip_size_senescence' call fates_params%RetreiveParameterAllocate(name=name, & data=this%mort_ip_size_senescence) @@ -948,8 +855,7 @@ subroutine Receive_PFT(this, fates_params) name = 'fates_mort_scalar_cstarvation' call fates_params%RetreiveParameterAllocate(name=name, & data=this%mort_scalar_cstarvation) - - + name = 'fates_mort_hf_sm_threshold' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hf_sm_threshold) @@ -1497,32 +1403,7 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'phen_cold_size_threshold = ',EDPftvarcon_inst%phen_cold_size_threshold write(fates_log(),fmt0) 'phen_stem_drop_fraction',EDpftvarcon_inst%phen_stem_drop_fraction write(fates_log(),fmt0) 'fire_alpha_SH = ',EDPftvarcon_inst%fire_alpha_SH - write(fates_log(),fmt0) 'allom_hmode = ',EDPftvarcon_inst%allom_hmode - write(fates_log(),fmt0) 'allom_lmode = ',EDPftvarcon_inst%allom_lmode - write(fates_log(),fmt0) 'allom_fmode = ',EDPftvarcon_inst%allom_fmode - write(fates_log(),fmt0) 'allom_amode = ',EDPftvarcon_inst%allom_amode - write(fates_log(),fmt0) 'allom_cmode = ',EDPftvarcon_inst%allom_cmode - write(fates_log(),fmt0) 'allom_smode = ',EDPftvarcon_inst%allom_smode - write(fates_log(),fmt0) 'allom_la_per_sa_int = ',EDPftvarcon_inst%allom_la_per_sa_int - write(fates_log(),fmt0) 'allom_la_per_sa_slp = ',EDPftvarcon_inst%allom_la_per_sa_slp - write(fates_log(),fmt0) 'allom_l2fr = ',EDPftvarcon_inst%allom_l2fr - write(fates_log(),fmt0) 'allom_agb_frac = ',EDPftvarcon_inst%allom_agb_frac - write(fates_log(),fmt0) 'allom_d2h1 = ',EDPftvarcon_inst%allom_d2h1 - write(fates_log(),fmt0) 'allom_d2h2 = ',EDPftvarcon_inst%allom_d2h2 - write(fates_log(),fmt0) 'allom_d2h3 = ',EDPftvarcon_inst%allom_d2h3 - write(fates_log(),fmt0) 'allom_d2bl1 = ',EDPftvarcon_inst%allom_d2bl1 - write(fates_log(),fmt0) 'allom_d2bl2 = ',EDPftvarcon_inst%allom_d2bl2 - write(fates_log(),fmt0) 'allom_d2bl3 = ',EDPftvarcon_inst%allom_d2bl3 - write(fates_log(),fmt0) 'allom_sai_scaler = ',EDPftvarcon_inst%allom_sai_scaler - write(fates_log(),fmt0) 'allom_blca_expnt_diff = ',EDPftvarcon_inst%allom_blca_expnt_diff - write(fates_log(),fmt0) 'allom_d2ca_coefficient_max = ',EDPftvarcon_inst%allom_d2ca_coefficient_max - write(fates_log(),fmt0) 'allom_d2ca_coefficient_min = ',EDPftvarcon_inst%allom_d2ca_coefficient_min - write(fates_log(),fmt0) 'allom_agb1 = ',EDPftvarcon_inst%allom_agb1 - write(fates_log(),fmt0) 'allom_agb2 = ',EDPftvarcon_inst%allom_agb2 - write(fates_log(),fmt0) 'allom_agb3 = ',EDPftvarcon_inst%allom_agb3 - write(fates_log(),fmt0) 'allom_agb4 = ',EDPftvarcon_inst%allom_agb4 - write(fates_log(),fmt0) 'allom_frbstor_repro = ',EDPftvarcon_inst%allom_frbstor_repro - write(fates_log(),fmt0) 'allom_frbstor_repro = ',EDPftvarcon_inst%allom_frbstor_repro + write(fates_log(),fmt0) 'allom_frbstor_repro = ',EDPftvarcon_inst%allom_frbstor_repro write(fates_log(),fmt0) 'hydr_p_taper = ',EDPftvarcon_inst%hydr_p_taper write(fates_log(),fmt0) 'hydr_rs2 = ',EDPftvarcon_inst%hydr_rs2 write(fates_log(),fmt0) 'hydr_srl = ',EDPftvarcon_inst%hydr_srl From 2e3fe61e5f9b2966245afaca14c66acb9c0eef0c Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 5 Apr 2021 22:23:50 -0600 Subject: [PATCH 248/578] added logic to use internally-fates-saved info on snow depth during restarts for b4b-ness --- biogeochem/EDCanopyStructureMod.F90 | 19 ++++++++++++++----- main/EDInitMod.F90 | 1 + main/EDTypesMod.F90 | 1 + main/FatesRestartInterfaceMod.F90 | 9 +++++++++ 4 files changed, 25 insertions(+), 5 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 21bc96cb6b..d29b3451a9 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1251,7 +1251,7 @@ end subroutine canopy_spread ! ===================================================================================== - subroutine canopy_summarization( nsites, sites, bc_in ) + subroutine canopy_summarization( nsites, sites, bc_in, is_called_at_restart ) ! ---------------------------------------------------------------------------------- ! Much of this routine was once ed_clm_link minus all the IO and history stuff @@ -1269,6 +1269,7 @@ subroutine canopy_summarization( 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) + integer , intent(in) :: is_called_at_restart ! ifalse = daily timestep, itrue = restart ! ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch @@ -1380,7 +1381,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentPatch => currentPatch%younger end do !patch loop - call leaf_area_profile(sites(s),bc_in(s)%snow_depth_si,bc_in(s)%frac_sno_eff_si) + call leaf_area_profile(sites(s),bc_in(s)%snow_depth_si,bc_in(s)%frac_sno_eff_si, is_called_at_restart) end do ! site loop @@ -1389,7 +1390,7 @@ end subroutine canopy_summarization ! ===================================================================================== - subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) + subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si, is_called_at_restart) ! ----------------------------------------------------------------------------------- ! This subroutine calculates how leaf and stem areas are distributed @@ -1433,6 +1434,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) type(ed_site_type) , intent(inout) :: currentSite real(r8) , intent(in) :: snow_depth_si real(r8) , intent(in) :: frac_sno_eff_si + integer , intent(in) :: is_called_at_restart ! ifalse = daily timestep, itrue = restart ! ! !LOCAL VARIABLES: @@ -1534,6 +1536,15 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) enddo !currentCohort + ! calculate average snow depth. + snow_depth_avg = snow_depth_si * frac_sno_eff_si + + if ( is_called_at_restart .eq. ifalse ) then ! normal timestepping + currentSite%snow_depth = snow_depth_avg + else ! restart step + snow_depth_avg = currentSite%snow_depth + endif + if(smooth_leaf_distribution == 1)then ! ----------------------------------------------------------------------------- @@ -1581,7 +1592,6 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) currentCohort%sai !snow burial - snow_depth_avg = snow_depth_si * frac_sno_eff_si if(snow_depth_avg > maxh(iv))then fraction_exposed = 0._r8 endif @@ -1678,7 +1688,6 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) EDPftvarcon_inst%crown(currentCohort%pft) ) fraction_exposed = 1.0_r8 - snow_depth_avg = snow_depth_si * frac_sno_eff_si if(snow_depth_avg > layer_top_hite)then fraction_exposed = 0._r8 endif diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 19a9d2cb00..bb380b0a00 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -174,6 +174,7 @@ subroutine zero_site( site_in ) site_in%cstatus = fates_unset_int ! are leaves in this pixel on or off? site_in%dstatus = fates_unset_int site_in%grow_deg_days = nan ! growing degree days + site_in%snow_depth = nan site_in%nchilldays = fates_unset_int site_in%ncolddays = fates_unset_int site_in%cleafondate = fates_unset_int ! doy of leaf on diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 110673f94a..e77a83e00d 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -703,6 +703,7 @@ module EDTypesMod ! PHENOLOGY real(r8) :: grow_deg_days ! Phenology growing degree days + real(r8) :: snow_depth ! site-level snow depth (used for ELAI/TLAI calcs) integer :: cstatus ! are leaves in this pixel on or off for cold decid ! 0 = this site has not experienced a cold period over at least diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 0b621dec0a..979684f856 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -86,6 +86,7 @@ module FatesRestartInterfaceMod integer :: ir_dleafoffdate_si integer :: ir_acc_ni_si integer :: ir_gdd_si + integer :: ir_snow_depth_si integer :: ir_trunk_product_si integer :: ir_ncohort_pa integer :: ir_canopy_layer_co @@ -622,6 +623,10 @@ subroutine define_restart_vars(this, initialize_variables) long_name='growing degree days at each site', units='degC days', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gdd_si ) + call this%set_restart_var(vname='fates_snow_depth_site', vtype=site_r8, & + long_name='growing degree days at each site', units='degC days', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_snow_depth_si ) + call this%set_restart_var(vname='fates_trunk_product_site', vtype=site_r8, & long_name='Accumulate trunk product flux at site', & units='kgC/m2', flushval = flushzero, & @@ -1600,6 +1605,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_dleafoffdate_si => this%rvars(ir_dleafoffdate_si)%int1d, & rio_acc_ni_si => this%rvars(ir_acc_ni_si)%r81d, & rio_gdd_si => this%rvars(ir_gdd_si)%r81d, & + rio_snow_depth_si => this%rvars(ir_snow_depth_si)%r81d, & rio_trunk_product_si => this%rvars(ir_trunk_product_si)%r81d, & rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d, & rio_solar_zenith_flag_pa => this%rvars(ir_solar_zenith_flag_pa)%int1d, & @@ -2052,6 +2058,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_dleafoffdate_si(io_idx_si) = sites(s)%dleafoffdate rio_acc_ni_si(io_idx_si) = sites(s)%acc_NI rio_gdd_si(io_idx_si) = sites(s)%grow_deg_days + rio_snow_depth_si(io_idx_si) = sites(s)%snow_depth ! Accumulated trunk product rio_trunk_product_si(io_idx_si) = sites(s)%resources_management%trunk_product_site @@ -2388,6 +2395,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_dleafoffdate_si => this%rvars(ir_dleafoffdate_si)%int1d, & rio_acc_ni_si => this%rvars(ir_acc_ni_si)%r81d, & rio_gdd_si => this%rvars(ir_gdd_si)%r81d, & + rio_snow_depth_si => this%rvars(ir_snow_depth_si)%r81d, & rio_trunk_product_si => this%rvars(ir_trunk_product_si)%r81d, & rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d, & rio_solar_zenith_flag_pa => this%rvars(ir_solar_zenith_flag_pa)%int1d, & @@ -2868,6 +2876,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%dleafoffdate = rio_dleafoffdate_si(io_idx_si) sites(s)%acc_NI = rio_acc_ni_si(io_idx_si) sites(s)%grow_deg_days = rio_gdd_si(io_idx_si) + sites(s)%snow_depth = rio_snow_depth_si(io_idx_si) sites(s)%resources_management%trunk_product_site = rio_trunk_product_si(io_idx_si) From 699f12e200488638f27b4d30e47e6495636a83ef Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 6 Apr 2021 12:52:50 -0400 Subject: [PATCH 249/578] Modified logic on snow depth tracking --- biogeochem/EDCanopyStructureMod.F90 | 71 ++++++++++++++++------------- 1 file changed, 40 insertions(+), 31 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index d29b3451a9..9f24d99fc3 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -29,6 +29,7 @@ module EDCanopyStructureMod use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking use FatesInterfaceTypesMod , only : numpft + use FatesInterfaceTypesMod, only : bc_in_type use FatesPlantHydraulicsMod, only : UpdateH2OVeg,InitHydrCohort, RecruitWaterStorage use EDTypesMod , only : maxCohortsPerPatch @@ -54,7 +55,8 @@ module EDCanopyStructureMod public :: calc_areaindex public :: canopy_summarization public :: update_hlm_dynamics - + public :: UpdateFatesAvgSnowDepth + logical, parameter :: debug=.false. character(len=*), parameter, private :: sourcefile = & @@ -122,7 +124,7 @@ subroutine canopy_structure( currentSite , bc_in ) use EDParamsMod, only : ED_val_comp_excln use EDTypesMod , only : min_patch_area - use FatesInterfaceTypesMod, only : bc_in_type + ! ! !ARGUMENTS type(ed_site_type) , intent(inout), target :: currentSite @@ -1251,13 +1253,12 @@ end subroutine canopy_spread ! ===================================================================================== - subroutine canopy_summarization( nsites, sites, bc_in, is_called_at_restart ) + subroutine canopy_summarization( nsites, sites, bc_in ) ! ---------------------------------------------------------------------------------- ! Much of this routine was once ed_clm_link minus all the IO and history stuff ! --------------------------------------------------------------------------------- - 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 @@ -1269,7 +1270,6 @@ subroutine canopy_summarization( nsites, sites, bc_in, is_called_at_restart ) integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) type(bc_in_type) , intent(in) :: bc_in(nsites) - integer , intent(in) :: is_called_at_restart ! ifalse = daily timestep, itrue = restart ! ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch @@ -1381,16 +1381,37 @@ subroutine canopy_summarization( nsites, sites, bc_in, is_called_at_restart ) currentPatch => currentPatch%younger end do !patch loop - call leaf_area_profile(sites(s),bc_in(s)%snow_depth_si,bc_in(s)%frac_sno_eff_si, is_called_at_restart) + call leaf_area_profile(sites(s)) end do ! site loop return end subroutine canopy_summarization - - ! ===================================================================================== - subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si, is_called_at_restart) + ! ==================================================================================== + + subroutine UpdateFatesAvgSnowDepth(sites,bc_in) + + ! This routine updates the snow depth used in FATES to occlude vegetation + ! Currently this average takes into account the depth of snow and the + ! areal coverage fraction + + type(ed_site_type) , intent(inout), target :: sites(:) + type(bc_in_type) , intent(in) :: bc_in(:) + + integer :: s + + do s = 1, size(sites,dim=1) + sites(s)%snow_depth = bc_in(s)%snow_depth_si * bc_in(s)%frac_sno_eff_si + end do + + return + end subroutine UpdateFatesAvgSnowDepth + + + ! ===================================================================================== + + subroutine leaf_area_profile( currentSite ) ! ----------------------------------------------------------------------------------- ! This subroutine calculates how leaf and stem areas are distributed @@ -1432,9 +1453,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si, is_c ! ! !ARGUMENTS type(ed_site_type) , intent(inout) :: currentSite - real(r8) , intent(in) :: snow_depth_si - real(r8) , intent(in) :: frac_sno_eff_si - integer , intent(in) :: is_called_at_restart ! ifalse = daily timestep, itrue = restart + ! ! !LOCAL VARIABLES: @@ -1457,7 +1476,6 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si, is_c real(r8) :: min_chite ! bottom of cohort canopy (m) real(r8) :: max_chite ! top of cohort canopy (m) real(r8) :: lai ! summed lai for checking m2 m-2 - real(r8) :: snow_depth_avg ! avg snow over whole site real(r8) :: leaf_c ! leaf carbon [kg] !---------------------------------------------------------------------- @@ -1536,15 +1554,6 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si, is_c enddo !currentCohort - ! calculate average snow depth. - snow_depth_avg = snow_depth_si * frac_sno_eff_si - - if ( is_called_at_restart .eq. ifalse ) then ! normal timestepping - currentSite%snow_depth = snow_depth_avg - else ! restart step - snow_depth_avg = currentSite%snow_depth - endif - if(smooth_leaf_distribution == 1)then ! ----------------------------------------------------------------------------- @@ -1592,14 +1601,14 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si, is_c currentCohort%sai !snow burial - if(snow_depth_avg > maxh(iv))then + if(currentSite%snow_depth > maxh(iv))then fraction_exposed = 0._r8 endif - if(snow_depth_avg < minh(iv))then + if(currentSite%snow_depth < minh(iv))then fraction_exposed = 1._r8 endif - if(snow_depth_avg>= minh(iv).and.snow_depth_avg <= maxh(iv))then !only partly hidden... - fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(snow_depth_avg-minh(iv))/dh))) + if(currentSite%snow_depth >= minh(iv) .and. currentSite%snow_depth <= maxh(iv)) then !only partly hidden... + fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(currentSite%snow_depth-minh(iv))/dh))) endif if ( debug ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) @@ -1688,15 +1697,15 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si, is_c EDPftvarcon_inst%crown(currentCohort%pft) ) fraction_exposed = 1.0_r8 - if(snow_depth_avg > layer_top_hite)then + if(currentSite%snow_depth > layer_top_hite)then fraction_exposed = 0._r8 endif - if(snow_depth_avg < layer_bottom_hite)then + if(currentSite%snow_depth < layer_bottom_hite)then fraction_exposed = 1._r8 endif - if( snow_depth_avg>= layer_bottom_hite .and. & - snow_depth_avg <= layer_top_hite) then !only partly hidden... - fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(snow_depth_avg-layer_bottom_hite)/ & + if(currentSite%snow_depth >= layer_bottom_hite .and. & + currentSite%snow_depth <= layer_top_hite) then !only partly hidden... + fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(currentSite%snow_depth -layer_bottom_hite)/ & (layer_top_hite-layer_bottom_hite )))) endif From bf261ff3eb827aaf9b3567a8c007153fd23242b4 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 6 Apr 2021 11:23:18 -0600 Subject: [PATCH 250/578] fixed metadata on snow_depth restart variable --- main/FatesRestartInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 979684f856..fc6ac09c8a 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -624,7 +624,7 @@ subroutine define_restart_vars(this, initialize_variables) hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gdd_si ) call this%set_restart_var(vname='fates_snow_depth_site', vtype=site_r8, & - long_name='growing degree days at each site', units='degC days', flushval = flushzero, & + long_name='average snow depth', units='m', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_snow_depth_si ) call this%set_restart_var(vname='fates_trunk_product_site', vtype=site_r8, & From ff0fee8a70152b886eb6fddad47951a7cae64f4b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 6 Apr 2021 16:59:01 -0400 Subject: [PATCH 251/578] removing unused code for demand calculations in new plants --- biogeochem/FatesSoilBGCFluxMod.F90 | 29 +++-------------------------- 1 file changed, 3 insertions(+), 26 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 97e6979165..68a895c2b7 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -135,33 +135,10 @@ function GetPlantDemand(ccohort,element_id) result(plant_demand) ! If the cohort has not experienced a day of integration - ! (and thus any allocation yet), we specify demand - ! based purely on a fraction of its starting nutrient content + ! (and thus any allocation yet), it has no deficit + ! in its storage to drive any need, so it thus has no demand if(ccohort%isnew) then - - if(element_id.eq.nitrogen_element) then - - leafm = ccohort%prt%GetState(leaf_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(leaf_organ)) - fnrtm = ccohort%prt%GetState(fnrt_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(fnrt_organ)) - sapwm = ccohort%prt%GetState(sapw_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(sapw_organ)) - structm = ccohort%prt%GetState(struct_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(struct_organ)) - storem = StorageNutrientTarget(pft, element_id, leafm,fnrtm,sapwm,structm) - - plant_max_x = leafm+fnrtm+sapwm+structm+storem - - elseif(element_id.eq.phosphorus_element) then - - leafm = ccohort%prt%GetState(leaf_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(leaf_organ)) - fnrtm = ccohort%prt%GetState(fnrt_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(fnrt_organ)) - sapwm = ccohort%prt%GetState(sapw_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(sapw_organ)) - structm = ccohort%prt%GetState(struct_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(struct_organ)) - storem = StorageNutrientTarget(pft, element_id, leafm,fnrtm,sapwm,structm) - - plant_max_x = leafm+fnrtm+sapwm+structm+storem - - end if - - plant_demand = 0._r8 ! (let the storage handle the first day) init_demand_frac*plant_max_x + plant_demand = 0._r8 return end if From 1d5a73cd4d8081e72767128147e66d81281a1e24 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 7 Apr 2021 12:21:17 -0400 Subject: [PATCH 252/578] Reverted to nclmax=2, as that would be a different feature to use >2 --- main/EDTypesMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 5633f041cb..79314c158b 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -28,7 +28,7 @@ module EDTypesMod (/ 10, 4 /) !!! MUST SUM TO maxPatchesPerSite !!! integer, public :: maxCohortsPerPatch = 150 ! maximum number of cohorts per patch - integer, parameter, public :: nclmax = 3 ! Maximum number of canopy layers + integer, parameter, public :: nclmax = 2 ! Maximum number of canopy layers integer, parameter, public :: ican_upper = 1 ! Nominal index for the upper canopy integer, parameter, public :: ican_ustory = 2 ! Nominal index for diagnostics that refer ! to understory layers (all layers that From 094a752c43f0b2f947c79a09b39e5e7550c45e07 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 7 Apr 2021 12:34:29 -0400 Subject: [PATCH 253/578] minor comment and cleanings to FatesSoilBGCFluxMod.F90 --- biogeochem/FatesSoilBGCFluxMod.F90 | 9 --------- 1 file changed, 9 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 68a895c2b7..55c0149571 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -681,7 +681,6 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) ccohort => cpatch%tallest do while (associated(ccohort)) pft = ccohort%pft - dbh = ccohort%dbh if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then icomp = icomp+1 else @@ -703,7 +702,6 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) ccohort => cpatch%tallest do while (associated(ccohort)) pft = ccohort%pft - dbh = ccohort%dbh if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then icomp = icomp+1 else @@ -1060,13 +1058,6 @@ function ECACScalar(ccohort, element_id) result(c_scalar) c_scalar = max(0._r8,min(1._r8,logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))))) -! if(element_id==nitrogen_element) then -! print*,"DBH, N STOREFRAC: ",ccohort%dbh,c_scalar,store_frac,ccohort%prt%GetState(store_organ, element_id),store_max -! else -! print*,"DBH, P STOREFRAC: ",ccohort%dbh,c_scalar,store_frac,ccohort%prt%GetState(store_organ, element_id),store_max -! end if - - call check_var_real(c_scalar,'c_scalar',icode) if (icode .ne. 0) then write(fates_log(),*) 'c_scalar is invalid, element: ',element_id From f75de402848c2403ed8770bd7a6d6512e9be64dd Mon Sep 17 00:00:00 2001 From: Junyan Ding Date: Wed, 7 Apr 2021 14:08:00 -0700 Subject: [PATCH 254/578] but fix Apr07 2021 --- biogeophys/FatesPlantHydraulicsMod.F90 | 34 ++++++++++++++++-------- parameter_files/fates_params_default.cdl | 4 +-- 2 files changed, 25 insertions(+), 13 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index c2c50cbe91..ec9e3deb74 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -66,7 +66,7 @@ module FatesPlantHydraulicsMod use FatesAllometryMod, only : bsap_allom use FatesAllometryMod, only : CrownDepth use FatesAllometryMod , only : set_root_fraction - use FatesAllometryMod , only : i_hydro_rootprof_context + ! use FatesAllometryMod , only : i_hydro_rootprof_context use FatesHydraulicsMemMod, only: use_2d_hydrosolve use FatesHydraulicsMemMod, only: ed_site_hydr_type use FatesHydraulicsMemMod, only: ed_cohort_hydr_type @@ -179,7 +179,7 @@ module FatesPlantHydraulicsMod ! (if we are going to help purge super-saturation) logical,parameter :: debug = .false. ! flag to report warning in hydro - logical,public, parameter :: JD_debug = .false. ! Junyan added to debug my modifications + logical,public, parameter :: JD_debug = .true. ! Junyan added to debug my modifications character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -928,7 +928,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! alternative cross section calculation ! a_sapwood = a_leaf_tot / ( 0.001_r8 + 0.025_r8 * ccohort%hite ) * 1.e-4_r8 - crown_depth = prt_params%crown(ft) * ccohort%hite + crown_depth = EDPftvarcon_inst%crown(ft) * ccohort%hite 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 @@ -1368,7 +1368,7 @@ subroutine InitHydrSites(sites,bc_in) end subroutine InitHydrSites ! =================================================================================== - subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) + subroutine HydrSiteColdStart(sites, bc_in ) ! , bc_out) ! Arguments @@ -1546,7 +1546,7 @@ subroutine UpdateH2OVeg(nsites,sites,bc_out) 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 - ! check for nan value + ! check for nan value , Junyan do ily = 1,csite_hydr%nlevrhiz if(ccohort_hydr%th_aroot(ily)/=ccohort_hydr%th_aroot(ily)) then ccohort_hydr%th_aroot(ily) = 0 @@ -1578,7 +1578,7 @@ subroutine UpdateH2OVeg(nsites,sites,bc_out) ! 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) if (JD_debug) then - write(fates_log(),*) 'check NaN, line 1561' + write(fates_log(),*) 'check NaN in , line 1561' write(fates_log(),*) 'csite_hydr%h2oveg:',csite_hydr%h2oveg write(fates_log(),*) 'csite_hydr%h2oveg_dead:',csite_hydr%h2oveg_dead write(fates_log(),*) 'csite_hydr%h2oveg_growturn_err:', csite_hydr%h2oveg_growturn_err @@ -1681,9 +1681,10 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) endif end do ! site loop - !write(fates_log(),*) 'Calculating recruit water' - !write(fates_log(),*) csite_hydr%recruit_w_uptake - + if (JD_debug) then + write(fates_log(),*) 'Calculating recruit uptake' + write(fates_log(),*) csite_hydr%recruit_w_uptake(:) + endif end subroutine RecruitWUptake @@ -2429,6 +2430,15 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) prev_h2oveg = site_hydr%h2oveg prev_h2osoil = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & site_hydr%v_shell(:,:)) * denh2o * AREA_INV + + ! 2433 + if (JD_debug) then + write(fates_log(),*) ' line 2434' + write(fates_log(),*) 'prev_h2oveg', prev_h2oveg + write(fates_log(),*) 'prev_h2osoil',prev_h2osoil + write(fates_log(),*) 'site_hydr%h2osoi_liqvol_shell(:,:)',site_hydr%h2osoi_liqvol_shell(:,:) + write(fates_log(),*) 'site_hydr%v_shell(:,:)',site_hydr%v_shell(:,:) + endif bc_out(s)%qflx_ro_sisl(:) = 0._r8 @@ -2649,8 +2659,10 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! Junyan added loginfo write(fates_log(),*) 'root_flux: ', root_flux + ! Junyan added, to set bc_out of every soil layer to be 0, then only update the layers that having roots bc_out(s)%qflx_soil2root_sisl(:) = 0 bc_out(s)%qflx_ro_sisl(:) = 0 + do j=1,site_hydr%nlevrhiz j_bc = j+site_hydr%i_rhiz_t-1 @@ -2712,9 +2724,9 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) end do bc_out(s)%qflx_ro_sisl(j_bc) = site_runoff/dtime - end if + end if ! purge_supersaturation end if ! adjust for Nan - enddo + enddo ! update bc_out ! Note that the cohort-level solvers are expected to update diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 44a7865cdf..b1ca374fa0 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -813,9 +813,9 @@ data: fates_allom_dbh_max = 100, 100, 100, 100, 100, 100, 2, 2, 2, 2, 2, 2 ; - fates_allom_dbh_0 = 1, 1, 1, 2.5, 2.5, 2.5, 1, 1, 1, 1, 1, 1 ; + fates_allom_dbh_0 = 1, 1, 1, 2.5, 2.5, 2.5, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 ; - fates_allom_zfr_max = 9, 9, 9, 9, 8, 8, 1, 1, 1, 1, 1, 1 ; + fates_allom_zfr_max = 9, 9, 9, 9, 8, 8, 2, 2, 2, 2, 2, 2 ; fates_allom_zfr_0 = 1, 1, 1, 1, 1, 1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 ; From c9f49fb02c44973aac0c19677635633d8253cca6 Mon Sep 17 00:00:00 2001 From: Junyan Ding Date: Wed, 7 Apr 2021 14:11:22 -0700 Subject: [PATCH 255/578] bug fix Apr07 2021 --- biogeophys/FatesPlantHydraulicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index ec9e3deb74..08270e1e8e 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -179,7 +179,7 @@ module FatesPlantHydraulicsMod ! (if we are going to help purge super-saturation) logical,parameter :: debug = .false. ! flag to report warning in hydro - logical,public, parameter :: JD_debug = .true. ! Junyan added to debug my modifications + logical,public, parameter :: JD_debug = .false. ! Junyan added to debug my modifications character(len=*), parameter, private :: sourcefile = & __FILE__ From aeaca3057238b109162c1a88161f3df69371f33c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 9 Apr 2021 15:59:14 -0400 Subject: [PATCH 256/578] Moved storage nutrient calculation to PRTGeneric and call it from more locations. Started shift to add in thaw depth to root depth calculations. --- biogeochem/EDCohortDynamicsMod.F90 | 13 +++-- biogeochem/EDLoggingMortalityMod.F90 | 6 ++- biogeochem/EDPatchDynamicsMod.F90 | 23 ++++++--- biogeochem/EDPhysiologyMod.F90 | 2 +- biogeochem/FatesAllometryMod.F90 | 34 ++++++++++--- biogeochem/FatesSoilBGCFluxMod.F90 | 4 +- main/EDInitMod.F90 | 2 +- main/EDTypesMod.F90 | 2 +- main/FatesInventoryInitMod.F90 | 2 +- parteh/PRTAllometricCNPMod.F90 | 74 ++------------------------- parteh/PRTGenericMod.F90 | 76 +++++++++++++++++++++++++++- parteh/PRTParamsFATESMod.F90 | 24 ++++++--- 12 files changed, 157 insertions(+), 105 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 3621ceec1b..96d9f482e9 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -695,7 +695,7 @@ subroutine zero_cohort(cc_p) end subroutine zero_cohort !-------------------------------------------------------------------------------------! - subroutine terminate_cohorts( currentSite, currentPatch, level , call_index) + subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_in) ! ! !DESCRIPTION: ! terminates cohorts when they get too small @@ -708,7 +708,8 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index) type (ed_patch_type), intent(inout), target :: currentPatch integer , intent(in) :: level integer :: call_index - + type(bc_in_type), intent(in) :: bc_in + ! Important point regarding termination levels. Termination is typically ! called after fusion. We do this so that we can re-capture the biomass that would ! otherwise be lost from termination. The biomass of a fused plant remains in the @@ -824,7 +825,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index) if (currentCohort%n.gt.0.0_r8) then call SendCohortToLitter(currentSite,currentPatch, & - currentCohort,currentCohort%n) + currentCohort,currentCohort%n, bc_in) end if ! Set pointers and remove the current cohort from the list @@ -858,7 +859,7 @@ end subroutine terminate_cohorts ! ===================================================================================== - subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant) + subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) ! ----------------------------------------------------------------------------------- ! This routine transfers the existing mass in all pools and all elements @@ -882,6 +883,7 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant) type (ed_cohort_type) , target :: ccohort real(r8) :: nplant ! Number (absolute) ! of plants to transfer + type(bc_in_type), intent(in) :: bc_in ! type(litter_type), pointer :: litt ! Litter object for each element @@ -907,7 +909,8 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant) plant_dens = nplant/cpatch%area - call set_root_fraction(csite%rootfrac_scr, pft, csite%zi_soil) + call set_root_fraction(csite%rootfrac_scr, pft, csite%zi_soil, & + bc_in%max_rooting_depth_index_col) do el=1,num_elements diff --git a/biogeochem/EDLoggingMortalityMod.F90 b/biogeochem/EDLoggingMortalityMod.F90 index a6228e7b20..b8295bbf55 100644 --- a/biogeochem/EDLoggingMortalityMod.F90 +++ b/biogeochem/EDLoggingMortalityMod.F90 @@ -394,7 +394,7 @@ end subroutine get_harvest_rate_area ! ============================================================================ - subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site_areadis) + subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site_areadis, bc_in) ! ------------------------------------------------------------------------------------------- ! @@ -440,6 +440,7 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site type(ed_patch_type) , intent(inout), target :: currentPatch type(ed_patch_type) , intent(inout), target :: newPatch real(r8) , intent(in) :: patch_site_areadis + type(bc_in_type) , intent(in) :: bc_in !LOCAL VARIABLES: type(ed_cohort_type), pointer :: currentCohort @@ -567,7 +568,8 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site ! derived from the current patch, so we need to multiply by patch_areadis/np%area ! ---------------------------------------------------------------------------------------- - call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil) + call set_root_fraction(currentSite%rootfrac_scr, pft, & + currentSite%zi_soil, bc_in%max_rooting_depth_index_col) ag_wood = (direct_dead+indirect_dead) * (struct_m + sapw_m ) * & prt_params%allom_agb_frac(currentCohort%pft) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 5a49695d15..d31c4ec7a8 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -659,11 +659,14 @@ subroutine spawn_patches( currentSite, bc_in) ! Transfer in litter fluxes from plants in various contexts of death and destruction if(currentPatch%disturbance_mode .eq. dtype_ilog) then - call logging_litter_fluxes(currentSite, currentPatch, new_patch, patch_site_areadis) + call logging_litter_fluxes(currentSite, currentPatch, & + new_patch, patch_site_areadis,bc_in) elseif(currentPatch%disturbance_mode .eq. dtype_ifire) then - call fire_litter_fluxes(currentSite, currentPatch, new_patch, patch_site_areadis) + call fire_litter_fluxes(currentSite, currentPatch, & + new_patch, patch_site_areadis,bc_in) else - call mortality_litter_fluxes(currentSite, currentPatch, new_patch, patch_site_areadis) + call mortality_litter_fluxes(currentSite, currentPatch, & + new_patch, patch_site_areadis,bc_in) endif ! -------------------------------------------------------------------------- @@ -1510,7 +1513,8 @@ end subroutine TransLitterNewPatch ! ============================================================================ - subroutine fire_litter_fluxes(currentSite, currentPatch, newPatch, patch_site_areadis) + subroutine fire_litter_fluxes(currentSite, currentPatch, & + newPatch, patch_site_areadis, bc_in) ! ! !DESCRIPTION: ! CWD pool burned by a fire. @@ -1530,6 +1534,7 @@ subroutine fire_litter_fluxes(currentSite, currentPatch, newPatch, patch_site_ar type(ed_patch_type) , intent(inout), target :: newPatch ! New Patch real(r8) , intent(in) :: patch_site_areadis ! Area being donated ! by current patch + type(bc_in_type) , intent(in) :: bc_in ! ! !LOCAL VARIABLES: @@ -1658,7 +1663,8 @@ subroutine fire_litter_fluxes(currentSite, currentPatch, newPatch, patch_site_ar site_mass%burn_flux_to_atm = site_mass%burn_flux_to_atm + burned_mass - call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil) + call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil, & + bc_in%max_rooting_depth_index_col) ! Contribution of dead trees to root litter (no root burn flux to atm) do dcmpy=1,ndcmpy @@ -1730,7 +1736,8 @@ end subroutine fire_litter_fluxes ! ============================================================================ - subroutine mortality_litter_fluxes(currentSite, currentPatch, newPatch, patch_site_areadis) + subroutine mortality_litter_fluxes(currentSite, currentPatch, & + newPatch, patch_site_areadis, bc_in) ! ! !DESCRIPTION: ! Carbon going from mortality associated with disturbance into CWD pools. @@ -1753,6 +1760,7 @@ subroutine mortality_litter_fluxes(currentSite, currentPatch, newPatch, patch_si type(ed_patch_type) , intent(inout), target :: newPatch real(r8) , intent(in) :: patch_site_areadis + type(bc_in_type) , intent(in) :: bc_in ! ! !LOCAL VARIABLES: type(ed_cohort_type), pointer :: currentCohort @@ -1867,7 +1875,8 @@ subroutine mortality_litter_fluxes(currentSite, currentPatch, newPatch, patch_si ag_wood = num_dead * (struct_m + sapw_m) * prt_params%allom_agb_frac(pft) bg_wood = num_dead * (struct_m + sapw_m) * (1.0_r8-prt_params%allom_agb_frac(pft)) - call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil) + call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil, & + bc_in%max_rooting_depth_index_col) do c=1,ncwd diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index d7d7a9e6a5..26248478dc 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -102,7 +102,7 @@ module EDPhysiologyMod use PRTLossFluxesMod, only : PRTPhenologyFlush use PRTLossFluxesMod, only : PRTDeciduousTurnover use PRTLossFluxesMod, only : PRTReproRelease - use PRTAllometricCNPMod, only : StorageNutrientTarget + use PRTGenericMod, only : StorageNutrientTarget implicit none private diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index a24653e652..8e27faae22 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -127,6 +127,8 @@ module FatesAllometryMod logical , parameter :: verbose_logging = .false. character(len=*), parameter :: sourcefile = __FILE__ + + logical, parameter :: debug = .false. ! If testing b4b with older versions, do not remove sapwood ! Our old methods with saldarriaga did not remove sapwood from the @@ -1968,7 +1970,7 @@ end subroutine carea_2pwr ! ========================================================================= - subroutine set_root_fraction(root_fraction, ft, zi) + subroutine set_root_fraction(root_fraction, ft, zi, max_nlevroot) ! ! !DESCRIPTION: @@ -1983,8 +1985,13 @@ subroutine set_root_fraction(root_fraction, ft, zi) ! !ARGUMENTS real(r8),intent(inout) :: root_fraction(:) ! Normalized profile integer, intent(in) :: ft ! functional typpe - real(r8),intent(in) :: zi(0:) ! Center of depth [m] + real(r8),intent(in) :: zi(0:) ! Center of depth [m] + + ! The soil may not be active over the soil whole column due to things + ! like permafrost. If so, compress profile over the maximum depth + integer,optional, intent(in) :: max_nlevroot + ! locals real(r8) :: a_par ! local temporary for "a" parameter real(r8) :: b_par ! "" "b" parameter @@ -2010,7 +2017,8 @@ subroutine set_root_fraction(root_fraction, ft, zi) integer :: root_profile_type integer :: corr_id(1) ! This is the bin with largest fraction - ! add/subtract any corrections there + ! add/subtract any corrections there + integer :: nlevroot real(r8) :: correction ! This correction ensures that root fractions ! sum to 1.0 @@ -2022,13 +2030,27 @@ subroutine set_root_fraction(root_fraction, ft, zi) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + nlevroot = ubound(zi,1) + + ! Set root fraction to zero in all layers, as some may be inactive + ! and we will only calculate the profiles over those + root_fraction(:) = 0._r8 + + if(present(max_nlevroot))then + if(debug .and. max_nlevroot<0)then + write(fates_log(),*) 'A maximum rooting layer depth <0 was specified' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + nlevroot = min(max_nlevroot,nlevroot) + end if + select case(nint(prt_params%fnrt_prof_mode(ft))) case ( exponential_1p_profile_type ) - call exponential_1p_root_profile(root_fraction, zi, prt_params%fnrt_prof_a(ft)) + call exponential_1p_root_profile(root_fraction(1:nlevroot), zi(0:nlevroot), prt_params%fnrt_prof_a(ft)) case ( jackson_beta_profile_type ) - call jackson_beta_root_profile(root_fraction, zi, prt_params%fnrt_prof_a(ft)) + call jackson_beta_root_profile(root_fraction(1:nlevroot), zi(0:nlevroot), prt_params%fnrt_prof_a(ft)) case ( exponential_2p_profile_type ) - call exponential_2p_root_profile(root_fraction, zi, & + call exponential_2p_root_profile(root_fraction(1:nlevroot), zi(0:nlevroot), & prt_params%fnrt_prof_a(ft),prt_params%fnrt_prof_b(ft)) case default diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 55c0149571..ae0e76cce2 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -74,7 +74,6 @@ module FatesSoilBGCFluxMod use FatesLitterMod , only : icellulose use PRTParametersMod , only : prt_params use EDPftvarcon , only : EDPftvarcon_inst - use PRTAllometricCNPMod, only : StorageNutrientTarget use FatesUtilsMod, only : check_var_real implicit none @@ -509,7 +508,8 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) bc_out%ft_index(icomp) = pft end if - call set_root_fraction(csite%rootfrac_scr, pft, csite%zi_soil) + call set_root_fraction(csite%rootfrac_scr, pft, csite%zi_soil, & + bc_in%max_rooting_depth_index_col ) fnrt_c = ccohort%prt%GetState(fnrt_organ, carbon12_element) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index ec45d8866d..f0d44b40a3 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -53,7 +53,7 @@ module EDInitMod use FatesAllometryMod , only : bsap_allom use FatesAllometryMod , only : bdead_allom use FatesAllometryMod , only : bstore_allom - use PRTAllometricCNPMod , only : StorageNutrientTarget + use PRTGenericMod , only : StorageNutrientTarget use FatesInterfaceTypesMod, only : hlm_parteh_mode use PRTGenericMod, only : prt_carbon_allom_hyp use PRTGenericMod, only : prt_cnp_flex_allom_hyp diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 79314c158b..4954601969 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -26,7 +26,7 @@ module EDTypesMod integer, parameter, public :: maxPatchesPerSite = 14 ! maximum number of patches to live on a site integer, parameter, public :: maxPatchesPerSite_by_disttype(n_anthro_disturbance_categories) = & (/ 10, 4 /) !!! MUST SUM TO maxPatchesPerSite !!! - integer, public :: maxCohortsPerPatch = 150 ! maximum number of cohorts per patch + integer, public :: maxCohortsPerPatch = 100 ! maximum number of cohorts per patch integer, parameter, public :: nclmax = 2 ! Maximum number of canopy layers integer, parameter, public :: ican_upper = 1 ! Nominal index for the upper canopy diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 8a2b588023..efdebb8708 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -62,7 +62,7 @@ module FatesInventoryInitMod use PRTGenericMod, only : phosphorus_element use PRTGenericMod, only : SetState use FatesConstantsMod, only : primaryforest - use PRTAllometricCNPMod, only : StorageNutrientTarget + use PRTGenericMod, only : StorageNutrientTarget implicit none private diff --git a/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 index 3ca51ca03a..b7db852a4e 100644 --- a/parteh/PRTAllometricCNPMod.F90 +++ b/parteh/PRTAllometricCNPMod.F90 @@ -27,7 +27,8 @@ module PRTAllometricCNPMod use PRTGenericMod , only : struct_organ use PRTGenericMod , only : all_organs use PRTGenericMod , only : prt_cnp_flex_allom_hyp - + use PRTGenericMod , only : StorageNutrientTarget + use FatesAllometryMod , only : bleaf use FatesAllometryMod , only : bsap_allom use FatesAllometryMod , only : bfineroot @@ -187,7 +188,7 @@ module PRTAllometricCNPMod ! phase, to give first dibs to leaves, even though they are ! in the same priority group as fineroots. - logical, parameter :: reproduce_conly = .false. + logical, parameter :: reproduce_conly = .true. ! Array of pointers are difficult in F90 @@ -235,7 +236,7 @@ module PRTAllometricCNPMod logical, parameter :: debug = .false. public :: InitPRTGlobalAllometricCNP - public :: StorageNutrientTarget + contains @@ -2305,74 +2306,7 @@ subroutine TargetAllometryCheck(bleaf,bfroot,bsap,bstore,bdead, & end if end subroutine TargetAllometryCheck - ! ==================================================================================== - function StorageNutrientTarget(pft, element_id, leaf_target, fnrt_target, sapw_target, struct_target) result(store_target) - - integer :: pft - integer :: element_id - real(r8) :: leaf_target ! Target leaf nutrient mass [kg] - real(r8) :: fnrt_target ! Target fineroot nutrient mass [kg] - real(r8) :: sapw_target ! Target sapwood nutrient mass [kg] - real(r8) :: struct_target ! Target structural nutrient mass [kg] - - real(r8) :: store_target ! Output: Target storage nutrient mass [kg] - - - ! ------------------------------------------------------------------------------------- - ! Choice of how nutrient storage target is proportioned to - ! Each choice makes the nutrient storage proportional the the "in-tissue" - ! total nitrogen content of 1 or more sets of organs - ! ------------------------------------------------------------------------------------- - - integer, parameter :: lfs_store_prop = 1 ! leaf-fnrt-sapw proportional storage - integer, parameter :: lfss_store_prop = 2 ! leaf-fnrt-sapw-struct proportional storage - integer, parameter :: fnrt_store_prop = 3 ! fineroot proportional storage - integer, parameter :: store_prop = fnrt_store_prop - - - select case(element_id) - case(carbon12_element) - write(fates_log(),*) 'Cannot call StorageNutrientTarget() for carbon' - write(fates_log(),*) 'exiting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - - case(nitrogen_element) - - if (store_prop == lfs_store_prop) then - - store_target = prt_params%nitr_store_ratio(pft) * (leaf_target + fnrt_target + sapw_target) - - elseif(store_prop==lfss_store_prop) then - - store_target = prt_params%nitr_store_ratio(pft) * (leaf_target + fnrt_target + sapw_target + struct_target) - - elseif(store_prop==fnrt_store_prop) then - - store_target = prt_params%nitr_store_ratio(pft) * fnrt_target - - end if - - - case(phosphorus_element) - - if (store_prop == lfs_store_prop) then - - store_target = prt_params%phos_store_ratio(pft) * (leaf_target + fnrt_target + sapw_target) - - elseif(store_prop==lfss_store_prop) then - - store_target = prt_params%nitr_store_ratio(pft) * (leaf_target + fnrt_target + sapw_target + struct_target) - - elseif(store_prop==fnrt_store_prop) then - - store_target = prt_params%phos_store_ratio(pft) * fnrt_target - - end if - end select - - - end function StorageNutrientTarget diff --git a/parteh/PRTGenericMod.F90 b/parteh/PRTGenericMod.F90 index 6a29a93b06..76d0e01eda 100644 --- a/parteh/PRTGenericMod.F90 +++ b/parteh/PRTGenericMod.F90 @@ -391,7 +391,8 @@ module PRTGenericMod ! Make necessary procedures public public :: GetCoordVal public :: SetState - + public :: StorageNutrientTarget + contains ! ===================================================================================== @@ -1400,6 +1401,77 @@ function GetNutrientTargetBase(this,element_id,organ_id,stoich_mode) result(targ return end function GetNutrientTargetBase - + + + ! ==================================================================================== + + function StorageNutrientTarget(pft, element_id, leaf_target, fnrt_target, sapw_target, struct_target) result(store_target) + + integer :: pft + integer :: element_id + real(r8) :: leaf_target ! Target leaf nutrient mass [kg] + real(r8) :: fnrt_target ! Target fineroot nutrient mass [kg] + real(r8) :: sapw_target ! Target sapwood nutrient mass [kg] + real(r8) :: struct_target ! Target structural nutrient mass [kg] + + real(r8) :: store_target ! Output: Target storage nutrient mass [kg] + + + ! ------------------------------------------------------------------------------------- + ! Choice of how nutrient storage target is proportioned to + ! Each choice makes the nutrient storage proportional the the "in-tissue" + ! total nitrogen content of 1 or more sets of organs + ! ------------------------------------------------------------------------------------- + + integer, parameter :: lfs_store_prop = 1 ! leaf-fnrt-sapw proportional storage + integer, parameter :: lfss_store_prop = 2 ! leaf-fnrt-sapw-struct proportional storage + integer, parameter :: fnrt_store_prop = 3 ! fineroot proportional storage + integer, parameter :: store_prop = fnrt_store_prop + + + select case(element_id) + case(carbon12_element) + write(fates_log(),*) 'Cannot call StorageNutrientTarget() for carbon' + write(fates_log(),*) 'exiting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + case(nitrogen_element) + + if (store_prop == lfs_store_prop) then + + store_target = prt_params%nitr_store_ratio(pft) * (leaf_target + fnrt_target + sapw_target) + + elseif(store_prop==lfss_store_prop) then + + store_target = prt_params%nitr_store_ratio(pft) * (leaf_target + fnrt_target + sapw_target + struct_target) + + elseif(store_prop==fnrt_store_prop) then + + store_target = prt_params%nitr_store_ratio(pft) * fnrt_target + + end if + + + case(phosphorus_element) + + if (store_prop == lfs_store_prop) then + + store_target = prt_params%phos_store_ratio(pft) * (leaf_target + fnrt_target + sapw_target) + + elseif(store_prop==lfss_store_prop) then + + store_target = prt_params%nitr_store_ratio(pft) * (leaf_target + fnrt_target + sapw_target + struct_target) + + elseif(store_prop==fnrt_store_prop) then + + store_target = prt_params%phos_store_ratio(pft) * fnrt_target + + end if + end select + + + end function StorageNutrientTarget + + end module PRTGenericMod diff --git a/parteh/PRTParamsFATESMod.F90 b/parteh/PRTParamsFATESMod.F90 index 035f101176..4442c090e8 100644 --- a/parteh/PRTParamsFATESMod.F90 +++ b/parteh/PRTParamsFATESMod.F90 @@ -30,6 +30,7 @@ module PRTInitParamsFatesMod use FatesAllometryMod , only : carea_allom use FatesAllometryMod , only : CheckIntegratedAllometries use FatesAllometryMod, only : set_root_fraction + use PRTGenericMod, only : StorageNutrientTarget use EDTypesMod, only : init_recruit_trim ! @@ -1417,22 +1418,31 @@ function NewRecruitTotalStoichiometry(ft,element_id) result(recruit_stoich) ! Total nutrient in a newly recruited plant select case(element_id) case(nitrogen_element) - + nutr_total = & c_struct*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + & - (1._r8 + prt_params%nitr_store_ratio(ft)) * & - (c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & + c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & c_fnrt*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & - c_sapw*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) ) + c_sapw*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) + & + StorageNutrientTarget(ft, element_id, & + c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)), & + c_fnrt*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)), & + c_sapw*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)), & + c_struct*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(struct_organ))) case(phosphorus_element) nutr_total = & c_struct*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + & - (1._r8 + prt_params%phos_store_ratio(ft)) * & - (c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & + c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & c_fnrt*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & - c_sapw*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) ) + c_sapw*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) + & + StorageNutrientTarget(ft, element_id, & + c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)), & + c_fnrt*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)), & + c_sapw*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)), & + c_struct*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(struct_organ))) + end select From d38a25a66a1066cfa7f81a2fa430d025806a64a9 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 9 Apr 2021 16:38:19 -0700 Subject: [PATCH 257/578] cleaning up merge for successful build --- biogeochem/EDCanopyStructureMod.F90 | 2 +- biogeochem/EDPatchDynamicsMod.F90 | 2 +- main/EDInitMod.F90 | 2 +- main/EDPftvarcon.F90 | 3 ++- 4 files changed, 5 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 3460871e7f..d4527c3e97 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -2194,7 +2194,7 @@ function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) res ! If so we need to make another layer. if(arealayer > currentPatch%area)then z = z + 1 - if(hlm_use_sp)then + if(hlm_use_sp.eq.itrue)then write(fates_log(),*) 'SPmode, canopy_layer full:',arealayer,currentPatch%area end if diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index d776db593e..ad034dd8a4 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1276,7 +1276,7 @@ subroutine set_patchno( currentSite ) currentPatch => currentPatch%younger enddo - if(hlm_use_sp)then + if(hlm_use_sp.eq.itrue)then patchno = 1 currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 1c2385c8f9..007d6dd68b 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -312,7 +312,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) sites(s)%acc_NI = acc_NI sites(s)%NF = 0.0_r8 - sites(s)%frac_burnt = 0.0_r8 + sites(s)%NF_successful = 0.0_r8 if(hlm_use_fixed_biogeog.eq.itrue)then ! MAPPING OF FATES PFTs on to HLM_PFTs diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 6ca06b3f43..d57233cbdb 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -629,7 +629,8 @@ subroutine Register_PFT(this, fates_params) pftmap_dim_names(2) = dimension_name_hlm_pftno name = 'fates_hlm_pft_map' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=pftmap_dim_names, lower_bounds=dim_lower_bound) + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=pftmap_dim_names, lower_bounds=dim_lower_bound) end subroutine Register_PFT From b9d43e3ec528a548124258db5a6f005059327a2c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sat, 10 Apr 2021 12:09:39 -0400 Subject: [PATCH 258/578] Adding thaw-depth to root depth calculations --- biogeochem/EDCohortDynamicsMod.F90 | 12 +++---- biogeochem/EDLoggingMortalityMod.F90 | 7 ++-- biogeochem/EDPatchDynamicsMod.F90 | 18 ++++------ biogeochem/EDPhysiologyMod.F90 | 3 +- biogeophys/EDBtranMod.F90 | 3 +- biogeophys/FatesBstressMod.F90 | 6 ++-- biogeophys/FatesPlantHydraulicsMod.F90 | 1 - biogeophys/FatesPlantRespPhotosynthMod.F90 | 3 +- main/EDInitMod.F90 | 16 +++++---- main/EDTypesMod.F90 | 11 ++++++ main/FatesInterfaceMod.F90 | 40 +++++++++++++++++++++- main/FatesInterfaceTypesMod.F90 | 39 +-------------------- main/FatesRestartInterfaceMod.F90 | 7 ++-- 13 files changed, 88 insertions(+), 78 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 96d9f482e9..331492956b 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -695,7 +695,7 @@ subroutine zero_cohort(cc_p) end subroutine zero_cohort !-------------------------------------------------------------------------------------! - subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_in) + subroutine terminate_cohorts( currentSite, currentPatch, level , call_index) ! ! !DESCRIPTION: ! terminates cohorts when they get too small @@ -708,7 +708,6 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ type (ed_patch_type), intent(inout), target :: currentPatch integer , intent(in) :: level integer :: call_index - type(bc_in_type), intent(in) :: bc_in ! Important point regarding termination levels. Termination is typically ! called after fusion. We do this so that we can re-capture the biomass that would @@ -825,7 +824,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ if (currentCohort%n.gt.0.0_r8) then call SendCohortToLitter(currentSite,currentPatch, & - currentCohort,currentCohort%n, bc_in) + currentCohort,currentCohort%n) end if ! Set pointers and remove the current cohort from the list @@ -859,7 +858,7 @@ end subroutine terminate_cohorts ! ===================================================================================== - subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) + subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant) ! ----------------------------------------------------------------------------------- ! This routine transfers the existing mass in all pools and all elements @@ -883,9 +882,6 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) type (ed_cohort_type) , target :: ccohort real(r8) :: nplant ! Number (absolute) ! of plants to transfer - type(bc_in_type), intent(in) :: bc_in - - ! type(litter_type), pointer :: litt ! Litter object for each element type(site_fluxdiags_type),pointer :: flux_diags @@ -910,7 +906,7 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) plant_dens = nplant/cpatch%area call set_root_fraction(csite%rootfrac_scr, pft, csite%zi_soil, & - bc_in%max_rooting_depth_index_col) + csite%bc_in_ptr%max_rooting_depth_index_col) do el=1,num_elements diff --git a/biogeochem/EDLoggingMortalityMod.F90 b/biogeochem/EDLoggingMortalityMod.F90 index b8295bbf55..7eba00af32 100644 --- a/biogeochem/EDLoggingMortalityMod.F90 +++ b/biogeochem/EDLoggingMortalityMod.F90 @@ -394,7 +394,7 @@ end subroutine get_harvest_rate_area ! ============================================================================ - subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site_areadis, bc_in) + subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site_areadis) ! ------------------------------------------------------------------------------------------- ! @@ -440,7 +440,7 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site type(ed_patch_type) , intent(inout), target :: currentPatch type(ed_patch_type) , intent(inout), target :: newPatch real(r8) , intent(in) :: patch_site_areadis - type(bc_in_type) , intent(in) :: bc_in + !LOCAL VARIABLES: type(ed_cohort_type), pointer :: currentCohort @@ -569,7 +569,8 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site ! ---------------------------------------------------------------------------------------- call set_root_fraction(currentSite%rootfrac_scr, pft, & - currentSite%zi_soil, bc_in%max_rooting_depth_index_col) + currentSite%zi_soil, & + currentSite%bc_in_ptr%max_rooting_depth_index_col) ag_wood = (direct_dead+indirect_dead) * (struct_m + sapw_m ) * & prt_params%allom_agb_frac(currentCohort%pft) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index d31c4ec7a8..c3c1595853 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -660,13 +660,13 @@ subroutine spawn_patches( currentSite, bc_in) if(currentPatch%disturbance_mode .eq. dtype_ilog) then call logging_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis,bc_in) + new_patch, patch_site_areadis) elseif(currentPatch%disturbance_mode .eq. dtype_ifire) then call fire_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis,bc_in) + new_patch, patch_site_areadis) else call mortality_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis,bc_in) + new_patch, patch_site_areadis) endif ! -------------------------------------------------------------------------- @@ -1514,7 +1514,7 @@ end subroutine TransLitterNewPatch ! ============================================================================ subroutine fire_litter_fluxes(currentSite, currentPatch, & - newPatch, patch_site_areadis, bc_in) + newPatch, patch_site_areadis) ! ! !DESCRIPTION: ! CWD pool burned by a fire. @@ -1533,8 +1533,6 @@ subroutine fire_litter_fluxes(currentSite, currentPatch, & type(ed_patch_type) , intent(inout), target :: currentPatch ! Donor Patch type(ed_patch_type) , intent(inout), target :: newPatch ! New Patch real(r8) , intent(in) :: patch_site_areadis ! Area being donated - ! by current patch - type(bc_in_type) , intent(in) :: bc_in ! ! !LOCAL VARIABLES: @@ -1664,7 +1662,7 @@ subroutine fire_litter_fluxes(currentSite, currentPatch, & site_mass%burn_flux_to_atm = site_mass%burn_flux_to_atm + burned_mass call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil, & - bc_in%max_rooting_depth_index_col) + currentSite%bc_in_ptr%max_rooting_depth_index_col) ! Contribution of dead trees to root litter (no root burn flux to atm) do dcmpy=1,ndcmpy @@ -1737,7 +1735,7 @@ end subroutine fire_litter_fluxes ! ============================================================================ subroutine mortality_litter_fluxes(currentSite, currentPatch, & - newPatch, patch_site_areadis, bc_in) + newPatch, patch_site_areadis) ! ! !DESCRIPTION: ! Carbon going from mortality associated with disturbance into CWD pools. @@ -1759,8 +1757,6 @@ subroutine mortality_litter_fluxes(currentSite, currentPatch, & type(ed_patch_type) , intent(inout), target :: currentPatch type(ed_patch_type) , intent(inout), target :: newPatch real(r8) , intent(in) :: patch_site_areadis - - type(bc_in_type) , intent(in) :: bc_in ! ! !LOCAL VARIABLES: type(ed_cohort_type), pointer :: currentCohort @@ -1876,7 +1872,7 @@ subroutine mortality_litter_fluxes(currentSite, currentPatch, & bg_wood = num_dead * (struct_m + sapw_m) * (1.0_r8-prt_params%allom_agb_frac(pft)) call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil, & - bc_in%max_rooting_depth_index_col) + currentSite%bc_in_ptr%max_rooting_depth_index_col) do c=1,ncwd diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 26248478dc..0f1faf253e 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1953,7 +1953,8 @@ subroutine CWDInput( currentSite, currentPatch, litt) do while(associated(currentCohort)) pft = currentCohort%pft - call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil) + call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil, & + currentSite%bc_in_ptr%max_rooting_depth_index_col) leaf_m_turnover = currentCohort%prt%GetTurnover(leaf_organ,element_id) store_m_turnover = currentCohort%prt%GetTurnover(store_organ,element_id) diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index e7faac9cc3..6826a0dd95 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -139,7 +139,8 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) do ft = 1,numpft - call set_root_fraction(sites(s)%rootfrac_scr, ft, sites(s)%zi_soil ) + call set_root_fraction(sites(s)%rootfrac_scr, ft, sites(s)%zi_soil, & + sites(s)%bc_in_ptr%max_rooting_depth_index_col ) cpatch%btran_ft(ft) = 0.0_r8 do j = 1,bc_in(s)%nlevsoil diff --git a/biogeophys/FatesBstressMod.F90 b/biogeophys/FatesBstressMod.F90 index 46f30f434b..4c991bd97c 100644 --- a/biogeophys/FatesBstressMod.F90 +++ b/biogeophys/FatesBstressMod.F90 @@ -63,12 +63,12 @@ subroutine btran_sal_stress_fates( nsites, sites, bc_in) cpatch => sites(s)%oldest_patch do while (associated(cpatch)) - ! THIS SHOULD REALLY BE A COHORT LOOP ONCE WE HAVE rootfr_ft FOR COHORTS (RGK) - do ft = 1,numpft cpatch%bstress_sal_ft(ft) = 0.0_r8 - call set_root_fraction(sites(s)%rootfrac_scr, ft, sites(s)%zi_soil ) + call set_root_fraction(sites(s)%rootfrac_scr, ft, & + sites(s)%zi_soil, & + sites(s)%bc_in_ptr%max_rooting_depth_index_col ) do j = 1,bc_in(s)%nlevsoil diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 359ad16515..b7edf60d32 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -65,7 +65,6 @@ module FatesPlantHydraulicsMod use FatesAllometryMod, only : bleaf use FatesAllometryMod, only : bsap_allom use FatesAllometryMod, only : CrownDepth - use FatesAllometryMod , only : set_root_fraction use FatesHydraulicsMemMod, only: use_2d_hydrosolve use FatesHydraulicsMemMod, only: ed_site_hydr_type use FatesHydraulicsMemMod, only: ed_cohort_hydr_type diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 41596c4f5e..112a03baf5 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -272,7 +272,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) do ft = 1,numpft call set_root_fraction(rootfr_ft(ft,:), ft, & - bc_in(s)%zi_sisl) + bc_in(s)%zi_sisl, & + bc_in(s)%max_rooting_depth_index_col) end do diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index f0d44b40a3..aa5ce68f34 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -36,7 +36,7 @@ module EDInitMod use EDTypesMod , only : phen_dstat_moistoff use EDTypesMod , only : phen_cstat_notcold use EDTypesMod , only : phen_dstat_moiston - use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : bc_in_type,bc_out_type use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_use_inventory_init use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog @@ -93,14 +93,15 @@ module EDInitMod ! ============================================================================ - subroutine init_site_vars( site_in, bc_in ) + subroutine init_site_vars( site_in, bc_in, bc_out ) ! ! !DESCRIPTION: ! ! ! !ARGUMENTS - type(ed_site_type), intent(inout) :: site_in - type(bc_in_type),intent(in) :: bc_in + type(ed_site_type), intent(inout) :: site_in + type(bc_in_type),intent(in),target :: bc_in + type(bc_out_type),intent(in),target :: bc_out ! ! !LOCAL VARIABLES: !---------------------------------------------------------------------- @@ -139,13 +140,14 @@ subroutine init_site_vars( site_in, bc_in ) ! Initialize the static soil ! arrays from the boundary (initial) condition - - + site_in%zi_soil(:) = bc_in%zi_sisl(:) site_in%dz_soil(:) = bc_in%dz_sisl(:) site_in%z_soil(:) = bc_in%z_sisl(:) - + site_in%bc_in_ptr => bc_in + site_in%bc_out_ptr => bc_out + ! end subroutine init_site_vars diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 4954601969..3605e5cb50 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -18,6 +18,8 @@ module EDTypesMod use FatesLitterMod, only : ncwd use FatesConstantsMod, only : n_anthro_disturbance_categories use FatesConstantsMod, only : days_per_year + use FatesInterfaceTypesMod,only : bc_in_type + use FatesInterfaceTypesMod,only : bc_out_type implicit none private ! By default everything is private @@ -682,6 +684,15 @@ module EDTypesMod ! position in history output fields !integer :: clump_id + ! This is the pointer to the input boundary condition structure, ie information that is + ! derived purerly from the HLM + type(bc_in_type), pointer :: bc_in_ptr + + ! This is the pointer to the output boundary condition structure, ie information that is + ! derived purerly from the HLM + type(bc_out_type), pointer :: bc_out_ptr + + ! Global index of this site in the history output file integer :: h_gid diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 42fa7798b5..ad9999f343 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -43,6 +43,7 @@ module FatesInterfaceMod use CLMFatesParamInterfaceMod , only : FatesReadParameters use EDTypesMod , only : p_uptake_mode use EDTypesMod , only : n_uptake_mode + use EDTypesMod , only : ed_site_type use FatesConstantsMod , only : prescribed_p_uptake use FatesConstantsMod , only : prescribed_n_uptake use FatesConstantsMod , only : coupled_p_uptake @@ -76,11 +77,48 @@ module FatesInterfaceMod ! its sister code use FatesInterfaceTypesMod - implicit none private + 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(:) + + + ! These are parameter constants that FATES may need to provide a host model + ! We have other methods of reading in input parameters. Since these + ! are parameter constants, we don't need them allocated over every site,one + ! instance is fine. + + type(bc_pconst_type) :: bc_pconst + + + end type fates_interface_type + + + character(len=*), parameter :: sourcefile = & __FILE__ diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index f9c8152888..92319469be 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -7,7 +7,6 @@ module FatesInterfaceTypesMod 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 @@ -711,43 +710,7 @@ module FatesInterfaceTypesMod ! increasing, or all 1s) end type bc_pconst_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(:) - - - ! These are parameter constants that FATES may need to provide a host model - ! We have other methods of reading in input parameters. Since these - ! are parameter constants, we don't need them allocated over every site,one - ! instance is fine. - - type(bc_pconst_type) :: bc_pconst - - - end type fates_interface_type + contains diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 0d8e07f67f..1beed327a0 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -2115,7 +2115,7 @@ end subroutine set_restart_vectors ! ==================================================================================== - subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) + subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in, bc_out) ! ---------------------------------------------------------------------------------- ! This subroutine takes a peak at the restart file to determine how to allocate @@ -2145,7 +2145,8 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) integer , intent(in) :: nc integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) - type(bc_in_type) , intent(in) :: bc_in(nsites) + type(bc_in_type) :: bc_in(nsites) + type(bc_out_type) :: bc_out(nsites) ! local variables @@ -2177,7 +2178,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) - call init_site_vars( sites(s), bc_in(s) ) + call init_site_vars( sites(s), bc_in(s), bc_out(s) ) call zero_site( sites(s) ) if ( rio_npatch_si(io_idx_si)<0 .or. rio_npatch_si(io_idx_si) > 10000 ) then From 453876d45ba61aa87c5857ff72b0891dbb5a5671 Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Sat, 10 Apr 2021 15:27:20 -0700 Subject: [PATCH 259/578] Update FatesPlantRespPhotosynthMod.F90 --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 28 +++++++++------------- 1 file changed, 11 insertions(+), 17 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 5830b4e0a1..2db53563e4 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -957,8 +957,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in real(r8) :: gstoma_out ! Adjusted stoma conductance that incorporates the leaf water status real(r8) :: qs ! specific humidity at leaf surface real(r8) :: qsat ! saturated specific humidity - real(r8) :: qsat_adj ! specific humidity adjusted by leaf water potential (g/kg) - real(r8) :: veg_esat_adj ! vapor pressure adjusted by leaf water potential () + real(r8) :: qsat_adj ! specific humidity adjusted by leaf water potential (g/kg) real(r8) :: LWP_star ! leaf water potential scaling coefficient for inner leaf humidity real(r8) :: k_lwp = 8.0_r8 ! an sclaing coefficient for the ratio of leaf xylem water potential to mesophyll water potential real(r8) :: th_sat ! saturated water content of leaf m3/m3 @@ -1293,29 +1292,24 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! th_sat = EDPftvarcon_inst%hydr_thetas_node(ft,1) ! th_rs = EDPftvarcon_inst%hydr_resid_node(ft,1) + ! Note: to disable this control, set k_lwp to zero, LWP_star will be 1, see code (line 1308) below k_lwp = EDPftvarcon_inst%hydr_k_lwp(ft) if (psi<0) then LWP_star = exp(((k_lwp) * psi)*18.0_r8/(8.314_r8*veg_tempk)) - ! k_lwp**btran else LWP_star = 1 end if - ! now adjust veg_esat by LWP_star - veg_esat_adj = veg_esat*LWP_star - + ! now adjust inner leaf humidity by LWP_star ! note: q is the specific humidity qs = 0.622 * ceair / (can_press - 0.378 * ceair) qsat = 0.622 * veg_esat / (can_press - 0.378 * veg_esat) - ! qsat_adj = 0.622 * veg_esat_adj / (can_press - 0.378 * veg_esat_adj) qsat_adj = qsat*LWP_star - ! write (fates_log(),*) 'qsat:', qsat, 'RHleaf:', qsat_adj/qsat, 'RHs:', qs/qsat if (k_lwp == 0 ) then rstoma_out = 1._r8/gstoma else if ((qsat_adj - qs) <= 0) then - ! write (fates_log(),*) 'LWP_star:', LWP_star - ! write (fates_log(),*) 'qleaf:', qsat * LWP_star, 'qs',qs + ! if inner leaf vapor pressure is less then or equal to that at leaf surface ! then set stomata resistance to be very large to stop the transpiration or back flow of vapor rstoma_out = rsmax0*100 @@ -1324,13 +1318,13 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in end if if (rstoma_out <=0 ) then - ! write (fates_log(),*) 'code line 1244' - ! write (fates_log(),*) 'qsat:', qsat, 'qs:', qs - ! write (fates_log(),*) 'LWP :', psi, 'BTRAN:', th_rs, 'th:', th - ! write (fates_log(),*) 'ceair:', ceair, 'veg_esat:', veg_esat - ! write (fates_log(),*) 'rstoma_out:', rstoma_out, 'rb:', rb - ! write (fates_log(),*) 'LWP_star', LWP_star - ! call endrun(msg=errMsg(sourcefile, __LINE__)) + + write (fates_log(),*) 'qsat:', qsat, 'qs:', qs + write (fates_log(),*) 'LWP :', psi, 'BTRAN:', th_rs, 'th:', th + write (fates_log(),*) 'ceair:', ceair, 'veg_esat:', veg_esat + write (fates_log(),*) 'rstoma_out:', rstoma_out, 'rb:', rb + write (fates_log(),*) 'LWP_star', LWP_star + call endrun(msg=errMsg(sourcefile, __LINE__)) end if end if ! k_lwp == 0 else From 0fc7a17b5e413efe081cd228de88de42fccd9793 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 12 Apr 2021 11:23:02 -0600 Subject: [PATCH 260/578] allocating sp_mode related variables to start at zero --- main/FatesInterfaceMod.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index e7c4bf1cc8..e90a694770 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -476,13 +476,13 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) allocate(bc_in%hlm_harvest_catnames(0)) end if - allocate(bc_in%pft_areafrac(maxpft)) + allocate(bc_in%pft_areafrac(0:maxpft)) ! Variables for SP mode. if(hlm_use_sp.eq.itrue) then - allocate(bc_in%hlm_sp_tlai(maxpft)) - allocate(bc_in%hlm_sp_tsai(maxpft)) - allocate(bc_in%hlm_sp_htop(maxpft)) + allocate(bc_in%hlm_sp_tlai(0:maxpft)) + allocate(bc_in%hlm_sp_tsai(0:maxpft)) + allocate(bc_in%hlm_sp_htop(0:maxpft)) end if return end subroutine allocate_bcin From fa4a6412a0c40296f51997dbd5b19eeb2895b8d6 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 13 Apr 2021 11:06:43 -0400 Subject: [PATCH 261/578] Updated comment describing hydro limitations --- biogeophys/FatesPlantHydraulicsMod.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index d9e67be564..2444ad881f 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -1682,9 +1682,11 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) endif end do - ! If the minimum number of plants is less than what was dictated by the - ! carbon-nitrogen-phosphorus availability, then we appy a reduction. - ! We also have to add back in what had been taken, to the germination seed pool + ! If the minimum number of plants that are recruitable due to water + ! limitations, is less than what is currently recruitable (due to + ! carbon-nitrogen-phosphorus availability), then we apply a reduction. + ! We also have to add back in what had been taken, to the germination + ! seed pool if(nmin < ccohort%n) then do el = 1,num_elements From fe94d1b38603666f2f341a2fe9479d2b8cc648f7 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 13 Apr 2021 15:45:21 -0600 Subject: [PATCH 262/578] Added errh2o to hydro restarts --- main/FatesRestartInterfaceMod.F90 | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index bd7f9921b2..b3e321f67e 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -209,6 +209,7 @@ module FatesRestartInterfaceMod integer :: ir_hydro_dead_si integer :: ir_hydro_growturn_err_si integer :: ir_hydro_hydro_err_si + integer :: ir_hydro_errh2o ! The number of variable dim/kind types we have defined (static) integer, parameter, public :: fates_restart_num_dimensions = 2 !(cohort,column) @@ -1060,6 +1061,12 @@ subroutine define_restart_vars(this, initialize_variables) long_name='Site level error for hydrodynamics', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_hydro_err_si ) + + call this%set_restart_var(vname='fates_errh2o', vtype=cohort_r8, & + long_name='ed cohort - running plant h2o error for hydro', & + units='kg/indiv', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_errh2o ) + end if @@ -1802,6 +1809,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) this%rvars(ir_hydro_th_troot)%r81d(io_idx_co) = ccohort%co_hydr%th_troot + this%rvars(ir_hydro_errh2o)%r81d(io_idx_co) = ccohort%co_hydr%errh2o + end if rio_canopy_layer_co(io_idx_co) = ccohort%canopy_layer @@ -2618,7 +2627,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ir_hydro_th_aroot_covec,io_idx_co) ccohort%co_hydr%th_troot = this%rvars(ir_hydro_th_troot)%r81d(io_idx_co) - + ccohort%co_hydr%errh2o = this%rvars(ir_hydro_errh2o)%r81d(io_idx_co) + call UpdatePlantPsiFTCFromTheta(ccohort,sites(s)%si_hydr) end if From 6065b9a210b35e13e5104f79b5487015ae3a9c50 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 16 Apr 2021 09:25:51 -0700 Subject: [PATCH 263/578] manually reinstating ai_min after test failure in ctsm pr 1324 --- biogeochem/EDCanopyStructureMod.F90 | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 16911e163a..28db5a7b67 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -2040,11 +2040,15 @@ function calc_areaindex(cpatch,ai_type) result(ai) integer :: cl,ft real(r8) :: ai + ! TODO: THIS MIN LAI IS AN ARTIFACT FROM TESTING LONG-AGO AND SHOULD BE REMOVED + ! THIS HAS BEEN KEPT THUS FAR TO MAINTAIN B4B IN TESTING OTHER COMMITS + real(r8),parameter :: ai_min = 0.1_r8 + real(r8),pointer :: ai_profile ai = 0._r8 if (trim(ai_type) == 'elai') then - do cl = 1,cpatch%NCL_p + do cl = 1,cpatch%NCL_p do ft = 1,numpft ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft))) @@ -2076,6 +2080,8 @@ function calc_areaindex(cpatch,ai_type) result(ai) write(fates_log(),*) 'Unsupported area index sent to calc_areaindex' call endrun(msg=errMsg(sourcefile, __LINE__)) end if + + ai = max(ai_min,ai) return From 588ac1291c6aa746f7960a35fe2c2e9b8daeec31 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 21 Apr 2021 16:10:32 -0600 Subject: [PATCH 264/578] removing the nocomp_pft_label check as the was resulting in invalid zero indexing --- biogeochem/EDCanopyStructureMod.F90 | 4 ++-- main/EDInitMod.F90 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index d4527c3e97..eefb94291b 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1922,10 +1922,10 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentPatch => sites(s)%oldest_patch c = fcolumn(s) do while(associated(currentPatch)) - if(currentPatch%nocomp_pft_label.ne.0)then + !if(currentPatch%nocomp_pft_label.ne.0)then ! only increase ifp for veg patches, not bareground (in SP mode) ifp = ifp+1 - endif ! stay with ifp=0 for bareground patch. + !endif ! stay with ifp=0 for bareground patch. if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area currentPatch%total_canopy_area = currentPatch%area diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 007d6dd68b..05a17d7a9c 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -133,7 +133,7 @@ subroutine init_site_vars( site_in, bc_in ) allocate(site_in%dz_soil(site_in%nlevsoil)) allocate(site_in%z_soil(site_in%nlevsoil)) - allocate(site_in%area_pft(1:numpft)) + allocate(site_in%area_pft(0:numpft)) ! Changing to zero indexing allocate(site_in%use_this_pft(1:numpft)) ! SP mode @@ -486,7 +486,7 @@ subroutine init_patches( nsites, sites, bc_in) if(hlm_use_nocomp.eq.itrue)then num_new_patches = numpft if(hlm_use_sp.eq.itrue)then - num_new_patches = numpft + 1 ! bare ground patch in SP mode. + !num_new_patches = numpft + 1 ! bare ground patch in SP mode. start_patch = 0 ! start at the bare ground patch endif ! allocate(newppft(numpft)) From 11d71eb9fb16acf08a4f854dbb5c73bd35adaffe Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 23 Apr 2021 10:32:45 -0400 Subject: [PATCH 265/578] debugging issues with nutrient coupling --- biogeochem/FatesSoilBGCFluxMod.F90 | 26 ++++++++++++++++++-------- main/EDMainMod.F90 | 2 ++ main/EDTypesMod.F90 | 4 ++-- parteh/PRTAllometricCNPMod.F90 | 18 +----------------- 4 files changed, 23 insertions(+), 27 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index ae0e76cce2..95c5c8dcaa 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -317,10 +317,13 @@ subroutine UnPackNutrientAquisitionBCs(sites, bc_in) do while (associated(ccohort)) icomp = icomp+1 ! N Uptake: Convert g/m2/day -> kg/plant/day - ccohort%daily_nh4_uptake = ccohort%daily_nh4_uptake + & - sum(bc_in(s)%plant_nh4_uptake_flux(icomp,:))*kg_per_g*AREA/ccohort%n - ccohort%daily_no3_uptake = ccohort%daily_no3_uptake + & - sum(bc_in(s)%plant_no3_uptake_flux(icomp,:))*kg_per_g*AREA/ccohort%n + print*,"NEED:",ccohort%daily_n_need,ccohort%dbh + !print*,"uptake: ",sum(bc_in(s)%plant_nh4_uptake_flux(icomp,:))*kg_per_g*AREA/ccohort%n + & + ! sum(bc_in(s)%plant_no3_uptake_flux(icomp,:))*kg_per_g*AREA/ccohort%n + + + ccohort%daily_nh4_uptake = sum(bc_in(s)%plant_nh4_uptake_flux(icomp,:))*kg_per_g*AREA/ccohort%n + ccohort%daily_no3_uptake = sum(bc_in(s)%plant_no3_uptake_flux(icomp,:))*kg_per_g*AREA/ccohort%n ccohort => ccohort%shorter end do cpatch => cpatch%younger @@ -454,6 +457,7 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) ((n_uptake_mode.eq.coupled_n_uptake) .or. & (p_uptake_mode.eq.coupled_p_uptake))) then comp_scaling = fates_np_comp_scaling + else comp_scaling = trivial_np_comp_scaling @@ -485,7 +489,7 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) icomp = 0 comp_per_pft(:) = 0 ! This counts how many competitors per ! pft, used for averaging - + cpatch => csite%oldest_patch do while (associated(cpatch)) @@ -545,7 +549,7 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) bc_out%decompmicc(id) = bc_out%decompmicc(id) / & max(nearzero,sum(bc_out%veg_rootc(:,id),dim=1)) end do - + if(comp_scaling.eq.cohort_np_comp_scaling) then bc_out%num_plant_comps = icomp elseif(comp_scaling.eq.pft_np_comp_scaling) then @@ -557,6 +561,7 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) return end if + coupled_n_if: if(n_uptake_mode.eq.coupled_n_uptake) then icomp = 0 cpatch => csite%oldest_patch @@ -595,7 +600,6 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) end if coupled_n_if - coupled_p_if: if(p_uptake_mode.eq.coupled_p_uptake) then icomp = 0 @@ -1055,8 +1059,12 @@ function ECACScalar(ccohort, element_id) result(c_scalar) ! as the plant's nutrien storage hits a low threshold ! and goes to 0, no demand, as the plant's nutrient ! storage approaches it's maximum holding capacity + + c_scalar = max(0._r8,min(1._r8,logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))))) + + print*,"store_frac: ",store_frac,c_scalar call check_var_real(c_scalar,'c_scalar',icode) if (icode .ne. 0) then @@ -1064,7 +1072,7 @@ function ECACScalar(ccohort, element_id) result(c_scalar) write(fates_log(),*) 'ending' call endrun(msg=errMsg(sourcefile, __LINE__)) endif - + else store_c = ccohort%prt%GetState(store_organ, carbon12_element) @@ -1078,6 +1086,8 @@ function ECACScalar(ccohort, element_id) result(c_scalar) store_frac = store_frac / (store_c/store_c_max) c_scalar = max(0._r8,min(1._r8,logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))))) + + end if diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 8b8eb4aa24..b25b058bf0 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -430,6 +430,8 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) call currentCohort%prt%DailyPRT() + + print*,"N NEED2: ",currentCohort%daily_n_need,currentCohort%dbh ! Update the mass balance tracking for the daily nutrient uptake flux ! Then zero out the daily uptakes, they have been used diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 3605e5cb50..782991b680 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -28,9 +28,9 @@ module EDTypesMod integer, parameter, public :: maxPatchesPerSite = 14 ! maximum number of patches to live on a site integer, parameter, public :: maxPatchesPerSite_by_disttype(n_anthro_disturbance_categories) = & (/ 10, 4 /) !!! MUST SUM TO maxPatchesPerSite !!! - integer, public :: maxCohortsPerPatch = 100 ! maximum number of cohorts per patch + integer, public :: maxCohortsPerPatch = 150 ! maximum number of cohorts per patch - integer, parameter, public :: nclmax = 2 ! Maximum number of canopy layers + integer, parameter, public :: nclmax = 3 ! Maximum number of canopy layers integer, parameter, public :: ican_upper = 1 ! Nominal index for the upper canopy integer, parameter, public :: ican_ustory = 2 ! Nominal index for diagnostics that refer ! to understory layers (all layers that diff --git a/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 index b7db852a4e..5617d71e5d 100644 --- a/parteh/PRTAllometricCNPMod.F90 +++ b/parteh/PRTAllometricCNPMod.F90 @@ -188,7 +188,7 @@ module PRTAllometricCNPMod ! phase, to give first dibs to leaves, even though they are ! in the same priority group as fineroots. - logical, parameter :: reproduce_conly = .true. + logical, parameter :: reproduce_conly = .false. ! Array of pointers are difficult in F90 @@ -374,11 +374,6 @@ subroutine DailyPRTAllometricCNP(this) real(r8) :: p_gain0 real(r8) :: maint_r_def0 - ! These are mass gains and fluxes used for the N&P non-limiting case - real(r8) :: c_gain_unl - real(r8) :: n_gain_unl,n_gain_unl0 - real(r8) :: p_gain_unl,p_gain_unl0 - ! Used for mass checking, total mass allocated based ! on change in the states, should match gain0's real(r8) :: allocated_c @@ -415,17 +410,6 @@ subroutine DailyPRTAllometricCNP(this) dbh => this%bc_inout(acnp_bc_inout_id_dbh)%rval; dbh0 = dbh - ! Initialize fields used for assessing N/P needs - ! (these run the allocation scheme with ample - ! N+P, to determine how much - ! availability was needed (in hindsight) drive - ! non-limited C allocaiton. - - c_gain_unl = c_gain - n_gain_unl = abs(10._r8*c_gain) - n_gain_unl0 = n_gain_unl - p_gain_unl = abs(10._r8*c_gain) - p_gain_unl0 = p_gain_unl ! If more than 1 leaf age bin is present, this ! call advances leaves in their age, but does From 5cc29024fe1bb20157529a48fed24ff27f242cdd Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Sat, 24 Apr 2021 12:22:55 -0700 Subject: [PATCH 266/578] Update FatesPlantHydraulicsMod.F90 Made changes according to Chonggang's comments --- biogeophys/FatesPlantHydraulicsMod.F90 | 23 +++++++++++------------ 1 file changed, 11 insertions(+), 12 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 37a34aa873..7d1ef5bf88 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -123,8 +123,7 @@ module FatesPlantHydraulicsMod ! use a control to prevent model from quiting when encounter the water balance error ! instead put it into an endless loop (JD) - integer, public :: debug_JD = 1 ! set to 0 to disable the - integer, public :: RP = 1 ! + integer, public :: debug_JD = 0 ! set to 0 to disable it, not used currently ! The following options are temporarily unavailable (RGK 09-06-19) ! ---------------------------------------------------------------------------------- @@ -197,8 +196,8 @@ module FatesPlantHydraulicsMod integer, public, parameter :: campbell_type = 2 integer, public, parameter :: tfs_type = 3 - integer, parameter :: plant_wrf_type = van_genuchten_type - integer, parameter :: plant_wkf_type = van_genuchten_type + integer, parameter :: plant_wrf_type = tfs_type + integer, parameter :: plant_wkf_type = tfs_type integer, parameter :: soil_wrf_type = campbell_type integer, parameter :: soil_wkf_type = campbell_type @@ -3247,15 +3246,15 @@ subroutine ImTaylorSolve1D(slat, slon, recruitflag,site_hydr,cohort,cohort_hydr, 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,slat,slon,recruitflag) - if (debug_JD>0) then - write(fates_log(),*) 'WARNING, WARNING, WARNING! Hydro encounter water balance error, and will be put into an eneless loop.' - write(fates_log(),*) 'To disable this and end the run, change debug_JD to -1 on line 125' - do while ( debug_JD > 0) - debug_JD = 1 - end do - else + ! if (debug_JD>0) then + ! write(fates_log(),*) 'WARNING, WARNING, WARNING! Hydro encounter water balance error, and will be put into an eneless loop.' + ! write(fates_log(),*) 'To disable this and end the run, change debug_JD to -1 on line 125' + ! do while ( debug_JD > 0) + ! debug_JD = 1 + ! end do + ! else call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + ! end if end if ! If debugging, then lets re-initialize our diagnostics of From b53d685eba25e366e46c57e7574dac2969f10e25 Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Sat, 24 Apr 2021 13:03:40 -0700 Subject: [PATCH 267/578] Update FatesHydroWTFMod.F90 Make linear interperation as an option for VG water retention function --- biogeophys/FatesHydroWTFMod.F90 | 48 ++++++++++++++++++++------------- 1 file changed, 29 insertions(+), 19 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index e1844faa8c..ad3456658c 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -43,7 +43,8 @@ module FatesHydroWTFMod real(r8), parameter :: quad_a2 = 0.99_r8 ! Smoothing factor or "A" term in ! elastic-caviation region - + logical :: use_linear_interp = .false. ! parameter used to control whether to use + ! linear interprotation in vg water retention function ! Generic class that can be extended to describe ! specific water retention functions @@ -436,12 +437,15 @@ function th_from_psi_vg(this,psi) result(th) m = this%m_vg n = this%n_vg - ! pressure above which we use a linear function, - ! psi_interp = -(1._r8/this%alpha)*(max_sf_interp**(1._r8/(-m)) - 1._r8 )**(1/n) - - ! Junyan modified to get rid of the linear interperation - psi_interp = 0 - + if (use_linear_interp) then + pressure above which we use a linear function, + psi_interp = -(1._r8/this%alpha)*(max_sf_interp**(1._r8/(-m)) - 1._r8 )**(1/n) + else + ! Junyan modified to get rid of the linear interperation + psi_interp = 0 + end if + + if(psi1) then !(satfrac>=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/n) - ! psi = psi_interp + dpsidth_interp*(th-th_interp) - psi = 0 + if (satfrac>1) then + if (use_linear_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/n) + psi = psi_interp + dpsidth_interp*(th-th_interp) + else + psi = 0 + end if !write(fates_log(),*) 'cap psi, th: ', th, 'th_sat: ',this%th_sat else From 733532c8f454dbf24bb058b440828299d0639c72 Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Sat, 24 Apr 2021 13:52:59 -0700 Subject: [PATCH 268/578] Update FatesPlantRespPhotosynthMod.F90 remove the agross-anet option from this pull request, and put in a separate PR. --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 21 +-------------------- 1 file changed, 1 insertion(+), 20 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 2db53563e4..fd3b33067a 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -965,9 +965,6 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in real(r8) :: rb ! leaf boundary layer ressistance ! Parameters ! ------------------------------------------------------------------------ - ! selection to use agross or anet in stomatal models, 1 - use agross, other values - use anet - integer,parameter :: use_agross = 1 - ! Fraction of light absorbed by non-photosynthetic pigments real(r8),parameter :: fnps = 0.15_r8 @@ -1182,14 +1179,8 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in gs_mol = max(r1,r2) end if ! Derive new estimate for co2_inter_c - if (use_agross == 1) then - co2_inter_c = can_co2_ppress - agross * can_press * & - (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - else co2_inter_c = can_co2_ppress - anet * can_press * & (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - end if - ! end of Junyan's change for gs calculation ! Check for co2_inter_c convergence. Delta co2_inter_c/pair = mol/mol. @@ -1206,15 +1197,6 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! End of co2_inter_c iteration. Check for an < 0, in which case gs_mol = bbb ! And Final estimates for leaf_co2_ppress and co2_inter_c ! (needed for early exit of co2_inter_c iteration when an < 0) - if (use_agross == 1) then - if (agross < 0._r8) then - gs_mol = stomatal_intercept_btran - end if - leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * agross * can_press - leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) - co2_inter_c = can_co2_ppress - agross * can_press * & - (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - else if (anet < 0._r8) then gs_mol = stomatal_intercept_btran end if @@ -1222,8 +1204,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) co2_inter_c = can_co2_ppress - anet * can_press * & (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - end if - + ! Convert gs_mol (umol /m**2/s) to gs (m/s) and then to rs (s/m) gs = gs_mol / cf From b9675ed171dcac575ee9faa6bfbff037ba510cd4 Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Sat, 24 Apr 2021 14:07:12 -0700 Subject: [PATCH 269/578] Update FatesPlantRespPhotosynthMod.F90 --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index fd3b33067a..ecadc96c6d 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -216,7 +216,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! above the leaf layer of interest real(r8) :: lai_current ! the LAI in the current leaf layer real(r8) :: cumulative_lai ! the cumulative LAI, top down, to the leaf layer of interest - real(r8) :: psi_leaf ! xylem water potential of leaf + real(r8) :: psi_leaf ! water potential of leaf real(r8), allocatable :: rootfr_ft(:,:) ! Root fractions per depth and PFT ! ----------------------------------------------------------------------------------- @@ -953,13 +953,13 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in real(r8), dimension(0:1) :: bbbopt ! Cuticular conductance at full water potential (umol H2O /m2/s) - real(r8) :: psi ! Xylem Water potential of leaf + real(r8) :: psi ! Water potential of leaf real(r8) :: gstoma_out ! Adjusted stoma conductance that incorporates the leaf water status real(r8) :: qs ! specific humidity at leaf surface real(r8) :: qsat ! saturated specific humidity real(r8) :: qsat_adj ! specific humidity adjusted by leaf water potential (g/kg) - real(r8) :: LWP_star ! leaf water potential scaling coefficient for inner leaf humidity - real(r8) :: k_lwp = 8.0_r8 ! an sclaing coefficient for the ratio of leaf xylem water potential to mesophyll water potential + real(r8) :: LWP_star ! leaf water potential scaling coefficient for inner leaf humidity, 0 means total dehydroted leaf, 1 means total saturated leaf + integer :: k_lwp ! an sclaing coefficient for the ratio of leaf xylem water potential to mesophyll water potential real(r8) :: th_sat ! saturated water content of leaf m3/m3 real(r8) :: th_rs ! residual waater content of leaf m3/m3 real(r8) :: rb ! leaf boundary layer ressistance From 3e675e998cd4a12b2c43206d0dad531d2719366b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 30 Apr 2021 09:59:17 -0400 Subject: [PATCH 270/578] Cleaning of debugging during cnp coupling developments --- biogeochem/EDPatchDynamicsMod.F90 | 11 +++++++++++ biogeochem/FatesSoilBGCFluxMod.F90 | 31 +++++++++++++++--------------- main/FatesHistoryInterfaceMod.F90 | 10 +++++++--- 3 files changed, 33 insertions(+), 19 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index c3c1595853..dcd2e5d03b 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1386,6 +1386,17 @@ subroutine TransLitterNewPatch(currentSite, & enddo + do pft = 1,numpft + + new_litt%seed_decay(pft) = new_litt%seed_decay(pft) + & + curr_litt%seed_decay(pft)*patch_site_areadis/newPatch%area + + new_litt%seed_germ_decay(pft) = new_litt%seed_germ_decay(pft) + & + curr_litt%seed_germ_decay(pft)*patch_site_areadis/newPatch%area + + end do + + ! ----------------------------------------------------------------------------- ! Distribute the existing litter that was already in place on the donor ! patch. Some of this burns and is sent to the atmosphere, and some goes to the diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 95c5c8dcaa..02e684c910 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -193,7 +193,6 @@ subroutine UnPackNutrientAquisitionBCs(sites, bc_in) real(r8) :: fnrt_c ! fine-root carbon [kg] real(r8) :: fnrt_c_pft(numpft) ! total mass of root for each PFT [kgC] - nsites = size(sites,dim=1) @@ -316,14 +315,12 @@ subroutine UnPackNutrientAquisitionBCs(sites, bc_in) ccohort => cpatch%tallest do while (associated(ccohort)) icomp = icomp+1 - ! N Uptake: Convert g/m2/day -> kg/plant/day - print*,"NEED:",ccohort%daily_n_need,ccohort%dbh - !print*,"uptake: ",sum(bc_in(s)%plant_nh4_uptake_flux(icomp,:))*kg_per_g*AREA/ccohort%n + & - ! sum(bc_in(s)%plant_no3_uptake_flux(icomp,:))*kg_per_g*AREA/ccohort%n + ! N Uptake: Convert g/m2/day -> kg/plant/day ccohort%daily_nh4_uptake = sum(bc_in(s)%plant_nh4_uptake_flux(icomp,:))*kg_per_g*AREA/ccohort%n ccohort%daily_no3_uptake = sum(bc_in(s)%plant_no3_uptake_flux(icomp,:))*kg_per_g*AREA/ccohort%n + ccohort => ccohort%shorter end do cpatch => cpatch%younger @@ -452,6 +449,8 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) real(r8), parameter :: decompmicc_lambda = 2.5_r8 ! Depth attenuation exponent for decomposer biomass real(r8), parameter :: decompmicc_zmax = 7.0e-2_r8 ! Depth of maximum decomposer biomass + + ! Determine the scaling approach if((hlm_parteh_mode.eq.prt_cnp_flex_allom_hyp) .and. & ((n_uptake_mode.eq.coupled_n_uptake) .or. & @@ -474,7 +473,7 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) end if end if - + ! ECA Specific Parameters ! -------------------------------------------------------------------------------- if(trim(hlm_nu_com).eq.'ECA')then @@ -536,7 +535,6 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) bc_out%decompmicc(id) = bc_out%decompmicc(id) + decompmicc_layer * veg_rootc end do - ccohort => ccohort%shorter end do @@ -561,7 +559,6 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) return end if - coupled_n_if: if(n_uptake_mode.eq.coupled_n_uptake) then icomp = 0 cpatch => csite%oldest_patch @@ -599,7 +596,7 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) bc_out%cn_scalar(:) = 0._r8 end if coupled_n_if - + coupled_p_if: if(p_uptake_mode.eq.coupled_p_uptake) then icomp = 0 @@ -1034,7 +1031,7 @@ function ECACScalar(ccohort, element_id) result(c_scalar) integer, parameter :: downreg_logi = 2 integer, parameter :: downreg_CN_logi = 3 - integer, parameter :: downreg_type = downreg_logi + integer, parameter :: downreg_type = downreg_linear real(r8), parameter :: logi_k = 25.0_r8 ! logistic function k @@ -1045,12 +1042,16 @@ function ECACScalar(ccohort, element_id) result(c_scalar) ! a linear function real(r8), parameter :: store_frac0 = 0.5_r8 + real(r8), parameter :: c_max = 1.0_r8 + real(r8), parameter :: c_min = 1.e-3_r8 + + store_max = ccohort%prt%GetNutrientTarget(element_id,store_organ,stoich_max) store_frac = min(2.0_r8,ccohort%prt%GetState(store_organ, element_id)/store_max) if(downreg_type == downreg_linear) then - - c_scalar = min(1.0_r8,max(0._r8,1.0 - (store_frac - store_frac0)/(1.0_r8-store_frac0))) + + c_scalar = min(c_max,max(c_min,1.0 - (store_frac - store_frac0)/(1.0_r8-store_frac0))) elseif(downreg_type == downreg_logi) then @@ -1062,10 +1063,8 @@ function ECACScalar(ccohort, element_id) result(c_scalar) - c_scalar = max(0._r8,min(1._r8,logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))))) + c_scalar = max(c_min,min(c_max,logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))))) - print*,"store_frac: ",store_frac,c_scalar - call check_var_real(c_scalar,'c_scalar',icode) if (icode .ne. 0) then write(fates_log(),*) 'c_scalar is invalid, element: ',element_id @@ -1085,7 +1084,7 @@ function ECACScalar(ccohort, element_id) result(c_scalar) store_frac = store_frac / (store_c/store_c_max) - c_scalar = max(0._r8,min(1._r8,logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))))) + c_scalar = max(c_min,min(c_max,logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))))) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 0de85610c2..a34fcdc095 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3156,12 +3156,16 @@ subroutine update_history_dyn(this,nc,nsites,sites) area_frac = cpatch%area * AREA_INV + + ! Sum up all output fluxes (fragmentation) hio_litter_out_elem(io_si,el) = hio_litter_out_elem(io_si,el) + & (sum(litt%leaf_fines_frag(:)) + & sum(litt%root_fines_frag(:,:)) + & sum(litt%ag_cwd_frag(:)) + & - sum(litt%bg_cwd_frag(:,:))) * cpatch%area + sum(litt%bg_cwd_frag(:,:)) + & + sum(litt%seed_decay(:)) + & + sum(litt%seed_germ_decay(:))) * cpatch%area hio_seed_bank_elem(io_si,el) = hio_seed_bank_elem(io_si,el) + & sum(litt%seed(:)) * cpatch%area @@ -3170,7 +3174,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) sum(litt%seed_germ(:)) * cpatch%area hio_seed_decay_elem(io_si,el) = hio_seed_decay_elem(io_si,el) + & - sum(litt%seed_decay(:)) * cpatch%area + sum(litt%seed_decay(:) + litt%seed_germ_decay(:) ) * cpatch%area hio_seeds_in_local_elem(io_si,el) = hio_seeds_in_local_elem(io_si,el) + & sum(litt%seed_in_local(:)) * cpatch%area @@ -4611,7 +4615,7 @@ subroutine define_history_vars(this, initialize_variables) ivar=ivar, initialize=initialize_variables, index = ih_seed_germ_elem ) call this%set_history_var(vname='SEED_DECAY_ELEM', units='kg ha-1 d-1', & - long='Seed mass decay', use_default='active', & + long='Seed mass decay (germinated and un-germinated)', use_default='active', & avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_seed_decay_elem ) From e3a783a9521a4fcb784fd550e02875d240614424 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 30 Apr 2021 10:00:30 -0400 Subject: [PATCH 271/578] Remove print statement --- main/EDMainMod.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index b25b058bf0..8b8eb4aa24 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -430,8 +430,6 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) call currentCohort%prt%DailyPRT() - - print*,"N NEED2: ",currentCohort%daily_n_need,currentCohort%dbh ! Update the mass balance tracking for the daily nutrient uptake flux ! Then zero out the daily uptakes, they have been used From 3bf95e156f07e982d262c2260e60ac406c2d1e86 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 3 May 2021 14:37:18 -0400 Subject: [PATCH 272/578] Added output boundary conditions for communication with CH4 model. Added storage deficit history variables for canopy/understory --- biogeochem/FatesSoilBGCFluxMod.F90 | 141 ++++++++++++++++++++++++++++- main/EDMainMod.F90 | 15 ++- main/FatesHistoryInterfaceMod.F90 | 87 +++++++++++++----- main/FatesInterfaceMod.F90 | 14 ++- main/FatesInterfaceTypesMod.F90 | 12 ++- 5 files changed, 231 insertions(+), 38 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 02e684c910..b4a9d02b18 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -66,6 +66,9 @@ module FatesSoilBGCFluxMod use FatesConstantsMod, only : pft_np_comp_scaling use FatesConstantsMod, only : trivial_np_comp_scaling use FatesConstantsMod, only : rsnbl_math_prec + use FatesConstantsMod, only : days_per_year + use FatesConstantsMod, only : sec_per_day + use FatesConstantsMod, only : years_per_day use FatesLitterMod, only : litter_type use FatesLitterMod , only : ncwd use FatesLitterMod , only : ndcmpy @@ -78,7 +81,8 @@ module FatesSoilBGCFluxMod implicit none private - + + public :: PrepCH4Bcs public :: PrepNutrientAquisitionBCs public :: UnPackNutrientAquisitionBCs public :: FluxIntoLitterPools @@ -411,6 +415,139 @@ end subroutine UnPackNutrientAquisitionBCs ! ===================================================================================== + subroutine PrepCH4BCs(csite) + + ! + ! This routine prepares the output boundary conditions for methane calculations + ! in ELM/CLM. + ! ----------------------------------------------------------------------------------- + + + ! !ARGUMENTS + type(ed_site_type), intent(inout) :: csite + + type(bc_out_type), pointer :: bc_out + type(bc_in_type), pointer :: bc_in + type(ed_patch_type), pointer :: cpatch ! current patch pointer + type(ed_cohort_type), pointer :: ccohort ! current cohort pointer + integer :: pft ! plant functional type + integer :: fp ! patch index of the site + real(r8) :: agnpp ! Above ground daily npp + real(r8) :: bgnpp ! Below ground daily npp + real(r8) :: fnrt_c ! Fine root carbon [kg/plant] + real(r8) :: sapw_net_alloc + real(r8) :: store_net_alloc + real(r8) :: fnrt_net_alloc + real(r8) :: leaf_net_alloc + real(r8) :: struct_net_alloc + real(r8) :: repro_net_alloc + + bc_out => csite%bc_out_ptr + bc_in => csite%bc_in_ptr + + ! Initialize to zero + bc_out%annavg_agnpp_pa(:) = 0._r8 + bc_out%annavg_bgnpp_pa(:) = 0._r8 + bc_out%annsum_npp_pa(:) = 0._r8 + bc_out%rootfr_pa(:,:) = 0._r8 + bc_out%frootc_pa(:) = 0._r8 + bc_out%root_resp(:) = 0._r8 + + fp = 0 + cpatch => csite%oldest_patch + do while (associated(cpatch)) + + ! Patch ordering when passing boundary conditions + ! always goes from oldest to youngest, following + ! the convention of EDPatchDynamics::set_patchno() + + fp = fp + 1 + + agnpp = 0._r8 + bgnpp = 0._r8 + + ccohort => cpatch%tallest + do while (associated(ccohort)) + + ! For consistency, only apply calculations to non-new + ! cohorts. New cohorts will not have respiration rates + ! at this point in the call sequence. + + if(.not.ccohort%isnew) then + + pft = ccohort%pft + + call set_root_fraction(csite%rootfrac_scr, pft, csite%zi_soil, & + bc_in%max_rooting_depth_index_col ) + + fnrt_c = ccohort%prt%GetState(fnrt_organ, carbon12_element) + + ! Fine root fraction over depth + + bc_out%rootfr_pa(fp,1:bc_in%nlevsoil) = & + bc_out%rootfr_pa(fp,1:bc_in%nlevsoil) + & + csite%rootfrac_scr(1:bc_in%nlevsoil) + + ! Fine root carbon, convert [kg/plant] -> [g/m2] + bc_out%frootc_pa(fp) = & + bc_out%frootc_pa(fp) + & + fnrt_c*ccohort%n/cpatch%area * g_per_kg + + ! [kgC/day] + sapw_net_alloc = ccohort%prt%GetNetAlloc(sapw_organ, carbon12_element) * days_per_sec + store_net_alloc = ccohort%prt%GetNetAlloc(store_organ, carbon12_element) * days_per_sec + leaf_net_alloc = ccohort%prt%GetNetAlloc(leaf_organ, carbon12_element) * days_per_sec + fnrt_net_alloc = ccohort%prt%GetNetAlloc(fnrt_organ, carbon12_element) * days_per_sec + struct_net_alloc = ccohort%prt%GetNetAlloc(struct_organ, carbon12_element) * days_per_sec + repro_net_alloc = ccohort%prt%GetNetAlloc(repro_organ, carbon12_element) * days_per_sec + + ! [kgC/plant/day] -> [gC/m2/s] + agnpp = agnpp + ccohort%n/cpatch%area * (leaf_net_alloc + repro_net_alloc + & + prt_params%allom_agb_frac(ccohort%pft)*(sapw_net_alloc+store_net_alloc+struct_net_alloc)) * g_per_kg + + ! [kgC/plant/day] -> [gC/m2/s] + bgnpp = bgnpp + ccohort%n/cpatch%area * (fnrt_net_alloc + & + (1._r8-prt_params%allom_agb_frac(ccohort%pft))*(sapw_net_alloc+store_net_alloc+struct_net_alloc)) * g_per_kg + + ! (gC/m2/s) root respiration (fine root MR + total root GR) + ! RGK: We do not save root respiration and average over the day. Until we do + ! this is a best (bad) guess at fine root MR + total root GR + ! (kgC/indiv/yr) -> gC/m2/s + bc_out%root_resp(1:bc_in%nlevsoil) = bc_out%root_resp(1:bc_in%nlevsoil) + & + ccohort%resp_acc_hold*years_per_day*g_per_kg*days_per_sec* & + ccohort%n*area_inv*(1._r8-prt_params%allom_agb_frac(ccohort%pft)) * csite%rootfrac_scr(1:bc_in%nlevsoil) + + end if + + ccohort => ccohort%shorter + end do + + if( sum(bc_out%rootfr_pa(fp,1:bc_in%nlevsoil)) > nearzero) then + bc_out%rootfr_pa(fp,1:bc_in%nlevsoil) = & + bc_out%rootfr_pa(fp,1:bc_in%nlevsoil) / & + sum(bc_out%rootfr_pa(fp,1:bc_in%nlevsoil)) + end if + + ! RGK: These averages should switch to the new patch averaging methods + ! when available. Right now we are not doing any time averaging + ! because it would be mixing the memory of patches, which + ! would be arguably worse than just using the instantaneous value + + ! gC/m2/s + bc_out%annavg_agnpp_pa(fp) = agnpp + bc_out%annavg_bgnpp_pa(fp) = bgnpp + ! gc/m2/yr + bc_out%annsum_npp_pa(fp) = (bgnpp+agnpp)*days_per_year*sec_per_day + + + cpatch => cpatch%younger + end do + + return + end subroutine PrepCH4BCs + + ! ===================================================================================== + subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) ! ----------------------------------------------------------------------------------- @@ -449,8 +586,6 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) real(r8), parameter :: decompmicc_lambda = 2.5_r8 ! Depth attenuation exponent for decomposer biomass real(r8), parameter :: decompmicc_zmax = 7.0e-2_r8 ! Depth of maximum decomposer biomass - - ! Determine the scaling approach if((hlm_parteh_mode.eq.prt_cnp_flex_allom_hyp) .and. & ((n_uptake_mode.eq.coupled_n_uptake) .or. & diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 8b8eb4aa24..6b3cc6b71b 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -48,6 +48,7 @@ module EDMainMod use FatesSoilBGCFluxMod , only : FluxIntoLitterPools use EDCohortDynamicsMod , only : UpdateCohortBioPhysRates use FatesSoilBGCFluxMod , only : PrepNutrientAquisitionBCs + use FatesSoilBGCFluxMod , only : PrepCH4BCs use SFMainMod , only : fire_model use FatesSizeAgeTypeIndicesMod, only : get_age_class_index use FatesSizeAgeTypeIndicesMod, only : coagetype_class_index @@ -676,16 +677,14 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) currentPatch => currentPatch%younger enddo - ! Aggregate FATES litter output fluxes and - ! package them into boundary conditions - ! Note: The FATES state variables that generate these - ! boundary conditions are read in on the restart, - ! and, they are zero'd only at the start of ecosystem - ! dynamics - - ! Based on current status of the + ! The HLMs need to know about nutrient demand, and/or + ! root mass and affinities call PrepNutrientAquisitionBCs(currentSite,bc_in,bc_out) + ! The HLM methane module needs information about + ! rooting mass, distributions, respiration rates and NPP + call PrepCH4BCs(currentSite) + ! FIX(RF,032414). This needs to be monthly, not annual ! If this is the second to last day of the year, then perform trimming diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index a34fcdc095..27021da83a 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -217,7 +217,8 @@ module FatesHistoryInterfaceMod integer :: ih_leafn_scpf integer :: ih_fnrtn_scpf integer :: ih_storen_scpf - integer :: ih_storentfrac_scpf + integer :: ih_storentfrac_canopy_scpf + integer :: ih_storentfrac_understory_scpf integer :: ih_sapwn_scpf integer :: ih_repron_scpf integer,public :: ih_nh4uptake_scpf @@ -238,7 +239,8 @@ module FatesHistoryInterfaceMod integer :: ih_fnrtp_scpf integer :: ih_reprop_scpf integer :: ih_storep_scpf - integer :: ih_storeptfrac_scpf + integer :: ih_storeptfrac_canopy_scpf + integer :: ih_storeptfrac_understory_scpf integer :: ih_sapwp_scpf integer,public :: ih_puptake_scpf integer :: ih_pefflux_scpf @@ -3109,7 +3111,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_fnrtn_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_sapwn_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_storen_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_storentfrac_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_repron_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_nefflux_scpf)%r82d(io_si,:) = & @@ -3131,9 +3134,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_fnrtp_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_sapwp_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_storep_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_storeptfrac_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_reprop_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_pefflux_scpf)%r82d(io_si,:) = & sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) @@ -3246,9 +3249,15 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) + store_m * ccohort%n this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) + repro_m * ccohort%n - this%hvars(ih_storentfrac_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storentfrac_scpf)%r82d(io_si,i_scpf) + store_max * ccohort%n + if (ccohort%canopy_layer .eq. 1) then + this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n + else + this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n + end if + elseif(element_list(el).eq.phosphorus_element)then store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) @@ -3265,8 +3274,15 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) + store_m * ccohort%n this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) + repro_m * ccohort%n - this%hvars(ih_storeptfrac_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storeptfrac_scpf)%r82d(io_si,i_scpf) + store_max * ccohort%n + + if (ccohort%canopy_layer .eq. 1) then + this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n + else + this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n + end if + end if ccohort => ccohort%shorter @@ -3288,11 +3304,19 @@ subroutine update_history_dyn(this,nc,nsites,sites) do i_pft = 1, numpft do i_scls = 1,nlevsclass i_scpf = (i_pft-1)*nlevsclass + i_scls - if( this%hvars(ih_storentfrac_scpf)%r82d(io_si,i_scpf)>nearzero ) then - this%hvars(ih_storentfrac_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) / & - this%hvars(ih_storentfrac_scpf)%r82d(io_si,i_scpf) + + if( hio_nplant_canopy_si_scpf(io_si,i_scpf)>nearzero ) then + this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) / & + hio_nplant_canopy_si_scpf(io_si,i_scpf) + end if + + if( hio_nplant_understory_si_scpf(io_si,i_scpf)>nearzero ) then + this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) / & + hio_nplant_understory_si_scpf(io_si,i_scpf) end if + end do end do elseif(element_list(el).eq.phosphorus_element)then @@ -3303,11 +3327,19 @@ subroutine update_history_dyn(this,nc,nsites,sites) do i_pft = 1, numpft do i_scls = 1,nlevsclass i_scpf = (i_pft-1)*nlevsclass + i_scls - if( this%hvars(ih_storeptfrac_scpf)%r82d(io_si,i_scpf)>nearzero ) then - this%hvars(ih_storeptfrac_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) / & - this%hvars(ih_storeptfrac_scpf)%r82d(io_si,i_scpf) + + if( hio_nplant_canopy_si_scpf(io_si,i_scpf)>nearzero ) then + this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) /& + hio_nplant_canopy_si_scpf(io_si,i_scpf) + + end if + if( hio_nplant_understory_si_scpf(io_si,i_scpf)>nearzero ) then + this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) /& + hio_nplant_understory_si_scpf(io_si,i_scpf) end if + end do end do end if @@ -6025,10 +6057,15 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storen_scpf ) - call this%set_history_var(vname='STOREN_TFRAC_SCPF', units='kgN/ha', & - long='storage nitrogen fraction of target by size-class x pft', use_default='inactive', & + call this%set_history_var(vname='STOREN_TFRAC_CANOPY_SCPF', units='kgN/ha', & + long='storage nitrogen fraction of target,in canopy, by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storentfrac_canopy_scpf ) + + call this%set_history_var(vname='STOREN_TFRAC_UNDERSTORY_SCPF', units='kgN/ha', & + long='storage nitrogen fraction of target,in understory, by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storentfrac_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storentfrac_understory_scpf ) call this%set_history_var(vname='REPRON_SCPF', units='kgN/ha', & long='reproductive nitrogen mass (on plant) by size-class x pft', use_default='inactive', & @@ -6084,11 +6121,15 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storep_scpf ) - call this%set_history_var(vname='STOREP_TFRAC_SCPF', units='kgN/ha', & - long='storage phosphorus fraction of target by size-class x pft', use_default='inactive', & + call this%set_history_var(vname='STOREP_TFRAC_CANOPY_SCPF', units='kgN/ha', & + long='storage phosphorus fraction of target,in canopy, by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storeptfrac_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storeptfrac_canopy_scpf ) + call this%set_history_var(vname='STOREP_TFRAC_UNDERSTORY_SCPF', units='kgN/ha', & + long='storage phosphorus fraction of target,in understory, by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storeptfrac_understory_scpf ) call this%set_history_var(vname='REPROP_SCPF', units='kgP/ha', & long='reproductive phosphorus mass (on plant) by size-class x pft', use_default='inactive', & diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index ad9999f343..d65044eb56 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -345,7 +345,7 @@ subroutine zero_bcs(fates,s) 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 @@ -582,6 +582,18 @@ subroutine allocate_bcout(bc_out, nlevsoil_in, nlevdecomp_in) allocate(bc_out%cp_scalar(max_comp_per_site)) end if + ! Include the bare-ground patch for these patch-level boundary conditions + ! (it will always be zero for all of these) + allocate(bc_out%annavg_agnpp_pa(0:maxPatchesPerSite));bc_out%annavg_agnpp_pa(:)=nan + allocate(bc_out%annavg_bgnpp_pa(0:maxPatchesPerSite));bc_out%annavg_bgnpp_pa(:)=nan + allocate(bc_out%annsum_npp_pa(0:maxPatchesPerSite));bc_out%annsum_npp_pa(:)=nan + allocate(bc_out%frootc_pa(0:maxPatchesPerSite));bc_out%frootc_pa(:)=nan + allocate(bc_out%root_resp(nlevsoil_in));bc_out%root_resp(:)=nan + allocate(bc_out%rootfr_pa(0:maxPatchesPerSite,nlevsoil_in)) + bc_out%rootfr_pa(:,:)=nan + + ! Give the bare-ground root fractions a nominal fraction of unity over depth + bc_out%rootfr_pa(0,1:nlevsoil_in)=1._r8/real(nlevsoil_in,r8) ! Fates -> BGC fragmentation mass fluxes select case(hlm_parteh_mode) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 92319469be..3492814e59 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -621,7 +621,7 @@ module FatesInterfaceTypesMod - ! CTC/RD Nutrient Boundary Conditions + ! RD Nutrient Boundary Conditions ! --------------------------------------------------------------------------------- real(r8), pointer :: n_demand(:) ! Nitrogen demand from each competitor @@ -630,8 +630,14 @@ module FatesInterfaceTypesMod ! for use in ELMs CTC/RD [g/m2/s] - - + ! CH4 Boundary Conditions + ! ----------------------------------------------------------------------------------- + real(r8), pointer :: annavg_agnpp_pa(:) ! annual average patch npp above ground (gC/m2/s) + real(r8), pointer :: annavg_bgnpp_pa(:) ! annual average patch npp below ground (gC/m2/s) + real(r8), pointer :: annsum_npp_pa(:) ! annual sum patch npp (gC/m2/yr) + real(r8), pointer :: frootc_pa(:) ! Carbon in fine roots (gC/m2) + real(r8), pointer :: root_resp(:) ! (gC/m2/s) root respiration (fine root MR + total root GR) + real(r8), pointer :: rootfr_pa(:,:) ! Rooting fraction with depth ! Canopy Structure From 554165b1db02935311ae70c43afcff07c98e0b8a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 4 May 2021 11:26:43 -0400 Subject: [PATCH 273/578] Added woody fraction bc for ch4 coupling --- biogeochem/FatesSoilBGCFluxMod.F90 | 25 ++++++++++++++++++++----- main/FatesInterfaceMod.F90 | 1 + main/FatesInterfaceTypesMod.F90 | 14 ++++++++------ 3 files changed, 29 insertions(+), 11 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index b4a9d02b18..c329545beb 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -69,6 +69,7 @@ module FatesSoilBGCFluxMod use FatesConstantsMod, only : days_per_year use FatesConstantsMod, only : sec_per_day use FatesConstantsMod, only : years_per_day + use FatesConstantsMod, only : itrue use FatesLitterMod, only : litter_type use FatesLitterMod , only : ncwd use FatesLitterMod , only : ndcmpy @@ -434,6 +435,8 @@ subroutine PrepCH4BCs(csite) integer :: fp ! patch index of the site real(r8) :: agnpp ! Above ground daily npp real(r8) :: bgnpp ! Below ground daily npp + real(r8) :: plant_area ! crown area (m2) of all plants in patch + real(r8) :: woody_area ! corwn area (m2) of woody plants in patch real(r8) :: fnrt_c ! Fine root carbon [kg/plant] real(r8) :: sapw_net_alloc real(r8) :: store_net_alloc @@ -452,7 +455,8 @@ subroutine PrepCH4BCs(csite) bc_out%rootfr_pa(:,:) = 0._r8 bc_out%frootc_pa(:) = 0._r8 bc_out%root_resp(:) = 0._r8 - + bc_out%woody_frac_aere_pa(:) = 0._r8 + fp = 0 cpatch => csite%oldest_patch do while (associated(cpatch)) @@ -465,6 +469,8 @@ subroutine PrepCH4BCs(csite) agnpp = 0._r8 bgnpp = 0._r8 + woody_area = 0._r8 + plant_area = 0._r8 ccohort => cpatch%tallest do while (associated(ccohort)) @@ -503,11 +509,11 @@ subroutine PrepCH4BCs(csite) ! [kgC/plant/day] -> [gC/m2/s] agnpp = agnpp + ccohort%n/cpatch%area * (leaf_net_alloc + repro_net_alloc + & - prt_params%allom_agb_frac(ccohort%pft)*(sapw_net_alloc+store_net_alloc+struct_net_alloc)) * g_per_kg + prt_params%allom_agb_frac(pft)*(sapw_net_alloc+store_net_alloc+struct_net_alloc)) * g_per_kg ! [kgC/plant/day] -> [gC/m2/s] bgnpp = bgnpp + ccohort%n/cpatch%area * (fnrt_net_alloc + & - (1._r8-prt_params%allom_agb_frac(ccohort%pft))*(sapw_net_alloc+store_net_alloc+struct_net_alloc)) * g_per_kg + (1._r8-prt_params%allom_agb_frac(pft))*(sapw_net_alloc+store_net_alloc+struct_net_alloc)) * g_per_kg ! (gC/m2/s) root respiration (fine root MR + total root GR) ! RGK: We do not save root respiration and average over the day. Until we do @@ -515,7 +521,13 @@ subroutine PrepCH4BCs(csite) ! (kgC/indiv/yr) -> gC/m2/s bc_out%root_resp(1:bc_in%nlevsoil) = bc_out%root_resp(1:bc_in%nlevsoil) + & ccohort%resp_acc_hold*years_per_day*g_per_kg*days_per_sec* & - ccohort%n*area_inv*(1._r8-prt_params%allom_agb_frac(ccohort%pft)) * csite%rootfrac_scr(1:bc_in%nlevsoil) + ccohort%n*area_inv*(1._r8-prt_params%allom_agb_frac(pft)) * csite%rootfrac_scr(1:bc_in%nlevsoil) + + if( prt_params%woody(pft)==itrue ) then + woody_area = woody_area + ccohort%c_area + end if + plant_area = plant_area + ccohort%c_area + end if @@ -538,7 +550,10 @@ subroutine PrepCH4BCs(csite) bc_out%annavg_bgnpp_pa(fp) = bgnpp ! gc/m2/yr bc_out%annsum_npp_pa(fp) = (bgnpp+agnpp)*days_per_year*sec_per_day - + + if(plant_area>nearzero) then + bc_out%woody_frac_aere_pa(fp) = woody_area/plant_area + end if cpatch => cpatch%younger end do diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index d65044eb56..330f3aef05 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -589,6 +589,7 @@ subroutine allocate_bcout(bc_out, nlevsoil_in, nlevdecomp_in) allocate(bc_out%annsum_npp_pa(0:maxPatchesPerSite));bc_out%annsum_npp_pa(:)=nan allocate(bc_out%frootc_pa(0:maxPatchesPerSite));bc_out%frootc_pa(:)=nan allocate(bc_out%root_resp(nlevsoil_in));bc_out%root_resp(:)=nan + allocate(bc_out%woody_frac_aere_pa(0:maxPatchesPerSite));bc_out%woody_frac_aere_pa(:)=nan allocate(bc_out%rootfr_pa(0:maxPatchesPerSite,nlevsoil_in)) bc_out%rootfr_pa(:,:)=nan diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 3492814e59..e0bef76e78 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -632,12 +632,14 @@ module FatesInterfaceTypesMod ! CH4 Boundary Conditions ! ----------------------------------------------------------------------------------- - real(r8), pointer :: annavg_agnpp_pa(:) ! annual average patch npp above ground (gC/m2/s) - real(r8), pointer :: annavg_bgnpp_pa(:) ! annual average patch npp below ground (gC/m2/s) - real(r8), pointer :: annsum_npp_pa(:) ! annual sum patch npp (gC/m2/yr) - real(r8), pointer :: frootc_pa(:) ! Carbon in fine roots (gC/m2) - real(r8), pointer :: root_resp(:) ! (gC/m2/s) root respiration (fine root MR + total root GR) - real(r8), pointer :: rootfr_pa(:,:) ! Rooting fraction with depth + real(r8), pointer :: annavg_agnpp_pa(:) ! annual average patch npp above ground (gC/m2/s) + real(r8), pointer :: annavg_bgnpp_pa(:) ! annual average patch npp below ground (gC/m2/s) + real(r8), pointer :: annsum_npp_pa(:) ! annual sum patch npp (gC/m2/yr) + real(r8), pointer :: frootc_pa(:) ! Carbon in fine roots (gC/m2) + real(r8), pointer :: root_resp(:) ! (gC/m2/s) root respiration (fine root MR + total root GR) + real(r8), pointer :: rootfr_pa(:,:) ! Rooting fraction with depth + real(r8), pointer :: woody_frac_aere_pa(:) ! Woody plant fraction (by crown area) of all plants + ! used for calculating patch-level aerenchyma porosity ! Canopy Structure From 593ee03aa88fd156069fcf3cc378cede8f321fa3 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 4 May 2021 12:03:11 -0400 Subject: [PATCH 274/578] Updated CH4 coupling with ELM/CLM to utilize use_ch4 coupling flag, which prevents allocations when not needed --- biogeochem/FatesSoilBGCFluxMod.F90 | 4 +++ main/FatesInterfaceMod.F90 | 41 +++++++++++++++++++++--------- main/FatesInterfaceTypesMod.F90 | 4 +++ 3 files changed, 37 insertions(+), 12 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index c329545beb..9cc9f4398f 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -54,6 +54,7 @@ module FatesSoilBGCFluxMod use FatesInterfaceTypesMod, only : numpft use FatesInterfaceTypesMod, only : hlm_nu_com use FatesInterfaceTypesMod, only : hlm_parteh_mode + use FatesInterfaceTypesMod, only : hlm_use_ch4 use FatesConstantsMod , only : prescribed_p_uptake use FatesConstantsMod , only : prescribed_n_uptake use FatesConstantsMod , only : coupled_p_uptake @@ -444,6 +445,9 @@ subroutine PrepCH4BCs(csite) real(r8) :: leaf_net_alloc real(r8) :: struct_net_alloc real(r8) :: repro_net_alloc + + ! Exit if we need not communicate with the hlm's ch4 module + if(.not.(hlm_use_ch4==itrue)) return bc_out => csite%bc_out_ptr bc_in => csite%bc_in_ptr diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 330f3aef05..0156beb2dc 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -584,18 +584,21 @@ subroutine allocate_bcout(bc_out, nlevsoil_in, nlevdecomp_in) ! Include the bare-ground patch for these patch-level boundary conditions ! (it will always be zero for all of these) - allocate(bc_out%annavg_agnpp_pa(0:maxPatchesPerSite));bc_out%annavg_agnpp_pa(:)=nan - allocate(bc_out%annavg_bgnpp_pa(0:maxPatchesPerSite));bc_out%annavg_bgnpp_pa(:)=nan - allocate(bc_out%annsum_npp_pa(0:maxPatchesPerSite));bc_out%annsum_npp_pa(:)=nan - allocate(bc_out%frootc_pa(0:maxPatchesPerSite));bc_out%frootc_pa(:)=nan - allocate(bc_out%root_resp(nlevsoil_in));bc_out%root_resp(:)=nan - allocate(bc_out%woody_frac_aere_pa(0:maxPatchesPerSite));bc_out%woody_frac_aere_pa(:)=nan - allocate(bc_out%rootfr_pa(0:maxPatchesPerSite,nlevsoil_in)) - bc_out%rootfr_pa(:,:)=nan - - ! Give the bare-ground root fractions a nominal fraction of unity over depth - bc_out%rootfr_pa(0,1:nlevsoil_in)=1._r8/real(nlevsoil_in,r8) - + if(hlm_use_ch4.eq.itrue) then + allocate(bc_out%annavg_agnpp_pa(0:maxPatchesPerSite));bc_out%annavg_agnpp_pa(:)=nan + allocate(bc_out%annavg_bgnpp_pa(0:maxPatchesPerSite));bc_out%annavg_bgnpp_pa(:)=nan + allocate(bc_out%annsum_npp_pa(0:maxPatchesPerSite));bc_out%annsum_npp_pa(:)=nan + allocate(bc_out%frootc_pa(0:maxPatchesPerSite));bc_out%frootc_pa(:)=nan + allocate(bc_out%root_resp(nlevsoil_in));bc_out%root_resp(:)=nan + allocate(bc_out%woody_frac_aere_pa(0:maxPatchesPerSite));bc_out%woody_frac_aere_pa(:)=nan + allocate(bc_out%rootfr_pa(0:maxPatchesPerSite,nlevsoil_in)) + bc_out%rootfr_pa(:,:)=nan + + ! Give the bare-ground root fractions a nominal fraction of unity over depth + bc_out%rootfr_pa(0,1:nlevsoil_in)=1._r8/real(nlevsoil_in,r8) + end if + + ! Fates -> BGC fragmentation mass fluxes select case(hlm_parteh_mode) case(prt_carbon_allom_hyp) @@ -1214,6 +1217,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_nitrogen_spec = unset_int hlm_phosphorus_spec = unset_int hlm_max_patch_per_site = unset_int + hlm_use_ch4 = unset_int hlm_use_vertsoilc = unset_int hlm_parteh_mode = unset_int hlm_spitfire_mode = unset_int @@ -1452,6 +1456,13 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if(hlm_use_ch4 .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'switch for the HLMs CH4 module unset: hlm_use_ch4, exiting' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if(hlm_use_vertsoilc .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'switch for the HLMs soil carbon discretization unset: hlm_use_vertsoilc, exiting' @@ -1594,6 +1605,12 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering hlm_max_patch_per_site = ',ival,' to FATES' end if + case('use_ch4') + hlm_use_ch4 = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_use_ch4 = ',ival,' to FATES' + end if + case('use_vertsoilc') hlm_use_vertsoilc = ival if (fates_global_verbose()) then diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index e0bef76e78..1052ef251e 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -100,6 +100,10 @@ module FatesInterfaceTypesMod ! Transport (exensible) Hypothesis (PARTEH) to use + integer, public :: hlm_use_ch4 ! This flag signals whether the methane model in ELM/CLM is + ! active, and therefore whether or not boundary conditions + ! need to be prepped + integer, public :: hlm_use_vertsoilc ! This flag signals whether or not the ! host model is using vertically discretized ! soil carbon From f3d75c318684b33fe51e42f8438a09bcab00e21c Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 7 May 2021 11:17:40 -0600 Subject: [PATCH 275/578] added tools to difference two netcdf files, and two PFTs in one netcdf file --- tools/ncdiff.bash | 15 +++++++++++++++ tools/pftdiff.bash | 26 ++++++++++++++++++++++++++ 2 files changed, 41 insertions(+) create mode 100755 tools/ncdiff.bash create mode 100755 tools/pftdiff.bash diff --git a/tools/ncdiff.bash b/tools/ncdiff.bash new file mode 100755 index 0000000000..494d4168cd --- /dev/null +++ b/tools/ncdiff.bash @@ -0,0 +1,15 @@ +#!/usr/bin/env bash + +## script that compares the differences between two netcdf files. +## two arguments are the paths to two files to compare + +tempfile1=$(mktemp) +tempfile2=$(mktemp) + +ncdump $1 >> ${tempfile1} +ncdump $2 >> ${tempfile2} + +diff ${tempfile1} ${tempfile2} + +rm ${temp_file1} +rm ${temp_file2} diff --git a/tools/pftdiff.bash b/tools/pftdiff.bash new file mode 100755 index 0000000000..4076f8386a --- /dev/null +++ b/tools/pftdiff.bash @@ -0,0 +1,26 @@ +#!/usr/bin/env bash + +## script to compare two PFTs in a FATES parameter file. takes three arguments: +## first argument is the parameter file name +## second argument is the first pft +## third argument is the second pft + +tempfile1=$(mktemp) +tempfile2=$(mktemp) +tempfile3=$(mktemp) +tempfile4=$(mktemp) + +toolsdir=$(dirname "$0") + +$toolsdir/FatesPFTIndexSwapper.py --pft-indices=$2 --fin=$1 --fout=${tempfile1} &>/dev/null +$toolsdir/FatesPFTIndexSwapper.py --pft-indices=$3 --fin=$1 --fout=${tempfile2} &>/dev/null + +ncdump ${tempfile1} >> ${tempfile3} +ncdump ${tempfile2} >> ${tempfile4} + +diff ${tempfile3} ${tempfile4} + +rm ${tempfile1} +rm ${tempfile2} +rm ${tempfile3} +rm ${tempfile4} From c231b42180b73bd6929b38cc4608fe2f78e2599e Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 7 May 2021 11:22:32 -0600 Subject: [PATCH 276/578] fixed typo --- tools/ncdiff.bash | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tools/ncdiff.bash b/tools/ncdiff.bash index 494d4168cd..ab09d91cd4 100755 --- a/tools/ncdiff.bash +++ b/tools/ncdiff.bash @@ -11,5 +11,5 @@ ncdump $2 >> ${tempfile2} diff ${tempfile1} ${tempfile2} -rm ${temp_file1} -rm ${temp_file2} +rm ${tempfile1} +rm ${tempfile2} From cce7113bf50d3970a79272e63e097db33b05d186 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 10 May 2021 12:38:09 -0600 Subject: [PATCH 277/578] Fixes to litter generation and what organs are filtered --- parteh/PRTLossFluxesMod.F90 | 58 ++++++++++++++++++++----------------- 1 file changed, 31 insertions(+), 27 deletions(-) diff --git a/parteh/PRTLossFluxesMod.F90 b/parteh/PRTLossFluxesMod.F90 index e144f228e3..13b09b2e37 100644 --- a/parteh/PRTLossFluxesMod.F90 +++ b/parteh/PRTLossFluxesMod.F90 @@ -513,23 +513,25 @@ subroutine DeciduousTurnoverSimpleRetranslocation(prt,ipft,organ_id,mass_fractio i_var = organ_map(organ_id)%var_id(i_var_of_organ) element_id = prt_global%state_descriptor(i_var)%element_id - - - if ( any(element_id == carbon_elements_list) ) then - retrans = prt_params%turnover_carb_retrans(ipft,prt_params%organ_param_id(organ_id)) - else if( element_id == nitrogen_element ) then - retrans = prt_params%turnover_nitr_retrans(ipft,prt_params%organ_param_id(organ_id)) - else if( element_id == phosphorus_element ) then - retrans = prt_params%turnover_phos_retrans(ipft,prt_params%organ_param_id(organ_id)) + if( prt_params%organ_param_id(organ_id) < 1 ) then + retrans = 0._r8 else - write(fates_log(),*) 'Please add a new re-translocation clause to your ' - write(fates_log(),*) ' organ x element combination' - write(fates_log(),*) ' organ: ',leaf_organ,' element: ',element_id - write(fates_log(),*) 'Exiting' - call endrun(msg=errMsg(__FILE__, __LINE__)) + if ( any(element_id == carbon_elements_list) ) then + retrans = prt_params%turnover_carb_retrans(ipft,prt_params%organ_param_id(organ_id)) + else if( element_id == nitrogen_element ) then + retrans = prt_params%turnover_nitr_retrans(ipft,prt_params%organ_param_id(organ_id)) + else if( element_id == phosphorus_element ) then + retrans = prt_params%turnover_phos_retrans(ipft,prt_params%organ_param_id(organ_id)) + else + write(fates_log(),*) 'Please add a new re-translocation clause to your ' + write(fates_log(),*) ' organ x element combination' + write(fates_log(),*) ' organ: ',leaf_organ,' element: ',element_id + write(fates_log(),*) 'Exiting' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if end if - + ! Get the variable id of the storage pool for this element store_var_id = prt_global%sp_organ_map(store_organ,element_id) @@ -723,20 +725,22 @@ subroutine MaintTurnoverSimpleRetranslocation(prt,ipft,is_drought) ! If this organ does not have a retranslocation rate ! then it is not valid for turnover - if( prt_params%organ_param_id(organ_id) < 1 ) cycle - - if ( any(element_id == carbon_elements_list) ) then - retrans_frac = prt_params%turnover_carb_retrans(ipft,prt_params%organ_param_id(organ_id)) - else if( element_id == nitrogen_element ) then - retrans_frac = prt_params%turnover_nitr_retrans(ipft,prt_params%organ_param_id(organ_id)) - else if( element_id == phosphorus_element ) then - retrans_frac = prt_params%turnover_phos_retrans(ipft,prt_params%organ_param_id(organ_id)) + if( prt_params%organ_param_id(organ_id) < 1 ) then + retrans_frac = 0._r8 else - write(fates_log(),*) 'Please add a new re-translocation clause to your ' - write(fates_log(),*) ' organ x element combination' - write(fates_log(),*) ' organ: ',organ_id,' element: ',element_id - write(fates_log(),*) 'Exiting' - call endrun(msg=errMsg(__FILE__, __LINE__)) + if ( any(element_id == carbon_elements_list) ) then + retrans_frac = prt_params%turnover_carb_retrans(ipft,prt_params%organ_param_id(organ_id)) + else if( element_id == nitrogen_element ) then + retrans_frac = prt_params%turnover_nitr_retrans(ipft,prt_params%organ_param_id(organ_id)) + else if( element_id == phosphorus_element ) then + retrans_frac = prt_params%turnover_phos_retrans(ipft,prt_params%organ_param_id(organ_id)) + else + write(fates_log(),*) 'Please add a new re-translocation clause to your ' + write(fates_log(),*) ' organ x element combination' + write(fates_log(),*) ' organ: ',organ_id,' element: ',element_id + write(fates_log(),*) 'Exiting' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if end if if(base_turnover(organ_id) < check_initialized) then From b77a0d5d1d256c334812b4fb2b3dd37fe91cc2f4 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 10 May 2021 12:39:41 -0600 Subject: [PATCH 278/578] Revereted canopy layer and max cohort counts to maintain consistency with previous release (2,100) --- main/EDTypesMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index f6cf59f359..3548e3a61d 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -28,9 +28,9 @@ module EDTypesMod integer, parameter, public :: maxPatchesPerSite = 14 ! maximum number of patches to live on a site integer, parameter, public :: maxPatchesPerSite_by_disttype(n_anthro_disturbance_categories) = & (/ 10, 4 /) !!! MUST SUM TO maxPatchesPerSite !!! - integer, public :: maxCohortsPerPatch = 150 ! maximum number of cohorts per patch + integer, public :: maxCohortsPerPatch = 100 ! maximum number of cohorts per patch - integer, parameter, public :: nclmax = 3 ! Maximum number of canopy layers + integer, parameter, public :: nclmax = 2 ! Maximum number of canopy layers integer, parameter, public :: ican_upper = 1 ! Nominal index for the upper canopy integer, parameter, public :: ican_ustory = 2 ! Nominal index for diagnostics that refer ! to understory layers (all layers that From 7fba81e143046a870e913e40c79ac4131368b952 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 10 May 2021 15:59:26 -0700 Subject: [PATCH 279/578] adding hui's logic to exclude sai calculation from lai during sp mode --- biogeochem/EDCanopyStructureMod.F90 | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index eefb94291b..a86c6cc022 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -55,7 +55,7 @@ module EDCanopyStructureMod public :: canopy_summarization public :: update_hlm_dynamics - logical, parameter :: debug=.false. + logical, parameter :: debug=.true. character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -1478,6 +1478,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) real(r8) :: lai ! summed lai for checking m2 m-2 real(r8) :: snow_depth_avg ! avg snow over whole site real(r8) :: leaf_c ! leaf carbon [kg] + real(r8) :: saicheck ! diagnostic check for Satellite phenology mode !---------------------------------------------------------------------- @@ -1534,10 +1535,24 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) currentCohort%n, currentCohort%canopy_layer, & currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + if (hlm_use_sp .eq. ifalse) then currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & currentPatch%canopy_layer_tlai, currentCohort%treelai , & currentCohort%vcmax25top,4) + else + ! If we are using satellite phenology, conduct a check against the calculated sai + saicheck = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & + currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai, currentCohort%treelai , & + currentCohort%vcmax25top,4) + + if ( debug ) write(fates_log(), *) 'SP mode: sai check: ', saicheck - currentCohort%treesai + + end if + + if ( debug ) write(fates_log(), *) 'currentCohort%treesai: ', currentCohort%treesai + if ( debug ) write(fates_log(), *) 'currentCohort%treelai: ', currentCohort%treelai currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area From 80db20de483798e5abcf2ab5f1e94f25dfc73e33 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 11 May 2021 11:25:14 -0400 Subject: [PATCH 280/578] Updated comments in hydro recruitment routines --- biogeochem/EDCanopyStructureMod.F90 | 8 +++++++- biogeophys/FatesPlantHydraulicsMod.F90 | 9 ++++----- 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index a8b8d6aa5e..bf62fa4247 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -2022,7 +2022,13 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) end do - ! This call is purely for diagnostics and history variables + ! This call to RecruitWaterStorage() makes an accounting of + ! how much water is used to intialize newly recruited plants. + ! However, it does not actually move water from the soil or create + ! a flux, it is just accounting for diagnostics purposes. The water + ! will not actually be moved until the beginning of the first hydraulics + ! call during the fast timestep sequence + if (hlm_use_planthydro.eq.itrue) then call RecruitWaterStorage(nsites,sites,bc_out) end if diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 2444ad881f..a3389cdd61 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -4079,11 +4079,10 @@ 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. + ! *Note that no mass is moved in this call, this routine is only for + ! generating diagnostics. Water fluxes will be calculated during + ! again during RecruitWUptake() the next time the hydraulics routine is run, + ! and water will be removed from the soil to accomodate. ! --------------------------------------------------------------------------- ! Arguments From be6afa8c2bf4d1e2ffb0afdf11eebeb4bcb0de0b Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 11 May 2021 14:27:31 -0600 Subject: [PATCH 281/578] added halp output and changed names of ncdiff and pftdiff scripts --- tools/ncdiff | 21 +++++++++++++++++++++ tools/ncdiff.bash | 15 --------------- tools/{pftdiff.bash => pftdiff} | 15 +++++++++++---- 3 files changed, 32 insertions(+), 19 deletions(-) create mode 100755 tools/ncdiff delete mode 100755 tools/ncdiff.bash rename tools/{pftdiff.bash => pftdiff} (54%) diff --git a/tools/ncdiff b/tools/ncdiff new file mode 100755 index 0000000000..37709b4ad1 --- /dev/null +++ b/tools/ncdiff @@ -0,0 +1,21 @@ +#!/usr/bin/env bash + +while getopts ":h" option; do + case $option in + h) # display Help + echo "script that compares the differences between two netcdf files." + echo "two arguments are the paths to two files to compare" + exit;; + esac +done + +tempfile1=$(mktemp) +tempfile2=$(mktemp) + +ncdump $1 >> ${tempfile1} +ncdump $2 >> ${tempfile2} + +diff ${tempfile1} ${tempfile2} + +rm ${tempfile1} +rm ${tempfile2} diff --git a/tools/ncdiff.bash b/tools/ncdiff.bash deleted file mode 100755 index ab09d91cd4..0000000000 --- a/tools/ncdiff.bash +++ /dev/null @@ -1,15 +0,0 @@ -#!/usr/bin/env bash - -## script that compares the differences between two netcdf files. -## two arguments are the paths to two files to compare - -tempfile1=$(mktemp) -tempfile2=$(mktemp) - -ncdump $1 >> ${tempfile1} -ncdump $2 >> ${tempfile2} - -diff ${tempfile1} ${tempfile2} - -rm ${tempfile1} -rm ${tempfile2} diff --git a/tools/pftdiff.bash b/tools/pftdiff similarity index 54% rename from tools/pftdiff.bash rename to tools/pftdiff index 4076f8386a..300add459e 100755 --- a/tools/pftdiff.bash +++ b/tools/pftdiff @@ -1,9 +1,16 @@ #!/usr/bin/env bash -## script to compare two PFTs in a FATES parameter file. takes three arguments: -## first argument is the parameter file name -## second argument is the first pft -## third argument is the second pft +while getopts ":h" option; do + case $option in + h) # display Help + echo "script to compare two PFTs in a FATES parameter file. takes three arguments: " + echo "first argument is the parameter file name" + echo "second argument is the first pft number (PFT numbering starts with 1)" + echo "third argument is the second pft number (PFT numbering starts with 1)" + exit;; + esac +done + tempfile1=$(mktemp) tempfile2=$(mktemp) From b0f482f814008bc10b222acab240d911d78cc6f9 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 12 May 2021 10:14:30 -0400 Subject: [PATCH 282/578] Update main/FatesRunningMeanMod.F90 Co-authored-by: Charlie Koven --- main/FatesRunningMeanMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesRunningMeanMod.F90 b/main/FatesRunningMeanMod.F90 index b535b6b678..f1a30d8fa8 100644 --- a/main/FatesRunningMeanMod.F90 +++ b/main/FatesRunningMeanMod.F90 @@ -131,7 +131,7 @@ function GetMean(this) if(this%def_type%method .eq. moving_ema_window) then if(this%c_index == 0) then write(fates_log(), *) 'attempting to get a running mean from a variable' - write(fates_log(), *) 'that has been given a value yet' + write(fates_log(), *) 'that has not been given a value yet' call endrun(msg=errMsg(sourcefile, __LINE__)) end if else From 7d9142353cc0da691d05e85f12f1e2953b6bb5e6 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 12 May 2021 10:15:03 -0400 Subject: [PATCH 283/578] Update main/FatesRunningMeanMod.F90 Co-authored-by: Charlie Koven --- main/FatesRunningMeanMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesRunningMeanMod.F90 b/main/FatesRunningMeanMod.F90 index f1a30d8fa8..43e5793b69 100644 --- a/main/FatesRunningMeanMod.F90 +++ b/main/FatesRunningMeanMod.F90 @@ -51,7 +51,7 @@ module FatesRunningMeanMod type, public :: rmean_type real(r8) :: c_mean ! The current mean value, if this - ! is a moving window, its is the mean. + ! is a moving window, it is the mean. ! If this is a fixed window, it is only a partial mean ! as the value uses equal update weights and is not ! necessarily fully constructed. From d3b02c65ba4a69f2780805e3d2b1f6890d8a6b11 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 12 May 2021 10:15:15 -0400 Subject: [PATCH 284/578] Update main/FatesRunningMeanMod.F90 Co-authored-by: Charlie Koven --- main/FatesRunningMeanMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesRunningMeanMod.F90 b/main/FatesRunningMeanMod.F90 index 43e5793b69..98e2a07880 100644 --- a/main/FatesRunningMeanMod.F90 +++ b/main/FatesRunningMeanMod.F90 @@ -59,7 +59,7 @@ module FatesRunningMeanMod real(r8) :: l_mean ! The latest reportable mean value ! this value is actually the same ! as c_mean for moving windows, and for fixed windows - ! it is the mean value when the time integratino window + ! it is the mean value when the time integration window ! last completed. integer :: c_index ! The number of values that have From 656a8ad926c62c8948361af13d23e3f7e8e4fa50 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 12 May 2021 10:47:13 -0400 Subject: [PATCH 285/578] Moving tveg24 to a fixed window average, part 1 --- biogeochem/EDPatchDynamicsMod.F90 | 11 +++++++++-- main/EDTypesMod.F90 | 2 +- main/FatesRunningMeanMod.F90 | 8 +++----- 3 files changed, 13 insertions(+), 8 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 25c5decc79..9d342cc6a6 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -85,7 +85,7 @@ module EDPatchDynamicsMod use SFParamsMod, only : SF_VAL_CWD_FRAC use EDParamsMod, only : logging_event_code use EDParamsMod, only : logging_export_frac - use FatesRunningMeanMod, only : ema_24hr + use FatesRunningMeanMod, only : ema_24hr, fixed_24hr ! CIME globals use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) @@ -1959,6 +1959,8 @@ end subroutine mortality_litter_fluxes subroutine create_patch(currentSite, new_patch, age, areap, label) + use FatesInterfaceTypesMod, only : hlm_current_tod,hlm_current_date,hlm_reference_date + ! ! !DESCRIPTION: ! Set default values for creating a new patch @@ -1988,8 +1990,13 @@ subroutine create_patch(currentSite, new_patch, age, areap, label) allocate(new_patch%fragmentation_scaler(currentSite%nlevsoil)) allocate(new_patch%tveg24) - call new_patch%tveg24%InitRMean(ema_24hr) ! No initial value + !call new_patch%tveg24%InitRMean(ema_24hr) ! No initial value + print*,hlm_current_tod,hlm_current_date,hlm_reference_date + stop + + call new_patch%tveg24%InitRMean(fixed_24hr ) + ! Litter ! Allocate, Zero Fluxes, and Initialize to "unset" values diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 94c4d77fcf..e4b274e5bc 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -415,7 +415,7 @@ module EDTypesMod ! Running means !class(rmean_type), pointer :: t2m ! Place-holder for 2m air temperature (variable window-size) - class(rmean_type), pointer :: tveg24 ! 24-hour mean vegetation temperature (K) + class(rmean_type), pointer :: tveg24 ! 24-hour mean vegetation temperature (K) ! LEAF ORGANIZATION diff --git a/main/FatesRunningMeanMod.F90 b/main/FatesRunningMeanMod.F90 index 98e2a07880..0dc9fe3355 100644 --- a/main/FatesRunningMeanMod.F90 +++ b/main/FatesRunningMeanMod.F90 @@ -11,18 +11,16 @@ module FatesRunningMeanMod implicit none private - integer, parameter :: maxlen_varname = 8 - ! These are flags that specify how the averaging window works. - ! Moving windows (default) can have an arbitrary size and update frequency) + ! Exponential moving average (EMA) windows have an arbitrary size and update frequency) ! and it is technically never reset, it just averages indefinitely. - ! But hourly, six-hourly, daily, monthly and yearly windows have pre-set + ! But hourly, six-hourly, daily, monthly and yearly fixed windows have pre-set ! window sizes associated with their namesake, and more importantly, they ! are zero'd at the beginning of the interval, and get equal average weighting ! over their construction period. - integer, public, parameter :: moving_ema_window = 0 + integer, public, parameter :: moving_ema_window = 0 ! (exponential moving average) integer, public, parameter :: fixed_window = 1 ! This type defines a type of mean. It does not From 7136c10f60633d61c6b253e02bb2739084b27d8e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 14 May 2021 15:27:19 -0400 Subject: [PATCH 286/578] Cleaned up some diagnostic print statements, finalizing vegtemp 24 rmean as using fixed window --- biogeochem/EDPatchDynamicsMod.F90 | 11 ++--- main/FatesRunningMeanMod.F90 | 78 ++++++++++++++++++------------- 2 files changed, 49 insertions(+), 40 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 9d342cc6a6..d3f5165674 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -580,7 +580,6 @@ subroutine spawn_patches( currentSite, bc_in) endif - ! next create patch to receive secondary forest area if ( site_areadis_secondary .gt. nearzero) then allocate(new_patch_secondary) @@ -1974,6 +1973,9 @@ subroutine create_patch(currentSite, new_patch, age, areap, label) real(r8), intent(in) :: areap ! initial area of this patch in m2. integer, intent(in) :: label ! anthropogenic disturbance label + real(r8), parameter :: temp_init_vegc = 15._r8 ! Until bc's are pointed to by sites + ! give veg temp a default temp. + ! !LOCAL VARIABLES: !--------------------------------------------------------------------- integer :: el ! element loop index @@ -1990,12 +1992,7 @@ subroutine create_patch(currentSite, new_patch, age, areap, label) allocate(new_patch%fragmentation_scaler(currentSite%nlevsoil)) allocate(new_patch%tveg24) - !call new_patch%tveg24%InitRMean(ema_24hr) ! No initial value - - print*,hlm_current_tod,hlm_current_date,hlm_reference_date - stop - - call new_patch%tveg24%InitRMean(fixed_24hr ) + call new_patch%tveg24%InitRMean(fixed_24hr,init_value=temp_init_vegc,init_offset=real(hlm_current_tod,r8) ) ! Litter ! Allocate, Zero Fluxes, and Initialize to "unset" values diff --git a/main/FatesRunningMeanMod.F90 b/main/FatesRunningMeanMod.F90 index 0dc9fe3355..5075417bea 100644 --- a/main/FatesRunningMeanMod.F90 +++ b/main/FatesRunningMeanMod.F90 @@ -79,6 +79,8 @@ module FatesRunningMeanMod end type rmean_type + + logical, parameter :: debug = .true. character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -86,8 +88,8 @@ module FatesRunningMeanMod ! Define the time methods that we want to have available to us - class(rmean_def_type), public, pointer :: ema_24hr - class(rmean_def_type), public, pointer :: fixed_24hr + class(rmean_def_type), public, pointer :: ema_24hr ! Exponential moving average - 24hr window + class(rmean_def_type), public, pointer :: fixed_24hr ! Fixed, 24-hour window contains @@ -101,16 +103,18 @@ subroutine define(this,mem_period,up_period,method) integer,intent(in) :: method ! Check the memory and update periods - if( abs(nint(mem_period/up_period)-mem_period/up_period) > nearzero ) then - write(fates_log(), *) 'While defining a running mean definition' - write(fates_log(), *) 'an update and memory period was specified' - write(fates_log(), *) 'where the update period is not an exact fraction of the period' - write(fates_log(), *) 'mem_period: ',mem_period - write(fates_log(), *) 'up_period: ',up_period - write(fates_log(), *) 'exiting' - call endrun(msg=errMsg(sourcefile, __LINE__)) + if(debug) then + if( abs(nint(mem_period/up_period)-mem_period/up_period) > nearzero ) then + write(fates_log(), *) 'While defining a running mean definition' + write(fates_log(), *) 'an update and memory period was specified' + write(fates_log(), *) 'where the update period is not an exact fraction of the period' + write(fates_log(), *) 'mem_period: ',mem_period + write(fates_log(), *) 'up_period: ',up_period + write(fates_log(), *) 'exiting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if end if - + this%mem_period = mem_period this%up_period = up_period this%method = method @@ -127,18 +131,11 @@ function GetMean(this) real(r8) :: GetMean if(this%def_type%method .eq. moving_ema_window) then - if(this%c_index == 0) then + if(this%c_index == 0 .and. debug) then write(fates_log(), *) 'attempting to get a running mean from a variable' write(fates_log(), *) 'that has not been given a value yet' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - else - if(this%c_index .ne. this%def_type%n_mem)then - write(fates_log(), *) 'attempting to get a mean over a fixed window' - write(fates_log(), *) 'at a time where the window has not completed' - write(fates_log(), *) 'its cycle yet' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if end if GetMean = this%l_mean @@ -165,18 +162,35 @@ subroutine InitRMean(this,rmean_def,init_value,init_offset) this%def_type => rmean_def if(this%def_type%method .eq. fixed_window) then - - if(.not.(present(init_offset).and.present(init_value)) )then - write(fates_log(), *) 'when initializing a temporal mean on a fixed window' - write(fates_log(), *) 'there must be an initial value and a time offset' - write(fates_log(), *) 'specified.' - call endrun(msg=errMsg(sourcefile, __LINE__)) + + if(debug) then + if(.not.(present(init_offset).and.present(init_value)) )then + write(fates_log(), *) 'when initializing a temporal mean on a fixed window' + write(fates_log(), *) 'there must be an initial value and a time offset' + write(fates_log(), *) 'specified.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Check to see if the offset is an even increment of the update frequency + if( abs(real(nint(init_offset/rmean_def%up_period),r8)-(init_offset/rmean_def%up_period)) > nearzero ) then + write(fates_log(), *) 'when initializing a temporal mean on a fixed window' + write(fates_log(), *) 'the time offset must be an inrement of the update frequency' + write(fates_log(), *) 'offset: ',init_offset + write(fates_log(), *) 'up freq: ',rmean_def%up_period + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(init_offset<-nearzero) then + write(fates_log(), *) 'offset must be positive: ',init_offset + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if - - this%c_index = modulo(nint(init_offset/rmean_def%up_period)+1,rmean_def%n_mem) + + this%c_index = modulo(nint(init_offset/rmean_def%up_period),rmean_def%n_mem) this%c_mean = real(this%c_index,r8)/real(rmean_def%n_mem,r8)*init_value this%l_mean = init_value - + elseif(this%def_type%method .eq. moving_ema_window) then if(present(init_value))then @@ -250,18 +264,16 @@ subroutine UpdateRMean(this, new_value) ! average, then zero things out if(this%c_index == this%def_type%n_mem) then - this%c_mean = 0._r8 + this%l_mean = this%c_mean + this%c_mean = 0._r8 this%c_index = 0 + end if this%c_index = this%c_index + 1 wgt = this%def_type%up_period/this%def_type%mem_period this%c_mean = this%c_mean + new_value*wgt - if(this%c_index == this%def_type%n_mem) then - this%l_mean = this%c_mean - end if - end if return From 1d215b8f5d57200554b880ffe391a038d41b41d9 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 17 May 2021 14:36:21 -0700 Subject: [PATCH 287/578] adding sp mode check in create_cohort to avoid setting sai as well --- biogeochem/EDCanopyStructureMod.F90 | 15 ++++++++++++++- biogeochem/EDCohortDynamicsMod.F90 | 6 ++++++ 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index a86c6cc022..b8f12f210f 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1547,10 +1547,12 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) currentPatch%canopy_layer_tlai, currentCohort%treelai , & currentCohort%vcmax25top,4) - if ( debug ) write(fates_log(), *) 'SP mode: sai check: ', saicheck - currentCohort%treesai + if ( debug ) write(fates_log(), *) 'SP mode: sai check: ', saicheck end if + if ( debug ) write(fates_log(), *) 'currentCohort%canopy_layer: ', cl + if ( debug ) write(fates_log(), *) 'currentCohort%pft: ', ft if ( debug ) write(fates_log(), *) 'currentCohort%treesai: ', currentCohort%treesai if ( debug ) write(fates_log(), *) 'currentCohort%treelai: ', currentCohort%treelai @@ -1615,6 +1617,9 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) currentCohort%lai currentPatch%tsai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) + frac_canopy(iv) * & currentCohort%sai + if ( debug ) write(fates_log(), *) 'currentCohort%pft,iv: ', ft,iv + if ( debug ) write(fates_log(), *) 'currentPatch%tlai_profile(1,ft,iv): ', currentPatch%tlai_profile(1,ft,iv) + if ( debug ) write(fates_log(), *) 'currentPatch%tsai_profile(1,ft,iv): ', currentPatch%tsai_profile(1,ft,iv) !snow burial !write(fates_log(), *) 'calc snow' @@ -2008,6 +2013,14 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') + !if(debug) then + ! write(fates_log(),*) 'ifp: ', ifp + ! write(fates_log(),*) 'bc_out(s)%elai_pa(ifp): ', bc_out(s)%elai_pa(ifp) + ! write(fates_log(),*) 'bc_out(s)%tlai_pa(ifp): ', bc_out(s)%tlai_pa(ifp) + ! write(fates_log(),*) 'bc_out(s)%esai_pa(ifp): ', bc_out(s)%esai_pa(ifp) + ! write(fates_log(),*) 'bc_out(s)%tsai_pa(ifp): ', bc_out(s)%tsai_pa(ifp) + !end if + ! Fraction of vegetation free of snow. This is used to flag those ! patches which shall under-go photosynthesis ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index ae9983f356..74b7a32ee7 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -278,9 +278,13 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & new_cohort%n, new_cohort%canopy_layer, & patchptr%canopy_layer_tlai,new_cohort%vcmax25top ) + write(fates_log(),*) 'create_cohort: calling tree_sai' + + if(hlm_use_sp.eq.ifalse)then new_cohort%treesai = tree_sai(new_cohort%pft, new_cohort%dbh, new_cohort%canopy_trim, & new_cohort%c_area, new_cohort%n, new_cohort%canopy_layer, & patchptr%canopy_layer_tlai, new_cohort%treelai,new_cohort%vcmax25top,2 ) + end if new_cohort%lai = new_cohort%treelai * new_cohort%c_area/patchptr%area @@ -1304,6 +1308,8 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, newn, & currentCohort%canopy_layer, currentPatch%canopy_layer_tlai, & currentCohort%vcmax25top) + + write(fates_log(),*) 'fuse_cohort: calling tree_sai' currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & currentCohort%c_area, newn, currentCohort%canopy_layer, & currentPatch%canopy_layer_tlai, currentCohort%treelai,currentCohort%vcmax25top,1 ) From 56f89a4916ad0bf547b16f273ef8c9d233ec51f7 Mon Sep 17 00:00:00 2001 From: Yilin Fang Date: Thu, 20 May 2021 08:29:36 -0700 Subject: [PATCH 288/578] Fix big number error for soil moisture and column water balance issue due to error accumulation. --- biogeophys/FatesHydroWTFMod.F90 | 10 +-- biogeophys/FatesPlantHydraulicsMod.F90 | 120 +++++++++++++++++++------ main/FatesHistoryInterfaceMod.F90 | 2 + main/FatesHydraulicsMemMod.F90 | 3 +- 4 files changed, 103 insertions(+), 32 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 4d09263bff..09e49887bd 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -30,7 +30,7 @@ module FatesHydroWTFMod ! real(r8), parameter :: min_ftc = 0.00001_r8 ! Minimum allowed fraction of total conductance ! The above cause negative organ water content - real(r8), parameter :: min_ftc = 0.00001e1_r8 ! Minimum allowed fraction of total conductance + real(r8), parameter :: min_ftc = 0.00001e2_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" @@ -604,7 +604,7 @@ function ftc_from_psi_vg(this,psi) result(ftc) 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)) + ftc = min(1._r8,max(min_ftc*10.,num/den)) else ftc = 1._r8 @@ -643,7 +643,7 @@ function dftcdpsi_from_psi_vg(this,psi) result(dftcdpsi) ftc = this%ftc_from_psi(psi) - if(ftc<=min_ftc) then + if(ftc<=min_ftc*10.) then dftcdpsi = 0._r8 ! We cap ftc, so derivative is zero else @@ -1687,7 +1687,7 @@ function ftc_from_psi_tfs(this,psi) result(ftc) psi_eff = min(0._r8,psi) - ftc = max(min_ftc,1._r8/(1._r8 + (psi_eff/this%p50)**this%avuln)) + ftc = max(min_ftc*10,1._r8/(1._r8 + (psi_eff/this%p50)**this%avuln)) end function ftc_from_psi_tfs @@ -1709,7 +1709,7 @@ function dftcdpsi_from_psi_tfs(this,psi) result(dftcdpsi) dftcdpsi = 0._r8 else ftc = 1._r8/(1._r8 + (psi/this%p50)**this%avuln) - if(ftc ccohort%co_hydr FT = cCohort%pft + csite_hydr =>currentSite%si_hydr + !csite_hydr%h2oveg_growturn_err = 0.0_r8 associate(pm_node => currentSite%si_hydr%pm_node) ! MAYBE ADD A NAN CATCH? If UpdateSizeDepPlantHydProps() was not called twice prior to the first @@ -1115,7 +1118,6 @@ subroutine UpdateSizeDepPlantHydStates(currentSite,ccohort) ccohort_hydr%errh2o_growturn_troot = denh2o*cCohort%n*AREA_INV*ccohort_hydr%v_troot * & (ccohort_hydr%th_troot-th_troot_uncorr) - csite_hydr =>currentSite%si_hydr csite_hydr%h2oveg_growturn_err = csite_hydr%h2oveg_growturn_err + & sum(ccohort_hydr%errh2o_growturn_ag(:)) + & ccohort_hydr%errh2o_growturn_troot + & @@ -1382,7 +1384,7 @@ subroutine InitHydrSites(sites,bc_in) ! Calculate the number of rhizosphere ! layers used if(aggregate_layers) then - csite_hydr%i_rhiz_t = 7 + csite_hydr%i_rhiz_t = 11 csite_hydr%i_rhiz_b = bc_in(s)%nlevsoil csite_hydr%nlevrhiz = csite_hydr%i_rhiz_b - csite_hydr%i_rhiz_t + 2 !ideally to be read in from the parameter file @@ -1638,6 +1640,7 @@ subroutine UpdateH2OVeg(nsites,sites,bc_out) ! ---------------------------------------------------------------------------------- ! Arguments + use clm_time_manager , only : is_beg_curr_day integer, intent(in) :: nsites type(ed_site_type), intent(inout), target :: sites(nsites) type(bc_out_type), intent(inout) :: bc_out(nsites) @@ -1664,6 +1667,12 @@ subroutine UpdateH2OVeg(nsites,sites,bc_out) csite_hydr => sites(s)%si_hydr csite_hydr%h2oveg = 0.0_r8 + if(is_beg_curr_day() ) then + csite_hydr%h2oveg_dead = 0.0_r8 + csite_hydr%h2oveg_growturn_err = 0._r8 + csite_hydr%h2oveg_pheno_err = 0._r8 + csite_hydr%h2oveg_hydro_err = 0._r8 + endif currentPatch => sites(s)%oldest_patch do while(associated(currentPatch)) currentCohort=>currentPatch%tallest @@ -1692,6 +1701,10 @@ subroutine UpdateH2OVeg(nsites,sites,bc_out) csite_hydr%h2oveg_growturn_err - & csite_hydr%h2oveg_pheno_err-& csite_hydr%h2oveg_hydro_err + print *,'bc_out',s,bc_out(s)%plant_stored_h2o_si +! if(abs(bc_out(s)%plant_stored_h2o_si) > 1e3) & +! print *,'problem grid',csite_hydr%h2oveg,csite_hydr%h2oveg_dead, & +! csite_hydr%h2oveg_growturn_err,csite_hydr%h2oveg_pheno_err,csite_hydr%h2oveg_hydro_err end do @@ -2632,6 +2645,12 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) prev_h2osoil = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & site_hydr%v_shell(:,:)) * denh2o * AREA_INV + !site_hydr%h2oveg = 0._r8 + !site_hydr%h2oveg_dead = 0._r8 + !site_hydr%h2oveg_growturn_err = 0._r8 + !site_hydr%h2oveg_pheno_err = 0._r8 + !site_hydr%h2oveg_hydro_err = 0._r8 + bc_out(s)%qflx_ro_sisl(:) = 0._r8 ! Zero out diagnotsics that rely on accumulation @@ -2759,12 +2778,12 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! ----------------------------------------------------------------------------------- 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) + dth_layershell_col,sites(s)%lat,sites(s)%lon) end if @@ -2917,7 +2936,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) 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__)) +! call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(abs(delta_soil_storage + root_flux + site_runoff) > 1.e-3_r8 ) then @@ -2928,7 +2947,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) 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__)) +! call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -2972,7 +2991,9 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) site_hydr%h2oveg_growturn_err - & site_hydr%h2oveg_pheno_err-& site_hydr%h2oveg_hydro_err - + if(transp_flux > 0 .and. bc_out(s)%plant_stored_h2o_si == 0._r8) then + print *,'zero error-',transp_flux,site_hydr%h2oveg,site_hydr%h2oveg_dead,site_hydr%h2oveg_hydro_err,site_hydr%h2oveg_growturn_err + endif enddo !site return @@ -3328,7 +3349,7 @@ end subroutine OrderLayersForSolve1D subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ordered,kbg_layer, sapflow,rootuptake,& - wb_err_plant,dwat_plant,dth_layershell_col) + wb_err_plant,dwat_plant,dth_layershell_col,lat_tmp,lon_tmp) ! ------------------------------------------------------------------------------- ! Calculate the hydraulic conductances across a list of paths. The list is a 1D vector, and @@ -3426,12 +3447,13 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & integer :: ft ! plant functional type real(r8) :: q_flow ! flow diagnostic [kg] real(r8) :: rootfr ! rooting fraction of this layer (used for diagnostics) + real(r8) :: lat_tmp, lon_tmp !for debugging ! 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 + integer, parameter :: max_iter = 30 ! 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] @@ -3440,6 +3462,8 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & 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 + real(r8) :: ajac(n_hypool_tot,n_hypool_tot) + integer :: info,ipiv(n_hypool_tot) associate(pm_node => site_hydr%pm_node) @@ -3560,8 +3584,9 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & 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) + write(fates_log(),*) 'hydro stability lat/lon: ',lat_tmp,lon_tmp - call endrun(msg=errMsg(sourcefile, __LINE__)) +! call endrun(msg=errMsg(sourcefile, __LINE__)) end if ! If debugging, then lets re-initialize our diagnostics of @@ -3582,7 +3607,7 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & 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. - +! nsteps = 1 dt_substep = dt_step/real(nsteps,r8) ! This is the sub-stem length in seconds ! Walk through sub-steps @@ -3597,6 +3622,8 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! Get matric potential [Mpa] psi_node(i) = wrf_plant(pm_node(i),ft)%p%psi_from_th(th_node(i)) + !cap capillary pressure + psi_node(i) = max(-1e5_r8,psi_node(i)) ! Get total potential [Mpa] h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) @@ -3630,6 +3657,8 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & do i = n_hypool_plant+1,n_hypool_tot psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) + !cap capillary pressure + psi_node(i) = max(-1e5_r8,psi_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)) @@ -3811,8 +3840,27 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! Calculate the change in theta call Hydraulics_Tridiagonal(tris_a, tris_b, tris_c, tris_r, dth_node, tri_ierr) - +#if 0 + ajac(:,:) = 0._r8 + do i=1,n_hypool_tot + if(i==1) then + ajac(i,i) = tris_b(i) + ajac(i,i+1) = tris_c(i) + elseif(i==n_hypool_tot) then + ajac(i,i-1)= tris_a(i) + ajac(i,i) = tris_b(i) + else + ajac(i,i-1)= tris_a(i) + ajac(i,i) = tris_b(i) + ajac(i,i+1) = tris_c(i) + endif + enddo + ipiv = 0 + call DGESV(n_hypool_tot,1,ajac(1:n_hypool_tot,1:n_hypool_tot),n_hypool_tot,ipiv,tris_r,n_hypool_tot,info) + dth_node(1:n_hypool_tot) = tris_r(1:n_hypool_tot) +#endif if(tri_ierr == 1) then +! if(info > 0) then solution_found = .false. error_code = 2 error_arr(:) = 0._r8 @@ -3828,10 +3876,26 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! 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 +#if 0 +if( q_top_eff > 0.0 .and. (w_tot_beg-w_tot_end) == 0._r8) then + print *,'zero dth--',dth_node,'th-',th_node,'wb-',w_tot_beg,w_tot_end + print *,'tris_a',tris_a + print *,'tris_b',tris_b + print *,'tris_c',tris_c + print *,'tris_r',tris_r + stop +endif +#endif 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 + !if(lon_tmp == 120._r8 .and. lat_tmp == -34._r8) then + ! write(fates_log(),*)'Grid with problem -',wb_step_err,q_top_eff,'th-',dth_node(1:5),'w_totb',w_tot_beg,w_tot_end + !endif + !linear solver error cannot be avoided + !if(abs(wb_step_err)>1*max_wb_step_err .or. any(dth_node(:).ne.dth_node(:)) )then + if( any(dth_node(:).ne.dth_node(:)) )then + !if(abs(wb_step_err)>1*max_wb_step_err .or. any(dth_node(:).ne.dth_node(:)) )then + !solution_found = .false. solution_found = .false. error_code = 1 error_arr(:) = 0._r8 @@ -3858,9 +3922,13 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! 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)) + !cap capillary pressure + psi_node(i) = max(-1e5_r8,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)) + !cap capillary pressure + psi_node(i) = max(-1e5_r8,psi_node(i)) end do ! If desired, check and trap pressures that are supersaturated @@ -3933,8 +4001,8 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! ------------------------------------------------------------ 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' + write(fates_log(),*)'EDPlantHydraulics water balance error exceeds threshold of = ', max_wb_err,wb_err_layer + write(fates_log(),*)'transpiration demand: ', dt_step*q_top_eff,' kg/step/plant','dt',dt_step,'iter',iter leaf_water = cohort_hydr%th_ag(1)*cohort_hydr%v_ag(1)*denh2o stem_water = sum(cohort_hydr%th_ag(2:n_hypool_ag) * & @@ -3945,11 +4013,11 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & 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(),*) 'LWP: ',cohort_hydr%psi_ag(1), psi_node(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__)) +! call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -4086,7 +4154,7 @@ subroutine Report1DError(cohort, site_hydr, ilayer, z_node, v_node, & 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(),*) 'layer: ',ilayer, 'dt_step',dt_step 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' @@ -4869,9 +4937,9 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ! reduction factor for soil compartments real(r8), parameter :: rlfx_plnt_init = 1.0 ! Initial Pressure update ! reduction factor for plant comparmtents - real(r8), parameter :: dpsi_scap = 0.2 ! Changes in psi (for soil) larger than this + real(r8), parameter :: dpsi_scap = 0.1 ! Changes in psi (for soil) larger than this ! will be subject to a capping routine - real(r8), parameter :: dpsi_pcap = 0.3 ! Change sin psi (for plants) larger than this + real(r8), parameter :: dpsi_pcap = 0.1 ! Change sin psi (for plants) larger than this ! will be subject to a capping routine real(r8), parameter :: rlfx_plnt_shrink = 1.0 ! Shrink the starting plant relaxtion factor ! by this multipliler each round diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 6b7ef45e16..39c21afb5a 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3920,6 +3920,8 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) end if vwc = bc_in(s)%h2o_liqvol_sl(jsoil) psi = site_hydr%wrf_soil(jrhiz)%p%psi_from_th(vwc) + !cap capillary pressure + psi = max(-1e5_r8,psi) vwc_sat = bc_in(s)%watsat_sl(jsoil) !patch with cohorts if(site_hydr%l_aroot_layer(jrhiz) > 0._r8) then diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 8507f7278d..bb5cc079c9 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -29,7 +29,8 @@ module FatesHydraulicsMemMod integer, parameter, public :: n_hypool_stem = 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 +! integer, parameter, public :: nshell = 5 + integer, parameter, public :: nshell = 1 ! number of aboveground plant water storage nodes integer, parameter, public :: n_hypool_ag = n_hypool_leaf+n_hypool_stem From c31e17d35ab4fa84ba18ddaa89adf1f64bc30cfb Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 21 May 2021 15:26:06 -0700 Subject: [PATCH 289/578] changing pftdiff to only send stdout, not stderr, to /dev/null --- tools/pftdiff | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tools/pftdiff b/tools/pftdiff index 300add459e..a2d7305bb2 100755 --- a/tools/pftdiff +++ b/tools/pftdiff @@ -19,8 +19,8 @@ tempfile4=$(mktemp) toolsdir=$(dirname "$0") -$toolsdir/FatesPFTIndexSwapper.py --pft-indices=$2 --fin=$1 --fout=${tempfile1} &>/dev/null -$toolsdir/FatesPFTIndexSwapper.py --pft-indices=$3 --fin=$1 --fout=${tempfile2} &>/dev/null +$toolsdir/FatesPFTIndexSwapper.py --pft-indices=$2 --fin=$1 --fout=${tempfile1} 1>/dev/null +$toolsdir/FatesPFTIndexSwapper.py --pft-indices=$3 --fin=$1 --fout=${tempfile2} 1>/dev/null ncdump ${tempfile1} >> ${tempfile3} ncdump ${tempfile2} >> ${tempfile4} From 62cbbe7372e2a387cc02bf6ea8fa1fb36a0f94d1 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 24 May 2021 17:00:48 -0700 Subject: [PATCH 290/578] trying Hui's suggested fix per issue 745 --- biogeophys/EDSurfaceAlbedoMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index c59f81b47f..ebc01b1b69 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -133,7 +133,8 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 - bc_out(s)%ftid_parb(ifp,ib)= 1.0_r8 + !bc_out(s)%ftid_parb(ifp,ib)= 1.0_r8 + bc_out(s)%ftid_parb(ifp,ib)= 0.0_r8 bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 enddo From 0f7b6176023ea2d2c6a604922cecb3cdb578bfd6 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 25 May 2021 14:20:43 -0400 Subject: [PATCH 291/578] Reverting bc_in_ptr and bc_out_ptr, because nag. --- biogeochem/EDCanopyStructureMod.F90 | 19 +++++++++-------- biogeochem/EDCohortDynamicsMod.F90 | 13 +++++++----- biogeochem/EDLoggingMortalityMod.F90 | 6 ++++-- biogeochem/EDMortalityFunctionsMod.F90 | 1 - biogeochem/EDPatchDynamicsMod.F90 | 29 ++++++++++++++------------ biogeochem/EDPhysiologyMod.F90 | 8 +++---- biogeochem/FatesSoilBGCFluxMod.F90 | 9 +++----- biogeophys/EDBtranMod.F90 | 2 +- biogeophys/FatesBstressMod.F90 | 2 +- main/EDInitMod.F90 | 3 --- main/EDMainMod.F90 | 10 ++++----- main/EDTypesMod.F90 | 9 -------- 12 files changed, 52 insertions(+), 59 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 622f019b1b..4586939b8d 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -197,7 +197,7 @@ subroutine canopy_structure( currentSite , bc_in ) ! Its possible that before we even enter this scheme ! some cohort numbers are very low. Terminate them. - call terminate_cohorts(currentSite, currentPatch, 1, 12) + call terminate_cohorts(currentSite, currentPatch, 1, 12, bc_in) ! Calculate how many layers we have in this canopy ! This also checks the understory to see if its crown @@ -205,17 +205,17 @@ subroutine canopy_structure( currentSite , bc_in ) z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) do i_lyr = 1,z ! Loop around the currently occupied canopy layers. - call DemoteFromLayer(currentSite, currentPatch, i_lyr) + call DemoteFromLayer(currentSite, currentPatch, i_lyr, bc_in) end do ! After demotions, we may then again have cohorts that are very very ! very sparse, remove them - call terminate_cohorts(currentSite, currentPatch, 1,13) + call terminate_cohorts(currentSite, currentPatch, 1,13,bc_in) call fuse_cohorts(currentSite, currentPatch, bc_in) ! Remove cohorts for various other reasons - call terminate_cohorts(currentSite, currentPatch, 2,13) + call terminate_cohorts(currentSite, currentPatch, 2,13,bc_in) ! --------------------------------------------------------------------------------------- @@ -234,12 +234,12 @@ subroutine canopy_structure( currentSite , bc_in ) end do ! Remove cohorts that are incredibly sparse - call terminate_cohorts(currentSite, currentPatch, 1,14) + call terminate_cohorts(currentSite, currentPatch, 1,14,bc_in) call fuse_cohorts(currentSite, currentPatch, bc_in) ! Remove cohorts for various other reasons - call terminate_cohorts(currentSite, currentPatch, 2,14) + call terminate_cohorts(currentSite, currentPatch, 2,14,bc_in) end if @@ -332,7 +332,7 @@ end subroutine canopy_structure ! ============================================================================================== - subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) + subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) use EDParamsMod, only : ED_val_comp_excln use SFParamsMod, only : SF_val_CWD_frac @@ -341,7 +341,8 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type), intent(inout), target :: currentPatch integer, intent(in) :: i_lyr ! Current canopy layer of interest - + type(bc_in_type), intent(in) :: bc_in + ! !LOCAL VARIABLES: type(ed_cohort_type), pointer :: currentCohort type(ed_cohort_type), pointer :: copyc @@ -720,7 +721,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) ! put the litter from the terminated cohorts ! straight into the fragmenting pools call SendCohortToLitter(currentSite,currentPatch, & - currentCohort,currentCohort%n) + currentCohort,currentCohort%n,bc_in) currentCohort%n = 0.0_r8 currentCohort%c_area = 0.0_r8 diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 331492956b..b6714ee3e9 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -695,7 +695,7 @@ subroutine zero_cohort(cc_p) end subroutine zero_cohort !-------------------------------------------------------------------------------------! - subroutine terminate_cohorts( currentSite, currentPatch, level , call_index) + subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_in) ! ! !DESCRIPTION: ! terminates cohorts when they get too small @@ -708,6 +708,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index) type (ed_patch_type), intent(inout), target :: currentPatch integer , intent(in) :: level integer :: call_index + type(bc_in_type), intent(in) :: bc_in ! Important point regarding termination levels. Termination is typically ! called after fusion. We do this so that we can re-capture the biomass that would @@ -824,7 +825,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index) if (currentCohort%n.gt.0.0_r8) then call SendCohortToLitter(currentSite,currentPatch, & - currentCohort,currentCohort%n) + currentCohort,currentCohort%n,bc_in) end if ! Set pointers and remove the current cohort from the list @@ -858,7 +859,7 @@ end subroutine terminate_cohorts ! ===================================================================================== - subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant) + subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) ! ----------------------------------------------------------------------------------- ! This routine transfers the existing mass in all pools and all elements @@ -881,7 +882,9 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant) type (ed_patch_type) , target :: cpatch type (ed_cohort_type) , target :: ccohort real(r8) :: nplant ! Number (absolute) - ! of plants to transfer + ! of plants to transfer + type(bc_in_type), intent(in) :: bc_in + type(litter_type), pointer :: litt ! Litter object for each element type(site_fluxdiags_type),pointer :: flux_diags @@ -906,7 +909,7 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant) plant_dens = nplant/cpatch%area call set_root_fraction(csite%rootfrac_scr, pft, csite%zi_soil, & - csite%bc_in_ptr%max_rooting_depth_index_col) + bc_in%max_rooting_depth_index_col) do el=1,num_elements diff --git a/biogeochem/EDLoggingMortalityMod.F90 b/biogeochem/EDLoggingMortalityMod.F90 index 7eba00af32..f1f23d9f33 100644 --- a/biogeochem/EDLoggingMortalityMod.F90 +++ b/biogeochem/EDLoggingMortalityMod.F90 @@ -40,6 +40,7 @@ module EDLoggingMortalityMod use EDParamsMod , only : logging_mechanical_frac use EDParamsMod , only : logging_coll_under_frac use EDParamsMod , only : logging_dbhmax_infra + use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_current_year use FatesInterfaceTypesMod , only : hlm_current_month use FatesInterfaceTypesMod , only : hlm_current_day @@ -394,7 +395,7 @@ end subroutine get_harvest_rate_area ! ============================================================================ - subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site_areadis) + subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site_areadis, bc_in) ! ------------------------------------------------------------------------------------------- ! @@ -440,6 +441,7 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site type(ed_patch_type) , intent(inout), target :: currentPatch type(ed_patch_type) , intent(inout), target :: newPatch real(r8) , intent(in) :: patch_site_areadis + type(bc_in_type) , intent(in) :: bc_in !LOCAL VARIABLES: @@ -570,7 +572,7 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site call set_root_fraction(currentSite%rootfrac_scr, pft, & currentSite%zi_soil, & - currentSite%bc_in_ptr%max_rooting_depth_index_col) + bc_in%max_rooting_depth_index_col) ag_wood = (direct_dead+indirect_dead) * (struct_m + sapw_m ) * & prt_params%allom_agb_frac(currentCohort%pft) diff --git a/biogeochem/EDMortalityFunctionsMod.F90 b/biogeochem/EDMortalityFunctionsMod.F90 index fa0b933fc5..6eb5ec3097 100644 --- a/biogeochem/EDMortalityFunctionsMod.F90 +++ b/biogeochem/EDMortalityFunctionsMod.F90 @@ -19,7 +19,6 @@ module EDMortalityFunctionsMod use FatesInterfaceTypesMod , only : hlm_use_planthydro use EDLoggingMortalityMod , only : LoggingMortality_frac use EDParamsMod , only : fates_mortality_disturbance_fraction - use FatesInterfaceTypesMod , only : bc_in_type use PRTGenericMod, only : all_carbon_elements use PRTGenericMod, only : store_organ diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 3ba89a538b..60716b23dd 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -661,13 +661,13 @@ subroutine spawn_patches( currentSite, bc_in) if(currentPatch%disturbance_mode .eq. dtype_ilog) then call logging_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis) + new_patch, patch_site_areadis,bc_in) elseif(currentPatch%disturbance_mode .eq. dtype_ifire) then call fire_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis) + new_patch, patch_site_areadis,bc_in) else call mortality_litter_fluxes(currentSite, currentPatch, & - new_patch, patch_site_areadis) + new_patch, patch_site_areadis,bc_in) endif ! -------------------------------------------------------------------------- @@ -1083,9 +1083,9 @@ subroutine spawn_patches( currentSite, bc_in) ! the first call to terminate cohorts removes sparse number densities, ! the second call removes for all other reasons (sparse culling must happen ! before fusion) - call terminate_cohorts(currentSite, currentPatch, 1,16) + call terminate_cohorts(currentSite, currentPatch, 1,16,bc_in) call fuse_cohorts(currentSite,currentPatch, bc_in) - call terminate_cohorts(currentSite, currentPatch, 2,16) + call terminate_cohorts(currentSite, currentPatch, 2,16,bc_in) call sort_cohorts(currentPatch) end if ! if ( new_patch%area > nearzero ) then @@ -1157,16 +1157,16 @@ subroutine spawn_patches( currentSite, bc_in) ! before fusion) if ( site_areadis_primary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_primary, 1,17) + call terminate_cohorts(currentSite, new_patch_primary, 1,17, bc_in) call fuse_cohorts(currentSite,new_patch_primary, bc_in) - call terminate_cohorts(currentSite, new_patch_primary, 2,17) + call terminate_cohorts(currentSite, new_patch_primary, 2,17, bc_in) call sort_cohorts(new_patch_primary) endif if ( site_areadis_secondary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_secondary, 1,18) + call terminate_cohorts(currentSite, new_patch_secondary, 1,18,bc_in) call fuse_cohorts(currentSite,new_patch_secondary, bc_in) - call terminate_cohorts(currentSite, new_patch_secondary, 2,18) + call terminate_cohorts(currentSite, new_patch_secondary, 2,18,bc_in) call sort_cohorts(new_patch_secondary) endif @@ -1526,7 +1526,7 @@ end subroutine TransLitterNewPatch ! ============================================================================ subroutine fire_litter_fluxes(currentSite, currentPatch, & - newPatch, patch_site_areadis) + newPatch, patch_site_areadis, bc_in) ! ! !DESCRIPTION: ! CWD pool burned by a fire. @@ -1545,6 +1545,8 @@ subroutine fire_litter_fluxes(currentSite, currentPatch, & type(ed_patch_type) , intent(inout), target :: currentPatch ! Donor Patch type(ed_patch_type) , intent(inout), target :: newPatch ! New Patch real(r8) , intent(in) :: patch_site_areadis ! Area being donated + type(bc_in_type) , intent(in) :: bc_in + ! ! !LOCAL VARIABLES: @@ -1674,7 +1676,7 @@ subroutine fire_litter_fluxes(currentSite, currentPatch, & site_mass%burn_flux_to_atm = site_mass%burn_flux_to_atm + burned_mass call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil, & - currentSite%bc_in_ptr%max_rooting_depth_index_col) + bc_in%max_rooting_depth_index_col) ! Contribution of dead trees to root litter (no root burn flux to atm) do dcmpy=1,ndcmpy @@ -1747,7 +1749,7 @@ end subroutine fire_litter_fluxes ! ============================================================================ subroutine mortality_litter_fluxes(currentSite, currentPatch, & - newPatch, patch_site_areadis) + newPatch, patch_site_areadis,bc_in) ! ! !DESCRIPTION: ! Carbon going from mortality associated with disturbance into CWD pools. @@ -1769,6 +1771,7 @@ subroutine mortality_litter_fluxes(currentSite, currentPatch, & type(ed_patch_type) , intent(inout), target :: currentPatch type(ed_patch_type) , intent(inout), target :: newPatch real(r8) , intent(in) :: patch_site_areadis + type(bc_in_type) , intent(in) :: bc_in ! ! !LOCAL VARIABLES: type(ed_cohort_type), pointer :: currentCohort @@ -1884,7 +1887,7 @@ subroutine mortality_litter_fluxes(currentSite, currentPatch, & bg_wood = num_dead * (struct_m + sapw_m) * (1.0_r8-prt_params%allom_agb_frac(pft)) call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil, & - currentSite%bc_in_ptr%max_rooting_depth_index_col) + bc_in%max_rooting_depth_index_col) do c=1,ncwd diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 0f1faf253e..066d6271c7 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -236,7 +236,7 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! Send fluxes from newly created litter into the litter pools ! This litter flux is from non-disturbance inducing mortality, as well ! as litter fluxes from live trees - call CWDInput(currentSite, currentPatch, litt) + call CWDInput(currentSite, currentPatch, litt,bc_in) ! Only calculate fragmentation flux over layers that are active @@ -1876,7 +1876,7 @@ end subroutine recruitment ! ============================================================================ - subroutine CWDInput( currentSite, currentPatch, litt) + subroutine CWDInput( currentSite, currentPatch, litt, bc_in) ! ! !DESCRIPTION: @@ -1894,7 +1894,7 @@ subroutine CWDInput( currentSite, currentPatch, litt) type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type),intent(inout), target :: currentPatch type(litter_type),intent(inout),target :: litt - + type(bc_in_type),intent(in) :: bc_in ! ! !LOCAL VARIABLES: @@ -1954,7 +1954,7 @@ subroutine CWDInput( currentSite, currentPatch, litt) pft = currentCohort%pft call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil, & - currentSite%bc_in_ptr%max_rooting_depth_index_col) + bc_in%max_rooting_depth_index_col) leaf_m_turnover = currentCohort%prt%GetTurnover(leaf_organ,element_id) store_m_turnover = currentCohort%prt%GetTurnover(store_organ,element_id) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 9cc9f4398f..a8d535e114 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -417,7 +417,7 @@ end subroutine UnPackNutrientAquisitionBCs ! ===================================================================================== - subroutine PrepCH4BCs(csite) + subroutine PrepCH4BCs(csite,bc_in,bc_out) ! ! This routine prepares the output boundary conditions for methane calculations @@ -428,8 +428,8 @@ subroutine PrepCH4BCs(csite) ! !ARGUMENTS type(ed_site_type), intent(inout) :: csite - type(bc_out_type), pointer :: bc_out - type(bc_in_type), pointer :: bc_in + type(bc_out_type), intent(inout) :: bc_out + type(bc_in_type), intent(in) :: bc_in type(ed_patch_type), pointer :: cpatch ! current patch pointer type(ed_cohort_type), pointer :: ccohort ! current cohort pointer integer :: pft ! plant functional type @@ -449,9 +449,6 @@ subroutine PrepCH4BCs(csite) ! Exit if we need not communicate with the hlm's ch4 module if(.not.(hlm_use_ch4==itrue)) return - bc_out => csite%bc_out_ptr - bc_in => csite%bc_in_ptr - ! Initialize to zero bc_out%annavg_agnpp_pa(:) = 0._r8 bc_out%annavg_bgnpp_pa(:) = 0._r8 diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index 6826a0dd95..5d949ea9ef 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -140,7 +140,7 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) do ft = 1,numpft call set_root_fraction(sites(s)%rootfrac_scr, ft, sites(s)%zi_soil, & - sites(s)%bc_in_ptr%max_rooting_depth_index_col ) + bc_in(s)%max_rooting_depth_index_col ) cpatch%btran_ft(ft) = 0.0_r8 do j = 1,bc_in(s)%nlevsoil diff --git a/biogeophys/FatesBstressMod.F90 b/biogeophys/FatesBstressMod.F90 index 4c991bd97c..c56b4930f5 100644 --- a/biogeophys/FatesBstressMod.F90 +++ b/biogeophys/FatesBstressMod.F90 @@ -68,7 +68,7 @@ subroutine btran_sal_stress_fates( nsites, sites, bc_in) call set_root_fraction(sites(s)%rootfrac_scr, ft, & sites(s)%zi_soil, & - sites(s)%bc_in_ptr%max_rooting_depth_index_col ) + bc_in(s)%max_rooting_depth_index_col ) do j = 1,bc_in(s)%nlevsoil diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index b26663eefb..9c3059312d 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -145,9 +145,6 @@ subroutine init_site_vars( site_in, bc_in, bc_out ) site_in%dz_soil(:) = bc_in%dz_sisl(:) site_in%z_soil(:) = bc_in%z_sisl(:) - site_in%bc_in_ptr => bc_in - site_in%bc_out_ptr => bc_out - ! end subroutine init_site_vars diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 6b3cc6b71b..4cbeedacdf 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -238,13 +238,13 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) call sort_cohorts(currentPatch) ! kills cohorts that are too few - call terminate_cohorts(currentSite, currentPatch, 1, 10 ) + call terminate_cohorts(currentSite, currentPatch, 1, 10, bc_in ) ! fuses similar cohorts call fuse_cohorts(currentSite,currentPatch, bc_in ) ! kills cohorts for various other reasons - call terminate_cohorts(currentSite, currentPatch, 2, 10 ) + call terminate_cohorts(currentSite, currentPatch, 2, 10, bc_in ) currentPatch => currentPatch%younger @@ -667,8 +667,8 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) ! Is termination really needed here? ! Canopy_structure just called it several times! (rgk) - call terminate_cohorts(currentSite, currentPatch, 1, 11) - call terminate_cohorts(currentSite, currentPatch, 2, 11) + call terminate_cohorts(currentSite, currentPatch, 1, 11, bc_in) + call terminate_cohorts(currentSite, currentPatch, 2, 11, bc_in) ! This cohort count is used in the photosynthesis loop call count_cohorts(currentPatch) @@ -683,7 +683,7 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) ! The HLM methane module needs information about ! rooting mass, distributions, respiration rates and NPP - call PrepCH4BCs(currentSite) + call PrepCH4BCs(currentSite,bc_in,bc_out) ! FIX(RF,032414). This needs to be monthly, not annual diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 3548e3a61d..5da7babc54 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -684,15 +684,6 @@ module EDTypesMod ! position in history output fields !integer :: clump_id - ! This is the pointer to the input boundary condition structure, ie information that is - ! derived purerly from the HLM - type(bc_in_type), pointer :: bc_in_ptr - - ! This is the pointer to the output boundary condition structure, ie information that is - ! derived purerly from the HLM - type(bc_out_type), pointer :: bc_out_ptr - - ! Global index of this site in the history output file integer :: h_gid From f34015d56137698f55f9e7dd7f1fbd66838615fa Mon Sep 17 00:00:00 2001 From: Yilin Fang Date: Wed, 26 May 2021 00:16:29 -0700 Subject: [PATCH 292/578] Fix column water mass balance error. --- biogeophys/FatesPlantHydraulicsMod.F90 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 8242ff4662..a4a5dabecf 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -2633,7 +2633,10 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) do s = 1, nsites site_hydr => sites(s)%si_hydr - if( sum(site_hydr%l_aroot_layer) == 0._r8 ) cycle + if( sum(site_hydr%l_aroot_layer) == 0._r8 ) then + bc_out(s)%qflx_soil2root_sisl(:) = 0._r8 + cycle + end if nlevrhiz = site_hydr%nlevrhiz From e7d54ed64439f9fdb94aab96dd7f089b651183ec Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 28 May 2021 10:07:28 -0600 Subject: [PATCH 293/578] starting to mess with the code --- main/EDTypesMod.F90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 5da7babc54..12c4aba528 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -36,7 +36,6 @@ module EDTypesMod ! to understory layers (all layers that ! are not the top canopy layer) - integer, parameter, public :: nlevleaf = 30 ! number of leaf layers in canopy layer integer, parameter, public :: maxpft = 16 ! maximum number of PFTs allowed ! the parameter file may determine that fewer ! are used, but this helps allocate scratch @@ -58,6 +57,13 @@ module EDTypesMod integer, parameter, public :: idirect = 1 ! This is the array index for direct radiation integer, parameter, public :: idiffuse = 2 ! This is the array index for diffuse radiation + ! parameters that govern the VAI (LAI+SAI) bins used in radiative transfer code + integer, parameter, public :: nlevleaf = 30 ! number of leaf+stem layers in canopy layer + real(r8), parameter, public :: top_vai_bin_width = 0.25 ! width in VAI units of uppermost canopy scattering element + real(r8), parameter, public :: vai_width_increase_factor = 1.3 ! factor by which each bin increases in VAI binning + real(r8), public :: dinc_vai(nlevleaf) ! width of VAI bins + real(r8), public :: dlevedges_vai(0:nlevleaf) ! edges of VAI bins, element 0 is the top edge of the canopy + ! TODO: we use this cp_maxSWb only because we have a static array q(size=2) of ! land-ice abledo for vis and nir. This should be a parameter, which would @@ -123,8 +129,6 @@ module EDTypesMod ! BIOLOGY/BIOGEOCHEMISTRY integer , parameter, public :: num_vegtemp_mem = 10 ! Window of time over which we track temp for cold sensecence (days) - real(r8), parameter, public :: dinc_ed = 1.0_r8 ! size of VAI bins (LAI+SAI) [CHANGE THIS NAME WITH NEXT INTERFACE - ! UPDATE] integer , parameter, public :: N_DIST_TYPES = 3 ! Disturbance Modes 1) tree-fall, 2) fire, 3) logging integer , parameter, public :: dtype_ifall = 1 ! index for naturally occuring tree-fall generated event integer , parameter, public :: dtype_ifire = 2 ! index for fire generated disturbance event From 914aaeb6becad31e6f4f6b0b2d7719cc5ab62d98 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 28 May 2021 11:06:34 -0600 Subject: [PATCH 294/578] first attempt to have exponential leaf layering system --- biogeochem/EDCanopyStructureMod.F90 | 14 ++++++-------- biogeochem/EDPhysiologyMod.F90 | 11 ++++++----- biogeochem/FatesAllometryMod.F90 | 7 ++++--- biogeophys/FatesPlantRespPhotosynthMod.F90 | 13 ++++++++----- main/EDTypesMod.F90 | 8 +++++--- 5 files changed, 29 insertions(+), 24 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 6aee6de8de..fb77839f6c 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1448,7 +1448,7 @@ subroutine leaf_area_profile( currentSite ) ! !USES: - use EDtypesMod , only : area, dinc_ed, hitemax, n_hite_bins + use EDtypesMod , only : area, dinc_vai, dlower_vai, hitemax, n_hite_bins ! ! !ARGUMENTS @@ -1480,8 +1480,6 @@ subroutine leaf_area_profile( currentSite ) !---------------------------------------------------------------------- - - smooth_leaf_distribution = 0 ! Here we are trying to generate a profile of leaf area, indexed by 'z' and by pft @@ -1542,7 +1540,7 @@ subroutine leaf_area_profile( currentSite ) currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area ! Number of actual vegetation layers in this cohort's crown - currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) + currentCohort%nv = count((currentCohort%treelai+currentCohort%treesai) .gt. dlower_vai(:)) + 1 currentPatch%ncan(cl,ft) = max(currentPatch%ncan(cl,ft),currentCohort%NV) @@ -1711,15 +1709,15 @@ subroutine leaf_area_profile( currentSite ) if(iv==currentCohort%NV) then remainder = (currentCohort%treelai + currentCohort%treesai) - & - (dinc_ed*real(currentCohort%nv-1,r8)) - if(remainder > dinc_ed )then + (dlower_vai(iv) - dinc_vai(iv)) + if(remainder > dinc_vai(iv) )then write(fates_log(), *)'ED: issue with remainder', & - currentCohort%treelai,currentCohort%treesai,dinc_ed, & + currentCohort%treelai,currentCohort%treesai,dinc_vai(iv), & currentCohort%NV,remainder call endrun(msg=errMsg(sourcefile, __LINE__)) endif else - remainder = dinc_ed + remainder = dinc_vai(iv) end if currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) + & diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index fe184dd343..183e79b82f 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -34,7 +34,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, area_inv + use EDTypesMod , only : dl_sf, dinc_vai, dlower_vai, area_inv use FatesLitterMod , only : ncwd use FatesLitterMod , only : ndcmpy use FatesLitterMod , only : ilabile @@ -385,7 +385,7 @@ subroutine trim_canopy( currentSite ) real(r8) :: sapw_c ! sapwood carbon [kg] real(r8) :: store_c ! storage carbon [kg] real(r8) :: struct_c ! structure carbon [kg] - real(r8) :: leaf_inc ! LAI-only portion of the vegetation increment of dinc_ed + real(r8) :: leaf_inc ! LAI-only portion of the vegetation increment of dinc_vai real(r8) :: lai_canopy_above ! the LAI in the canopy layers above the layer of interest real(r8) :: lai_layers_above ! the LAI in the leaf layers, within the current canopy, ! above the leaf layer of interest @@ -469,7 +469,7 @@ subroutine trim_canopy( currentSite ) currentPatch%canopy_layer_tlai, currentCohort%treelai, & currentCohort%vcmax25top,0 ) - currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) + currentCohort%nv = count((currentCohort%treelai+currentCohort%treesai) .gt. dlower_vai(:)) + 1 if (currentCohort%nv > nlevleaf)then write(fates_log(),*) 'nv > nlevleaf',currentCohort%nv, & @@ -501,11 +501,12 @@ subroutine trim_canopy( currentSite ) ! Calculate the cumulative total vegetation area index (no snow occlusion, stems and leaves) - leaf_inc = dinc_ed * & + leaf_inc = dinc_vai(z) * & currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) ! Now calculate the cumulative top-down lai of the current layer's midpoint within the current cohort - lai_layers_above = leaf_inc * (z-1) + lai_layers_above = (dlower_vai(z) - dinc_vai(z)) * & + currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) lai_current = min(leaf_inc, currentCohort%treelai - lai_layers_above) cumulative_lai_cohort = lai_layers_above + 0.5*lai_current diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index 8e27faae22..a8f0348034 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -95,7 +95,7 @@ module FatesAllometryMod use shr_log_mod , only : errMsg => shr_log_errMsg use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun - use EDTypesMod , only : nlevleaf, dinc_ed + use EDTypesMod , only : nlevleaf, dinc_vai use EDTypesMod , only : nclmax @@ -730,7 +730,7 @@ real(r8) function tree_sai( pft, dbh, canopy_trim, c_area, nplant, cl, & tree_sai = prt_params%allom_sai_scaler(pft) * target_lai - if( (treelai + tree_sai) > (nlevleaf*dinc_ed) )then + if( (treelai + tree_sai) > (sum(dinc_vai)) )then call h_allom(dbh,pft,h) @@ -739,7 +739,8 @@ real(r8) function tree_sai( pft, dbh, canopy_trim, c_area, nplant, cl, & write(fates_log(),*) 'sai: ',tree_sai write(fates_log(),*) 'target_lai: ',target_lai write(fates_log(),*) 'lai+sai: ',treelai+tree_sai - write(fates_log(),*) 'nlevleaf,dinc_ed,nlevleaf*dinc_ed :',nlevleaf,dinc_ed,nlevleaf*dinc_ed + write(fates_log(),*) 'dinc_vai:',dinc_vai + write(fates_log(),*) 'nlevleaf,sum(dinc_vai):',nlevleaf,sum(dinc_vai) write(fates_log(),*) 'pft: ',pft write(fates_log(),*) 'call id: ',call_id write(fates_log(),*) 'n: ',nplant diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 8b919f52c1..46fe6f30ec 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -96,7 +96,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use EDTypesMod , only : ed_cohort_type use EDTypesMod , only : ed_site_type use EDTypesMod , only : maxpft - use EDTypesMod , only : dinc_ed + use EDTypesMod , only : dinc_vai + use EDTypesMod , only : dlower_vai use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : bc_out_type use EDCanopyStructureMod, only : calc_areaindex @@ -208,7 +209,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: lnc_top ! Leaf nitrogen content per unit area at canopy top [gN/m2] real(r8) :: lmr25top ! canopy top leaf maint resp rate at 25C ! for this plant or pft (umol CO2/m**2/s) - real(r8) :: leaf_inc ! LAI-only portion of the vegetation increment of dinc_ed + real(r8) :: leaf_inc ! LAI-only portion of the vegetation increment of dinc_vai real(r8) :: lai_canopy_above ! the LAI in the canopy layers above the layer of interest real(r8) :: lai_layers_above ! the LAI in the leaf layers, within the current canopy, ! above the leaf layer of interest @@ -402,15 +403,17 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentCohort%co_hydr%btran ) btran_eff = currentCohort%co_hydr%btran - ! dinc_ed is the total vegetation area index of each "leaf" layer + ! dinc_vai(:) is the total vegetation area index of each "leaf" layer ! we convert to the leaf only portion of the increment ! ------------------------------------------------------ - leaf_inc = dinc_ed * & + leaf_inc = dinc_vai(iv) * & currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) ! Now calculate the cumulative top-down lai of the current layer's midpoint lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) - lai_layers_above = leaf_inc * (iv-1) + + lai_layers_above = (dlower_vai(iv) - dinc_vai(iv)) * & + currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) lai_current = min(leaf_inc, currentCohort%treelai - lai_layers_above) cumulative_lai = lai_canopy_above + lai_layers_above + 0.5*lai_current diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 12c4aba528..4699b1d7d5 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -61,9 +61,11 @@ module EDTypesMod integer, parameter, public :: nlevleaf = 30 ! number of leaf+stem layers in canopy layer real(r8), parameter, public :: top_vai_bin_width = 0.25 ! width in VAI units of uppermost canopy scattering element real(r8), parameter, public :: vai_width_increase_factor = 1.3 ! factor by which each bin increases in VAI binning - real(r8), public :: dinc_vai(nlevleaf) ! width of VAI bins - real(r8), public :: dlevedges_vai(0:nlevleaf) ! edges of VAI bins, element 0 is the top edge of the canopy - + integer :: i ! iterator used to define bin widths + real(r8), parameter, public :: dinc_vai(nlevleaf) = & + top_vai_bin_width * vai_width_increase_factor ** (/(i, i=0,nlevleaf-1,1)/) ! VAI bin widths array + real(r8), parameter, public :: dlower_vai(nlevleaf) = & + (/(sum(dinc_vai(1:i)), i=1,nlevleaf,1)/) ! lower edge of VAI bins ! TODO: we use this cp_maxSWb only because we have a static array q(size=2) of ! land-ice abledo for vis and nir. This should be a parameter, which would From e71ae9856e224d5ba70932d84eee6746064028d8 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 28 May 2021 11:13:09 -0600 Subject: [PATCH 295/578] updated bin spacing and specified precision --- main/EDTypesMod.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 4699b1d7d5..5a01c72c7b 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -58,14 +58,14 @@ module EDTypesMod integer, parameter, public :: idiffuse = 2 ! This is the array index for diffuse radiation ! parameters that govern the VAI (LAI+SAI) bins used in radiative transfer code - integer, parameter, public :: nlevleaf = 30 ! number of leaf+stem layers in canopy layer - real(r8), parameter, public :: top_vai_bin_width = 0.25 ! width in VAI units of uppermost canopy scattering element - real(r8), parameter, public :: vai_width_increase_factor = 1.3 ! factor by which each bin increases in VAI binning + integer, parameter, public :: nlevleaf = 15 ! number of leaf+stem layers in canopy layer + real(r8), parameter, public :: top_vai_bin_width = 0.25_r8 ! width in VAI units of uppermost canopy scattering element + real(r8), parameter, public :: vai_width_increase_factor = 1.3_r8 ! factor by which each bin increases in VAI binning integer :: i ! iterator used to define bin widths real(r8), parameter, public :: dinc_vai(nlevleaf) = & - top_vai_bin_width * vai_width_increase_factor ** (/(i, i=0,nlevleaf-1,1)/) ! VAI bin widths array + top_vai_bin_width * vai_width_increase_factor ** (/(real(i,r8), i=0,nlevleaf-1,1)/) ! VAI bin widths array real(r8), parameter, public :: dlower_vai(nlevleaf) = & - (/(sum(dinc_vai(1:i)), i=1,nlevleaf,1)/) ! lower edge of VAI bins + (/(sum(dinc_vai(1:i)), i=1,nlevleaf,1)/) ! lower edges of VAI bins ! TODO: we use this cp_maxSWb only because we have a static array q(size=2) of ! land-ice abledo for vis and nir. This should be a parameter, which would From 227ded749c966e005b78107d932f8e4b5426867b Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 1 Jun 2021 03:20:46 -0600 Subject: [PATCH 296/578] sai bug changes first pass --- biogeophys/EDSurfaceAlbedoMod.F90 | 66 +++++++++++++++++++------------ 1 file changed, 41 insertions(+), 25 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 4e5309ea61..cfd0b3d7fc 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -215,7 +215,14 @@ subroutine PatchNormanRadiation (currentPatch, & real(r8) :: Dif_dn(nclmax,maxpft,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) real(r8) :: Dif_up(nclmax,maxpft,nlevleaf) ! Upward diffuse flux above canopy layer J (W/m**2 ground area) real(r8) :: lai_change(nclmax,maxpft,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) - real(r8) :: f_not_abs(maxpft,maxSWb) ! Fraction reflected + transmitted. 1-absorbtion. + + real(r8) :: total_lai_sai(nclmax,maxpft,nlevleaf) ! Total intercepting surfaces in canopy layer. m2 + real(r8) :: frac_lai(nclmax,maxpft,nlevleaf) ! Fraction of lai in each layer + real(r8) :: frac_sai(nclmax,maxpft,nlevleaf) ! Fraction of sai in each layer + real(r8) :: f_abs(nclmax,maxpft,nlevleaf,maxSWb) ! Fraction of light absorbed by surfaces. + real(r8) :: rho_layer(nclmax,maxpft,nlevleaf,maxSWb)! Weighted verage reflectance of layer + real(r8) :: tau_layer(nclmax,maxpft,nlevleaf,maxSWb)! Weighted average transmittance of layer + real(r8) :: Abs_dir_z(maxpft,nlevleaf) real(r8) :: Abs_dif_z(maxpft,nlevleaf) real(r8) :: abs_rad(maxSWb) !radiation absorbed by soil @@ -290,7 +297,16 @@ subroutine PatchNormanRadiation (currentPatch, & do iv = 1, currentPatch%nrad(L,ft) if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then currentPatch%canopy_mask(L,ft) = 1 - !I think 'present' is only used here... + total_lai_sai(L,ft,iv) = currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) + frac_lai(L,ft,iv) = currentPatch%elai_profile(L,ft,iv)/total_lai_sai(L,ft,iv) + frac_sai(L,ft,iv) = currentPatch%esai_profile(L,ft,iv)/total_lai_sai(L,ft,iv) + ! layer level reflectance qualities + do ib = 1,hlm_numSWb !vis, nir + f_abs(L,ft,iv,ib) = 1.0_r8 - (frac_lai(L,ft,iv)*(rhol(ft,ib) + taul(ft,ib))+& + frac_sai(L,ft,iv)*(rhos(ft,ib) + taus(ft,ib))) + rho_layer(L,ft,iv,ib)=frac_lai(L,ft,iv)*rhol(ft,ib)+frac_sai(L,ft,iv)*rhos(ft,ib) + tau_layer(L,ft,iv,ib)=frac_lai(L,ft,iv)*taul(ft,ib)+frac_sai(L,ft,iv)*taus(ft,ib) + end do !ib endif end do !iv end do !ft @@ -363,7 +379,7 @@ subroutine PatchNormanRadiation (currentPatch, & gdir = phi1b(ft) + phi2b(ft) * sin(angle) tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-clumping_index(ft) * & gdir / sin(angle) * & - (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))) * & + total_lai_sai(L,ft,iv)) * & sin(angle)*cos(angle) end do @@ -384,8 +400,8 @@ subroutine PatchNormanRadiation (currentPatch, & endif laisum = 0.00_r8 !total direct beam getting to the bottom of the top canopy. - do iv = 1,currentPatch%nrad(L,ft) - laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) + do iv = 1,currentPatch%nrad(L,ft) + laisum = laisum + total_lai_sai(L,ft,iv) lai_change(L,ft,iv) = 0.0_r8 if (( ftweight(L,ft,iv+1) > 0.0_r8 ) .and. ( ftweight(L,ft,iv+1) < ftweight(L,ft,iv) ))then !where there is a partly empty leaf layer, some fluxes go straight through. @@ -440,9 +456,9 @@ subroutine PatchNormanRadiation (currentPatch, & ! Now use cumulative lai at center of layer. ! Same as tr_dir_z calcualtions, but in the middle of the layer? FIX(RF,032414)-WHY? if (iv == 1) then - laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) + laisum = 0.5_r8 * total_lai_sai(L,ft,iv) else - laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) + laisum = laisum + total_lai_sai(L,ft,iv) end if @@ -498,15 +514,13 @@ subroutine PatchNormanRadiation (currentPatch, & ! Leaf scattering coefficient and terms do diffuse radiation reflected ! and transmitted by a layer !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - f_not_abs(ft,ib) = rhol(ft,ib) + taul(ft,ib) !leaf level fraction NOT absorbed. - !tr_dif_z is a term that uses the LAI in each layer, whereas rhol and taul do not, - !because they are properties of leaf surfaces and not of the leaf matrix. + do iv = 1,currentPatch%nrad(L,ft) !How much diffuse light is intercepted and then reflected? - refl_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * rhol(ft,ib) + refl_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * rho_layer(L,ft,iv,ib) !How much diffuse light in this layer is transmitted? tran_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * & - taul(ft,ib) + tr_dif_z(L,ft,iv) + tau_layer(L,ft,iv,ib) + tr_dif_z(L,ft,iv) end do !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! @@ -672,12 +686,17 @@ subroutine PatchNormanRadiation (currentPatch, & down_rad = 0._r8 do iv = 1, currentPatch%nrad(L,ft) - - down_rad = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) + & - Dif_up(L,ft,iv+1) * refl_dif(L,ft,iv,ib) + & - forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - & - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & - currentPatch%esai_profile(L,ft,iv)))) * taul(ft,ib) + ! down rad'n is the sum of the down and upwards reflected diffuse fluxes... + down_rad = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) + & + Dif_up(L,ft,iv+1) * refl_dif(L,ft,iv,ib) + + !... plus the direct beam intercepted and intransmitted by this layer. + down_rad = down_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - & + exp(-k_dir(ft) * total_lai_sai(L,ft,iv))) * tau_layer(L,ft,iv,ib) + + !... plus the direct beam intercepted and intransmitted by this layer. + ! modified to spread it out over the whole of incomplete layers. + down_rad = down_rad *(ftweight(L,ft,iv)/ftweight(L,ft,1)) if (iv > 1)then @@ -734,8 +753,7 @@ subroutine PatchNormanRadiation (currentPatch, & !reflection of the lower layer, up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) up_rad = up_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - exp(-k_dir(ft) * & - (currentPatch%elai_profile(L,ft,iv) + currentPatch%esai_profile(L,ft,iv)))) * & - rhol(ft,ib) + total_lai_sai(L,ft,iv)) )* rho_layer(L,ft,iv,ib) up_rad = up_rad + Dif_up(L,ft,iv+1) * tran_dif(L,ft,iv,ib) up_rad = up_rad * ftweight(L,ft,iv)/ftweight(L,ft,1) up_rad = up_rad + Dif_up(L,ft,iv+1) *(ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) @@ -777,12 +795,11 @@ subroutine PatchNormanRadiation (currentPatch, & ! Absorbed direct beam and diffuse do leaf layers do iv = 1, currentPatch%nrad(L,ft) Abs_dir_z(ft,iv) = ftweight(L,ft,iv)* forc_dir(radtype) * tr_dir_z(L,ft,iv) * & - (1.00_r8 - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & - currentPatch%esai_profile(L,ft,iv)))) * (1.00_r8 - f_not_abs(ft,ib)) + (1.00_r8 - exp(-k_dir(ft) * total_lai_sai(L,ft,iv))) * f_abs(L,ft,iv,ib) Abs_dif_z(ft,iv) = ftweight(L,ft,iv)* ((Dif_dn(L,ft,iv) + & - Dif_up(L,ft,iv+1)) * (1.00_r8 - tr_dif_z(L,ft,iv)) * & - (1.00_r8 - f_not_abs(ft,ib))) + Dif_up(L,ft,iv+1)) * (1.00_r8 - tr_dif_z(L,ft,iv)) * f_abs(L,ft,iv,ib)) end do + ! Absorbed direct beam and diffuse do soil if (L == currentPatch%NCL_p)then @@ -974,7 +991,6 @@ subroutine PatchNormanRadiation (currentPatch, & write(fates_log(),*) 'Large Dir Radn consvn error',error ,ib write(fates_log(),*) 'diags', albd_parb_out(ib), ftdd_parb_out(ib), & ftid_parb_out(ib), fabd_parb_out(ib) - write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) From 54f158b04fb31a7c594865b961d87f67a3e40d4b Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 1 Jun 2021 07:24:52 -0600 Subject: [PATCH 297/578] addeding LAI+SAI criteria to radiation loop check --- biogeophys/EDSurfaceAlbedoMod.F90 | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index cfd0b3d7fc..34bffe42b5 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -295,17 +295,20 @@ subroutine PatchNormanRadiation (currentPatch, & do ft = 1,numpft currentPatch%canopy_mask(L,ft) = 0 do iv = 1, currentPatch%nrad(L,ft) - if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then + total_lai_sai(L,ft,iv) = currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L\ +,ft,iv) + if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8.and.total_lai_sai(l,ft,iv) > 0._r8)then currentPatch%canopy_mask(L,ft) = 1 - total_lai_sai(L,ft,iv) = currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) frac_lai(L,ft,iv) = currentPatch%elai_profile(L,ft,iv)/total_lai_sai(L,ft,iv) frac_sai(L,ft,iv) = currentPatch%esai_profile(L,ft,iv)/total_lai_sai(L,ft,iv) + ! layer level reflectance qualities do ib = 1,hlm_numSWb !vis, nir f_abs(L,ft,iv,ib) = 1.0_r8 - (frac_lai(L,ft,iv)*(rhol(ft,ib) + taul(ft,ib))+& frac_sai(L,ft,iv)*(rhos(ft,ib) + taus(ft,ib))) rho_layer(L,ft,iv,ib)=frac_lai(L,ft,iv)*rhol(ft,ib)+frac_sai(L,ft,iv)*rhos(ft,ib) tau_layer(L,ft,iv,ib)=frac_lai(L,ft,iv)*taul(ft,ib)+frac_sai(L,ft,iv)*taus(ft,ib) + end do !ib endif end do !iv @@ -694,6 +697,7 @@ subroutine PatchNormanRadiation (currentPatch, & down_rad = down_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - & exp(-k_dir(ft) * total_lai_sai(L,ft,iv))) * tau_layer(L,ft,iv,ib) + !... plus the direct beam intercepted and intransmitted by this layer. ! modified to spread it out over the whole of incomplete layers. @@ -1036,7 +1040,6 @@ subroutine PatchNormanRadiation (currentPatch, & end if end if - end do !hlm_numSWb enddo ! rad-type From b3832ca4200e35b47b7bf08815e504537d9fdf26 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 1 Jun 2021 10:12:13 -0600 Subject: [PATCH 298/578] hard-coded bin sizes into edtypes for now --- main/EDTypesMod.F90 | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 5a01c72c7b..20ad0dc2ca 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -62,10 +62,18 @@ module EDTypesMod real(r8), parameter, public :: top_vai_bin_width = 0.25_r8 ! width in VAI units of uppermost canopy scattering element real(r8), parameter, public :: vai_width_increase_factor = 1.3_r8 ! factor by which each bin increases in VAI binning integer :: i ! iterator used to define bin widths - real(r8), parameter, public :: dinc_vai(nlevleaf) = & - top_vai_bin_width * vai_width_increase_factor ** (/(real(i,r8), i=0,nlevleaf-1,1)/) ! VAI bin widths array - real(r8), parameter, public :: dlower_vai(nlevleaf) = & - (/(sum(dinc_vai(1:i)), i=1,nlevleaf,1)/) ! lower edges of VAI bins + ! real(r8), protected, public :: dinc_vai(nlevleaf) = & + ! top_vai_bin_width * vai_width_increase_factor ** (/i, i=0,nlevleaf-1,1)/) ! VAI bin widths array + real(r8), parameter, public :: dinc_vai(nlevleaf) = (/0.25_r8,0.325_r8,0.4225_r8,0.54925_r8,0.714025_r8, & + 0.9282325_r8,1.20670225_r8,1.56871293_r8,2.0393268_r8,2.65112484_r8, & + 3.4464623_r8,4.48040099_r8,5.82452128_r8,7.57187766_r8,9.84344096_r8/) + + ! real(r8), protected, public :: dlower_vai(nlevleaf) = & + ! (/(sum(dinc_vai(1:i)), i=1,nlevleaf,1)/) ! lower edges of VAI bins + + real(r8), parameter, public :: dlower_vai(nlevleaf) = (/0.25_r8,0.575_r8,0.9975_r8,1.54675_r8,2.260775_r8,& + 3.1890075_r8,4.39570975_r8,5.96442268_r8,8.00374948_r8,10.65487432_r8, & + 14.10133662_r8,18.5817376_r8,24.40625888_r8,31.97813655_r8,41.82157751_r8/) ! TODO: we use this cp_maxSWb only because we have a static array q(size=2) of ! land-ice abledo for vis and nir. This should be a parameter, which would From ff4c61a6126fe59b8f67f15a7ba862287f9100b2 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 1 Jun 2021 10:42:22 -0600 Subject: [PATCH 299/578] added error checking, and zero lai+sai capacity --- biogeophys/EDSurfaceAlbedoMod.F90 | 66 +++++++++++++++++-------------- 1 file changed, 37 insertions(+), 29 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 34bffe42b5..723aafbf23 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -199,6 +199,7 @@ subroutine PatchNormanRadiation (currentPatch, & integer :: irep ! Flag to exit iteration loop real(r8) :: sb real(r8) :: error ! Error check + real(r8) :: lgerror real(r8) :: down_rad, up_rad ! Iterative solution do Dif_dn and Dif_up real(r8) :: ftweight(nclmax,maxpft,nlevleaf) real(r8) :: k_dir(maxpft) ! Direct beam extinction coefficient @@ -217,8 +218,8 @@ subroutine PatchNormanRadiation (currentPatch, & real(r8) :: lai_change(nclmax,maxpft,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) real(r8) :: total_lai_sai(nclmax,maxpft,nlevleaf) ! Total intercepting surfaces in canopy layer. m2 - real(r8) :: frac_lai(nclmax,maxpft,nlevleaf) ! Fraction of lai in each layer - real(r8) :: frac_sai(nclmax,maxpft,nlevleaf) ! Fraction of sai in each layer + real(r8) :: frac_lai ! Fraction of lai in each layer + real(r8) :: frac_sai ! Fraction of sai in each layer real(r8) :: f_abs(nclmax,maxpft,nlevleaf,maxSWb) ! Fraction of light absorbed by surfaces. real(r8) :: rho_layer(nclmax,maxpft,nlevleaf,maxSWb)! Weighted verage reflectance of layer real(r8) :: tau_layer(nclmax,maxpft,nlevleaf,maxSWb)! Weighted average transmittance of layer @@ -263,6 +264,8 @@ subroutine PatchNormanRadiation (currentPatch, & clumping_index => EDPftvarcon_inst%clumping_index) + lgerror = 0.03_r8 + ! Initialize local arrays weighted_dir_tr(:) = 0._r8 @@ -297,18 +300,23 @@ subroutine PatchNormanRadiation (currentPatch, & do iv = 1, currentPatch%nrad(L,ft) total_lai_sai(L,ft,iv) = currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L\ ,ft,iv) - if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8.and.total_lai_sai(l,ft,iv) > 0._r8)then + if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then currentPatch%canopy_mask(L,ft) = 1 - frac_lai(L,ft,iv) = currentPatch%elai_profile(L,ft,iv)/total_lai_sai(L,ft,iv) - frac_sai(L,ft,iv) = currentPatch%esai_profile(L,ft,iv)/total_lai_sai(L,ft,iv) - ! layer level reflectance qualities do ib = 1,hlm_numSWb !vis, nir - f_abs(L,ft,iv,ib) = 1.0_r8 - (frac_lai(L,ft,iv)*(rhol(ft,ib) + taul(ft,ib))+& - frac_sai(L,ft,iv)*(rhos(ft,ib) + taus(ft,ib))) - rho_layer(L,ft,iv,ib)=frac_lai(L,ft,iv)*rhol(ft,ib)+frac_sai(L,ft,iv)*rhos(ft,ib) - tau_layer(L,ft,iv,ib)=frac_lai(L,ft,iv)*taul(ft,ib)+frac_sai(L,ft,iv)*taus(ft,ib) - + if(total_lai_sai(L,ft,iv).gt.0._r8)then + frac_lai = currentPatch%elai_profile(L,ft,iv)/total_lai_sai(L,ft,iv) + frac_sai = 1.0_r8 - frac_lai + f_abs(L,ft,iv,ib) = 1.0_r8 - (frac_lai*(rhol(ft,ib) + taul(ft,ib))+& + frac_sai*(rhos(ft,ib) + taus(ft,ib))) + rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) + tau_layer(L,ft,iv,ib)=frac_lai*taul(ft,ib)+frac_sai*taus(ft,ib) + + else ! this is an empty layer, so all the light goes through. + rho_layer(L,ft,iv,ib)=0.0_r8 + tau_layer(L,ft,iv,ib)=1.0_r8 + end if + end do !ib endif end do !iv @@ -982,7 +990,7 @@ subroutine PatchNormanRadiation (currentPatch, & if (radtype == idirect)then !here we are adding a within-ED radiation scheme tolerance, and then adding the diffrence onto the albedo !it is important that the lower boundary for this is ~1000 times smaller than the tolerance in surface albedo. - if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then + if (abs(error) > 1.e-9_r8 .and. abs(error) < lgerror)then albd_parb_out(ib) = albd_parb_out(ib) + error !this terms adds the error back on to the albedo. While this is partly inexcusable, it is ! in the medium term a solution that @@ -991,40 +999,40 @@ subroutine PatchNormanRadiation (currentPatch, & ! to the complexity of this code, but where the system generates occasional errors, we ! will deal with them for now. end if - if (abs(error) > 0.15_r8)then + if (abs(error) > lgerror)then write(fates_log(),*) 'Large Dir Radn consvn error',error ,ib write(fates_log(),*) 'diags', albd_parb_out(ib), ftdd_parb_out(ib), & ftid_parb_out(ib), fabd_parb_out(ib) - write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) - albd_parb_out(ib) = albd_parb_out(ib) + error + !albd_parb_out(ib) = albd_parb_out(ib) + error end if else - if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then + if (abs(error) > 1.e-9_r8 .and. abs(error) < lgerror)then albi_parb_out(ib) = albi_parb_out(ib) + error end if - if (abs(error) > 0.15_r8)then - write(fates_log(),*) '>5% Dif Radn consvn error',error ,ib + if (abs(error) > lgerror)then + write(fates_log(),*) 'lg Dif Radn consvn error',error ,ib write(fates_log(),*) 'diags', albi_parb_out(ib), ftii_parb_out(ib), & fabi_parb_out(ib) - write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) - write(fates_log(),*) 'rhol',rhol(1:numpft,:) - write(fates_log(),*) 'ftw',sum(ftweight(1,1:numpft,1)),ftweight(1,1:numpft,1) - write(fates_log(),*) 'present',currentPatch%canopy_mask(1,1:numpft) - write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:numpft,1) + !write(fates_log(),*) 'rhol',rhol(1:numpft,:) + !write(fates_log(),*) 'ftw',sum(ftweight(1,1:numpft,1)),ftweight(1,1:numpft,1) + !write(fates_log(),*) 'present',currentPatch%canopy_mask(1,1:numpft) + !write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:numpft,1) - albi_parb_out(ib) = albi_parb_out(ib) + error + ! albi_parb_out(ib) = albi_parb_out(ib) + error end if if (radtype == idirect)then From 789342dfededbd5b309ad5796d5be744bce2b158 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 2 Jun 2021 04:01:12 -0600 Subject: [PATCH 300/578] added tracking of residual radiation error for diagnosis --- biogeochem/EDPatchDynamicsMod.F90 | 4 ++-- biogeophys/EDSurfaceAlbedoMod.F90 | 18 +++++++++++------- main/EDTypesMod.F90 | 2 +- 3 files changed, 14 insertions(+), 10 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 60716b23dd..365e791cfd 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2181,7 +2181,7 @@ subroutine zero_patch(cp_p) currentPatch%c_stomata = 0.0_r8 ! This is calculated immediately before use currentPatch%c_lblayer = 0.0_r8 currentPatch%fragmentation_scaler(:) = 0.0_r8 - + currentPatch%radiation_error = 0.0_r8 currentPatch%solar_zenith_flag = .false. currentPatch%solar_zenith_angle = nan @@ -2520,7 +2520,7 @@ subroutine fuse_2_patches(csite, dp, rp) rp%zstar = (dp%zstar*dp%area + rp%zstar*rp%area) * inv_sum_area rp%c_stomata = (dp%c_stomata*dp%area + rp%c_stomata*rp%area) * inv_sum_area rp%c_lblayer = (dp%c_lblayer*dp%area + rp%c_lblayer*rp%area) * inv_sum_area - + rp%radiation_error = (dp%radiation_error*dp%area + rp%radiation_error*rp%area) * inv_sum_area rp%area = rp%area + dp%area !THIS MUST COME AT THE END! !insert donor cohorts into recipient patch diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 723aafbf23..ac155dac35 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -264,7 +264,7 @@ subroutine PatchNormanRadiation (currentPatch, & clumping_index => EDPftvarcon_inst%clumping_index) - lgerror = 0.03_r8 + lgerror = 0.05_r8 ! Initialize local arrays @@ -307,6 +307,8 @@ subroutine PatchNormanRadiation (currentPatch, & if(total_lai_sai(L,ft,iv).gt.0._r8)then frac_lai = currentPatch%elai_profile(L,ft,iv)/total_lai_sai(L,ft,iv) frac_sai = 1.0_r8 - frac_lai +! frac_lai = 1.0_r8 +! frac_sai = 0.0_r8 f_abs(L,ft,iv,ib) = 1.0_r8 - (frac_lai*(rhol(ft,ib) + taul(ft,ib))+& frac_sai*(rhos(ft,ib) + taus(ft,ib))) rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) @@ -565,7 +567,7 @@ subroutine PatchNormanRadiation (currentPatch, & end do!ft end do!L - + currentPatch%radiation_error = 0.0_r8 do ib = 1,hlm_numSWb Dif_dn(:,:,:) = 0.00_r8 Dif_up(:,:,:) = 0.00_r8 @@ -970,9 +972,11 @@ subroutine PatchNormanRadiation (currentPatch, & if (radtype == idirect)then error = (forc_dir(radtype) + forc_dif(radtype)) - & (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) + currentPatch%radiation_error = currentPatch%radiation_error + error else error = (forc_dir(radtype) + forc_dif(radtype)) - & (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) + currentPatch%radiation_error = currentPatch%radiation_error + error endif lai_reduction(:) = 0.0_r8 do L = 1, currentPatch%NCL_p @@ -1003,13 +1007,13 @@ subroutine PatchNormanRadiation (currentPatch, & write(fates_log(),*) 'Large Dir Radn consvn error',error ,ib write(fates_log(),*) 'diags', albd_parb_out(ib), ftdd_parb_out(ib), & ftid_parb_out(ib), fabd_parb_out(ib) - !write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - !write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - !write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) - !albd_parb_out(ib) = albd_parb_out(ib) + error + albd_parb_out(ib) = albd_parb_out(ib) + error end if else @@ -1032,7 +1036,7 @@ subroutine PatchNormanRadiation (currentPatch, & !write(fates_log(),*) 'present',currentPatch%canopy_mask(1,1:numpft) !write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:numpft,1) - ! albi_parb_out(ib) = albi_parb_out(ib) + error + albi_parb_out(ib) = albi_parb_out(ib) + error end if if (radtype == idirect)then diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 5da7babc54..0b700286d1 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -430,7 +430,7 @@ module EDTypesMod real(r8) :: elai_profile(nclmax,maxpft,nlevleaf) ! exposed leaf area in each canopy layer, pft, and leaf layer real(r8) :: tsai_profile(nclmax,maxpft,nlevleaf) ! total stem area in each canopy layer, pft, and leaf layer real(r8) :: esai_profile(nclmax,maxpft,nlevleaf) ! exposed stem area in each canopy layer, pft, and leaf layer - + real(r8) :: radiation_error real(r8) :: layer_height_profile(nclmax,maxpft,nlevleaf) real(r8) :: canopy_area_profile(nclmax,maxpft,nlevleaf) ! fraction of crown area per canopy area in each layer ! they will sum to 1.0 in the fully closed canopy layers From c892b4eaca313da0c76dc3816a0bd51c2d2b7f6f Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 2 Jun 2021 04:13:46 -0600 Subject: [PATCH 301/578] removed frac_lai dummy args --- biogeophys/EDSurfaceAlbedoMod.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index ac155dac35..d472685616 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -307,8 +307,6 @@ subroutine PatchNormanRadiation (currentPatch, & if(total_lai_sai(L,ft,iv).gt.0._r8)then frac_lai = currentPatch%elai_profile(L,ft,iv)/total_lai_sai(L,ft,iv) frac_sai = 1.0_r8 - frac_lai -! frac_lai = 1.0_r8 -! frac_sai = 0.0_r8 f_abs(L,ft,iv,ib) = 1.0_r8 - (frac_lai*(rhol(ft,ib) + taul(ft,ib))+& frac_sai*(rhos(ft,ib) + taus(ft,ib))) rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) From 3a546854be7e11a6060d60f2e4261df086894d34 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 2 Jun 2021 17:40:35 -0600 Subject: [PATCH 302/578] moved VAI bin width parameters to parameter file --- main/EDParamsMod.F90 | 20 ++++++++++++++++++++ main/EDTypesMod.F90 | 18 +++--------------- main/FatesInterfaceMod.F90 | 15 +++++++++++++++ main/FatesInterfaceTypesMod.F90 | 1 + parameter_files/fates_params_default.cdl | 10 ++++++++++ 5 files changed, 49 insertions(+), 15 deletions(-) diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 8162939bc3..111b20d38e 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -23,6 +23,8 @@ module EDParamsMod real(r8),protected, public :: fates_mortality_disturbance_fraction ! the fraction of canopy mortality that results in disturbance real(r8),protected, public :: ED_val_comp_excln + real(r8),protected, public :: ED_val_vai_top_bin_width + real(r8),protected, public :: ED_val_vai_width_increase_factor real(r8),protected, public :: ED_val_init_litter real(r8),protected, public :: ED_val_nignitions real(r8),protected, public :: ED_val_understorey_death @@ -62,6 +64,8 @@ module EDParamsMod character(len=param_string_length),parameter,public :: ED_name_mort_disturb_frac = "fates_mort_disturb_frac" character(len=param_string_length),parameter,public :: ED_name_comp_excln = "fates_comp_excln" + character(len=param_string_length),parameter,public :: ED_name_vai_top_bin_width = "fates_vai_top_bin_width" + character(len=param_string_length),parameter,public :: ED_name_vai_width_increase_factor = "fates_vai_width_increase_factor" character(len=param_string_length),parameter,public :: ED_name_init_litter = "fates_init_litter" character(len=param_string_length),parameter,public :: ED_name_nignitions = "fates_fire_nignitions" character(len=param_string_length),parameter,public :: ED_name_understorey_death = "fates_mort_understorey_death" @@ -175,6 +179,8 @@ subroutine FatesParamsInit() fates_mortality_disturbance_fraction = nan ED_val_comp_excln = nan + ED_val_vai_top_bin_width = nan + ED_val_vai_width_increase_factor = nan ED_val_init_litter = nan ED_val_nignitions = nan ED_val_understorey_death = nan @@ -246,6 +252,12 @@ subroutine FatesRegisterParams(fates_params) call fates_params%RegisterParameter(name=ED_name_comp_excln, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_vai_top_bin_width, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=ED_name_vai_width_increase_factor, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_init_litter, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) @@ -397,6 +409,12 @@ subroutine FatesReceiveParams(fates_params) call fates_params%RetreiveParameter(name=ED_name_comp_excln, & data=ED_val_comp_excln) + call fates_params%RetreiveParameter(name=ED_name_vai_top_bin_width, & + data=ED_val_vai_top_bin_width) + + call fates_params%RetreiveParameter(name=ED_name_vai_width_increase_factor, & + data=ED_val_vai_width_increase_factor) + call fates_params%RetreiveParameter(name=ED_name_init_litter, & data=ED_val_init_litter) @@ -546,6 +564,8 @@ subroutine FatesReportParams(is_master) write(fates_log(),*) '----------- FATES Scalar Parameters -----------------' write(fates_log(),fmt0) 'fates_mortality_disturbance_fraction = ',fates_mortality_disturbance_fraction write(fates_log(),fmt0) 'ED_val_comp_excln = ',ED_val_comp_excln + write(fates_log(),fmt0) 'ED_val_vai_top_bin_width = ',ED_val_vai_top_bin_width + write(fates_log(),fmt0) 'ED_val_vai_width_increase_factor = ',ED_val_vai_width_increase_factor write(fates_log(),fmt0) 'ED_val_init_litter = ',ED_val_init_litter write(fates_log(),fmt0) 'ED_val_nignitions = ',ED_val_nignitions write(fates_log(),fmt0) 'ED_val_understorey_death = ',ED_val_understorey_death diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 20ad0dc2ca..eef319631a 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -18,6 +18,7 @@ module EDTypesMod use FatesLitterMod, only : ncwd use FatesConstantsMod, only : n_anthro_disturbance_categories use FatesConstantsMod, only : days_per_year + use FatesConstantsMod, only : fates_unset_r8 use FatesInterfaceTypesMod,only : bc_in_type use FatesInterfaceTypesMod,only : bc_out_type @@ -59,21 +60,8 @@ module EDTypesMod ! parameters that govern the VAI (LAI+SAI) bins used in radiative transfer code integer, parameter, public :: nlevleaf = 15 ! number of leaf+stem layers in canopy layer - real(r8), parameter, public :: top_vai_bin_width = 0.25_r8 ! width in VAI units of uppermost canopy scattering element - real(r8), parameter, public :: vai_width_increase_factor = 1.3_r8 ! factor by which each bin increases in VAI binning - integer :: i ! iterator used to define bin widths - ! real(r8), protected, public :: dinc_vai(nlevleaf) = & - ! top_vai_bin_width * vai_width_increase_factor ** (/i, i=0,nlevleaf-1,1)/) ! VAI bin widths array - real(r8), parameter, public :: dinc_vai(nlevleaf) = (/0.25_r8,0.325_r8,0.4225_r8,0.54925_r8,0.714025_r8, & - 0.9282325_r8,1.20670225_r8,1.56871293_r8,2.0393268_r8,2.65112484_r8, & - 3.4464623_r8,4.48040099_r8,5.82452128_r8,7.57187766_r8,9.84344096_r8/) - - ! real(r8), protected, public :: dlower_vai(nlevleaf) = & - ! (/(sum(dinc_vai(1:i)), i=1,nlevleaf,1)/) ! lower edges of VAI bins - - real(r8), parameter, public :: dlower_vai(nlevleaf) = (/0.25_r8,0.575_r8,0.9975_r8,1.54675_r8,2.260775_r8,& - 3.1890075_r8,4.39570975_r8,5.96442268_r8,8.00374948_r8,10.65487432_r8, & - 14.10133662_r8,18.5817376_r8,24.40625888_r8,31.97813655_r8,41.82157751_r8/) + real(r8), public :: dinc_vai(nlevleaf) = fates_unset_r8 ! VAI bin widths array + real(r8), public :: dlower_vai(nlevleaf) = fates_unset_r8 ! lower edges of VAI bins ! TODO: we use this cp_maxSWb only because we have a static array q(size=2) of ! land-ice abledo for vis and nir. This should be a parameter, which would diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 0156beb2dc..a52edfac67 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -12,6 +12,10 @@ module FatesInterfaceMod use EDTypesMod , only : ed_site_type use EDTypesMod , only : maxPatchesPerSite use EDTypesMod , only : maxCohortsPerPatch + use EDTypesMod , only : dinc_vai + use EDTypesMod , only : dlower_vai + use EDParamsMod , only : ED_val_vai_top_bin_width + use EDParamsMod , only : ED_val_vai_width_increase_factor use EDTypesMod , only : maxSWb use EDTypesMod , only : ivis use EDTypesMod , only : inir @@ -785,7 +789,16 @@ subroutine SetFatesGlobalElements(use_fates) max_comp_per_site = 1 end if + ! calculate the bin edges for radiative transfer calculations + ! VAI bin widths array + do i = 1,nlevleaf + dinc_vai(i) = ED_val_vai_top_bin_width * ED_val_vai_width_increase_factor ** (i-1) + end do + ! lower edges of VAI bins + do i = 1,nlevleaf + dlower_vai(i) = sum(dinc_vai(1:i)) + end do ! Identify number of size and age class bins for history output ! assume these arrays are 1-indexed @@ -961,6 +974,7 @@ subroutine fates_history_maps allocate( fates_hdim_levcan(nclmax)) allocate( fates_hdim_levelem(num_elements)) + allocate( fates_hdim_levleaf(nlevleaf)) allocate( fates_hdim_canmap_levcnlf(nlevleaf*nclmax)) allocate( fates_hdim_lfmap_levcnlf(nlevleaf*nclmax)) allocate( fates_hdim_canmap_levcnlfpf(nlevleaf*nclmax*numpft)) @@ -989,6 +1003,7 @@ subroutine fates_history_maps fates_hdim_levage(:) = ED_val_history_ageclass_bin_edges(:) fates_hdim_levheight(:) = ED_val_history_height_bin_edges(:) fates_hdim_levcoage(:) = ED_val_history_coageclass_bin_edges(:) + fates_hdim_levleaf(:) = dlower_vai(:) ! make pft array do ipft=1,numpft diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 1052ef251e..a359118dbb 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -232,6 +232,7 @@ module FatesInterfaceTypesMod integer , public, allocatable :: fates_hdim_levfuel(:) ! fire fuel size class (fsc) dimension integer , public, allocatable :: fates_hdim_levcwdsc(:) ! cwd class dimension integer , public, allocatable :: fates_hdim_levcan(:) ! canopy-layer dimension + integer , public, allocatable :: fates_hdim_levleaf(:) ! leaf-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 diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 86d46710da..3d8c11e718 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -687,6 +687,12 @@ variables: double fates_soil_salinity ; fates_soil_salinity:units = "ppt" ; fates_soil_salinity:long_name = "soil salinity used for model when not coupled to dynamic soil salinity" ; + double fates_vai_top_bin_width ; + fates_vai_top_bin_width:units = "unitless" ; + fates_vai_top_bin_width:long_name = "width in VAI units of uppermost leaf+stem layer scattering element in each canopy layer" ; + double fates_vai_width_increase_factor ; + fates_vai_width_increase_factor:units = "unitless" ; + fates_vai_width_increase_factor:long_name = "factor by which each leaf+stem scattering element increases in VAI width (1 = uniform spacing)" ; // global attributes: :history = "This parameter file is maintained in version control\nSee https://github.com/NGEET/fates/blob/master/parameter_files/fates_params_default.cdl \nFor changes, use git blame \n" ; @@ -1329,4 +1335,8 @@ data: fates_q10_mr = 1.5 ; fates_soil_salinity = 0.4 ; + + fates_vai_top_bin_width = 0.25 ; + + fates_vai_width_increase_factor = 1.3 ; } From e9a5da90fb74b1db8993b7b35cf2589c20d6e2e1 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 2 Jun 2021 17:57:08 -0600 Subject: [PATCH 303/578] removing nocomp pft label check in radiation restart update --- main/FatesRestartInterfaceMod.F90 | 3 --- 1 file changed, 3 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 1328edef8c..dc521649c8 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -2922,7 +2922,6 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ifp = 0 currentpatch => sites(s)%oldest_patch do while (associated(currentpatch)) - if(currentpatch%nocomp_pft_label.gt.0)then ifp = ifp+1 currentPatch%f_sun (:,:,:) = 0._r8 @@ -2986,8 +2985,6 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) endif ! is there vegetation? end if ! if the vegetation and zenith filter is active - - end if ! not bare ground currentPatch => currentPatch%younger end do ! Loop linked-list patches enddo ! Loop Sites From b6723d2bba19f0fa8866cf459720979feb59847c Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 2 Jun 2021 18:57:04 -0600 Subject: [PATCH 304/578] reverting to 30 layers with constant dinc of 1.0 as a reference case --- main/EDTypesMod.F90 | 2 +- parameter_files/fates_params_default.cdl | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index eef319631a..911a68fe90 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -59,7 +59,7 @@ module EDTypesMod integer, parameter, public :: idiffuse = 2 ! This is the array index for diffuse radiation ! parameters that govern the VAI (LAI+SAI) bins used in radiative transfer code - integer, parameter, public :: nlevleaf = 15 ! number of leaf+stem layers in canopy layer + integer, parameter, public :: nlevleaf = 30 ! number of leaf+stem layers in canopy layer real(r8), public :: dinc_vai(nlevleaf) = fates_unset_r8 ! VAI bin widths array real(r8), public :: dlower_vai(nlevleaf) = fates_unset_r8 ! lower edges of VAI bins diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 3d8c11e718..5420c34017 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -1336,7 +1336,7 @@ data: fates_soil_salinity = 0.4 ; - fates_vai_top_bin_width = 0.25 ; + fates_vai_top_bin_width = 1.0 ; - fates_vai_width_increase_factor = 1.3 ; + fates_vai_width_increase_factor = 1.0 ; } From 58c33ee2232e9d602948e29417b030e2289afc44 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 3 Jun 2021 12:16:08 -0600 Subject: [PATCH 305/578] correcting logic check for ST3 mode --- main/EDMainMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index c7bdc30f41..6903ee85b2 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -264,7 +264,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) !********************************************************************************* do_patch_dynamics = itrue - if(hlm_use_ed_st3.eq.ifalse)then + if(hlm_use_ed_st3.eq.itrue)then do_patch_dynamics = ifalse end if From d901f9f36450d5b7f19dca257a668e865e5eb6dd Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 4 Jun 2021 09:45:57 -0600 Subject: [PATCH 306/578] removing redundeant newparea call and deallocation which was causing hydro enabled failures --- main/EDInitMod.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 05a17d7a9c..19907e4842 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -492,7 +492,6 @@ subroutine init_patches( nsites, sites, bc_in) ! allocate(newppft(numpft)) else !default num_new_patches = 1 - newparea = area end if !nocomp is_first_patch = itrue @@ -647,7 +646,6 @@ subroutine init_patches( nsites, sites, bc_in) sitep => sites(s) call updateSizeDepRhizHydProps(sitep, bc_in(s)) end do - deallocate(recall_older_patch) end if return From 6f8acfb266e17e5a725168f7c23f5f61073fb433 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Jun 2021 04:22:57 -0600 Subject: [PATCH 307/578] rewind tracking of radiation errors --- biogeochem/EDPatchDynamicsMod.F90 | 2 -- biogeophys/EDSurfaceAlbedoMod.F90 | 9 +++------ main/EDTypesMod.F90 | 1 - 3 files changed, 3 insertions(+), 9 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 365e791cfd..ce81751cc4 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2181,7 +2181,6 @@ subroutine zero_patch(cp_p) currentPatch%c_stomata = 0.0_r8 ! This is calculated immediately before use currentPatch%c_lblayer = 0.0_r8 currentPatch%fragmentation_scaler(:) = 0.0_r8 - currentPatch%radiation_error = 0.0_r8 currentPatch%solar_zenith_flag = .false. currentPatch%solar_zenith_angle = nan @@ -2520,7 +2519,6 @@ subroutine fuse_2_patches(csite, dp, rp) rp%zstar = (dp%zstar*dp%area + rp%zstar*rp%area) * inv_sum_area rp%c_stomata = (dp%c_stomata*dp%area + rp%c_stomata*rp%area) * inv_sum_area rp%c_lblayer = (dp%c_lblayer*dp%area + rp%c_lblayer*rp%area) * inv_sum_area - rp%radiation_error = (dp%radiation_error*dp%area + rp%radiation_error*rp%area) * inv_sum_area rp%area = rp%area + dp%area !THIS MUST COME AT THE END! !insert donor cohorts into recipient patch diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index d472685616..f8fd7264e4 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -117,7 +117,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%fabd_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM - bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftid_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM if (maxval(currentPatch%nrad(1,:))==0)then @@ -129,7 +129,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 - bc_out(s)%ftid_parb(ifp,ib)= 1.0_r8 + bc_out(s)%ftid_parb(ifp,ib)= 0.0_r8 bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 enddo @@ -289,7 +289,7 @@ subroutine PatchNormanRadiation (currentPatch, & fabd_parb_out(1:hlm_numSWb) = 0.0_r8 fabi_parb_out(1:hlm_numSWb) = 0.0_r8 ftdd_parb_out(1:hlm_numSWb) = 1.0_r8 - ftid_parb_out(1:hlm_numSWb) = 1.0_r8 + ftid_parb_out(1:hlm_numSWb) = 0.0_r8 ftii_parb_out(1:hlm_numSWb) = 1.0_r8 ! Is this pft/canopy layer combination present in this patch? @@ -565,7 +565,6 @@ subroutine PatchNormanRadiation (currentPatch, & end do!ft end do!L - currentPatch%radiation_error = 0.0_r8 do ib = 1,hlm_numSWb Dif_dn(:,:,:) = 0.00_r8 Dif_up(:,:,:) = 0.00_r8 @@ -970,11 +969,9 @@ subroutine PatchNormanRadiation (currentPatch, & if (radtype == idirect)then error = (forc_dir(radtype) + forc_dif(radtype)) - & (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) - currentPatch%radiation_error = currentPatch%radiation_error + error else error = (forc_dir(radtype) + forc_dif(radtype)) - & (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) - currentPatch%radiation_error = currentPatch%radiation_error + error endif lai_reduction(:) = 0.0_r8 do L = 1, currentPatch%NCL_p diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 0b700286d1..d572fb00be 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -430,7 +430,6 @@ module EDTypesMod real(r8) :: elai_profile(nclmax,maxpft,nlevleaf) ! exposed leaf area in each canopy layer, pft, and leaf layer real(r8) :: tsai_profile(nclmax,maxpft,nlevleaf) ! total stem area in each canopy layer, pft, and leaf layer real(r8) :: esai_profile(nclmax,maxpft,nlevleaf) ! exposed stem area in each canopy layer, pft, and leaf layer - real(r8) :: radiation_error real(r8) :: layer_height_profile(nclmax,maxpft,nlevleaf) real(r8) :: canopy_area_profile(nclmax,maxpft,nlevleaf) ! fraction of crown area per canopy area in each layer ! they will sum to 1.0 in the fully closed canopy layers From f2b207e2829d5e0f4786e89a4c7d343ad1cd8726 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Jun 2021 05:08:00 -0600 Subject: [PATCH 308/578] removing Hui's bugfix --- biogeophys/EDSurfaceAlbedoMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index f8fd7264e4..ad630bcf55 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -117,7 +117,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%fabd_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM - bc_out(s)%ftid_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM if (maxval(currentPatch%nrad(1,:))==0)then @@ -129,7 +129,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 - bc_out(s)%ftid_parb(ifp,ib)= 0.0_r8 + bc_out(s)%ftid_parb(ifp,ib)= 1.0_r8 bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 enddo From 63e35d73db9073b19bccd9e36cf5f619021984a0 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Jun 2021 05:47:50 -0600 Subject: [PATCH 309/578] whitespace corrections --- biogeochem/EDPatchDynamicsMod.F90 | 2 ++ main/EDTypesMod.F90 | 1 + 2 files changed, 3 insertions(+) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index ce81751cc4..200959a4b7 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2181,6 +2181,7 @@ subroutine zero_patch(cp_p) currentPatch%c_stomata = 0.0_r8 ! This is calculated immediately before use currentPatch%c_lblayer = 0.0_r8 currentPatch%fragmentation_scaler(:) = 0.0_r8 + currentPatch%solar_zenith_flag = .false. currentPatch%solar_zenith_angle = nan @@ -2519,6 +2520,7 @@ subroutine fuse_2_patches(csite, dp, rp) rp%zstar = (dp%zstar*dp%area + rp%zstar*rp%area) * inv_sum_area rp%c_stomata = (dp%c_stomata*dp%area + rp%c_stomata*rp%area) * inv_sum_area rp%c_lblayer = (dp%c_lblayer*dp%area + rp%c_lblayer*rp%area) * inv_sum_area + rp%area = rp%area + dp%area !THIS MUST COME AT THE END! !insert donor cohorts into recipient patch diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index d572fb00be..5da7babc54 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -430,6 +430,7 @@ module EDTypesMod real(r8) :: elai_profile(nclmax,maxpft,nlevleaf) ! exposed leaf area in each canopy layer, pft, and leaf layer real(r8) :: tsai_profile(nclmax,maxpft,nlevleaf) ! total stem area in each canopy layer, pft, and leaf layer real(r8) :: esai_profile(nclmax,maxpft,nlevleaf) ! exposed stem area in each canopy layer, pft, and leaf layer + real(r8) :: layer_height_profile(nclmax,maxpft,nlevleaf) real(r8) :: canopy_area_profile(nclmax,maxpft,nlevleaf) ! fraction of crown area per canopy area in each layer ! they will sum to 1.0 in the fully closed canopy layers From fa3874b786a4337e66239158418e1bc4715c72f4 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Mon, 7 Jun 2021 05:49:30 -0600 Subject: [PATCH 310/578] revert lgerror changes --- biogeophys/EDSurfaceAlbedoMod.F90 | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index ad630bcf55..d658877be1 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -199,7 +199,6 @@ subroutine PatchNormanRadiation (currentPatch, & integer :: irep ! Flag to exit iteration loop real(r8) :: sb real(r8) :: error ! Error check - real(r8) :: lgerror real(r8) :: down_rad, up_rad ! Iterative solution do Dif_dn and Dif_up real(r8) :: ftweight(nclmax,maxpft,nlevleaf) real(r8) :: k_dir(maxpft) ! Direct beam extinction coefficient @@ -264,7 +263,6 @@ subroutine PatchNormanRadiation (currentPatch, & clumping_index => EDPftvarcon_inst%clumping_index) - lgerror = 0.05_r8 ! Initialize local arrays @@ -989,7 +987,7 @@ subroutine PatchNormanRadiation (currentPatch, & if (radtype == idirect)then !here we are adding a within-ED radiation scheme tolerance, and then adding the diffrence onto the albedo !it is important that the lower boundary for this is ~1000 times smaller than the tolerance in surface albedo. - if (abs(error) > 1.e-9_r8 .and. abs(error) < lgerror)then + if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then albd_parb_out(ib) = albd_parb_out(ib) + error !this terms adds the error back on to the albedo. While this is partly inexcusable, it is ! in the medium term a solution that @@ -998,7 +996,7 @@ subroutine PatchNormanRadiation (currentPatch, & ! to the complexity of this code, but where the system generates occasional errors, we ! will deal with them for now. end if - if (abs(error) > lgerror)then + if (abs(error) > 0.15_r8)then write(fates_log(),*) 'Large Dir Radn consvn error',error ,ib write(fates_log(),*) 'diags', albd_parb_out(ib), ftdd_parb_out(ib), & ftid_parb_out(ib), fabd_parb_out(ib) @@ -1012,11 +1010,11 @@ subroutine PatchNormanRadiation (currentPatch, & end if else - if (abs(error) > 1.e-9_r8 .and. abs(error) < lgerror)then + if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then albi_parb_out(ib) = albi_parb_out(ib) + error end if - if (abs(error) > lgerror)then + if (abs(error) > 0.15_r8)then write(fates_log(),*) 'lg Dif Radn consvn error',error ,ib write(fates_log(),*) 'diags', albi_parb_out(ib), ftii_parb_out(ib), & fabi_parb_out(ib) From 870b36c21f3a22f79732d2c3f6cef75030bb6629 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 9 Jun 2021 04:15:25 -0600 Subject: [PATCH 311/578] removed total_lai_sai to simplify changes --- biogeophys/EDSurfaceAlbedoMod.F90 | 49 ++++++++++++++++++++----------- 1 file changed, 32 insertions(+), 17 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index d658877be1..71af0c1b31 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -216,7 +216,6 @@ subroutine PatchNormanRadiation (currentPatch, & real(r8) :: Dif_up(nclmax,maxpft,nlevleaf) ! Upward diffuse flux above canopy layer J (W/m**2 ground area) real(r8) :: lai_change(nclmax,maxpft,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) - real(r8) :: total_lai_sai(nclmax,maxpft,nlevleaf) ! Total intercepting surfaces in canopy layer. m2 real(r8) :: frac_lai ! Fraction of lai in each layer real(r8) :: frac_sai ! Fraction of sai in each layer real(r8) :: f_abs(nclmax,maxpft,nlevleaf,maxSWb) ! Fraction of light absorbed by surfaces. @@ -296,24 +295,27 @@ subroutine PatchNormanRadiation (currentPatch, & do ft = 1,numpft currentPatch%canopy_mask(L,ft) = 0 do iv = 1, currentPatch%nrad(L,ft) - total_lai_sai(L,ft,iv) = currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L\ -,ft,iv) if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then currentPatch%canopy_mask(L,ft) = 1 ! layer level reflectance qualities do ib = 1,hlm_numSWb !vis, nir - if(total_lai_sai(L,ft,iv).gt.0._r8)then - frac_lai = currentPatch%elai_profile(L,ft,iv)/total_lai_sai(L,ft,iv) +! if(total_lai_sai(L,ft,iv).gt.0._r8)then + frac_lai = currentPatch%elai_profile(L,ft,iv)/& + (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv)) frac_sai = 1.0_r8 - frac_lai f_abs(L,ft,iv,ib) = 1.0_r8 - (frac_lai*(rhol(ft,ib) + taul(ft,ib))+& frac_sai*(rhos(ft,ib) + taus(ft,ib))) rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) tau_layer(L,ft,iv,ib)=frac_lai*taul(ft,ib)+frac_sai*taus(ft,ib) - - else ! this is an empty layer, so all the light goes through. - rho_layer(L,ft,iv,ib)=0.0_r8 - tau_layer(L,ft,iv,ib)=1.0_r8 - end if + rho_layer(L,ft,iv,ib)= rhol(ft,ib) + tau_layer(L,ft,iv,ib)=taul(ft,ib) + f_abs(L,ft,iv,ib) = 1.0_r8 -(taul(ft,ib)+rhol(ft,ib)) + +! else ! this is an empty layer, so all the light goes through. +! rho_layer(L,ft,iv,ib)=0.0_r8 +! tau_layer(L,ft,iv,ib)=1.0_r8 +! end if end do !ib endif @@ -388,7 +390,8 @@ subroutine PatchNormanRadiation (currentPatch, & gdir = phi1b(ft) + phi2b(ft) * sin(angle) tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-clumping_index(ft) * & gdir / sin(angle) * & - total_lai_sai(L,ft,iv)) * & + (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv))) * & sin(angle)*cos(angle) end do @@ -410,7 +413,14 @@ subroutine PatchNormanRadiation (currentPatch, & laisum = 0.00_r8 !total direct beam getting to the bottom of the top canopy. do iv = 1,currentPatch%nrad(L,ft) - laisum = laisum + total_lai_sai(L,ft,iv) + if( currentPatch%elai_profile(L,ft,iv) & + +currentPatch%esai_profile(L,ft,iv).gt.0._r8.and.ftweight(L,ft,iv).le.0._r8)then + + write(*,*) 'lai in layer by no weight' + endif + + laisum = laisum+currentPatch%elai_profile(L,ft,iv) & + +currentPatch%esai_profile(L,ft,iv) lai_change(L,ft,iv) = 0.0_r8 if (( ftweight(L,ft,iv+1) > 0.0_r8 ) .and. ( ftweight(L,ft,iv+1) < ftweight(L,ft,iv) ))then !where there is a partly empty leaf layer, some fluxes go straight through. @@ -465,9 +475,11 @@ subroutine PatchNormanRadiation (currentPatch, & ! Now use cumulative lai at center of layer. ! Same as tr_dir_z calcualtions, but in the middle of the layer? FIX(RF,032414)-WHY? if (iv == 1) then - laisum = 0.5_r8 * total_lai_sai(L,ft,iv) + laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv)) else - laisum = laisum + total_lai_sai(L,ft,iv) + laisum = laisum + (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv)) end if @@ -700,7 +712,8 @@ subroutine PatchNormanRadiation (currentPatch, & !... plus the direct beam intercepted and intransmitted by this layer. down_rad = down_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - & - exp(-k_dir(ft) * total_lai_sai(L,ft,iv))) * tau_layer(L,ft,iv,ib) + exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv)) )) * tau_layer(L,ft,iv,ib) !... plus the direct beam intercepted and intransmitted by this layer. @@ -762,7 +775,8 @@ subroutine PatchNormanRadiation (currentPatch, & !reflection of the lower layer, up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) up_rad = up_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - exp(-k_dir(ft) * & - total_lai_sai(L,ft,iv)) )* rho_layer(L,ft,iv,ib) + (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv)) ))* rho_layer(L,ft,iv,ib) up_rad = up_rad + Dif_up(L,ft,iv+1) * tran_dif(L,ft,iv,ib) up_rad = up_rad * ftweight(L,ft,iv)/ftweight(L,ft,1) up_rad = up_rad + Dif_up(L,ft,iv+1) *(ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) @@ -804,7 +818,8 @@ subroutine PatchNormanRadiation (currentPatch, & ! Absorbed direct beam and diffuse do leaf layers do iv = 1, currentPatch%nrad(L,ft) Abs_dir_z(ft,iv) = ftweight(L,ft,iv)* forc_dir(radtype) * tr_dir_z(L,ft,iv) * & - (1.00_r8 - exp(-k_dir(ft) * total_lai_sai(L,ft,iv))) * f_abs(L,ft,iv,ib) + (1.00_r8 - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv)) )) * f_abs(L,ft,iv,ib) Abs_dif_z(ft,iv) = ftweight(L,ft,iv)* ((Dif_dn(L,ft,iv) + & Dif_up(L,ft,iv+1)) * (1.00_r8 - tr_dif_z(L,ft,iv)) * f_abs(L,ft,iv,ib)) end do From 3a2d88bc922aae34674ac33ffc19393a28eccfda Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Wed, 9 Jun 2021 13:56:25 -0700 Subject: [PATCH 312/578] Update FatesPlantHydraulicsMod.F90 Have made changes according to all the comments. --- biogeophys/FatesPlantHydraulicsMod.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 08270e1e8e..b5f1f57f07 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -959,11 +959,11 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! to the layer-by-layer absorbing root (which is now a hybrid compartment) ! ------------------------------------------------------------------------------ ccohort_hydr%v_troot = (1._r8-t2aroot_vol_donate_frac) * v_troot - + ! modified by Junyan May 29, 2020 ! Partition the total absorbing root lengths and volumes into the active soil layers ! We have a condition, where we may ignore the first layer ! ------------------------------------------------------------------------------ - ! modified by Junyan May 29, 2020 + ! norm = 1._r8 - & ! zeng2001_crootfr(roota, rootb,site_hydr%zi_rhiz(1)-site_hydr%dz_rhiz(1), site_hydr%zi_rhiz(nlevrhiz)) @@ -972,6 +972,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! z_fr_max/(1 + ((z_fr_max-z_fr_0)/z_fr_0)*exp(-frk*dbh_rev)) ! which is constrained by the maximum soil depth: site_hydr%zi_rhiz(nlevrhiz) + ! The dynamic root growth model by Junyan Ding, June 9, 2021 z_fr = min(site_hydr%zi_rhiz(nlevrhiz), z_fr_max/(1 + ((z_fr_max-z_fr_0)/z_fr_0)*exp(-frk*dbh_rev))) norm = 1._r8 - & zeng2001_crootfr(roota, rootb,site_hydr%zi_rhiz(1)-site_hydr%dz_rhiz(1), z_fr) From 31bf1cda37334129ce252a38db367b4cd5d78438 Mon Sep 17 00:00:00 2001 From: JunyanDing <43835195+JunyanDing@users.noreply.github.com> Date: Wed, 9 Jun 2021 13:58:52 -0700 Subject: [PATCH 313/578] Update FatesPlantHydraulicsMod.F90 --- biogeophys/FatesPlantHydraulicsMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index b5f1f57f07..d5dab90441 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -66,7 +66,6 @@ module FatesPlantHydraulicsMod 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 From 0010efeed963432008d4da73a11433bcacfc3ca0 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 11 Jun 2021 14:01:24 -0600 Subject: [PATCH 314/578] adding c_area to restart interface --- main/FatesRestartInterfaceMod.F90 | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index dc521649c8..acdbdab904 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -18,6 +18,7 @@ module FatesRestartInterfaceMod use FatesInterfaceTypesMod, only : bc_in_type use FatesInterfaceTypesMod, only : bc_out_type use FatesInterfaceTypesMod, only : hlm_use_planthydro + use FatesInterfaceTypesMod, only : hlm_use_sp use FatesInterfaceTypesMod, only : fates_maxElementsPerSite use EDCohortDynamicsMod, only : UpdateCohortBioPhysRates use FatesHydraulicsMemMod, only : nshell @@ -113,6 +114,7 @@ module FatesRestartInterfaceMod integer :: ir_frmort_co integer :: ir_smort_co integer :: ir_asmort_co + integer :: ir_c_area_co integer :: ir_daily_n_uptake_co integer :: ir_daily_p_uptake_co @@ -1008,6 +1010,15 @@ subroutine define_restart_vars(this, initialize_variables) hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_errfates_mbal) + ! Only register satellite phenology related restart variables if it is turned on! + + if(hlm_use_sp .eq. itrue) then + call this%set_restart_var(vname='fates_cohort_area', vtype=cohort_r8, & + long_name='area of the fates cohort', & + units='m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_c_area_co ) + end if + ! Only register hydraulics restart variables if it is turned on! @@ -1683,6 +1694,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_imortcflux_si => this%rvars(ir_imortcflux_si)%r81d, & rio_fmortcflux_cano_si => this%rvars(ir_fmortcflux_cano_si)%r81d, & rio_fmortcflux_usto_si => this%rvars(ir_fmortcflux_usto_si)%r81d) + !rio_c_area_co => this%rvars(ir_c_area_co)%r81d) totalCohorts = 0 @@ -1905,6 +1917,11 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_isnew_co(io_idx_co) = old_cohort endif + if (hlm_use_sp .eq. itrue) then + !rio_c_area_co(io_idx_co) = ccohort%c_area + this%rvars(ir_c_area_co)%r81d(io_idx_co) = ccohort%c_area + end if + if ( debug ) then write(fates_log(),*) 'CLTV offsetNumCohorts II ',io_idx_co, & cohortsperpatch @@ -2101,7 +2118,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end do end do end if - + enddo if ( debug ) then @@ -2322,6 +2339,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) use EDTypesMod, only : maxSWb use FatesInterfaceTypesMod, only : numpft use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch + use EDPhysiologyMod, only : assign_cohort_sp_properties use EDTypesMod, only : numWaterMem use EDTypesMod, only : num_vegtemp_mem use FatesSizeAgeTypeIndicesMod, only : get_age_class_index @@ -2474,6 +2492,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_imortcflux_si => this%rvars(ir_imortcflux_si)%r81d, & rio_fmortcflux_cano_si => this%rvars(ir_fmortcflux_cano_si)%r81d, & rio_fmortcflux_usto_si => this%rvars(ir_fmortcflux_usto_si)%r81d) + !rio_c_area_co => this%rvars(ir_c_area_co)%r81d) totalcohorts = 0 @@ -2678,6 +2697,11 @@ subroutine get_restart_vectors(this, nc, nsites, sites) n_hypool_ag, & ir_hydro_err_growturn_ag_covec,io_idx_co) end if + + if (hlm_use_sp .eq. itrue) then + !ccohort%c_area = rio_c_area_co(io_idx_co) + ccohort%c_area = this%rvars(ir_c_area_co)%r81d(io_idx_co) + end if io_idx_co = io_idx_co + 1 From e3a884f47c4bafe61a3f1f44702a9b59e8bbcad4 Mon Sep 17 00:00:00 2001 From: rgknox Date: Thu, 17 Jun 2021 08:22:49 -0700 Subject: [PATCH 315/578] These fixes are needed to enable b4b restarts in elm --- biogeochem/EDPatchDynamicsMod.F90 | 10 +++++++++ biogeochem/FatesSoilBGCFluxMod.F90 | 33 ++++++++---------------------- main/FatesRestartInterfaceMod.F90 | 17 +++++++++++++++ 3 files changed, 36 insertions(+), 24 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 472c8eb48c..e5bd982225 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -1384,6 +1384,16 @@ subroutine TransLitterNewPatch(currentSite, & enddo + do pft = 1,numpft + + new_litt%seed_decay(pft) = new_litt%seed_decay(pft) + & + curr_litt%seed_decay(pft)*patch_site_areadis/newPatch%area + + new_litt%seed_germ_decay(pft) = new_litt%seed_germ_decay(pft) + & + curr_litt%seed_germ_decay(pft)*patch_site_areadis/newPatch%area + + end do + ! ----------------------------------------------------------------------------- ! Distribute the existing litter that was already in place on the donor ! patch. Some of this burns and is sent to the atmosphere, and some goes to the diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index a09dc3725b..c96728f661 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -826,9 +826,9 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) select case (element_list(el)) case (carbon12_element) - bc_out%litt_flux_cel_c_si(:) = 0._r8 - bc_out%litt_flux_lig_c_si(:) = 0._r8 - bc_out%litt_flux_lab_c_si(:) = 0._r8 + bc_out%litt_flux_cel_c_si(:) = 0.0_r8 + bc_out%litt_flux_lig_c_si(:) = 0.0_r8 + bc_out%litt_flux_lab_c_si(:) = 0.0_r8 flux_cel_si => bc_out%litt_flux_cel_c_si(:) flux_lab_si => bc_out%litt_flux_lab_c_si(:) flux_lig_si => bc_out%litt_flux_lig_c_si(:) @@ -861,31 +861,16 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) end select + ! Add efflux to the litter pool. kg/ha/day -> kg/m2/day + do id = 1,nlev_eff_decomp + flux_lab_si(id) = flux_lab_si(id) + & + sum(csite%flux_diags(el)%nutrient_efflux_scpf)*surface_prof(id)*area_inv + end do + currentPatch => csite%oldest_patch do while (associated(currentPatch)) - ! If there is any efflux (from stores overflowing) - ! than pass that to the labile litter pool - - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) - if(.not.currentCohort%isnew)then - if(element_list(el).eq.carbon12_element) then - efflux_ptr => currentCohort%daily_c_efflux - elseif(element_list(el).eq.nitrogen_element) then - efflux_ptr => currentCohort%daily_n_efflux - elseif(element_list(el).eq.phosphorus_element) then - efflux_ptr => currentCohort%daily_p_efflux - end if - do id = 1,nlev_eff_decomp - flux_lab_si(id) = flux_lab_si(id) + & - efflux_ptr*currentCohort%n* AREA_INV * surface_prof(id) - end do - end if - currentCohort => currentCohort%shorter - end do - ! Set a pointer to the litter object ! for the current element on the current ! patch diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 0b621dec0a..621e8f81ce 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -149,6 +149,8 @@ module FatesRestartInterfaceMod integer :: ir_fnrt_litt integer :: ir_seed_litt integer :: ir_seedgerm_litt + integer :: ir_seed_decay_litt + integer :: ir_seedgerm_decay_litt integer :: ir_seed_prod_co integer :: ir_livegrass_pa integer :: ir_age_pa @@ -936,6 +938,17 @@ subroutine define_restart_vars(this, initialize_variables) units='kg/m2', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seedgerm_litt) + + call this%RegisterCohortVector(symbol_base='fates_seed_decay', vtype=cohort_r8, & + long_name_base='seed bank (non-germinated)', & + units='kg/m2', veclength=num_elements, flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seed_decay_litt) + + call this%RegisterCohortVector(symbol_base='fates_seedgerm_decay', vtype=cohort_r8, & + long_name_base='seed bank (germinated)', & + units='kg/m2', veclength=num_elements, flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seedgerm_decay_litt) + call this%RegisterCohortVector(symbol_base='fates_ag_cwd_frag', vtype=cohort_r8, & long_name_base='above ground CWD frag flux', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & @@ -1954,6 +1967,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) do i = 1,numpft this%rvars(ir_seed_litt+el)%r81d(io_idx_pa_pft) = litt%seed(i) this%rvars(ir_seedgerm_litt+el)%r81d(io_idx_pa_pft) = litt%seed_germ(i) + this%rvars(ir_seed_decay_litt+el)%r81d(io_idx_pa_pft) = litt%seed_decay(i) + this%rvars(ir_seedgerm_decay_litt+el)%r81d(io_idx_pa_pft) = litt%seed_germ_decay(i) io_idx_pa_pft = io_idx_pa_pft + 1 end do @@ -2723,6 +2738,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) do i = 1,numpft litt%seed(i) = this%rvars(ir_seed_litt+el)%r81d(io_idx_pa_pft) litt%seed_germ(i) = this%rvars(ir_seedgerm_litt+el)%r81d(io_idx_pa_pft) + litt%seed_decay(i) = this%rvars(ir_seed_decay_litt+el)%r81d(io_idx_pa_pft) + litt%seed_germ_decay(i) = this%rvars(ir_seedgerm_decay_litt+el)%r81d(io_idx_pa_pft) io_idx_pa_pft = io_idx_pa_pft + 1 end do From 07330264d89a5837bf10a9adae0fc8d0d6c8b769 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 22 Jun 2021 10:55:52 -0400 Subject: [PATCH 316/578] Updated metadata on the restart variables fates_seedgerm_frag and fates_seed_frag --- main/FatesRestartInterfaceMod.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 0f49b1e06e..7ae00ed0b2 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -947,13 +947,13 @@ subroutine define_restart_vars(this, initialize_variables) hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seedgerm_litt) - call this%RegisterCohortVector(symbol_base='fates_seed_decay', vtype=cohort_r8, & - long_name_base='seed bank (non-germinated)', & + call this%RegisterCohortVector(symbol_base='fates_seed_frag', vtype=cohort_r8, & + long_name_base='seed bank fragmentation flux (non-germinated)', & units='kg/m2', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seed_decay_litt) - call this%RegisterCohortVector(symbol_base='fates_seedgerm_decay', vtype=cohort_r8, & - long_name_base='seed bank (germinated)', & + call this%RegisterCohortVector(symbol_base='fates_seedgerm_frag', vtype=cohort_r8, & + long_name_base='seed bank fragmentation flux (germinated)', & units='kg/m2', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seedgerm_decay_litt) From 6aaabe91e072b136d696b75faa9cb672b574c11a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 22 Jun 2021 12:04:16 -0600 Subject: [PATCH 317/578] Revered labile fluxes to HLM from efflux to be from cohort level not the diagnostic. The diagnostic is not restartable --- biogeochem/FatesSoilBGCFluxMod.F90 | 33 +++++++++++++++++++++++------- 1 file changed, 26 insertions(+), 7 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 9ced535220..9f210e8404 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -1022,16 +1022,35 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) end select - ! Add efflux to the litter pool. kg/ha/day -> kg/m2/day - do id = 1,nlev_eff_decomp - flux_lab_si(id) = flux_lab_si(id) + & - sum(csite%flux_diags(el)%nutrient_efflux_scpf)*surface_prof(id)*area_inv - end do - - currentPatch => csite%oldest_patch do while (associated(currentPatch)) + ! If there is any efflux (from stores overflowing) + ! than pass that to the labile litter pool + + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + if(.not.currentCohort%isnew)then + if(element_list(el).eq.carbon12_element) then + efflux_ptr => currentCohort%daily_c_efflux + elseif(element_list(el).eq.nitrogen_element) then + efflux_ptr => currentCohort%daily_n_efflux + elseif(element_list(el).eq.phosphorus_element) then + efflux_ptr => currentCohort%daily_p_efflux + end if + + ! Unit conversion + ! kg/plant/day * plant/ha * ha/m2 -> kg/m2/day + + do id = 1,nlev_eff_decomp + flux_lab_si(id) = flux_lab_si(id) + & + efflux_ptr * currentCohort%n* AREA_INV * surface_prof(id) + end do + end if + currentCohort => currentCohort%shorter + end do + + ! Set a pointer to the litter object ! for the current element on the current ! patch From 4e81d3eb810241dd6410bdd12c6fca0b513859fc Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 23 Jun 2021 03:53:40 -0600 Subject: [PATCH 318/578] reformatted esai statemnts, made laifrac=1 --- biogeophys/EDSurfaceAlbedoMod.F90 | 24 ++++++++---------------- 1 file changed, 8 insertions(+), 16 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 71af0c1b31..a8950bbce4 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -301,16 +301,14 @@ subroutine PatchNormanRadiation (currentPatch, & do ib = 1,hlm_numSWb !vis, nir ! if(total_lai_sai(L,ft,iv).gt.0._r8)then frac_lai = currentPatch%elai_profile(L,ft,iv)/& - (currentPatch%elai_profile(L,ft,iv)+ & - currentPatch%esai_profile(L,ft,iv)) + (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) + frac_lai = 1.0_r8 ! make the same as previous codebase, in theory. frac_sai = 1.0_r8 - frac_lai f_abs(L,ft,iv,ib) = 1.0_r8 - (frac_lai*(rhol(ft,ib) + taul(ft,ib))+& frac_sai*(rhos(ft,ib) + taus(ft,ib))) rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) tau_layer(L,ft,iv,ib)=frac_lai*taul(ft,ib)+frac_sai*taus(ft,ib) - rho_layer(L,ft,iv,ib)= rhol(ft,ib) - tau_layer(L,ft,iv,ib)=taul(ft,ib) - f_abs(L,ft,iv,ib) = 1.0_r8 -(taul(ft,ib)+rhol(ft,ib)) + f_abs(L,ft,iv,ib) = 1.0_r8 -(taul(ft,ib)+rhol(ft,ib)) ! else ! this is an empty layer, so all the light goes through. ! rho_layer(L,ft,iv,ib)=0.0_r8 @@ -390,8 +388,7 @@ subroutine PatchNormanRadiation (currentPatch, & gdir = phi1b(ft) + phi2b(ft) * sin(angle) tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-clumping_index(ft) * & gdir / sin(angle) * & - (currentPatch%elai_profile(L,ft,iv)+ & - currentPatch%esai_profile(L,ft,iv))) * & + (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv))) * & sin(angle)*cos(angle) end do @@ -415,12 +412,10 @@ subroutine PatchNormanRadiation (currentPatch, & do iv = 1,currentPatch%nrad(L,ft) if( currentPatch%elai_profile(L,ft,iv) & +currentPatch%esai_profile(L,ft,iv).gt.0._r8.and.ftweight(L,ft,iv).le.0._r8)then - write(*,*) 'lai in layer by no weight' endif - laisum = laisum+currentPatch%elai_profile(L,ft,iv) & - +currentPatch%esai_profile(L,ft,iv) + laisum = laisum+currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) lai_change(L,ft,iv) = 0.0_r8 if (( ftweight(L,ft,iv+1) > 0.0_r8 ) .and. ( ftweight(L,ft,iv+1) < ftweight(L,ft,iv) ))then !where there is a partly empty leaf layer, some fluxes go straight through. @@ -475,11 +470,9 @@ subroutine PatchNormanRadiation (currentPatch, & ! Now use cumulative lai at center of layer. ! Same as tr_dir_z calcualtions, but in the middle of the layer? FIX(RF,032414)-WHY? if (iv == 1) then - laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+ & - currentPatch%esai_profile(L,ft,iv)) + laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) else - laisum = laisum + (currentPatch%elai_profile(L,ft,iv)+ & - currentPatch%esai_profile(L,ft,iv)) + laisum = laisum + (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) end if @@ -775,8 +768,7 @@ subroutine PatchNormanRadiation (currentPatch, & !reflection of the lower layer, up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) up_rad = up_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - exp(-k_dir(ft) * & - (currentPatch%elai_profile(L,ft,iv)+ & - currentPatch%esai_profile(L,ft,iv)) ))* rho_layer(L,ft,iv,ib) + (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) ))* rho_layer(L,ft,iv,ib) up_rad = up_rad + Dif_up(L,ft,iv+1) * tran_dif(L,ft,iv,ib) up_rad = up_rad * ftweight(L,ft,iv)/ftweight(L,ft,1) up_rad = up_rad + Dif_up(L,ft,iv+1) *(ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) From 89729a26e3cfd11ebb56d57c6af5a9bec59a2d49 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 23 Jun 2021 04:10:10 -0600 Subject: [PATCH 319/578] whitespace changes --- biogeophys/EDSurfaceAlbedoMod.F90 | 15 +++++---------- 1 file changed, 5 insertions(+), 10 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index a8950bbce4..63df6dd803 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -299,7 +299,6 @@ subroutine PatchNormanRadiation (currentPatch, & currentPatch%canopy_mask(L,ft) = 1 ! layer level reflectance qualities do ib = 1,hlm_numSWb !vis, nir -! if(total_lai_sai(L,ft,iv).gt.0._r8)then frac_lai = currentPatch%elai_profile(L,ft,iv)/& (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) frac_lai = 1.0_r8 ! make the same as previous codebase, in theory. @@ -310,11 +309,6 @@ subroutine PatchNormanRadiation (currentPatch, & tau_layer(L,ft,iv,ib)=frac_lai*taul(ft,ib)+frac_sai*taus(ft,ib) f_abs(L,ft,iv,ib) = 1.0_r8 -(taul(ft,ib)+rhol(ft,ib)) -! else ! this is an empty layer, so all the light goes through. -! rho_layer(L,ft,iv,ib)=0.0_r8 -! tau_layer(L,ft,iv,ib)=1.0_r8 -! end if - end do !ib endif end do !iv @@ -410,12 +404,12 @@ subroutine PatchNormanRadiation (currentPatch, & laisum = 0.00_r8 !total direct beam getting to the bottom of the top canopy. do iv = 1,currentPatch%nrad(L,ft) + laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) if( currentPatch%elai_profile(L,ft,iv) & +currentPatch%esai_profile(L,ft,iv).gt.0._r8.and.ftweight(L,ft,iv).le.0._r8)then write(*,*) 'lai in layer by no weight' endif - laisum = laisum+currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) lai_change(L,ft,iv) = 0.0_r8 if (( ftweight(L,ft,iv+1) > 0.0_r8 ) .and. ( ftweight(L,ft,iv+1) < ftweight(L,ft,iv) ))then !where there is a partly empty leaf layer, some fluxes go straight through. @@ -470,9 +464,9 @@ subroutine PatchNormanRadiation (currentPatch, & ! Now use cumulative lai at center of layer. ! Same as tr_dir_z calcualtions, but in the middle of the layer? FIX(RF,032414)-WHY? if (iv == 1) then - laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) + laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) else - laisum = laisum + (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) + laisum = laisum + currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv) end if @@ -768,7 +762,8 @@ subroutine PatchNormanRadiation (currentPatch, & !reflection of the lower layer, up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) up_rad = up_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - exp(-k_dir(ft) * & - (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) ))* rho_layer(L,ft,iv,ib) + (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) ))* & + rho_layer(L,ft,iv,ib) up_rad = up_rad + Dif_up(L,ft,iv+1) * tran_dif(L,ft,iv,ib) up_rad = up_rad * ftweight(L,ft,iv)/ftweight(L,ft,1) up_rad = up_rad + Dif_up(L,ft,iv+1) *(ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) From f7967496324a56bf2ab4f2f72b92d77edb1798a0 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 23 Jun 2021 04:15:12 -0600 Subject: [PATCH 320/578] more whitespace changes --- biogeophys/EDSurfaceAlbedoMod.F90 | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 63df6dd803..d350e0a511 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -382,7 +382,7 @@ subroutine PatchNormanRadiation (currentPatch, & gdir = phi1b(ft) + phi2b(ft) * sin(angle) tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-clumping_index(ft) * & gdir / sin(angle) * & - (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv))) * & + (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))) * & sin(angle)*cos(angle) end do @@ -403,14 +403,9 @@ subroutine PatchNormanRadiation (currentPatch, & endif laisum = 0.00_r8 !total direct beam getting to the bottom of the top canopy. - do iv = 1,currentPatch%nrad(L,ft) + do iv = 1,currentPatch%nrad(L,ft) laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) - if( currentPatch%elai_profile(L,ft,iv) & - +currentPatch%esai_profile(L,ft,iv).gt.0._r8.and.ftweight(L,ft,iv).le.0._r8)then - write(*,*) 'lai in layer by no weight' - endif - - lai_change(L,ft,iv) = 0.0_r8 + lai_change(L,ft,iv) = 0.0_r8 if (( ftweight(L,ft,iv+1) > 0.0_r8 ) .and. ( ftweight(L,ft,iv+1) < ftweight(L,ft,iv) ))then !where there is a partly empty leaf layer, some fluxes go straight through. lai_change(L,ft,iv) = ftweight(L,ft,iv)-ftweight(L,ft,iv+1) @@ -464,9 +459,9 @@ subroutine PatchNormanRadiation (currentPatch, & ! Now use cumulative lai at center of layer. ! Same as tr_dir_z calcualtions, but in the middle of the layer? FIX(RF,032414)-WHY? if (iv == 1) then - laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) + laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) else - laisum = laisum + currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv) + laisum = laisum + currentPatch%elai_profile(L,ft,iv)+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currentPatch%esai_profile(L,ft,iv) end if @@ -762,7 +757,7 @@ subroutine PatchNormanRadiation (currentPatch, & !reflection of the lower layer, up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) up_rad = up_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - exp(-k_dir(ft) * & - (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) ))* & + (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))))* & rho_layer(L,ft,iv,ib) up_rad = up_rad + Dif_up(L,ft,iv+1) * tran_dif(L,ft,iv,ib) up_rad = up_rad * ftweight(L,ft,iv)/ftweight(L,ft,1) @@ -810,7 +805,6 @@ subroutine PatchNormanRadiation (currentPatch, & Abs_dif_z(ft,iv) = ftweight(L,ft,iv)* ((Dif_dn(L,ft,iv) + & Dif_up(L,ft,iv+1)) * (1.00_r8 - tr_dif_z(L,ft,iv)) * f_abs(L,ft,iv,ib)) end do - ! Absorbed direct beam and diffuse do soil if (L == currentPatch%NCL_p)then From 6919a2f407a6cab594f4c27b6cc1543997fdda9c Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 23 Jun 2021 04:17:12 -0600 Subject: [PATCH 321/578] revert ftid change --- biogeophys/EDSurfaceAlbedoMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index d350e0a511..69e4cf2f33 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -286,7 +286,7 @@ subroutine PatchNormanRadiation (currentPatch, & fabd_parb_out(1:hlm_numSWb) = 0.0_r8 fabi_parb_out(1:hlm_numSWb) = 0.0_r8 ftdd_parb_out(1:hlm_numSWb) = 1.0_r8 - ftid_parb_out(1:hlm_numSWb) = 0.0_r8 + ftid_parb_out(1:hlm_numSWb) = 1.0_r8 ftii_parb_out(1:hlm_numSWb) = 1.0_r8 ! Is this pft/canopy layer combination present in this patch? From 17b76887016de8e865298ec63e7a596b0fb21a6c Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 23 Jun 2021 05:02:52 -0600 Subject: [PATCH 322/578] removed fraclai=1 --- biogeophys/EDSurfaceAlbedoMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 69e4cf2f33..4073366560 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -301,7 +301,7 @@ subroutine PatchNormanRadiation (currentPatch, & do ib = 1,hlm_numSWb !vis, nir frac_lai = currentPatch%elai_profile(L,ft,iv)/& (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) - frac_lai = 1.0_r8 ! make the same as previous codebase, in theory. + !frac_lai = 1.0_r8 ! make the same as previous codebase, in theory. frac_sai = 1.0_r8 - frac_lai f_abs(L,ft,iv,ib) = 1.0_r8 - (frac_lai*(rhol(ft,ib) + taul(ft,ib))+& frac_sai*(rhos(ft,ib) + taus(ft,ib))) @@ -461,7 +461,7 @@ subroutine PatchNormanRadiation (currentPatch, & if (iv == 1) then laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) else - laisum = laisum + currentPatch%elai_profile(L,ft,iv)+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currentPatch%esai_profile(L,ft,iv) + laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) end if From 924c551a47c229f8b2cc44ad305cca5e7ab92435 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 23 Jun 2021 15:19:06 -0600 Subject: [PATCH 323/578] remove f_abs line, add fraclai check an zero out new indicies --- biogeophys/EDSurfaceAlbedoMod.F90 | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 4073366560..d8d4540463 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -290,7 +290,9 @@ subroutine PatchNormanRadiation (currentPatch, & ftii_parb_out(1:hlm_numSWb) = 1.0_r8 ! Is this pft/canopy layer combination present in this patch? - + rho_layer(:,:,:,:)=0.0_r8 + tau_layer(:,:,:,:)=0.0_r8 + f_abs(:,:,:,:)=0.0_r8 do L = 1,nclmax do ft = 1,numpft currentPatch%canopy_mask(L,ft) = 0 @@ -299,15 +301,18 @@ subroutine PatchNormanRadiation (currentPatch, & currentPatch%canopy_mask(L,ft) = 1 ! layer level reflectance qualities do ib = 1,hlm_numSWb !vis, nir - frac_lai = currentPatch%elai_profile(L,ft,iv)/& - (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) + if(currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv).gt.0.0_r8) then + frac_lai = currentPatch%elai_profile(L,ft,iv)/& + (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) + else + frac_lai = 1.0_r8 + endif !frac_lai = 1.0_r8 ! make the same as previous codebase, in theory. frac_sai = 1.0_r8 - frac_lai f_abs(L,ft,iv,ib) = 1.0_r8 - (frac_lai*(rhol(ft,ib) + taul(ft,ib))+& frac_sai*(rhos(ft,ib) + taus(ft,ib))) rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) tau_layer(L,ft,iv,ib)=frac_lai*taul(ft,ib)+frac_sai*taus(ft,ib) - f_abs(L,ft,iv,ib) = 1.0_r8 -(taul(ft,ib)+rhol(ft,ib)) end do !ib endif From 7fe7af7e7298db25e55d45e5cc43157a79ea38db Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 23 Jun 2021 15:49:12 -0700 Subject: [PATCH 324/578] adding instantaneous gpp and npp to restart --- main/FatesRestartInterfaceMod.F90 | 670 +++++++++++++++--------------- 1 file changed, 342 insertions(+), 328 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index acdbdab904..50984091ed 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -15,7 +15,7 @@ module FatesRestartInterfaceMod use FatesIOVariableKindMod, only : fates_io_variable_kind_type use FatesRestartVariableMod, only : fates_restart_variable_type use FatesInterfaceTypesMod, only : nlevcoage - use FatesInterfaceTypesMod, only : bc_in_type + use FatesInterfaceTypesMod, only : bc_in_type use FatesInterfaceTypesMod, only : bc_out_type use FatesInterfaceTypesMod, only : hlm_use_planthydro use FatesInterfaceTypesMod, only : hlm_use_sp @@ -72,11 +72,11 @@ module FatesRestartInterfaceMod ! ls: layer sublayer dimension (fine discretization of upper,lower) ! wm: the number of memory slots for water (currently 10) ! ------------------------------------------------------------- - - + + ! Indices to the restart variable object - integer :: ir_npatch_si + integer :: ir_npatch_si integer :: ir_cd_status_si integer :: ir_dd_status_si integer :: ir_nchill_days_si @@ -115,6 +115,8 @@ module FatesRestartInterfaceMod integer :: ir_smort_co integer :: ir_asmort_co integer :: ir_c_area_co + integer :: ir_gpp_tstep_co + integer :: ir_npp_tstep_co integer :: ir_daily_n_uptake_co integer :: ir_daily_p_uptake_co @@ -125,7 +127,7 @@ module FatesRestartInterfaceMod integer :: ir_daily_p_demand_co integer :: ir_daily_n_need_co integer :: ir_daily_p_need_co - + !Logging integer :: ir_lmort_direct_co integer :: ir_lmort_collateral_co @@ -206,7 +208,7 @@ module FatesRestartInterfaceMod ! Hydraulic indices integer :: ir_hydro_th_ag_covec integer :: ir_hydro_th_troot - integer :: ir_hydro_th_aroot_covec + integer :: ir_hydro_th_aroot_covec integer :: ir_hydro_liqvol_shell_si integer :: ir_hydro_err_growturn_aroot integer :: ir_hydro_err_growturn_ag_covec @@ -223,12 +225,12 @@ module FatesRestartInterfaceMod ! integer constants for storing logical data integer, parameter, public :: old_cohort = 0 - integer, parameter, public :: new_cohort = 1 + integer, parameter, public :: new_cohort = 1 real(r8), parameter, public :: flushinvalid = -9999.0 real(r8), parameter, public :: flushzero = 0.0 real(r8), parameter, public :: flushone = 1.0 - + ! Local debug flag logical, parameter, public :: debug=.false. @@ -255,20 +257,20 @@ module FatesRestartInterfaceMod ! Instanteate one registry of the different dimension/kinds (dk) ! All output variables will have a pointer to one of these dk's type(fates_io_variable_kind_type) :: dim_kinds(fates_restart_num_dim_kinds) - + ! This is a structure that explains where FATES patch boundaries ! on each thread point to in the host IO array, this structure is ! allocated by number of threads. This could be dynamically ! allocated, but is unlikely to change...? ! Note: history io also instanteates fates_io_dimension_type type(fates_io_dimension_type) :: dim_bounds(fates_restart_num_dimensions) - + type(restart_map_type), pointer :: restart_map(:) integer, private :: cohort_index_, column_index_ contains - + ! public functions procedure :: Init procedure :: SetThreadBoundsEach @@ -281,7 +283,7 @@ module FatesRestartInterfaceMod procedure :: create_patchcohort_structure procedure :: get_restart_vectors procedure :: update_3dpatch_radiation - + ! private work functions procedure, private :: init_dim_kinds_maps procedure, private :: set_dim_indices @@ -297,15 +299,15 @@ module FatesRestartInterfaceMod end type fates_restart_interface_type - + contains ! ===================================================================================== - + subroutine Init(this, num_threads, fates_bounds) - + use FatesIODimensionsMod, only : fates_bounds_type, column, cohort implicit none @@ -330,13 +332,13 @@ subroutine Init(this, num_threads, fates_bounds) ! Allocate the mapping between FATES indices and the IO indices allocate(this%restart_map(num_threads)) - - end subroutine Init + + end subroutine Init ! ====================================================================== subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) - + use FatesIODimensionsMod, only : fates_bounds_type implicit none @@ -347,25 +349,25 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) type(fates_bounds_type), intent(in) :: thread_bounds integer :: index - + index = this%cohort_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%cohort_begin, thread_bounds%cohort_end) - + index = this%column_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%column_begin, thread_bounds%column_end) - + end subroutine SetThreadBoundsEach ! =================================================================================== subroutine assemble_restart_output_types(this) - + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int implicit none - + class(fates_restart_interface_type), intent(inout) :: this call this%init_dim_kinds_maps() @@ -379,7 +381,7 @@ subroutine assemble_restart_output_types(this) end subroutine assemble_restart_output_types ! =================================================================================== - + subroutine set_dim_indices(this, dk_name, idim, dim_index) use FatesIOVariableKindMod , only : iotype_index @@ -428,13 +430,13 @@ subroutine set_cohort_index(this, index) integer, intent(in) :: index this%cohort_index_ = index end subroutine set_cohort_index - + integer function cohort_index(this) implicit none class(fates_restart_interface_type), intent(in) :: this cohort_index = this%cohort_index_ end function cohort_index - + ! ======================================================================= subroutine set_column_index(this, index) @@ -443,17 +445,17 @@ subroutine set_column_index(this, index) integer, intent(in) :: index this%column_index_ = index end subroutine set_column_index - + integer function column_index(this) implicit none class(fates_restart_interface_type), intent(in) :: this column_index = this%column_index_ end function column_index - + ! ======================================================================= subroutine init_dim_kinds_maps(this) - + ! ---------------------------------------------------------------------------------- ! This subroutine simply initializes the structures that define the different ! array and type formats for different IO variables @@ -468,9 +470,9 @@ subroutine init_dim_kinds_maps(this) ! ! ---------------------------------------------------------------------------------- use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int - + implicit none - + ! Arguments class(fates_restart_interface_type), intent(inout) :: this @@ -499,17 +501,17 @@ end subroutine init_dim_kinds_maps ! ==================================================================================== integer function num_restart_vars(this) - + implicit none class(fates_restart_interface_type), intent(in) :: this num_restart_vars = this%num_restart_vars_ - + end function num_restart_vars - + ! ==================================================================================== - + subroutine initialize_restart_vars(this) implicit none @@ -522,16 +524,16 @@ subroutine initialize_restart_vars(this) ! Allocate the list of restart output variable objects allocate(this%rvars(this%num_restart_vars())) - + ! construct the object that defines all of the IO variables call this%define_restart_vars(initialize_variables=.true.) - + end subroutine initialize_restart_vars ! ====================================================================================== subroutine flush_rvars(this,nc) - + class(fates_restart_interface_type) :: this integer,intent(in) :: nc @@ -544,17 +546,17 @@ subroutine flush_rvars(this,nc) call rvar%Flush(nc, this%dim_bounds, this%dim_kinds) end associate end do - + end subroutine flush_rvars - + ! ==================================================================================== - + subroutine define_restart_vars(this, initialize_variables) - + ! --------------------------------------------------------------------------------- - ! + ! ! REGISTRY OF RESTART OUTPUT VARIABLES ! ! Please add any restart variables to this registry. This registry will handle @@ -562,19 +564,19 @@ subroutine define_restart_vars(this, initialize_variables) ! variables. Note that restarts are only using 1D vectors in ALM and CLM. If you ! have a multi-dimensional variable that is below the cohort scale, then pack ! that variable into a cohort-sized output array by giving it a vtype "cohort_r8" - ! or "cohort_int". + ! or "cohort_int". ! ! Unlike history variables, restarts flush to zero. ! --------------------------------------------------------------------------------- - + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_int, cohort_r8 implicit none - + class(fates_restart_interface_type), intent(inout) :: this logical, intent(in) :: initialize_variables ! are we 'count'ing or 'initializ'ing? integer :: ivar - - + + ivar=0 ! ----------------------------------------------------------------------------------- @@ -620,7 +622,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_acc_nesterov_id', vtype=site_r8, & long_name='a nesterov index accumulator', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_acc_ni_si ) - + call this%set_restart_var(vname='fates_gdd_site', vtype=site_r8, & long_name='growing degree days at each site', units='degC days', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gdd_si ) @@ -646,7 +648,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_solar_zenith_flag_pa', vtype=cohort_int, & long_name='switch specifying if zenith is positive', units='unitless', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_solar_zenith_flag_pa ) - + call this%set_restart_var(vname='fates_solar_zenith_angle_pa', vtype=cohort_r8, & long_name='the angle of the solar zenith for each patch', units='radians', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_solar_zenith_angle_pa ) @@ -683,7 +685,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_coage', vtype=cohort_r8, & long_name='ed cohort - age in days', units='days', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_coage_co ) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_coage_co ) call this%set_restart_var(vname='fates_height', vtype=cohort_r8, & long_name='ed cohort - plant height', units='m', flushval = flushzero, & @@ -698,12 +700,12 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - target sapwood biomass set from prev year', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_sapwmemory_co ) - + call this%set_restart_var(vname='fates_structmemory', vtype=cohort_r8, & long_name='ed cohort - target structural biomass set from prev year', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_structmemory_co ) - + call this%set_restart_var(vname='fates_nplant', vtype=cohort_r8, & long_name='ed cohort - number of plants in the cohort', & units='/patch', flushval = flushzero, & @@ -743,7 +745,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - maintenance respiration deficit', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_resp_m_def_co ) - + call this%set_restart_var(vname='fates_bmort', vtype=cohort_r8, & long_name='ed cohort - background mortality rate', & units='/year', flushval = flushzero, & @@ -778,7 +780,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates cohort- daily nitrogen efflux', & units='kg/plant/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_efflux_co ) - + call this%set_restart_var(vname='fates_daily_p_efflux', vtype=cohort_r8, & long_name='fates cohort- daily phosphorus efflux', & units='kg/plant/day', flushval = flushzero, & @@ -803,7 +805,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates cohort- daily nitrogen need', & units='kgN/plant/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_need_co ) - + call this%set_restart_var(vname='fates_frmort', vtype=cohort_r8, & long_name='ed cohort - freezing mortality rate', & units='/year', flushval = flushzero, & @@ -816,7 +818,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_asmort', vtype=cohort_r8, & long_name='ed cohort - age senescence mortality rate', & - units = '/year', flushval = flushzero, & + units = '/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_asmort_co ) call this%set_restart_var(vname='fates_lmort_direct', vtype=cohort_r8, & @@ -827,12 +829,12 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_lmort_collateral', vtype=cohort_r8, & long_name='ed cohort - collateral mortality rate', & units='%/event', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_collateral_co ) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_collateral_co ) + call this%set_restart_var(vname='fates_lmort_in', vtype=cohort_r8, & long_name='ed cohort - mechanical mortality rate', & units='%/event', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_infra_co ) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_infra_co ) call this%set_restart_var(vname='fates_ddbhdt', vtype=cohort_r8, & long_name='ed cohort - differential: ddbh/dt', & @@ -916,23 +918,23 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_ag_cwd', vtype=cohort_r8, & long_name_base='above ground CWD', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_litt) call this%RegisterCohortVector(symbol_base='fates_bg_cwd', vtype=cohort_r8, & long_name_base='below ground CWD', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_litt) call this%RegisterCohortVector(symbol_base='fates_leaf_fines', vtype=cohort_r8, & long_name_base='above ground leaf litter', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litt) call this%RegisterCohortVector(symbol_base='fates_fnrt_fines', vtype=cohort_r8, & long_name_base='fine root litter', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fnrt_litt) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fnrt_litt) + call this%RegisterCohortVector(symbol_base='fates_seed', vtype=cohort_r8, & long_name_base='seed bank (non-germinated)', & units='kg/m2', veclength=num_elements, flushval = flushzero, & @@ -946,18 +948,18 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_ag_cwd_frag', vtype=cohort_r8, & long_name_base='above ground CWD frag flux', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_frag_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_frag_litt) call this%RegisterCohortVector(symbol_base='fates_bg_cwd_frag', vtype=cohort_r8, & long_name_base='below ground CWD frag flux', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_frag_litt) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_frag_litt) + call this%RegisterCohortVector(symbol_base='fates_lfines_frag', vtype=cohort_r8, & long_name_base='frag flux from leaf fines', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lfines_frag_litt) - + call this%RegisterCohortVector(symbol_base='fates_rfines_frag', vtype=cohort_r8, & long_name_base='frag flux from froot fines', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & @@ -996,20 +998,20 @@ subroutine define_restart_vars(this, initialize_variables) units='kg/day/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_uptake_flxdg) - + ! Site level Mass Balance State Accounting call this%RegisterCohortVector(symbol_base='fates_oldstock', vtype=site_r8, & long_name_base='Previous total mass of all fates state variables', & units='kg/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_oldstock_mbal) - + call this%RegisterCohortVector(symbol_base='fates_errfates', vtype=site_r8, & long_name_base='Previous total mass of error fates state variables', & units='kg/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_errfates_mbal) - - + + ! Only register satellite phenology related restart variables if it is turned on! if(hlm_use_sp .eq. itrue) then @@ -1017,11 +1019,19 @@ subroutine define_restart_vars(this, initialize_variables) long_name='area of the fates cohort', & units='m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_c_area_co ) + call this%set_restart_var(vname='fates_gpp_tstep', vtype=cohort_r8, & + long_name='instantaneous fates gross primary production', & + units='kgC/indiv/timestep', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gpp_tstep_co ) + call this%set_restart_var(vname='fates_npp_tstep', vtype=cohort_r8, & + long_name='instantaneous fates net primary production', & + units='kgC/indiv/timestep', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_tstep_co ) end if ! Only register hydraulics restart variables if it is turned on! - + if(hlm_use_planthydro==itrue) then if ( fates_maxElementsPerSite < (nshell * nlevsoi_hyd_max) ) then @@ -1039,32 +1049,32 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_hydro_th_ag', vtype=cohort_r8, & long_name_base='water in aboveground compartments', & units='kg/plant', veclength=n_hypool_ag, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_ag_covec) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_ag_covec) + 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) - + 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', & units='kg/plant', veclength=nlevsoi_hyd_max, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_aroot_covec) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_aroot_covec) 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) + 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', & units='kg/plant', veclength=n_hypool_ag, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_ag_covec) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_ag_covec) 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) + 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, & @@ -1077,13 +1087,13 @@ subroutine define_restart_vars(this, initialize_variables) long_name='Site level water mass used for new recruits', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_recruit_si ) - + ! Site-level water bound in dead plants call this%set_restart_var(vname='fates_hydro_dead_h2o', vtype=site_r8, & long_name='Site level water bound in dead plants', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_dead_si ) - + ! Site-level water balance error due to growth/turnover call this%set_restart_var(vname='fates_hydro_growturn_err', vtype=site_r8, & long_name='Site level error for hydraulics due to growth/turnover', & @@ -1101,7 +1111,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='Site level error for hydrodynamics', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_hydro_err_si ) - + end if @@ -1118,7 +1128,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='last 10 days of 24-hour vegetation temperature, by site x day-index', & units='m3/m3', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_vegtempmem_sitm ) - + call this%set_restart_var(vname='fates_recrate', vtype=cohort_r8, & long_name='fates diagnostics on recruitment', & units='indiv/ha/day', flushval = flushzero, & @@ -1174,7 +1184,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates diag: rate of indivs moving via fusion', & units='indiv/ha/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_growflx_fusion_siscpf) - + call this%set_restart_var(vname='fates_demorate', vtype=cohort_r8, & long_name='fates diagnoatic rate of indivs demoted', & units='indiv/ha/day', flushval = flushzero, & @@ -1189,7 +1199,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='biomass of indivs killed due to impact mort', & units='kgC/ha/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_imortcflux_si) - + call this%set_restart_var(vname='fates_fmortcflux_canopy', vtype=site_r8, & long_name='fates diagnostic biomass of canopy fire', & units='gC/m2/sec', flushval = flushzero, & @@ -1227,20 +1237,20 @@ subroutine define_restart_vars(this, initialize_variables) ir_prt_base = ivar call this%DefinePRTRestartVars(initialize_variables,ivar) - - - + + + ! Must be last thing before return this%num_restart_vars_ = ivar - + end subroutine define_restart_vars - + ! ===================================================================================== - + subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! ---------------------------------------------------------------------------------- - ! PARTEH variables are objects. These objects + ! PARTEH variables are objects. These objects ! each are registered to have things like names units and symbols ! as part of that object. Thus, when defining, reading and writing restarts, ! instead of manually typing out each variable we want, we just loop through @@ -1267,7 +1277,7 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) class(fates_restart_interface_type) :: this logical, intent(in) :: initialize_variables integer,intent(inout) :: ivar ! global variable counter - + integer :: dummy_out ! dummy index for variable ! position in global file integer :: i_var ! loop counter for prt variables @@ -1283,12 +1293,12 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! The base symbol name symbol_base = prt_global%state_descriptor(i_var)%symbol - + ! The long name of the variable name_base = prt_global%state_descriptor(i_var)%longname do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos - + ! String describing the physical position of the variable write(pos_symbol, '(I3.3)') i_pos @@ -1306,7 +1316,7 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) + ivar=ivar, index = dummy_out ) ! Register the turnover flux variables ! ---------------------------------------------------------------------------- @@ -1316,19 +1326,19 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! The expanded long name of the variable long_name = trim(name_base)//', turnover, position:'//trim(pos_symbol) - + call this%set_restart_var(vname=trim(symbol), & vtype=cohort_r8, & long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) - + ivar=ivar, index = dummy_out ) + ! Register the net allocation flux variable ! ---------------------------------------------------------------------------- - + ! The symbol that is written to file symbol = trim(symbol_base)//'_net_'//trim(pos_symbol) @@ -1340,8 +1350,8 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) - + ivar=ivar, index = dummy_out ) + ! Register the burn flux variable @@ -1357,11 +1367,11 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) + ivar=ivar, index = dummy_out ) end do end do - + return end subroutine DefinePRTRestartVars @@ -1369,20 +1379,20 @@ end subroutine DefinePRTRestartVars subroutine RegisterCohortVector(this,symbol_base, vtype, long_name_base, & units, veclength, flushval, hlms, & - initialize, ivar, index) + initialize, ivar, index) + - ! The basic idea here is that instead of saving cohorts with vector data ! as long arrays in the restart file, we give each index of the vector ! its own variable. This helps reduce the size of the restart files ! considerably. - - + + use FatesIOVariableKindMod, only : cohort_r8 - + class(fates_restart_interface_type) :: this character(*),intent(in) :: symbol_base ! Symbol name without position - character(*),intent(in) :: vtype ! String defining variable type + character(*),intent(in) :: vtype ! String defining variable type character(*),intent(in) :: long_name_base ! name without position character(*),intent(in) :: units ! units for this variable integer,intent(in) :: veclength ! length of the vector @@ -1391,58 +1401,58 @@ subroutine RegisterCohortVector(this,symbol_base, vtype, long_name_base, & logical, intent(in) :: initialize ! Is this registering or counting? integer,intent(inout) :: ivar ! global variable counter integer,intent(out) :: index ! The variable index for this variable - + ! Local Variables character(len=4) :: pos_symbol ! vectors need text strings for each position character(len=128) :: symbol ! symbol name written to file character(len=256) :: long_name ! long name written to file integer :: i_pos ! loop counter for discrete position integer :: dummy_index - + ! We give each vector its own index that points to the first position - + index = ivar + 1 - + do i_pos = 1, veclength - + ! String describing the physical position of the variable write(pos_symbol, '(I3.3)') i_pos - + ! The symbol that is written to file symbol = trim(symbol_base)//'_vec_'//trim(pos_symbol) - + ! The expanded long name of the variable long_name = trim(long_name_base)//', position:'//trim(pos_symbol) - + call this%set_restart_var(vname=trim(symbol), & vtype=vtype, & long_name=trim(long_name), & units=units, flushval = flushval, & hlms='CLM:ALM', initialize=initialize, & - ivar=ivar, index = dummy_index ) - + ivar=ivar, index = dummy_index ) + end do - + end subroutine RegisterCohortVector ! ===================================================================================== - + subroutine GetCohortRealVector(this, state_vector, len_state_vector, & variable_index_base, co_global_index) - + ! This subroutine walks through global cohort vector indices ! and pulls from the different associated restart variables - + class(fates_restart_interface_type) , intent(inout) :: this integer,intent(in) :: len_state_vector real(r8),intent(inout) :: state_vector(len_state_vector) integer,intent(in) :: variable_index_base integer,intent(in) :: co_global_index - + integer :: i_pos ! vector position loop index integer :: ir_pos_var ! global variable index - + ir_pos_var = variable_index_base do i_pos = 1, len_state_vector state_vector(i_pos) = this%rvars(ir_pos_var)%r81d(co_global_index) @@ -1450,24 +1460,24 @@ subroutine GetCohortRealVector(this, state_vector, len_state_vector, & end do return end subroutine GetCohortRealVector - - ! ===================================================================================== - + + ! ===================================================================================== + subroutine SetCohortRealVector(this, state_vector, len_state_vector, & variable_index_base, co_global_index) ! This subroutine walks through global cohort vector indices ! and pushes into the restart arrays the different associated restart variables - + class(fates_restart_interface_type) , intent(inout) :: this integer,intent(in) :: len_state_vector real(r8),intent(in) :: state_vector(len_state_vector) integer,intent(in) :: variable_index_base integer,intent(in) :: co_global_index - + integer :: i_pos ! vector position loop index integer :: ir_pos_var ! global variable index - + ir_pos_var = variable_index_base do i_pos = 1, len_state_vector this%rvars(ir_pos_var)%r81d(co_global_index) = state_vector(i_pos) @@ -1475,7 +1485,7 @@ subroutine SetCohortRealVector(this, state_vector, len_state_vector, & end do return end subroutine SetCohortRealVector - + ! ===================================================================================== @@ -1489,7 +1499,7 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & class(fates_restart_interface_type) :: this character(len=*),intent(in) :: vname character(len=*),intent(in) :: vtype - character(len=*),intent(in) :: units + character(len=*),intent(in) :: units real(r8), intent(in) :: flushval character(len=*),intent(in) :: long_name character(len=*),intent(in) :: hlms @@ -1501,32 +1511,32 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & ! A zero is passed back when the variable is ! not used - + type(fates_restart_variable_type),pointer :: rvar integer :: ub1,lb1,ub2,lb2 ! Bounds for allocating the var integer :: ityp - + logical :: use_var - + use_var = check_hlm_list(trim(hlms), trim(hlm_name)) if( use_var ) then - + ivar = ivar+1 - index = ivar - + index = ivar + if( initialize )then - + call this%rvars(ivar)%Init(vname, units, long_name, vtype, flushval, & fates_restart_num_dim_kinds, this%dim_kinds, this%dim_bounds) end if else - + index = 0 end if - + return end subroutine set_restart_var @@ -1584,7 +1594,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) integer :: patchespersite ! number of patches per site - integer :: cohortsperpatch ! number of cohorts per patch + integer :: cohortsperpatch ! number of cohorts per patch integer :: ft ! functional type index integer :: el ! element loop index @@ -1639,14 +1649,14 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_gpp_acc_hold_co => this%rvars(ir_gpp_acc_hold_co)%r81d, & rio_resp_acc_hold_co => this%rvars(ir_resp_acc_hold_co)%r81d, & rio_npp_acc_hold_co => this%rvars(ir_npp_acc_hold_co)%r81d, & - rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & + rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & - rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & - rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & + rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & + rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & rio_daily_p_efflux_co => this%rvars(ir_daily_p_efflux_co)%r81d, & rio_daily_n_demand_co => this%rvars(ir_daily_n_demand_co)%r81d, & rio_daily_p_demand_co => this%rvars(ir_daily_p_demand_co)%r81d, & @@ -1668,8 +1678,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_spread_si => this%rvars(ir_spread_si)%r81d, & rio_livegrass_pa => this%rvars(ir_livegrass_pa)%r81d, & rio_age_pa => this%rvars(ir_age_pa)%r81d, & - rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & - rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & + rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & + rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & rio_nocomp_pft_label_pa => this%rvars(ir_nocomp_pft_label_pa)%int1d, & rio_area_pa => this%rvars(ir_area_pa)%r81d, & rio_watermem_siwm => this%rvars(ir_watermem_siwm)%r81d, & @@ -1698,20 +1708,20 @@ subroutine set_restart_vectors(this,nc,nsites,sites) totalCohorts = 0 - + ! --------------------------------------------------------------------------------- ! Flush arrays to values defined by %flushval (see registry entry in ! subroutine define_history_vars() ! --------------------------------------------------------------------------------- call this%flush_rvars(nc) - + do s = 1,nsites - + ! Calculate the offsets ! fcolumn is the global column index of the current site. ! For the first site, if that site aligns with the first column index ! in the clump, than the offset should be be equal to begCohort - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) @@ -1726,32 +1736,32 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_sc = io_idx_co_1st io_idx_si_capf = io_idx_co_1st io_idx_si_cacls= io_idx_co_1st - + ! recruitment rate do i_pft = 1,numpft rio_recrate_sift(io_idx_co_1st+i_pft-1) = sites(s)%recruitment_rate(i_pft) end do - + do i_pft = 1,numpft - rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%use_this_pft(i_pft) + rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%use_this_pft(i_pft) end do - + do i_pft = 1,numpft rio_area_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%area_pft(i_pft) end do - + do el = 1, num_elements io_idx_si_cwd = io_idx_co_1st io_idx_si_pft = io_idx_co_1st io_idx_si_scpf = io_idx_co_1st - + do i_cwd=1,ncwd this%rvars(ir_cwdagin_flxdg+el-1)%r81d(io_idx_si_cwd) = sites(s)%flux_diags(el)%cwd_ag_input(i_cwd) this%rvars(ir_cwdbgin_flxdg+el-1)%r81d(io_idx_si_cwd) = sites(s)%flux_diags(el)%cwd_bg_input(i_cwd) io_idx_si_cwd = io_idx_si_cwd + 1 end do - + do i_pft=1,numpft this%rvars(ir_leaflittin_flxdg+el-1)%r81d(io_idx_si_pft) = sites(s)%flux_diags(el)%leaf_litter_input(i_pft) this%rvars(ir_rootlittin_flxdg+el-1)%r81d(io_idx_si_pft) = sites(s)%flux_diags(el)%root_litter_input(i_pft) @@ -1767,8 +1777,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_scpf = io_idx_si_scpf + 1 end do end do - - + + this%rvars(ir_oldstock_mbal+el-1)%r81d(io_idx_si) = sites(s)%mass_balance(el)%old_stock this%rvars(ir_errfates_mbal+el-1)%r81d(io_idx_si) = sites(s)%mass_balance(el)%err_fates @@ -1777,31 +1787,31 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! canopy spread term rio_spread_si(io_idx_si) = sites(s)%spread - + cpatch => sites(s)%oldest_patch - + ! new column, reset num patches patchespersite = 0 - + do while(associated(cpatch)) - + ! found patch, increment patchespersite = patchespersite + 1 - + ccohort => cpatch%shortest - + ! new patch, reset num cohorts cohortsperpatch = 0 - + do while(associated(ccohort)) - + ! found cohort, increment cohortsperpatch = cohortsperpatch + 1 totalCohorts = totalCohorts + 1 - + if ( debug ) then write(fates_log(),*) 'CLTV io_idx_co ', io_idx_co - write(fates_log(),*) 'CLTV lowerbound ', lbound(rio_npp_acc_co,1) + write(fates_log(),*) 'CLTV lowerbound ', lbound(rio_npp_acc_co,1) write(fates_log(),*) 'CLTV upperbound ', ubound(rio_npp_acc_co,1) endif @@ -1814,7 +1824,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_base do i_var = 1, prt_global%num_vars do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos - + ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%val(i_pos) @@ -1822,7 +1832,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%turnover(i_pos) - + ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%net_alloc(i_pos) @@ -1830,13 +1840,13 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%burned(i_pos) - + end do end do - + if(hlm_use_planthydro==itrue)then - + ! Load the water contents call this%SetCohortRealVector(ccohort%co_hydr%th_ag,n_hypool_ag, & ir_hydro_th_ag_covec,io_idx_co) @@ -1849,13 +1859,13 @@ subroutine set_restart_vectors(this,nc,nsites,sites) 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 @@ -1887,12 +1897,12 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_cmort_co(io_idx_co) = ccohort%cmort rio_smort_co(io_idx_co) = ccohort%smort rio_asmort_co(io_idx_co) = ccohort%asmort - rio_frmort_co(io_idx_co) = ccohort%frmort + rio_frmort_co(io_idx_co) = ccohort%frmort ! Nutrient uptake/efflux rio_daily_n_uptake_co(io_idx_co) = ccohort%daily_n_uptake rio_daily_p_uptake_co(io_idx_co) = ccohort%daily_p_uptake - + rio_daily_c_efflux_co(io_idx_co) = ccohort%daily_c_efflux rio_daily_n_efflux_co(io_idx_co) = ccohort%daily_n_efflux rio_daily_p_efflux_co(io_idx_co) = ccohort%daily_p_efflux @@ -1901,7 +1911,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_daily_p_demand_co(io_idx_co) = ccohort%daily_p_demand rio_daily_n_need_co(io_idx_co) = ccohort%daily_n_need2 rio_daily_p_need_co(io_idx_co) = ccohort%daily_p_need2 - + !Logging rio_lmort_direct_co(io_idx_co) = ccohort%lmort_direct rio_lmort_collateral_co(io_idx_co) = ccohort%lmort_collateral @@ -1916,23 +1926,25 @@ subroutine set_restart_vectors(this,nc,nsites,sites) else rio_isnew_co(io_idx_co) = old_cohort endif - + if (hlm_use_sp .eq. itrue) then !rio_c_area_co(io_idx_co) = ccohort%c_area this%rvars(ir_c_area_co)%r81d(io_idx_co) = ccohort%c_area + this%rvars(ir_gpp_tstep_co)%r81d(io_idx_co) = ccohort%gpp_tstep + this%rvars(ir_npp_tstep_co)%r81d(io_idx_co) = ccohort%npp_tstep end if - + if ( debug ) then write(fates_log(),*) 'CLTV offsetNumCohorts II ',io_idx_co, & cohortsperpatch endif - + io_idx_co = io_idx_co + 1 - + ccohort => ccohort%taller - + enddo ! ccohort do while - + ! ! deal with patch level fields here ! @@ -1942,10 +1954,10 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_agesinceanthrodist_pa(io_idx_co_1st) = cpatch%age_since_anthro_disturbance rio_nocomp_pft_label_pa(io_idx_co_1st)= cpatch%nocomp_pft_label rio_area_pa(io_idx_co_1st) = cpatch%area - + ! set cohorts per patch for IO rio_ncohort_pa( io_idx_co_1st ) = cohortsperpatch - + ! Set zenith angle info if ( cpatch%solar_zenith_flag ) then rio_solar_zenith_flag_pa(io_idx_co_1st) = itrue @@ -1961,18 +1973,18 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! -------------------------------------------------------------------------- ! Send litter to the restart arrays - ! Each element has its own variable, so we have to make sure - ! we keep re-setting this + ! Each element has its own variable, so we have to make sure + ! we keep re-setting this ! -------------------------------------------------------------------------- do el = 0, num_elements-1 - + io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_cwsl = io_idx_co_1st io_idx_pa_dcsl = io_idx_co_1st io_idx_pa_dc = io_idx_co_1st - + litt => cpatch%litter(el+1) do i = 1,numpft @@ -1992,7 +2004,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_dcsl = io_idx_pa_dcsl + 1 end do end do - + do i = 1,ncwd this%rvars(ir_agcwd_litt+el)%r81d(io_idx_pa_cwd) = litt%ag_cwd(i) this%rvars(ir_agcwd_frag_litt+el)%r81d(io_idx_pa_cwd) = litt%ag_cwd_frag(i) @@ -2006,7 +2018,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end do - + do i = 1,maxSWb rio_gnd_alb_dif_pasb(io_idx_pa_ib) = cpatch%gnd_alb_dif(i) rio_gnd_alb_dir_pasb(io_idx_pa_ib) = cpatch%gnd_alb_dir(i) @@ -2016,29 +2028,29 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Set the first cohort index to the start of the next patch, increment ! by the maximum number of cohorts per patch io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch - + ! reset counters so that they are all advanced evenly. io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_co = io_idx_co_1st - + if ( debug ) then write(fates_log(),*) 'CLTV io_idx_co_1st ', io_idx_co_1st write(fates_log(),*) 'CLTV numCohort ', cohortsperpatch write(fates_log(),*) 'CLTV totalCohorts ', totalCohorts end if - + cpatch => cpatch%younger - + enddo ! cpatch do while - + io_idx_si_scpf = io_idx_co_1st - + ! Fill the site level diagnostics arrays do i_scls = 1, nlevsclass do i_pft = 1, numpft - + rio_fmortrate_cano_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_canopy(i_scls, i_pft) rio_fmortrate_usto_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_ustory(i_scls, i_pft) rio_imortrate_siscpf(io_idx_si_scpf) = sites(s)%imort_rate(i_scls, i_pft) @@ -2047,16 +2059,16 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_termnindiv_cano_siscpf(io_idx_si_scpf) = sites(s)%term_nindivs_canopy(i_scls,i_pft) rio_termnindiv_usto_siscpf(io_idx_si_scpf) = sites(s)%term_nindivs_ustory(i_scls,i_pft) rio_growflx_fusion_siscpf(io_idx_si_scpf) = sites(s)%growthflux_fusion(i_scls, i_pft) - + io_idx_si_scpf = io_idx_si_scpf + 1 end do rio_demorate_sisc(io_idx_si_sc) = sites(s)%demotion_rate(i_scls) rio_promrate_sisc(io_idx_si_sc) = sites(s)%promotion_rate(i_scls) - + io_idx_si_sc = io_idx_si_sc + 1 end do - + rio_termcflux_cano_si(io_idx_si) = sites(s)%term_carbonflux_canopy rio_termcflux_usto_si(io_idx_si) = sites(s)%term_carbonflux_ustory rio_democflux_si(io_idx_si) = sites(s)%demotion_carbonflux @@ -2075,14 +2087,14 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_dleafondate_si(io_idx_si) = sites(s)%dleafondate rio_dleafoffdate_si(io_idx_si) = sites(s)%dleafoffdate rio_acc_ni_si(io_idx_si) = sites(s)%acc_NI - rio_gdd_si(io_idx_si) = sites(s)%grow_deg_days - + rio_gdd_si(io_idx_si) = sites(s)%grow_deg_days + ! Accumulated trunk product rio_trunk_product_si(io_idx_si) = sites(s)%resources_management%trunk_product_site ! set numpatches for this column rio_npatch_si(io_idx_si) = patchespersite - + do i = 1,numWaterMem ! numWaterMem currently 10 rio_watermem_siwm( io_idx_si_wmem ) = sites(s)%water_memory(i) io_idx_si_wmem = io_idx_si_wmem + 1 @@ -2120,18 +2132,18 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end if enddo - + if ( debug ) then write(fates_log(),*) 'CLTV total cohorts ',totalCohorts end if - + return end associate end subroutine set_restart_vectors ! ==================================================================================== - subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) + subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! ---------------------------------------------------------------------------------- ! This subroutine takes a peak at the restart file to determine how to allocate @@ -2145,7 +2157,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) use EDTypesMod, only : ed_patch_type use EDTypesMod, only : maxSWb use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch - + use EDTypesMod, only : maxpft use EDTypesMod, only : area use EDPatchDynamicsMod, only : zero_patch @@ -2154,7 +2166,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) use EDPatchDynamicsMod, only : create_patch use EDPftvarcon, only : EDPftvarcon_inst use FatesAllometryMod, only : h2d_allom - + ! !ARGUMENTS: class(fates_restart_interface_type) , intent(inout) :: this @@ -2164,7 +2176,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) type(bc_in_type) , intent(in) :: bc_in(nsites) ! local variables - + type(ed_patch_type) , pointer :: newp type(ed_cohort_type), pointer :: new_cohort type(ed_cohort_type), pointer :: prev_cohort @@ -2184,12 +2196,12 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! and the number of cohorts per patch. These values tell us how much ! space to allocate. ! ---------------------------------------------------------------------------------- - + associate( rio_npatch_si => this%rvars(ir_npatch_si)%int1d , & rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d ) - + do s = 1,nsites - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) @@ -2201,9 +2213,9 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) write(fates_log(),*) '0 is a valid number, but this column seems uninitialized',rio_npatch_si(io_idx_si) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + ! Initialize the site pointers to null - sites(s)%youngest_patch => null() + sites(s)%youngest_patch => null() sites(s)%oldest_patch => null() do idx_pa = 1,rio_npatch_si(io_idx_si) @@ -2212,10 +2224,10 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) write(fates_log(),*) 'create patch ',idx_pa write(fates_log(),*) 'idx_pa 1-cohortsperpatch : ', rio_ncohort_pa( io_idx_co_1st ) end if - + ! create patch - allocate(newp) - nocomp_pft = fates_unset_int + allocate(newp) + nocomp_pft = fates_unset_int ! the nocomp_pft label is set after patch creation has occured in 'get_restart_vectors' ! make new patch call create_patch(sites(s), newp, fates_unset_r8, fates_unset_r8, primaryforest, nocomp_pft ) @@ -2231,16 +2243,16 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) init_seed=fates_unset_r8, & init_seed_germ=fates_unset_r8) end do - + ! give this patch a unique patch number newp%patchno = idx_pa ! Iterate over the number of cohorts ! the file says are associated with this patch - ! we are just allocating space here, so we do + ! we are just allocating space here, so we do ! a simple list filling routine - + newp%tallest => null() newp%shortest => null() prev_cohort => null() @@ -2248,7 +2260,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) do fto = 1, rio_ncohort_pa( io_idx_co_1st ) allocate(new_cohort) - call nan_cohort(new_cohort) + call nan_cohort(new_cohort) call zero_cohort(new_cohort) new_cohort%patchptr => newp @@ -2256,7 +2268,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) if (.not.associated(newp%tallest)) then newp%tallest => new_cohort endif - + ! Every cohort's taller is the one that came before ! (unless it is first) if(associated(prev_cohort)) then @@ -2272,8 +2284,8 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) new_cohort%prt => null() call InitPRTObject(new_cohort%prt) call InitPRTBoundaryConditions(new_cohort) - - + + ! Allocate hydraulics arrays if( hlm_use_planthydro.eq.itrue ) then call InitHydrCohort(sites(s),new_cohort) @@ -2281,28 +2293,28 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! Update the previous prev_cohort => new_cohort - + enddo ! ends loop over fto - + ! ! insert this patch with cohorts into the site pointer. At this ! point just insert the new patch in the youngest position ! if (idx_pa == 1) then ! nothing associated yet. first patch is pointed to by youngest and oldest - + if ( debug ) write(fates_log(),*) 'idx_pa = 1 ',idx_pa - - sites(s)%youngest_patch => newp - sites(s)%oldest_patch => newp + + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp sites(s)%youngest_patch%younger => null() sites(s)%youngest_patch%older => null() sites(s)%oldest_patch%younger => null() sites(s)%oldest_patch%older => null() - + else if (idx_pa == 2) then ! add second patch to list - + if ( debug ) write(fates_log(),*) 'idx_pa = 2 ',idx_pa - + sites(s)%youngest_patch => newp sites(s)%youngest_patch%younger => null() sites(s)%youngest_patch%older => sites(s)%oldest_patch @@ -2310,25 +2322,25 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) sites(s)%oldest_patch%older => null() else ! more than 2 patches, insert patch into youngest slot - + if ( debug ) write(fates_log(),*) 'idx_pa > 2 ',idx_pa - + newp%older => sites(s)%youngest_patch sites(s)%youngest_patch%younger => newp newp%younger => null() sites(s)%youngest_patch => newp - + endif - + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch enddo ! ends loop over idx_pa enddo ! ends loop over s - + end associate end subroutine create_patchcohort_structure - + ! ==================================================================================== subroutine get_restart_vectors(this, nc, nsites, sites) @@ -2375,7 +2387,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) integer :: io_idx_pa_cwd ! each cwd class within each patch (pa_cwd) integer :: io_idx_pa_cwsl ! each cwd x soil layer integer :: io_idx_pa_dcsl ! each decomposability x soil layer - integer :: io_idx_pa_dc ! each decomposability index + integer :: io_idx_pa_dc ! each decomposability index integer :: io_idx_pa_ib ! each SW radiation band per patch (pa_ib) integer :: io_idx_si_wmem ! each water memory class within each site integer :: io_idx_si_vtmem ! counter for vegetation temp memory @@ -2390,7 +2402,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) integer :: patchespersite ! number of patches per site - integer :: cohortsperpatch ! number of cohorts per patch + integer :: cohortsperpatch ! number of cohorts per patch integer :: el ! loop counter for elements integer :: nlevsoil ! number of soil layers integer :: ilyr ! soil layer loop counter @@ -2424,7 +2436,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_seed_prod_co => this%rvars(ir_seed_prod_co)%r81d, & rio_size_class_lasttimestep => this%rvars(ir_size_class_lasttimestep_co)%int1d, & rio_dbh_co => this%rvars(ir_dbh_co)%r81d, & - rio_coage_co => this%rvars(ir_coage_co)%r81d, & + rio_coage_co => this%rvars(ir_coage_co)%r81d, & rio_g_sb_laweight_co => this%rvars(ir_g_sb_laweight_co)%r81d, & rio_height_co => this%rvars(ir_height_co)%r81d, & rio_laimemory_co => this%rvars(ir_laimemory_co)%r81d, & @@ -2437,14 +2449,14 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_gpp_acc_hold_co => this%rvars(ir_gpp_acc_hold_co)%r81d, & rio_resp_acc_hold_co => this%rvars(ir_resp_acc_hold_co)%r81d, & rio_npp_acc_hold_co => this%rvars(ir_npp_acc_hold_co)%r81d, & - rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & + rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & - rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & - rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & - rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & - rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & + rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & + rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & + rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & + rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & rio_daily_p_efflux_co => this%rvars(ir_daily_p_efflux_co)%r81d, & rio_daily_n_demand_co => this%rvars(ir_daily_n_demand_co)%r81d, & rio_daily_p_demand_co => this%rvars(ir_daily_p_demand_co)%r81d, & @@ -2493,15 +2505,15 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_fmortcflux_cano_si => this%rvars(ir_fmortcflux_cano_si)%r81d, & rio_fmortcflux_usto_si => this%rvars(ir_fmortcflux_usto_si)%r81d) !rio_c_area_co => this%rvars(ir_c_area_co)%r81d) - + totalcohorts = 0 - + do s = 1,nsites - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) - + io_idx_co = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_si_wmem = io_idx_co_1st @@ -2514,13 +2526,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_sc = io_idx_co_1st io_idx_si_capf = io_idx_co_1st io_idx_si_cacls= io_idx_co_1st - + ! read seed_bank info(site-level, but PFT-resolved) - do i_pft = 1,numpft + do i_pft = 1,numpft sites(s)%recruitment_rate(i_pft) = rio_recrate_sift(io_idx_co_1st+i_pft-1) enddo - - !variables for fixed biogeography mode. These are currently used in restart even when this is off. + + !variables for fixed biogeography mode. These are currently used in restart even when this is off. do i_pft = 1,numpft sites(s)%use_this_pft(i_pft) = rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) sites(s)%area_pft(i_pft) = rio_area_pft_sift(io_idx_co_1st+i_pft-1) @@ -2532,13 +2544,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_cwd = io_idx_co_1st io_idx_si_pft = io_idx_co_1st io_idx_si_scpf = io_idx_co_1st - + do i_cwd=1,ncwd sites(s)%flux_diags(el)%cwd_ag_input(i_cwd) = this%rvars(ir_cwdagin_flxdg+el-1)%r81d(io_idx_si_cwd) sites(s)%flux_diags(el)%cwd_bg_input(i_cwd) = this%rvars(ir_cwdbgin_flxdg+el-1)%r81d(io_idx_si_cwd) io_idx_si_cwd = io_idx_si_cwd + 1 end do - + do i_pft=1,numpft sites(s)%flux_diags(el)%leaf_litter_input(i_pft) = this%rvars(ir_leaflittin_flxdg+el-1)%r81d(io_idx_si_pft) sites(s)%flux_diags(el)%root_litter_input(i_pft) = this%rvars(ir_rootlittin_flxdg+el-1)%r81d(io_idx_si_pft) @@ -2554,34 +2566,34 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_scpf = io_idx_si_scpf + 1 end do end do - - + + sites(s)%mass_balance(el)%old_stock = this%rvars(ir_oldstock_mbal+el-1)%r81d(io_idx_si) sites(s)%mass_balance(el)%err_fates = this%rvars(ir_errfates_mbal+el-1)%r81d(io_idx_si) end do - sites(s)%spread = rio_spread_si(io_idx_si) - + sites(s)%spread = rio_spread_si(io_idx_si) + ! Perform a check on the number of patches per site patchespersite = 0 - + cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - + patchespersite = patchespersite + 1 - + ccohort => cpatch%shortest - + ! new patch, reset num cohorts cohortsperpatch = 0 - - do while(associated(ccohort)) - + + do while(associated(ccohort)) + ! found cohort, increment cohortsperpatch = cohortsperpatch + 1 totalcohorts = totalcohorts + 1 - + if ( debug ) then write(fates_log(),*) 'CVTL io_idx_co ',io_idx_co endif @@ -2593,7 +2605,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ir_prt_var = ir_prt_base do i_var = 1, prt_global%num_vars - do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos + do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos ir_prt_var = ir_prt_var + 1 ccohort%prt%variables(i_var)%val(i_pos) = & @@ -2609,13 +2621,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ir_prt_var = ir_prt_var + 1 ccohort%prt%variables(i_var)%burned(i_pos) = & - this%rvars(ir_prt_var)%r81d(io_idx_co) + this%rvars(ir_prt_var)%r81d(io_idx_co) end do end do - !ccohort%vcmax25top + !ccohort%vcmax25top !ccohort%jmax25top - !ccohort%tpu25top + !ccohort%tpu25top !ccohort%kp25top @@ -2646,15 +2658,15 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%smort = rio_smort_co(io_idx_co) ccohort%asmort = rio_asmort_co(io_idx_co) ccohort%frmort = rio_frmort_co(io_idx_co) - + ! Nutrient uptake / efflux ccohort%daily_n_uptake = rio_daily_n_uptake_co(io_idx_co) ccohort%daily_p_uptake = rio_daily_p_uptake_co(io_idx_co) ccohort%daily_c_efflux = rio_daily_c_efflux_co(io_idx_co) ccohort%daily_n_efflux = rio_daily_n_efflux_co(io_idx_co) ccohort%daily_p_efflux = rio_daily_p_efflux_co(io_idx_co) - - ccohort%daily_n_demand = rio_daily_n_demand_co(io_idx_co) + + ccohort%daily_n_demand = rio_daily_n_demand_co(io_idx_co) ccohort%daily_p_demand = rio_daily_p_demand_co(io_idx_co) ccohort%daily_n_need2 = rio_daily_n_need_co(io_idx_co) ccohort%daily_p_need2 = rio_daily_p_need_co(io_idx_co) @@ -2676,18 +2688,18 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Initialize Plant Hydraulics if(hlm_use_planthydro==itrue)then - + ! Load the water contents call this%GetCohortRealVector(ccohort%co_hydr%th_ag,n_hypool_ag, & ir_hydro_th_ag_covec,io_idx_co) call this%GetCohortRealVector(ccohort%co_hydr%th_aroot,sites(s)%si_hydr%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) - + ccohort%co_hydr%errh2o_growturn_aroot = & this%rvars(ir_hydro_err_growturn_aroot)%r81d(io_idx_co) ccohort%co_hydr%errh2o_growturn_troot = & @@ -2701,12 +2713,14 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if (hlm_use_sp .eq. itrue) then !ccohort%c_area = rio_c_area_co(io_idx_co) ccohort%c_area = this%rvars(ir_c_area_co)%r81d(io_idx_co) + ccohort%npp_tstep = this%rvars(ir_npp_tstep_co)%r81d(io_idx_co) + ccohort%gpp_tstep = this%rvars(ir_gpp_tstep_co)%r81d(io_idx_co) end if - + io_idx_co = io_idx_co + 1 - + ccohort => ccohort%taller - + enddo ! current cohort do while if(cohortsperpatch .ne. rio_ncohort_pa(io_idx_co_1st)) then @@ -2731,20 +2745,20 @@ subroutine get_restart_vectors(this, nc, nsites, sites) cpatch%solar_zenith_angle = rio_solar_zenith_angle_pa(io_idx_co_1st) ! set cohorts per patch for IO - + if ( debug ) then write(fates_log(),*) 'CVTL III ' & ,io_idx_co,cohortsperpatch endif - + ! -------------------------------------------------------------------------- ! Pull litter from the restart arrays - ! Each element has its own variable, so we have to make sure - ! we keep re-setting this + ! Each element has its own variable, so we have to make sure + ! we keep re-setting this ! -------------------------------------------------------------------------- do el = 0, num_elements-1 - + io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_cwsl = io_idx_co_1st @@ -2770,13 +2784,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_pa_dcsl = io_idx_pa_dcsl + 1 end do end do - + do i = 1,ncwd litt%ag_cwd(i) = this%rvars(ir_agcwd_litt+el)%r81d(io_idx_pa_cwd) litt%ag_cwd_frag(i) = this%rvars(ir_agcwd_frag_litt+el)%r81d(io_idx_pa_cwd) io_idx_pa_cwd = io_idx_pa_cwd + 1 - + do ilyr=1,nlevsoil litt%bg_cwd(i,ilyr) = this%rvars(ir_bgcwd_litt+el)%r81d(io_idx_pa_cwsl) litt%bg_cwd_frag(i,ilyr) = this%rvars(ir_bgcwd_frag_litt+el)%r81d(io_idx_pa_cwsl) @@ -2794,30 +2808,30 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Now increment the position of the first cohort to that of the next ! patch - + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch - + ! and max the number of allowed cohorts per patch io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_co = io_idx_co_1st - + if ( debug ) then write(fates_log(),*) 'CVTL io_idx_co_1st ', io_idx_co_1st write(fates_log(),*) 'CVTL cohortsperpatch ', cohortsperpatch write(fates_log(),*) 'CVTL totalCohorts ', totalCohorts end if - + cpatch => cpatch%younger - + enddo ! patch do while - + if(patchespersite .ne. rio_npatch_si(io_idx_si)) then write(fates_log(),*) 'Number of patches per site during retrieval does not match allocation' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + do i = 1,numWaterMem sites(s)%water_memory(i) = rio_watermem_siwm( io_idx_si_wmem ) io_idx_si_wmem = io_idx_si_wmem + 1 @@ -2832,7 +2846,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Retrieve site-level hydraulics arrays ! Note that Hydraulics structures, their allocations, and the length ! declaration nlevsoi_hyd should be allocated early on when the code first - ! allocates sites (before restart info), and when the soils layer is + ! allocates sites (before restart info), and when the soils layer is ! first known. ! ----------------------------------------------------------------------------- @@ -2855,7 +2869,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) end do end if - + ! Fill the site level diagnostics arrays ! ----------------------------------------------------------------------------- @@ -2868,7 +2882,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%fmort_rate_ustory(i_scls, i_pft) = rio_fmortrate_usto_siscpf(io_idx_si_scpf) sites(s)%imort_rate(i_scls, i_pft) = rio_imortrate_siscpf(io_idx_si_scpf) sites(s)%fmort_rate_crown(i_scls, i_pft) = rio_fmortrate_crown_siscpf(io_idx_si_scpf) - sites(s)%fmort_rate_cambial(i_scls, i_pft) = rio_fmortrate_cambi_siscpf(io_idx_si_scpf) + sites(s)%fmort_rate_cambial(i_scls, i_pft) = rio_fmortrate_cambi_siscpf(io_idx_si_scpf) sites(s)%term_nindivs_canopy(i_scls,i_pft) = rio_termnindiv_cano_siscpf(io_idx_si_scpf) sites(s)%term_nindivs_ustory(i_scls,i_pft) = rio_termnindiv_usto_siscpf(io_idx_si_scpf) sites(s)%growthflux_fusion(i_scls, i_pft) = rio_growflx_fusion_siscpf(io_idx_si_scpf) @@ -2877,7 +2891,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%demotion_rate(i_scls) = rio_demorate_sisc(io_idx_si_sc) sites(s)%promotion_rate(i_scls) = rio_promrate_sisc(io_idx_si_sc) - + io_idx_si_sc = io_idx_si_sc + 1 end do @@ -2889,7 +2903,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%fmort_carbonflux_canopy = rio_fmortcflux_cano_si(io_idx_si) sites(s)%fmort_carbonflux_ustory = rio_fmortcflux_usto_si(io_idx_si) - + ! Site level phenology status flags sites(s)%cstatus = rio_cd_status_si(io_idx_si) @@ -2910,10 +2924,10 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if ( debug ) then write(fates_log(),*) 'CVTL total cohorts ',totalCohorts end if - + end associate end subroutine get_restart_vectors - + ! ==================================================================================== subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) @@ -2942,12 +2956,12 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) integer :: ifp ! patch counter do s = 1, nsites - + ifp = 0 currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) + do while (associated(currentpatch)) ifp = ifp+1 - + currentPatch%f_sun (:,:,:) = 0._r8 currentPatch%fabd_sun_z (:,:,:) = 0._r8 currentPatch%fabd_sha_z (:,:,:) = 0._r8 @@ -2961,7 +2975,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 - + ! ----------------------------------------------------------- ! When calling norman radiation from the short-timestep ! we are passing in boundary conditions to set the following @@ -2969,9 +2983,9 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ! currentPatch%solar_zenith_flag (is there daylight?) ! currentPatch%solar_zenith_angle (what is the value?) ! ----------------------------------------------------------- - + if(currentPatch%solar_zenith_flag)then - + bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM @@ -2979,10 +2993,10 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM - + if (maxval(currentPatch%nrad(1,:))==0)then - !there are no leaf layers in this patch. it is effectively bare ground. - ! no radiation is absorbed + !there are no leaf layers in this patch. it is effectively bare ground. + ! no radiation is absorbed bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 do ib = 1,hlm_numSWb @@ -2996,7 +3010,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 enddo else - + call PatchNormanRadiation (currentPatch, & bc_out(s)%albd_parb(ifp,:), & bc_out(s)%albi_parb(ifp,:), & @@ -3005,14 +3019,14 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftdd_parb(ifp,:), & bc_out(s)%ftid_parb(ifp,:), & bc_out(s)%ftii_parb(ifp,:)) - - endif ! is there vegetation? - + + endif ! is there vegetation? + end if ! if the vegetation and zenith filter is active currentPatch => currentPatch%younger end do ! Loop linked-list patches enddo ! Loop Sites - + return end subroutine update_3dpatch_radiation From 64c53d380f6765f2e6a076a5c4ba57bafc485ac9 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 23 Jun 2021 23:22:14 -0600 Subject: [PATCH 325/578] Revert "adding instantaneous gpp and npp to restart" This reverts commit 7fe7af7e7298db25e55d45e5cc43157a79ea38db. --- main/FatesRestartInterfaceMod.F90 | 670 +++++++++++++++--------------- 1 file changed, 328 insertions(+), 342 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 50984091ed..acdbdab904 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -15,7 +15,7 @@ module FatesRestartInterfaceMod use FatesIOVariableKindMod, only : fates_io_variable_kind_type use FatesRestartVariableMod, only : fates_restart_variable_type use FatesInterfaceTypesMod, only : nlevcoage - use FatesInterfaceTypesMod, only : bc_in_type + use FatesInterfaceTypesMod, only : bc_in_type use FatesInterfaceTypesMod, only : bc_out_type use FatesInterfaceTypesMod, only : hlm_use_planthydro use FatesInterfaceTypesMod, only : hlm_use_sp @@ -72,11 +72,11 @@ module FatesRestartInterfaceMod ! ls: layer sublayer dimension (fine discretization of upper,lower) ! wm: the number of memory slots for water (currently 10) ! ------------------------------------------------------------- - - + + ! Indices to the restart variable object - integer :: ir_npatch_si + integer :: ir_npatch_si integer :: ir_cd_status_si integer :: ir_dd_status_si integer :: ir_nchill_days_si @@ -115,8 +115,6 @@ module FatesRestartInterfaceMod integer :: ir_smort_co integer :: ir_asmort_co integer :: ir_c_area_co - integer :: ir_gpp_tstep_co - integer :: ir_npp_tstep_co integer :: ir_daily_n_uptake_co integer :: ir_daily_p_uptake_co @@ -127,7 +125,7 @@ module FatesRestartInterfaceMod integer :: ir_daily_p_demand_co integer :: ir_daily_n_need_co integer :: ir_daily_p_need_co - + !Logging integer :: ir_lmort_direct_co integer :: ir_lmort_collateral_co @@ -208,7 +206,7 @@ module FatesRestartInterfaceMod ! Hydraulic indices integer :: ir_hydro_th_ag_covec integer :: ir_hydro_th_troot - integer :: ir_hydro_th_aroot_covec + integer :: ir_hydro_th_aroot_covec integer :: ir_hydro_liqvol_shell_si integer :: ir_hydro_err_growturn_aroot integer :: ir_hydro_err_growturn_ag_covec @@ -225,12 +223,12 @@ module FatesRestartInterfaceMod ! integer constants for storing logical data integer, parameter, public :: old_cohort = 0 - integer, parameter, public :: new_cohort = 1 + integer, parameter, public :: new_cohort = 1 real(r8), parameter, public :: flushinvalid = -9999.0 real(r8), parameter, public :: flushzero = 0.0 real(r8), parameter, public :: flushone = 1.0 - + ! Local debug flag logical, parameter, public :: debug=.false. @@ -257,20 +255,20 @@ module FatesRestartInterfaceMod ! Instanteate one registry of the different dimension/kinds (dk) ! All output variables will have a pointer to one of these dk's type(fates_io_variable_kind_type) :: dim_kinds(fates_restart_num_dim_kinds) - + ! This is a structure that explains where FATES patch boundaries ! on each thread point to in the host IO array, this structure is ! allocated by number of threads. This could be dynamically ! allocated, but is unlikely to change...? ! Note: history io also instanteates fates_io_dimension_type type(fates_io_dimension_type) :: dim_bounds(fates_restart_num_dimensions) - + type(restart_map_type), pointer :: restart_map(:) integer, private :: cohort_index_, column_index_ contains - + ! public functions procedure :: Init procedure :: SetThreadBoundsEach @@ -283,7 +281,7 @@ module FatesRestartInterfaceMod procedure :: create_patchcohort_structure procedure :: get_restart_vectors procedure :: update_3dpatch_radiation - + ! private work functions procedure, private :: init_dim_kinds_maps procedure, private :: set_dim_indices @@ -299,15 +297,15 @@ module FatesRestartInterfaceMod end type fates_restart_interface_type - + contains ! ===================================================================================== - + subroutine Init(this, num_threads, fates_bounds) - + use FatesIODimensionsMod, only : fates_bounds_type, column, cohort implicit none @@ -332,13 +330,13 @@ subroutine Init(this, num_threads, fates_bounds) ! Allocate the mapping between FATES indices and the IO indices allocate(this%restart_map(num_threads)) - - end subroutine Init + + end subroutine Init ! ====================================================================== subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) - + use FatesIODimensionsMod, only : fates_bounds_type implicit none @@ -349,25 +347,25 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) type(fates_bounds_type), intent(in) :: thread_bounds integer :: index - + index = this%cohort_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%cohort_begin, thread_bounds%cohort_end) - + index = this%column_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%column_begin, thread_bounds%column_end) - + end subroutine SetThreadBoundsEach ! =================================================================================== subroutine assemble_restart_output_types(this) - + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int implicit none - + class(fates_restart_interface_type), intent(inout) :: this call this%init_dim_kinds_maps() @@ -381,7 +379,7 @@ subroutine assemble_restart_output_types(this) end subroutine assemble_restart_output_types ! =================================================================================== - + subroutine set_dim_indices(this, dk_name, idim, dim_index) use FatesIOVariableKindMod , only : iotype_index @@ -430,13 +428,13 @@ subroutine set_cohort_index(this, index) integer, intent(in) :: index this%cohort_index_ = index end subroutine set_cohort_index - + integer function cohort_index(this) implicit none class(fates_restart_interface_type), intent(in) :: this cohort_index = this%cohort_index_ end function cohort_index - + ! ======================================================================= subroutine set_column_index(this, index) @@ -445,17 +443,17 @@ subroutine set_column_index(this, index) integer, intent(in) :: index this%column_index_ = index end subroutine set_column_index - + integer function column_index(this) implicit none class(fates_restart_interface_type), intent(in) :: this column_index = this%column_index_ end function column_index - + ! ======================================================================= subroutine init_dim_kinds_maps(this) - + ! ---------------------------------------------------------------------------------- ! This subroutine simply initializes the structures that define the different ! array and type formats for different IO variables @@ -470,9 +468,9 @@ subroutine init_dim_kinds_maps(this) ! ! ---------------------------------------------------------------------------------- use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int - + implicit none - + ! Arguments class(fates_restart_interface_type), intent(inout) :: this @@ -501,17 +499,17 @@ end subroutine init_dim_kinds_maps ! ==================================================================================== integer function num_restart_vars(this) - + implicit none class(fates_restart_interface_type), intent(in) :: this num_restart_vars = this%num_restart_vars_ - + end function num_restart_vars - + ! ==================================================================================== - + subroutine initialize_restart_vars(this) implicit none @@ -524,16 +522,16 @@ subroutine initialize_restart_vars(this) ! Allocate the list of restart output variable objects allocate(this%rvars(this%num_restart_vars())) - + ! construct the object that defines all of the IO variables call this%define_restart_vars(initialize_variables=.true.) - + end subroutine initialize_restart_vars ! ====================================================================================== subroutine flush_rvars(this,nc) - + class(fates_restart_interface_type) :: this integer,intent(in) :: nc @@ -546,17 +544,17 @@ subroutine flush_rvars(this,nc) call rvar%Flush(nc, this%dim_bounds, this%dim_kinds) end associate end do - + end subroutine flush_rvars - + ! ==================================================================================== - + subroutine define_restart_vars(this, initialize_variables) - + ! --------------------------------------------------------------------------------- - ! + ! ! REGISTRY OF RESTART OUTPUT VARIABLES ! ! Please add any restart variables to this registry. This registry will handle @@ -564,19 +562,19 @@ subroutine define_restart_vars(this, initialize_variables) ! variables. Note that restarts are only using 1D vectors in ALM and CLM. If you ! have a multi-dimensional variable that is below the cohort scale, then pack ! that variable into a cohort-sized output array by giving it a vtype "cohort_r8" - ! or "cohort_int". + ! or "cohort_int". ! ! Unlike history variables, restarts flush to zero. ! --------------------------------------------------------------------------------- - + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_int, cohort_r8 implicit none - + class(fates_restart_interface_type), intent(inout) :: this logical, intent(in) :: initialize_variables ! are we 'count'ing or 'initializ'ing? integer :: ivar - - + + ivar=0 ! ----------------------------------------------------------------------------------- @@ -622,7 +620,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_acc_nesterov_id', vtype=site_r8, & long_name='a nesterov index accumulator', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_acc_ni_si ) - + call this%set_restart_var(vname='fates_gdd_site', vtype=site_r8, & long_name='growing degree days at each site', units='degC days', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gdd_si ) @@ -648,7 +646,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_solar_zenith_flag_pa', vtype=cohort_int, & long_name='switch specifying if zenith is positive', units='unitless', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_solar_zenith_flag_pa ) - + call this%set_restart_var(vname='fates_solar_zenith_angle_pa', vtype=cohort_r8, & long_name='the angle of the solar zenith for each patch', units='radians', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_solar_zenith_angle_pa ) @@ -685,7 +683,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_coage', vtype=cohort_r8, & long_name='ed cohort - age in days', units='days', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_coage_co ) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_coage_co ) call this%set_restart_var(vname='fates_height', vtype=cohort_r8, & long_name='ed cohort - plant height', units='m', flushval = flushzero, & @@ -700,12 +698,12 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - target sapwood biomass set from prev year', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_sapwmemory_co ) - + call this%set_restart_var(vname='fates_structmemory', vtype=cohort_r8, & long_name='ed cohort - target structural biomass set from prev year', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_structmemory_co ) - + call this%set_restart_var(vname='fates_nplant', vtype=cohort_r8, & long_name='ed cohort - number of plants in the cohort', & units='/patch', flushval = flushzero, & @@ -745,7 +743,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - maintenance respiration deficit', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_resp_m_def_co ) - + call this%set_restart_var(vname='fates_bmort', vtype=cohort_r8, & long_name='ed cohort - background mortality rate', & units='/year', flushval = flushzero, & @@ -780,7 +778,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates cohort- daily nitrogen efflux', & units='kg/plant/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_efflux_co ) - + call this%set_restart_var(vname='fates_daily_p_efflux', vtype=cohort_r8, & long_name='fates cohort- daily phosphorus efflux', & units='kg/plant/day', flushval = flushzero, & @@ -805,7 +803,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates cohort- daily nitrogen need', & units='kgN/plant/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_need_co ) - + call this%set_restart_var(vname='fates_frmort', vtype=cohort_r8, & long_name='ed cohort - freezing mortality rate', & units='/year', flushval = flushzero, & @@ -818,7 +816,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_asmort', vtype=cohort_r8, & long_name='ed cohort - age senescence mortality rate', & - units = '/year', flushval = flushzero, & + units = '/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_asmort_co ) call this%set_restart_var(vname='fates_lmort_direct', vtype=cohort_r8, & @@ -829,12 +827,12 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_lmort_collateral', vtype=cohort_r8, & long_name='ed cohort - collateral mortality rate', & units='%/event', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_collateral_co ) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_collateral_co ) + call this%set_restart_var(vname='fates_lmort_in', vtype=cohort_r8, & long_name='ed cohort - mechanical mortality rate', & units='%/event', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_infra_co ) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_infra_co ) call this%set_restart_var(vname='fates_ddbhdt', vtype=cohort_r8, & long_name='ed cohort - differential: ddbh/dt', & @@ -918,23 +916,23 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_ag_cwd', vtype=cohort_r8, & long_name_base='above ground CWD', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_litt) call this%RegisterCohortVector(symbol_base='fates_bg_cwd', vtype=cohort_r8, & long_name_base='below ground CWD', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_litt) call this%RegisterCohortVector(symbol_base='fates_leaf_fines', vtype=cohort_r8, & long_name_base='above ground leaf litter', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litt) call this%RegisterCohortVector(symbol_base='fates_fnrt_fines', vtype=cohort_r8, & long_name_base='fine root litter', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fnrt_litt) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fnrt_litt) + call this%RegisterCohortVector(symbol_base='fates_seed', vtype=cohort_r8, & long_name_base='seed bank (non-germinated)', & units='kg/m2', veclength=num_elements, flushval = flushzero, & @@ -948,18 +946,18 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_ag_cwd_frag', vtype=cohort_r8, & long_name_base='above ground CWD frag flux', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_frag_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_frag_litt) call this%RegisterCohortVector(symbol_base='fates_bg_cwd_frag', vtype=cohort_r8, & long_name_base='below ground CWD frag flux', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_frag_litt) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_frag_litt) + call this%RegisterCohortVector(symbol_base='fates_lfines_frag', vtype=cohort_r8, & long_name_base='frag flux from leaf fines', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lfines_frag_litt) - + call this%RegisterCohortVector(symbol_base='fates_rfines_frag', vtype=cohort_r8, & long_name_base='frag flux from froot fines', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & @@ -998,20 +996,20 @@ subroutine define_restart_vars(this, initialize_variables) units='kg/day/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_uptake_flxdg) - + ! Site level Mass Balance State Accounting call this%RegisterCohortVector(symbol_base='fates_oldstock', vtype=site_r8, & long_name_base='Previous total mass of all fates state variables', & units='kg/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_oldstock_mbal) - + call this%RegisterCohortVector(symbol_base='fates_errfates', vtype=site_r8, & long_name_base='Previous total mass of error fates state variables', & units='kg/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_errfates_mbal) - - + + ! Only register satellite phenology related restart variables if it is turned on! if(hlm_use_sp .eq. itrue) then @@ -1019,19 +1017,11 @@ subroutine define_restart_vars(this, initialize_variables) long_name='area of the fates cohort', & units='m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_c_area_co ) - call this%set_restart_var(vname='fates_gpp_tstep', vtype=cohort_r8, & - long_name='instantaneous fates gross primary production', & - units='kgC/indiv/timestep', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gpp_tstep_co ) - call this%set_restart_var(vname='fates_npp_tstep', vtype=cohort_r8, & - long_name='instantaneous fates net primary production', & - units='kgC/indiv/timestep', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_tstep_co ) end if ! Only register hydraulics restart variables if it is turned on! - + if(hlm_use_planthydro==itrue) then if ( fates_maxElementsPerSite < (nshell * nlevsoi_hyd_max) ) then @@ -1049,32 +1039,32 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_hydro_th_ag', vtype=cohort_r8, & long_name_base='water in aboveground compartments', & units='kg/plant', veclength=n_hypool_ag, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_ag_covec) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_ag_covec) + 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) - + 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', & units='kg/plant', veclength=nlevsoi_hyd_max, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_aroot_covec) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_aroot_covec) 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) + 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', & units='kg/plant', veclength=n_hypool_ag, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_ag_covec) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_ag_covec) 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) + 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, & @@ -1087,13 +1077,13 @@ subroutine define_restart_vars(this, initialize_variables) long_name='Site level water mass used for new recruits', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_recruit_si ) - + ! Site-level water bound in dead plants call this%set_restart_var(vname='fates_hydro_dead_h2o', vtype=site_r8, & long_name='Site level water bound in dead plants', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_dead_si ) - + ! Site-level water balance error due to growth/turnover call this%set_restart_var(vname='fates_hydro_growturn_err', vtype=site_r8, & long_name='Site level error for hydraulics due to growth/turnover', & @@ -1111,7 +1101,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='Site level error for hydrodynamics', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_hydro_err_si ) - + end if @@ -1128,7 +1118,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='last 10 days of 24-hour vegetation temperature, by site x day-index', & units='m3/m3', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_vegtempmem_sitm ) - + call this%set_restart_var(vname='fates_recrate', vtype=cohort_r8, & long_name='fates diagnostics on recruitment', & units='indiv/ha/day', flushval = flushzero, & @@ -1184,7 +1174,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates diag: rate of indivs moving via fusion', & units='indiv/ha/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_growflx_fusion_siscpf) - + call this%set_restart_var(vname='fates_demorate', vtype=cohort_r8, & long_name='fates diagnoatic rate of indivs demoted', & units='indiv/ha/day', flushval = flushzero, & @@ -1199,7 +1189,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='biomass of indivs killed due to impact mort', & units='kgC/ha/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_imortcflux_si) - + call this%set_restart_var(vname='fates_fmortcflux_canopy', vtype=site_r8, & long_name='fates diagnostic biomass of canopy fire', & units='gC/m2/sec', flushval = flushzero, & @@ -1237,20 +1227,20 @@ subroutine define_restart_vars(this, initialize_variables) ir_prt_base = ivar call this%DefinePRTRestartVars(initialize_variables,ivar) - - - + + + ! Must be last thing before return this%num_restart_vars_ = ivar - + end subroutine define_restart_vars - + ! ===================================================================================== - + subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! ---------------------------------------------------------------------------------- - ! PARTEH variables are objects. These objects + ! PARTEH variables are objects. These objects ! each are registered to have things like names units and symbols ! as part of that object. Thus, when defining, reading and writing restarts, ! instead of manually typing out each variable we want, we just loop through @@ -1277,7 +1267,7 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) class(fates_restart_interface_type) :: this logical, intent(in) :: initialize_variables integer,intent(inout) :: ivar ! global variable counter - + integer :: dummy_out ! dummy index for variable ! position in global file integer :: i_var ! loop counter for prt variables @@ -1293,12 +1283,12 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! The base symbol name symbol_base = prt_global%state_descriptor(i_var)%symbol - + ! The long name of the variable name_base = prt_global%state_descriptor(i_var)%longname do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos - + ! String describing the physical position of the variable write(pos_symbol, '(I3.3)') i_pos @@ -1316,7 +1306,7 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) + ivar=ivar, index = dummy_out ) ! Register the turnover flux variables ! ---------------------------------------------------------------------------- @@ -1326,19 +1316,19 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! The expanded long name of the variable long_name = trim(name_base)//', turnover, position:'//trim(pos_symbol) - + call this%set_restart_var(vname=trim(symbol), & vtype=cohort_r8, & long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) - + ivar=ivar, index = dummy_out ) + ! Register the net allocation flux variable ! ---------------------------------------------------------------------------- - + ! The symbol that is written to file symbol = trim(symbol_base)//'_net_'//trim(pos_symbol) @@ -1350,8 +1340,8 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) - + ivar=ivar, index = dummy_out ) + ! Register the burn flux variable @@ -1367,11 +1357,11 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) + ivar=ivar, index = dummy_out ) end do end do - + return end subroutine DefinePRTRestartVars @@ -1379,20 +1369,20 @@ end subroutine DefinePRTRestartVars subroutine RegisterCohortVector(this,symbol_base, vtype, long_name_base, & units, veclength, flushval, hlms, & - initialize, ivar, index) - + initialize, ivar, index) + ! The basic idea here is that instead of saving cohorts with vector data ! as long arrays in the restart file, we give each index of the vector ! its own variable. This helps reduce the size of the restart files ! considerably. - - + + use FatesIOVariableKindMod, only : cohort_r8 - + class(fates_restart_interface_type) :: this character(*),intent(in) :: symbol_base ! Symbol name without position - character(*),intent(in) :: vtype ! String defining variable type + character(*),intent(in) :: vtype ! String defining variable type character(*),intent(in) :: long_name_base ! name without position character(*),intent(in) :: units ! units for this variable integer,intent(in) :: veclength ! length of the vector @@ -1401,58 +1391,58 @@ subroutine RegisterCohortVector(this,symbol_base, vtype, long_name_base, & logical, intent(in) :: initialize ! Is this registering or counting? integer,intent(inout) :: ivar ! global variable counter integer,intent(out) :: index ! The variable index for this variable - + ! Local Variables character(len=4) :: pos_symbol ! vectors need text strings for each position character(len=128) :: symbol ! symbol name written to file character(len=256) :: long_name ! long name written to file integer :: i_pos ! loop counter for discrete position integer :: dummy_index - + ! We give each vector its own index that points to the first position - + index = ivar + 1 - + do i_pos = 1, veclength - + ! String describing the physical position of the variable write(pos_symbol, '(I3.3)') i_pos - + ! The symbol that is written to file symbol = trim(symbol_base)//'_vec_'//trim(pos_symbol) - + ! The expanded long name of the variable long_name = trim(long_name_base)//', position:'//trim(pos_symbol) - + call this%set_restart_var(vname=trim(symbol), & vtype=vtype, & long_name=trim(long_name), & units=units, flushval = flushval, & hlms='CLM:ALM', initialize=initialize, & - ivar=ivar, index = dummy_index ) - + ivar=ivar, index = dummy_index ) + end do - + end subroutine RegisterCohortVector ! ===================================================================================== - + subroutine GetCohortRealVector(this, state_vector, len_state_vector, & variable_index_base, co_global_index) - + ! This subroutine walks through global cohort vector indices ! and pulls from the different associated restart variables - + class(fates_restart_interface_type) , intent(inout) :: this integer,intent(in) :: len_state_vector real(r8),intent(inout) :: state_vector(len_state_vector) integer,intent(in) :: variable_index_base integer,intent(in) :: co_global_index - + integer :: i_pos ! vector position loop index integer :: ir_pos_var ! global variable index - + ir_pos_var = variable_index_base do i_pos = 1, len_state_vector state_vector(i_pos) = this%rvars(ir_pos_var)%r81d(co_global_index) @@ -1460,24 +1450,24 @@ subroutine GetCohortRealVector(this, state_vector, len_state_vector, & end do return end subroutine GetCohortRealVector - - ! ===================================================================================== - + + ! ===================================================================================== + subroutine SetCohortRealVector(this, state_vector, len_state_vector, & variable_index_base, co_global_index) ! This subroutine walks through global cohort vector indices ! and pushes into the restart arrays the different associated restart variables - + class(fates_restart_interface_type) , intent(inout) :: this integer,intent(in) :: len_state_vector real(r8),intent(in) :: state_vector(len_state_vector) integer,intent(in) :: variable_index_base integer,intent(in) :: co_global_index - + integer :: i_pos ! vector position loop index integer :: ir_pos_var ! global variable index - + ir_pos_var = variable_index_base do i_pos = 1, len_state_vector this%rvars(ir_pos_var)%r81d(co_global_index) = state_vector(i_pos) @@ -1485,7 +1475,7 @@ subroutine SetCohortRealVector(this, state_vector, len_state_vector, & end do return end subroutine SetCohortRealVector - + ! ===================================================================================== @@ -1499,7 +1489,7 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & class(fates_restart_interface_type) :: this character(len=*),intent(in) :: vname character(len=*),intent(in) :: vtype - character(len=*),intent(in) :: units + character(len=*),intent(in) :: units real(r8), intent(in) :: flushval character(len=*),intent(in) :: long_name character(len=*),intent(in) :: hlms @@ -1511,32 +1501,32 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & ! A zero is passed back when the variable is ! not used - + type(fates_restart_variable_type),pointer :: rvar integer :: ub1,lb1,ub2,lb2 ! Bounds for allocating the var integer :: ityp - + logical :: use_var - + use_var = check_hlm_list(trim(hlms), trim(hlm_name)) if( use_var ) then - + ivar = ivar+1 - index = ivar - + index = ivar + if( initialize )then - + call this%rvars(ivar)%Init(vname, units, long_name, vtype, flushval, & fates_restart_num_dim_kinds, this%dim_kinds, this%dim_bounds) end if else - + index = 0 end if - + return end subroutine set_restart_var @@ -1594,7 +1584,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) integer :: patchespersite ! number of patches per site - integer :: cohortsperpatch ! number of cohorts per patch + integer :: cohortsperpatch ! number of cohorts per patch integer :: ft ! functional type index integer :: el ! element loop index @@ -1649,14 +1639,14 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_gpp_acc_hold_co => this%rvars(ir_gpp_acc_hold_co)%r81d, & rio_resp_acc_hold_co => this%rvars(ir_resp_acc_hold_co)%r81d, & rio_npp_acc_hold_co => this%rvars(ir_npp_acc_hold_co)%r81d, & - rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & + rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & - rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & - rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & + rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & + rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & rio_daily_p_efflux_co => this%rvars(ir_daily_p_efflux_co)%r81d, & rio_daily_n_demand_co => this%rvars(ir_daily_n_demand_co)%r81d, & rio_daily_p_demand_co => this%rvars(ir_daily_p_demand_co)%r81d, & @@ -1678,8 +1668,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_spread_si => this%rvars(ir_spread_si)%r81d, & rio_livegrass_pa => this%rvars(ir_livegrass_pa)%r81d, & rio_age_pa => this%rvars(ir_age_pa)%r81d, & - rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & - rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & + rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & + rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & rio_nocomp_pft_label_pa => this%rvars(ir_nocomp_pft_label_pa)%int1d, & rio_area_pa => this%rvars(ir_area_pa)%r81d, & rio_watermem_siwm => this%rvars(ir_watermem_siwm)%r81d, & @@ -1708,20 +1698,20 @@ subroutine set_restart_vectors(this,nc,nsites,sites) totalCohorts = 0 - + ! --------------------------------------------------------------------------------- ! Flush arrays to values defined by %flushval (see registry entry in ! subroutine define_history_vars() ! --------------------------------------------------------------------------------- call this%flush_rvars(nc) - + do s = 1,nsites - + ! Calculate the offsets ! fcolumn is the global column index of the current site. ! For the first site, if that site aligns with the first column index ! in the clump, than the offset should be be equal to begCohort - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) @@ -1736,32 +1726,32 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_sc = io_idx_co_1st io_idx_si_capf = io_idx_co_1st io_idx_si_cacls= io_idx_co_1st - + ! recruitment rate do i_pft = 1,numpft rio_recrate_sift(io_idx_co_1st+i_pft-1) = sites(s)%recruitment_rate(i_pft) end do - + do i_pft = 1,numpft - rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%use_this_pft(i_pft) + rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%use_this_pft(i_pft) end do - + do i_pft = 1,numpft rio_area_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%area_pft(i_pft) end do - + do el = 1, num_elements io_idx_si_cwd = io_idx_co_1st io_idx_si_pft = io_idx_co_1st io_idx_si_scpf = io_idx_co_1st - + do i_cwd=1,ncwd this%rvars(ir_cwdagin_flxdg+el-1)%r81d(io_idx_si_cwd) = sites(s)%flux_diags(el)%cwd_ag_input(i_cwd) this%rvars(ir_cwdbgin_flxdg+el-1)%r81d(io_idx_si_cwd) = sites(s)%flux_diags(el)%cwd_bg_input(i_cwd) io_idx_si_cwd = io_idx_si_cwd + 1 end do - + do i_pft=1,numpft this%rvars(ir_leaflittin_flxdg+el-1)%r81d(io_idx_si_pft) = sites(s)%flux_diags(el)%leaf_litter_input(i_pft) this%rvars(ir_rootlittin_flxdg+el-1)%r81d(io_idx_si_pft) = sites(s)%flux_diags(el)%root_litter_input(i_pft) @@ -1777,8 +1767,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_scpf = io_idx_si_scpf + 1 end do end do - - + + this%rvars(ir_oldstock_mbal+el-1)%r81d(io_idx_si) = sites(s)%mass_balance(el)%old_stock this%rvars(ir_errfates_mbal+el-1)%r81d(io_idx_si) = sites(s)%mass_balance(el)%err_fates @@ -1787,31 +1777,31 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! canopy spread term rio_spread_si(io_idx_si) = sites(s)%spread - + cpatch => sites(s)%oldest_patch - + ! new column, reset num patches patchespersite = 0 - + do while(associated(cpatch)) - + ! found patch, increment patchespersite = patchespersite + 1 - + ccohort => cpatch%shortest - + ! new patch, reset num cohorts cohortsperpatch = 0 - + do while(associated(ccohort)) - + ! found cohort, increment cohortsperpatch = cohortsperpatch + 1 totalCohorts = totalCohorts + 1 - + if ( debug ) then write(fates_log(),*) 'CLTV io_idx_co ', io_idx_co - write(fates_log(),*) 'CLTV lowerbound ', lbound(rio_npp_acc_co,1) + write(fates_log(),*) 'CLTV lowerbound ', lbound(rio_npp_acc_co,1) write(fates_log(),*) 'CLTV upperbound ', ubound(rio_npp_acc_co,1) endif @@ -1824,7 +1814,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_base do i_var = 1, prt_global%num_vars do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos - + ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%val(i_pos) @@ -1832,7 +1822,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%turnover(i_pos) - + ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%net_alloc(i_pos) @@ -1840,13 +1830,13 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%burned(i_pos) - + end do end do - + if(hlm_use_planthydro==itrue)then - + ! Load the water contents call this%SetCohortRealVector(ccohort%co_hydr%th_ag,n_hypool_ag, & ir_hydro_th_ag_covec,io_idx_co) @@ -1859,13 +1849,13 @@ subroutine set_restart_vectors(this,nc,nsites,sites) 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 @@ -1897,12 +1887,12 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_cmort_co(io_idx_co) = ccohort%cmort rio_smort_co(io_idx_co) = ccohort%smort rio_asmort_co(io_idx_co) = ccohort%asmort - rio_frmort_co(io_idx_co) = ccohort%frmort + rio_frmort_co(io_idx_co) = ccohort%frmort ! Nutrient uptake/efflux rio_daily_n_uptake_co(io_idx_co) = ccohort%daily_n_uptake rio_daily_p_uptake_co(io_idx_co) = ccohort%daily_p_uptake - + rio_daily_c_efflux_co(io_idx_co) = ccohort%daily_c_efflux rio_daily_n_efflux_co(io_idx_co) = ccohort%daily_n_efflux rio_daily_p_efflux_co(io_idx_co) = ccohort%daily_p_efflux @@ -1911,7 +1901,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_daily_p_demand_co(io_idx_co) = ccohort%daily_p_demand rio_daily_n_need_co(io_idx_co) = ccohort%daily_n_need2 rio_daily_p_need_co(io_idx_co) = ccohort%daily_p_need2 - + !Logging rio_lmort_direct_co(io_idx_co) = ccohort%lmort_direct rio_lmort_collateral_co(io_idx_co) = ccohort%lmort_collateral @@ -1926,25 +1916,23 @@ subroutine set_restart_vectors(this,nc,nsites,sites) else rio_isnew_co(io_idx_co) = old_cohort endif - + if (hlm_use_sp .eq. itrue) then !rio_c_area_co(io_idx_co) = ccohort%c_area this%rvars(ir_c_area_co)%r81d(io_idx_co) = ccohort%c_area - this%rvars(ir_gpp_tstep_co)%r81d(io_idx_co) = ccohort%gpp_tstep - this%rvars(ir_npp_tstep_co)%r81d(io_idx_co) = ccohort%npp_tstep end if - + if ( debug ) then write(fates_log(),*) 'CLTV offsetNumCohorts II ',io_idx_co, & cohortsperpatch endif - + io_idx_co = io_idx_co + 1 - + ccohort => ccohort%taller - + enddo ! ccohort do while - + ! ! deal with patch level fields here ! @@ -1954,10 +1942,10 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_agesinceanthrodist_pa(io_idx_co_1st) = cpatch%age_since_anthro_disturbance rio_nocomp_pft_label_pa(io_idx_co_1st)= cpatch%nocomp_pft_label rio_area_pa(io_idx_co_1st) = cpatch%area - + ! set cohorts per patch for IO rio_ncohort_pa( io_idx_co_1st ) = cohortsperpatch - + ! Set zenith angle info if ( cpatch%solar_zenith_flag ) then rio_solar_zenith_flag_pa(io_idx_co_1st) = itrue @@ -1973,18 +1961,18 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! -------------------------------------------------------------------------- ! Send litter to the restart arrays - ! Each element has its own variable, so we have to make sure - ! we keep re-setting this + ! Each element has its own variable, so we have to make sure + ! we keep re-setting this ! -------------------------------------------------------------------------- do el = 0, num_elements-1 - + io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_cwsl = io_idx_co_1st io_idx_pa_dcsl = io_idx_co_1st io_idx_pa_dc = io_idx_co_1st - + litt => cpatch%litter(el+1) do i = 1,numpft @@ -2004,7 +1992,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_dcsl = io_idx_pa_dcsl + 1 end do end do - + do i = 1,ncwd this%rvars(ir_agcwd_litt+el)%r81d(io_idx_pa_cwd) = litt%ag_cwd(i) this%rvars(ir_agcwd_frag_litt+el)%r81d(io_idx_pa_cwd) = litt%ag_cwd_frag(i) @@ -2018,7 +2006,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end do - + do i = 1,maxSWb rio_gnd_alb_dif_pasb(io_idx_pa_ib) = cpatch%gnd_alb_dif(i) rio_gnd_alb_dir_pasb(io_idx_pa_ib) = cpatch%gnd_alb_dir(i) @@ -2028,29 +2016,29 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Set the first cohort index to the start of the next patch, increment ! by the maximum number of cohorts per patch io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch - + ! reset counters so that they are all advanced evenly. io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_co = io_idx_co_1st - + if ( debug ) then write(fates_log(),*) 'CLTV io_idx_co_1st ', io_idx_co_1st write(fates_log(),*) 'CLTV numCohort ', cohortsperpatch write(fates_log(),*) 'CLTV totalCohorts ', totalCohorts end if - + cpatch => cpatch%younger - + enddo ! cpatch do while - + io_idx_si_scpf = io_idx_co_1st - + ! Fill the site level diagnostics arrays do i_scls = 1, nlevsclass do i_pft = 1, numpft - + rio_fmortrate_cano_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_canopy(i_scls, i_pft) rio_fmortrate_usto_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_ustory(i_scls, i_pft) rio_imortrate_siscpf(io_idx_si_scpf) = sites(s)%imort_rate(i_scls, i_pft) @@ -2059,16 +2047,16 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_termnindiv_cano_siscpf(io_idx_si_scpf) = sites(s)%term_nindivs_canopy(i_scls,i_pft) rio_termnindiv_usto_siscpf(io_idx_si_scpf) = sites(s)%term_nindivs_ustory(i_scls,i_pft) rio_growflx_fusion_siscpf(io_idx_si_scpf) = sites(s)%growthflux_fusion(i_scls, i_pft) - + io_idx_si_scpf = io_idx_si_scpf + 1 end do rio_demorate_sisc(io_idx_si_sc) = sites(s)%demotion_rate(i_scls) rio_promrate_sisc(io_idx_si_sc) = sites(s)%promotion_rate(i_scls) - + io_idx_si_sc = io_idx_si_sc + 1 end do - + rio_termcflux_cano_si(io_idx_si) = sites(s)%term_carbonflux_canopy rio_termcflux_usto_si(io_idx_si) = sites(s)%term_carbonflux_ustory rio_democflux_si(io_idx_si) = sites(s)%demotion_carbonflux @@ -2087,14 +2075,14 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_dleafondate_si(io_idx_si) = sites(s)%dleafondate rio_dleafoffdate_si(io_idx_si) = sites(s)%dleafoffdate rio_acc_ni_si(io_idx_si) = sites(s)%acc_NI - rio_gdd_si(io_idx_si) = sites(s)%grow_deg_days - + rio_gdd_si(io_idx_si) = sites(s)%grow_deg_days + ! Accumulated trunk product rio_trunk_product_si(io_idx_si) = sites(s)%resources_management%trunk_product_site ! set numpatches for this column rio_npatch_si(io_idx_si) = patchespersite - + do i = 1,numWaterMem ! numWaterMem currently 10 rio_watermem_siwm( io_idx_si_wmem ) = sites(s)%water_memory(i) io_idx_si_wmem = io_idx_si_wmem + 1 @@ -2132,18 +2120,18 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end if enddo - + if ( debug ) then write(fates_log(),*) 'CLTV total cohorts ',totalCohorts end if - + return end associate end subroutine set_restart_vectors ! ==================================================================================== - subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) + subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! ---------------------------------------------------------------------------------- ! This subroutine takes a peak at the restart file to determine how to allocate @@ -2157,7 +2145,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) use EDTypesMod, only : ed_patch_type use EDTypesMod, only : maxSWb use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch - + use EDTypesMod, only : maxpft use EDTypesMod, only : area use EDPatchDynamicsMod, only : zero_patch @@ -2166,7 +2154,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) use EDPatchDynamicsMod, only : create_patch use EDPftvarcon, only : EDPftvarcon_inst use FatesAllometryMod, only : h2d_allom - + ! !ARGUMENTS: class(fates_restart_interface_type) , intent(inout) :: this @@ -2176,7 +2164,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) type(bc_in_type) , intent(in) :: bc_in(nsites) ! local variables - + type(ed_patch_type) , pointer :: newp type(ed_cohort_type), pointer :: new_cohort type(ed_cohort_type), pointer :: prev_cohort @@ -2196,12 +2184,12 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! and the number of cohorts per patch. These values tell us how much ! space to allocate. ! ---------------------------------------------------------------------------------- - + associate( rio_npatch_si => this%rvars(ir_npatch_si)%int1d , & rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d ) - + do s = 1,nsites - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) @@ -2213,9 +2201,9 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) write(fates_log(),*) '0 is a valid number, but this column seems uninitialized',rio_npatch_si(io_idx_si) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + ! Initialize the site pointers to null - sites(s)%youngest_patch => null() + sites(s)%youngest_patch => null() sites(s)%oldest_patch => null() do idx_pa = 1,rio_npatch_si(io_idx_si) @@ -2224,10 +2212,10 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) write(fates_log(),*) 'create patch ',idx_pa write(fates_log(),*) 'idx_pa 1-cohortsperpatch : ', rio_ncohort_pa( io_idx_co_1st ) end if - + ! create patch - allocate(newp) - nocomp_pft = fates_unset_int + allocate(newp) + nocomp_pft = fates_unset_int ! the nocomp_pft label is set after patch creation has occured in 'get_restart_vectors' ! make new patch call create_patch(sites(s), newp, fates_unset_r8, fates_unset_r8, primaryforest, nocomp_pft ) @@ -2243,16 +2231,16 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) init_seed=fates_unset_r8, & init_seed_germ=fates_unset_r8) end do - + ! give this patch a unique patch number newp%patchno = idx_pa ! Iterate over the number of cohorts ! the file says are associated with this patch - ! we are just allocating space here, so we do + ! we are just allocating space here, so we do ! a simple list filling routine - + newp%tallest => null() newp%shortest => null() prev_cohort => null() @@ -2260,7 +2248,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) do fto = 1, rio_ncohort_pa( io_idx_co_1st ) allocate(new_cohort) - call nan_cohort(new_cohort) + call nan_cohort(new_cohort) call zero_cohort(new_cohort) new_cohort%patchptr => newp @@ -2268,7 +2256,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) if (.not.associated(newp%tallest)) then newp%tallest => new_cohort endif - + ! Every cohort's taller is the one that came before ! (unless it is first) if(associated(prev_cohort)) then @@ -2284,8 +2272,8 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) new_cohort%prt => null() call InitPRTObject(new_cohort%prt) call InitPRTBoundaryConditions(new_cohort) - - + + ! Allocate hydraulics arrays if( hlm_use_planthydro.eq.itrue ) then call InitHydrCohort(sites(s),new_cohort) @@ -2293,28 +2281,28 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! Update the previous prev_cohort => new_cohort - + enddo ! ends loop over fto - + ! ! insert this patch with cohorts into the site pointer. At this ! point just insert the new patch in the youngest position ! if (idx_pa == 1) then ! nothing associated yet. first patch is pointed to by youngest and oldest - + if ( debug ) write(fates_log(),*) 'idx_pa = 1 ',idx_pa - - sites(s)%youngest_patch => newp - sites(s)%oldest_patch => newp + + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp sites(s)%youngest_patch%younger => null() sites(s)%youngest_patch%older => null() sites(s)%oldest_patch%younger => null() sites(s)%oldest_patch%older => null() - + else if (idx_pa == 2) then ! add second patch to list - + if ( debug ) write(fates_log(),*) 'idx_pa = 2 ',idx_pa - + sites(s)%youngest_patch => newp sites(s)%youngest_patch%younger => null() sites(s)%youngest_patch%older => sites(s)%oldest_patch @@ -2322,25 +2310,25 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) sites(s)%oldest_patch%older => null() else ! more than 2 patches, insert patch into youngest slot - + if ( debug ) write(fates_log(),*) 'idx_pa > 2 ',idx_pa - + newp%older => sites(s)%youngest_patch sites(s)%youngest_patch%younger => newp newp%younger => null() sites(s)%youngest_patch => newp - + endif - + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch enddo ! ends loop over idx_pa enddo ! ends loop over s - + end associate end subroutine create_patchcohort_structure - + ! ==================================================================================== subroutine get_restart_vectors(this, nc, nsites, sites) @@ -2387,7 +2375,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) integer :: io_idx_pa_cwd ! each cwd class within each patch (pa_cwd) integer :: io_idx_pa_cwsl ! each cwd x soil layer integer :: io_idx_pa_dcsl ! each decomposability x soil layer - integer :: io_idx_pa_dc ! each decomposability index + integer :: io_idx_pa_dc ! each decomposability index integer :: io_idx_pa_ib ! each SW radiation band per patch (pa_ib) integer :: io_idx_si_wmem ! each water memory class within each site integer :: io_idx_si_vtmem ! counter for vegetation temp memory @@ -2402,7 +2390,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) integer :: patchespersite ! number of patches per site - integer :: cohortsperpatch ! number of cohorts per patch + integer :: cohortsperpatch ! number of cohorts per patch integer :: el ! loop counter for elements integer :: nlevsoil ! number of soil layers integer :: ilyr ! soil layer loop counter @@ -2436,7 +2424,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_seed_prod_co => this%rvars(ir_seed_prod_co)%r81d, & rio_size_class_lasttimestep => this%rvars(ir_size_class_lasttimestep_co)%int1d, & rio_dbh_co => this%rvars(ir_dbh_co)%r81d, & - rio_coage_co => this%rvars(ir_coage_co)%r81d, & + rio_coage_co => this%rvars(ir_coage_co)%r81d, & rio_g_sb_laweight_co => this%rvars(ir_g_sb_laweight_co)%r81d, & rio_height_co => this%rvars(ir_height_co)%r81d, & rio_laimemory_co => this%rvars(ir_laimemory_co)%r81d, & @@ -2449,14 +2437,14 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_gpp_acc_hold_co => this%rvars(ir_gpp_acc_hold_co)%r81d, & rio_resp_acc_hold_co => this%rvars(ir_resp_acc_hold_co)%r81d, & rio_npp_acc_hold_co => this%rvars(ir_npp_acc_hold_co)%r81d, & - rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & + rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & - rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & - rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & - rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & - rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & + rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & + rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & + rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & + rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & rio_daily_p_efflux_co => this%rvars(ir_daily_p_efflux_co)%r81d, & rio_daily_n_demand_co => this%rvars(ir_daily_n_demand_co)%r81d, & rio_daily_p_demand_co => this%rvars(ir_daily_p_demand_co)%r81d, & @@ -2505,15 +2493,15 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_fmortcflux_cano_si => this%rvars(ir_fmortcflux_cano_si)%r81d, & rio_fmortcflux_usto_si => this%rvars(ir_fmortcflux_usto_si)%r81d) !rio_c_area_co => this%rvars(ir_c_area_co)%r81d) - + totalcohorts = 0 - + do s = 1,nsites - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) - + io_idx_co = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_si_wmem = io_idx_co_1st @@ -2526,13 +2514,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_sc = io_idx_co_1st io_idx_si_capf = io_idx_co_1st io_idx_si_cacls= io_idx_co_1st - + ! read seed_bank info(site-level, but PFT-resolved) - do i_pft = 1,numpft + do i_pft = 1,numpft sites(s)%recruitment_rate(i_pft) = rio_recrate_sift(io_idx_co_1st+i_pft-1) enddo - - !variables for fixed biogeography mode. These are currently used in restart even when this is off. + + !variables for fixed biogeography mode. These are currently used in restart even when this is off. do i_pft = 1,numpft sites(s)%use_this_pft(i_pft) = rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) sites(s)%area_pft(i_pft) = rio_area_pft_sift(io_idx_co_1st+i_pft-1) @@ -2544,13 +2532,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_cwd = io_idx_co_1st io_idx_si_pft = io_idx_co_1st io_idx_si_scpf = io_idx_co_1st - + do i_cwd=1,ncwd sites(s)%flux_diags(el)%cwd_ag_input(i_cwd) = this%rvars(ir_cwdagin_flxdg+el-1)%r81d(io_idx_si_cwd) sites(s)%flux_diags(el)%cwd_bg_input(i_cwd) = this%rvars(ir_cwdbgin_flxdg+el-1)%r81d(io_idx_si_cwd) io_idx_si_cwd = io_idx_si_cwd + 1 end do - + do i_pft=1,numpft sites(s)%flux_diags(el)%leaf_litter_input(i_pft) = this%rvars(ir_leaflittin_flxdg+el-1)%r81d(io_idx_si_pft) sites(s)%flux_diags(el)%root_litter_input(i_pft) = this%rvars(ir_rootlittin_flxdg+el-1)%r81d(io_idx_si_pft) @@ -2566,34 +2554,34 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_scpf = io_idx_si_scpf + 1 end do end do - - + + sites(s)%mass_balance(el)%old_stock = this%rvars(ir_oldstock_mbal+el-1)%r81d(io_idx_si) sites(s)%mass_balance(el)%err_fates = this%rvars(ir_errfates_mbal+el-1)%r81d(io_idx_si) end do - sites(s)%spread = rio_spread_si(io_idx_si) - + sites(s)%spread = rio_spread_si(io_idx_si) + ! Perform a check on the number of patches per site patchespersite = 0 - + cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - + patchespersite = patchespersite + 1 - + ccohort => cpatch%shortest - + ! new patch, reset num cohorts cohortsperpatch = 0 - - do while(associated(ccohort)) - + + do while(associated(ccohort)) + ! found cohort, increment cohortsperpatch = cohortsperpatch + 1 totalcohorts = totalcohorts + 1 - + if ( debug ) then write(fates_log(),*) 'CVTL io_idx_co ',io_idx_co endif @@ -2605,7 +2593,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ir_prt_var = ir_prt_base do i_var = 1, prt_global%num_vars - do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos + do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos ir_prt_var = ir_prt_var + 1 ccohort%prt%variables(i_var)%val(i_pos) = & @@ -2621,13 +2609,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ir_prt_var = ir_prt_var + 1 ccohort%prt%variables(i_var)%burned(i_pos) = & - this%rvars(ir_prt_var)%r81d(io_idx_co) + this%rvars(ir_prt_var)%r81d(io_idx_co) end do end do - !ccohort%vcmax25top + !ccohort%vcmax25top !ccohort%jmax25top - !ccohort%tpu25top + !ccohort%tpu25top !ccohort%kp25top @@ -2658,15 +2646,15 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%smort = rio_smort_co(io_idx_co) ccohort%asmort = rio_asmort_co(io_idx_co) ccohort%frmort = rio_frmort_co(io_idx_co) - + ! Nutrient uptake / efflux ccohort%daily_n_uptake = rio_daily_n_uptake_co(io_idx_co) ccohort%daily_p_uptake = rio_daily_p_uptake_co(io_idx_co) ccohort%daily_c_efflux = rio_daily_c_efflux_co(io_idx_co) ccohort%daily_n_efflux = rio_daily_n_efflux_co(io_idx_co) ccohort%daily_p_efflux = rio_daily_p_efflux_co(io_idx_co) - - ccohort%daily_n_demand = rio_daily_n_demand_co(io_idx_co) + + ccohort%daily_n_demand = rio_daily_n_demand_co(io_idx_co) ccohort%daily_p_demand = rio_daily_p_demand_co(io_idx_co) ccohort%daily_n_need2 = rio_daily_n_need_co(io_idx_co) ccohort%daily_p_need2 = rio_daily_p_need_co(io_idx_co) @@ -2688,18 +2676,18 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Initialize Plant Hydraulics if(hlm_use_planthydro==itrue)then - + ! Load the water contents call this%GetCohortRealVector(ccohort%co_hydr%th_ag,n_hypool_ag, & ir_hydro_th_ag_covec,io_idx_co) call this%GetCohortRealVector(ccohort%co_hydr%th_aroot,sites(s)%si_hydr%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) - + ccohort%co_hydr%errh2o_growturn_aroot = & this%rvars(ir_hydro_err_growturn_aroot)%r81d(io_idx_co) ccohort%co_hydr%errh2o_growturn_troot = & @@ -2713,14 +2701,12 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if (hlm_use_sp .eq. itrue) then !ccohort%c_area = rio_c_area_co(io_idx_co) ccohort%c_area = this%rvars(ir_c_area_co)%r81d(io_idx_co) - ccohort%npp_tstep = this%rvars(ir_npp_tstep_co)%r81d(io_idx_co) - ccohort%gpp_tstep = this%rvars(ir_gpp_tstep_co)%r81d(io_idx_co) end if - + io_idx_co = io_idx_co + 1 - + ccohort => ccohort%taller - + enddo ! current cohort do while if(cohortsperpatch .ne. rio_ncohort_pa(io_idx_co_1st)) then @@ -2745,20 +2731,20 @@ subroutine get_restart_vectors(this, nc, nsites, sites) cpatch%solar_zenith_angle = rio_solar_zenith_angle_pa(io_idx_co_1st) ! set cohorts per patch for IO - + if ( debug ) then write(fates_log(),*) 'CVTL III ' & ,io_idx_co,cohortsperpatch endif - + ! -------------------------------------------------------------------------- ! Pull litter from the restart arrays - ! Each element has its own variable, so we have to make sure - ! we keep re-setting this + ! Each element has its own variable, so we have to make sure + ! we keep re-setting this ! -------------------------------------------------------------------------- do el = 0, num_elements-1 - + io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_cwsl = io_idx_co_1st @@ -2784,13 +2770,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_pa_dcsl = io_idx_pa_dcsl + 1 end do end do - + do i = 1,ncwd litt%ag_cwd(i) = this%rvars(ir_agcwd_litt+el)%r81d(io_idx_pa_cwd) litt%ag_cwd_frag(i) = this%rvars(ir_agcwd_frag_litt+el)%r81d(io_idx_pa_cwd) io_idx_pa_cwd = io_idx_pa_cwd + 1 - + do ilyr=1,nlevsoil litt%bg_cwd(i,ilyr) = this%rvars(ir_bgcwd_litt+el)%r81d(io_idx_pa_cwsl) litt%bg_cwd_frag(i,ilyr) = this%rvars(ir_bgcwd_frag_litt+el)%r81d(io_idx_pa_cwsl) @@ -2808,30 +2794,30 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Now increment the position of the first cohort to that of the next ! patch - + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch - + ! and max the number of allowed cohorts per patch io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_co = io_idx_co_1st - + if ( debug ) then write(fates_log(),*) 'CVTL io_idx_co_1st ', io_idx_co_1st write(fates_log(),*) 'CVTL cohortsperpatch ', cohortsperpatch write(fates_log(),*) 'CVTL totalCohorts ', totalCohorts end if - + cpatch => cpatch%younger - + enddo ! patch do while - + if(patchespersite .ne. rio_npatch_si(io_idx_si)) then write(fates_log(),*) 'Number of patches per site during retrieval does not match allocation' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + do i = 1,numWaterMem sites(s)%water_memory(i) = rio_watermem_siwm( io_idx_si_wmem ) io_idx_si_wmem = io_idx_si_wmem + 1 @@ -2846,7 +2832,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Retrieve site-level hydraulics arrays ! Note that Hydraulics structures, their allocations, and the length ! declaration nlevsoi_hyd should be allocated early on when the code first - ! allocates sites (before restart info), and when the soils layer is + ! allocates sites (before restart info), and when the soils layer is ! first known. ! ----------------------------------------------------------------------------- @@ -2869,7 +2855,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) end do end if - + ! Fill the site level diagnostics arrays ! ----------------------------------------------------------------------------- @@ -2882,7 +2868,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%fmort_rate_ustory(i_scls, i_pft) = rio_fmortrate_usto_siscpf(io_idx_si_scpf) sites(s)%imort_rate(i_scls, i_pft) = rio_imortrate_siscpf(io_idx_si_scpf) sites(s)%fmort_rate_crown(i_scls, i_pft) = rio_fmortrate_crown_siscpf(io_idx_si_scpf) - sites(s)%fmort_rate_cambial(i_scls, i_pft) = rio_fmortrate_cambi_siscpf(io_idx_si_scpf) + sites(s)%fmort_rate_cambial(i_scls, i_pft) = rio_fmortrate_cambi_siscpf(io_idx_si_scpf) sites(s)%term_nindivs_canopy(i_scls,i_pft) = rio_termnindiv_cano_siscpf(io_idx_si_scpf) sites(s)%term_nindivs_ustory(i_scls,i_pft) = rio_termnindiv_usto_siscpf(io_idx_si_scpf) sites(s)%growthflux_fusion(i_scls, i_pft) = rio_growflx_fusion_siscpf(io_idx_si_scpf) @@ -2891,7 +2877,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%demotion_rate(i_scls) = rio_demorate_sisc(io_idx_si_sc) sites(s)%promotion_rate(i_scls) = rio_promrate_sisc(io_idx_si_sc) - + io_idx_si_sc = io_idx_si_sc + 1 end do @@ -2903,7 +2889,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%fmort_carbonflux_canopy = rio_fmortcflux_cano_si(io_idx_si) sites(s)%fmort_carbonflux_ustory = rio_fmortcflux_usto_si(io_idx_si) - + ! Site level phenology status flags sites(s)%cstatus = rio_cd_status_si(io_idx_si) @@ -2924,10 +2910,10 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if ( debug ) then write(fates_log(),*) 'CVTL total cohorts ',totalCohorts end if - + end associate end subroutine get_restart_vectors - + ! ==================================================================================== subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) @@ -2956,12 +2942,12 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) integer :: ifp ! patch counter do s = 1, nsites - + ifp = 0 currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) + do while (associated(currentpatch)) ifp = ifp+1 - + currentPatch%f_sun (:,:,:) = 0._r8 currentPatch%fabd_sun_z (:,:,:) = 0._r8 currentPatch%fabd_sha_z (:,:,:) = 0._r8 @@ -2975,7 +2961,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 - + ! ----------------------------------------------------------- ! When calling norman radiation from the short-timestep ! we are passing in boundary conditions to set the following @@ -2983,9 +2969,9 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ! currentPatch%solar_zenith_flag (is there daylight?) ! currentPatch%solar_zenith_angle (what is the value?) ! ----------------------------------------------------------- - + if(currentPatch%solar_zenith_flag)then - + bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM @@ -2993,10 +2979,10 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM - + if (maxval(currentPatch%nrad(1,:))==0)then - !there are no leaf layers in this patch. it is effectively bare ground. - ! no radiation is absorbed + !there are no leaf layers in this patch. it is effectively bare ground. + ! no radiation is absorbed bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 do ib = 1,hlm_numSWb @@ -3010,7 +2996,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 enddo else - + call PatchNormanRadiation (currentPatch, & bc_out(s)%albd_parb(ifp,:), & bc_out(s)%albi_parb(ifp,:), & @@ -3019,14 +3005,14 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftdd_parb(ifp,:), & bc_out(s)%ftid_parb(ifp,:), & bc_out(s)%ftii_parb(ifp,:)) - - endif ! is there vegetation? - + + endif ! is there vegetation? + end if ! if the vegetation and zenith filter is active currentPatch => currentPatch%younger end do ! Loop linked-list patches enddo ! Loop Sites - + return end subroutine update_3dpatch_radiation From d987947f779b988f0894cfe12f2c00313568f28b Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 23 Jun 2021 23:23:29 -0600 Subject: [PATCH 326/578] cleaning up old code --- main/FatesRestartInterfaceMod.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index acdbdab904..1a84aa864f 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -1694,7 +1694,6 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_imortcflux_si => this%rvars(ir_imortcflux_si)%r81d, & rio_fmortcflux_cano_si => this%rvars(ir_fmortcflux_cano_si)%r81d, & rio_fmortcflux_usto_si => this%rvars(ir_fmortcflux_usto_si)%r81d) - !rio_c_area_co => this%rvars(ir_c_area_co)%r81d) totalCohorts = 0 @@ -1918,7 +1917,6 @@ subroutine set_restart_vectors(this,nc,nsites,sites) endif if (hlm_use_sp .eq. itrue) then - !rio_c_area_co(io_idx_co) = ccohort%c_area this%rvars(ir_c_area_co)%r81d(io_idx_co) = ccohort%c_area end if @@ -2492,7 +2490,6 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_imortcflux_si => this%rvars(ir_imortcflux_si)%r81d, & rio_fmortcflux_cano_si => this%rvars(ir_fmortcflux_cano_si)%r81d, & rio_fmortcflux_usto_si => this%rvars(ir_fmortcflux_usto_si)%r81d) - !rio_c_area_co => this%rvars(ir_c_area_co)%r81d) totalcohorts = 0 @@ -2699,7 +2696,6 @@ subroutine get_restart_vectors(this, nc, nsites, sites) end if if (hlm_use_sp .eq. itrue) then - !ccohort%c_area = rio_c_area_co(io_idx_co) ccohort%c_area = this%rvars(ir_c_area_co)%r81d(io_idx_co) end if From b87f252c4965ff2efcdea05287d7eee5be0190c2 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 23 Jun 2021 22:27:24 -0700 Subject: [PATCH 327/578] more cleanup --- main/FatesRestartInterfaceMod.F90 | 657 +++++++++++++++--------------- 1 file changed, 328 insertions(+), 329 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 1a84aa864f..47737a9dd3 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -15,7 +15,7 @@ module FatesRestartInterfaceMod use FatesIOVariableKindMod, only : fates_io_variable_kind_type use FatesRestartVariableMod, only : fates_restart_variable_type use FatesInterfaceTypesMod, only : nlevcoage - use FatesInterfaceTypesMod, only : bc_in_type + use FatesInterfaceTypesMod, only : bc_in_type use FatesInterfaceTypesMod, only : bc_out_type use FatesInterfaceTypesMod, only : hlm_use_planthydro use FatesInterfaceTypesMod, only : hlm_use_sp @@ -72,11 +72,11 @@ module FatesRestartInterfaceMod ! ls: layer sublayer dimension (fine discretization of upper,lower) ! wm: the number of memory slots for water (currently 10) ! ------------------------------------------------------------- - - + + ! Indices to the restart variable object - integer :: ir_npatch_si + integer :: ir_npatch_si integer :: ir_cd_status_si integer :: ir_dd_status_si integer :: ir_nchill_days_si @@ -125,7 +125,7 @@ module FatesRestartInterfaceMod integer :: ir_daily_p_demand_co integer :: ir_daily_n_need_co integer :: ir_daily_p_need_co - + !Logging integer :: ir_lmort_direct_co integer :: ir_lmort_collateral_co @@ -206,7 +206,7 @@ module FatesRestartInterfaceMod ! Hydraulic indices integer :: ir_hydro_th_ag_covec integer :: ir_hydro_th_troot - integer :: ir_hydro_th_aroot_covec + integer :: ir_hydro_th_aroot_covec integer :: ir_hydro_liqvol_shell_si integer :: ir_hydro_err_growturn_aroot integer :: ir_hydro_err_growturn_ag_covec @@ -223,12 +223,12 @@ module FatesRestartInterfaceMod ! integer constants for storing logical data integer, parameter, public :: old_cohort = 0 - integer, parameter, public :: new_cohort = 1 + integer, parameter, public :: new_cohort = 1 real(r8), parameter, public :: flushinvalid = -9999.0 real(r8), parameter, public :: flushzero = 0.0 real(r8), parameter, public :: flushone = 1.0 - + ! Local debug flag logical, parameter, public :: debug=.false. @@ -255,20 +255,20 @@ module FatesRestartInterfaceMod ! Instanteate one registry of the different dimension/kinds (dk) ! All output variables will have a pointer to one of these dk's type(fates_io_variable_kind_type) :: dim_kinds(fates_restart_num_dim_kinds) - + ! This is a structure that explains where FATES patch boundaries ! on each thread point to in the host IO array, this structure is ! allocated by number of threads. This could be dynamically ! allocated, but is unlikely to change...? ! Note: history io also instanteates fates_io_dimension_type type(fates_io_dimension_type) :: dim_bounds(fates_restart_num_dimensions) - + type(restart_map_type), pointer :: restart_map(:) integer, private :: cohort_index_, column_index_ contains - + ! public functions procedure :: Init procedure :: SetThreadBoundsEach @@ -281,7 +281,7 @@ module FatesRestartInterfaceMod procedure :: create_patchcohort_structure procedure :: get_restart_vectors procedure :: update_3dpatch_radiation - + ! private work functions procedure, private :: init_dim_kinds_maps procedure, private :: set_dim_indices @@ -297,15 +297,15 @@ module FatesRestartInterfaceMod end type fates_restart_interface_type - + contains ! ===================================================================================== - + subroutine Init(this, num_threads, fates_bounds) - + use FatesIODimensionsMod, only : fates_bounds_type, column, cohort implicit none @@ -330,13 +330,13 @@ subroutine Init(this, num_threads, fates_bounds) ! Allocate the mapping between FATES indices and the IO indices allocate(this%restart_map(num_threads)) - - end subroutine Init + + end subroutine Init ! ====================================================================== subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) - + use FatesIODimensionsMod, only : fates_bounds_type implicit none @@ -347,25 +347,25 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) type(fates_bounds_type), intent(in) :: thread_bounds integer :: index - + index = this%cohort_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%cohort_begin, thread_bounds%cohort_end) - + index = this%column_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%column_begin, thread_bounds%column_end) - + end subroutine SetThreadBoundsEach ! =================================================================================== subroutine assemble_restart_output_types(this) - + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int implicit none - + class(fates_restart_interface_type), intent(inout) :: this call this%init_dim_kinds_maps() @@ -379,7 +379,7 @@ subroutine assemble_restart_output_types(this) end subroutine assemble_restart_output_types ! =================================================================================== - + subroutine set_dim_indices(this, dk_name, idim, dim_index) use FatesIOVariableKindMod , only : iotype_index @@ -428,13 +428,13 @@ subroutine set_cohort_index(this, index) integer, intent(in) :: index this%cohort_index_ = index end subroutine set_cohort_index - + integer function cohort_index(this) implicit none class(fates_restart_interface_type), intent(in) :: this cohort_index = this%cohort_index_ end function cohort_index - + ! ======================================================================= subroutine set_column_index(this, index) @@ -443,17 +443,17 @@ subroutine set_column_index(this, index) integer, intent(in) :: index this%column_index_ = index end subroutine set_column_index - + integer function column_index(this) implicit none class(fates_restart_interface_type), intent(in) :: this column_index = this%column_index_ end function column_index - + ! ======================================================================= subroutine init_dim_kinds_maps(this) - + ! ---------------------------------------------------------------------------------- ! This subroutine simply initializes the structures that define the different ! array and type formats for different IO variables @@ -468,9 +468,9 @@ subroutine init_dim_kinds_maps(this) ! ! ---------------------------------------------------------------------------------- use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int - + implicit none - + ! Arguments class(fates_restart_interface_type), intent(inout) :: this @@ -499,17 +499,17 @@ end subroutine init_dim_kinds_maps ! ==================================================================================== integer function num_restart_vars(this) - + implicit none class(fates_restart_interface_type), intent(in) :: this num_restart_vars = this%num_restart_vars_ - + end function num_restart_vars - + ! ==================================================================================== - + subroutine initialize_restart_vars(this) implicit none @@ -522,16 +522,16 @@ subroutine initialize_restart_vars(this) ! Allocate the list of restart output variable objects allocate(this%rvars(this%num_restart_vars())) - + ! construct the object that defines all of the IO variables call this%define_restart_vars(initialize_variables=.true.) - + end subroutine initialize_restart_vars ! ====================================================================================== subroutine flush_rvars(this,nc) - + class(fates_restart_interface_type) :: this integer,intent(in) :: nc @@ -544,17 +544,17 @@ subroutine flush_rvars(this,nc) call rvar%Flush(nc, this%dim_bounds, this%dim_kinds) end associate end do - + end subroutine flush_rvars - + ! ==================================================================================== - + subroutine define_restart_vars(this, initialize_variables) - + ! --------------------------------------------------------------------------------- - ! + ! ! REGISTRY OF RESTART OUTPUT VARIABLES ! ! Please add any restart variables to this registry. This registry will handle @@ -562,19 +562,19 @@ subroutine define_restart_vars(this, initialize_variables) ! variables. Note that restarts are only using 1D vectors in ALM and CLM. If you ! have a multi-dimensional variable that is below the cohort scale, then pack ! that variable into a cohort-sized output array by giving it a vtype "cohort_r8" - ! or "cohort_int". + ! or "cohort_int". ! ! Unlike history variables, restarts flush to zero. ! --------------------------------------------------------------------------------- - + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_int, cohort_r8 implicit none - + class(fates_restart_interface_type), intent(inout) :: this logical, intent(in) :: initialize_variables ! are we 'count'ing or 'initializ'ing? integer :: ivar - - + + ivar=0 ! ----------------------------------------------------------------------------------- @@ -620,7 +620,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_acc_nesterov_id', vtype=site_r8, & long_name='a nesterov index accumulator', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_acc_ni_si ) - + call this%set_restart_var(vname='fates_gdd_site', vtype=site_r8, & long_name='growing degree days at each site', units='degC days', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gdd_si ) @@ -646,7 +646,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_solar_zenith_flag_pa', vtype=cohort_int, & long_name='switch specifying if zenith is positive', units='unitless', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_solar_zenith_flag_pa ) - + call this%set_restart_var(vname='fates_solar_zenith_angle_pa', vtype=cohort_r8, & long_name='the angle of the solar zenith for each patch', units='radians', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_solar_zenith_angle_pa ) @@ -683,7 +683,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_coage', vtype=cohort_r8, & long_name='ed cohort - age in days', units='days', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_coage_co ) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_coage_co ) call this%set_restart_var(vname='fates_height', vtype=cohort_r8, & long_name='ed cohort - plant height', units='m', flushval = flushzero, & @@ -698,12 +698,12 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - target sapwood biomass set from prev year', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_sapwmemory_co ) - + call this%set_restart_var(vname='fates_structmemory', vtype=cohort_r8, & long_name='ed cohort - target structural biomass set from prev year', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_structmemory_co ) - + call this%set_restart_var(vname='fates_nplant', vtype=cohort_r8, & long_name='ed cohort - number of plants in the cohort', & units='/patch', flushval = flushzero, & @@ -743,7 +743,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - maintenance respiration deficit', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_resp_m_def_co ) - + call this%set_restart_var(vname='fates_bmort', vtype=cohort_r8, & long_name='ed cohort - background mortality rate', & units='/year', flushval = flushzero, & @@ -778,7 +778,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates cohort- daily nitrogen efflux', & units='kg/plant/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_efflux_co ) - + call this%set_restart_var(vname='fates_daily_p_efflux', vtype=cohort_r8, & long_name='fates cohort- daily phosphorus efflux', & units='kg/plant/day', flushval = flushzero, & @@ -803,7 +803,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates cohort- daily nitrogen need', & units='kgN/plant/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_need_co ) - + call this%set_restart_var(vname='fates_frmort', vtype=cohort_r8, & long_name='ed cohort - freezing mortality rate', & units='/year', flushval = flushzero, & @@ -816,7 +816,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_asmort', vtype=cohort_r8, & long_name='ed cohort - age senescence mortality rate', & - units = '/year', flushval = flushzero, & + units = '/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_asmort_co ) call this%set_restart_var(vname='fates_lmort_direct', vtype=cohort_r8, & @@ -827,12 +827,12 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_lmort_collateral', vtype=cohort_r8, & long_name='ed cohort - collateral mortality rate', & units='%/event', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_collateral_co ) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_collateral_co ) + call this%set_restart_var(vname='fates_lmort_in', vtype=cohort_r8, & long_name='ed cohort - mechanical mortality rate', & units='%/event', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_infra_co ) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_infra_co ) call this%set_restart_var(vname='fates_ddbhdt', vtype=cohort_r8, & long_name='ed cohort - differential: ddbh/dt', & @@ -916,23 +916,23 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_ag_cwd', vtype=cohort_r8, & long_name_base='above ground CWD', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_litt) call this%RegisterCohortVector(symbol_base='fates_bg_cwd', vtype=cohort_r8, & long_name_base='below ground CWD', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_litt) call this%RegisterCohortVector(symbol_base='fates_leaf_fines', vtype=cohort_r8, & long_name_base='above ground leaf litter', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litt) call this%RegisterCohortVector(symbol_base='fates_fnrt_fines', vtype=cohort_r8, & long_name_base='fine root litter', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fnrt_litt) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fnrt_litt) + call this%RegisterCohortVector(symbol_base='fates_seed', vtype=cohort_r8, & long_name_base='seed bank (non-germinated)', & units='kg/m2', veclength=num_elements, flushval = flushzero, & @@ -946,18 +946,18 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_ag_cwd_frag', vtype=cohort_r8, & long_name_base='above ground CWD frag flux', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_frag_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_frag_litt) call this%RegisterCohortVector(symbol_base='fates_bg_cwd_frag', vtype=cohort_r8, & long_name_base='below ground CWD frag flux', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_frag_litt) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_frag_litt) + call this%RegisterCohortVector(symbol_base='fates_lfines_frag', vtype=cohort_r8, & long_name_base='frag flux from leaf fines', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lfines_frag_litt) - + call this%RegisterCohortVector(symbol_base='fates_rfines_frag', vtype=cohort_r8, & long_name_base='frag flux from froot fines', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & @@ -996,20 +996,20 @@ subroutine define_restart_vars(this, initialize_variables) units='kg/day/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_uptake_flxdg) - + ! Site level Mass Balance State Accounting call this%RegisterCohortVector(symbol_base='fates_oldstock', vtype=site_r8, & long_name_base='Previous total mass of all fates state variables', & units='kg/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_oldstock_mbal) - + call this%RegisterCohortVector(symbol_base='fates_errfates', vtype=site_r8, & long_name_base='Previous total mass of error fates state variables', & units='kg/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_errfates_mbal) - - + + ! Only register satellite phenology related restart variables if it is turned on! if(hlm_use_sp .eq. itrue) then @@ -1021,7 +1021,7 @@ subroutine define_restart_vars(this, initialize_variables) ! Only register hydraulics restart variables if it is turned on! - + if(hlm_use_planthydro==itrue) then if ( fates_maxElementsPerSite < (nshell * nlevsoi_hyd_max) ) then @@ -1039,32 +1039,32 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_hydro_th_ag', vtype=cohort_r8, & long_name_base='water in aboveground compartments', & units='kg/plant', veclength=n_hypool_ag, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_ag_covec) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_ag_covec) + 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) - + 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', & units='kg/plant', veclength=nlevsoi_hyd_max, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_aroot_covec) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_aroot_covec) 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) + 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', & units='kg/plant', veclength=n_hypool_ag, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_ag_covec) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_err_growturn_ag_covec) 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) + 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, & @@ -1077,13 +1077,13 @@ subroutine define_restart_vars(this, initialize_variables) long_name='Site level water mass used for new recruits', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_recruit_si ) - + ! Site-level water bound in dead plants call this%set_restart_var(vname='fates_hydro_dead_h2o', vtype=site_r8, & long_name='Site level water bound in dead plants', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_dead_si ) - + ! Site-level water balance error due to growth/turnover call this%set_restart_var(vname='fates_hydro_growturn_err', vtype=site_r8, & long_name='Site level error for hydraulics due to growth/turnover', & @@ -1101,7 +1101,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='Site level error for hydrodynamics', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_hydro_err_si ) - + end if @@ -1118,7 +1118,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='last 10 days of 24-hour vegetation temperature, by site x day-index', & units='m3/m3', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_vegtempmem_sitm ) - + call this%set_restart_var(vname='fates_recrate', vtype=cohort_r8, & long_name='fates diagnostics on recruitment', & units='indiv/ha/day', flushval = flushzero, & @@ -1174,7 +1174,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates diag: rate of indivs moving via fusion', & units='indiv/ha/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_growflx_fusion_siscpf) - + call this%set_restart_var(vname='fates_demorate', vtype=cohort_r8, & long_name='fates diagnoatic rate of indivs demoted', & units='indiv/ha/day', flushval = flushzero, & @@ -1189,7 +1189,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='biomass of indivs killed due to impact mort', & units='kgC/ha/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_imortcflux_si) - + call this%set_restart_var(vname='fates_fmortcflux_canopy', vtype=site_r8, & long_name='fates diagnostic biomass of canopy fire', & units='gC/m2/sec', flushval = flushzero, & @@ -1227,20 +1227,20 @@ subroutine define_restart_vars(this, initialize_variables) ir_prt_base = ivar call this%DefinePRTRestartVars(initialize_variables,ivar) - - - + + + ! Must be last thing before return this%num_restart_vars_ = ivar - + end subroutine define_restart_vars - + ! ===================================================================================== - + subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! ---------------------------------------------------------------------------------- - ! PARTEH variables are objects. These objects + ! PARTEH variables are objects. These objects ! each are registered to have things like names units and symbols ! as part of that object. Thus, when defining, reading and writing restarts, ! instead of manually typing out each variable we want, we just loop through @@ -1267,7 +1267,7 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) class(fates_restart_interface_type) :: this logical, intent(in) :: initialize_variables integer,intent(inout) :: ivar ! global variable counter - + integer :: dummy_out ! dummy index for variable ! position in global file integer :: i_var ! loop counter for prt variables @@ -1283,12 +1283,12 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! The base symbol name symbol_base = prt_global%state_descriptor(i_var)%symbol - + ! The long name of the variable name_base = prt_global%state_descriptor(i_var)%longname do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos - + ! String describing the physical position of the variable write(pos_symbol, '(I3.3)') i_pos @@ -1306,7 +1306,7 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) + ivar=ivar, index = dummy_out ) ! Register the turnover flux variables ! ---------------------------------------------------------------------------- @@ -1316,19 +1316,19 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! The expanded long name of the variable long_name = trim(name_base)//', turnover, position:'//trim(pos_symbol) - + call this%set_restart_var(vname=trim(symbol), & vtype=cohort_r8, & long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) - + ivar=ivar, index = dummy_out ) + ! Register the net allocation flux variable ! ---------------------------------------------------------------------------- - + ! The symbol that is written to file symbol = trim(symbol_base)//'_net_'//trim(pos_symbol) @@ -1340,8 +1340,8 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) - + ivar=ivar, index = dummy_out ) + ! Register the burn flux variable @@ -1357,11 +1357,11 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) + ivar=ivar, index = dummy_out ) end do end do - + return end subroutine DefinePRTRestartVars @@ -1369,20 +1369,20 @@ end subroutine DefinePRTRestartVars subroutine RegisterCohortVector(this,symbol_base, vtype, long_name_base, & units, veclength, flushval, hlms, & - initialize, ivar, index) + initialize, ivar, index) + - ! The basic idea here is that instead of saving cohorts with vector data ! as long arrays in the restart file, we give each index of the vector ! its own variable. This helps reduce the size of the restart files ! considerably. - - + + use FatesIOVariableKindMod, only : cohort_r8 - + class(fates_restart_interface_type) :: this character(*),intent(in) :: symbol_base ! Symbol name without position - character(*),intent(in) :: vtype ! String defining variable type + character(*),intent(in) :: vtype ! String defining variable type character(*),intent(in) :: long_name_base ! name without position character(*),intent(in) :: units ! units for this variable integer,intent(in) :: veclength ! length of the vector @@ -1391,58 +1391,58 @@ subroutine RegisterCohortVector(this,symbol_base, vtype, long_name_base, & logical, intent(in) :: initialize ! Is this registering or counting? integer,intent(inout) :: ivar ! global variable counter integer,intent(out) :: index ! The variable index for this variable - + ! Local Variables character(len=4) :: pos_symbol ! vectors need text strings for each position character(len=128) :: symbol ! symbol name written to file character(len=256) :: long_name ! long name written to file integer :: i_pos ! loop counter for discrete position integer :: dummy_index - + ! We give each vector its own index that points to the first position - + index = ivar + 1 - + do i_pos = 1, veclength - + ! String describing the physical position of the variable write(pos_symbol, '(I3.3)') i_pos - + ! The symbol that is written to file symbol = trim(symbol_base)//'_vec_'//trim(pos_symbol) - + ! The expanded long name of the variable long_name = trim(long_name_base)//', position:'//trim(pos_symbol) - + call this%set_restart_var(vname=trim(symbol), & vtype=vtype, & long_name=trim(long_name), & units=units, flushval = flushval, & hlms='CLM:ALM', initialize=initialize, & - ivar=ivar, index = dummy_index ) - + ivar=ivar, index = dummy_index ) + end do - + end subroutine RegisterCohortVector ! ===================================================================================== - + subroutine GetCohortRealVector(this, state_vector, len_state_vector, & variable_index_base, co_global_index) - + ! This subroutine walks through global cohort vector indices ! and pulls from the different associated restart variables - + class(fates_restart_interface_type) , intent(inout) :: this integer,intent(in) :: len_state_vector real(r8),intent(inout) :: state_vector(len_state_vector) integer,intent(in) :: variable_index_base integer,intent(in) :: co_global_index - + integer :: i_pos ! vector position loop index integer :: ir_pos_var ! global variable index - + ir_pos_var = variable_index_base do i_pos = 1, len_state_vector state_vector(i_pos) = this%rvars(ir_pos_var)%r81d(co_global_index) @@ -1450,24 +1450,24 @@ subroutine GetCohortRealVector(this, state_vector, len_state_vector, & end do return end subroutine GetCohortRealVector - - ! ===================================================================================== - + + ! ===================================================================================== + subroutine SetCohortRealVector(this, state_vector, len_state_vector, & variable_index_base, co_global_index) ! This subroutine walks through global cohort vector indices ! and pushes into the restart arrays the different associated restart variables - + class(fates_restart_interface_type) , intent(inout) :: this integer,intent(in) :: len_state_vector real(r8),intent(in) :: state_vector(len_state_vector) integer,intent(in) :: variable_index_base integer,intent(in) :: co_global_index - + integer :: i_pos ! vector position loop index integer :: ir_pos_var ! global variable index - + ir_pos_var = variable_index_base do i_pos = 1, len_state_vector this%rvars(ir_pos_var)%r81d(co_global_index) = state_vector(i_pos) @@ -1475,7 +1475,7 @@ subroutine SetCohortRealVector(this, state_vector, len_state_vector, & end do return end subroutine SetCohortRealVector - + ! ===================================================================================== @@ -1489,7 +1489,7 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & class(fates_restart_interface_type) :: this character(len=*),intent(in) :: vname character(len=*),intent(in) :: vtype - character(len=*),intent(in) :: units + character(len=*),intent(in) :: units real(r8), intent(in) :: flushval character(len=*),intent(in) :: long_name character(len=*),intent(in) :: hlms @@ -1501,32 +1501,32 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & ! A zero is passed back when the variable is ! not used - + type(fates_restart_variable_type),pointer :: rvar integer :: ub1,lb1,ub2,lb2 ! Bounds for allocating the var integer :: ityp - + logical :: use_var - + use_var = check_hlm_list(trim(hlms), trim(hlm_name)) if( use_var ) then - + ivar = ivar+1 - index = ivar - + index = ivar + if( initialize )then - + call this%rvars(ivar)%Init(vname, units, long_name, vtype, flushval, & fates_restart_num_dim_kinds, this%dim_kinds, this%dim_bounds) end if else - + index = 0 end if - + return end subroutine set_restart_var @@ -1584,7 +1584,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) integer :: patchespersite ! number of patches per site - integer :: cohortsperpatch ! number of cohorts per patch + integer :: cohortsperpatch ! number of cohorts per patch integer :: ft ! functional type index integer :: el ! element loop index @@ -1639,14 +1639,14 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_gpp_acc_hold_co => this%rvars(ir_gpp_acc_hold_co)%r81d, & rio_resp_acc_hold_co => this%rvars(ir_resp_acc_hold_co)%r81d, & rio_npp_acc_hold_co => this%rvars(ir_npp_acc_hold_co)%r81d, & - rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & + rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & - rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & - rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & + rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & + rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & rio_daily_p_efflux_co => this%rvars(ir_daily_p_efflux_co)%r81d, & rio_daily_n_demand_co => this%rvars(ir_daily_n_demand_co)%r81d, & rio_daily_p_demand_co => this%rvars(ir_daily_p_demand_co)%r81d, & @@ -1668,8 +1668,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_spread_si => this%rvars(ir_spread_si)%r81d, & rio_livegrass_pa => this%rvars(ir_livegrass_pa)%r81d, & rio_age_pa => this%rvars(ir_age_pa)%r81d, & - rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & - rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & + rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & + rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & rio_nocomp_pft_label_pa => this%rvars(ir_nocomp_pft_label_pa)%int1d, & rio_area_pa => this%rvars(ir_area_pa)%r81d, & rio_watermem_siwm => this%rvars(ir_watermem_siwm)%r81d, & @@ -1697,20 +1697,20 @@ subroutine set_restart_vectors(this,nc,nsites,sites) totalCohorts = 0 - + ! --------------------------------------------------------------------------------- ! Flush arrays to values defined by %flushval (see registry entry in ! subroutine define_history_vars() ! --------------------------------------------------------------------------------- call this%flush_rvars(nc) - + do s = 1,nsites - + ! Calculate the offsets ! fcolumn is the global column index of the current site. ! For the first site, if that site aligns with the first column index ! in the clump, than the offset should be be equal to begCohort - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) @@ -1725,32 +1725,32 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_sc = io_idx_co_1st io_idx_si_capf = io_idx_co_1st io_idx_si_cacls= io_idx_co_1st - + ! recruitment rate do i_pft = 1,numpft rio_recrate_sift(io_idx_co_1st+i_pft-1) = sites(s)%recruitment_rate(i_pft) end do - + do i_pft = 1,numpft - rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%use_this_pft(i_pft) + rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%use_this_pft(i_pft) end do - + do i_pft = 1,numpft rio_area_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%area_pft(i_pft) end do - + do el = 1, num_elements io_idx_si_cwd = io_idx_co_1st io_idx_si_pft = io_idx_co_1st io_idx_si_scpf = io_idx_co_1st - + do i_cwd=1,ncwd this%rvars(ir_cwdagin_flxdg+el-1)%r81d(io_idx_si_cwd) = sites(s)%flux_diags(el)%cwd_ag_input(i_cwd) this%rvars(ir_cwdbgin_flxdg+el-1)%r81d(io_idx_si_cwd) = sites(s)%flux_diags(el)%cwd_bg_input(i_cwd) io_idx_si_cwd = io_idx_si_cwd + 1 end do - + do i_pft=1,numpft this%rvars(ir_leaflittin_flxdg+el-1)%r81d(io_idx_si_pft) = sites(s)%flux_diags(el)%leaf_litter_input(i_pft) this%rvars(ir_rootlittin_flxdg+el-1)%r81d(io_idx_si_pft) = sites(s)%flux_diags(el)%root_litter_input(i_pft) @@ -1766,8 +1766,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_scpf = io_idx_si_scpf + 1 end do end do - - + + this%rvars(ir_oldstock_mbal+el-1)%r81d(io_idx_si) = sites(s)%mass_balance(el)%old_stock this%rvars(ir_errfates_mbal+el-1)%r81d(io_idx_si) = sites(s)%mass_balance(el)%err_fates @@ -1776,31 +1776,31 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! canopy spread term rio_spread_si(io_idx_si) = sites(s)%spread - + cpatch => sites(s)%oldest_patch - + ! new column, reset num patches patchespersite = 0 - + do while(associated(cpatch)) - + ! found patch, increment patchespersite = patchespersite + 1 - + ccohort => cpatch%shortest - + ! new patch, reset num cohorts cohortsperpatch = 0 - + do while(associated(ccohort)) - + ! found cohort, increment cohortsperpatch = cohortsperpatch + 1 totalCohorts = totalCohorts + 1 - + if ( debug ) then write(fates_log(),*) 'CLTV io_idx_co ', io_idx_co - write(fates_log(),*) 'CLTV lowerbound ', lbound(rio_npp_acc_co,1) + write(fates_log(),*) 'CLTV lowerbound ', lbound(rio_npp_acc_co,1) write(fates_log(),*) 'CLTV upperbound ', ubound(rio_npp_acc_co,1) endif @@ -1813,7 +1813,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_base do i_var = 1, prt_global%num_vars do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos - + ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%val(i_pos) @@ -1821,7 +1821,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%turnover(i_pos) - + ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%net_alloc(i_pos) @@ -1829,13 +1829,13 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%burned(i_pos) - + end do end do - + if(hlm_use_planthydro==itrue)then - + ! Load the water contents call this%SetCohortRealVector(ccohort%co_hydr%th_ag,n_hypool_ag, & ir_hydro_th_ag_covec,io_idx_co) @@ -1848,13 +1848,13 @@ subroutine set_restart_vectors(this,nc,nsites,sites) 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 @@ -1886,12 +1886,12 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_cmort_co(io_idx_co) = ccohort%cmort rio_smort_co(io_idx_co) = ccohort%smort rio_asmort_co(io_idx_co) = ccohort%asmort - rio_frmort_co(io_idx_co) = ccohort%frmort + rio_frmort_co(io_idx_co) = ccohort%frmort ! Nutrient uptake/efflux rio_daily_n_uptake_co(io_idx_co) = ccohort%daily_n_uptake rio_daily_p_uptake_co(io_idx_co) = ccohort%daily_p_uptake - + rio_daily_c_efflux_co(io_idx_co) = ccohort%daily_c_efflux rio_daily_n_efflux_co(io_idx_co) = ccohort%daily_n_efflux rio_daily_p_efflux_co(io_idx_co) = ccohort%daily_p_efflux @@ -1900,7 +1900,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_daily_p_demand_co(io_idx_co) = ccohort%daily_p_demand rio_daily_n_need_co(io_idx_co) = ccohort%daily_n_need2 rio_daily_p_need_co(io_idx_co) = ccohort%daily_p_need2 - + !Logging rio_lmort_direct_co(io_idx_co) = ccohort%lmort_direct rio_lmort_collateral_co(io_idx_co) = ccohort%lmort_collateral @@ -1915,22 +1915,22 @@ subroutine set_restart_vectors(this,nc,nsites,sites) else rio_isnew_co(io_idx_co) = old_cohort endif - + if (hlm_use_sp .eq. itrue) then this%rvars(ir_c_area_co)%r81d(io_idx_co) = ccohort%c_area end if - + if ( debug ) then write(fates_log(),*) 'CLTV offsetNumCohorts II ',io_idx_co, & cohortsperpatch endif - + io_idx_co = io_idx_co + 1 - + ccohort => ccohort%taller - + enddo ! ccohort do while - + ! ! deal with patch level fields here ! @@ -1940,10 +1940,10 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_agesinceanthrodist_pa(io_idx_co_1st) = cpatch%age_since_anthro_disturbance rio_nocomp_pft_label_pa(io_idx_co_1st)= cpatch%nocomp_pft_label rio_area_pa(io_idx_co_1st) = cpatch%area - + ! set cohorts per patch for IO rio_ncohort_pa( io_idx_co_1st ) = cohortsperpatch - + ! Set zenith angle info if ( cpatch%solar_zenith_flag ) then rio_solar_zenith_flag_pa(io_idx_co_1st) = itrue @@ -1959,18 +1959,18 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! -------------------------------------------------------------------------- ! Send litter to the restart arrays - ! Each element has its own variable, so we have to make sure - ! we keep re-setting this + ! Each element has its own variable, so we have to make sure + ! we keep re-setting this ! -------------------------------------------------------------------------- do el = 0, num_elements-1 - + io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_cwsl = io_idx_co_1st io_idx_pa_dcsl = io_idx_co_1st io_idx_pa_dc = io_idx_co_1st - + litt => cpatch%litter(el+1) do i = 1,numpft @@ -1990,7 +1990,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_dcsl = io_idx_pa_dcsl + 1 end do end do - + do i = 1,ncwd this%rvars(ir_agcwd_litt+el)%r81d(io_idx_pa_cwd) = litt%ag_cwd(i) this%rvars(ir_agcwd_frag_litt+el)%r81d(io_idx_pa_cwd) = litt%ag_cwd_frag(i) @@ -2004,7 +2004,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end do - + do i = 1,maxSWb rio_gnd_alb_dif_pasb(io_idx_pa_ib) = cpatch%gnd_alb_dif(i) rio_gnd_alb_dir_pasb(io_idx_pa_ib) = cpatch%gnd_alb_dir(i) @@ -2014,29 +2014,29 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Set the first cohort index to the start of the next patch, increment ! by the maximum number of cohorts per patch io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch - + ! reset counters so that they are all advanced evenly. io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_co = io_idx_co_1st - + if ( debug ) then write(fates_log(),*) 'CLTV io_idx_co_1st ', io_idx_co_1st write(fates_log(),*) 'CLTV numCohort ', cohortsperpatch write(fates_log(),*) 'CLTV totalCohorts ', totalCohorts end if - + cpatch => cpatch%younger - + enddo ! cpatch do while - + io_idx_si_scpf = io_idx_co_1st - + ! Fill the site level diagnostics arrays do i_scls = 1, nlevsclass do i_pft = 1, numpft - + rio_fmortrate_cano_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_canopy(i_scls, i_pft) rio_fmortrate_usto_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_ustory(i_scls, i_pft) rio_imortrate_siscpf(io_idx_si_scpf) = sites(s)%imort_rate(i_scls, i_pft) @@ -2045,16 +2045,16 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_termnindiv_cano_siscpf(io_idx_si_scpf) = sites(s)%term_nindivs_canopy(i_scls,i_pft) rio_termnindiv_usto_siscpf(io_idx_si_scpf) = sites(s)%term_nindivs_ustory(i_scls,i_pft) rio_growflx_fusion_siscpf(io_idx_si_scpf) = sites(s)%growthflux_fusion(i_scls, i_pft) - + io_idx_si_scpf = io_idx_si_scpf + 1 end do rio_demorate_sisc(io_idx_si_sc) = sites(s)%demotion_rate(i_scls) rio_promrate_sisc(io_idx_si_sc) = sites(s)%promotion_rate(i_scls) - + io_idx_si_sc = io_idx_si_sc + 1 end do - + rio_termcflux_cano_si(io_idx_si) = sites(s)%term_carbonflux_canopy rio_termcflux_usto_si(io_idx_si) = sites(s)%term_carbonflux_ustory rio_democflux_si(io_idx_si) = sites(s)%demotion_carbonflux @@ -2073,14 +2073,14 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_dleafondate_si(io_idx_si) = sites(s)%dleafondate rio_dleafoffdate_si(io_idx_si) = sites(s)%dleafoffdate rio_acc_ni_si(io_idx_si) = sites(s)%acc_NI - rio_gdd_si(io_idx_si) = sites(s)%grow_deg_days - + rio_gdd_si(io_idx_si) = sites(s)%grow_deg_days + ! Accumulated trunk product rio_trunk_product_si(io_idx_si) = sites(s)%resources_management%trunk_product_site ! set numpatches for this column rio_npatch_si(io_idx_si) = patchespersite - + do i = 1,numWaterMem ! numWaterMem currently 10 rio_watermem_siwm( io_idx_si_wmem ) = sites(s)%water_memory(i) io_idx_si_wmem = io_idx_si_wmem + 1 @@ -2118,18 +2118,18 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end if enddo - + if ( debug ) then write(fates_log(),*) 'CLTV total cohorts ',totalCohorts end if - + return end associate end subroutine set_restart_vectors ! ==================================================================================== - subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) + subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! ---------------------------------------------------------------------------------- ! This subroutine takes a peak at the restart file to determine how to allocate @@ -2143,7 +2143,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) use EDTypesMod, only : ed_patch_type use EDTypesMod, only : maxSWb use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch - + use EDTypesMod, only : maxpft use EDTypesMod, only : area use EDPatchDynamicsMod, only : zero_patch @@ -2152,7 +2152,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) use EDPatchDynamicsMod, only : create_patch use EDPftvarcon, only : EDPftvarcon_inst use FatesAllometryMod, only : h2d_allom - + ! !ARGUMENTS: class(fates_restart_interface_type) , intent(inout) :: this @@ -2162,7 +2162,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) type(bc_in_type) , intent(in) :: bc_in(nsites) ! local variables - + type(ed_patch_type) , pointer :: newp type(ed_cohort_type), pointer :: new_cohort type(ed_cohort_type), pointer :: prev_cohort @@ -2182,12 +2182,12 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! and the number of cohorts per patch. These values tell us how much ! space to allocate. ! ---------------------------------------------------------------------------------- - + associate( rio_npatch_si => this%rvars(ir_npatch_si)%int1d , & rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d ) - + do s = 1,nsites - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) @@ -2199,9 +2199,9 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) write(fates_log(),*) '0 is a valid number, but this column seems uninitialized',rio_npatch_si(io_idx_si) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + ! Initialize the site pointers to null - sites(s)%youngest_patch => null() + sites(s)%youngest_patch => null() sites(s)%oldest_patch => null() do idx_pa = 1,rio_npatch_si(io_idx_si) @@ -2210,10 +2210,10 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) write(fates_log(),*) 'create patch ',idx_pa write(fates_log(),*) 'idx_pa 1-cohortsperpatch : ', rio_ncohort_pa( io_idx_co_1st ) end if - + ! create patch - allocate(newp) - nocomp_pft = fates_unset_int + allocate(newp) + nocomp_pft = fates_unset_int ! the nocomp_pft label is set after patch creation has occured in 'get_restart_vectors' ! make new patch call create_patch(sites(s), newp, fates_unset_r8, fates_unset_r8, primaryforest, nocomp_pft ) @@ -2229,16 +2229,16 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) init_seed=fates_unset_r8, & init_seed_germ=fates_unset_r8) end do - + ! give this patch a unique patch number newp%patchno = idx_pa ! Iterate over the number of cohorts ! the file says are associated with this patch - ! we are just allocating space here, so we do + ! we are just allocating space here, so we do ! a simple list filling routine - + newp%tallest => null() newp%shortest => null() prev_cohort => null() @@ -2246,7 +2246,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) do fto = 1, rio_ncohort_pa( io_idx_co_1st ) allocate(new_cohort) - call nan_cohort(new_cohort) + call nan_cohort(new_cohort) call zero_cohort(new_cohort) new_cohort%patchptr => newp @@ -2254,7 +2254,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) if (.not.associated(newp%tallest)) then newp%tallest => new_cohort endif - + ! Every cohort's taller is the one that came before ! (unless it is first) if(associated(prev_cohort)) then @@ -2270,8 +2270,8 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) new_cohort%prt => null() call InitPRTObject(new_cohort%prt) call InitPRTBoundaryConditions(new_cohort) - - + + ! Allocate hydraulics arrays if( hlm_use_planthydro.eq.itrue ) then call InitHydrCohort(sites(s),new_cohort) @@ -2279,28 +2279,28 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) ! Update the previous prev_cohort => new_cohort - + enddo ! ends loop over fto - + ! ! insert this patch with cohorts into the site pointer. At this ! point just insert the new patch in the youngest position ! if (idx_pa == 1) then ! nothing associated yet. first patch is pointed to by youngest and oldest - + if ( debug ) write(fates_log(),*) 'idx_pa = 1 ',idx_pa - - sites(s)%youngest_patch => newp - sites(s)%oldest_patch => newp + + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp sites(s)%youngest_patch%younger => null() sites(s)%youngest_patch%older => null() sites(s)%oldest_patch%younger => null() sites(s)%oldest_patch%older => null() - + else if (idx_pa == 2) then ! add second patch to list - + if ( debug ) write(fates_log(),*) 'idx_pa = 2 ',idx_pa - + sites(s)%youngest_patch => newp sites(s)%youngest_patch%younger => null() sites(s)%youngest_patch%older => sites(s)%oldest_patch @@ -2308,25 +2308,25 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) sites(s)%oldest_patch%older => null() else ! more than 2 patches, insert patch into youngest slot - + if ( debug ) write(fates_log(),*) 'idx_pa > 2 ',idx_pa - + newp%older => sites(s)%youngest_patch sites(s)%youngest_patch%younger => newp newp%younger => null() sites(s)%youngest_patch => newp - + endif - + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch enddo ! ends loop over idx_pa enddo ! ends loop over s - + end associate end subroutine create_patchcohort_structure - + ! ==================================================================================== subroutine get_restart_vectors(this, nc, nsites, sites) @@ -2337,7 +2337,6 @@ subroutine get_restart_vectors(this, nc, nsites, sites) use EDTypesMod, only : maxSWb use FatesInterfaceTypesMod, only : numpft use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch - use EDPhysiologyMod, only : assign_cohort_sp_properties use EDTypesMod, only : numWaterMem use EDTypesMod, only : num_vegtemp_mem use FatesSizeAgeTypeIndicesMod, only : get_age_class_index @@ -2373,7 +2372,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) integer :: io_idx_pa_cwd ! each cwd class within each patch (pa_cwd) integer :: io_idx_pa_cwsl ! each cwd x soil layer integer :: io_idx_pa_dcsl ! each decomposability x soil layer - integer :: io_idx_pa_dc ! each decomposability index + integer :: io_idx_pa_dc ! each decomposability index integer :: io_idx_pa_ib ! each SW radiation band per patch (pa_ib) integer :: io_idx_si_wmem ! each water memory class within each site integer :: io_idx_si_vtmem ! counter for vegetation temp memory @@ -2388,7 +2387,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) integer :: patchespersite ! number of patches per site - integer :: cohortsperpatch ! number of cohorts per patch + integer :: cohortsperpatch ! number of cohorts per patch integer :: el ! loop counter for elements integer :: nlevsoil ! number of soil layers integer :: ilyr ! soil layer loop counter @@ -2422,7 +2421,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_seed_prod_co => this%rvars(ir_seed_prod_co)%r81d, & rio_size_class_lasttimestep => this%rvars(ir_size_class_lasttimestep_co)%int1d, & rio_dbh_co => this%rvars(ir_dbh_co)%r81d, & - rio_coage_co => this%rvars(ir_coage_co)%r81d, & + rio_coage_co => this%rvars(ir_coage_co)%r81d, & rio_g_sb_laweight_co => this%rvars(ir_g_sb_laweight_co)%r81d, & rio_height_co => this%rvars(ir_height_co)%r81d, & rio_laimemory_co => this%rvars(ir_laimemory_co)%r81d, & @@ -2435,14 +2434,14 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_gpp_acc_hold_co => this%rvars(ir_gpp_acc_hold_co)%r81d, & rio_resp_acc_hold_co => this%rvars(ir_resp_acc_hold_co)%r81d, & rio_npp_acc_hold_co => this%rvars(ir_npp_acc_hold_co)%r81d, & - rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & + rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & - rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & - rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & - rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & - rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & + rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & + rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & + rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & + rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & rio_daily_p_efflux_co => this%rvars(ir_daily_p_efflux_co)%r81d, & rio_daily_n_demand_co => this%rvars(ir_daily_n_demand_co)%r81d, & rio_daily_p_demand_co => this%rvars(ir_daily_p_demand_co)%r81d, & @@ -2490,15 +2489,15 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_imortcflux_si => this%rvars(ir_imortcflux_si)%r81d, & rio_fmortcflux_cano_si => this%rvars(ir_fmortcflux_cano_si)%r81d, & rio_fmortcflux_usto_si => this%rvars(ir_fmortcflux_usto_si)%r81d) - + totalcohorts = 0 - + do s = 1,nsites - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) - + io_idx_co = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_si_wmem = io_idx_co_1st @@ -2511,13 +2510,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_sc = io_idx_co_1st io_idx_si_capf = io_idx_co_1st io_idx_si_cacls= io_idx_co_1st - + ! read seed_bank info(site-level, but PFT-resolved) - do i_pft = 1,numpft + do i_pft = 1,numpft sites(s)%recruitment_rate(i_pft) = rio_recrate_sift(io_idx_co_1st+i_pft-1) enddo - - !variables for fixed biogeography mode. These are currently used in restart even when this is off. + + !variables for fixed biogeography mode. These are currently used in restart even when this is off. do i_pft = 1,numpft sites(s)%use_this_pft(i_pft) = rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) sites(s)%area_pft(i_pft) = rio_area_pft_sift(io_idx_co_1st+i_pft-1) @@ -2529,13 +2528,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_cwd = io_idx_co_1st io_idx_si_pft = io_idx_co_1st io_idx_si_scpf = io_idx_co_1st - + do i_cwd=1,ncwd sites(s)%flux_diags(el)%cwd_ag_input(i_cwd) = this%rvars(ir_cwdagin_flxdg+el-1)%r81d(io_idx_si_cwd) sites(s)%flux_diags(el)%cwd_bg_input(i_cwd) = this%rvars(ir_cwdbgin_flxdg+el-1)%r81d(io_idx_si_cwd) io_idx_si_cwd = io_idx_si_cwd + 1 end do - + do i_pft=1,numpft sites(s)%flux_diags(el)%leaf_litter_input(i_pft) = this%rvars(ir_leaflittin_flxdg+el-1)%r81d(io_idx_si_pft) sites(s)%flux_diags(el)%root_litter_input(i_pft) = this%rvars(ir_rootlittin_flxdg+el-1)%r81d(io_idx_si_pft) @@ -2551,34 +2550,34 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_scpf = io_idx_si_scpf + 1 end do end do - - + + sites(s)%mass_balance(el)%old_stock = this%rvars(ir_oldstock_mbal+el-1)%r81d(io_idx_si) sites(s)%mass_balance(el)%err_fates = this%rvars(ir_errfates_mbal+el-1)%r81d(io_idx_si) end do - sites(s)%spread = rio_spread_si(io_idx_si) - + sites(s)%spread = rio_spread_si(io_idx_si) + ! Perform a check on the number of patches per site patchespersite = 0 - + cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - + patchespersite = patchespersite + 1 - + ccohort => cpatch%shortest - + ! new patch, reset num cohorts cohortsperpatch = 0 - - do while(associated(ccohort)) - + + do while(associated(ccohort)) + ! found cohort, increment cohortsperpatch = cohortsperpatch + 1 totalcohorts = totalcohorts + 1 - + if ( debug ) then write(fates_log(),*) 'CVTL io_idx_co ',io_idx_co endif @@ -2590,7 +2589,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ir_prt_var = ir_prt_base do i_var = 1, prt_global%num_vars - do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos + do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos ir_prt_var = ir_prt_var + 1 ccohort%prt%variables(i_var)%val(i_pos) = & @@ -2606,13 +2605,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ir_prt_var = ir_prt_var + 1 ccohort%prt%variables(i_var)%burned(i_pos) = & - this%rvars(ir_prt_var)%r81d(io_idx_co) + this%rvars(ir_prt_var)%r81d(io_idx_co) end do end do - !ccohort%vcmax25top + !ccohort%vcmax25top !ccohort%jmax25top - !ccohort%tpu25top + !ccohort%tpu25top !ccohort%kp25top @@ -2643,15 +2642,15 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%smort = rio_smort_co(io_idx_co) ccohort%asmort = rio_asmort_co(io_idx_co) ccohort%frmort = rio_frmort_co(io_idx_co) - + ! Nutrient uptake / efflux ccohort%daily_n_uptake = rio_daily_n_uptake_co(io_idx_co) ccohort%daily_p_uptake = rio_daily_p_uptake_co(io_idx_co) ccohort%daily_c_efflux = rio_daily_c_efflux_co(io_idx_co) ccohort%daily_n_efflux = rio_daily_n_efflux_co(io_idx_co) ccohort%daily_p_efflux = rio_daily_p_efflux_co(io_idx_co) - - ccohort%daily_n_demand = rio_daily_n_demand_co(io_idx_co) + + ccohort%daily_n_demand = rio_daily_n_demand_co(io_idx_co) ccohort%daily_p_demand = rio_daily_p_demand_co(io_idx_co) ccohort%daily_n_need2 = rio_daily_n_need_co(io_idx_co) ccohort%daily_p_need2 = rio_daily_p_need_co(io_idx_co) @@ -2673,18 +2672,18 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Initialize Plant Hydraulics if(hlm_use_planthydro==itrue)then - + ! Load the water contents call this%GetCohortRealVector(ccohort%co_hydr%th_ag,n_hypool_ag, & ir_hydro_th_ag_covec,io_idx_co) call this%GetCohortRealVector(ccohort%co_hydr%th_aroot,sites(s)%si_hydr%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) - + ccohort%co_hydr%errh2o_growturn_aroot = & this%rvars(ir_hydro_err_growturn_aroot)%r81d(io_idx_co) ccohort%co_hydr%errh2o_growturn_troot = & @@ -2698,11 +2697,11 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if (hlm_use_sp .eq. itrue) then ccohort%c_area = this%rvars(ir_c_area_co)%r81d(io_idx_co) end if - + io_idx_co = io_idx_co + 1 - + ccohort => ccohort%taller - + enddo ! current cohort do while if(cohortsperpatch .ne. rio_ncohort_pa(io_idx_co_1st)) then @@ -2727,20 +2726,20 @@ subroutine get_restart_vectors(this, nc, nsites, sites) cpatch%solar_zenith_angle = rio_solar_zenith_angle_pa(io_idx_co_1st) ! set cohorts per patch for IO - + if ( debug ) then write(fates_log(),*) 'CVTL III ' & ,io_idx_co,cohortsperpatch endif - + ! -------------------------------------------------------------------------- ! Pull litter from the restart arrays - ! Each element has its own variable, so we have to make sure - ! we keep re-setting this + ! Each element has its own variable, so we have to make sure + ! we keep re-setting this ! -------------------------------------------------------------------------- do el = 0, num_elements-1 - + io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_cwsl = io_idx_co_1st @@ -2766,13 +2765,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_pa_dcsl = io_idx_pa_dcsl + 1 end do end do - + do i = 1,ncwd litt%ag_cwd(i) = this%rvars(ir_agcwd_litt+el)%r81d(io_idx_pa_cwd) litt%ag_cwd_frag(i) = this%rvars(ir_agcwd_frag_litt+el)%r81d(io_idx_pa_cwd) io_idx_pa_cwd = io_idx_pa_cwd + 1 - + do ilyr=1,nlevsoil litt%bg_cwd(i,ilyr) = this%rvars(ir_bgcwd_litt+el)%r81d(io_idx_pa_cwsl) litt%bg_cwd_frag(i,ilyr) = this%rvars(ir_bgcwd_frag_litt+el)%r81d(io_idx_pa_cwsl) @@ -2790,30 +2789,30 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Now increment the position of the first cohort to that of the next ! patch - + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch - + ! and max the number of allowed cohorts per patch io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_co = io_idx_co_1st - + if ( debug ) then write(fates_log(),*) 'CVTL io_idx_co_1st ', io_idx_co_1st write(fates_log(),*) 'CVTL cohortsperpatch ', cohortsperpatch write(fates_log(),*) 'CVTL totalCohorts ', totalCohorts end if - + cpatch => cpatch%younger - + enddo ! patch do while - + if(patchespersite .ne. rio_npatch_si(io_idx_si)) then write(fates_log(),*) 'Number of patches per site during retrieval does not match allocation' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + do i = 1,numWaterMem sites(s)%water_memory(i) = rio_watermem_siwm( io_idx_si_wmem ) io_idx_si_wmem = io_idx_si_wmem + 1 @@ -2828,7 +2827,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Retrieve site-level hydraulics arrays ! Note that Hydraulics structures, their allocations, and the length ! declaration nlevsoi_hyd should be allocated early on when the code first - ! allocates sites (before restart info), and when the soils layer is + ! allocates sites (before restart info), and when the soils layer is ! first known. ! ----------------------------------------------------------------------------- @@ -2851,7 +2850,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) end do end if - + ! Fill the site level diagnostics arrays ! ----------------------------------------------------------------------------- @@ -2864,7 +2863,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%fmort_rate_ustory(i_scls, i_pft) = rio_fmortrate_usto_siscpf(io_idx_si_scpf) sites(s)%imort_rate(i_scls, i_pft) = rio_imortrate_siscpf(io_idx_si_scpf) sites(s)%fmort_rate_crown(i_scls, i_pft) = rio_fmortrate_crown_siscpf(io_idx_si_scpf) - sites(s)%fmort_rate_cambial(i_scls, i_pft) = rio_fmortrate_cambi_siscpf(io_idx_si_scpf) + sites(s)%fmort_rate_cambial(i_scls, i_pft) = rio_fmortrate_cambi_siscpf(io_idx_si_scpf) sites(s)%term_nindivs_canopy(i_scls,i_pft) = rio_termnindiv_cano_siscpf(io_idx_si_scpf) sites(s)%term_nindivs_ustory(i_scls,i_pft) = rio_termnindiv_usto_siscpf(io_idx_si_scpf) sites(s)%growthflux_fusion(i_scls, i_pft) = rio_growflx_fusion_siscpf(io_idx_si_scpf) @@ -2873,7 +2872,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%demotion_rate(i_scls) = rio_demorate_sisc(io_idx_si_sc) sites(s)%promotion_rate(i_scls) = rio_promrate_sisc(io_idx_si_sc) - + io_idx_si_sc = io_idx_si_sc + 1 end do @@ -2885,7 +2884,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%fmort_carbonflux_canopy = rio_fmortcflux_cano_si(io_idx_si) sites(s)%fmort_carbonflux_ustory = rio_fmortcflux_usto_si(io_idx_si) - + ! Site level phenology status flags sites(s)%cstatus = rio_cd_status_si(io_idx_si) @@ -2906,10 +2905,10 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if ( debug ) then write(fates_log(),*) 'CVTL total cohorts ',totalCohorts end if - + end associate end subroutine get_restart_vectors - + ! ==================================================================================== subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) @@ -2938,12 +2937,12 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) integer :: ifp ! patch counter do s = 1, nsites - + ifp = 0 currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) + do while (associated(currentpatch)) ifp = ifp+1 - + currentPatch%f_sun (:,:,:) = 0._r8 currentPatch%fabd_sun_z (:,:,:) = 0._r8 currentPatch%fabd_sha_z (:,:,:) = 0._r8 @@ -2957,7 +2956,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 - + ! ----------------------------------------------------------- ! When calling norman radiation from the short-timestep ! we are passing in boundary conditions to set the following @@ -2965,9 +2964,9 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ! currentPatch%solar_zenith_flag (is there daylight?) ! currentPatch%solar_zenith_angle (what is the value?) ! ----------------------------------------------------------- - + if(currentPatch%solar_zenith_flag)then - + bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM @@ -2975,10 +2974,10 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM - + if (maxval(currentPatch%nrad(1,:))==0)then - !there are no leaf layers in this patch. it is effectively bare ground. - ! no radiation is absorbed + !there are no leaf layers in this patch. it is effectively bare ground. + ! no radiation is absorbed bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 do ib = 1,hlm_numSWb @@ -2992,7 +2991,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 enddo else - + call PatchNormanRadiation (currentPatch, & bc_out(s)%albd_parb(ifp,:), & bc_out(s)%albi_parb(ifp,:), & @@ -3001,14 +3000,14 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftdd_parb(ifp,:), & bc_out(s)%ftid_parb(ifp,:), & bc_out(s)%ftii_parb(ifp,:)) - - endif ! is there vegetation? - + + endif ! is there vegetation? + end if ! if the vegetation and zenith filter is active currentPatch => currentPatch%younger end do ! Loop linked-list patches enddo ! Loop Sites - + return end subroutine update_3dpatch_radiation From 848bc4876d74cd2a2bb6a03b44da59137d4a722e Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 24 Jun 2021 01:51:43 -0600 Subject: [PATCH 328/578] modified photosynthetic radiation --- biogeophys/EDSurfaceAlbedoMod.F90 | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index d8d4540463..726e1bf1cb 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -221,7 +221,7 @@ subroutine PatchNormanRadiation (currentPatch, & real(r8) :: f_abs(nclmax,maxpft,nlevleaf,maxSWb) ! Fraction of light absorbed by surfaces. real(r8) :: rho_layer(nclmax,maxpft,nlevleaf,maxSWb)! Weighted verage reflectance of layer real(r8) :: tau_layer(nclmax,maxpft,nlevleaf,maxSWb)! Weighted average transmittance of layer - + real(r8) :: f_abs_leaf(nclmax,maxpft,nlevleaf,maxSWb) real(r8) :: Abs_dir_z(maxpft,nlevleaf) real(r8) :: Abs_dif_z(maxpft,nlevleaf) real(r8) :: abs_rad(maxSWb) !radiation absorbed by soil @@ -293,6 +293,7 @@ subroutine PatchNormanRadiation (currentPatch, & rho_layer(:,:,:,:)=0.0_r8 tau_layer(:,:,:,:)=0.0_r8 f_abs(:,:,:,:)=0.0_r8 + f_abs_leaf(:,:,:,:)=0._r8 do L = 1,nclmax do ft = 1,numpft currentPatch%canopy_mask(L,ft) = 0 @@ -311,6 +312,8 @@ subroutine PatchNormanRadiation (currentPatch, & frac_sai = 1.0_r8 - frac_lai f_abs(L,ft,iv,ib) = 1.0_r8 - (frac_lai*(rhol(ft,ib) + taul(ft,ib))+& frac_sai*(rhos(ft,ib) + taus(ft,ib))) + f_abs_leaf(L,ft,iv,ib) = frac_lai*(1.0_r8 - rhol(ft,ib) - taul(ft,ib))/f_abs(L,ft,iv,ib) + rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) tau_layer(L,ft,iv,ib)=frac_lai*taul(ft,ib)+frac_sai*taus(ft,ib) @@ -833,15 +836,15 @@ subroutine PatchNormanRadiation (currentPatch, & currentPatch%fabd_sun_z(L,ft,iv) endif currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - (1._r8 - currentPatch%f_sun(L,ft,iv)) - currentPatch%fabd_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv))*f_abs_leaf(L,ft,iv,ib) + currentPatch%fabd_sun_z(L,ft,iv) =( Abs_dif_z(ft,iv) * & currentPatch%f_sun(L,ft,iv) + & - Abs_dir_z(ft,iv) + Abs_dir_z(ft,iv))*f_abs_leaf(L,ft,iv,ib) else currentPatch%fabi_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - (1._r8 - currentPatch%f_sun(L,ft,iv)) + (1._r8 - currentPatch%f_sun(L,ft,iv))*f_abs_leaf(L,ft,iv,ib) currentPatch%fabi_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - currentPatch%f_sun(L,ft,iv) + currentPatch%f_sun(L,ft,iv)*f_abs_leaf(L,ft,iv,ib) endif if ( debug ) then write(fates_log(),*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & From b887b062b9f0489eab2d4778d59ce038386bf349 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 24 Jun 2021 10:31:36 -0400 Subject: [PATCH 329/578] Adding both patch and cohort level photosynthesis acclimation vegetation temperature running mean. --- biogeochem/EDCohortDynamicsMod.F90 | 17 +++++++++++++++-- biogeochem/EDPatchDynamicsMod.F90 | 8 ++++++-- main/EDInitMod.F90 | 14 ++++++++------ main/EDTypesMod.F90 | 12 ++++++++++++ main/FatesInterfaceMod.F90 | 14 +++++++++++++- main/FatesRunningMeanMod.F90 | 1 + 6 files changed, 55 insertions(+), 11 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index b6714ee3e9..e50d168533 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -300,8 +300,10 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & call InitPRTBoundaryConditions(new_cohort) - - + ! Allocate running mean functions + allocate(new_cohort%tveg_lpa) + call new_cohort%tveg_lpa%InitRMean(ema_lpa) + ! Recuits do not have mortality rates, nor have they moved any ! carbon when they are created. They will bias our statistics ! until they have experienced a full day. We need a newly recruited flag. @@ -991,6 +993,9 @@ subroutine DeallocateCohort(currentCohort) ! ---------------------------------------------------------------------------------- type(ed_cohort_type),intent(inout) :: currentCohort + + ! Remove the running mean structure + deallocate(new_cohort%tveg_lpa) ! At this point, nothing should be pointing to current Cohort if (hlm_use_planthydro.eq.itrue) call DeallocateHydrCohort(currentCohort) @@ -1155,6 +1160,10 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) end do end if + ! Running mean fuses based on number density fraction just + ! like other variables + call currentCohort%tveg_lpa%FuseRMean(nextc%tveg_lpa,currentCohort%n/newn) + ! new cohort age is weighted mean of two cohorts currentCohort%coage = & (currentCohort%coage * (currentCohort%n/(currentCohort%n + nextc%n))) + & @@ -1786,6 +1795,7 @@ subroutine copy_cohort( currentCohort,copyc ) n%size_by_pft_class = o%size_by_pft_class n%coage_class = o%coage_class n%coage_by_pft_class = o%coage_by_pft_class + ! This transfers the PRT objects over. call n%prt%CopyPRTVartypes(o%prt) @@ -1795,6 +1805,9 @@ subroutine copy_cohort( currentCohort,copyc ) n%tpu25top = o%tpu25top n%kp25top = o%kp25top + ! Copy over running means + n%tveg_lpa%CopyFromDonor(o%tveg_lpa) + ! CARBON FLUXES n%gpp_acc_hold = o%gpp_acc_hold n%gpp_acc = o%gpp_acc diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index c9f5b2d16f..12da82bf23 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -85,7 +85,7 @@ module EDPatchDynamicsMod use SFParamsMod, only : SF_VAL_CWD_FRAC use EDParamsMod, only : logging_event_code use EDParamsMod, only : logging_export_frac - use FatesRunningMeanMod, only : ema_24hr, fixed_24hr + use FatesRunningMeanMod, only : ema_24hr, fixed_24hr, ema_lpa ! CIME globals use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) @@ -676,7 +676,7 @@ subroutine spawn_patches( currentSite, bc_in) ! These values will inherit all info from the original patch ! -------------------------------------------------------------------------- call new_patch%tveg24%CopyFromDonor(currentPatch%tveg24) - + call new_patch%tveg_lpa%CopyFromDonor(currentPatch%tveg_lpa) ! -------------------------------------------------------------------------- @@ -2013,6 +2013,8 @@ subroutine create_patch(currentSite, new_patch, age, areap, label) allocate(new_patch%tveg24) call new_patch%tveg24%InitRMean(fixed_24hr,init_value=temp_init_vegc,init_offset=real(hlm_current_tod,r8) ) + allocate(new_patch%tveg_lpa) + call new_patch%tveg_lpa%InitRmean(ema_lpa,init_value=temp_init_vegc) ! Litter ! Allocate, Zero Fluxes, and Initialize to "unset" values @@ -2517,6 +2519,7 @@ subroutine fuse_2_patches(csite, dp, rp) ! Weighted mean of the running means call rp%tveg24%FuseRMean(dp%tveg24,rp%area*inv_sum_area) + call rp%tveg_lpa%FuseRMean(dp%tveg_lpa,rp%area*inv_sum_area) rp%fuel_eff_moist = (dp%fuel_eff_moist*dp%area + rp%fuel_eff_moist*rp%area) * inv_sum_area rp%livegrass = (dp%livegrass*dp%area + rp%livegrass*rp%area) * inv_sum_area @@ -2858,6 +2861,7 @@ subroutine dealloc_patch(cpatch) ! Deallocate any running means deallocate(cpatch%tveg24) + deallocate(cpatch%tveg_lpa) return end subroutine dealloc_patch diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 6b3d861a28..8862e7237a 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -672,12 +672,14 @@ subroutine init_cohorts( site_in, patch_in, bc_in) endif !use_this_pft enddo !numpft - ! Zero the mass flux pools of the new cohorts -! temp_cohort => patch_in%tallest -! do while(associated(temp_cohort)) -! call temp_cohort%prt%ZeroRates() -! temp_cohort => temp_cohort%shorter -! end do + ! Pass patch level temperature to the new cohorts (this is a nominal 15C right now) + temp_cohort => patch_in%tallest + do while(associated(temp_cohort)) + call temp_cohort%tveg_lpa%UpdateRmean(patch_in%tveg_lpa%GetMean()) + temp_cohort => temp_cohort%shorter + end do + + call fuse_cohorts(site_in, patch_in,bc_in) call sort_cohorts(patch_in) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 9904e360e3..55b42e41d9 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -192,6 +192,12 @@ module EDTypesMod integer, public :: n_uptake_mode integer, public :: p_uptake_mode + + + ! Leaf photosynthetic temperature acclimation timescale [days] + ! (This variable may be moved to the FATES parameter file soon) + + real(r8), parameter, public :: leaf_photo_temp_acclim_days = 30._r8 !************************************ @@ -388,6 +394,12 @@ module EDTypesMod ! Hydraulics type(ed_cohort_hydr_type), pointer :: co_hydr ! All cohort hydraulics data, see FatesHydraulicsMemMod.F90 + + ! Running means + class(rmean_type), pointer :: tveg_lpa ! exponential moving average of leaf temperature at the + ! leaf photosynthetic acclimation time-scale + + end type ed_cohort_type !************************************ diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index ca0f95a03a..2b86c4f236 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -23,6 +23,7 @@ module FatesInterfaceMod use EDTypesMod , only : numlevsoil_max use EDTypesMod , only : ed_site_type use EDTypesMod , only : ed_patch_type + use EDTypesMod , only : leaf_photo_temp_acclim_days use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue,ifalse use FatesConstantsMod , only : nearzero @@ -72,6 +73,7 @@ module FatesInterfaceMod use PRTAllometricCNPMod , only : InitPRTGlobalAllometricCNP use FatesRunningMeanMod , only : ema_24hr use FatesRunningMeanMod , only : fixed_24hr + use FatesRunningMeanMod , only : ema_lpa use FatesRunningMeanMod , only : moving_ema_window use FatesRunningMeanMod , only : fixed_window @@ -865,7 +867,8 @@ subroutine SetFatesGlobalElements(use_fates) call ema_24hr%define(sec_per_day, hlm_stepsize, moving_ema_window) allocate(fixed_24hr) call fixed_24hr%define(sec_per_day, hlm_stepsize, fixed_window) - + allocate(ema_lpa) + call ema_lpa%define(leaf_photo_temp_acclim_days,hlm_stepsize,moving_ema_window) else @@ -1839,6 +1842,7 @@ subroutine UpdateFatesRMeansTStep(sites,bc_in) type(bc_in_type), intent(in) :: bc_in(:) type(ed_patch_type), pointer :: cpatch + type(ed_cohort_type), pointer :: ccohort integer :: s, ifp @@ -1848,6 +1852,14 @@ subroutine UpdateFatesRMeansTStep(sites,bc_in) do while(associated(cpatch)) ifp=ifp+1 call cpatch%tveg24%UpdateRMean(bc_in(s)%tveg_pa(ifp)) + call cpatch%tveg_lpa%UpdateRMean(bc_in(s)%tveg_pa(ifp)) + + ccohort => cpatch%tallest + do while (associated(ccohort)) + call ccohort%tveg_lpa%UpdateRMean(bc_in(s)%tveg_pa(ifp)) + ccohort => ccohort%shorter + end do + cpatch => cpatch%younger enddo enddo diff --git a/main/FatesRunningMeanMod.F90 b/main/FatesRunningMeanMod.F90 index 5075417bea..df1c12c7be 100644 --- a/main/FatesRunningMeanMod.F90 +++ b/main/FatesRunningMeanMod.F90 @@ -90,6 +90,7 @@ module FatesRunningMeanMod class(rmean_def_type), public, pointer :: ema_24hr ! Exponential moving average - 24hr window class(rmean_def_type), public, pointer :: fixed_24hr ! Fixed, 24-hour window + class(rmean_def_type), public, pointer :: ema_lpa ! Exponential moving average - leaf photo acclimation contains From 8c8da99540ffc4a2f887368d4e8339192e433323 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 22 Jun 2021 12:06:02 -0600 Subject: [PATCH 330/578] Changed loop bounds in history writing to use actual rather than maximum canopy layers and leaf layers --- main/FatesHistoryInterfaceMod.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 97f3342b43..a7deb6fea4 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3682,8 +3682,8 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! summarize radiation profiles through the canopy do ipft=1,numpft - do ican=1,nclmax ! cpatch%ncl_p ? - do ileaf=1,nlevleaf ! cpatch%ncan(ican,ipft) ? + do ican=1,cpatch%ncl_p + do ileaf=1,cpatch%ncan(ican,ipft) ! calculate where we are on multiplexed dimensions cnlfpft_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax cnlf_indx = ileaf + (ican-1) * nlevleaf @@ -3756,11 +3756,12 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) cpatch%fabi_sha_z(ican,ipft,1) * cpatch%area * AREA_INV ! end do - end do + end do ! PFT-mean radiation profiles - do ican=1,nclmax - do ileaf=1,nlevleaf + do ican = 1, cpatch%ncl_p + do ileaf = 1, maxval(cpatch%nrad(ican,:)) + ! calculate where we are on multiplexed dimensions cnlf_indx = ileaf + (ican-1) * nlevleaf ! From 4e5a24934c3d265eae48426b0959e5578422b904 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 24 Jun 2021 22:52:16 -0400 Subject: [PATCH 331/578] Adding parameters for logistic root growth. --- parameter_files/fates_params_default.cdl | 31 +++++++++++++++ parteh/PRTParametersMod.F90 | 8 +++- parteh/PRTParamsFATESMod.F90 | 49 +++++++++++++++++++++++- 3 files changed, 86 insertions(+), 2 deletions(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 86d46710da..a6e0d42299 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -124,6 +124,27 @@ variables: fates_allom_stmode:units = "index" ; fates_allom_stmode:long_name = "storage allometry function index." ; fates_allom_stmode:possible_values = "1: target storage proportional to trimmed maximum leaf biomass." ; + + double fates_allom_zroot_max_dbh(fates_pft) ; + fates_allom_zroot_max_dbh:units = "cm" ; + fates_allom_zroot_max_dbh:long_name = "dbh at which maximum rooting depth is defined" ; + + double fates_allom_zroot_max_z(fates_pft) ; + fates_allom_zroot_max_z:units = "m" ; + fates_allom_zroot_max_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_max_dbh" ; + + double fates_allom_zroot_min_dbh(fates_pft) ; + fates_allom_zroot_min_dbh:units = "cm" ; + fates_allom_zroot_min_dbh:long_name = "dbh at which the rooting depth for a recruit is defined" ; + + double fates_allom_zroot_min_z(fates_pft) ; + fates_allom_zroot_min_z:units = "m" ; + fates_allom_zroot_min_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_min_dbh" ; + + double fates_allom_zroot_k(fates_pft) ; + fates_allom_zroot_k:units = "unitless" ; + fates_allom_zroot_k:long_name = "scale coefficient of logistic rooting depth model" ; + double fates_branch_turnover(fates_pft) ; fates_branch_turnover:units = "yr" ; fates_branch_turnover:long_name = "turnover time of branches" ; @@ -797,6 +818,16 @@ data: fates_allom_stmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + fates_allom_zroot_max_dbh = 100, 100, 100, 100, 100, 100, 2, 2, 2, 2, 2, 2 ; + + fates_allom_zroot_max_z = 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100; + + fates_allom_zroot_min_dbh = 1, 1, 1, 2.5, 2.5, 2.5, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 ; + + fates_allom_zroot_min_z = 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100; + + fates_allom_zroot_k = 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10 ; + fates_branch_turnover = 150, 150, 150, 150, 150, 150, 150, 150, 150, 0, 0, 0 ; fates_c2b = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 ; diff --git a/parteh/PRTParametersMod.F90 b/parteh/PRTParametersMod.F90 index 6e2c17ac66..8fb57cb6b6 100644 --- a/parteh/PRTParametersMod.F90 +++ b/parteh/PRTParametersMod.F90 @@ -136,7 +136,13 @@ module PRTParametersMod real(r8), allocatable :: allom_agb2(:) ! Parameter 2 for agb allometry real(r8), allocatable :: allom_agb3(:) ! Parameter 3 for agb allometry real(r8), allocatable :: allom_agb4(:) ! Parameter 3 for agb allometry - + + real(r8), allocatable :: allom_zroot_max_dbh(:) ! dbh at which maximum rooting depth saturates (largest possible) [cm] + real(r8), allocatable :: allom_zroot_max_z(:) ! the maximum rooting depth defined at dbh = fates_allom_zroot_max_dbh [m] + real(r8), allocatable :: allom_zroot_min_dbh(:) ! dbh at which the maximum rooting depth for a recruit is defined [cm] + real(r8), allocatable :: allom_zroot_min_z(:) ! the maximum rooting depth defined at dbh = fates_allom_zroot_min_dbh [m] + real(r8), allocatable :: allom_zroot_k(:) ! scale coefficient of logistic rooting depth model + end type prt_param_type diff --git a/parteh/PRTParamsFATESMod.F90 b/parteh/PRTParamsFATESMod.F90 index 4442c090e8..dce172d47d 100644 --- a/parteh/PRTParamsFATESMod.F90 +++ b/parteh/PRTParamsFATESMod.F90 @@ -331,6 +331,26 @@ subroutine PRTRegisterPFT(fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_allom_zroot_max_dbh' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_zroot_max_z' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_zroot_min_dbh' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_zroot_min_z' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_zroot_k' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_turnover_retrans_mode' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -554,7 +574,27 @@ subroutine PRTReceivePFT(fates_params) name = 'fates_allom_agb4' call fates_params%RetreiveParameterAllocate(name=name, & data=prt_params%allom_agb4) - + + name = 'fates_allom_zroot_max_dbh' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_zroot_max_dbh) + + name = 'fates_allom_zroot_max_z' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_zroot_max_z) + + name = 'fates_allom_zroot_min_dbh' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_zroot_min_dbh) + + name = 'fates_allom_zroot_min_z' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_zroot_min_z) + + name = 'fates_allom_zroot_k' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_zroot_k) + name = 'fates_branch_turnover' call fates_params%RetreiveParameterAllocate(name=name, & data=prt_params%branch_long) @@ -850,6 +890,13 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'allom_agb2 = ',prt_params%allom_agb2 write(fates_log(),fmt0) 'allom_agb3 = ',prt_params%allom_agb3 write(fates_log(),fmt0) 'allom_agb4 = ',prt_params%allom_agb4 + + write(fates_log(),fmt0) 'allom_zroot_max_dbh = ',prt_params%allom_zroot_max_dbh + write(fates_log(),fmt0) 'allom_zroot_max_z = ',prt_params%allom_zroot_max_z + write(fates_log(),fmt0) 'allom_zroot_min_dbh = ',prt_params%allom_zroot_min_dbh + write(fates_log(),fmt0) 'allom_zroot_min_z = ',prt_params%allom_zroot_min_z + write(fates_log(),fmt0) 'allom_zroot_k = ',prt_params%allom_zroot_k + write(fates_log(),fmt0) 'prt_nitr_stoich_p1 = ',prt_params%nitr_stoich_p1 write(fates_log(),fmt0) 'prt_nitr_stoich_p2 = ',prt_params%nitr_stoich_p2 write(fates_log(),fmt0) 'prt_phos_stoich_p1 = ',prt_params%phos_stoich_p1 From 03b3a9ca79c2384c031db1691e0c0b7bb742d512 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 24 Jun 2021 23:16:49 -0400 Subject: [PATCH 332/578] Adding VAI variable bin scaling parameters, updating notes on zroot parameters. --- main/EDParamsMod.F90 | 28 +++++++++++++++++++++++- parameter_files/fates_params_default.cdl | 20 ++++++++++++----- parteh/PRTParametersMod.F90 | 3 ++- 3 files changed, 44 insertions(+), 7 deletions(-) diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 8162939bc3..0afdbcf658 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -20,7 +20,14 @@ module EDParamsMod ! ! this is what the user can use for the actual values ! - + + real(r8),protected, public :: vai_top_bin_width ! width in VAI units of uppermost leaf+stem + ! layer scattering element in each canopy layer [m2/m2] + ! (NOT YET IMPLEMENTED) + real(r8),protected, public :: vai_width_increase_factor ! factor by which each leaf+stem scattering element + ! increases in VAI width (1 = uniform spacing) + ! (NOT YET IMPLEMENTED) + real(r8),protected, public :: fates_mortality_disturbance_fraction ! the fraction of canopy mortality that results in disturbance real(r8),protected, public :: ED_val_comp_excln real(r8),protected, public :: ED_val_init_litter @@ -59,6 +66,9 @@ module EDParamsMod real(r8),protected,allocatable,public :: ED_val_history_ageclass_bin_edges(:) real(r8),protected,allocatable,public :: ED_val_history_height_bin_edges(:) real(r8),protected,allocatable,public :: ED_val_history_coageclass_bin_edges(:) + + character(len=param_string_length),parameter,public :: ED_name_vai_top_bin_width = "fates_vai_top_bin_width" + character(len=param_string_length),parameter,public :: ED_name_vai_width_increase_factor = "fates_vai_width_increase_factor" character(len=param_string_length),parameter,public :: ED_name_mort_disturb_frac = "fates_mort_disturb_frac" character(len=param_string_length),parameter,public :: ED_name_comp_excln = "fates_comp_excln" @@ -173,6 +183,8 @@ subroutine FatesParamsInit() implicit none + vai_top_bin_width = nan + vai_width_increase_factor = nan fates_mortality_disturbance_fraction = nan ED_val_comp_excln = nan ED_val_init_litter = nan @@ -240,6 +252,12 @@ subroutine FatesRegisterParams(fates_params) call FatesParamsInit() + call fates_params%RegisterParameter(name=ED_name_vai_top_bin_width, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=ED_name_vai_width_increase_factor, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_mort_disturb_frac, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) @@ -390,6 +408,12 @@ subroutine FatesReceiveParams(fates_params) class(fates_parameters_type), intent(inout) :: fates_params real(r8) :: tmpreal ! local real variable for changing type on read + + call fates_params%RetreiveParameter(name=ED_name_vai_top_bin_width, & + data=vai_top_bin_width) + + call fates_params%RetreiveParameter(name=ED_name_vai_width_increase_factor, & + data=vai_width_increase_factor) call fates_params%RetreiveParameter(name=ED_name_mort_disturb_frac, & data=fates_mortality_disturbance_fraction) @@ -544,6 +568,8 @@ subroutine FatesReportParams(is_master) if(debug_report .and. is_master) then write(fates_log(),*) '----------- FATES Scalar Parameters -----------------' + write(fates_log(),fmt0) 'vai_top_bin_width = ',vai_top_bin_width + write(fates_log(),fmt0) 'vai_width_increase_factor = ',vai_width_increase_factor write(fates_log(),fmt0) 'fates_mortality_disturbance_fraction = ',fates_mortality_disturbance_fraction write(fates_log(),fmt0) 'ED_val_comp_excln = ',ED_val_comp_excln write(fates_log(),fmt0) 'ED_val_init_litter = ',ED_val_init_litter diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index a6e0d42299..7d53d4cb08 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -127,23 +127,23 @@ variables: double fates_allom_zroot_max_dbh(fates_pft) ; fates_allom_zroot_max_dbh:units = "cm" ; - fates_allom_zroot_max_dbh:long_name = "dbh at which maximum rooting depth is defined" ; + fates_allom_zroot_max_dbh:long_name = "dbh at which maximum rooting depth is defined (NOT USED)" ; double fates_allom_zroot_max_z(fates_pft) ; fates_allom_zroot_max_z:units = "m" ; - fates_allom_zroot_max_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_max_dbh" ; + fates_allom_zroot_max_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_max_dbh (NOT USED). note: max_z=min_z=large, sets rooting depth to soil depth" ; double fates_allom_zroot_min_dbh(fates_pft) ; fates_allom_zroot_min_dbh:units = "cm" ; - fates_allom_zroot_min_dbh:long_name = "dbh at which the rooting depth for a recruit is defined" ; + fates_allom_zroot_min_dbh:long_name = "dbh at which the rooting depth for a recruit is defined (NOT USED)" ; double fates_allom_zroot_min_z(fates_pft) ; fates_allom_zroot_min_z:units = "m" ; - fates_allom_zroot_min_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_min_dbh" ; + fates_allom_zroot_min_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_min_dbh (NOT USED) note: max_z=min_z=large, sets rooting depth to soil depth" ; double fates_allom_zroot_k(fates_pft) ; fates_allom_zroot_k:units = "unitless" ; - fates_allom_zroot_k:long_name = "scale coefficient of logistic rooting depth model" ; + fates_allom_zroot_k:long_name = "scale coefficient of logistic rooting depth model (NOT USED)" ; double fates_branch_turnover(fates_pft) ; fates_branch_turnover:units = "yr" ; @@ -708,6 +708,12 @@ variables: double fates_soil_salinity ; fates_soil_salinity:units = "ppt" ; fates_soil_salinity:long_name = "soil salinity used for model when not coupled to dynamic soil salinity" ; + double fates_vai_top_bin_width ; + fates_vai_top_bin_width:units = "m2/m2" ; + fates_vai_top_bin_width:long_name = "width in VAI units of uppermost leaf+stem layer scattering element in each canopy layer (NOT USED)" ; + double fates_vai_width_increase_factor ; + fates_vai_width_increase_factor:units = "unitless" ; + fates_vai_width_increase_factor:long_name = "factor by which each leaf+stem scattering element increases in VAI width (1 = uniform spacing) (NOT USED)" ; // global attributes: :history = "This parameter file is maintained in version control\nSee https://github.com/NGEET/fates/blob/master/parameter_files/fates_params_default.cdl \nFor changes, use git blame \n" ; @@ -1360,4 +1366,8 @@ data: fates_q10_mr = 1.5 ; fates_soil_salinity = 0.4 ; + + fates_vai_top_bin_width = 1.0 ; + + fates_vai_width_increase_factor = 1.0 ; } diff --git a/parteh/PRTParametersMod.F90 b/parteh/PRTParametersMod.F90 index 8fb57cb6b6..dcf20dbd14 100644 --- a/parteh/PRTParametersMod.F90 +++ b/parteh/PRTParametersMod.F90 @@ -136,7 +136,8 @@ module PRTParametersMod real(r8), allocatable :: allom_agb2(:) ! Parameter 2 for agb allometry real(r8), allocatable :: allom_agb3(:) ! Parameter 3 for agb allometry real(r8), allocatable :: allom_agb4(:) ! Parameter 3 for agb allometry - + + ! ------------------------ (NOT YET IMPLEMENTED) ------------------------- real(r8), allocatable :: allom_zroot_max_dbh(:) ! dbh at which maximum rooting depth saturates (largest possible) [cm] real(r8), allocatable :: allom_zroot_max_z(:) ! the maximum rooting depth defined at dbh = fates_allom_zroot_max_dbh [m] real(r8), allocatable :: allom_zroot_min_dbh(:) ! dbh at which the maximum rooting depth for a recruit is defined [cm] From a361b69d165746028164b485a07441f4f2a0bf89 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 24 Jun 2021 23:29:05 -0400 Subject: [PATCH 333/578] Added parameters for photosynthetic temperature acclimation timescale --- main/EDParamsMod.F90 | 27 +++++++++++++++++------- parameter_files/fates_params_default.cdl | 13 +++++++++++- 2 files changed, 31 insertions(+), 9 deletions(-) diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 0afdbcf658..51f8d39add 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -21,13 +21,16 @@ module EDParamsMod ! this is what the user can use for the actual values ! - real(r8),protected, public :: vai_top_bin_width ! width in VAI units of uppermost leaf+stem - ! layer scattering element in each canopy layer [m2/m2] - ! (NOT YET IMPLEMENTED) - real(r8),protected, public :: vai_width_increase_factor ! factor by which each leaf+stem scattering element - ! increases in VAI width (1 = uniform spacing) - ! (NOT YET IMPLEMENTED) - + real(r8),protected, public :: vai_top_bin_width ! width in VAI units of uppermost leaf+stem + ! layer scattering element in each canopy layer [m2/m2] + ! (NOT YET IMPLEMENTED) + real(r8),protected, public :: vai_width_increase_factor ! factor by which each leaf+stem scattering element + ! increases in VAI width (1 = uniform spacing) + ! (NOT YET IMPLEMENTED) + real(r8),protected, public :: photo_temp_acclim_timescale ! Length of the window for the exponential moving average (ema) + ! of vegetation temperature used in photosynthesis + ! temperature acclimation (NOT YET IMPLEMENTED) + real(r8),protected, public :: fates_mortality_disturbance_fraction ! the fraction of canopy mortality that results in disturbance real(r8),protected, public :: ED_val_comp_excln real(r8),protected, public :: ED_val_init_litter @@ -69,7 +72,7 @@ module EDParamsMod character(len=param_string_length),parameter,public :: ED_name_vai_top_bin_width = "fates_vai_top_bin_width" character(len=param_string_length),parameter,public :: ED_name_vai_width_increase_factor = "fates_vai_width_increase_factor" - + character(len=param_string_length),parameter,public :: ED_name_photo_temp_acclim_timescale = "fates_photo_temp_acclim_timescale" character(len=param_string_length),parameter,public :: ED_name_mort_disturb_frac = "fates_mort_disturb_frac" character(len=param_string_length),parameter,public :: ED_name_comp_excln = "fates_comp_excln" character(len=param_string_length),parameter,public :: ED_name_init_litter = "fates_init_litter" @@ -185,6 +188,7 @@ subroutine FatesParamsInit() vai_top_bin_width = nan vai_width_increase_factor = nan + photo_temp_acclim_timescale = nan fates_mortality_disturbance_fraction = nan ED_val_comp_excln = nan ED_val_init_litter = nan @@ -258,6 +262,9 @@ subroutine FatesRegisterParams(fates_params) call fates_params%RegisterParameter(name=ED_name_vai_width_increase_factor, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_photo_temp_acclim_timescale, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_mort_disturb_frac, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) @@ -414,6 +421,9 @@ subroutine FatesReceiveParams(fates_params) call fates_params%RetreiveParameter(name=ED_name_vai_width_increase_factor, & data=vai_width_increase_factor) + + call fates_params%RetreiveParameter(name=ED_name_photo_temp_acclim_timescale, & + data=photo_temp_acclim_timescale) call fates_params%RetreiveParameter(name=ED_name_mort_disturb_frac, & data=fates_mortality_disturbance_fraction) @@ -570,6 +580,7 @@ subroutine FatesReportParams(is_master) write(fates_log(),*) '----------- FATES Scalar Parameters -----------------' write(fates_log(),fmt0) 'vai_top_bin_width = ',vai_top_bin_width write(fates_log(),fmt0) 'vai_width_increase_factor = ',vai_width_increase_factor + write(fates_log(),fmt0) 'photo_temp_acclim_timescale = ',photo_temp_acclim_timescale write(fates_log(),fmt0) 'fates_mortality_disturbance_fraction = ',fates_mortality_disturbance_fraction write(fates_log(),fmt0) 'ED_val_comp_excln = ',ED_val_comp_excln write(fates_log(),fmt0) 'ED_val_init_litter = ',ED_val_init_litter diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 7d53d4cb08..781057db06 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -265,6 +265,9 @@ variables: double fates_hydr_thetas_node(fates_hydr_organs, fates_pft) ; fates_hydr_thetas_node:units = "cm3/cm3" ; fates_hydr_thetas_node:long_name = "saturated water content" ; + + + double fates_leaf_c3psn(fates_pft) ; fates_leaf_c3psn:units = "flag" ; fates_leaf_c3psn:long_name = "Photosynthetic pathway (1=c3, 0=c4)" ; @@ -633,7 +636,10 @@ variables: double fates_init_litter ; fates_init_litter:units = "NA" ; fates_init_litter:long_name = "Initialization value for litter pool in cold-start (NOT USED)" ; - double fates_leaf_stomatal_model ; + + + + double fates_leaf_stomatal_model ; fates_leaf_stomatal_model:units = "unitless" ; fates_leaf_stomatal_model:long_name = "switch for choosing between Ball-Berry (1) stomatal conductance model and Medlyn (2) model" ; double fates_logging_coll_under_frac ; @@ -699,6 +705,9 @@ variables: double fates_phen_ncolddayslim ; fates_phen_ncolddayslim:units = "days" ; fates_phen_ncolddayslim:long_name = "day threshold exceedance for temperature leaf-drop" ; + double fates_photo_temp_acclim_timescale ; + fates_photo_temp_acclim_timescale:units = "days" ; + fates_photo_temp_acclim_timescale:long_name = "Length of the window for the exponential moving average (ema) of vegetation temperature used in photosynthesis temperature acclimation (NOT USED)" ; double fates_q10_froz ; fates_q10_froz:units = "unitless" ; fates_q10_froz:long_name = "Q10 for frozen-soil respiration rates" ; @@ -1360,6 +1369,8 @@ data: fates_phen_mindayson = 90 ; fates_phen_ncolddayslim = 5 ; + + fates_photo_temp_acclim_timescale = 30 ; fates_q10_froz = 1.5 ; From a30578b675f83ba65cef24e6afe9e89b2aed463c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 25 Jun 2021 12:36:14 -0400 Subject: [PATCH 334/578] Adding Van Genuchten parameters, and WTF type switch to the parameter file and memory. --- biogeophys/FatesPlantHydraulicsMod.F90 | 137 ++++++++++------------- main/EDParamsMod.F90 | 31 ++++- main/EDPftvarcon.F90 | 83 ++++++++++++-- parameter_files/fates_params_default.cdl | 47 +++++++- 4 files changed, 207 insertions(+), 91 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 4e86d22ae7..431d35f201 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -47,6 +47,7 @@ module FatesPlantHydraulicsMod use EDParamsMod , only : hydr_kmax_rsurf2 use EDParamsMod , only : hydr_psi0 use EDParamsMod , only : hydr_psicap + use EDParamsMod , only : hydr_wtftype_node use EDTypesMod , only : ed_site_type use EDTypesMod , only : ed_patch_type @@ -190,12 +191,12 @@ module FatesPlantHydraulicsMod __FILE__ - integer, public, parameter :: van_genuchten_type = 1 - integer, public, parameter :: campbell_type = 2 - integer, public, parameter :: tfs_type = 3 + integer, public, parameter :: van_genuchten_type = 2 + integer, public, parameter :: campbell_type = 3 + integer, public, parameter :: tfs_type = 1 - integer, parameter :: plant_wrf_type = tfs_type - integer, parameter :: plant_wkf_type = tfs_type + !integer, parameter :: plant_wrf_type = tfs_type + !integer, parameter :: plant_wkf_type = tfs_type integer, parameter :: soil_wrf_type = campbell_type integer, parameter :: soil_wkf_type = campbell_type @@ -5312,81 +5313,67 @@ subroutine InitHydroGlobals() ! 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)]) + do pm = 1, n_plant_media + select case(hydr_wtftype_node(pm)) + case(van_genuchten_type) + do ft = 1,numpft + allocate(wrf_vg) + wrf_plant(pm,ft)%p => wrf_vg + call wrf_vg%set_wrf_param([EDPftvarcon_inst%hydr_vg_alpha_node(ft,pm), & + EDPftvarcon_inst%hydr_vg_m_node(ft,pm), & + EDPftvarcon_inst%hydr_thetas_node(ft,pm), & + EDPftvarcon_inst%hydr_resid_node(ft,pm)]) + end do + case(tfs_type) + do ft = 1,numpft + allocate(wrf_tfs) + wrf_plant(pm,ft)%p => wrf_tfs + if (pm.eq.leaf_p_media) then ! Leaf tissue + cap_slp = 0.0_r8 + cap_int = 0.0_r8 + cap_corr = 1.0_r8 + else ! Non leaf tissues + cap_slp = (hydr_psi0 - hydr_psicap )/(1.0_r8 - rwccap(pm)) + cap_int = -cap_slp + hydr_psi0 + cap_corr = -cap_int/cap_slp + end if + call wrf_tfs%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & + EDPftvarcon_inst%hydr_resid_node(ft,pm), & + EDPftvarcon_inst%hydr_pinot_node(ft,pm), & + EDPftvarcon_inst%hydr_epsil_node(ft,pm), & + rwcft(pm), & + cap_corr, & + cap_int, & + cap_slp,real(pm,r8)]) end do - end do - - end select + end select + end do ! ----------------------------------------------------------------------------------- ! Initialize the Water Conductance (K) Functions ! ----------------------------------------------------------------------------------- - - select case(plant_wkf_type) - case(van_genuchten_type) - do ft = 1,numpft - do pm = 1, n_plant_media - allocate(wkf_vg) - wkf_plant(pm,ft)%p => wkf_vg - call wkf_vg%set_wkf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg, tort_vg]) - end do - - end do - case(campbell_type) - write(fates_log(),*) 'campbell/clapp-hornberger conductance not used in plants' - call endrun(msg=errMsg(sourcefile, __LINE__)) - case(tfs_type) - do ft = 1,numpft - do pm = 1, n_plant_media - allocate(wkf_tfs) - wkf_plant(pm,ft)%p => wkf_tfs - call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_node(ft,pm), & - EDPftvarcon_inst%hydr_avuln_node(ft,pm)]) - end do - end do - end select + do pm = 1, n_plant_media + select case(hydr_wtftype_node(pm)) + + case(van_genuchten_type) + do ft = 1,numpft + allocate(wkf_vg) + wkf_plant(pm,ft)%p => wkf_vg + call wkf_vg%set_wkf_param([EDPftvarcon_inst%hydr_vg_alpha_node(ft,pm), & + EDPftvarcon_inst%hydr_vg_m_node(ft,pm), & + EDPftvarcon_inst%hydr_thetas_node(ft,pm), & + EDPftvarcon_inst%hydr_resid_node(ft,pm), & + tort_vg]) + end do + case(tfs_type) + do ft = 1,numpft + 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 select + end do ! There is only 1 stomata conductance hypothesis which uses the p50 and ! vulnerability parameters diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 51f8d39add..c3894606f6 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -30,7 +30,7 @@ module EDParamsMod real(r8),protected, public :: photo_temp_acclim_timescale ! Length of the window for the exponential moving average (ema) ! of vegetation temperature used in photosynthesis ! temperature acclimation (NOT YET IMPLEMENTED) - + real(r8),protected, public :: fates_mortality_disturbance_fraction ! the fraction of canopy mortality that results in disturbance real(r8),protected, public :: ED_val_comp_excln real(r8),protected, public :: ED_val_init_litter @@ -64,15 +64,22 @@ module EDParamsMod real(r8),protected,public :: q10_mr ! Q10 for respiration rate (for soil fragmenation and plant respiration) (unitless) real(r8),protected,public :: q10_froz ! Q10 for frozen-soil respiration rates (for soil fragmentation) (unitless) - ! two special parameters whose size is defined in the parameter file + ! parameters whose size is defined in the parameter file real(r8),protected,allocatable,public :: ED_val_history_sizeclass_bin_edges(:) real(r8),protected,allocatable,public :: ED_val_history_ageclass_bin_edges(:) real(r8),protected,allocatable,public :: ED_val_history_height_bin_edges(:) real(r8),protected,allocatable,public :: ED_val_history_coageclass_bin_edges(:) + ! Switch that defines the current pressure-volume and pressure-conductivity model + ! to be used at each node (compartment/organ) + ! 1 = Christofferson et al. 2016 (TFS), 2 = Van Genuchten 1980 + integer, protected,allocatable,public :: hydr_wtftype_node(:) + character(len=param_string_length),parameter,public :: ED_name_vai_top_bin_width = "fates_vai_top_bin_width" character(len=param_string_length),parameter,public :: ED_name_vai_width_increase_factor = "fates_vai_width_increase_factor" character(len=param_string_length),parameter,public :: ED_name_photo_temp_acclim_timescale = "fates_photo_temp_acclim_timescale" + character(len=param_string_length),parameter,public :: ED_name_hydr_wtftype_node = "fates_hydr_wtftype_node" + character(len=param_string_length),parameter,public :: ED_name_mort_disturb_frac = "fates_mort_disturb_frac" character(len=param_string_length),parameter,public :: ED_name_comp_excln = "fates_comp_excln" character(len=param_string_length),parameter,public :: ED_name_init_litter = "fates_init_litter" @@ -238,7 +245,7 @@ subroutine FatesRegisterParams(fates_params) use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar, dimension_shape_1d use FatesParametersInterface, only : dimension_name_history_size_bins, dimension_name_history_age_bins - use FatesParametersInterface, only : dimension_name_history_height_bins + use FatesParametersInterface, only : dimension_name_history_height_bins, dimension_name_hydr_organs use FatesParametersInterface, only : dimension_name_history_coage_bins use FatesParametersInterface, only : dimension_shape_scalar @@ -252,7 +259,7 @@ subroutine FatesRegisterParams(fates_params) character(len=param_string_length), parameter :: dim_names_ageclass(1) = (/dimension_name_history_age_bins/) character(len=param_string_length), parameter :: dim_names_height(1) = (/dimension_name_history_height_bins/) character(len=param_string_length), parameter :: dim_names_coageclass(1) = (/dimension_name_history_coage_bins/) - + character(len=param_string_length), parameter :: dim_names_hydro_organs(1) = (/dimension_name_hydr_organs/) call FatesParamsInit() @@ -264,6 +271,8 @@ subroutine FatesRegisterParams(fates_params) call fates_params%RegisterParameter(name=ED_name_photo_temp_acclim_timescale, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=ED_name_mort_disturb_frac, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) @@ -383,6 +392,10 @@ subroutine FatesRegisterParams(fates_params) dimension_names=dim_names_scalar) ! non-scalar parameters + + call fates_params%RegisterParameter(name=ED_name_hydr_wtftype_node, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names_hydro_organs) + call fates_params%RegisterParameter(name=ED_name_history_sizeclass_bin_edges, dimension_shape=dimension_shape_1d, & dimension_names=dim_names_sizeclass) @@ -415,7 +428,8 @@ subroutine FatesReceiveParams(fates_params) class(fates_parameters_type), intent(inout) :: fates_params real(r8) :: tmpreal ! local real variable for changing type on read - + real(r8), allocatable :: hydr_wtftype_real(:) + call fates_params%RetreiveParameter(name=ED_name_vai_top_bin_width, & data=vai_top_bin_width) @@ -563,6 +577,11 @@ subroutine FatesReceiveParams(fates_params) call fates_params%RetreiveParameterAllocate(name=ED_name_history_coageclass_bin_edges, & data=ED_val_history_coageclass_bin_edges) + call fates_params%RetreiveParameterAllocate(name=ED_name_hydr_wtftype_node, & + data=hydr_wtftype_real) + allocate(hydr_wtftype_node(size(hydr_wtftype_real))) + hydr_wtftype_node(:) = nint(hydr_wtftype_real(:)) + deallocate(hydr_wtftype_real) end subroutine FatesReceiveParams @@ -573,6 +592,7 @@ subroutine FatesReportParams(is_master) logical,intent(in) :: is_master character(len=32),parameter :: fmt0 = '(a,(F12.4))' + character(len=32),parameter :: fmti = '(a,(I4))' logical, parameter :: debug_report = .false. if(debug_report .and. is_master) then @@ -581,6 +601,7 @@ subroutine FatesReportParams(is_master) write(fates_log(),fmt0) 'vai_top_bin_width = ',vai_top_bin_width write(fates_log(),fmt0) 'vai_width_increase_factor = ',vai_width_increase_factor write(fates_log(),fmt0) 'photo_temp_acclim_timescale = ',photo_temp_acclim_timescale + write(fates_log(),fmti) 'hydr_wtftype_node = ',hydr_wtftype_node write(fates_log(),fmt0) 'fates_mortality_disturbance_fraction = ',fates_mortality_disturbance_fraction write(fates_log(),fmt0) 'ED_val_comp_excln = ',ED_val_comp_excln write(fates_log(),fmt0) 'ED_val_init_litter = ',ED_val_init_litter diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 61f095a758..e3bffa466b 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -189,23 +189,35 @@ module EDPftvarcon ! --------------------------------------------------------------------------------------------- ! PFT Dimension - real(r8), allocatable :: hydr_p_taper(:) ! xylem taper exponent - real(r8), allocatable :: hydr_rs2(:) ! absorbing root radius (m) - real(r8), allocatable :: hydr_srl(:) ! specific root length (m g-1) - real(r8), allocatable :: hydr_rfrac_stem(:) ! fraction of total tree resistance from troot to canopy - real(r8), allocatable :: hydr_avuln_gs(:) ! shape parameter for stomatal control of water vapor exiting leaf - real(r8), allocatable :: hydr_p50_gs(:) ! water potential at 50% loss of stomatal conductance - + real(r8), allocatable :: hydr_p_taper(:) ! xylem taper exponent + real(r8), allocatable :: hydr_rs2(:) ! absorbing root radius (m) + real(r8), allocatable :: hydr_srl(:) ! specific root length (m g-1) + real(r8), allocatable :: hydr_rfrac_stem(:) ! fraction of total tree resistance from troot to canopy + real(r8), allocatable :: hydr_avuln_gs(:) ! shape parameter for stomatal control of water vapor exiting leaf + real(r8), allocatable :: hydr_p50_gs(:) ! water potential at 50% loss of stomatal conductance + real(r8), allocatable :: hydr_k_lwp(:) ! inner leaf humidity scaling coefficient + ! PFT x Organ Dimension (organs are: 1=leaf, 2=stem, 3=transporting root, 4=absorbing root) + ! ---------------------------------------------------------------------------------- + + ! Van Genuchten PV PK curves + real(r8), allocatable :: hydr_vg_alpha_node(:,:) ! capilary length parameter in van Genuchten model + real(r8), allocatable :: hydr_vg_m_node(:,:) ! pore size distribution, m in van Genuchten 1980 model, range (0,1) + real(r8), allocatable :: hydr_vg_n_node(:,:) ! pore size distribution, n in van Genuchten 1980 model, range >2 + + ! TFS PV-PK curves real(r8), allocatable :: hydr_avuln_node(:,:) ! xylem vulernability curve shape parameter real(r8), allocatable :: hydr_p50_node(:,:) ! xylem water potential at 50% conductivity loss (MPa) - real(r8), allocatable :: hydr_thetas_node(:,:) ! saturated water content (cm3/cm3) real(r8), allocatable :: hydr_epsil_node(:,:) ! bulk elastic modulus (MPa) real(r8), allocatable :: hydr_pitlp_node(:,:) ! turgor loss point (MPa) - real(r8), allocatable :: hydr_resid_node(:,:) ! residual fraction (fraction) real(r8), allocatable :: hydr_fcap_node(:,:) ! fraction of (1-resid_node) that is capillary in source real(r8), allocatable :: hydr_pinot_node(:,:) ! osmotic potential at full turgor real(r8), allocatable :: hydr_kmax_node(:,:) ! maximum xylem conductivity per unit conducting xylem area + + ! Parameters for both VG and TFS PV-PK curves + real(r8), allocatable :: hydr_resid_node(:,:) ! residual fraction (fraction) + real(r8), allocatable :: hydr_thetas_node(:,:) ! saturated water content (cm3/cm3) + contains procedure, public :: Init => EDpftconInit @@ -1172,6 +1184,18 @@ subroutine Register_PFT_hydr_organs(this, fates_params) dim_names(1) = dimension_name_pft dim_names(2) = dimension_name_hydr_organs + name = 'fates_hydr_vg_alpha_node' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hydr_vg_m_node' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hydr_vg_n_node' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_hydr_avuln_node' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -1207,8 +1231,19 @@ subroutine Register_PFT_hydr_organs(this, fates_params) name = 'fates_hydr_kmax_node' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_hydr_vg_alpha_node' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hydr_vg_m_node' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hydr_vg_n_node' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + end subroutine Register_PFT_hydr_organs !----------------------------------------------------------------------- @@ -1224,6 +1259,19 @@ subroutine Receive_PFT_hydr_organs(this, fates_params) class(fates_parameters_type), intent(inout) :: fates_params character(len=param_string_length) :: name + + + name = 'fates_hydr_vg_alpha_node' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_vg_alpha_node) + + name = 'fates_hydr_vg_m_node' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_vg_m_node) + + name = 'fates_hydr_vg_n_node' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_vg_n_node) name = 'fates_hydr_avuln_node' call fates_params%RetreiveParameterAllocate(name=name, & @@ -1261,6 +1309,18 @@ subroutine Receive_PFT_hydr_organs(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_kmax_node) + name = 'fates_hydr_vg_alpha_node' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_vg_alpha_node) + + name = 'fates_hydr_vg_m_node' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_vg_m_node) + + name = 'fates_hydr_vg_n_node' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_vg_n_node) + end subroutine Receive_PFT_hydr_organs ! =============================================================================================== @@ -1356,6 +1416,9 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'hydr_fcap_node = ',EDPftvarcon_inst%hydr_fcap_node write(fates_log(),fmt0) 'hydr_pinot_node = ',EDPftvarcon_inst%hydr_pinot_node write(fates_log(),fmt0) 'hydr_kmax_node = ',EDPftvarcon_inst%hydr_kmax_node + write(fates_log(),fmt0) 'hydr_vg_alpha_node = ',EDPftvarcon_inst%hydr_vg_alpha_node + write(fates_log(),fmt0) 'hydr_vg_m_node = ',EDPftvarcon_inst%hydr_vg_m_node + write(fates_log(),fmt0) 'hydr_vg_n_node = ',EDPftvarcon_inst%hydr_vg_n_node write(fates_log(),*) '-------------------------------------------------' end if diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 781057db06..2b27e7fba4 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -24,7 +24,17 @@ variables: double fates_history_sizeclass_bin_edges(fates_history_size_bins) ; fates_history_sizeclass_bin_edges:units = "cm" ; fates_history_sizeclass_bin_edges:long_name = "Lower edges for DBH size class bins used in size-resolved cohort history output" ; - char fates_pftname(fates_pft, fates_string_length) ; + + double fates_hydr_wtftype_node(fates_hydr_organs) ; + fates_hydr_wtftype_node:units = "unitless" ; + fates_hydr_wtftype_node:long_name = "Switch that defines the water transfer functions for each organ." ; + fates_hydr_wtftype_node:possible_values = "1: Christofferson et al. 2016 (TFS); 2: Van Genuchten 1980" ; + + char fates_hydr_organname_node(fates_hydr_organs, fates_string_length) ; + fates_hydr_organname_node:units = "unitless - string" ; + fates_hydr_organname_node:long_name = "Name of plant hydraulics organs (DONT CHANGE, order matches media list in FatesHydraulicsMemMod.F90)" ; + + char fates_pftname(fates_pft, fates_string_length) ; fates_pftname:units = "unitless - string" ; fates_pftname:long_name = "Description of plant type" ; char fates_prt_organ_name(fates_prt_organs, fates_string_length) ; @@ -220,6 +230,18 @@ variables: double fates_grperc(fates_pft) ; fates_grperc:units = "unitless" ; fates_grperc:long_name = "Growth respiration factor" ; + + double fates_hydr_vg_alpha_node(fates_hydr_organs,fates_pft) ; + fates_hydr_vg_alpha_node:units = "MPa-1" ; + fates_hydr_vg_alpha_node:long_name = "capalary length parameter in van Genuchten model" ; + double fates_hydr_vg_m_node(fates_hydr_organs,fates_pft) ; + fates_hydr_vg_m_node:units = "unitless" ; + fates_hydr_vg_m_node:long_name = "m in van Genuchten 1980 model, 2nd pore size distribution parameter" ; + double fates_hydr_vg_n_node(fates_hydr_organs,fates_pft) ; + fates_hydr_vg_n_node:units = "unitless" ; + fates_hydr_vg_n_node:long_name = "n in van Genuchten 1980 model, pore size distribution parameter" ; + + double fates_hydr_avuln_gs(fates_pft) ; fates_hydr_avuln_gs:units = "unitless" ; fates_hydr_avuln_gs:long_name = "shape parameter for stomatal control of water vapor exiting leaf" ; @@ -757,6 +779,12 @@ data: "sapwood ", "structure " ; + fates_hydr_organname_node = + "leaf ", + "stem ", + "transporting root ", + "absorbing root " ; + fates_prt_organ_id = 1, 2, 3, 6 ; fates_alloc_storage_cushion = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, @@ -912,6 +940,23 @@ data: fates_hydr_avuln_gs = 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5 ; + fates_hydr_vg_alpha_node = 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, +0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, +0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, +0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005 ; + + fates_hydr_vg_m_node = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; + + fates_hydr_vg_n_node = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 ; + + fates_hydr_wtftype_node = 1, 1, 1, 1 ; + fates_hydr_avuln_node = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, From bc201d505146387e15db0d6a208e4d3af26b6d88 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 25 Jun 2021 12:47:05 -0400 Subject: [PATCH 335/578] Added the hydr_k_lwp parameter --- main/EDPftvarcon.F90 | 9 +++++++++ parameter_files/fates_params_default.cdl | 7 +++++++ 2 files changed, 16 insertions(+) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index e3bffa466b..827267575e 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -456,6 +456,10 @@ subroutine Register_PFT(this, fates_params) name = 'fates_hydr_p50_gs' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hydr_k_lwp' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'fates_mort_bmort' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & @@ -778,6 +782,10 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_p50_gs) + name = 'fates_hydr_k_lwp' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_k_lwp) + name = 'fates_mort_bmort' call fates_params%RetreiveParameterAllocate(name=name, & data=this%bmort) @@ -1407,6 +1415,7 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'hydr_rfrac_stem = ',EDPftvarcon_inst%hydr_rfrac_stem write(fates_log(),fmt0) 'hydr_avuln_gs = ',EDPftvarcon_inst%hydr_avuln_gs write(fates_log(),fmt0) 'hydr_p50_gs = ',EDPftvarcon_inst%hydr_p50_gs + write(fates_log(),fmt0) 'hydr_k_lwp = ',EDPftvarcon_inst%hydr_k_lwp write(fates_log(),fmt0) 'hydr_avuln_node = ',EDPftvarcon_inst%hydr_avuln_node write(fates_log(),fmt0) 'hydr_p50_node = ',EDPftvarcon_inst%hydr_p50_node write(fates_log(),fmt0) 'hydr_thetas_node = ',EDPftvarcon_inst%hydr_thetas_node diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 2b27e7fba4..4635e0fa89 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -241,6 +241,11 @@ variables: fates_hydr_vg_n_node:units = "unitless" ; fates_hydr_vg_n_node:long_name = "n in van Genuchten 1980 model, pore size distribution parameter" ; +double fates_hydr_k_lwp(fates_pft) ; +fates_hydr_k_lwp:units = "unitless" ; +fates_hydr_k_lwp:long_name = "inner leaf humidity scaling coefficient" ; +fates_hydr_k_lwp:possible_values = "0: turns off leaf humidity effects on conductance. 1-10 activates humidity effects" ; + double fates_hydr_avuln_gs(fates_pft) ; fates_hydr_avuln_gs:units = "unitless" ; @@ -940,6 +945,8 @@ data: fates_hydr_avuln_gs = 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5 ; +fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + fates_hydr_vg_alpha_node = 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, From 760602e5d3dbe631b64bb70427182cde1057d7a1 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 25 Jun 2021 13:02:03 -0400 Subject: [PATCH 336/578] Added mapping table for biogeography to the param file --- main/EDPftvarcon.F90 | 31 ++++++++++++++++++++---- main/FatesParametersInterface.F90 | 1 + parameter_files/fates_params_default.cdl | 23 ++++++++++++++++++ 3 files changed, 50 insertions(+), 5 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 827267575e..f56cb8de84 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -200,7 +200,7 @@ module EDPftvarcon ! PFT x Organ Dimension (organs are: 1=leaf, 2=stem, 3=transporting root, 4=absorbing root) ! ---------------------------------------------------------------------------------- - ! Van Genuchten PV PK curves + ! Van Genuchten PV PK curves (NOT IMPLEMENTED) real(r8), allocatable :: hydr_vg_alpha_node(:,:) ! capilary length parameter in van Genuchten model real(r8), allocatable :: hydr_vg_m_node(:,:) ! pore size distribution, m in van Genuchten 1980 model, range (0,1) real(r8), allocatable :: hydr_vg_n_node(:,:) ! pore size distribution, n in van Genuchten 1980 model, range >2 @@ -218,6 +218,12 @@ module EDPftvarcon real(r8), allocatable :: hydr_resid_node(:,:) ! residual fraction (fraction) real(r8), allocatable :: hydr_thetas_node(:,:) ! saturated water content (cm3/cm3) + + ! Table that maps HLM pfts to FATES pfts for fixed biogeography mode + ! The values are area fractions (NOT IMPLEMENTED) + real(r8), allocatable :: hlm_pft_map(:,:) + + contains procedure, public :: Init => EDpftconInit @@ -296,16 +302,19 @@ subroutine Register_PFT(this, fates_params) use FatesParametersInterface, only : fates_parameters_type, param_string_length use FatesParametersInterface, only : dimension_name_pft, dimension_shape_1d - + use FatesParametersInterface, only : dimension_name_hlm_pftno, dimension_shape_2d + implicit none class(EDPftvarcon_type), intent(inout) :: this class(fates_parameters_type), intent(inout) :: fates_params character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_pft/) - + character(len=param_string_length) :: pftmap_dim_names(2) + integer, parameter :: dim_lower_bound(1) = (/ lower_bound_pft /) - + + character(len=param_string_length) :: name !X! name = '' @@ -619,7 +628,15 @@ subroutine Register_PFT(this, fates_params) name = 'fates_prescribed_puptake' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + + ! adding the hlm_pft_map variable with two dimensions - FATES PFTno and HLM PFTno + pftmap_dim_names(1) = dimension_name_pft + pftmap_dim_names(2) = dimension_name_hlm_pftno + + name = 'fates_hlm_pft_map' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=pftmap_dim_names, lower_bounds=dim_lower_bound) + end subroutine Register_PFT !----------------------------------------------------------------------- @@ -952,6 +969,10 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%eca_lambda_ptase) + name = 'fates_hlm_pft_map' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hlm_pft_map) + end subroutine Receive_PFT !----------------------------------------------------------------------- diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 index ebaad3fa7c..f69d4ef5bf 100644 --- a/main/FatesParametersInterface.F90 +++ b/main/FatesParametersInterface.F90 @@ -35,6 +35,7 @@ module FatesParametersInterface character(len=*), parameter, public :: dimension_name_history_age_bins = 'fates_history_age_bins' character(len=*), parameter, public :: dimension_name_history_height_bins = 'fates_history_height_bins' character(len=*), parameter, public :: dimension_name_history_coage_bins = 'fates_history_coage_bins' + character(len=*), parameter, public :: dimension_name_hlm_pftno = 'fates_hlm_pftno' ! Dimensions in the host namespace: character(len=*), parameter, public :: dimension_name_host_allpfts = 'allpfts' diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 4635e0fa89..366125da28 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -11,6 +11,8 @@ dimensions: fates_pft = 12 ; fates_prt_organs = 4 ; fates_string_length = 60 ; + fates_hlm_pftno = 14 ; + variables: double fates_history_ageclass_bin_edges(fates_history_age_bins) ; fates_history_ageclass_bin_edges:units = "yr" ; @@ -552,6 +554,11 @@ fates_hydr_k_lwp:possible_values = "0: turns off leaf humidity effects on conduc double fates_z0mr(fates_pft) ; fates_z0mr:units = "unitless" ; fates_z0mr:long_name = "Ratio of momentum roughness length to canopy top height" ; + + double fates_hlm_pft_map(fates_hlm_pftno, fates_pft) ; + fates_hlm_pft_map:units = "area fraction" ; + fates_hlm_pft_map:long_name = "In fixed biogeog mode, fraction of HLM area associated with each FATES PFT" ; + double fates_fire_FBD(fates_litterclass) ; fates_fire_FBD:units = "kg Biomass/m3" ; fates_fire_FBD:long_name = "fuel bulk density" ; @@ -1304,6 +1311,22 @@ fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_z0mr = 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055 ; + fates_hlm_pft_map = + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 ; + fates_fire_FBD = 15.4, 16.8, 19.6, 999, 4, 4 ; fates_fire_low_moisture_Coeff = 1.12, 1.09, 0.98, 0.8, 1.15, 1.15 ; From 12ca006e3e9fcf4b048050799fb7b298b5bb293f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 25 Jun 2021 13:15:27 -0400 Subject: [PATCH 337/578] Sorted the new additions to the parameter file and updated the sorter script --- parameter_files/fates_params_default.cdl | 227 +++++++++++------------ tools/ncvarsort.py | 24 ++- 2 files changed, 122 insertions(+), 129 deletions(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 366125da28..cf0055e74b 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -12,7 +12,6 @@ dimensions: fates_prt_organs = 4 ; fates_string_length = 60 ; fates_hlm_pftno = 14 ; - variables: double fates_history_ageclass_bin_edges(fates_history_age_bins) ; fates_history_ageclass_bin_edges:units = "yr" ; @@ -26,25 +25,22 @@ variables: double fates_history_sizeclass_bin_edges(fates_history_size_bins) ; fates_history_sizeclass_bin_edges:units = "cm" ; fates_history_sizeclass_bin_edges:long_name = "Lower edges for DBH size class bins used in size-resolved cohort history output" ; - - double fates_hydr_wtftype_node(fates_hydr_organs) ; - fates_hydr_wtftype_node:units = "unitless" ; + double fates_hydr_wtftype_node(fates_hydr_organs) ; + fates_hydr_wtftype_node:units = "unitless" ; fates_hydr_wtftype_node:long_name = "Switch that defines the water transfer functions for each organ." ; fates_hydr_wtftype_node:possible_values = "1: Christofferson et al. 2016 (TFS); 2: Van Genuchten 1980" ; - - char fates_hydr_organname_node(fates_hydr_organs, fates_string_length) ; - fates_hydr_organname_node:units = "unitless - string" ; - fates_hydr_organname_node:long_name = "Name of plant hydraulics organs (DONT CHANGE, order matches media list in FatesHydraulicsMemMod.F90)" ; - - char fates_pftname(fates_pft, fates_string_length) ; + double fates_prt_organ_id(fates_prt_organs) ; + fates_prt_organ_id:units = "index, unitless" ; + fates_prt_organ_id:long_name = "This is the global index the organ in this file is associated with in PRTGenericMod.F90" ; + char fates_pftname(fates_pft, fates_string_length) ; fates_pftname:units = "unitless - string" ; fates_pftname:long_name = "Description of plant type" ; + char fates_hydr_organname_node(fates_hydr_organs, fates_string_length) ; + fates_hydr_organname_node:units = "unitless - string" ; + fates_hydr_organname_node:long_name = "Name of plant hydraulics organs (DONT CHANGE, order matches media list in FatesHydraulicsMemMod.F90)" ; char fates_prt_organ_name(fates_prt_organs, fates_string_length) ; fates_prt_organ_name:units = "unitless - string" ; fates_prt_organ_name:long_name = "Name of plant organs (order must match PRTGenericMod.F90)" ; - double fates_prt_organ_id(fates_prt_organs) ; - fates_prt_organ_id:units = "index, unitless" ; - fates_prt_organ_id:long_name = "This is the global index the organ in this file is associated with in PRTGenericMod.F90" ; double fates_alloc_storage_cushion(fates_pft) ; fates_alloc_storage_cushion:units = "fraction" ; fates_alloc_storage_cushion:long_name = "maximum size of storage C pool, relative to maximum size of leaf C pool" ; @@ -136,27 +132,21 @@ variables: fates_allom_stmode:units = "index" ; fates_allom_stmode:long_name = "storage allometry function index." ; fates_allom_stmode:possible_values = "1: target storage proportional to trimmed maximum leaf biomass." ; - + double fates_allom_zroot_k(fates_pft) ; + fates_allom_zroot_k:units = "unitless" ; + fates_allom_zroot_k:long_name = "scale coefficient of logistic rooting depth model (NOT USED)" ; double fates_allom_zroot_max_dbh(fates_pft) ; fates_allom_zroot_max_dbh:units = "cm" ; - fates_allom_zroot_max_dbh:long_name = "dbh at which maximum rooting depth is defined (NOT USED)" ; - + fates_allom_zroot_max_dbh:long_name = "dbh at which maximum rooting depth is defined (NOT USED)" ; double fates_allom_zroot_max_z(fates_pft) ; - fates_allom_zroot_max_z:units = "m" ; + fates_allom_zroot_max_z:units = "m" ; fates_allom_zroot_max_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_max_dbh (NOT USED). note: max_z=min_z=large, sets rooting depth to soil depth" ; - double fates_allom_zroot_min_dbh(fates_pft) ; fates_allom_zroot_min_dbh:units = "cm" ; fates_allom_zroot_min_dbh:long_name = "dbh at which the rooting depth for a recruit is defined (NOT USED)" ; - double fates_allom_zroot_min_z(fates_pft) ; fates_allom_zroot_min_z:units = "m" ; fates_allom_zroot_min_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_min_dbh (NOT USED) note: max_z=min_z=large, sets rooting depth to soil depth" ; - - double fates_allom_zroot_k(fates_pft) ; - fates_allom_zroot_k:units = "unitless" ; - fates_allom_zroot_k:long_name = "scale coefficient of logistic rooting depth model (NOT USED)" ; - double fates_branch_turnover(fates_pft) ; fates_branch_turnover:units = "yr" ; fates_branch_turnover:long_name = "turnover time of branches" ; @@ -232,23 +222,6 @@ variables: double fates_grperc(fates_pft) ; fates_grperc:units = "unitless" ; fates_grperc:long_name = "Growth respiration factor" ; - - double fates_hydr_vg_alpha_node(fates_hydr_organs,fates_pft) ; - fates_hydr_vg_alpha_node:units = "MPa-1" ; - fates_hydr_vg_alpha_node:long_name = "capalary length parameter in van Genuchten model" ; - double fates_hydr_vg_m_node(fates_hydr_organs,fates_pft) ; - fates_hydr_vg_m_node:units = "unitless" ; - fates_hydr_vg_m_node:long_name = "m in van Genuchten 1980 model, 2nd pore size distribution parameter" ; - double fates_hydr_vg_n_node(fates_hydr_organs,fates_pft) ; - fates_hydr_vg_n_node:units = "unitless" ; - fates_hydr_vg_n_node:long_name = "n in van Genuchten 1980 model, pore size distribution parameter" ; - -double fates_hydr_k_lwp(fates_pft) ; -fates_hydr_k_lwp:units = "unitless" ; -fates_hydr_k_lwp:long_name = "inner leaf humidity scaling coefficient" ; -fates_hydr_k_lwp:possible_values = "0: turns off leaf humidity effects on conductance. 1-10 activates humidity effects" ; - - double fates_hydr_avuln_gs(fates_pft) ; fates_hydr_avuln_gs:units = "unitless" ; fates_hydr_avuln_gs:long_name = "shape parameter for stomatal control of water vapor exiting leaf" ; @@ -261,6 +234,10 @@ fates_hydr_k_lwp:possible_values = "0: turns off leaf humidity effects on conduc double fates_hydr_fcap_node(fates_hydr_organs, fates_pft) ; fates_hydr_fcap_node:units = "unitless" ; fates_hydr_fcap_node:long_name = "fraction of non-residual water that is capillary in source" ; + double fates_hydr_k_lwp(fates_pft) ; + fates_hydr_k_lwp:units = "unitless" ; + fates_hydr_k_lwp:long_name = "inner leaf humidity scaling coefficient" ; + fates_hydr_k_lwp:possible_values = "0: turns off leaf humidity effects on conductance. 1-10 activates humidity effects" ; double fates_hydr_kmax_node(fates_hydr_organs, fates_pft) ; fates_hydr_kmax_node:units = "kg/MPa/m/s" ; fates_hydr_kmax_node:long_name = "maximum xylem conductivity per unit conducting xylem area" ; @@ -294,9 +271,15 @@ fates_hydr_k_lwp:possible_values = "0: turns off leaf humidity effects on conduc double fates_hydr_thetas_node(fates_hydr_organs, fates_pft) ; fates_hydr_thetas_node:units = "cm3/cm3" ; fates_hydr_thetas_node:long_name = "saturated water content" ; - - - + double fates_hydr_vg_alpha_node(fates_hydr_organs, fates_pft) ; + fates_hydr_vg_alpha_node:units = "MPa-1" ; + fates_hydr_vg_alpha_node:long_name = "capalary length parameter in van Genuchten model" ; + double fates_hydr_vg_m_node(fates_hydr_organs, fates_pft) ; + fates_hydr_vg_m_node:units = "unitless" ; + fates_hydr_vg_m_node:long_name = "m in van Genuchten 1980 model, 2nd pore size distribution parameter" ; + double fates_hydr_vg_n_node(fates_hydr_organs, fates_pft) ; + fates_hydr_vg_n_node:units = "unitless" ; + fates_hydr_vg_n_node:long_name = "n in van Genuchten 1980 model, pore size distribution parameter" ; double fates_leaf_c3psn(fates_pft) ; fates_leaf_c3psn:units = "flag" ; fates_leaf_c3psn:long_name = "Photosynthetic pathway (1=c3, 0=c4)" ; @@ -405,6 +388,9 @@ fates_hydr_k_lwp:possible_values = "0: turns off leaf humidity effects on conduc double fates_nfix2(fates_pft) ; fates_nfix2:units = "NA" ; fates_nfix2:long_name = "place-holder for future n-fixation parameter (NOT IMPLEMENTED)" ; + double fates_nitr_store_ratio(fates_pft) ; + fates_nitr_store_ratio:units = "(gN/gN)" ; + fates_nitr_store_ratio:long_name = "ratio of storeable N, to functional N bound in cell structures of leaf,root,sap" ; double fates_phen_cold_size_threshold(fates_pft) ; fates_phen_cold_size_threshold:units = "cm" ; fates_phen_cold_size_threshold:long_name = "the dbh size above which will lead to phenology-related stem and leaf drop" ; @@ -423,6 +409,9 @@ fates_hydr_k_lwp:possible_values = "0: turns off leaf humidity effects on conduc double fates_phenflush_fraction(fates_pft) ; fates_phenflush_fraction:units = "fraction" ; fates_phenflush_fraction:long_name = "Upon bud-burst, the maximum fraction of storage carbon used for flushing leaves" ; + double fates_phos_store_ratio(fates_pft) ; + fates_phos_store_ratio:units = "(gP/gP)" ; + fates_phos_store_ratio:long_name = "ratio of storeable P, to functional P bound in cell structures of leaf,root,sap" ; double fates_prescribed_mortality_canopy(fates_pft) ; fates_prescribed_mortality_canopy:units = "1/yr" ; fates_prescribed_mortality_canopy:long_name = "mortality rate of canopy trees for prescribed physiology mode" ; @@ -436,10 +425,10 @@ fates_hydr_k_lwp:possible_values = "0: turns off leaf humidity effects on conduc fates_prescribed_npp_understory:units = "kgC / m^2 / yr" ; fates_prescribed_npp_understory:long_name = "NPP per unit crown area of understory trees for prescribed physiology mode" ; double fates_prescribed_nuptake(fates_pft) ; - fates_prescribed_nuptake:units = "fraction" ; + fates_prescribed_nuptake:units = "fraction" ; fates_prescribed_nuptake:long_name = "Prescribed N uptake flux. 0=fully coupled simulation >0=prescribed (experimental)" ; double fates_prescribed_puptake(fates_pft) ; - fates_prescribed_puptake:units = "fraction" ; + fates_prescribed_puptake:units = "fraction" ; fates_prescribed_puptake:long_name = "Prescribed P uptake flux. 0=fully coupled simulation, >0=prescribed (experimental)" ; double fates_prescribed_recruitment(fates_pft) ; fates_prescribed_recruitment:units = "n/yr" ; @@ -459,13 +448,6 @@ fates_hydr_k_lwp:possible_values = "0: turns off leaf humidity effects on conduc double fates_prt_phos_stoich_p2(fates_prt_organs, fates_pft) ; fates_prt_phos_stoich_p2:units = "(gP/gC)" ; fates_prt_phos_stoich_p2:long_name = "phosphorous stoichiometry, parameter 2" ; - double fates_nitr_store_ratio(fates_pft) ; - fates_nitr_store_ratio:units = "(gN/gN)" ; - fates_nitr_store_ratio:long_name = "ratio of storeable N, to functional N bound in cell structures of leaf,root,sap" ; - double fates_phos_store_ratio(fates_pft) ; - fates_phos_store_ratio:units = "(gP/gP)" ; - fates_phos_store_ratio:long_name = "ratio of storeable P, to functional P bound in cell structures of leaf,root,sap" ; - double fates_recruit_hgt_min(fates_pft) ; fates_recruit_hgt_min:units = "m" ; fates_recruit_hgt_min:long_name = "the minimum height (ie starting height) of a newly recruited plant" ; @@ -554,11 +536,9 @@ fates_hydr_k_lwp:possible_values = "0: turns off leaf humidity effects on conduc double fates_z0mr(fates_pft) ; fates_z0mr:units = "unitless" ; fates_z0mr:long_name = "Ratio of momentum roughness length to canopy top height" ; - double fates_hlm_pft_map(fates_hlm_pftno, fates_pft) ; - fates_hlm_pft_map:units = "area fraction" ; - fates_hlm_pft_map:long_name = "In fixed biogeog mode, fraction of HLM area associated with each FATES PFT" ; - + fates_hlm_pft_map:units = "area fraction" ; + fates_hlm_pft_map:long_name = "In fixed biogeog mode, fraction of HLM area associated with each FATES PFT" ; double fates_fire_FBD(fates_litterclass) ; fates_fire_FBD:units = "kg Biomass/m3" ; fates_fire_FBD:long_name = "fuel bulk density" ; @@ -670,10 +650,7 @@ fates_hydr_k_lwp:possible_values = "0: turns off leaf humidity effects on conduc double fates_init_litter ; fates_init_litter:units = "NA" ; fates_init_litter:long_name = "Initialization value for litter pool in cold-start (NOT USED)" ; - - - - double fates_leaf_stomatal_model ; + double fates_leaf_stomatal_model ; fates_leaf_stomatal_model:units = "unitless" ; fates_leaf_stomatal_model:long_name = "switch for choosing between Ball-Berry (1) stomatal conductance model and Medlyn (2) model" ; double fates_logging_coll_under_frac ; @@ -740,7 +717,7 @@ fates_hydr_k_lwp:possible_values = "0: turns off leaf humidity effects on conduc fates_phen_ncolddayslim:units = "days" ; fates_phen_ncolddayslim:long_name = "day threshold exceedance for temperature leaf-drop" ; double fates_photo_temp_acclim_timescale ; - fates_photo_temp_acclim_timescale:units = "days" ; + fates_photo_temp_acclim_timescale:units = "days" ; fates_photo_temp_acclim_timescale:long_name = "Length of the window for the exponential moving average (ema) of vegetation temperature used in photosynthesis temperature acclimation (NOT USED)" ; double fates_q10_froz ; fates_q10_froz:units = "unitless" ; @@ -751,7 +728,7 @@ fates_hydr_k_lwp:possible_values = "0: turns off leaf humidity effects on conduc double fates_soil_salinity ; fates_soil_salinity:units = "ppt" ; fates_soil_salinity:long_name = "soil salinity used for model when not coupled to dynamic soil salinity" ; - double fates_vai_top_bin_width ; + double fates_vai_top_bin_width ; fates_vai_top_bin_width:units = "m2/m2" ; fates_vai_top_bin_width:long_name = "width in VAI units of uppermost leaf+stem layer scattering element in each canopy layer (NOT USED)" ; double fates_vai_width_increase_factor ; @@ -771,6 +748,10 @@ data: fates_history_sizeclass_bin_edges = 0, 5, 10, 15, 20, 30, 40, 50, 60, 70, 80, 90, 100 ; + fates_hydr_wtftype_node = 1, 1, 1, 1 ; + + fates_prt_organ_id = 1, 2, 3, 6 ; + fates_pftname = "broadleaf_evergreen_tropical_tree ", "needleleaf_evergreen_extratrop_tree ", @@ -785,19 +766,17 @@ data: "cool_c3_grass ", "c4_grass " ; - fates_prt_organ_name = - "leaf ", - "fine root ", - "sapwood ", - "structure " ; - fates_hydr_organname_node = "leaf ", "stem ", "transporting root ", "absorbing root " ; - - fates_prt_organ_id = 1, 2, 3, 6 ; + + fates_prt_organ_name = + "leaf ", + "fine root ", + "sapwood ", + "structure " ; fates_alloc_storage_cushion = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2 ; @@ -873,15 +852,18 @@ data: fates_allom_stmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_allom_zroot_max_dbh = 100, 100, 100, 100, 100, 100, 2, 2, 2, 2, 2, 2 ; + fates_allom_zroot_k = 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10 ; - fates_allom_zroot_max_z = 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100; + fates_allom_zroot_max_dbh = 100, 100, 100, 100, 100, 100, 2, 2, 2, 2, 2, 2 ; - fates_allom_zroot_min_dbh = 1, 1, 1, 2.5, 2.5, 2.5, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 ; + fates_allom_zroot_max_z = 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100 ; - fates_allom_zroot_min_z = 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, 100; + fates_allom_zroot_min_dbh = 1, 1, 1, 2.5, 2.5, 2.5, 0.1, 0.1, 0.1, 0.1, 0.1, + 0.1 ; - fates_allom_zroot_k = 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10 ; + fates_allom_zroot_min_z = 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100 ; fates_branch_turnover = 150, 150, 150, 150, 150, 150, 150, 150, 150, 0, 0, 0 ; @@ -952,25 +934,6 @@ data: fates_hydr_avuln_gs = 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5 ; -fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; - - fates_hydr_vg_alpha_node = 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, -0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, -0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, -0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005 ; - - fates_hydr_vg_m_node = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, - 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, - 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, - 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; - - fates_hydr_vg_n_node = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 ; - - fates_hydr_wtftype_node = 1, 1, 1, 1 ; - fates_hydr_avuln_node = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, @@ -989,6 +952,8 @@ fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + fates_hydr_kmax_node = -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, @@ -1048,6 +1013,28 @@ fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75 ; + fates_hydr_vg_alpha_node = + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005, + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005, + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005, + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005 ; + + fates_hydr_vg_m_node = + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; + + fates_hydr_vg_n_node = + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 ; + fates_leaf_c3psn = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0 ; fates_leaf_clumping_index = 0.85, 0.85, 0.8, 0.85, 0.85, 0.9, 0.85, 0.9, @@ -1145,6 +1132,9 @@ fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_nfix2 = _, _, _, _, _, _, _, _, _, _, _, _ ; + fates_nitr_store_ratio = 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, + 1.5, 1.5 ; + fates_phen_cold_size_threshold = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_phen_evergreen = 1, 1, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0 ; @@ -1157,6 +1147,9 @@ fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_phenflush_fraction = _, _, 0.5, _, 0.5, 0.5, _, 0.5, 0.5, 0.5, 0.5, 0.5 ; + fates_phos_store_ratio = 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, + 1.5, 1.5 ; + fates_prescribed_mortality_canopy = 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194 ; @@ -1169,9 +1162,9 @@ fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_prescribed_npp_understory = 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125 ; - fates_prescribed_nuptake = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0 ; + fates_prescribed_nuptake = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_prescribed_puptake = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0 ; + fates_prescribed_puptake = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; fates_prescribed_recruitment = 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02 ; @@ -1220,10 +1213,6 @@ fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047 ; - fates_nitr_store_ratio = 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5; - - fates_phos_store_ratio = 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5; - fates_recruit_hgt_min = 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 0.75, 0.75, 0.75, 0.125, 0.125, 0.125 ; @@ -1311,21 +1300,21 @@ fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_z0mr = 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055 ; - fates_hlm_pft_map = - 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 ; + fates_hlm_pft_map = + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 ; fates_fire_FBD = 15.4, 16.8, 19.6, 999, 4, 4 ; @@ -1444,7 +1433,7 @@ fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_phen_mindayson = 90 ; fates_phen_ncolddayslim = 5 ; - + fates_photo_temp_acclim_timescale = 30 ; fates_q10_froz = 1.5 ; @@ -1453,7 +1442,7 @@ fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_soil_salinity = 0.4 ; - fates_vai_top_bin_width = 1.0 ; + fates_vai_top_bin_width = 1 ; - fates_vai_width_increase_factor = 1.0 ; + fates_vai_width_increase_factor = 1 ; } diff --git a/tools/ncvarsort.py b/tools/ncvarsort.py index bd6587378d..4175d52ad1 100755 --- a/tools/ncvarsort.py +++ b/tools/ncvarsort.py @@ -29,7 +29,7 @@ def main(): # make empty lists to hold the variable names in. the first of these is a list of sub-lists, # one for each type of variable (based on dimensionality). # the second is the master list that will contain all variables. - varnames_list = [[],[],[],[],[],[],[],[],[],[]] + varnames_list = [[],[],[],[],[],[],[],[],[],[],[],[],[]] varnames_list_sorted = [] # # sort the variables by dimensionality, but mix the PFT x other dimension in with the regular PFT-indexed variables @@ -38,15 +38,19 @@ def main(): (u'fates_history_coage_bins',):1, (u'fates_history_height_bins',):2, (u'fates_history_size_bins',):3, - (u'fates_pft', u'fates_string_length'):4, - (u'fates_prt_organs', u'fates_string_length'):5, - (u'fates_pft',):6, - (u'fates_hydr_organs', u'fates_pft'):6, - (u'fates_leafage_class', u'fates_pft'):6, - (u'fates_prt_organs', u'fates_pft'):6, - (u'fates_litterclass',):7, - (u'fates_NCWD',):8, - ():9} + (u'fates_hydr_organs',):4, + (u'fates_prt_organs',):4, + (u'fates_pft', u'fates_string_length'):5, + (u'fates_hydr_organs', u'fates_string_length'):6, + (u'fates_prt_organs', u'fates_string_length'):7, + (u'fates_pft',):8, + (u'fates_hydr_organs', u'fates_pft'):8, + (u'fates_leafage_class', u'fates_pft'):8, + (u'fates_prt_organs', u'fates_pft'):8, + (u'fates_hlm_pftno', u'fates_pft'):9, + (u'fates_litterclass',):10, + (u'fates_NCWD',):11, + ():12} # # go through each of the variables and assign it to one of the sub-lists based on its dimensionality for v_name, varin in dsin.variables.items(): From 526b092d317c04fe019eb74ccf5d76c883c7097c Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 25 Jun 2021 13:44:41 -0700 Subject: [PATCH 338/578] fixing typo in fates_maintresp_reduction_intercept --- parameter_files/fates_params_default.cdl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index cf0055e74b..858d0df750 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -1098,7 +1098,7 @@ data: fates_maintresp_reduction_curvature = 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01 ; - fates_maintresp_reduction_intercept = 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1 ; + fates_maintresp_reduction_intercept = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; fates_mort_bmort = 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014 ; From b89c9bacf89f251a3ec1b7e1cc48057e75fd5112 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 25 Jun 2021 21:51:53 -0400 Subject: [PATCH 339/578] Update parameter_files/fates_params_default.cdl Co-authored-by: Charlie Koven --- parameter_files/fates_params_default.cdl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 858d0df750..45ff1ecb44 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -137,7 +137,7 @@ variables: fates_allom_zroot_k:long_name = "scale coefficient of logistic rooting depth model (NOT USED)" ; double fates_allom_zroot_max_dbh(fates_pft) ; fates_allom_zroot_max_dbh:units = "cm" ; - fates_allom_zroot_max_dbh:long_name = "dbh at which maximum rooting depth is defined (NOT USED)" ; + fates_allom_zroot_max_dbh:long_name = "dbh at which a plant reaches the maximum value for its maximum rooting depth (NOT USED)" ; double fates_allom_zroot_max_z(fates_pft) ; fates_allom_zroot_max_z:units = "m" ; fates_allom_zroot_max_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_max_dbh (NOT USED). note: max_z=min_z=large, sets rooting depth to soil depth" ; From 396cd428a25301d1d3a2f0629f7659a26ec1533c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 25 Jun 2021 21:52:05 -0400 Subject: [PATCH 340/578] Update parameter_files/fates_params_default.cdl Co-authored-by: Charlie Koven --- parameter_files/fates_params_default.cdl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 45ff1ecb44..136515c0d1 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -143,7 +143,7 @@ variables: fates_allom_zroot_max_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_max_dbh (NOT USED). note: max_z=min_z=large, sets rooting depth to soil depth" ; double fates_allom_zroot_min_dbh(fates_pft) ; fates_allom_zroot_min_dbh:units = "cm" ; - fates_allom_zroot_min_dbh:long_name = "dbh at which the rooting depth for a recruit is defined (NOT USED)" ; + fates_allom_zroot_min_dbh:long_name = "dbh at which the maximum rooting depth for a recruit is defined (NOT USED)" ; double fates_allom_zroot_min_z(fates_pft) ; fates_allom_zroot_min_z:units = "m" ; fates_allom_zroot_min_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_min_dbh (NOT USED) note: max_z=min_z=large, sets rooting depth to soil depth" ; From 3471bac8db825e9208dd85dcaa25f3d71243e331 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 25 Jun 2021 21:52:20 -0400 Subject: [PATCH 341/578] Update parameter_files/fates_params_default.cdl Co-authored-by: Charlie Koven --- parameter_files/fates_params_default.cdl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 136515c0d1..f38970bb4f 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -273,7 +273,7 @@ variables: fates_hydr_thetas_node:long_name = "saturated water content" ; double fates_hydr_vg_alpha_node(fates_hydr_organs, fates_pft) ; fates_hydr_vg_alpha_node:units = "MPa-1" ; - fates_hydr_vg_alpha_node:long_name = "capalary length parameter in van Genuchten model" ; + fates_hydr_vg_alpha_node:long_name = "capillary length parameter in van Genuchten model" ; double fates_hydr_vg_m_node(fates_hydr_organs, fates_pft) ; fates_hydr_vg_m_node:units = "unitless" ; fates_hydr_vg_m_node:long_name = "m in van Genuchten 1980 model, 2nd pore size distribution parameter" ; From b3db2fcc8660ca5fa7003bece13df71e00c4b7fa Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 28 Jun 2021 14:05:24 -0400 Subject: [PATCH 342/578] updated some descriptive text to the hydraulics pv/pk hypothesis switches --- biogeophys/FatesPlantHydraulicsMod.F90 | 16 ++++++++++++++-- 1 file changed, 14 insertions(+), 2 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 431d35f201..ebab9aa30e 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -191,12 +191,24 @@ module FatesPlantHydraulicsMod __FILE__ + ! These index flags specify which pressure-volumen and pressure + ! conductivity relationship are available. + ! For plants: Users can option between useing tfs and van_genuchten + ! by specifying their choice in the parameter file, + ! with the model parameter hydr_wtftype_node, + ! the value should be 1 for TFS or 2 for VG (as shown below). + ! Campbell, could technically be used, but the parameters for + ! that hypothesis are not in the parameter file, so it not currently available. + ! For soil: The soil hypothesis should follow the hypothesis for water transfer + ! in the Host Land Model. At this time campbell is the default for both + ! ELM and ALM. However, if alternatives arise (like VG), we still need to write + ! interface routines to transfer over parameters. Right now we just hard-code + ! the use of campbell_type for the soil (see a few lines below). + integer, public, parameter :: van_genuchten_type = 2 integer, public, parameter :: campbell_type = 3 integer, public, parameter :: tfs_type = 1 - !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 From a8ebe952c763aae5bb015930ff4ad467267decce Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 28 Jun 2021 14:15:29 -0400 Subject: [PATCH 343/578] Added descriptive text that explains the hydr_vg parameters are only relevant for hypothesis 2 (vg) in the parameter file --- parameter_files/fates_params_default.cdl | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index f38970bb4f..7aa448438a 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -273,13 +273,13 @@ variables: fates_hydr_thetas_node:long_name = "saturated water content" ; double fates_hydr_vg_alpha_node(fates_hydr_organs, fates_pft) ; fates_hydr_vg_alpha_node:units = "MPa-1" ; - fates_hydr_vg_alpha_node:long_name = "capillary length parameter in van Genuchten model" ; + fates_hydr_vg_alpha_node:long_name = "(used if hydr_wtftype_node = 2), capillary length parameter in van Genuchten model" ; double fates_hydr_vg_m_node(fates_hydr_organs, fates_pft) ; fates_hydr_vg_m_node:units = "unitless" ; - fates_hydr_vg_m_node:long_name = "m in van Genuchten 1980 model, 2nd pore size distribution parameter" ; + fates_hydr_vg_m_node:long_name = "(used if hydr_wtftype_node = 2),m in van Genuchten 1980 model, 2nd pore size distribution parameter" ; double fates_hydr_vg_n_node(fates_hydr_organs, fates_pft) ; fates_hydr_vg_n_node:units = "unitless" ; - fates_hydr_vg_n_node:long_name = "n in van Genuchten 1980 model, pore size distribution parameter" ; + fates_hydr_vg_n_node:long_name = "(used if hydr_wtftype_node = 2),n in van Genuchten 1980 model, pore size distribution parameter" ; double fates_leaf_c3psn(fates_pft) ; fates_leaf_c3psn:units = "flag" ; fates_leaf_c3psn:long_name = "Photosynthetic pathway (1=c3, 0=c4)" ; From 07089e44dc46854a5332c3adaddf435c5775d80c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 28 Jun 2021 18:09:05 -0400 Subject: [PATCH 344/578] Added theta_cj parameters to the parameter file (not used yet) and changed wtftype to htftype --- biogeophys/FatesPlantHydraulicsMod.F90 | 8 ++--- main/EDParamsMod.F90 | 40 ++++++++++++++++-------- parameter_files/fates_params_default.cdl | 31 +++++++++++++----- 3 files changed, 54 insertions(+), 25 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index ebab9aa30e..20cd97b64d 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -47,7 +47,7 @@ module FatesPlantHydraulicsMod use EDParamsMod , only : hydr_kmax_rsurf2 use EDParamsMod , only : hydr_psi0 use EDParamsMod , only : hydr_psicap - use EDParamsMod , only : hydr_wtftype_node + use EDParamsMod , only : hydr_htftype_node use EDTypesMod , only : ed_site_type use EDTypesMod , only : ed_patch_type @@ -195,7 +195,7 @@ module FatesPlantHydraulicsMod ! conductivity relationship are available. ! For plants: Users can option between useing tfs and van_genuchten ! by specifying their choice in the parameter file, - ! with the model parameter hydr_wtftype_node, + ! with the model parameter hydr_htftype_node, ! the value should be 1 for TFS or 2 for VG (as shown below). ! Campbell, could technically be used, but the parameters for ! that hypothesis are not in the parameter file, so it not currently available. @@ -5326,7 +5326,7 @@ subroutine InitHydroGlobals() ! ----------------------------------------------------------------------------------- do pm = 1, n_plant_media - select case(hydr_wtftype_node(pm)) + select case(hydr_htftype_node(pm)) case(van_genuchten_type) do ft = 1,numpft allocate(wrf_vg) @@ -5365,7 +5365,7 @@ subroutine InitHydroGlobals() ! Initialize the Water Conductance (K) Functions ! ----------------------------------------------------------------------------------- do pm = 1, n_plant_media - select case(hydr_wtftype_node(pm)) + select case(hydr_htftype_node(pm)) case(van_genuchten_type) do ft = 1,numpft diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index c3894606f6..54be9ed207 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -60,6 +60,10 @@ module EDParamsMod real(r8), protected, public :: cg_strikes ! fraction of cloud to ground lightning strikes (0-1) character(len=param_string_length),parameter :: fates_name_cg_strikes="fates_fire_cg_strikes" + + ! empirical curvature parameters for ac, aj photosynthesis co-limitation, c3 and c4 plants respectively + real(r8),protected,public :: theta_cj_c3 + real(r8),protected,public :: theta_cj_c4 real(r8),protected,public :: q10_mr ! Q10 for respiration rate (for soil fragmenation and plant respiration) (unitless) real(r8),protected,public :: q10_froz ! Q10 for frozen-soil respiration rates (for soil fragmentation) (unitless) @@ -103,13 +107,12 @@ module EDParamsMod character(len=param_string_length),parameter,public :: ED_name_canopy_closure_thresh= "fates_canopy_closure_thresh" character(len=param_string_length),parameter,public :: ED_name_stomatal_model= "fates_leaf_stomatal_model" - ! Resistance to active crown fire - - + character(len=param_string_length),parameter,public :: name_theta_cj_c3 = "fates_theta_cj_c3" + character(len=param_string_length),parameter,public :: name_theta_cj_c4 = "fates_theta_cj_c4" + character(len=param_string_length),parameter :: fates_name_q10_mr="fates_q10_mr" character(len=param_string_length),parameter :: fates_name_q10_froz="fates_q10_froz" - ! non-scalar parameter names character(len=param_string_length),parameter,public :: ED_name_history_sizeclass_bin_edges= "fates_history_sizeclass_bin_edges" character(len=param_string_length),parameter,public :: ED_name_history_ageclass_bin_edges= "fates_history_ageclass_bin_edges" @@ -234,7 +237,8 @@ subroutine FatesParamsInit() eca_plant_escalar = nan q10_mr = nan q10_froz = nan - + theta_cj_c3 = nan + theta_cj_c4 = nan end subroutine FatesParamsInit !----------------------------------------------------------------------- @@ -272,7 +276,11 @@ subroutine FatesRegisterParams(fates_params) call fates_params%RegisterParameter(name=ED_name_photo_temp_acclim_timescale, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=name_theta_cj_c3, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=name_theta_cj_c4, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) call fates_params%RegisterParameter(name=ED_name_mort_disturb_frac, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) @@ -393,7 +401,7 @@ subroutine FatesRegisterParams(fates_params) ! non-scalar parameters - call fates_params%RegisterParameter(name=ED_name_hydr_wtftype_node, dimension_shape=dimension_shape_1d, & + call fates_params%RegisterParameter(name=ED_name_hydr_htftype_node, dimension_shape=dimension_shape_1d, & dimension_names=dim_names_hydro_organs) call fates_params%RegisterParameter(name=ED_name_history_sizeclass_bin_edges, dimension_shape=dimension_shape_1d, & @@ -428,7 +436,7 @@ subroutine FatesReceiveParams(fates_params) class(fates_parameters_type), intent(inout) :: fates_params real(r8) :: tmpreal ! local real variable for changing type on read - real(r8), allocatable :: hydr_wtftype_real(:) + real(r8), allocatable :: hydr_htftype_real(:) call fates_params%RetreiveParameter(name=ED_name_vai_top_bin_width, & data=vai_top_bin_width) @@ -551,6 +559,12 @@ subroutine FatesReceiveParams(fates_params) call fates_params%RetreiveParameter(name=eca_name_plant_escalar, & data=eca_plant_escalar) + call fates_params%RetreiveParameter(name=name_theta_cj_c3, & + data=theta_cj_c3) + + call fates_params%RetreiveParameter(name=name_theta_cj_c4, & + data=theta_cj_c4) + call fates_params%RetreiveParameter(name=fates_name_q10_mr, & data=q10_mr) @@ -577,11 +591,11 @@ subroutine FatesReceiveParams(fates_params) call fates_params%RetreiveParameterAllocate(name=ED_name_history_coageclass_bin_edges, & data=ED_val_history_coageclass_bin_edges) - call fates_params%RetreiveParameterAllocate(name=ED_name_hydr_wtftype_node, & - data=hydr_wtftype_real) - allocate(hydr_wtftype_node(size(hydr_wtftype_real))) - hydr_wtftype_node(:) = nint(hydr_wtftype_real(:)) - deallocate(hydr_wtftype_real) + call fates_params%RetreiveParameterAllocate(name=ED_name_hydr_htftype_node, & + data=hydr_htftype_real) + allocate(hydr_htftype_node(size(hydr_htftype_real))) + hydr_htftype_node(:) = nint(hydr_htftype_real(:)) + deallocate(hydr_htftype_real) end subroutine FatesReceiveParams @@ -601,7 +615,7 @@ subroutine FatesReportParams(is_master) write(fates_log(),fmt0) 'vai_top_bin_width = ',vai_top_bin_width write(fates_log(),fmt0) 'vai_width_increase_factor = ',vai_width_increase_factor write(fates_log(),fmt0) 'photo_temp_acclim_timescale = ',photo_temp_acclim_timescale - write(fates_log(),fmti) 'hydr_wtftype_node = ',hydr_wtftype_node + write(fates_log(),fmti) 'hydr_htftype_node = ',hydr_htftype_node write(fates_log(),fmt0) 'fates_mortality_disturbance_fraction = ',fates_mortality_disturbance_fraction write(fates_log(),fmt0) 'ED_val_comp_excln = ',ED_val_comp_excln write(fates_log(),fmt0) 'ED_val_init_litter = ',ED_val_init_litter diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 7aa448438a..7d2cd54750 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -25,10 +25,10 @@ variables: double fates_history_sizeclass_bin_edges(fates_history_size_bins) ; fates_history_sizeclass_bin_edges:units = "cm" ; fates_history_sizeclass_bin_edges:long_name = "Lower edges for DBH size class bins used in size-resolved cohort history output" ; - double fates_hydr_wtftype_node(fates_hydr_organs) ; - fates_hydr_wtftype_node:units = "unitless" ; - fates_hydr_wtftype_node:long_name = "Switch that defines the water transfer functions for each organ." ; - fates_hydr_wtftype_node:possible_values = "1: Christofferson et al. 2016 (TFS); 2: Van Genuchten 1980" ; + double fates_hydr_htftype_node(fates_hydr_organs) ; + fates_hydr_htftype_node:units = "unitless" ; + fates_hydr_htftype_node:long_name = "Switch that defines the hydraulic transfer functions for each organ." ; + fates_hydr_htftype_node:possible_values = "1: Christofferson et al. 2016 (TFS); 2: Van Genuchten 1980" ; double fates_prt_organ_id(fates_prt_organs) ; fates_prt_organ_id:units = "index, unitless" ; fates_prt_organ_id:long_name = "This is the global index the organ in this file is associated with in PRTGenericMod.F90" ; @@ -273,13 +273,13 @@ variables: fates_hydr_thetas_node:long_name = "saturated water content" ; double fates_hydr_vg_alpha_node(fates_hydr_organs, fates_pft) ; fates_hydr_vg_alpha_node:units = "MPa-1" ; - fates_hydr_vg_alpha_node:long_name = "(used if hydr_wtftype_node = 2), capillary length parameter in van Genuchten model" ; + fates_hydr_vg_alpha_node:long_name = "(used if hydr_htftype_node = 2), capillary length parameter in van Genuchten model" ; double fates_hydr_vg_m_node(fates_hydr_organs, fates_pft) ; fates_hydr_vg_m_node:units = "unitless" ; - fates_hydr_vg_m_node:long_name = "(used if hydr_wtftype_node = 2),m in van Genuchten 1980 model, 2nd pore size distribution parameter" ; + fates_hydr_vg_m_node:long_name = "(used if hydr_htftype_node = 2),m in van Genuchten 1980 model, 2nd pore size distribution parameter" ; double fates_hydr_vg_n_node(fates_hydr_organs, fates_pft) ; fates_hydr_vg_n_node:units = "unitless" ; - fates_hydr_vg_n_node:long_name = "(used if hydr_wtftype_node = 2),n in van Genuchten 1980 model, pore size distribution parameter" ; + fates_hydr_vg_n_node:long_name = "(used if hydr_htftype_node = 2),n in van Genuchten 1980 model, pore size distribution parameter" ; double fates_leaf_c3psn(fates_pft) ; fates_leaf_c3psn:units = "flag" ; fates_leaf_c3psn:long_name = "Photosynthetic pathway (1=c3, 0=c4)" ; @@ -508,6 +508,8 @@ variables: double fates_tausvis(fates_pft) ; fates_tausvis:units = "fraction" ; fates_tausvis:long_name = "Stem transmittance: visible" ; + + double fates_trim_inc(fates_pft) ; fates_trim_inc:units = "m2/m2" ; fates_trim_inc:long_name = "Arbitrary incremental change in trimming function." ; @@ -719,6 +721,15 @@ variables: double fates_photo_temp_acclim_timescale ; fates_photo_temp_acclim_timescale:units = "days" ; fates_photo_temp_acclim_timescale:long_name = "Length of the window for the exponential moving average (ema) of vegetation temperature used in photosynthesis temperature acclimation (NOT USED)" ; + + double fates_theta_cj_c3 ; + fates_theta_cj_c3:units = "unitless" + fates_theta_cj_c3:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c3 plants" + + double fates_theta_cj_c4 ; + fates_theta_cj_c4:units = "unitless" + fates_theta_cj_c4:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c4 plants" + double fates_q10_froz ; fates_q10_froz:units = "unitless" ; fates_q10_froz:long_name = "Q10 for frozen-soil respiration rates" ; @@ -748,7 +759,7 @@ data: fates_history_sizeclass_bin_edges = 0, 5, 10, 15, 20, 30, 40, 50, 60, 70, 80, 90, 100 ; - fates_hydr_wtftype_node = 1, 1, 1, 1 ; + fates_hydr_htftype_node = 1, 1, 1, 1 ; fates_prt_organ_id = 1, 2, 3, 6 ; @@ -1436,6 +1447,10 @@ data: fates_photo_temp_acclim_timescale = 30 ; + fates_theta_cj_c3 = 0.999 + + fates_theta_cj_c4 = 0.999 + fates_q10_froz = 1.5 ; fates_q10_mr = 1.5 ; From 0b1239a8d3137ff4190eb336556a248612ba7f5c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 28 Jun 2021 18:10:35 -0400 Subject: [PATCH 345/578] fixed syntax bug in parameter file --- parameter_files/fates_params_default.cdl | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 7d2cd54750..bcb345b899 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -723,12 +723,12 @@ variables: fates_photo_temp_acclim_timescale:long_name = "Length of the window for the exponential moving average (ema) of vegetation temperature used in photosynthesis temperature acclimation (NOT USED)" ; double fates_theta_cj_c3 ; - fates_theta_cj_c3:units = "unitless" - fates_theta_cj_c3:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c3 plants" + fates_theta_cj_c3:units = "unitless" ; + fates_theta_cj_c3:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c3 plants" ; double fates_theta_cj_c4 ; - fates_theta_cj_c4:units = "unitless" - fates_theta_cj_c4:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c4 plants" + fates_theta_cj_c4:units = "unitless" ; + fates_theta_cj_c4:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c4 plants" ; double fates_q10_froz ; fates_q10_froz:units = "unitless" ; From 03e9987f17b563f78cbfcccc7dedbd84d486a9bb Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 28 Jun 2021 18:33:13 -0400 Subject: [PATCH 346/578] added arbitrary parameters cleaned up theta_cj parameters --- main/EDParamsMod.F90 | 19 ++++++++++++++++--- main/EDPftvarcon.F90 | 16 ++++++++++++++-- parameter_files/fates_params_default.cdl | 18 ++++++++++++++---- 3 files changed, 44 insertions(+), 9 deletions(-) diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 54be9ed207..062d681cd6 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -68,6 +68,12 @@ module EDParamsMod real(r8),protected,public :: q10_mr ! Q10 for respiration rate (for soil fragmenation and plant respiration) (unitless) real(r8),protected,public :: q10_froz ! Q10 for frozen-soil respiration rates (for soil fragmentation) (unitless) + ! Unassociated pft dimensioned free parameter that developers can use for testing arbitrary new hypotheses + ! (THIS PARAMETER IS UNUSED, FEEL FREE TO USE IT FOR WHATEVER PURPOSE YOU LIKE. WE CAN + ! HELP MIGRATE YOUR USAGE OF THE PARMETER TO A PERMANENT HOME LATER) + real(r8),protected,public :: dev_arbitrary + character(len=param_string_length),parameter,public :: name_dev_arbitrary = "fates_dev_arbitrary" + ! parameters whose size is defined in the parameter file real(r8),protected,allocatable,public :: ED_val_history_sizeclass_bin_edges(:) real(r8),protected,allocatable,public :: ED_val_history_ageclass_bin_edges(:) @@ -77,12 +83,12 @@ module EDParamsMod ! Switch that defines the current pressure-volume and pressure-conductivity model ! to be used at each node (compartment/organ) ! 1 = Christofferson et al. 2016 (TFS), 2 = Van Genuchten 1980 - integer, protected,allocatable,public :: hydr_wtftype_node(:) + integer, protected,allocatable,public :: hydr_htftype_node(:) character(len=param_string_length),parameter,public :: ED_name_vai_top_bin_width = "fates_vai_top_bin_width" character(len=param_string_length),parameter,public :: ED_name_vai_width_increase_factor = "fates_vai_width_increase_factor" character(len=param_string_length),parameter,public :: ED_name_photo_temp_acclim_timescale = "fates_photo_temp_acclim_timescale" - character(len=param_string_length),parameter,public :: ED_name_hydr_wtftype_node = "fates_hydr_wtftype_node" + character(len=param_string_length),parameter,public :: ED_name_hydr_htftype_node = "fates_hydr_htftype_node" character(len=param_string_length),parameter,public :: ED_name_mort_disturb_frac = "fates_mort_disturb_frac" character(len=param_string_length),parameter,public :: ED_name_comp_excln = "fates_comp_excln" @@ -239,6 +245,7 @@ subroutine FatesParamsInit() q10_froz = nan theta_cj_c3 = nan theta_cj_c4 = nan + dev_arbitrary = nan end subroutine FatesParamsInit !----------------------------------------------------------------------- @@ -399,6 +406,9 @@ subroutine FatesRegisterParams(fates_params) call fates_params%RegisterParameter(name=fates_name_q10_froz, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=name_dev_arbitrary, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + ! non-scalar parameters call fates_params%RegisterParameter(name=ED_name_hydr_htftype_node, dimension_shape=dimension_shape_1d, & @@ -569,7 +579,10 @@ subroutine FatesReceiveParams(fates_params) data=q10_mr) call fates_params%RetreiveParameter(name=fates_name_q10_froz, & - data=q10_froz) + data=q10_froz) + + call fates_params%RetreiveParameter(name=name_dev_arbitrary, & + data=dev_arbitrary) call fates_params%RetreiveParameter(name=fates_name_active_crown_fire, & data=tmpreal) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index f56cb8de84..b6f17bdd70 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -15,7 +15,6 @@ module EDPftvarcon use FatesGlobals, only : fates_log use FatesGlobals, only : endrun => fates_endrun use FatesLitterMod, only : ilabile,icellulose,ilignin - use PRTGenericMod, only : num_organ_types use PRTGenericMod, only : leaf_organ, fnrt_organ, store_organ use PRTGenericMod, only : sapw_organ, struct_organ, repro_organ use PRTGenericMod, only : prt_cnp_flex_allom_hyp,prt_carbon_allom_hyp @@ -42,7 +41,7 @@ module EDPftvarcon !ED specific variables. type, public :: EDPftvarcon_type - + real(r8), allocatable :: freezetol(:) ! minimum temperature tolerance real(r8), allocatable :: hgt_min(:) ! sapling height m real(r8), allocatable :: dleaf(:) ! leaf characteristic dimension length (m) @@ -180,6 +179,11 @@ module EDPftvarcon real(r8), allocatable :: prescribed_puptake(:) ! If there is no soil BGC model active, ! prescribe an uptake rate for phosphorus ! This is the fraction of plant demand + + + ! Unassociated pft dimensioned free parameter that + ! developers can use for testing arbitrary new hypothese + real(r8), allocatable :: dev_arbitrary_pft(:) ! Parameters dimensioned by PFT and leaf age real(r8), allocatable :: vcmax25top(:,:) ! maximum carboxylation rate of Rub. at 25C, @@ -629,6 +633,10 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_dev_arbitrary_pft' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + ! adding the hlm_pft_map variable with two dimensions - FATES PFTno and HLM PFTno pftmap_dim_names(1) = dimension_name_pft pftmap_dim_names(2) = dimension_name_hlm_pftno @@ -924,6 +932,10 @@ subroutine Receive_PFT(this, fates_params) name = 'fates_prescribed_puptake' call fates_params%RetreiveParameterAllocate(name=name, & data=this%prescribed_puptake) + + name = 'fates_dev_arbitrary_pft' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dev_arbitrary_pft) name = 'fates_eca_decompmicc' call fates_params%RetreiveParameterAllocate(name=name, & diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index bcb345b899..40c05ce79a 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -508,7 +508,9 @@ variables: double fates_tausvis(fates_pft) ; fates_tausvis:units = "fraction" ; fates_tausvis:long_name = "Stem transmittance: visible" ; - + double fates_dev_arbitrary_pft(fates_pft) ; + fates_dev_arbitrary_pft:units = "unknown" ; + fates_dev_arbitrary_pft:long_name = "Unassociated pft dimensioned free parameter that developers can use for testing arbitrary new hypotheses" ; double fates_trim_inc(fates_pft) ; fates_trim_inc:units = "m2/m2" ; @@ -729,7 +731,11 @@ variables: double fates_theta_cj_c4 ; fates_theta_cj_c4:units = "unitless" ; fates_theta_cj_c4:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c4 plants" ; - + + double fates_dev_arbitrary ; + fates_dev_arbitrary:units = "unknown" ; + fates_dev_arbitrary:long_name = "Unassociated free parameter that developers can use for testing arbitrary new hypotheses" ; + double fates_q10_froz ; fates_q10_froz:units = "unitless" ; fates_q10_froz:long_name = "Q10 for frozen-soil respiration rates" ; @@ -1308,6 +1314,8 @@ data: fates_woody = 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0 ; + fates_dev_arbitrary_pft = _,_,_,_,_,_,_,_,_,_,_,_ ; + fates_z0mr = 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055 ; @@ -1447,14 +1455,16 @@ data: fates_photo_temp_acclim_timescale = 30 ; - fates_theta_cj_c3 = 0.999 + fates_theta_cj_c3 = 0.999 ; - fates_theta_cj_c4 = 0.999 + fates_theta_cj_c4 = 0.999 ; fates_q10_froz = 1.5 ; fates_q10_mr = 1.5 ; + fates_dev_arbitrary = _ ; + fates_soil_salinity = 0.4 ; fates_vai_top_bin_width = 1 ; From a670861cfbd9adeab3bf40ca22058840c5e76863 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 28 Jun 2021 18:34:31 -0400 Subject: [PATCH 347/578] sorted default parameter file --- parameter_files/fates_params_default.cdl | 45 +++++++++++------------- 1 file changed, 20 insertions(+), 25 deletions(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 40c05ce79a..6db9007521 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -153,6 +153,9 @@ variables: double fates_c2b(fates_pft) ; fates_c2b:units = "ratio" ; fates_c2b:long_name = "Carbon to biomass multiplier of bulk structural tissues" ; + double fates_dev_arbitrary_pft(fates_pft) ; + fates_dev_arbitrary_pft:units = "unknown" ; + fates_dev_arbitrary_pft:long_name = "Unassociated pft dimensioned free parameter that developers can use for testing arbitrary new hypotheses" ; double fates_displar(fates_pft) ; fates_displar:units = "unitless" ; fates_displar:long_name = "Ratio of displacement height to canopy top height" ; @@ -508,10 +511,6 @@ variables: double fates_tausvis(fates_pft) ; fates_tausvis:units = "fraction" ; fates_tausvis:long_name = "Stem transmittance: visible" ; - double fates_dev_arbitrary_pft(fates_pft) ; - fates_dev_arbitrary_pft:units = "unknown" ; - fates_dev_arbitrary_pft:long_name = "Unassociated pft dimensioned free parameter that developers can use for testing arbitrary new hypotheses" ; - double fates_trim_inc(fates_pft) ; fates_trim_inc:units = "m2/m2" ; fates_trim_inc:long_name = "Arbitrary incremental change in trimming function." ; @@ -594,6 +593,9 @@ variables: double fates_cwd_flig ; fates_cwd_flig:units = "unitless" ; fates_cwd_flig:long_name = "Lignin fraction of coarse woody debris" ; + double fates_dev_arbitrary ; + fates_dev_arbitrary:units = "unknown" ; + fates_dev_arbitrary:long_name = "Unassociated free parameter that developers can use for testing arbitrary new hypotheses" ; double fates_eca_plant_escalar ; fates_eca_plant_escalar:units = "" ; fates_eca_plant_escalar:long_name = "scaling factor for plant fine root biomass to calculate nutrient carrier enzyme abundance (ECA)" ; @@ -723,19 +725,6 @@ variables: double fates_photo_temp_acclim_timescale ; fates_photo_temp_acclim_timescale:units = "days" ; fates_photo_temp_acclim_timescale:long_name = "Length of the window for the exponential moving average (ema) of vegetation temperature used in photosynthesis temperature acclimation (NOT USED)" ; - - double fates_theta_cj_c3 ; - fates_theta_cj_c3:units = "unitless" ; - fates_theta_cj_c3:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c3 plants" ; - - double fates_theta_cj_c4 ; - fates_theta_cj_c4:units = "unitless" ; - fates_theta_cj_c4:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c4 plants" ; - - double fates_dev_arbitrary ; - fates_dev_arbitrary:units = "unknown" ; - fates_dev_arbitrary:long_name = "Unassociated free parameter that developers can use for testing arbitrary new hypotheses" ; - double fates_q10_froz ; fates_q10_froz:units = "unitless" ; fates_q10_froz:long_name = "Q10 for frozen-soil respiration rates" ; @@ -745,6 +734,12 @@ variables: double fates_soil_salinity ; fates_soil_salinity:units = "ppt" ; fates_soil_salinity:long_name = "soil salinity used for model when not coupled to dynamic soil salinity" ; + double fates_theta_cj_c3 ; + fates_theta_cj_c3:units = "unitless" ; + fates_theta_cj_c3:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c3 plants" ; + double fates_theta_cj_c4 ; + fates_theta_cj_c4:units = "unitless" ; + fates_theta_cj_c4:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c4 plants" ; double fates_vai_top_bin_width ; fates_vai_top_bin_width:units = "m2/m2" ; fates_vai_top_bin_width:long_name = "width in VAI units of uppermost leaf+stem layer scattering element in each canopy layer (NOT USED)" ; @@ -886,6 +881,8 @@ data: fates_c2b = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 ; + fates_dev_arbitrary_pft = _, _, _, _, _, _, _, _, _, _, _, _ ; + fates_displar = 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67 ; @@ -1314,8 +1311,6 @@ data: fates_woody = 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0 ; - fates_dev_arbitrary_pft = _,_,_,_,_,_,_,_,_,_,_,_ ; - fates_z0mr = 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055 ; @@ -1369,6 +1364,8 @@ data: fates_cwd_flig = 0.24 ; + fates_dev_arbitrary = _ ; + fates_eca_plant_escalar = 1.25e-05 ; fates_fire_active_crown_fire = 0 ; @@ -1455,18 +1452,16 @@ data: fates_photo_temp_acclim_timescale = 30 ; - fates_theta_cj_c3 = 0.999 ; - - fates_theta_cj_c4 = 0.999 ; - fates_q10_froz = 1.5 ; fates_q10_mr = 1.5 ; - fates_dev_arbitrary = _ ; - fates_soil_salinity = 0.4 ; + fates_theta_cj_c3 = 0.999 ; + + fates_theta_cj_c4 = 0.999 ; + fates_vai_top_bin_width = 1 ; fates_vai_width_increase_factor = 1 ; From dca534e1b29c0afd37bd2d1e32911e47f4372835 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 28 Jun 2021 21:18:13 -0600 Subject: [PATCH 348/578] Using parameter file theta_cj instead of hard-coded --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 8b919f52c1..349f6473bf 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -865,6 +865,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! ------------------------------------------------------------------------------------ use EDPftvarcon , only : EDPftvarcon_inst + use EDParamsMod , only : theta_cj_c3, theta_cj_c4 ! Arguments @@ -962,11 +963,6 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! quantum efficiency, used only for C4 (mol CO2 / mol photons) (index 0) real(r8),parameter,dimension(0:1) :: quant_eff = [0.05_r8,0.0_r8] - ! empirical curvature parameter for ac, aj photosynthesis co-limitation. - ! Changed theta_cj and theta_ip to 0.999 to effectively remove smoothing logic - ! following Anthony Walker's findings from MAAT. - real(r8),parameter,dimension(0:1) :: theta_cj = [0.999_r8,0.999_r8] - ! empirical curvature parameter for ap photosynthesis co-limitation real(r8),parameter :: theta_ip = 0.999_r8 @@ -1063,7 +1059,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in (4._r8*co2_inter_c+8._r8*co2_cpoint) ! Gross photosynthesis smoothing calculations. Co-limit ac and aj. - aquad = theta_cj(c3c4_path_index) + aquad = theta_cj_c3 bquad = -(ac + aj) cquad = ac * aj call quadratic_f (aquad, bquad, cquad, r1, r2) @@ -1094,7 +1090,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap - aquad = theta_cj(c3c4_path_index) + aquad = theta_cj_c4 bquad = -(ac + aj) cquad = ac * aj call quadratic_f (aquad, bquad, cquad, r1, r2) From e6706741b0bd852d19ce5808d1cc6fc42b931e66 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Wed, 30 Jun 2021 01:25:25 -0600 Subject: [PATCH 349/578] adding in error tracking variable --- biogeochem/EDPatchDynamicsMod.F90 | 2 ++ biogeophys/EDSurfaceAlbedoMod.F90 | 4 +++- main/EDTypesMod.F90 | 2 +- 3 files changed, 6 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 200959a4b7..50d24e3798 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2181,6 +2181,7 @@ subroutine zero_patch(cp_p) currentPatch%c_stomata = 0.0_r8 ! This is calculated immediately before use currentPatch%c_lblayer = 0.0_r8 currentPatch%fragmentation_scaler(:) = 0.0_r8 + currentPatch%radiation_error = 0.0_r8 currentPatch%solar_zenith_flag = .false. currentPatch%solar_zenith_angle = nan @@ -2520,6 +2521,7 @@ subroutine fuse_2_patches(csite, dp, rp) rp%zstar = (dp%zstar*dp%area + rp%zstar*rp%area) * inv_sum_area rp%c_stomata = (dp%c_stomata*dp%area + rp%c_stomata*rp%area) * inv_sum_area rp%c_lblayer = (dp%c_lblayer*dp%area + rp%c_lblayer*rp%area) * inv_sum_area + rp%radiation_error = (dp%radiation_error*dp%area + rp%radiation_error*rp%area) * inv_sum_area rp%area = rp%area + dp%area !THIS MUST COME AT THE END! diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 726e1bf1cb..a8f2f12e79 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -564,7 +564,7 @@ subroutine PatchNormanRadiation (currentPatch, & endif ! currentPatch%canopy_mask end do!ft end do!L - + currentPatch%radiation_error = 0.0_r8 do ib = 1,hlm_numSWb Dif_dn(:,:,:) = 0.00_r8 Dif_up(:,:,:) = 0.00_r8 @@ -971,9 +971,11 @@ subroutine PatchNormanRadiation (currentPatch, & if (radtype == idirect)then error = (forc_dir(radtype) + forc_dif(radtype)) - & (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) + currentPatch%radiation_error = currentPatch%radiation_error + error else error = (forc_dir(radtype) + forc_dif(radtype)) - & (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) + currentPatch%radiation_error = currentPatch%radiation_error + error endif lai_reduction(:) = 0.0_r8 do L = 1, currentPatch%NCL_p diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 5da7babc54..0b700286d1 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -430,7 +430,7 @@ module EDTypesMod real(r8) :: elai_profile(nclmax,maxpft,nlevleaf) ! exposed leaf area in each canopy layer, pft, and leaf layer real(r8) :: tsai_profile(nclmax,maxpft,nlevleaf) ! total stem area in each canopy layer, pft, and leaf layer real(r8) :: esai_profile(nclmax,maxpft,nlevleaf) ! exposed stem area in each canopy layer, pft, and leaf layer - + real(r8) :: radiation_error real(r8) :: layer_height_profile(nclmax,maxpft,nlevleaf) real(r8) :: canopy_area_profile(nclmax,maxpft,nlevleaf) ! fraction of crown area per canopy area in each layer ! they will sum to 1.0 in the fully closed canopy layers From 6ee0d72ddfa1063091b8e8ac60ed1e736465afdb Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 1 Jul 2021 07:50:24 -0400 Subject: [PATCH 350/578] Adding two new switches and litterclass names --- main/EDParamsMod.F90 | 25 +++++++++++++++++++++++- parameter_files/fates_params_default.cdl | 23 +++++++++++++++++++++- tools/ncvarsort.py | 1 + 3 files changed, 47 insertions(+), 2 deletions(-) diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 062d681cd6..1f10aa2c7f 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -31,6 +31,12 @@ module EDParamsMod ! of vegetation temperature used in photosynthesis ! temperature acclimation (NOT YET IMPLEMENTED) + integer,protected, public :: maintresp_model ! switch for choosing between leaf maintenance + ! respiration model. 1=Ryan (1991) (NOT YET IMPLEMENTED) + integer,protected, public :: photo_tempsens_model ! switch for choosing the model that defines the temperature + ! sensitivity of photosynthetic parameters (vcmax, jmax). + ! 1=non-acclimating (NOT YET IMPLEMENTED) + real(r8),protected, public :: fates_mortality_disturbance_fraction ! the fraction of canopy mortality that results in disturbance real(r8),protected, public :: ED_val_comp_excln real(r8),protected, public :: ED_val_init_litter @@ -88,8 +94,9 @@ module EDParamsMod character(len=param_string_length),parameter,public :: ED_name_vai_top_bin_width = "fates_vai_top_bin_width" character(len=param_string_length),parameter,public :: ED_name_vai_width_increase_factor = "fates_vai_width_increase_factor" character(len=param_string_length),parameter,public :: ED_name_photo_temp_acclim_timescale = "fates_photo_temp_acclim_timescale" + character(len=param_string_length),parameter,public :: name_photo_tempsens_model = "fates_photo_tempsens_model" + character(len=param_string_length),parameter,public :: name_maintresp_model = "fates_maintresp_model" character(len=param_string_length),parameter,public :: ED_name_hydr_htftype_node = "fates_hydr_htftype_node" - character(len=param_string_length),parameter,public :: ED_name_mort_disturb_frac = "fates_mort_disturb_frac" character(len=param_string_length),parameter,public :: ED_name_comp_excln = "fates_comp_excln" character(len=param_string_length),parameter,public :: ED_name_init_litter = "fates_init_litter" @@ -205,6 +212,8 @@ subroutine FatesParamsInit() vai_top_bin_width = nan vai_width_increase_factor = nan photo_temp_acclim_timescale = nan + photo_tempsens_model = -9 + maintresp_model = -9 fates_mortality_disturbance_fraction = nan ED_val_comp_excln = nan ED_val_init_litter = nan @@ -283,6 +292,12 @@ subroutine FatesRegisterParams(fates_params) call fates_params%RegisterParameter(name=ED_name_photo_temp_acclim_timescale, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=name_photo_tempsens_model,dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=name_maintresp_model,dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=name_theta_cj_c3, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) @@ -456,6 +471,14 @@ subroutine FatesReceiveParams(fates_params) call fates_params%RetreiveParameter(name=ED_name_photo_temp_acclim_timescale, & data=photo_temp_acclim_timescale) + + call fates_params%RetreiveParameter(name=name_photo_tempsens_model, & + data=tmpreal) + photo_tempsens_model = nint(tmpreal) + + call fates_params%RetreiveParameter(name=name_maintresp_model, & + data=tmpreal) + maintresp_model = nint(tmpreal) call fates_params%RetreiveParameter(name=ED_name_mort_disturb_frac, & data=fates_mortality_disturbance_fraction) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 6db9007521..674c0a5ee7 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -1,4 +1,4 @@ -netcdf fates_params_default { +netcdf fates_params_default.c210629_sorted { dimensions: fates_NCWD = 4 ; fates_history_age_bins = 7 ; @@ -38,6 +38,9 @@ variables: char fates_hydr_organname_node(fates_hydr_organs, fates_string_length) ; fates_hydr_organname_node:units = "unitless - string" ; fates_hydr_organname_node:long_name = "Name of plant hydraulics organs (DONT CHANGE, order matches media list in FatesHydraulicsMemMod.F90)" ; + char fates_litterclass_name(fates_litterclass, fates_string_length) ; + fates_litterclass_name:units = "unitless - string" ; + fates_litterclass_name:long_name = "Name of the litter classes, for variables associated with dimension fates_litterclass" ; char fates_prt_organ_name(fates_prt_organs, fates_string_length) ; fates_prt_organ_name:units = "unitless - string" ; fates_prt_organ_name:long_name = "Name of plant organs (order must match PRTGenericMod.F90)" ; @@ -686,6 +689,9 @@ variables: double fates_logging_mechanical_frac ; fates_logging_mechanical_frac:units = "fraction" ; fates_logging_mechanical_frac:long_name = "Fraction of stems killed due infrastructure an other mechanical means" ; + double fates_maintresp_model ; + fates_maintresp_model:units = "unitless" ; + fates_maintresp_model:long_name = "switch for choosing between maintenance respiration models. 1=Ryan (1991) (NOT USED)" ; double fates_mort_disturb_frac ; fates_mort_disturb_frac:units = "fraction" ; fates_mort_disturb_frac:long_name = "fraction of canopy mortality that results in disturbance (i.e. transfer of area from new to old patch)" ; @@ -725,6 +731,9 @@ variables: double fates_photo_temp_acclim_timescale ; fates_photo_temp_acclim_timescale:units = "days" ; fates_photo_temp_acclim_timescale:long_name = "Length of the window for the exponential moving average (ema) of vegetation temperature used in photosynthesis temperature acclimation (NOT USED)" ; + double fates_photo_tempsens_model ; + fates_photo_tempsens_model:units = "unitless" ; + fates_photo_tempsens_model:long_name = "switch for choosing the model that defines the temperature sensitivity of photosynthetic parameters (vcmax, jmax). 1=non-acclimating (NOT USED)" ; double fates_q10_froz ; fates_q10_froz:units = "unitless" ; fates_q10_froz:long_name = "Q10 for frozen-soil respiration rates" ; @@ -784,6 +793,14 @@ data: "transporting root ", "absorbing root " ; + fates_litterclass_name = + "twig ", + "small branch ", + "large branch ", + "trunk ", + "dead leaves ", + "live grass " ; + fates_prt_organ_name = "leaf ", "fine root ", @@ -1426,6 +1443,8 @@ data: fates_logging_mechanical_frac = 0.05 ; + fates_maintresp_model = 1 ; + fates_mort_disturb_frac = 1 ; fates_mort_understorey_death = 0.55983 ; @@ -1452,6 +1471,8 @@ data: fates_photo_temp_acclim_timescale = 30 ; + fates_photo_tempsens_model = 1 ; + fates_q10_froz = 1.5 ; fates_q10_mr = 1.5 ; diff --git a/tools/ncvarsort.py b/tools/ncvarsort.py index 4175d52ad1..75d80c3799 100755 --- a/tools/ncvarsort.py +++ b/tools/ncvarsort.py @@ -43,6 +43,7 @@ def main(): (u'fates_pft', u'fates_string_length'):5, (u'fates_hydr_organs', u'fates_string_length'):6, (u'fates_prt_organs', u'fates_string_length'):7, + (u'fates_litterclass', u'fates_string_length'):7, (u'fates_pft',):8, (u'fates_hydr_organs', u'fates_pft'):8, (u'fates_leafage_class', u'fates_pft'):8, From a717efc3286ab45f2300f6d790832dd40104a751 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 2 Jul 2021 08:48:38 -0600 Subject: [PATCH 351/578] added radiation error output term --- biogeophys/EDSurfaceAlbedoMod.F90 | 3 ++- main/FatesHistoryInterfaceMod.F90 | 13 +++++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index a8f2f12e79..3ef16ce542 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -1199,7 +1199,8 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) end do !iv end do !FT end do !CL - + cpatch%radiation_error = cpatch%radiation_error * (bc_in(s)%solad_parb(ifp,ipar)+ & + bc_in(s)%solai_parb(ifp,ipar)) ! output the actual PAR profiles through the canopy for diagnostic purposes do CL = 1, cpatch%NCL_p diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 97f3342b43..7ae51138cd 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -304,6 +304,7 @@ module FatesHistoryInterfaceMod integer :: ih_c_stomata_si integer :: ih_c_lblayer_si + integer :: ih_rad_error_si integer :: ih_fire_c_to_atm_si @@ -3435,6 +3436,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) 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_rad_error_si => this%hvars(ih_rad_error_si)%r81d, & hio_nep_si => this%hvars(ih_nep_si)%r81d, & hio_hr_si => this%hvars(ih_hr_si)%r81d, & hio_ar_si_scpf => this%hvars(ih_ar_si_scpf)%r82d, & @@ -3541,6 +3543,9 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_c_lblayer_si(io_si) = hio_c_lblayer_si(io_si) + & cpatch%c_lblayer * cpatch%total_canopy_area + hio_rad_error_si(io_si) = hio_rad_error_si(io_si) + & + cpatch%radiation_error * cpatch%area * AREA_INV + ccohort => cpatch%shortest do while(associated(ccohort)) @@ -4913,6 +4918,14 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_c_lblayer_si ) +! radiation error + + call this%set_history_var(vname='RAD_ERROR', units='W m-2 ', & + long='radiation error in FATES RTM', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_rad_error_si ) + + ! Ecosystem Carbon Fluxes (updated rapidly, upfreq=2) From 3150bdc4944134b105cd1f0a9c37d1318d47e5d0 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 5 Jul 2021 18:03:29 -0400 Subject: [PATCH 352/578] Initialized a script that will take an existing cdl file and create a new one based off of a diff xml file. --- parameter_files/patch_default_e3smtest.xml | 10 ++ tools/BatchPatchParams.py | 119 +++++++++++++++++++++ tools/FatesPFTIndexSwapper.py | 37 +++++-- 3 files changed, 160 insertions(+), 6 deletions(-) create mode 100644 parameter_files/patch_default_e3smtest.xml create mode 100755 tools/BatchPatchParams.py diff --git a/parameter_files/patch_default_e3smtest.xml b/parameter_files/patch_default_e3smtest.xml new file mode 100644 index 0000000000..01111c2200 --- /dev/null +++ b/parameter_files/patch_default_e3smtest.xml @@ -0,0 +1,10 @@ + + + fates_params_default.cdl + fates_params_e3smtest.cdl + 1,2,3,4,5,6,7,8,9,10,11,12 + + 0,0,0,0,0,0,0,0,0,0,0,0 + 0,0,0,0,0,0,0,0,0,0,0,0 + + diff --git a/tools/BatchPatchParams.py b/tools/BatchPatchParams.py new file mode 100755 index 0000000000..127b7d21bc --- /dev/null +++ b/tools/BatchPatchParams.py @@ -0,0 +1,119 @@ +#!/usr/bin/env python + +#### this script modifies the default FATES parameter file to generate +# a file used in testing E3SM +# Parser code was based off of modify_fates_paramfile.py + +import os +import argparse +import code # For development: code.interact(local=dict(globals(), **locals())) + +# This is the list of fields that should be changed +# (no spaces on comma parsed parameter values): +# --------------------------------------------------------------------------------------- + + + +override_list = [["fates_prescribed_nuptake","pft","0,0,0,0,0,0,0,0,0,0,0,0"], \ + ["fates_prescribed_puptake","pft","0,0,0,0,0,0,0,0,0,0,0,0"],] + + +# --------------------------------------------------------------------------------------- + +class param_type: + def __init__(self,name,values_text): + self.name = name + self.values = values_text.replace(" ","") #[float(x) for x in values_text.split(',')] + + + + +def load_xml(xmlfile): + + import xml.etree.ElementTree as et + + xmlroot = et.parse(xmlfile).getroot() + print("\nOpenend: "+xmlfile) + + base_cdl = xmlroot.find('base_file').text + new_cdl = xmlroot.find('new_file').text + + pftparams = xmlroot.find('pft_list').text.replace(" ","") + + paramroot = xmlroot.find('parameters') + paramlist = [] + for param in paramroot: + print("parsing "+param.tag) + paramlist.append(param_type(param.tag,param.text)) + + + + return(base_cdl,new_cdl,pftparams,paramlist) + + + +# Little function for assembling the call to the system to make the modification +# ---------------------------------------------------------------------------------------- + +def parse_syscall_str(fnamein,fnameout,param_name,dimtype,param_val): + + if(dimtype=="pft"): + pft_str = " --allpfts" + else: + pft_str = "" + + sys_call_str = "../tools/modify_fates_paramfile.py"+" --fin " + fnamein + \ + " --fout " + fnameout + " --var " + param_name + pft_str + \ + " --val " + param_val + " --overwrite" + + return(sys_call_str) + + + +def main(): + + # Parse arguments + parser = argparse.ArgumentParser(description='Parse command line arguments to this script.') + parser.add_argument('--f', dest='xmlfile', type=str, help="XML control file Required.", required=True) + args = parser.parse_args() + + + # Load the xml file, which contains the base cdl, the output cdl, + # and the parameters to be modified + [base_cdl,new_cdl,pftlist,paramlist] = load_xml(args.xmlfile) + + + # Convert the base cdl file into a temp nc binary + base_nc = os.popen('mktemp').read().rstrip('\n') + gencmd = "ncgen -o "+base_nc+" "+base_cdl + print(gencmd) + os.system(gencmd) + + # Generate a temp output file name + new_nc = os.popen('mktemp').read().rstrip('\n') + + + # Use FatesPFTIndexSwapper.py to prune out unwanted PFTs + swapcmd="../tools/FatesPFTIndexSwapper.py --pft-indices="+pftlist+" --fin="+base_nc+" --fout="+new_nc #+" 1>/dev/null" + os.system(swapcmd) + + # code.interact(local=dict(globals(), **locals())) + + # On subsequent parameters, overwrite the file + for param in paramlist: + + if(len(param.values.split(',')) != len(pftlist.split(',')) ): + print('The number of parameters for pfts does not match the pft list') + exit(2) + + change_str = parse_syscall_str(new_nc,new_nc,param.name,"pft",param.values) + os.system(change_str) + + # Dump the new file to the cdl + os.system("ncdump "+new_nc+" > "+new_cdl) + + +# This is the actual call to main + +if __name__ == "__main__": + main() diff --git a/tools/FatesPFTIndexSwapper.py b/tools/FatesPFTIndexSwapper.py index 9e0830d626..7e39056fa8 100755 --- a/tools/FatesPFTIndexSwapper.py +++ b/tools/FatesPFTIndexSwapper.py @@ -25,7 +25,9 @@ pft_dim_name = 'fates_pft' prt_dim_name = 'fates_prt_organs' - +hydro_dim_name = 'fates_hydr_organs' +litt_dim_name = 'fates_litterclass' +string_dim_name = 'fates_string_length' class timetype: @@ -165,22 +167,31 @@ def main(argv): # Idenfity if this variable has pft dimension pft_dim_found = -1 prt_dim_found = -1 + hydro_dim_found = -1 + litt_dim_found = -1 + string_dim_found = -1 pft_dim_len = len(fp_in.variables.get(key).dimensions) for idim, name in enumerate(fp_in.variables.get(key).dimensions): + # Manipulate data if(name==pft_dim_name): pft_dim_found = idim if(name==prt_dim_name): prt_dim_found = idim - + if(name==litt_dim_name): + litt_dim_found = idim + if(name==hydro_dim_name): + hydro_dim_found = idim + if(name==string_dim_name): + string_dim_found = idim # Copy over the input data # Tedious, but I have to permute through all combinations of dimension position if( pft_dim_len == 0 ): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var.assignValue(float(fp_in.variables.get(key).data)) - elif( (pft_dim_found==-1) & (prt_dim_found==-1) ): + elif( (pft_dim_found==-1) & (prt_dim_found==-1) & (litt_dim_found==-1) & (hydro_dim_found==-1) ): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] elif( (pft_dim_found==0) & (pft_dim_len==1) ): # 1D fates_pft @@ -208,14 +219,28 @@ def main(argv): for id,ipft in enumerate(donor_pft_indices): out_var[id] = fp_in.variables.get(key).data[ipft-1] - elif( (prt_dim_found==0) & (pft_dim_len==2) ): # fates_prt_organs - string_length + elif( (prt_dim_found==0) & (pft_dim_len==2) ): + out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + + elif( (hydro_dim_found==0) & (string_dim_found>=0) ): out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] + + elif( (litt_dim_found==0) & (string_dim_found>=0) ): + out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + + elif( prt_dim_found==0 ): # fates_prt_organs - indices + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] - elif( prt_dim_found==0 ): + elif( litt_dim_found==0 ): + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + elif( hydro_dim_found==0): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] - else: print('This variable has a dimensioning that we have not considered yet.') print('Please add this condition to the logic above this statement.') From a7a884414e1ae2c2a7fba595ee565b98425de14a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 5 Jul 2021 18:16:29 -0400 Subject: [PATCH 353/578] removed temporary text overrides for batch cdl converter --- tools/BatchPatchParams.py | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/tools/BatchPatchParams.py b/tools/BatchPatchParams.py index 127b7d21bc..f4738d397b 100755 --- a/tools/BatchPatchParams.py +++ b/tools/BatchPatchParams.py @@ -8,14 +8,6 @@ import argparse import code # For development: code.interact(local=dict(globals(), **locals())) -# This is the list of fields that should be changed -# (no spaces on comma parsed parameter values): -# --------------------------------------------------------------------------------------- - - - -override_list = [["fates_prescribed_nuptake","pft","0,0,0,0,0,0,0,0,0,0,0,0"], \ - ["fates_prescribed_puptake","pft","0,0,0,0,0,0,0,0,0,0,0,0"],] # --------------------------------------------------------------------------------------- @@ -25,7 +17,7 @@ def __init__(self,name,values_text): self.name = name self.values = values_text.replace(" ","") #[float(x) for x in values_text.split(',')] - +# --------------------------------------------------------------------------------------- def load_xml(xmlfile): From 2704375f39483e90acdba36c410266edd0f3ac1f Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 6 Jul 2021 10:16:56 -0400 Subject: [PATCH 354/578] Added sorting to the batch parameter script --- tools/BatchPatchParams.py | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/tools/BatchPatchParams.py b/tools/BatchPatchParams.py index f4738d397b..4f13ad798e 100755 --- a/tools/BatchPatchParams.py +++ b/tools/BatchPatchParams.py @@ -7,7 +7,7 @@ import os import argparse import code # For development: code.interact(local=dict(globals(), **locals())) - +from scipy.io import netcdf # --------------------------------------------------------------------------------------- @@ -88,22 +88,33 @@ def main(): # Use FatesPFTIndexSwapper.py to prune out unwanted PFTs swapcmd="../tools/FatesPFTIndexSwapper.py --pft-indices="+pftlist+" --fin="+base_nc+" --fout="+new_nc #+" 1>/dev/null" os.system(swapcmd) - - # code.interact(local=dict(globals(), **locals())) + + # We open the new parameter file. We only use this + # to do some dimension checking. + fp_nc = netcdf.netcdf_file(base_nc, 'r') # On subsequent parameters, overwrite the file for param in paramlist: - if(len(param.values.split(',')) != len(pftlist.split(',')) ): - print('The number of parameters for pfts does not match the pft list') + dset_len = len(fp_nc.variables.get(param.name).data[:]) + if(len(param.values.split(',')) != dset_len ): + print('The number of parameters values specified does not match the dataset') exit(2) change_str = parse_syscall_str(new_nc,new_nc,param.name,"pft",param.values) os.system(change_str) + # Sort the new file + newer_nc = os.popen('mktemp').read().rstrip('\n') + os.system("../tools/ncvarsort.py --fin "+new_nc+" --fout "+newer_nc+" --overwrite") + # Dump the new file to the cdl - os.system("ncdump "+new_nc+" > "+new_cdl) + os.system("ncdump "+newer_nc+" > "+new_cdl) + + fp_nc.close() + print("\nBatch parameter transfer complete\n") + # This is the actual call to main From 953c5eb666032b36d7f2604019988ed0f5f591d5 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 6 Jul 2021 11:20:19 -0400 Subject: [PATCH 355/578] Updating running mean functions to include parameter conrolled acclimation to temperature. Updated recruit initialization --- biogeochem/EDCohortDynamicsMod.F90 | 2 +- biogeophys/FatesPlantRespPhotosynthMod.F90 | 5 +++++ main/EDTypesMod.F90 | 10 ++-------- main/FatesInterfaceMod.F90 | 5 +++-- 4 files changed, 11 insertions(+), 11 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index e50d168533..8440e0b079 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -302,7 +302,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & ! Allocate running mean functions allocate(new_cohort%tveg_lpa) - call new_cohort%tveg_lpa%InitRMean(ema_lpa) + call new_cohort%tveg_lpa%InitRMean(ema_lpa,init_value=patchptr%tveg_lpa%GetMean()) ! Recuits do not have mortality rates, nor have they moved any ! carbon when they are created. They will bias our statistics diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 349f6473bf..644ad66d0e 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -355,8 +355,13 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) if(currentPatch%countcohorts > 0.0)then ! Ignore empty patches + print*,"Ts: ",bc_in(s)%tveg_pa(ifp),cpatch%tveg_lpa%GetMean() + currentCohort => currentPatch%tallest do while (associated(currentCohort)) ! Cohort loop + + print*," c ",currentCohort%tveg_lpa%GetMean() + ! Identify the canopy layer (cl), functional type (ft) ! and the leaf layer (IV) for this cohort diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 55b42e41d9..7f053c832b 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -193,13 +193,6 @@ module EDTypesMod integer, public :: n_uptake_mode integer, public :: p_uptake_mode - - ! Leaf photosynthetic temperature acclimation timescale [days] - ! (This variable may be moved to the FATES parameter file soon) - - real(r8), parameter, public :: leaf_photo_temp_acclim_days = 30._r8 - - !************************************ !** COHORT type structure ** !************************************ @@ -430,7 +423,8 @@ module EDTypesMod ! Running means !class(rmean_type), pointer :: t2m ! Place-holder for 2m air temperature (variable window-size) class(rmean_type), pointer :: tveg24 ! 24-hour mean vegetation temperature (K) - + class(rmean_type), pointer :: tveg_lpa ! Running mean of vegetation temperature at the + ! leaf photosynthesis acclimation timescale ! LEAF ORGANIZATION real(r8) :: pft_agb_profile(maxpft,n_dbh_bins) ! binned above ground biomass, for patch fusion: KgC/m2 diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 2b86c4f236..7bb20b7f41 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -23,7 +23,6 @@ module FatesInterfaceMod use EDTypesMod , only : numlevsoil_max use EDTypesMod , only : ed_site_type use EDTypesMod , only : ed_patch_type - use EDTypesMod , only : leaf_photo_temp_acclim_days use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue,ifalse use FatesConstantsMod , only : nearzero @@ -40,6 +39,7 @@ module FatesInterfaceMod use EDParamsMod , only : FatesReportParams use EDParamsMod , only : bgc_soil_salinity use FatesPlantHydraulicsMod , only : InitHydroGlobals + use EDParamsMod , only : photo_temp_acclim_timescale 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 @@ -868,7 +868,8 @@ subroutine SetFatesGlobalElements(use_fates) allocate(fixed_24hr) call fixed_24hr%define(sec_per_day, hlm_stepsize, fixed_window) allocate(ema_lpa) - call ema_lpa%define(leaf_photo_temp_acclim_days,hlm_stepsize,moving_ema_window) + call ema_lpa%define(photo_temp_acclim_timescale*sec_per_day, & + hlm_stepsize,moving_ema_window) else From 8fa8241d1a95699d74c257608397d8ddd9b98efa Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 7 Jul 2021 12:01:46 -0400 Subject: [PATCH 356/578] Various fixes to initialization and restarting cohort/patch level running means. --- biogeochem/EDCanopyStructureMod.F90 | 12 ++++++++++ biogeochem/EDCohortDynamicsMod.F90 | 5 ++-- biogeochem/EDPatchDynamicsMod.F90 | 14 +++++++---- main/EDTypesMod.F90 | 4 ++-- main/FatesInterfaceMod.F90 | 1 + main/FatesInventoryInitMod.F90 | 7 +++++- main/FatesRestartInterfaceMod.F90 | 36 ++++++++++++++++++++++------- 7 files changed, 61 insertions(+), 18 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 6aee6de8de..3e10966bb4 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -41,6 +41,7 @@ module EDCanopyStructureMod use PRTGenericMod, only : repro_organ use PRTGenericMod, only : struct_organ use PRTGenericMod, only : SetState + use FatesRunningMeanMod, only : ema_lpa ! CIME Globals @@ -671,6 +672,11 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) call InitHydrCohort(currentSite,copyc) endif + ! Initialize running means + allocate(copyc%tveg_lpa) + call copyc%tveg_lpa%InitRMean(ema_lpa,& + init_value=currentPatch%tveg_lpa%GetMean()) + call copy_cohort(currentCohort, copyc) newarea = currentCohort%c_area - cc_loss @@ -1123,6 +1129,12 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) if( hlm_use_planthydro.eq.itrue ) then call InitHydrCohort(CurrentSite,copyc) endif + + ! Initialize running means + allocate(copyc%tveg_lpa) + call copyc%tveg_lpa%InitRMean(ema_lpa,& + init_value=currentPatch%tveg_lpa%GetMean()) + call copy_cohort(currentCohort, copyc) !makes an identical copy... newarea = currentCohort%c_area - cc_gain !new area of existing cohort diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 8440e0b079..5f5999fbf1 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -16,6 +16,7 @@ module EDCohortDynamicsMod use FatesConstantsMod , only : fates_unset_r8 use FatesConstantsMod , only : nearzero use FatesConstantsMod , only : calloc_abs_error + use FatesRunningMeanMod , only : ema_lpa use FatesInterfaceTypesMod , only : hlm_days_per_year use FatesInterfaceTypesMod , only : nleafage use SFParamsMod , only : SF_val_CWD_frac @@ -995,7 +996,7 @@ subroutine DeallocateCohort(currentCohort) type(ed_cohort_type),intent(inout) :: currentCohort ! Remove the running mean structure - deallocate(new_cohort%tveg_lpa) + deallocate(currentCohort%tveg_lpa) ! At this point, nothing should be pointing to current Cohort if (hlm_use_planthydro.eq.itrue) call DeallocateHydrCohort(currentCohort) @@ -1806,7 +1807,7 @@ subroutine copy_cohort( currentCohort,copyc ) n%kp25top = o%kp25top ! Copy over running means - n%tveg_lpa%CopyFromDonor(o%tveg_lpa) + call n%tveg_lpa%CopyFromDonor(o%tveg_lpa) ! CARBON FLUXES n%gpp_acc_hold = o%gpp_acc_hold diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 25dd9e915f..209302b2e8 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -49,6 +49,7 @@ module EDPatchDynamicsMod use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse + use FatesConstantsMod , only : t_water_freeze_k_1atm use FatesPlantHydraulicsMod, only : InitHydrCohort use FatesPlantHydraulicsMod, only : AccumulateMortalityWaterStorage use FatesPlantHydraulicsMod, only : DeallocateHydrCohort @@ -698,7 +699,10 @@ subroutine spawn_patches( currentSite, bc_in) nc%prt => null() call InitPRTObject(nc%prt) call InitPRTBoundaryConditions(nc) - + ! Allocate running mean functions + allocate(nc%tveg_lpa) + call nc%tveg_lpa%InitRMean(ema_lpa,init_value=new_patch%tveg_lpa%GetMean()) + call zero_cohort(nc) ! nc is the new cohort that goes in the disturbed patch (new_patch)... currentCohort @@ -1992,8 +1996,8 @@ subroutine create_patch(currentSite, new_patch, age, areap, label) real(r8), intent(in) :: areap ! initial area of this patch in m2. integer, intent(in) :: label ! anthropogenic disturbance label - real(r8), parameter :: temp_init_vegc = 15._r8 ! Until bc's are pointed to by sites - ! give veg temp a default temp. + ! Until bc's are pointed to by sites give veg temp a default temp [K] + real(r8), parameter :: temp_init_veg = 15._r8+t_water_freeze_k_1atm ! !LOCAL VARIABLES: !--------------------------------------------------------------------- @@ -2011,9 +2015,9 @@ subroutine create_patch(currentSite, new_patch, age, areap, label) allocate(new_patch%fragmentation_scaler(currentSite%nlevsoil)) allocate(new_patch%tveg24) - call new_patch%tveg24%InitRMean(fixed_24hr,init_value=temp_init_vegc,init_offset=real(hlm_current_tod,r8) ) + call new_patch%tveg24%InitRMean(fixed_24hr,init_value=temp_init_veg,init_offset=real(hlm_current_tod,r8) ) allocate(new_patch%tveg_lpa) - call new_patch%tveg_lpa%InitRmean(ema_lpa,init_value=temp_init_vegc) + call new_patch%tveg_lpa%InitRmean(ema_lpa,init_value=temp_init_veg) ! Litter ! Allocate, Zero Fluxes, and Initialize to "unset" values diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 7f053c832b..77c9392a4b 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -390,7 +390,7 @@ module EDTypesMod ! Running means class(rmean_type), pointer :: tveg_lpa ! exponential moving average of leaf temperature at the - ! leaf photosynthetic acclimation time-scale + ! leaf photosynthetic acclimation time-scale [K] end type ed_cohort_type @@ -424,7 +424,7 @@ module EDTypesMod !class(rmean_type), pointer :: t2m ! Place-holder for 2m air temperature (variable window-size) class(rmean_type), pointer :: tveg24 ! 24-hour mean vegetation temperature (K) class(rmean_type), pointer :: tveg_lpa ! Running mean of vegetation temperature at the - ! leaf photosynthesis acclimation timescale + ! leaf photosynthesis acclimation timescale [K] ! LEAF ORGANIZATION real(r8) :: pft_agb_profile(maxpft,n_dbh_bins) ! binned above ground biomass, for patch fusion: KgC/m2 diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 7bb20b7f41..21e9ca38cf 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -23,6 +23,7 @@ module FatesInterfaceMod use EDTypesMod , only : numlevsoil_max use EDTypesMod , only : ed_site_type use EDTypesMod , only : ed_patch_type + use EDTypesMod , only : ed_cohort_type use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue,ifalse use FatesConstantsMod , only : nearzero diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index efdebb8708..887310c105 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -62,6 +62,7 @@ module FatesInventoryInitMod use PRTGenericMod, only : phosphorus_element use PRTGenericMod, only : SetState use FatesConstantsMod, only : primaryforest + use FatesRunningMeanMod , only : ema_lpa use PRTGenericMod, only : StorageNutrientTarget implicit none @@ -1042,7 +1043,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & temp_cohort%structmemory = 0._r8 cstatus = leaves_on - stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) + stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) if( prt_params%season_decid(temp_cohort%pft) == itrue .and. & any(csite%cstatus == [phen_cstat_nevercold,phen_cstat_iscold])) then @@ -1069,6 +1070,10 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & prt_obj => null() call InitPRTObject(prt_obj) + ! Allocate running mean functions + allocate(temp_cohort%tveg_lpa) + call temp_cohort%tveg_lpa%InitRMean(ema_lpa,init_value=cpatch%tveg_lpa%GetMean()) + do el = 1,num_elements element_id = element_list(el) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index a0bc260066..04a17e1a1c 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -38,6 +38,7 @@ module FatesRestartInterfaceMod use PRTGenericMod, only : prt_global use PRTGenericMod, only : num_elements use FatesRunningMeanMod, only : rmean_type + use FatesRunningMeanMod, only : ema_lpa ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg @@ -138,8 +139,10 @@ module FatesRestartInterfaceMod integer :: ir_gnd_alb_dir_pasb ! Running Means - integer :: ir_tveg24patch_pa - + integer :: ir_tveg24_pa + integer :: ir_tveglpa_pa + integer :: ir_tveglpa_co + integer :: ir_ddbhdt_co integer :: ir_resp_tstep_co integer :: ir_pft_co @@ -1217,9 +1220,16 @@ subroutine define_restart_vars(this, initialize_variables) call this%DefineRMeanRestartVar(vname='fates_tveg24patch',vtype=cohort_r8, & long_name='24-hour patch veg temp', & - units='K', initialize=initialize_variables,ivar=ivar, index = ir_tveg24patch_pa) - + units='K', initialize=initialize_variables,ivar=ivar, index = ir_tveg24_pa) + call this%DefineRMeanRestartVar(vname='fates_tveglpapatch',vtype=cohort_r8, & + long_name='running average (EMA) of patch veg temp for photo acclim', & + units='K', initialize=initialize_variables,ivar=ivar, index = ir_tveglpa_pa) + + call this%DefineRMeanRestartVar(vname='fates_tveglpacohort',vtype=cohort_r8, & + long_name='running average (EMA) of cohort veg temp for photo acclim', & + units='K', initialize=initialize_variables,ivar=ivar, index = ir_tveglpa_co) + ! Register all of the PRT states and fluxes @@ -1999,7 +2009,9 @@ subroutine set_restart_vectors(this,nc,nsites,sites) write(fates_log(),*) 'CLTV offsetNumCohorts II ',io_idx_co, & cohortsperpatch endif - + + call this%SetRMeanRestartVar(ccohort%tveg_lpa, ir_tveglpa_co, io_idx_co) + io_idx_co = io_idx_co + 1 ccohort => ccohort%taller @@ -2016,7 +2028,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_area_pa(io_idx_co_1st) = cpatch%area ! Patch level running means - call this%SetRMeanRestartVar(cpatch%tveg24, ir_tveg24patch_pa, io_idx_co_1st) + call this%SetRMeanRestartVar(cpatch%tveg24, ir_tveg24_pa, io_idx_co_1st) + call this%SetRMeanRestartVar(cpatch%tveg_lpa, ir_tveglpa_pa, io_idx_co_1st) ! set cohorts per patch for IO rio_ncohort_pa( io_idx_co_1st ) = cohortsperpatch @@ -2356,6 +2369,11 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in, bc_out) call InitHydrCohort(sites(s),new_cohort) end if + ! Allocate running mean functions + allocate(new_cohort%tveg_lpa) + call new_cohort%tveg_lpa%InitRMean(ema_lpa) + + ! Update the previous prev_cohort => new_cohort @@ -2766,6 +2784,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) call UpdatePlantPsiFTCFromTheta(ccohort,sites(s)%si_hydr) end if + + call this%GetRMeanRestartVar(ccohort%tveg_lpa, ir_tveglpa_co, io_idx_co) io_idx_co = io_idx_co + 1 @@ -2794,8 +2814,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) cpatch%solar_zenith_angle = rio_solar_zenith_angle_pa(io_idx_co_1st) - call this%GetRMeanRestartVar(cpatch%tveg24, ir_tveg24patch_pa, io_idx_co_1st) - + call this%GetRMeanRestartVar(cpatch%tveg24, ir_tveg24_pa, io_idx_co_1st) + call this%GetRMeanRestartVar(cpatch%tveg_lpa, ir_tveglpa_pa, io_idx_co_1st) ! set cohorts per patch for IO From da2d7e36e52c205a9883f2c3a65bb358d994bdd2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 8 Jul 2021 13:03:37 -0400 Subject: [PATCH 357/578] Updates to leaf acclimation temperature running mean: history variables, and removing unnecessary (duplicative) boundary condition. --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 5 --- main/EDInitMod.F90 | 17 +++++--- main/EDMainMod.F90 | 7 +++- main/EDTypesMod.F90 | 6 ++- main/FatesHistoryInterfaceMod.F90 | 16 ++++++++ main/FatesInterfaceMod.F90 | 47 ++++++++++++++++------ main/FatesInterfaceTypesMod.F90 | 3 -- 7 files changed, 74 insertions(+), 27 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 644ad66d0e..dbdfd0b3d4 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -355,14 +355,9 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) if(currentPatch%countcohorts > 0.0)then ! Ignore empty patches - print*,"Ts: ",bc_in(s)%tveg_pa(ifp),cpatch%tveg_lpa%GetMean() - currentCohort => currentPatch%tallest do while (associated(currentCohort)) ! Cohort loop - print*," c ",currentCohort%tveg_lpa%GetMean() - - ! Identify the canopy layer (cl), functional type (ft) ! and the leaf layer (IV) for this cohort ft = currentCohort%pft diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 8862e7237a..b166c967de 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -68,6 +68,7 @@ module EDInitMod use PRTGenericMod, only : nitrogen_element use PRTGenericMod, only : phosphorus_element use PRTGenericMod, only : SetState + use FatesSizeAgeTypeIndicesMod,only : get_age_class_index ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg @@ -130,6 +131,8 @@ subroutine init_site_vars( site_in, bc_in, bc_out ) allocate(site_in%area_pft(1:numpft)) allocate(site_in%use_this_pft(1:numpft)) + allocate(site_in%area_by_age(1:nlevage)) + do el=1,num_elements allocate(site_in%flux_diags(el)%leaf_litter_input(1:numpft)) allocate(site_in%flux_diags(el)%root_litter_input(1:numpft)) @@ -228,6 +231,8 @@ subroutine zero_site( site_in ) site_in%area_pft(:) = 0._r8 site_in%use_this_pft(:) = fates_unset_int + + site_in%area_by_age(:) = 0._r8 end subroutine zero_site ! ============================================================================ @@ -347,6 +352,7 @@ subroutine init_patches( nsites, sites, bc_in) ! !LOCAL VARIABLES: integer :: s integer :: el + integer :: ageclass real(r8) :: age !notional age of this patch ! dummy locals @@ -358,9 +364,7 @@ subroutine init_patches( nsites, sites, bc_in) type(ed_patch_type), pointer :: newp type(ed_patch_type), pointer :: currentPatch - ! List out some nominal patch values that are used for Near Bear Ground initializations - ! as well as initializing inventory - age = 0.0_r8 + ! --------------------------------------------------------------------------------------------- ! --------------------------------------------------------------------------------------------- @@ -409,7 +413,9 @@ subroutine init_patches( nsites, sites, bc_in) sites(s)%oldest_patch => newp ! make new patch... - + ! List out some nominal patch values that are used for Near Bear Ground initializations + ! as well as initializing inventory + age = 0.0_r8 call create_patch(sites(s), newp, age, area, primaryforest) ! Initialize the litter pools to zero, these @@ -437,11 +443,11 @@ subroutine init_patches( nsites, sites, bc_in) end if - ! zero all the patch fire variables for the first timestep do s = 1, nsites currentPatch => sites(s)%youngest_patch do while(associated(currentPatch)) + ! zero all the patch fire variables for the first timestep currentPatch%litter_moisture(:) = 0._r8 currentPatch%fuel_eff_moist = 0._r8 currentPatch%livegrass = 0._r8 @@ -461,6 +467,7 @@ subroutine init_patches( nsites, sites, bc_in) currentPatch%scorch_ht(:) = 0._r8 currentPatch%frac_burnt = 0._r8 currentPatch%burnt_frac_litter(:) = 0._r8 + currentPatch => currentPatch%older enddo enddo diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 5deb2c5084..0518c1b34e 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -655,6 +655,8 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) call TotalBalanceCheck(currentSite,final_check_id) + currentSite%area_by_age(:) = 0._r8 + currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) @@ -666,7 +668,10 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) ! This cohort count is used in the photosynthesis loop call count_cohorts(currentPatch) - + ! Update the total area of by patch age class array + currentSite%area_by_age(currentPatch%age_class) = & + currentSite%area_by_age(currentPatch%age_class) + currentPatch%area + currentPatch => currentPatch%younger enddo diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 77c9392a4b..05a4178da9 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -707,7 +707,11 @@ module EDTypesMod ! Fixed Biogeography mode inputs real(r8), allocatable :: area_PFT(:) ! Area allocated to individual PFTs integer, allocatable :: use_this_pft(:) ! Is area_PFT > 0 ? (1=yes, 0=no) - + + ! Total area of patches in each age bin [m2] + real(r8), allocatable :: area_by_age(:) + + ! Mass Balance (allocation for each element) type(site_massbal_type), pointer :: mass_balance(:) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 480aefb180..cd9269849d 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -534,6 +534,8 @@ module FatesHistoryInterfaceMod integer :: ih_fire_sum_fuel_si_age integer :: ih_tveg24_si_age integer :: ih_tveg24_si + integer,public :: ih_tveglpa_si_age + integer,public :: ih_tveglpa_si ! indices to (site x height) variables integer :: ih_canopy_height_dist_si_height @@ -4624,6 +4626,20 @@ subroutine define_history_vars(this, initialize_variables) use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_tveg24_si ) + + call this%set_history_var(vname='TVEGLPA_AGE', units='Kelvin', & + long='fates leaf photo-acclim running mean vegetation temperature by patch age', & + use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_tveglpa_si_age ) + + call this%set_history_var(vname='TVEGLPA_SI', units='Kelvin', & + long='fates leaf photo-acclim running mean vegetation temperature by site', & + use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_tveglpa_si ) + + ! Litter Variables diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 21e9ca38cf..d5273a9ca7 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -24,6 +24,7 @@ module FatesInterfaceMod use EDTypesMod , only : ed_site_type use EDTypesMod , only : ed_patch_type use EDTypesMod , only : ed_cohort_type + use EDTypesMod , only : area_inv use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue,ifalse use FatesConstantsMod , only : nearzero @@ -77,6 +78,8 @@ module FatesInterfaceMod use FatesRunningMeanMod , only : ema_lpa use FatesRunningMeanMod , only : moving_ema_window use FatesRunningMeanMod , only : fixed_window + use FatesHistoryInterfaceMod , only : fates_hist + use FatesHistoryInterfaceMod , only : ih_tveglpa_si_age,ih_tveglpa_si ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -249,7 +252,6 @@ subroutine zero_bcs(fates,s) 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)%tveg_pa(:) = 0.0_r8 fates%bc_in(s)%solad_parb(:,:) = 0.0_r8 fates%bc_in(s)%solai_parb(:,:) = 0.0_r8 @@ -461,7 +463,6 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) allocate(bc_in%wind24_pa(maxPatchesPerSite)) allocate(bc_in%relhumid24_pa(maxPatchesPerSite)) allocate(bc_in%precip24_pa(maxPatchesPerSite)) - allocate(bc_in%tveg_pa(maxPatchesPerSite)) ! Radiation allocate(bc_in%solad_parb(maxPatchesPerSite,hlm_numSWb)) @@ -871,7 +872,6 @@ subroutine SetFatesGlobalElements(use_fates) allocate(ema_lpa) call ema_lpa%define(photo_temp_acclim_timescale*sec_per_day, & hlm_stepsize,moving_ema_window) - else ! If we are not using FATES, the cohort dimension is still @@ -1845,28 +1845,51 @@ subroutine UpdateFatesRMeansTStep(sites,bc_in) type(ed_patch_type), pointer :: cpatch type(ed_cohort_type), pointer :: ccohort - integer :: s, ifp - + integer :: s, ifp, io_si do s = 1,size(sites,dim=1) + ifp=0 cpatch => sites(s)%oldest_patch do while(associated(cpatch)) ifp=ifp+1 - call cpatch%tveg24%UpdateRMean(bc_in(s)%tveg_pa(ifp)) - call cpatch%tveg_lpa%UpdateRMean(bc_in(s)%tveg_pa(ifp)) + call cpatch%tveg24%UpdateRMean(bc_in(s)%t_veg_pa(ifp)) + call cpatch%tveg_lpa%UpdateRMean(bc_in(s)%t_veg_pa(ifp)) ccohort => cpatch%tallest do while (associated(ccohort)) - call ccohort%tveg_lpa%UpdateRMean(bc_in(s)%tveg_pa(ifp)) + call ccohort%tveg_lpa%UpdateRMean(bc_in(s)%t_veg_pa(ifp)) ccohort => ccohort%shorter end do cpatch => cpatch%younger enddo - enddo - + end do + + ! Update running mean history variables + ! ------------------------------------------------------------------------------- + associate(hio_tveglpa_si_age => fates_hist%hvars(ih_tveglpa_si_age)%r82d, & + hio_tveglpa_si => fates_hist%hvars(ih_tveglpa_si)%r81d) + + do s = 1,size(sites,dim=1) + + io_si = sites(s)%h_gid + hio_tveglpa_si_age(io_si,:) = 0._r8 + hio_tveglpa_si(io_si) = 0._r8 + + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + hio_tveglpa_si_age(io_si,cpatch%age_class) = & + hio_tveglpa_si_age(io_si,cpatch%age_class) + & + cpatch%tveg_lpa%GetMean()*cpatch%area/sites(s)%area_by_age(cpatch%age_class) + hio_tveglpa_si(io_si) = hio_tveglpa_si(io_si) + & + cpatch%tveg_lpa%GetMean()*cpatch%area*area_inv + cpatch => cpatch%younger + enddo + end do + end associate + return end subroutine UpdateFatesRMeansTStep - -end module FatesInterfaceMod + + end module FatesInterfaceMod diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 88a2fbde5f..df04f8e4d3 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -351,9 +351,6 @@ module FatesInterfaceTypesMod ! Average precipitation over the last 24 hours [mm/s] real(r8), allocatable :: precip24_pa(:) - ! Patch Vegetation temperature (K) - real(r8),allocatable :: tveg_pa(:) - ! Average relative humidity over past 24 hours [-] real(r8), allocatable :: relhumid24_pa(:) From 5730cedef519a0821e77d24284be55a7d95d097e Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 9 Jul 2021 16:48:57 -0700 Subject: [PATCH 358/578] adding restart variables for calculating area index profiles --- main/FatesRestartInterfaceMod.F90 | 42 ++++++++++++++++++++++++++++++- 1 file changed, 41 insertions(+), 1 deletion(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 47737a9dd3..f1c528ae9e 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -115,6 +115,9 @@ module FatesRestartInterfaceMod integer :: ir_smort_co integer :: ir_asmort_co integer :: ir_c_area_co + integer :: ir_treelai_co + integer :: ir_treesai_co + integer :: ir_canopy_layer_tlai_pa integer :: ir_daily_n_uptake_co integer :: ir_daily_p_uptake_co @@ -1017,6 +1020,18 @@ subroutine define_restart_vars(this, initialize_variables) long_name='area of the fates cohort', & units='m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_c_area_co ) + call this%set_restart_var(vname='fates_cohort_treelai', vtype=cohort_r8, & + long_name='leaf area index of fates cohort', & + units='m2/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_treelai_co ) + call this%set_restart_var(vname='fates_cohort_treesai', vtype=cohort_r8, & + long_name='stem area index of fates cohort', & + units='m2/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_treesai_co ) + call this%set_restart_var(vname='fates_canopy_layer_tlai_pa', vtype=cohort_r8, & + long_name='total patch level leaf area index of each fates canopy layer', & + units='m2/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_layer_tlai_pa ) end if @@ -1540,6 +1555,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type use EDTypesMod, only : maxSWb + use EDTypesMod, only : nclmax use EDTypesMod, only : numWaterMem use EDTypesMod, only : num_vegtemp_mem @@ -1579,7 +1595,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) integer :: io_idx_si_cwd ! each site-cwd index integer :: io_idx_si_pft ! each site-pft index integer :: io_idx_si_vtmem ! indices for veg-temp memory at site - + integer :: io_idx_pa_ncl ! each canopy layer within each patch ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) @@ -1918,6 +1934,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) if (hlm_use_sp .eq. itrue) then this%rvars(ir_c_area_co)%r81d(io_idx_co) = ccohort%c_area + this%rvars(ir_treelai_co)%r81d(io_idx_co) = ccohort%treelai + this%rvars(ir_treesai_co)%r81d(io_idx_co) = ccohort%treesai end if if ( debug ) then @@ -1970,6 +1988,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_cwsl = io_idx_co_1st io_idx_pa_dcsl = io_idx_co_1st io_idx_pa_dc = io_idx_co_1st + io_idx_pa_ncl = io_idx_co_1st litt => cpatch%litter(el+1) @@ -2011,6 +2030,13 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_ib = io_idx_pa_ib + 1 end do + if (hlm_use_sp .eq. itrue) then + do i = 1,nclmax + this%rvars(ir_canopy_layer_tlai_pa)%r81d(io_idx_pa_ncl) = cpatch%canopy_layer_tlai(i) + io_idx_pa_ncl = io_idx_pa_ncl + 1 + end do + end if + ! Set the first cohort index to the start of the next patch, increment ! by the maximum number of cohorts per patch io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch @@ -2020,6 +2046,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_cwd = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_co = io_idx_co_1st + io_idx_pa_ncl = io_idx_co_1st if ( debug ) then write(fates_log(),*) 'CLTV io_idx_co_1st ', io_idx_co_1st @@ -2335,6 +2362,7 @@ 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 EDTypesMod, only : nclmax use FatesInterfaceTypesMod, only : numpft use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch use EDTypesMod, only : numWaterMem @@ -2383,6 +2411,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) integer :: io_idx_si_capf ! each cohort age class x pft index within site integer :: io_idx_si_cwd integer :: io_idx_si_pft + integer :: io_idx_pa_ncl ! each canopy layer within each patch ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) @@ -2502,6 +2531,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_pa_ib = io_idx_co_1st io_idx_si_wmem = io_idx_co_1st io_idx_si_vtmem = io_idx_co_1st + io_idx_pa_ncl = io_idx_co_1st ! Hydraulics counters lyr = hydraulic layer, shell = rhizosphere shell io_idx_si_lyr_shell = io_idx_co_1st @@ -2696,6 +2726,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if (hlm_use_sp .eq. itrue) then ccohort%c_area = this%rvars(ir_c_area_co)%r81d(io_idx_co) + ccohort%treelai = this%rvars(ir_treelai_co)%r81d(io_idx_co) + ccohort%treesai = this%rvars(ir_treesai_co)%r81d(io_idx_co) end if io_idx_co = io_idx_co + 1 @@ -2787,6 +2819,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_pa_ib = io_idx_pa_ib + 1 end do + if (hlm_use_sp .eq. itrue) then + do i = 1,nclmax + cpatch%canopy_layer_tlai(i) = this%rvars(ir_canopy_layer_tlai_pa)%r81d(io_idx_pa_ncl) + io_idx_pa_ncl = io_idx_pa_ncl + 1 + end do + end if + ! Now increment the position of the first cohort to that of the next ! patch @@ -2797,6 +2836,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_pa_cwd = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_co = io_idx_co_1st + io_idx_pa_ncl = io_idx_co_1st if ( debug ) then write(fates_log(),*) 'CVTL io_idx_co_1st ', io_idx_co_1st From fc4dd7230e167ea444a86814a5a48732398f70c2 Mon Sep 17 00:00:00 2001 From: Yilin Fang Date: Tue, 13 Jul 2021 14:33:55 -0700 Subject: [PATCH 359/578] Remove 1D solve, add 2D picard solve --- biogeophys/FatesHydroWTFMod.F90 | 54 +- biogeophys/FatesPlantHydraulicsMod.F90 | 1618 ++++++++++-------------- main/FatesHydraulicsMemMod.F90 | 6 +- 3 files changed, 737 insertions(+), 941 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 09e49887bd..85e3c177f4 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -28,9 +28,10 @@ module FatesHydroWTFMod __FILE__ -! real(r8), parameter :: min_ftc = 0.00001_r8 ! Minimum allowed fraction of total conductance + real(r8), parameter :: min_ftc = 0.00001_r8 ! Minimum allowed fraction of total conductance ! The above cause negative organ water content - real(r8), parameter :: min_ftc = 0.00001e2_r8 ! Minimum allowed fraction of total conductance +! real(r8), parameter :: min_ftc = 0.00001e2_r8 ! Minimum allowed fraction of total conductance +! real(r8), parameter :: min_ftc = 1.e-10_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" @@ -74,6 +75,7 @@ module FatesHydroWTFMod procedure :: dpsidth_from_th => dpsidth_from_th_base procedure :: set_wrf_param => set_wrf_param_base procedure :: get_thsat => get_thsat_base + procedure :: get_thmin => get_thmin_base ! All brands of WRFs have access to these tools to operate ! above and below sat and residual, should they want to @@ -123,6 +125,7 @@ module FatesHydroWTFMod procedure :: dpsidth_from_th => dpsidth_from_th_vg procedure :: set_wrf_param => set_wrf_param_vg procedure :: get_thsat => get_thsat_vg + procedure :: get_thmin => get_thmin_vg end type wrf_type_vg ! Water Conductivity Function @@ -153,6 +156,7 @@ module FatesHydroWTFMod procedure :: dpsidth_from_th => dpsidth_from_th_cch procedure :: set_wrf_param => set_wrf_param_cch procedure :: get_thsat => get_thsat_cch + procedure :: get_thmin => get_thmin_cch end type wrf_type_cch ! Water Conductivity Function @@ -182,6 +186,7 @@ module FatesHydroWTFMod procedure :: dpsidth_from_th => dpsidth_from_th_smooth_cch procedure :: set_wrf_param => set_wrf_param_smooth_cch procedure :: get_thsat => get_thsat_smooth_cch + procedure :: get_thmin => get_thmin_smooth_cch end type wrf_type_smooth_cch ! Water Conductivity Function @@ -218,6 +223,7 @@ module FatesHydroWTFMod procedure :: dpsidth_from_th => dpsidth_from_th_tfs procedure :: set_wrf_param => set_wrf_param_tfs procedure :: get_thsat => get_thsat_tfs + procedure :: get_thmin => get_thmin_tfs procedure :: bisect_pv end type wrf_type_tfs @@ -341,6 +347,14 @@ function get_thsat_base(this) result(th_sat) write(fates_log(),*) 'check how the class pointer was setup' call endrun(msg=errMsg(sourcefile, __LINE__)) end function get_thsat_base + function get_thmin_base(this) result(th_sat) + class(wrf_type) :: this + real(r8) :: th_sat + write(fates_log(),*) 'The base thmin call' + 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 get_thmin_base subroutine set_wkf_param_base(this,params_in) class(wkf_type) :: this real(r8),intent(in) :: params_in(:) @@ -444,6 +458,15 @@ function get_thsat_vg(this) result(th_sat) th_sat = this%th_sat end function get_thsat_vg + ! ===================================================================================== + + function get_thmin_vg(this) result(th_min) + class(wrf_type_vg) :: this + real(r8) :: th_min + + th_min = this%th_min + + end function get_thmin_vg ! ===================================================================================== @@ -717,6 +740,15 @@ function get_thsat_cch(this) result(th_sat) th_sat = this%th_sat end function get_thsat_cch + ! ===================================================================================== + + function get_thmin_cch(this) result(th_min) + class(wrf_type_cch) :: this + real(r8) :: th_min + + th_min = this%th_min + + end function get_thmin_cch ! ===================================================================================== @@ -970,6 +1002,15 @@ function get_thsat_smooth_cch(this) result(th_sat) th_sat = this%th_sat end function get_thsat_smooth_cch + ! ===================================================================================== + + function get_thmin_smooth_cch(this) result(th_min) + class(wrf_type_smooth_cch) :: this + real(r8) :: th_min + + th_min = this%th_min + + end function get_thmin_smooth_cch ! ===================================================================================== @@ -1456,6 +1497,15 @@ function get_thsat_tfs(this) result(th_sat) th_sat = this%th_sat end function get_thsat_tfs + ! ===================================================================================== + + function get_thmin_tfs(this) result(th_min) + class(wrf_type_tfs) :: this + real(r8) :: th_min + + th_min = this%th_min + + end function get_thmin_tfs ! ===================================================================================== diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index a4a5dabecf..191e7f309e 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -202,8 +202,8 @@ module FatesPlantHydraulicsMod 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 +! integer, parameter :: soil_wrf_type = campbell_type +! integer, parameter :: soil_wkf_type = campbell_type !integer, parameter :: plant_wrf_type = van_genuchten_type !integer, parameter :: plant_wkf_type = van_genuchten_type integer, parameter :: soil_wrf_type = smooth1_campbell_type @@ -578,6 +578,8 @@ subroutine InitPlantHydStates(site, cohort) ! 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) = wrfa%p%th_from_psi(cohort_hydr%psi_aroot(j)) + !Avoid negative th + cohort_hydr%th_aroot(j) = max(cohort_hydr%th_aroot(j), wrf_plant(aroot_p_media,ft)%p%get_thmin()) cohort_hydr%ftc_aroot(j) = wkfa%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) end do @@ -588,6 +590,7 @@ subroutine InitPlantHydStates(site, cohort) ! 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) = wrfa%p%th_from_psi(cohort_hydr%psi_aroot(j)) + cohort_hydr%th_aroot(j) = max(cohort_hydr%th_aroot(j), wrf_plant(aroot_p_media,ft)%p%get_thmin()) cohort_hydr%ftc_aroot(j) = wkfa%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) end do end if @@ -608,6 +611,7 @@ subroutine InitPlantHydStates(site, cohort) mpa_per_pa*denh2o*grav_earth*cohort_hydr%z_node_troot - dh_dz cohort_hydr%th_troot = wrft%p%th_from_psi(cohort_hydr%psi_troot) + cohort_hydr%th_troot = max(cohort_hydr%th_troot, wrf_plant(troot_p_media,ft)%p%get_thmin()) cohort_hydr%ftc_troot = wkft%p%ftc_from_psi(cohort_hydr%psi_troot) @@ -620,6 +624,8 @@ subroutine InitPlantHydStates(site, cohort) cohort_hydr%th_ag(n_hypool_ag) = wrf_plant(stem_p_media,ft)%p%th_from_psi(cohort_hydr%psi_ag(n_hypool_ag)) + !Avoid negative th + cohort_hydr%th_ag(n_hypool_ag) = max(cohort_hydr%th_ag(n_hypool_ag), wrf_plant(stem_p_media,ft)%p%get_thmin()) cohort_hydr%ftc_ag(n_hypool_ag) = wkf_plant(stem_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_ag(n_hypool_ag)) @@ -630,6 +636,8 @@ subroutine InitPlantHydStates(site, cohort) dh_dz cohort_hydr%th_ag(k) = wrf_plant(site_hydr%pm_node(k),ft)%p%th_from_psi(cohort_hydr%psi_ag(k)) + !Avoid negative th + cohort_hydr%th_ag(k) = max(cohort_hydr%th_ag(k), wrf_plant(site_hydr%pm_node(k),ft)%p%get_thmin()) cohort_hydr%ftc_ag(k) = wkf_plant(site_hydr%pm_node(k),ft)%p%ftc_from_psi(cohort_hydr%psi_ag(k)) end do @@ -639,7 +647,6 @@ subroutine InitPlantHydStates(site, cohort) 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 cohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_ag(1)) @@ -951,12 +958,14 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! Lets also avoid super-low targets that have very low trimming functions call bleaf(ccohort%dbh,ccohort%pft,max(ccohort%canopy_trim,min_trim),leaf_c_target) - + if( (ccohort%status_coh == leaves_on) .or. ccohort_hydr%is_newly_recruited ) then ccohort_hydr%v_ag(1:n_hypool_leaf) = max(leaf_c,min_leaf_frac*leaf_c_target) * & prt_params%c2b(ft) / denleaf/ real(n_hypool_leaf,r8) end if - + if( ccohort%status_coh /= leaves_on ) then !leaves off + ccohort_hydr%v_ag(1:n_hypool_leaf) = 1.e-10_r8 !tiny number + end if ! Step sapwood volume ! ----------------------------------------------------------------------------------- @@ -1259,7 +1268,6 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne ccohort_hydr%th_aroot(:) = (currentCohort%n*ccohort_hydr%th_aroot(:) + & nextCohort%n*ncohort_hydr%th_aroot(:))/newn ccohort_hydr%supsub_flag = 0 - ! 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 @@ -1288,6 +1296,8 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) + ! Don't allow transpiration? + !if(ccohort_hydr%psi_ag(1) < -10._r8) ccohort_hydr%btran = 1.e-10 ccohort_hydr%qtop = (currentCohort%n*ccohort_hydr%qtop + & nextCohort%n*ncohort_hydr%qtop)/newn @@ -1384,7 +1394,9 @@ subroutine InitHydrSites(sites,bc_in) ! Calculate the number of rhizosphere ! layers used if(aggregate_layers) then - csite_hydr%i_rhiz_t = 11 +! csite_hydr%i_rhiz_t = 11 !one big layer + csite_hydr%i_rhiz_t = 6 !top 5 layer aggregate +! csite_hydr%i_rhiz_t = 2 !no aggregate csite_hydr%i_rhiz_b = bc_in(s)%nlevsoil csite_hydr%nlevrhiz = csite_hydr%i_rhiz_b - csite_hydr%i_rhiz_t + 2 !ideally to be read in from the parameter file @@ -1701,7 +1713,7 @@ subroutine UpdateH2OVeg(nsites,sites,bc_out) csite_hydr%h2oveg_growturn_err - & csite_hydr%h2oveg_pheno_err-& csite_hydr%h2oveg_hydro_err - print *,'bc_out',s,bc_out(s)%plant_stored_h2o_si + !print *,'bc_out',s,bc_out(s)%plant_stored_h2o_si ! if(abs(bc_out(s)%plant_stored_h2o_si) > 1e3) & ! print *,'problem grid',csite_hydr%h2oveg,csite_hydr%h2oveg_dead, & ! csite_hydr%h2oveg_growturn_err,csite_hydr%h2oveg_pheno_err,csite_hydr%h2oveg_hydro_err @@ -1785,7 +1797,7 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & err*csite_hydr%recruit_w_uptake(j)/sumrw_uptake enddo - write(fates_log(),*) 'math check on recruit water failed.' + write(fates_log(),*) 'math check on recruit water failed with err= ', err, sumrw_uptake, recruitw_total call endrun(msg=errMsg(sourcefile, __LINE__)) endif end do ! site loop @@ -2615,7 +2627,6 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) integer :: nlevrhiz ! local for number of rhizosphere levels integer :: sc ! size class index integer :: jl - ! ---------------------------------------------------------------------------------- ! 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 @@ -2692,7 +2703,11 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ccohort=>cpatch%tallest do while(associated(ccohort)) ccohort_hydr => ccohort%co_hydr - gscan_patch = gscan_patch + ccohort%g_sb_laweight + ft = ccohort%pft + ccohort_hydr%psi_ag(1) = wrf_plant(1,ft)%p%psi_from_th(ccohort_hydr%th_ag(1)) + gscan_patch = gscan_patch + ccohort%g_sb_laweight + !& + ! *wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) ccohort => ccohort%shorter enddo !cohort @@ -2715,10 +2730,12 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! 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] - + ! This can cause large transpiration due to small g_sb_laweight 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 + (ccohort%g_sb_laweight/gscan_patch)/ccohort%n + !& + ! *wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) else qflx_tran_veg_indiv = 0._r8 end if @@ -2756,37 +2773,18 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) if(use_2d_hydrosolve) then - +#if 0 call MatSolve2D(bc_in(s),site_hydr,ccohort,ccohort_hydr, & dtime,qflx_tran_veg_indiv, & sapflow,rootuptake(1:nlevrhiz),wb_err_plant,dwat_plant, & dth_layershell_col) - - else - - ! --------------------------------------------------------------------------------- - ! 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 - ! ----------------------------------------------------------------------------------- - - 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,sites(s)%lat,sites(s)%lon) +#endif +#if 1 + call PicardSolve2D(bc_in(s),site_hydr,ccohort,ccohort_hydr, & + dtime,qflx_tran_veg_indiv, & + sapflow,rootuptake(1:nlevrhiz),wb_err_plant,dwat_plant, & + dth_layershell_col,site_hydr%num_nodes) +#endif end if @@ -2837,6 +2835,9 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) call UpdatePlantPsiFTCFromTheta(ccohort,site_hydr) ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) + + ! Don't allow transpiration? + !if(ccohort_hydr%psi_ag(1) < -10._r8) ccohort_hydr%btran = 1.e-10 ccohort => ccohort%shorter @@ -2931,7 +2932,8 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) delta_soil_storage = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & site_hydr%v_shell(:,:)) * denh2o * AREA_INV - prev_h2osoil - +#if 0 + !Is this check meaningful? if(abs(delta_plant_storage - (root_flux - transp_flux)) > 1.e-3_r8 ) then write(fates_log(),*) 'Site plant water balance does not close' write(fates_log(),*) 'balance error: ',abs(delta_plant_storage - (root_flux - transp_flux)) @@ -2939,7 +2941,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) 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__)) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(abs(delta_soil_storage + root_flux + site_runoff) > 1.e-3_r8 ) then @@ -2950,9 +2952,9 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) 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__)) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if - +#endif !----------------------------------------------------------------------- ! mass balance check and pass the total stored vegetation water to HLM @@ -2966,27 +2968,28 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) wb_check_site = delta_plant_storage+delta_soil_storage+site_runoff+transp_flux -! if( abs(wb_check_site - site_hydr%errh2o_hyd) > 1.e-5_r8 ) then -! write(fates_log(),*) 'FATES hydro water ERROR balance does not add up [kg/m2]:',wb_check_site - site_hydr%errh2o_hyd + if( abs(wb_check_site - site_hydr%errh2o_hyd) > 1.e-5_r8 ) then + write(fates_log(),*) 'FATES hydro water ERROR balance does not add up [kg/m2]:',wb_check_site - site_hydr%errh2o_hyd ! 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 -! call endrun(msg=errMsg(sourcefile, __LINE__)) -! end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if ! Now check on total error +#if 0 if( abs(wb_check_site) > 1.e-4_r8 ) then - write(fates_log(),*) 'FATES hydro water balance is not so great [kg/m2]' + write(fates_log(),*) 'FATES hydro water balance is not so great [kg/m2]','at lat,lon=',sites(s)%lat,sites(s)%lon 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 - +#endif site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + site_hydr%errh2o_hyd @@ -2994,9 +2997,8 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) site_hydr%h2oveg_growturn_err - & site_hydr%h2oveg_pheno_err-& site_hydr%h2oveg_hydro_err - if(transp_flux > 0 .and. bc_out(s)%plant_stored_h2o_si == 0._r8) then - print *,'zero error-',transp_flux,site_hydr%h2oveg,site_hydr%h2oveg_dead,site_hydr%h2oveg_hydro_err,site_hydr%h2oveg_growturn_err - endif +! print *,'problem grid',site_hydr%h2oveg,site_hydr%h2oveg_dead, & +! site_hydr%h2oveg_growturn_err,site_hydr%h2oveg_pheno_err,site_hydr%h2oveg_hydro_err,transp_flux enddo !site return @@ -3348,888 +3350,8 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort,cohort_hydr,ordered, kbg_layer return end subroutine OrderLayersForSolve1D - ! ================================================================================= - - subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & - ordered,kbg_layer, sapflow,rootuptake,& - wb_err_plant,dwat_plant,dth_layershell_col,lat_tmp,lon_tmp) - - ! ------------------------------------------------------------------------------- - ! 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]) - - ! 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] - - - 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) :: rootfr ! rooting fraction of this layer (used for diagnostics) - real(r8) :: lat_tmp, lon_tmp !for debugging - ! 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 = 30 ! 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] - - - 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 - real(r8) :: ajac(n_hypool_tot,n_hypool_tot) - integer :: info,ipiv(n_hypool_tot) - - 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) - write(fates_log(),*) 'hydro stability lat/lon: ',lat_tmp,lon_tmp - -! 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. -! nsteps = 1 - 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)) - - !cap capillary pressure - psi_node(i) = max(-1e5_r8,psi_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)) - !cap capillary pressure - psi_node(i) = max(-1e5_r8,psi_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 0 - ajac(:,:) = 0._r8 - do i=1,n_hypool_tot - if(i==1) then - ajac(i,i) = tris_b(i) - ajac(i,i+1) = tris_c(i) - elseif(i==n_hypool_tot) then - ajac(i,i-1)= tris_a(i) - ajac(i,i) = tris_b(i) - else - ajac(i,i-1)= tris_a(i) - ajac(i,i) = tris_b(i) - ajac(i,i+1) = tris_c(i) - endif - enddo - ipiv = 0 - call DGESV(n_hypool_tot,1,ajac(1:n_hypool_tot,1:n_hypool_tot),n_hypool_tot,ipiv,tris_r,n_hypool_tot,info) - dth_node(1:n_hypool_tot) = tris_r(1:n_hypool_tot) -#endif - if(tri_ierr == 1) then -! if(info > 0) 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 -#if 0 -if( q_top_eff > 0.0 .and. (w_tot_beg-w_tot_end) == 0._r8) then - print *,'zero dth--',dth_node,'th-',th_node,'wb-',w_tot_beg,w_tot_end - print *,'tris_a',tris_a - print *,'tris_b',tris_b - print *,'tris_c',tris_c - print *,'tris_r',tris_r - stop -endif -#endif - - wb_step_err = (q_top_eff*dt_substep) - (w_tot_beg-w_tot_end) - !if(lon_tmp == 120._r8 .and. lat_tmp == -34._r8) then - ! write(fates_log(),*)'Grid with problem -',wb_step_err,q_top_eff,'th-',dth_node(1:5),'w_totb',w_tot_beg,w_tot_end - !endif - !linear solver error cannot be avoided - !if(abs(wb_step_err)>1*max_wb_step_err .or. any(dth_node(:).ne.dth_node(:)) )then - if( any(dth_node(:).ne.dth_node(:)) )then - !if(abs(wb_step_err)>1*max_wb_step_err .or. any(dth_node(:).ne.dth_node(:)) )then - !solution_found = .false. - 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 - - ! If desired, check and trap water contents - ! that are negative - if(trap_neg_wc) then - if( any(th_node(:)<0._r8) ) then - solution_found = .false. - error_code = 3 - error_arr(:) = th_node(:) - exit - end if - 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)) - !cap capillary pressure - psi_node(i) = max(-1e5_r8,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)) - !cap capillary pressure - psi_node(i) = max(-1e5_r8,psi_node(i)) - end do - - ! If desired, check and trap pressures that are supersaturated - if(trap_supersat_psi) then - do i = 1,n_hypool_plant - if(psi_node(i)>wrf_plant(pm_node(i),ft)%p%get_thsat()) then - solution_found = .false. - error_code = 4 - end if - end do - do i = n_hypool_plant+1,n_hypool_tot - if(psi_node(i)>site_hydr%wrf_soil(ilayer)%p%get_thsat()) then - solution_found = .false. - error_code = 4 - end if - end do - if(error_code==4) then - error_arr(:) = th_node(:) - end if - end if - - ! Accumulate the water balance error of the layer over the sub-steps - ! for diagnostic purposes - ! [kg/m2] - wb_err_layer = wb_err_layer + wb_step_err - - ! ------------------------------------------------------------------------- - ! Diagnostics - ! ------------------------------------------------------------------------- - - ! Sapflow at the base of the tree is the flux rate - ! between the transporting root node and the first stem node - ! (note: a path j is between node i and i+1) - ! [kg] = [kg/s] * [s] - - i = n_hypool_ag - sapflow_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,wb_err_layer - write(fates_log(),*)'transpiration demand: ', dt_step*q_top_eff,' kg/step/plant','dt',dt_step,'iter',iter - - 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), psi_node(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,r8)) - ! Save the number of sub-steps we ultimately used - cohort_hydr%iterh2 = max(cohort_hydr%iterh2,real(nsteps,r8)) - - ! 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, 'dt_step',dt_step - 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, & @@ -4262,7 +3384,12 @@ subroutine GetImTaylorKAB(kmax_up,kmax_dn, & ! Locals real(r8) :: h_diff ! Total potential difference [MPa] - + real(r8) :: ftc_dn_tmp, ftc_up_tmp ! working frac total conductance [-] + + ! Store ftc before changing it + ftc_dn_tmp = ftc_dn + ftc_up_tmp = ftc_up + ! Calculate difference in total potential over the path [MPa] h_diff = h_up - h_dn @@ -4297,7 +3424,9 @@ subroutine GetImTaylorKAB(kmax_up,kmax_dn, & 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 - + ! Restore ftc + ftc_dn = ftc_dn_tmp + ftc_up = ftc_up_tmp return end subroutine GetImTaylorKAB @@ -4519,6 +3648,7 @@ subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_ne real(r8) :: y_new ! corresponding y value at x.new real(r8) :: f_new ! y difference between new y guess at x.new and target y real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) + integer :: nitr ! number of iterations !---------------------------------------------------------------------- lower = lower_init @@ -4526,6 +3656,7 @@ subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_ne f_lo = zeng2001_crootfr(a, b, lower) - crootfr f_hi = zeng2001_crootfr(a, b, upper) - crootfr chg = upper - lower + nitr = 0 do while(abs(chg) .gt. xtol) x_new = 0.5_r8*(lower + upper) f_new = zeng2001_crootfr(a, b, x_new) - crootfr @@ -4535,7 +3666,11 @@ subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_ne 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_rootfr' + endif end subroutine bisect_rootfr ! ===================================================================================== @@ -4781,6 +3916,8 @@ subroutine Hydraulics_Tridiagonal(a, b, c, r, u, ierr) end if end subroutine Hydraulics_Tridiagonal + ! ===================================================================================== + ! ===================================================================================== @@ -5498,6 +4635,615 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & return end subroutine MatSolve2D + ! ===================================================================================== + + subroutine PicardSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & + tmx,qtop, & + sapflow,rootuptake,wb_err_plant , dwat_plant, & + dth_layershell_site,nnode) + + + ! --------------------------------------------------------------------------------- + ! 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(bc_in_type),intent(in) :: bc_in + 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 + integer :: nnode !total number of nodes + 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 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_bc ! layer of bc + 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 + + + real(r8) :: rlfx_soil ! Pressure update reduction factor for soil compartments + real(r8) :: rlfx_plnt ! Pressure update reduction factor for plant comparmtents + real(r8) :: rlfx_soil0 ! Base relaxation factor for the current iteration round + real(r8) :: rlfx_plnt0 ! "" + + 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] + logical :: continue_search + real(r8) :: k_eff ! Effective conductivity over the current pathway + ! between two nodes. Factors in fractional + ! loss of conductivity on each side of the pathway, and the material maximum + ! conductivity on each side [kg/s/MPa] + integer :: icnx_ar ! Connection index of the aroot <-> rhizosphere shell + + integer :: nsd ! node index of highest residual + integer :: nwtn_iter ! number of (Newton) iterations on each substep + + ! to get a succesfull Newton solve. + integer :: kshell ! rhizosphere shell index, 1->nshell + + integer :: info + integer :: nstep !number of time steps + + + ! 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 + + ! Maximum number of times we re-try a round of Picard + ! iterations, each time decreasing the time-step and + ! potentially reducing relaxation factors + integer, parameter :: max_picard_rounds = 10 + + ! dtime will shrink at the following rate (halving) [s]: + ! 1800,900,450,225,112.5,56.25,28.125,14.0625,7.03125,3.515625, + ! 1.7578125,0.87890625,0.439453125,0.2197265625,0.10986328125, + ! 0.054931640625,0.0274658203125,0.01373291015625,0.006866455078125, + ! 0.0034332275390625,0.00171661376953125, + + + ! Maximum number of Newton iterations in each round + integer, parameter :: max_newton_iter = 100 + + ! 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 + + + integer, parameter :: icnv_fail_round = 1 + integer, parameter :: icnv_pass_round = 2 + + ! Timestep reduction factor when a round of + ! newton iterations fail. + + real(r8), parameter :: dtime_rf = 0.5_r8 + + ! These are the initial relaxation factors at the beginning + ! of the large time-step. These may or may not shrink on + ! subsequent rounds, and may or may not grow over subsequent + ! iterations within rounds + real(r8), parameter :: rlfx_soil_init = 1.0 ! Initial Pressure update + ! reduction factor for soil compartments + real(r8), parameter :: rlfx_plnt_init = 1.0 ! Initial Pressure update + ! reduction factor for plant comparmtents + real(r8), parameter :: dpsi_scap = 0.1 ! Changes in psi (for soil) larger than this + ! will be subject to a capping routine + real(r8), parameter :: dpsi_pcap = 0.1 ! Change sin psi (for plants) larger than this + ! will be subject to a capping routine + real(r8), parameter :: rlfx_plnt_shrink = 1.0 ! Shrink the starting plant relaxtion factor + ! by this multipliler each round + real(r8), parameter :: rlfx_soil_shrink = 1.0 ! Shrink the starting soil relaxtion factor + ! by this multipliler each round + logical, parameter :: reset_on_fail = .false. ! If a round of Newton iterations is unable + ! to find a solution, you can either reset + ! to the beginning of the large timestep (true), or + ! to the beginning of the current substep (false) + + logical, parameter :: allow_lenient_lastiter = .true. ! If this is true, when the newton iteration + ! reaches its last allowed attempt, the + ! error tolerance will be increased (the bar lowered) by 10x + + real(r8), parameter :: cfl = 1.0_r8 !courant number (volume of water replaced in dt) + real(r8) :: cfl_max !maximum courant number + real(r8) :: wb_error ! sub sep error + real(r8) :: a_term ! flux contribution to dn_node + real(r8) :: b_term ! flux contribution to up_node + real(r8) :: dftc_dtheta_node(nnode) ! deriv FTC w.r.t. theta + real(r8) :: dpsi_dtheta_node(nnode) ! deriv psi w.r.t. theta + real(r8) :: volx !temporary volume + integer :: picd_iter !picard iteration counter + + + 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_prev => site_hydr%th_node_prev, & + 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() + + + ! This NaN's the scratch arrays + call site_hydr%FlushSiteScratch() + + ! This is the maximum number of iterations needed for this cohort + ! (each soil layer has a different number, this saves the max) + cohort_hydr%iterh1 = 0 + cohort_hydr%iterh2 = 0 + + ! These are output fluxes from the subroutine, total integrated + ! mass fluxes [kg] over the time-step. sapflow is the integrated + ! flux between the transporting root and the 1st stem compartment. + ! The rootuptake is the integrated flux between the 1st rhizosphere + ! and absorbing roots + sapflow = 0._r8 + rootuptake(:) = 0._r8 + + ! Chnage in water content, over all substeps [m3/m3] + dth_node(:) = 0._r8 + + ! Transfer node heights, volumes and initial water contents for + ! the transporting root and above ground compartments to the + ! complete node vector + + 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 + + ! 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 + + enddo + ! Initialize variables and flags that track + ! the progress of the solve + + tm = 0 + nsteps = 0 + th_node_prev(:) = th_node_init(:) + th_node(:) = th_node_init(:) + dtime = tmx + + ! Total water mass in the plant at the beginning of this solve [kg h2o] + w_tot_beg = sum(th_node_init(:)*v_node(:))*denh2o + + ! calculate cfl + cfl_max = 0._r8 + do k=1,site_hydr%num_nodes + + if(pm_node(k) == rhiz_p_media) then + + j = node_layer(k) + psi_node(k) = max(-1e2_r8, site_hydr%wrf_soil(j)%p%psi_from_th(th_node(k))) + + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = site_hydr%wkf_soil(j)%p%ftc_from_psi(psi_node(k)) + dftc_dpsi_node(k) = site_hydr%wkf_soil(j)%p%dftcdpsi_from_psi(psi_node(k)) + + dpsi_dtheta_node(k) = site_hydr%wrf_soil(j)%p%dpsidth_from_th(th_node(k)) + dftc_dtheta_node(k) = dftc_dpsi_node(k) * dpsi_dtheta_node(k) + + else + + psi_node(k) = max(-1e2_r8, 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)) + dpsi_dtheta_node(k) = wrf_plant(pm_node(k),ft)%p%dpsidth_from_th(th_node(k)) + + dftc_dtheta_node(k) = dftc_dpsi_node(k) * dpsi_dtheta_node(k) + + end if + + + enddo + + + ! Calculations of maximum conductance for upstream and downstream sides + ! of each connection. This IS dependant on total potential h_node + ! because of the root-soil radial conductance. + + call SetMaxCondConnections(site_hydr, cohort_hydr, h_node, kmax_dn, kmax_up) + + ! calculate boundary fluxes + do icnx=1,site_hydr%num_connections + + id_dn = conn_dn(icnx) + id_up = conn_up(icnx) + call GetImTaylorKAB(kmax_up(icnx),kmax_dn(icnx), & + ftc_node(id_up),ftc_node(id_dn), & + h_node(id_up),h_node(id_dn), & + dftc_dtheta_node(id_up), dftc_dtheta_node(id_dn), & + dpsi_dtheta_node(id_up), dpsi_dtheta_node(id_dn), & + k_eff, & + A_term, & + B_term) + + q_flux(icnx) = k_eff*(h_node(id_up)-h_node(id_dn)) + volx = (v_node(id_dn) + v_node(id_up))/2._r8 + cfl_max = max(cfl_max,abs(k_eff*(h_node(id_dn) -h_node(id_up)))*dtime/volx/denh2o) + enddo + !Top node + cfl_max = max(cfl_max, abs(qtop * dtime/v_node(1)/denh2o)) + ! To avoid extreme large clf_max due to large qtop from small gw weight + cfl_max = min(20._r8,cfl_max) + + !Calculate time step that meet cfl condition + if(cfl_max > cfl) then + nsteps = min(int(cfl_max/cfl) + 1, 20) + nsteps = 1 + dtime = tmx/nsteps + end if + outerloop: do while( tm < tmx ) + + ! The solve may reduce the time-step, the shorter + ! time-steps may not be perfectly divisible into + ! the remaining time. If so, then make sure we + ! don't overshoot + + dtime = min(dtime,tmx-tm) + if( ((tmx-tm) < (2*dtime)) .and. ((tmx-tm) > dtime) ) dtime = tmx-tm + + ! Advance time forward + tm = tm + dtime + ! If we have not exceeded our max number + ! of retrying rounds of Newton iterations, reduce + ! time and try a new round + + + ! This is the newton search loop + + continue_search = .true. + picd_iter = 0 + picardloop: do while(continue_search) + + picd_iter = picd_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_prev(k))*denh2o*v_node(k)/dtime + + if(pm_node(k) == rhiz_p_media) then + + j = node_layer(k) + psi_node(k) = max(-1e2_r8, site_hydr%wrf_soil(j)%p%psi_from_th(th_node(k))) + + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = site_hydr%wkf_soil(j)%p%ftc_from_psi(psi_node(k)) + dftc_dpsi_node(k) = site_hydr%wkf_soil(j)%p%dftcdpsi_from_psi(psi_node(k)) + + dpsi_dtheta_node(k) = site_hydr%wrf_soil(j)%p%dpsidth_from_th(th_node(k)) + dftc_dtheta_node(k) = dftc_dpsi_node(k) * dpsi_dtheta_node(k) + + else + + psi_node(k) = max(-1e2_r8, 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)) + dpsi_dtheta_node(k) = wrf_plant(pm_node(k),ft)%p%dpsidth_from_th(th_node(k)) + + dftc_dtheta_node(k) = dftc_dpsi_node(k) * dpsi_dtheta_node(k) + + end if + + ! Fill the self-term on the Jacobian's diagonal with the + ! the change in storage wrt change in psi. + + ajac(k,k) = - denh2o*v_node(k)/dtime + + enddo + + + ! Calculations of maximum conductance for upstream and downstream sides + ! of each connection. This IS dependant on total potential h_node + ! because of the root-soil radial conductance. + + call SetMaxCondConnections(site_hydr, cohort_hydr, h_node, kmax_dn, kmax_up) + + ! calculate boundary fluxes + 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 GetImTaylorKAB(kmax_up(icnx),kmax_dn(icnx), & + ftc_node(id_up),ftc_node(id_dn), & + h_node(id_up),h_node(id_dn), & + dftc_dtheta_node(id_up), dftc_dtheta_node(id_dn), & + dpsi_dtheta_node(id_up), dpsi_dtheta_node(id_dn), & + k_eff, & + A_term, & + B_term) + + 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) + + ! Down-stream node's contribution to the down-stream node's mass balance + ajac(id_dn,id_dn) = ajac(id_dn,id_dn) + A_term + + ! Down-stream node's contribution to the up-stream node's mass balance + ajac(id_up,id_dn) = ajac(id_up,id_dn) - A_term + + ! Up-stream node's contribution to the down-stream node's mass balance + ajac(id_dn,id_up) = ajac(id_dn,id_up) + B_term + + ! Up-stream node's contribution to the up-stream node's mass balance + ajac(id_up,id_up) = ajac(id_up,id_up) - B_term + + + + 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 + + !Solve linear equations + call DGESV(site_hydr%num_nodes,1,ajac,site_hydr%num_nodes,ipiv,residual,site_hydr%num_nodes,info) + + + if ( info < 0 ) then + write(fates_log(),*) 'illegal value generated in DGESV() linear' + write(fates_log(),*) 'system solver, see node: ',-info + 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 + + ! Update the water content + th_node(:) = th_node(:) + residual(:) + +#if 1 +! if(qtop > 0._r8) then +! print * +! end if + ! constrain th + do k=1,site_hydr%num_nodes + + if(pm_node(k) == rhiz_p_media) then + + j = node_layer(k) + th_node(k) = max(th_node(k), site_hydr%wrf_soil(j)%p%get_thmin()) + + else + + th_node(k) = max(th_node(k), wrf_plant(pm_node(k),ft)%p%get_thmin()) + + end if + + + enddo +#endif + + wb_error = qtop*dtime - (sum( th_node_prev(:)*v_node(:) ) - sum( th_node(:)*v_node(:) ))*denh2o + + ! Mass is conserved + if(abs(wb_error) < max_allowed_residual .or. maxval(abs(residual(:))) < 1.e-10_r8) exit picardloop + + if(picd_iter > max_picard_rounds) continue_search = .false. + + end do picardloop + + ! If we are here, that means we succesfully finished + ! a solve with minimal error. More substeps may be required though + ! ------------------------------------------------------------------------------ + + ! If there are any sub-steps left, we need to update + ! the initial water content + th_node_prev(:) = th_node(:) + + + + end do outerloop + + ! Save flux diagnostics + ! ------------------------------------------------------ + + sapflow = sapflow + q_flux(n_hypool_ag)*tmx + + 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)*tmx + enddo + + + ! Update the total change in water content + dth_node(:) = dth_node(:) + (th_node(:) - th_node_init(:)) + + ! 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) + if(minval(cohort_hydr%th_ag(1:n_hypool_ag)) < 0._r8) then + write(fates_log(),*) 'negative water content', cohort_hydr%th_ag(1:n_hypool_ag),wrf_plant(pm_node(1),ft)%p%get_thmin() + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + 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, 1 + nshell + 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*tmx)-(w_tot_beg-w_tot_end) + + + end associate + + return + end subroutine PicardSolve2D ! ===================================================================================== diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index bb5cc079c9..d159cdce54 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -10,7 +10,7 @@ module FatesHydraulicsMemMod implicit none private - logical, parameter, public :: use_2d_hydrosolve = .false. + logical, parameter, public :: use_2d_hydrosolve = .true. ! Number of soil layers for indexing cohort fine root quanitities @@ -29,8 +29,8 @@ module FatesHydraulicsMemMod integer, parameter, public :: n_hypool_stem = 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 - integer, parameter, public :: nshell = 1 + integer, parameter, public :: nshell = 5 +! integer, parameter, public :: nshell = 1 ! number of aboveground plant water storage nodes integer, parameter, public :: n_hypool_ag = n_hypool_leaf+n_hypool_stem From b97565a96f93625aff4afcf0336eb7fa0a67a55b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 16 Jul 2021 10:29:46 -0400 Subject: [PATCH 360/578] Fixing restarting of efflux variables --- biogeochem/FatesSoilBGCFluxMod.F90 | 36 +++++++++--------------------- main/FatesHistoryInterfaceMod.F90 | 6 ----- 2 files changed, 10 insertions(+), 32 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 9f210e8404..133d6a3efd 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -1022,35 +1022,19 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) end select + + ! If there is any efflux (from stores overflowing) + ! than pass that to the labile litter pool + + do id = 1,nlev_eff_decomp + flux_lab_si(id) = flux_lab_si(id) + & + sum(csite%flux_diags(el)%nutrient_efflux_scpf(:)) * & + area_inv * surface_prof(id) + end do + currentPatch => csite%oldest_patch do while (associated(currentPatch)) - ! If there is any efflux (from stores overflowing) - ! than pass that to the labile litter pool - - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) - if(.not.currentCohort%isnew)then - if(element_list(el).eq.carbon12_element) then - efflux_ptr => currentCohort%daily_c_efflux - elseif(element_list(el).eq.nitrogen_element) then - efflux_ptr => currentCohort%daily_n_efflux - elseif(element_list(el).eq.phosphorus_element) then - efflux_ptr => currentCohort%daily_p_efflux - end if - - ! Unit conversion - ! kg/plant/day * plant/ha * ha/m2 -> kg/m2/day - - do id = 1,nlev_eff_decomp - flux_lab_si(id) = flux_lab_si(id) + & - efflux_ptr * currentCohort%n* AREA_INV * surface_prof(id) - end do - end if - currentCohort => currentCohort%shorter - end do - - ! Set a pointer to the litter object ! for the current element on the current ! patch diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 97f3342b43..2d5af9c724 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3377,12 +3377,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) end do - ! and reset the disturbance-related field buffers - - do el = 1, num_elements - call sites(s)%flux_diags(el)%ZeroFluxDiags() - end do - enddo ! site loop end associate From b225db8501482561d45053a9ade373887d4f5ef6 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 16 Jul 2021 10:32:15 -0400 Subject: [PATCH 361/578] Updating pft index swapper script to use newer dimensions --- tools/FatesPFTIndexSwapper.py | 37 +++++++++++++++++++++++++++++------ 1 file changed, 31 insertions(+), 6 deletions(-) diff --git a/tools/FatesPFTIndexSwapper.py b/tools/FatesPFTIndexSwapper.py index 9e0830d626..7e39056fa8 100755 --- a/tools/FatesPFTIndexSwapper.py +++ b/tools/FatesPFTIndexSwapper.py @@ -25,7 +25,9 @@ pft_dim_name = 'fates_pft' prt_dim_name = 'fates_prt_organs' - +hydro_dim_name = 'fates_hydr_organs' +litt_dim_name = 'fates_litterclass' +string_dim_name = 'fates_string_length' class timetype: @@ -165,22 +167,31 @@ def main(argv): # Idenfity if this variable has pft dimension pft_dim_found = -1 prt_dim_found = -1 + hydro_dim_found = -1 + litt_dim_found = -1 + string_dim_found = -1 pft_dim_len = len(fp_in.variables.get(key).dimensions) for idim, name in enumerate(fp_in.variables.get(key).dimensions): + # Manipulate data if(name==pft_dim_name): pft_dim_found = idim if(name==prt_dim_name): prt_dim_found = idim - + if(name==litt_dim_name): + litt_dim_found = idim + if(name==hydro_dim_name): + hydro_dim_found = idim + if(name==string_dim_name): + string_dim_found = idim # Copy over the input data # Tedious, but I have to permute through all combinations of dimension position if( pft_dim_len == 0 ): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var.assignValue(float(fp_in.variables.get(key).data)) - elif( (pft_dim_found==-1) & (prt_dim_found==-1) ): + elif( (pft_dim_found==-1) & (prt_dim_found==-1) & (litt_dim_found==-1) & (hydro_dim_found==-1) ): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] elif( (pft_dim_found==0) & (pft_dim_len==1) ): # 1D fates_pft @@ -208,14 +219,28 @@ def main(argv): for id,ipft in enumerate(donor_pft_indices): out_var[id] = fp_in.variables.get(key).data[ipft-1] - elif( (prt_dim_found==0) & (pft_dim_len==2) ): # fates_prt_organs - string_length + elif( (prt_dim_found==0) & (pft_dim_len==2) ): + out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + + elif( (hydro_dim_found==0) & (string_dim_found>=0) ): out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] + + elif( (litt_dim_found==0) & (string_dim_found>=0) ): + out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + + elif( prt_dim_found==0 ): # fates_prt_organs - indices + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] - elif( prt_dim_found==0 ): + elif( litt_dim_found==0 ): + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + elif( hydro_dim_found==0): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] - else: print('This variable has a dimensioning that we have not considered yet.') print('Please add this condition to the logic above this statement.') From 1fbcb7db77b626dd22173a78843d4e335b9f3f8c Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 16 Jul 2021 09:33:15 -0600 Subject: [PATCH 362/578] snow on canopy implementation --- biogeochem/EDPatchDynamicsMod.F90 | 1 + biogeophys/EDSurfaceAlbedoMod.F90 | 23 ++++++++++++++++++++--- main/EDTypesMod.F90 | 1 + main/FatesInterfaceMod.F90 | 2 ++ main/FatesInterfaceTypesMod.F90 | 5 ++++- 5 files changed, 28 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 50d24e3798..d57eff5577 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2185,6 +2185,7 @@ subroutine zero_patch(cp_p) currentPatch%solar_zenith_flag = .false. currentPatch%solar_zenith_angle = nan + currentPatch%fcansno = nan currentPatch%gnd_alb_dir(:) = nan currentPatch%gnd_alb_dif(:) = nan diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 3ef16ce542..345ab4adb8 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -46,9 +46,20 @@ module EDSurfaceRadiationMod logical :: debug = .false. ! for debugging this module - real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) +! real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + ! (/ 0.80_r8, 0.55_r8 /) + +!parameters of canopy snow reflectance model. +! the parameters in the 2-stream model are not directly analagous to those here +! and so they are stored here for now in common with the ice parameters above. +! in principle these could be moved to the parameter file. + + real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) (/ 0.80_r8, 0.55_r8 /) - + real(r8), public :: rho_snow(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + (/ 0.80_r8, 0.55_r8 /) + real(r8), public :: tau_snow(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + (/ 0.01_r8, 0.01_r8 /) contains subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) @@ -109,6 +120,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) currentPatch%solar_zenith_angle = bc_in(s)%coszen_pa(ifp) currentPatch%gnd_alb_dif(1:hlm_numSWb) = bc_in(s)%albgr_dif_rb(1:hlm_numSWb) currentPatch%gnd_alb_dir(1:hlm_numSWb) = bc_in(s)%albgr_dir_rb(1:hlm_numSWb) + currentPatch%fcansno = bc_in(s)%fcansno_pa(ifp) if(currentPatch%solar_zenith_flag )then @@ -316,7 +328,12 @@ subroutine PatchNormanRadiation (currentPatch, & rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) tau_layer(L,ft,iv,ib)=frac_lai*taul(ft,ib)+frac_sai*taus(ft,ib) - + + ! adjust reflectance and transmittance for canopy snow + rho_layer(L,ft,iv,ib)=rho_layer(L,ft,iv,ib)*(1.0_r8- currentPatch%fcansno) & + + rho_snow(ib) * currentPatch%fcansno + tau_layer(L,ft,iv,ib)=tau_layer(L,ft,iv,ib)*(1.0_r8- currentPatch%fcansno) & + + tau_snow(ib) * currentPatch%fcansno end do !ib endif end do !iv diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 0b700286d1..8bcd49ccd5 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -444,6 +444,7 @@ module EDTypesMod integer :: ncan(nclmax,maxpft) ! number of total leaf layers for each canopy layer and pft !RADIATION FLUXES + real(r8) :: fcansno ! Fraction of canopy covered in snow logical :: solar_zenith_flag ! integer flag specifying daylight (based on zenith angle) real(r8) :: solar_zenith_angle ! solar zenith angle (radians) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 0156beb2dc..e126e9924f 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -250,6 +250,7 @@ subroutine zero_bcs(fates,s) 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)%fcansno_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 @@ -486,6 +487,7 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) ! Canopy Radiation allocate(bc_in%filter_vegzen_pa(maxPatchesPerSite)) allocate(bc_in%coszen_pa(maxPatchesPerSite)) + allocate(bc_in%fcansno_pa(maxPatchesPerSite)) allocate(bc_in%albgr_dir_rb(hlm_numSWb)) allocate(bc_in%albgr_dif_rb(hlm_numSWb)) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 1052ef251e..797f080fc0 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -442,7 +442,10 @@ module FatesInterfaceTypesMod ! I am leaving it at this scale for simplicity. Patches should ! have no spacially variable information real(r8), allocatable :: coszen_pa(:) - + + ! fraction of canopy that is covered in snow + real(r8), allocatable :: fcansno_pa(:) + ! Abledo of the ground for direct radiation, by site broadband (0-1) real(r8), allocatable :: albgr_dir_rb(:) From 2c892f7b84a7a56322e568dfa57ebb0c4e8225d1 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 21 Jul 2021 10:03:12 -0400 Subject: [PATCH 363/578] Updated the batchPatch and modify_fates_paramfile scripts to allow parameters to be defined as the full vector --- tools/BatchPatchParams.py | 18 +- tools/modify_fates_paramfile.py | 385 ++++++++++++++++++-------------- 2 files changed, 225 insertions(+), 178 deletions(-) diff --git a/tools/BatchPatchParams.py b/tools/BatchPatchParams.py index 4f13ad798e..19587b426a 100755 --- a/tools/BatchPatchParams.py +++ b/tools/BatchPatchParams.py @@ -47,16 +47,11 @@ def load_xml(xmlfile): # Little function for assembling the call to the system to make the modification # ---------------------------------------------------------------------------------------- -def parse_syscall_str(fnamein,fnameout,param_name,dimtype,param_val): - - if(dimtype=="pft"): - pft_str = " --allpfts" - else: - pft_str = "" +def parse_syscall_str(fnamein,fnameout,param_name,param_val): sys_call_str = "../tools/modify_fates_paramfile.py"+" --fin " + fnamein + \ - " --fout " + fnameout + " --var " + param_name + pft_str + \ - " --val " + param_val + " --overwrite" + " --fout " + fnameout + " --var " + param_name + \ + " --val " + param_val + " --overwrite --all" return(sys_call_str) @@ -96,12 +91,7 @@ def main(): # On subsequent parameters, overwrite the file for param in paramlist: - dset_len = len(fp_nc.variables.get(param.name).data[:]) - if(len(param.values.split(',')) != dset_len ): - print('The number of parameters values specified does not match the dataset') - exit(2) - - change_str = parse_syscall_str(new_nc,new_nc,param.name,"pft",param.values) + change_str = parse_syscall_str(new_nc,new_nc,param.name,param.values) os.system(change_str) # Sort the new file diff --git a/tools/modify_fates_paramfile.py b/tools/modify_fates_paramfile.py index 12fb552cdc..670ad96d8a 100755 --- a/tools/modify_fates_paramfile.py +++ b/tools/modify_fates_paramfile.py @@ -25,6 +25,7 @@ import datetime import time import numpy as np +import code # For development: code.interact(local=dict(globals(), **locals())) # ======================================================================================== # ======================================================================================== @@ -46,30 +47,39 @@ def main(): parser.add_argument('--silent', '--s', dest='silent', help="prevent writing of output.", action="store_true") parser.add_argument('--nohist', dest='nohist', help="prevent recording of the edit in the history attribute of the output file", action="store_true") parser.add_argument('--changeshape', dest='changeshape', help="allow script to change shape of specified variable, and all other variables with the relevant dimension, if necessary", action="store_true") + parser.add_argument('--all',dest='varall',help="replace all values for the specified parameter, supercedes other flags",action="store_true") # args = parser.parse_args() # - # work with the file in some random temporary place so that if something goes wrong, then nothing happens to original file and it doesn't make a persistent output file + # work with the file in some random temporary place so that if something goes wrong, + # then nothing happens to original file and it doesn't make a persistent output file tempdir = tempfile.mkdtemp() tempfilename = os.path.join(tempdir, 'temp_fates_param_file.nc') ncfile_old = None rename_pft = False - # - try: - outputval = float(args.val) - if args.changeshape: - raise Exception - except: + + if args.varall: + # val_list = args.val.split(',') + # output_vec = [float(valstr) for valstr in val_list] + outputval = np.fromstring(args.val, sep=',', dtype=np.float64) + + else: + try: - #print('output variable not interpretable as real. trying array') - outputval = np.fromstring(args.val, sep=',', dtype=np.float32) - if len(outputval) == 0: - raise RuntimeError('output variable needs to have size greater than zero') + outputval = float(args.val) + if args.changeshape: + raise Exception except: - if args.varname != 'fates_pftname': - raise RuntimeError('output variable not interpretable as real or array') - else: - rename_pft = True + try: + #print('output variable not interpretable as real. trying array') + outputval = np.fromstring(args.val, sep=',', dtype=np.float32) + if len(outputval) == 0: + raise RuntimeError('output variable needs to have size greater than zero') + except: + if args.varname != 'fates_pftname': + raise RuntimeError('output variable not interpretable as real or array') + else: + rename_pft = True # # try: @@ -78,169 +88,213 @@ def main(): ncfile = nc.netcdf_file(tempfilename, 'a') # var = ncfile.variables[args.varname] + # - ### check to make sure that, if a PFT is specified, the variable has a PFT dimension, and if not, then it doesn't. and also that shape is reasonable. + ### check to make sure that, if a PFT is specified, the variable has a PFT dimension, + ### and if not, then it doesn't. and also that shape is reasonable. ndim_file = len(var.dimensions) - ispftvar = False - # for purposes of current state of this script, assume 1D - if ndim_file > 2: - raise ValueError('variable dimensionality is too high for this script') - for i in range(ndim_file): - if var.dimensions[i] == 'fates_pft': - ispftvar = True - npft_file = var.shape[i] - pftdim = i - otherdimpresent = False - elif var.dimensions[i] in ['fates_history_age_bins','fates_history_size_bins','fates_history_coage_bins','fates_history_height_bins','fates_NCWD','fates_litterclass','fates_leafage_class','fates_prt_organs','fates_hydr_organs','fates_variants']: - 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') - # - if args.changeshape: - ### if we are allowing the script to change the shape of the variable, then we need to figure out if that's really a thing that needs to happen. - ### first identify what dimension we would change the shape of if we had to. - length_specified = len(outputval) - if length_specified != otherdimlength: - ### ok, we find ourselves in the situation where we need to rewrite the netcdf from scratch with its revised shape. - # - # first lets chech to make sure the dimension we are changing can be changed without breaking things. - plastic_dimensions_list = ['fates_history_age_bins','fates_history_size_bins','fates_history_coage_bins','fates_history_height_bins','fates_leafage_class'] - if otherdimname not in plastic_dimensions_list: - raise ValueError('asking to change the shape of a dimension, '+otherdimname+', that will probably break things') + + + if args.varall: + + # Calculate total number of values expected + nvals = 1 + #code.interact(local=dict(globals(), **locals())) + for i in range(ndim_file): + nvals = nvals*np.prod(var.shape[i]) + if(len(outputval) != nvals): + print('Input vector is not the same size as the in-file array for {}'.format(args.varname)) + print('total size = {}, you specified = {} values'.format(nvals,len(outputval))) + exit(2) + + if(ndim_file==2): + ii = 0 + for i in range(var.shape[0]): + for j in range(var.shape[1]): + var[i,j] = outputval[ii] + ii=ii+1 + + elif(ndim_file==1): + for i in range(var.shape[0]): + var[i] = outputval[i] + + else: + + ispftvar = False + # for purposes of current state of this script, assume 1D + if ndim_file > 2: + raise ValueError('variable dimensionality is too high for this script') + for i in range(ndim_file): + if var.dimensions[i] == 'fates_pft': + ispftvar = True + npft_file = var.shape[i] + pftdim = i + otherdimpresent = False + elif var.dimensions[i] in ['fates_history_age_bins','fates_history_size_bins', \ + 'fates_history_coage_bins','fates_history_height_bins', \ + 'fates_NCWD','fates_litterclass','fates_leafage_class', \ + 'fates_prt_organs','fates_hydr_organs','fates_variants']: + 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: - print('WARNING: we need to change the dimension of '+otherdimname) - ### close the file that's open and start over. - ncfile.close() - os.remove(tempfilename) - ncfile = nc.netcdf_file(tempfilename, 'w') - ncfile_old = nc.netcdf_file(args.inputfname, 'r') - # - try: - ncfile.history = ncfile_old.history - except: - print('no history') - # - ### copy over and, when needed, modify the dimensions - for name, dimlength in ncfile_old.dimensions.items(): - #print(name, dimlength) - if name != otherdimname: - ncfile.createDimension(name, dimlength) + raise ValueError('variable is not on either the PFT or scalar dimension') + + # + if args.changeshape: + ### if we are allowing the script to change the shape of the variable, + ### then we need to figure out if that's really a thing that needs to happen. + ### first identify what dimension we would change the shape of if we had to. + length_specified = len(outputval) + if length_specified != otherdimlength: + ### ok, we find ourselves in the situation where we need to rewrite the netcdf + ### from scratch with its revised shape. + # + # first lets chech to make sure the dimension we are changing can be changed without breaking things. + plastic_dimensions_list = ['fates_history_age_bins','fates_history_size_bins', \ + 'fates_history_coage_bins','fates_history_height_bins', \ + 'fates_leafage_class'] + if otherdimname not in plastic_dimensions_list: + raise ValueError('asking to change the shape of a dimension, '+\ + otherdimname+', that will probably break things') else: - ncfile.createDimension(name, length_specified) - #print(name, length_specified) - # - ### copy over and, when needed, modify the variables - for name, variable in ncfile_old.variables.items(): - variabledims = variable.dimensions - #print(name, variabledims) - x = ncfile.createVariable(name, variable.data.dtype, variable.dimensions) - try: - x.units = variable.units - except: - print('no units') + print('WARNING: we need to change the dimension of '+otherdimname) + ### close the file that's open and start over. + ncfile.close() + os.remove(tempfilename) + ncfile = nc.netcdf_file(tempfilename, 'w') + ncfile_old = nc.netcdf_file(args.inputfname, 'r') + # try: - x.long_name = variable.long_name + ncfile.history = ncfile_old.history except: - print('no long name') + print('no history') # - if len(variable.dimensions) > 0: - if not otherdimname in variable.dimensions: - x[:] = variable[:] + ### copy over and, when needed, modify the dimensions + for name, dimlength in ncfile_old.dimensions.items(): + #print(name, dimlength) + if name != otherdimname: + ncfile.createDimension(name, dimlength) else: - if len(variable.dimensions) == 1: - if length_specified > otherdimlength: - print('WARNING: Variable '+name+' has a dimension that has been reshaped. New length is longer than old, so its been filled in with zeros.') - x[0:otherdimlength] = variable[0:otherdimlength] - x[otherdimlength:length_specified] = 0 - else: - print('WARNING: Variable '+name+' has a dimension that has been reshaped. New length is shorter than old, so its been truncated.') - x[0:length_specified] = variable[0:length_specified] - elif len(variable.dimensions) == 2: - if length_specified > otherdimlength: - print('WARNING: Variable '+name+' has a dimension that has been reshaped. New length is longer than old, so its been filled in with zeros.') - x[0:otherdimlength,:] = variable[0:otherdimlength,:] - x[otherdimlength:length_specified,:] = 0 - else: - print('WARNING: Variable '+name+' has a dimension that has been reshaped. New length is shorter than old, so its been truncated.') - x[0:length_specified,:] = variable[0:length_specified,:] - else: - x.assignValue(float(variable.data)) - # - var = ncfile.variables[args.varname] - else: - # declare as none for now - ncfile_old = None - # - 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 or args.pftname != None) and args.allpfts: - raise ValueError("can't specify both a PFT number and the argument allPFTs.") - 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 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)+').') + ncfile.createDimension(name, length_specified) + #print(name, length_specified) + # + ### copy over and, when needed, modify the variables + for name, variable in ncfile_old.variables.items(): + variabledims = variable.dimensions + #print(name, variabledims) + x = ncfile.createVariable(name, variable.data.dtype, variable.dimensions) + try: + x.units = variable.units + except: + print('no units') + try: + x.long_name = variable.long_name + except: + print('no long name') + # + if len(variable.dimensions) > 0: + if not otherdimname in variable.dimensions: + x[:] = variable[:] + else: + if len(variable.dimensions) == 1: + if length_specified > otherdimlength: + print('WARNING: Variable '+name+ \ + ' has a dimension that has been reshaped.'+\ + ' New length is longer than old, so its been filled in with zeros.') + x[0:otherdimlength] = variable[0:otherdimlength] + x[otherdimlength:length_specified] = 0 + else: + print('WARNING: Variable '+name+' has a dimension that has been reshaped.'+\ + ' New length is shorter than old, so its been truncated.') + x[0:length_specified] = variable[0:length_specified] + elif len(variable.dimensions) == 2: + if length_specified > otherdimlength: + print('WARNING: Variable '+name+' has a dimension that has been reshaped.'+\ + ' New length is longer than old, so its been filled in with zeros.') + x[0:otherdimlength,:] = variable[0:otherdimlength,:] + x[otherdimlength:length_specified,:] = 0 + else: + print('WARNING: Variable '+name+' has a dimension that has been reshaped.'+\ + ' New length is shorter than old, so its been truncated.') + x[0:length_specified,:] = variable[0:length_specified,:] + else: + x.assignValue(float(variable.data)) + # + var = ncfile.variables[args.varname] + else: + # declare as none for now + ncfile_old = None + # + 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 or args.pftname != None) and args.allpfts: + raise ValueError("can't specify both a PFT number and the argument allPFTs.") + 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 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: - 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 + print('replacing prior values of variable '+args.varname+', for all PFTs, which were '+str(var[:])+', with new value of '+str(outputval)) + var[:] = 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: - print('replacing prior values of variable '+args.varname+', for all PFTs, which were '+str(var[:])+', with new value of '+str(outputval)) - var[:] = outputval - if pftdim == 1: - if not args.silent: - print('replacing prior values of variable '+args.varname+', for all PFTs, which were '+str(var[:])+', with new value of '+str(outputval)) - var[:] = outputval - elif args.pftnum == None and not ispftvar and ndim_file > 0: - if not otherdimpresent: + print('replacing prior values of variable '+args.varname+', for all PFTs, which were '+str(var[:])+', with new value of '+str(outputval)) + var[:] = outputval + elif args.pftnum == None and not ispftvar and ndim_file > 0: + if not otherdimpresent: + if not args.silent: + print('replacing prior value of variable '+args.varname+', which was '+str(var[:])+', with new value of '+str(outputval)) + var[:] = outputval + else: + #print(var.shape) + #print(outputval.shape) + if not args.silent: + print('replacing prior value of variable '+args.varname+', which was '+str(var[:])+', with new value of '+str(outputval)) + var[:] = outputval + elif ndim_file < 1: if not args.silent: - print('replacing prior value of variable '+args.varname+', which was '+str(var[:])+', with new value of '+str(outputval)) - var[:] = outputval + print('replacing prior value of scalar variable '+args.varname+', which was '+str(var.data)+', with new value of '+str(outputval)) + var.assignValue(outputval) else: - #print(var.shape) - #print(outputval.shape) - if not args.silent: - print('replacing prior value of variable '+args.varname+', which was '+str(var[:])+', with new value of '+str(outputval)) - var[:] = outputval - elif ndim_file < 1: - if not args.silent: - print('replacing prior value of scalar variable '+args.varname+', which was '+str(var.data)+', with new value of '+str(outputval)) - var.assignValue(outputval) - else: - raise ValueError('Nothing happened somehow.') + raise ValueError('Nothing happened somehow.') + # if not args.nohist: # write to the netcdf file history attribute what you just did. @@ -250,6 +304,9 @@ def main(): oldhiststr = ncfile.history.decode('utf-8') newhiststr = oldhiststr + "\n "+timestampstring + ': ' + actionstring ncfile.history = newhiststr + + + # ncfile.close() if type(ncfile_old) != type(None): From f701d0604f9d58246b905428878e495e822d706b Mon Sep 17 00:00:00 2001 From: Yilin Fang Date: Thu, 22 Jul 2021 10:36:42 -0700 Subject: [PATCH 364/578] Add variable definition --- biogeophys/FatesHydroWTFMod.F90 | 48 ++++++++++++++++++--------------- 1 file changed, 27 insertions(+), 21 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 85e3c177f4..aca545cd4b 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -1,4 +1,4 @@ -module FatesHydroWTFMod + module FatesHydroWTFMod use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : fates_unset_r8 @@ -179,7 +179,10 @@ module FatesHydroWTFMod real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] real(r8) :: psi_sat ! Bubbling pressure (potential at saturation) [Mpa] real(r8) :: beta ! Clapp-Hornberger "beta" parameter [-] - real(r8) :: scch_pu, scch_ps, scch_b2, scch_b3 + real(r8) :: scch_pu ! An estimated breakpoint capillary pressure, below which the specified water retention curve is applied. It is also the lower limit when the smoothing function is applied. [Mpa] + real(r8) :: scch_ps ! An estimated breakpoint capillary pressure, an upper limit where smoothing funciton is applied. [Mpa] + real(r8) :: scch_b2 ! constant coefficient of the quadratic term in the smoothing polynomial function [-] + real(r8) :: scch_b3 ! constant coefficient of the cubic term in the smoothing polynomial function [-] contains procedure :: th_from_psi => th_from_psi_smooth_cch procedure :: psi_from_th => psi_from_th_smooth_cch @@ -194,7 +197,10 @@ module FatesHydroWTFMod real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] real(r8) :: psi_sat ! Bubbling pressure (potential at saturation) [Mpa] real(r8) :: beta ! Clapp-Hornberger "beta" parameter [-] - real(r8) :: scch_pu, scch_ps, scch_b2, scch_b3 + real(r8) :: scch_pu ! An estimated breakpoint capillary pressure, below which the specified water retention curve is applied. It is also the lower limit when the smoothing function is applied. [Mpa] + real(r8) :: scch_ps ! An estimated breakpoint capillary pressure, an upper limit where smoothing funciton is applied. [Mpa] + real(r8) :: scch_b2 ! constant coefficient of the quadratic term in the smoothing polynomial function [-] + real(r8) :: scch_b3 ! constant coefficient of the cubic term in the smoothing polynomial function [-] contains procedure :: ftc_from_psi => ftc_from_psi_smooth_cch procedure :: dftcdpsi_from_psi => dftcdpsi_from_psi_smooth_cch @@ -700,7 +706,7 @@ subroutine set_wrf_param_cch(this,params_in) class(wrf_type_cch) :: this real(r8), intent(in) :: params_in(:) - real(r8) :: th_max + real(r8) :: th_max ! saturated water content this%th_sat = params_in(1) this%psi_sat = params_in(2) @@ -856,16 +862,16 @@ subroutine set_wrf_param_smooth_cch(this,params_in) class(wrf_type_smooth_cch) :: this real(r8), intent(in) :: params_in(:) - integer :: styp - real(r8) :: th_max + integer :: styp ! an option to force constant coefficient of the quadratic term 0 (styp = 1) or to force the constant coefficient of the cubic term 0 (styp/=2) + real(r8) :: th_max ! saturated water content [-] ! !LOCAL VARIABLES: - real(r8) :: pu - real(r8) :: bcAtPu - real(r8) :: lambdaDeltaPuOnPu - real(r8) :: oneOnDeltaPu - real(r8) :: lambda - real(r8) :: alpha - real(r8) :: ps + real(r8) :: pu ! an estimated breakpoint at which the constant coefficient of the quadratic term (styp=2) or the cubic term (styp/=2) is 0 [Mpa] + real(r8) :: bcAtPu ! working local + real(r8) :: lambdaDeltaPuOnPu !working local + real(r8) :: oneOnDeltaPu !working local + real(r8) :: lambda ! working local, inverse of Clapp and Hornberger "b" + real(r8) :: alpha ! working local + real(r8) :: ps ! working local, 90% of entry pressure [Mpa] @@ -935,14 +941,14 @@ subroutine set_wkf_param_smooth_cch(this,params_in) class(wkf_type_smooth_cch) :: this real(r8), intent(in) :: params_in(:) - integer :: styp - real(r8) :: pu - real(r8) :: bcAtPu - real(r8) :: lambdaDeltaPuOnPu - real(r8) :: oneOnDeltaPu - real(r8) :: lambda - real(r8) :: alpha - real(r8) :: ps + integer :: styp ! an option to force constant coefficient of the quadratic term 0 (styp = 1) or to force the constant coefficient of the cubic term 0 (styp/=2) + real(r8) :: pu ! an estimated breakpoint at which the constant coefficient of the quadratic term (styp=2) or the cubic term (styp/=2) is 0 [Mpa] + real(r8) :: bcAtPu !working local + real(r8) :: lambdaDeltaPuOnPu ! working local + real(r8) :: oneOnDeltaPu ! working local + real(r8) :: lambda ! working local + real(r8) :: alpha ! working local + real(r8) :: ps ! working local, 90% of entry pressure [Mpa] this%th_sat = params_in(1) this%psi_sat = params_in(2) From 5b25b2bb9d276e8eee19a46d30995d096dbadf3b Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 22 Jul 2021 15:21:53 -0700 Subject: [PATCH 365/578] fixing missing season_decid check in EDInitMod due to bad merge --- main/EDInitMod.F90 | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 6edce0b9be..a4c39ecdcb 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -783,8 +783,19 @@ subroutine init_cohorts( site_in, patch_in, bc_in) stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) - if(hlm_use_sp.eq.ifalse)then ! do not override SP vales with phenology + + if( prt_params%season_decid(pft) == itrue .and. & + any(site_in%cstatus == [phen_cstat_nevercold,phen_cstat_iscold])) then + temp_cohort%laimemory = c_leaf + temp_cohort%sapwmemory = c_sapw * stem_drop_fraction + temp_cohort%structmemory = c_struct * stem_drop_fraction + c_leaf = 0._r8 + c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw + c_struct = (1.0_r8-stem_drop_fraction) * c_struct + cstatus = leaves_off + endif + if ( prt_params%stress_decid(pft) == itrue .and. & any(site_in%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then temp_cohort%laimemory = c_leaf @@ -795,6 +806,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) c_struct = (1.0_r8-stem_drop_fraction) * c_struct cstatus = leaves_off endif + end if ! SP mode if ( debug ) write(fates_log(),*) 'EDInitMod.F90 call create_cohort ' From bd585257864eca3ecbb34dd70681c7bc0112b46a Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 3 Aug 2021 08:49:29 -0600 Subject: [PATCH 366/578] adding diagnostics --- biogeochem/EDCanopyStructureMod.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 6ee77f646f..aec5f8aaca 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -2012,11 +2012,16 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) + write(fates_log(),*) 's, ifp: ', s, ifp + write(fates_log(),*) 'EDCanopyStructure pre: bc_out(s)%tlai_pa(ifp): ', bc_out(s)%tlai_pa(ifp) + bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') + write(fates_log(),*) 'EDCanopyStructure post: bc_out(s)%tlai_pa(ifp): ', bc_out(s)%tlai_pa(ifp) + !if(debug) then ! write(fates_log(),*) 'ifp: ', ifp ! write(fates_log(),*) 'bc_out(s)%elai_pa(ifp): ', bc_out(s)%elai_pa(ifp) From 55e17e1f91a09017a7b30637a04ac11b3a2b8674 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 3 Aug 2021 11:33:55 -0600 Subject: [PATCH 367/578] adding tlai_profile output to diagnostics --- biogeochem/EDCanopyStructureMod.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index aec5f8aaca..b951990fa1 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1861,6 +1861,8 @@ subroutine leaf_area_profile( currentSite ) currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) / & currentPatch%canopy_area_profile(cl,ft,iv) + write(fates_log(), *) 'currentPatch%tlai_profile(cl,ft,iv): ', currentPatch%tlai_profile(cl,ft,iv) + write(fates_log(), *) 'currentPatch%canopy_area_profile(cl,ft,iv): ', currentPatch%canopy_area_profile(cl,ft,iv) currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) / & currentPatch%canopy_area_profile(cl,ft,iv) From eb9b850a7fff854ec14baf996ebb4a99db992d31 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 5 Aug 2021 10:29:34 -0600 Subject: [PATCH 368/578] fixing duplicates from poor merge --- biogeochem/EDPhysiologyMod.F90 | 26 -------------------------- 1 file changed, 26 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 6c088ef12a..888e490b4d 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1239,9 +1239,6 @@ subroutine phenology_leafonoff(currentSite) if(store_c>nearzero) then - store_c_transfer_frac = & - min(EDPftvarcon_inst%phenflush_fraction(ipft)*currentCohort%laimemory, store_c)/store_c - store_c_transfer_frac = & min((EDPftvarcon_inst%phenflush_fraction(ipft)*currentCohort%laimemory)/store_c, & (1.0_r8-carbon_store_buffer)) @@ -2479,29 +2476,6 @@ subroutine fragmentation_scaler( currentPatch, bc_in) ifp = currentPatch%patchno if(currentPatch%nocomp_pft_label.gt.0)then - 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. - 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) - else - t_scalar = (q10_mr**(-25._r8/10._r8))*(q10_froz**((bc_in%t_veg24_pa(ifp)-tfrz)/10._r8)) - !Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-tfrz)/10._r8) - endif - else - ! original century uses an arctangent function to calculate the - ! temperature dependence of decomposition - t_scalar = max(catanf(bc_in%t_veg24_pa(ifp)-tfrz)/catanf_30,0.01_r8) - endif - - !Moisture Limitations - !BTRAN APPROACH - is quite simple, but max's out decomp at all unstressed - !soil moisture values, which is not realistic. - !litter decomp is proportional to water limitation on average... - w_scalar = sum(currentPatch%btran_ft(1:numpft))/real(numpft,r8) - - currentPatch%fragmentation_scaler = min(1.0_r8,max(0.0_r8,t_scalar * w_scalar)) ! Use the hlm temp and moisture decomp fractions by default if ( use_hlm_soil_scalar ) then From f2c3156b7c7ccd1a80d8de95f93ccf816e41d4b8 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 5 Aug 2021 10:38:53 -0600 Subject: [PATCH 369/578] adding frag scaler diag --- biogeochem/EDPhysiologyMod.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 888e490b4d..a56d5a60ae 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -224,6 +224,7 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! Calculate the fragmentation rates call fragmentation_scaler(currentPatch, bc_in) + write(fates_log(),*) 'PreDistLittFlux: frag_scaler: ', currentPatch%fragmentation_scaler do el = 1, num_elements @@ -249,6 +250,7 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) nlev_eff_decomp = max(bc_in%max_rooting_depth_index_col, 1) call CWDOut(litt,currentPatch%fragmentation_scaler,nlev_eff_decomp) + write(fates_log(),*) 'PreDistLittFlux: sum ag_cwd_frag: ', sum(litt%ag_cwd_frag) site_mass => currentSite%mass_balance(el) From a0f66242d604b03909a7739118bb9ee07489e5b2 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 5 Aug 2021 11:56:05 -0600 Subject: [PATCH 370/578] Fixing no comp label check This needs to be not equal since when in any mode other than no comp or its derivatives, the label will be -999 --- biogeochem/EDPhysiologyMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index a56d5a60ae..924c4fbd55 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -2477,7 +2477,7 @@ subroutine fragmentation_scaler( currentPatch, bc_in) catanf_30 = catanf(30._r8) ifp = currentPatch%patchno - if(currentPatch%nocomp_pft_label.gt.0)then + if(currentPatch%nocomp_pft_label.ne.0)then ! Use the hlm temp and moisture decomp fractions by default if ( use_hlm_soil_scalar ) then From 9cc3e7c36af64ca10d5b0be85c199bf5b070951a Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 6 Aug 2021 10:30:05 -0600 Subject: [PATCH 371/578] fixedbiogeog passes bfb now --- main/EDInitMod.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index a4c39ecdcb..991281ec48 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -327,11 +327,11 @@ subroutine set_site_properties( nsites, sites,bc_in ) end do !hlm_pft do ft = 1,numpft - if(sites(s)%area_pft(ft).lt.0.01_r8.and.sites(s)%area_pft(ft).gt.0.0_r8)then - write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) - sites(s)%area_pft(ft)=0.0_r8 - ! remove tiny patches to prevent numerical errors in terminate patches - endif + ! if(sites(s)%area_pft(ft).lt.0.01_r8.and.sites(s)%area_pft(ft).gt.0.0_r8)then + ! write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) + ! sites(s)%area_pft(ft)=0.0_r8 + ! ! remove tiny patches to prevent numerical errors in terminate patches + ! endif if(sites(s)%area_pft(ft).lt.0._r8)then write(fates_log(),*) 'negative area',s,ft,sites(s)%area_pft(ft) call endrun(msg=errMsg(sourcefile, __LINE__)) From 58a427e704bcdd2ecaae890178c2eee0e6485339 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 9 Aug 2021 16:48:28 -0400 Subject: [PATCH 372/578] Updates to enable scalars in the BatchPatch script, also some tweaks to print statements and new file for parameters at barro colorado island panama. --- parameter_files/patch_default_bciopt224.xml | 52 +++++++++++++++++++++ tools/BatchPatchParams.py | 3 +- tools/modify_fates_paramfile.py | 8 +++- tools/ncvarsort.py | 6 ++- 4 files changed, 64 insertions(+), 5 deletions(-) create mode 100644 parameter_files/patch_default_bciopt224.xml diff --git a/parameter_files/patch_default_bciopt224.xml b/parameter_files/patch_default_bciopt224.xml new file mode 100644 index 0000000000..d8e3fe9631 --- /dev/null +++ b/parameter_files/patch_default_bciopt224.xml @@ -0,0 +1,52 @@ + + + This parameter dataset was created by Ryan Knox rgknox@lbl.gov. Please contact if using in published work. The calibration uses the following datasets: [1] Ely et al. 2019. Leaf mass area, Panama. NGEE-Tropics data collection.http://dx.doi.org/10.15486/ngt/1411973 and [2] Condit et al. 2019. Complete data from the Barro Colorado 50-ha plot. https://doi.org/10.15146/5xcp-0d46. The ECA nutrient aquisition parmeters are unconstrained, the file output naming convention vmn6phi is shorthand for vmax for nitrogen uptake is order e-6 and for phosphorus is excessively high. + fates_params_default.cdl + fates_params_opt224_vmn6phi_080621.cdl + 1 + + 0 + 0 + 1,1,3,4 + 0.03347526,0.024,1e-08,0.0047 + 0.03347526,0.024,1e-08,0.0047 + 0.025,0,0,0 + 0.45,0.25,0,0 + 0.8012471 + 30.94711 + 0.0673 + 0.976 + -9 + -9 + 3 + 0.1266844 + 1.281329 + -9 + 0.768654 + 0.768654 + 57.6 + 0.74 + 21.6 + 200 + 2 + 5 + 0.4863088 + 3 + 3e-06 + 3e-06 + 3e-07 + 3e-08 + 0.03991654 + 0.01995827 + 0.01303514 + 0.02955703 + 3 + 3 + 0.04680188 + 0.001 + 0.8374751 + -1 + 0.5 + 1 + + diff --git a/tools/BatchPatchParams.py b/tools/BatchPatchParams.py index 19587b426a..57edb7dfcb 100755 --- a/tools/BatchPatchParams.py +++ b/tools/BatchPatchParams.py @@ -50,7 +50,7 @@ def load_xml(xmlfile): def parse_syscall_str(fnamein,fnameout,param_name,param_val): sys_call_str = "../tools/modify_fates_paramfile.py"+" --fin " + fnamein + \ - " --fout " + fnameout + " --var " + param_name + \ + " --fout " + fnameout + " --var " + param_name + " --silent " +\ " --val " + param_val + " --overwrite --all" return(sys_call_str) @@ -73,7 +73,6 @@ def main(): # Convert the base cdl file into a temp nc binary base_nc = os.popen('mktemp').read().rstrip('\n') gencmd = "ncgen -o "+base_nc+" "+base_cdl - print(gencmd) os.system(gencmd) # Generate a temp output file name diff --git a/tools/modify_fates_paramfile.py b/tools/modify_fates_paramfile.py index 670ad96d8a..44565e48b3 100755 --- a/tools/modify_fates_paramfile.py +++ b/tools/modify_fates_paramfile.py @@ -62,7 +62,7 @@ def main(): # val_list = args.val.split(',') # output_vec = [float(valstr) for valstr in val_list] outputval = np.fromstring(args.val, sep=',', dtype=np.float64) - + else: try: @@ -117,6 +117,12 @@ def main(): elif(ndim_file==1): for i in range(var.shape[0]): var[i] = outputval[i] + elif(ndim_file==0): + var.assignValue(outputval[0]) + else: + print("Unhandled dimension size in modify_fates_paramfile.py") + print("using --all flag") + exit(2) else: diff --git a/tools/ncvarsort.py b/tools/ncvarsort.py index 75d80c3799..e9cdc422b4 100755 --- a/tools/ncvarsort.py +++ b/tools/ncvarsort.py @@ -83,7 +83,8 @@ def main(): # #Copy dimensions for dname, the_dim in dsin.dimensions.items(): - print(dname, the_dim.size) + if args.debug: + print(dname, the_dim.size) dsout.createDimension(dname, the_dim.size ) # print() @@ -100,7 +101,8 @@ def main(): v_name = varnames_list_sorted[i] varin = dsin.variables[v_name] outVar = dsout.createVariable(v_name, varin.datatype, varin.dimensions) - print(v_name) + if args.debug: + print(v_name) # outVar.setncatts({k: varin.getncattr(k) for k in varin.ncattrs()}) outVar[:] = varin[:] From a5c2d9d4e61d8470f3136d6b6be653c84f7d43a2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 9 Aug 2021 16:49:34 -0400 Subject: [PATCH 373/578] Update to the bci parameter patch file. --- parameter_files/patch_default_bciopt224.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parameter_files/patch_default_bciopt224.xml b/parameter_files/patch_default_bciopt224.xml index d8e3fe9631..b5e886c188 100644 --- a/parameter_files/patch_default_bciopt224.xml +++ b/parameter_files/patch_default_bciopt224.xml @@ -1,6 +1,6 @@ - This parameter dataset was created by Ryan Knox rgknox@lbl.gov. Please contact if using in published work. The calibration uses the following datasets: [1] Ely et al. 2019. Leaf mass area, Panama. NGEE-Tropics data collection.http://dx.doi.org/10.15486/ngt/1411973 and [2] Condit et al. 2019. Complete data from the Barro Colorado 50-ha plot. https://doi.org/10.15146/5xcp-0d46. The ECA nutrient aquisition parmeters are unconstrained, the file output naming convention vmn6phi is shorthand for vmax for nitrogen uptake is order e-6 and for phosphorus is excessively high. + This parameter dataset was created by Ryan Knox rgknox@lbl.gov. Please contact if using in published work. The calibration uses the following datasets: [1] Ely et al. 2019. Leaf mass area, Panama. NGEE-Tropics data collection.http://dx.doi.org/10.15486/ngt/1411973 and [2] Condit et al. 2019. Complete data from the Barro Colorado 50-ha plot. https://doi.org/10.15146/5xcp-0d46. The ECA nutrient aquisition parmeters are unconstrained, the file output naming convention vmn6phi is shorthand for vmax for nitrogen uptake is order e-6 and for phosphorus is excessively high. These parameters were calibrated with the special fates modification in main/EDTypesMod.F90: nclmax = 3 fates_params_default.cdl fates_params_opt224_vmn6phi_080621.cdl 1 From e065f7f8716a0a01dfcd3923fdd1d1c0059f80aa Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 9 Aug 2021 17:36:08 -0400 Subject: [PATCH 374/578] Updated notes on the bci patch xml file to include Koven et al. 2019 --- parameter_files/patch_default_bciopt224.xml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parameter_files/patch_default_bciopt224.xml b/parameter_files/patch_default_bciopt224.xml index b5e886c188..bfcc288efa 100644 --- a/parameter_files/patch_default_bciopt224.xml +++ b/parameter_files/patch_default_bciopt224.xml @@ -1,6 +1,6 @@ - This parameter dataset was created by Ryan Knox rgknox@lbl.gov. Please contact if using in published work. The calibration uses the following datasets: [1] Ely et al. 2019. Leaf mass area, Panama. NGEE-Tropics data collection.http://dx.doi.org/10.15486/ngt/1411973 and [2] Condit et al. 2019. Complete data from the Barro Colorado 50-ha plot. https://doi.org/10.15146/5xcp-0d46. The ECA nutrient aquisition parmeters are unconstrained, the file output naming convention vmn6phi is shorthand for vmax for nitrogen uptake is order e-6 and for phosphorus is excessively high. These parameters were calibrated with the special fates modification in main/EDTypesMod.F90: nclmax = 3 + This parameter dataset was created by Ryan Knox rgknox@lbl.gov. Please contact if using in published work. The calibration uses the following datasets: [1] Ely et al. 2019. Leaf mass area, Panama. NGEE-Tropics data collection.http://dx.doi.org/10.15486/ngt/1411973 and [2] Condit et al. 2019. Complete data from the Barro Colorado 50-ha plot. https://doi.org/10.15146/5xcp-0d46. [3] Koven et al. 2019. Benchmarking and parameter sensitivity of physiological and vegetation dynamics using the functionally assembled terrestrial ecosystem simulator. Biogeosciences. The ECA nutrient aquisition parmeters are unconstrained, the file output naming convention vmn6phi is shorthand for vmax for nitrogen uptake is order e-6 and for phosphorus is excessively high. These parameters were calibrated with the special fates modification in main/EDTypesMod.F90: nclmax = 3 fates_params_default.cdl fates_params_opt224_vmn6phi_080621.cdl 1 From 9e646dcbad9d82c499a59b1160972e96d750c43a Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 12 Aug 2021 14:47:40 -0700 Subject: [PATCH 375/578] manually reverting diagnostic writes --- biogeochem/EDCanopyStructureMod.F90 | 417 +++++++++++------------ biogeochem/EDPhysiologyMod.F90 | 508 ++++++++++++++-------------- 2 files changed, 447 insertions(+), 478 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index b951990fa1..6d3b6f723b 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1,8 +1,8 @@ module EDCanopyStructureMod ! ===================================================================================== - ! Code to determine whether the canopy is closed, and which plants are either in the - ! understorey or overstorey. This is obviosuly far too complicated for it's own good + ! Code to determine whether the canopy is closed, and which plants are either in the + ! understorey or overstorey. This is obviosuly far too complicated for it's own good ! ===================================================================================== use FatesConstantsMod , only : r8 => fates_r8 @@ -57,7 +57,7 @@ module EDCanopyStructureMod public :: update_hlm_dynamics public :: UpdateFatesAvgSnowDepth - logical, parameter :: debug=.true. + logical, parameter :: debug=.false. character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -66,7 +66,7 @@ module EDCanopyStructureMod ! will attempt to reduce errors ! below this level - real(r8), parameter :: area_check_precision = 1.0E-7_r8 ! Area conservation checks must + real(r8), parameter :: area_check_precision = 1.0E-7_r8 ! Area conservation checks must ! be within this absolute tolerance real(r8), parameter :: area_check_rel_precision = 1.0E-4_r8 ! Area conservation checks must ! be within this relative tolerance @@ -91,42 +91,42 @@ subroutine canopy_structure( currentSite , bc_in ) ! All top leaves in the same canopy layer get the same light resources. ! The first canopy layer is the 'canopy' or 'overstorey'. The second is the 'understorey'. ! More than two layers is not permitted at the moment - ! Seeds germinating into the 3rd or higher layers are automatically removed. + ! Seeds germinating into the 3rd or higher layers are automatically removed. ! ! ------Perfect Plasticity----- ! The idea of these canopy layers derives originally from Purves et al. 2009 ! Their concept is that, given enoughplasticity in canopy position, size, shape and depth ! all of the gound area will be filled perfectly by leaves, and additional leaves will have - ! to exist in the understorey. + ! to exist in the understorey. ! Purves et al. use the concept of 'Z*' to assume that the height required to attain a place in the ! canopy is spatially uniform. In this implementation, described in Fisher et al. (2010, New Phyt) we ! extent that concept to assume that position in the canopy has some random element, and that BOTH height - ! and chance combine to determine whether trees get into the canopy. + ! and chance combine to determine whether trees get into the canopy. ! Thus, when the canopy is closed and there is excess area, some of it must be demoted - ! If we demote -all- the trees less than a given height, there is a massive advantage in being the cohort that is - ! the biggest when the canopy is closed. + ! If we demote -all- the trees less than a given height, there is a massive advantage in being the cohort that is + ! the biggest when the canopy is closed. ! In this implementation, the amount demoted, ('weight') is a function of the height weighted by the competitive exclusion - ! parameter (ED_val_comp_excln). + ! parameter (ED_val_comp_excln). - ! Complexity in this routine results from a few things. + ! Complexity in this routine results from a few things. ! Firstly, the complication of the demotion amount sometimes being larger than the cohort area (for a very small, short cohort) - ! Second, occasionaly, disturbance (specifically fire) can cause the canopy layer to become less than closed, - ! without changing the area of the patch. If this happens, then some of the plants in the lower layer need to be 'promoted' so - ! all of the routine has to happen in both the downwards and upwards directions. + ! Second, occasionaly, disturbance (specifically fire) can cause the canopy layer to become less than closed, + ! without changing the area of the patch. If this happens, then some of the plants in the lower layer need to be 'promoted' so + ! all of the routine has to happen in both the downwards and upwards directions. ! ! The order of events here is therefore: - ! (The entire subroutine has a single outer 'patch' loop. - ! Section 1: figure out the total area, and whether there are >1 canopy layers at all. + ! (The entire subroutine has a single outer 'patch' loop. + ! Section 1: figure out the total area, and whether there are >1 canopy layers at all. ! - ! Sorts out cohorts into canopy and understorey layers... + ! Sorts out cohorts into canopy and understorey layers... ! ! !USES: use EDParamsMod, only : ED_val_comp_excln use EDTypesMod , only : min_patch_area - + ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type) , intent(inout), target :: currentSite type(bc_in_type), intent(in) :: bc_in @@ -135,7 +135,7 @@ subroutine canopy_structure( currentSite , bc_in ) type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort integer :: i_lyr ! current layer index - integer :: z ! Current number of canopy layers. (1= canopy, 2 = understorey) + integer :: z ! Current number of canopy layers. (1= canopy, 2 = understorey) integer :: ipft real(r8) :: arealayer(nclmax+2) ! Amount of plant area currently in each canopy layer integer :: patch_area_counter ! count iterations used to solve canopy areas @@ -152,8 +152,8 @@ subroutine canopy_structure( currentSite , bc_in ) !---------------------------------------------------------------------- - currentPatch => currentSite%oldest_patch - ! + currentPatch => currentSite%oldest_patch + ! ! zero site-level demotion / promotion tracking info currentSite%demotion_rate(:) = 0._r8 currentSite%promotion_rate(:) = 0._r8 @@ -162,9 +162,9 @@ subroutine canopy_structure( currentSite , bc_in ) ! - ! Section 1: Check total canopy area. + ! Section 1: Check total canopy area. ! - do while (associated(currentPatch)) ! Patch loop + do while (associated(currentPatch)) ! Patch loop ! ------------------------------------------------------------------------------ ! Perform numerical checks on some cohort and patch structures @@ -173,7 +173,7 @@ subroutine canopy_structure( currentSite , bc_in ) ! canopy layer has a special bounds check currentCohort => currentPatch%tallest do while (associated(currentCohort)) - if( currentCohort%canopy_layer < 1 .or. currentCohort%canopy_layer > nclmax+1 ) then + if( currentCohort%canopy_layer < 1 .or. currentCohort%canopy_layer > nclmax+1 ) then write(fates_log(),*) 'lat:',currentSite%lat write(fates_log(),*) 'lon:',currentSite%lon write(fates_log(),*) 'BOGUS CANOPY LAYER: ',currentCohort%canopy_layer @@ -199,11 +199,11 @@ subroutine canopy_structure( currentSite , bc_in ) call terminate_cohorts(currentSite, currentPatch, 1, 12, bc_in) ! Calculate how many layers we have in this canopy - ! This also checks the understory to see if its crown + ! This also checks the understory to see if its crown ! area is large enough to warrant a temporary sub-understory layer z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) - do i_lyr = 1,z ! Loop around the currently occupied canopy layers. + do i_lyr = 1,z ! Loop around the currently occupied canopy layers. call DemoteFromLayer(currentSite, currentPatch, i_lyr, bc_in) end do @@ -228,7 +228,7 @@ subroutine canopy_structure( currentSite , bc_in ) ! We only promote if we have at least two layers if (z>1) then - do i_lyr=1,z-1 + do i_lyr=1,z-1 call PromoteIntoLayer(currentSite, currentPatch, i_lyr) end do @@ -275,7 +275,7 @@ subroutine canopy_structure( currentSite , bc_in ) write(fates_log(),*) 'lon:',currentSite%lon write(fates_log(),*) 'spread:',currentSite%spread currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) write(fates_log(),*) 'coh ilayer:',currentCohort%canopy_layer write(fates_log(),*) 'coh dbh:',currentCohort%dbh write(fates_log(),*) 'coh pft:',currentCohort%pft @@ -296,13 +296,13 @@ subroutine canopy_structure( currentSite , bc_in ) enddo ! do while(area_not_balanced) - ! Set current canopy layer occupancy indicator. - currentPatch%NCL_p = min(nclmax,z) + ! Set current canopy layer occupancy indicator. + currentPatch%NCL_p = min(nclmax,z) ! ------------------------------------------------------------------------------------------- - ! if we are using "strict PPA", then calculate a z_star value as - ! the height of the smallest tree in the canopy - ! loop from top to bottom and locate the shortest cohort in level 1 whose shorter + ! if we are using "strict PPA", then calculate a z_star value as + ! the height of the smallest tree in the canopy + ! loop from top to bottom and locate the shortest cohort in level 1 whose shorter ! neighbor is in level 2 set zstar as the ehight of that shortest level 1 cohort ! ------------------------------------------------------------------------------------------- @@ -373,8 +373,8 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) if ( demote_area > area_target_precision ) then - ! Is this layer currently over-occupied? - ! In that case, we need to work out which cohorts to demote. + ! Is this layer currently over-occupied? + ! In that case, we need to work out which cohorts to demote. ! We go in order from shortest to tallest for ranked demotion sumweights = 0.0_r8 @@ -412,7 +412,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) ! Rank ordered deterministic method ! ----------------------------------------------------------- ! If there are cohorts that have the exact same height (which is possible, really) - ! we don't want to unilaterally promote/demote one before the others. + ! we don't want to unilaterally promote/demote one before the others. ! So we <>mote them as a unit ! now we need to go through and figure out how many equal-size cohorts there are. ! then we need to go through, add up the collective crown areas of all equal-sized @@ -449,7 +449,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) do while (associated(nextc)) if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - ! now we know the total crown area of all equal-sized, + ! now we know the total crown area of all equal-sized, ! equal-canopy-layer cohorts nextc%excl_weight = & max(0.0_r8,min(nextc%c_area, & @@ -475,7 +475,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) else currentCohort%excl_weight = & max(min(currentCohort%c_area, demote_area - sumweights ), 0._r8) - sumweights = sumweights + currentCohort%excl_weight + sumweights = sumweights + currentCohort%excl_weight end if endif @@ -496,7 +496,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) currentCohort => currentPatch%tallest do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then + if(currentCohort%canopy_layer == i_lyr) then currentCohort%excl_weight = currentCohort%excl_weight/sumweights if( 1._r8/currentCohort%excl_weight < scale_factor_min ) & @@ -505,7 +505,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) scale_factor = scale_factor + currentCohort%excl_weight * currentCohort%c_area endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo ! This is the factor by which we need to multiply @@ -520,7 +520,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) currentCohort => currentPatch%tallest do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then + if(currentCohort%canopy_layer == i_lyr) then currentCohort%excl_weight = currentCohort%c_area * currentCohort%excl_weight * scale_factor if(debug) then @@ -539,7 +539,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) end if endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo else @@ -551,8 +551,8 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) area_res = 0._r8 scale_factor_res = 0._r8 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then area_res = area_res + & currentCohort%c_area * currentCohort%excl_weight * & scale_factor_min @@ -560,7 +560,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) currentCohort%c_area * & (1._r8 - (currentCohort%excl_weight * scale_factor_min)) endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo area_res = demote_area - area_res @@ -568,8 +568,8 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) scale_factor_res = area_res / scale_factor_res currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then currentCohort%excl_weight = currentCohort%c_area * & (currentCohort%excl_weight * scale_factor_min + & @@ -590,7 +590,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) end if endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo end if @@ -601,7 +601,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) ! perform a check and see if the demotions meet the demand sumweights = 0._r8 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) if(currentCohort%canopy_layer == i_lyr) then sumweights = sumweights + currentCohort%excl_weight end if @@ -672,13 +672,13 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) call copy_cohort(currentCohort, copyc) newarea = currentCohort%c_area - cc_loss - copyc%n = currentCohort%n*newarea/currentCohort%c_area + copyc%n = currentCohort%n*newarea/currentCohort%c_area currentCohort%n = currentCohort%n - copyc%n copyc%canopy_layer = i_lyr !the taller cohort is the copy ! Demote the current cohort to the understory. - currentCohort%canopy_layer = i_lyr + 1 + currentCohort%canopy_layer = i_lyr + 1 ! keep track of number and biomass of demoted cohort currentSite%demotion_rate(currentCohort%size_class) = & @@ -690,7 +690,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) - !----------- Insert copy into linked list ------------------------! + !----------- Insert copy into linked list ------------------------! copyc%shorter => currentCohort if(associated(currentCohort%taller))then copyc%taller => currentCohort%taller @@ -713,9 +713,9 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) ! kill the ones which go into canopy layers that are not allowed - if(currentCohort%canopy_layer>nclmax )then + if(currentCohort%canopy_layer>nclmax )then - ! put the litter from the terminated cohorts + ! put the litter from the terminated cohorts ! straight into the fragmenting pools call SendCohortToLitter(currentSite,currentPatch, & currentCohort,currentCohort%n,bc_in) @@ -732,7 +732,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) endif !canopy layer = i_ly currentCohort => currentCohort%shorter - enddo !currentCohort + enddo !currentCohort ! Update the area calculations of the current layer @@ -766,7 +766,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! ------------------------------------------------------------------------------------------- ! Check whether the intended 'full' layers are actually filling all the space. ! If not, promote some fraction of cohorts upwards. - ! THIS SECTION MIGHT BE TRIGGERED BY A FIRE OR MORTALITY EVENT, FOLLOWED BY A PATCH FUSION, + ! THIS SECTION MIGHT BE TRIGGERED BY A FIRE OR MORTALITY EVENT, FOLLOWED BY A PATCH FUSION, ! SO THE TOP LAYER IS NO LONGER FULL. ! ------------------------------------------------------------------------------------------- @@ -809,7 +809,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! how much do we need to gain? - promote_area = currentPatch%area - arealayer_current + promote_area = currentPatch%area - arealayer_current if( promote_area > area_target_precision ) then @@ -820,10 +820,10 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! than the tolerance on the gains needed into current layer ! --------------------------------------------------------------------------- - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - !look at the cohorts in the canopy layer below... - if(currentCohort%canopy_layer == i_lyr+1)then + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + !look at the cohorts in the canopy layer below... + if(currentCohort%canopy_layer == i_lyr+1)then leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) @@ -831,7 +831,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) - currentCohort%canopy_layer = i_lyr + currentCohort%canopy_layer = i_lyr call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) ! keep track of number and biomass of promoted cohort @@ -841,7 +841,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo else @@ -853,14 +853,14 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! figure out with what weighting we need to promote cohorts. - ! This is the opposite of the demotion weighting... + ! This is the opposite of the demotion weighting... sumweights = 0.0_r8 - currentCohort => currentPatch%tallest + currentCohort => currentPatch%tallest do while (associated(currentCohort)) call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) - if(currentCohort%canopy_layer == i_lyr+1)then !look at the cohorts in the canopy layer below... + if(currentCohort%canopy_layer == i_lyr+1)then !look at the cohorts in the canopy layer below... if (ED_val_comp_excln .ge. 0.0_r8 ) then @@ -875,7 +875,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! ------------------------------------------------------------------ ! Rank ordered deterministic method ! If there are cohorts that have the exact same height (which is possible, really) - ! we don't want to unilaterally promote/demote one before the others. + ! we don't want to unilaterally promote/demote one before the others. ! So we <>mote them as a unit ! now we need to go through and figure out how many equal-size cohorts there are. ! then we need to go through, add up the collective crown areas of all equal-sized @@ -911,7 +911,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) do while (associated(nextc)) if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - ! now we know the total crown area of all equal-sized, + ! now we know the total crown area of all equal-sized, ! equal-canopy-layer cohorts nextc%prom_weight = & max(0.0_r8,min(nextc%c_area, & @@ -937,13 +937,13 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) else currentCohort%prom_weight = & max(min(currentCohort%c_area, promote_area - sumweights ), 0._r8) - sumweights = sumweights + currentCohort%prom_weight + sumweights = sumweights + currentCohort%prom_weight end if endif endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo !currentCohort @@ -959,7 +959,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) currentCohort => currentPatch%tallest do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1) ) then + if(currentCohort%canopy_layer == (i_lyr+1) ) then currentCohort%prom_weight = currentCohort%prom_weight/sumweights if( 1._r8/currentCohort%prom_weight < scale_factor_min ) & @@ -968,7 +968,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) scale_factor = scale_factor + currentCohort%prom_weight * currentCohort%c_area endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo ! This is the factor by which we need to multiply @@ -984,7 +984,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) currentCohort => currentPatch%tallest do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1) ) then + if(currentCohort%canopy_layer == (i_lyr+1) ) then currentCohort%prom_weight = currentCohort%c_area * & currentCohort%prom_weight * scale_factor @@ -1003,7 +1003,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) end if endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo else @@ -1014,15 +1014,15 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) area_res = 0._r8 scale_factor_res = 0._r8 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1) ) then + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1) ) then area_res = area_res + & currentCohort%c_area*currentCohort%prom_weight*scale_factor_min scale_factor_res = scale_factor_res + & currentCohort%c_area * & (1._r8 - (currentCohort%prom_weight * scale_factor_min)) endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo area_res = promote_area - area_res @@ -1030,8 +1030,8 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) scale_factor_res = area_res / scale_factor_res currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1)) then + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1)) then currentCohort%prom_weight = currentCohort%c_area * & (currentCohort%prom_weight * scale_factor_min + & @@ -1053,7 +1053,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) end if endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo end if @@ -1064,7 +1064,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! lets perform a check and see if the promotions meet the demand sumweights = 0._r8 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) if(currentCohort%canopy_layer == (i_lyr+1)) then sumweights = sumweights + currentCohort%prom_weight end if @@ -1082,10 +1082,10 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) end if currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) - !All the trees in this layer need to promote some area upwards... + !All the trees in this layer need to promote some area upwards... if( (currentCohort%canopy_layer == i_lyr+1) ) then cc_gain = currentCohort%prom_weight @@ -1128,14 +1128,14 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) - ! number of individuals in promoted cohort. - copyc%n = currentCohort%n*cc_gain/currentCohort%c_area + ! number of individuals in promoted cohort. + copyc%n = currentCohort%n*cc_gain/currentCohort%c_area - ! number of individuals in cohort remaining in understorey + ! number of individuals in cohort remaining in understorey currentCohort%n = currentCohort%n - copyc%n - currentCohort%canopy_layer = i_lyr + 1 ! keep current cohort in the understory. - copyc%canopy_layer = i_lyr ! promote copy to the higher canopy layer. + currentCohort%canopy_layer = i_lyr + 1 ! keep current cohort in the understory. + copyc%canopy_layer = i_lyr ! promote copy to the higher canopy layer. ! keep track of number and biomass of promoted cohort currentSite%promotion_rate(copyc%size_class) = & @@ -1148,7 +1148,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) currentCohort%pft,currentCohort%c_area) call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) - !----------- Insert copy into linked list ------------------------! + !----------- Insert copy into linked list ------------------------! copyc%shorter => currentCohort if(associated(currentCohort%taller))then copyc%taller => currentCohort%taller @@ -1157,7 +1157,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) currentPatch%tallest => copyc copyc%taller => null() endif - currentCohort%taller => copyc + currentCohort%taller => copyc elseif(cc_gain > currentCohort%c_area)then @@ -1170,7 +1170,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) endif ! if(currentCohort%canopy_layer == i_lyr+1) then currentCohort => currentCohort%shorter - enddo !currentCohort + enddo !currentCohort call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) @@ -1195,20 +1195,20 @@ end subroutine PromoteIntoLayer subroutine canopy_spread( currentSite ) ! ! !DESCRIPTION: - ! Calculates the spatial spread of tree canopies based on canopy closure. + ! Calculates the spatial spread of tree canopies based on canopy closure. ! ! !USES: use EDTypesMod , only : AREA - use EDParamsMod, only : ED_val_canopy_closure_thresh + use EDParamsMod, only : ED_val_canopy_closure_thresh ! - ! !ARGUMENTS + ! !ARGUMENTS type (ed_site_type), intent(inout), target :: currentSite ! ! !LOCAL VARIABLES: type (ed_cohort_type), pointer :: currentCohort type (ed_patch_type) , pointer :: currentPatch real(r8) :: sitelevel_canopyarea ! Amount of canopy in top layer at the site level - real(r8) :: inc ! Arbitrary daily incremental change in canopy area + real(r8) :: inc ! Arbitrary daily incremental change in canopy area integer :: z !---------------------------------------------------------------------- @@ -1216,7 +1216,7 @@ subroutine canopy_spread( currentSite ) currentPatch => currentSite%oldest_patch - sitelevel_canopyarea = 0.0_r8 + sitelevel_canopyarea = 0.0_r8 do while (associated(currentPatch)) !calculate canopy area in each patch... @@ -1239,8 +1239,8 @@ subroutine canopy_spread( currentSite ) ! squash the tree canopies and make them taller and thinner if( sitelevel_canopyarea/AREA .gt. ED_val_canopy_closure_thresh ) then currentSite%spread = currentSite%spread - inc - else - currentSite%spread = currentSite%spread + inc + else + currentSite%spread = currentSite%spread + inc endif ! put within bounds to make sure it stays between 0 and 1 @@ -1264,7 +1264,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) use EDtypesMod , only : area use FatesConstantsMod , only : itrue - ! !ARGUMENTS + ! !ARGUMENTS integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) type(bc_in_type) , intent(in) :: bc_in(nsites) @@ -1275,8 +1275,8 @@ subroutine canopy_summarization( nsites, sites, bc_in ) integer :: s integer :: ft ! plant functional type integer :: ifp ! the number of the vegetated patch (1,2,3). In SP mode bareground patch is 0 - integer :: patchn ! identification number for each patch. - real(r8) :: canopy_leaf_area ! total amount of leaf area in the vegetated area. m2. + integer :: patchn ! identification number for each patch. + real(r8) :: canopy_leaf_area ! total amount of leaf area in the vegetated area. m2. real(r8) :: leaf_c ! leaf carbon [kg] real(r8) :: fnrt_c ! fineroot carbon [kg] real(r8) :: sapw_c ! sapwood carbon [kg] @@ -1292,8 +1292,8 @@ subroutine canopy_summarization( nsites, sites, bc_in ) do s = 1,nsites ! -------------------------------------------------------------------------------- - ! Set the patch indices (this is usefull mostly for communicating with a host or - ! driving model. Loops through all patches and sets cpatch%patchno to the integer + ! Set the patch indices (this is usefull mostly for communicating with a host or + ! driving model. Loops through all patches and sets cpatch%patchno to the integer ! order of oldest to youngest where the oldest is 1. ! -------------------------------------------------------------------------------- call set_patchno( sites(s) ) @@ -1302,12 +1302,12 @@ subroutine canopy_summarization( nsites, sites, bc_in ) do while(associated(currentPatch)) - !zero cohort-summed variables. + !zero cohort-summed variables. currentPatch%total_canopy_area = 0.0_r8 currentPatch%total_tree_area = 0.0_r8 canopy_leaf_area = 0.0_r8 - !update cohort quantitie s + !update cohort quantitie s currentCohort => currentPatch%shortest do while(associated(currentCohort)) @@ -1347,7 +1347,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) endif endif - ! adding checks for SP and NOCOMP modes. + ! adding checks for SP and NOCOMP modes. if(currentPatch%nocomp_pft_label.eq.0)then write(fates_log(),*) 'cohorts in barepatch',currentPatch%total_canopy_area,currentPatch%nocomp_pft_label call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1367,7 +1367,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) end if end if !sp mode - ! Check for erroneous zero values. + ! Check for erroneous zero values. if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then write(fates_log(),*) 'FATES: dbh or n is zero in canopy_summarization', & currentCohort%dbh,currentCohort%n @@ -1403,7 +1403,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentPatch => currentPatch%younger end do !patch loop - call leaf_area_profile(sites(s)) + call leaf_area_profile(sites(s)) end do ! site loop @@ -1413,34 +1413,34 @@ end subroutine canopy_summarization ! ==================================================================================== subroutine UpdateFatesAvgSnowDepth(sites,bc_in) - + ! This routine updates the snow depth used in FATES to occlude vegetation ! Currently this average takes into account the depth of snow and the ! areal coverage fraction - + type(ed_site_type) , intent(inout), target :: sites(:) type(bc_in_type) , intent(in) :: bc_in(:) - + integer :: s - + do s = 1, size(sites,dim=1) sites(s)%snow_depth = bc_in(s)%snow_depth_si * bc_in(s)%frac_sno_eff_si end do - + return end subroutine UpdateFatesAvgSnowDepth - - + + ! ===================================================================================== subroutine leaf_area_profile( currentSite ) ! ----------------------------------------------------------------------------------- - ! This subroutine calculates how leaf and stem areas are distributed + ! This subroutine calculates how leaf and stem areas are distributed ! in vertical and horizontal space. ! ! The following cohort level diagnostics are updated here: - ! + ! ! currentCohort%treelai ! LAI per unit crown area (m2/m2) ! currentCohort%treesai ! SAI per unit crown area (m2/m2) ! currentCohort%lai ! LAI per unit canopy area (m2/m2) @@ -1449,10 +1449,10 @@ subroutine leaf_area_profile( currentSite ) ! ! layers needed to describe this crown ! ! The following patch level diagnostics are updated here: - ! + ! ! currentPatch%canopy_layer_tlai(cl) ! total leaf area index of canopy layer ! currentPatch%ncan(cl,ft) ! number of vegetation layers needed - ! ! in this patch's pft/canopy-layer + ! ! in this patch's pft/canopy-layer ! currentPatch%nrad(cl,ft) ! same as ncan, but does not include ! ! layers occluded by snow ! ! CURRENTLY SAME AS NCAN @@ -1462,7 +1462,7 @@ subroutine leaf_area_profile( currentSite ) ! currentPatch%elai_profile(cl,ft,iv) ! non-snow covered m2 of leaves per m2 of PFT footprint ! currentPatch%tsai_profile(cl,ft,iv) ! m2 of stems per m2 of PFT footprint ! currentPatch%esai_profile(cl,ft,iv) ! non-snow covered m2 of stems per m2 of PFT footprint - ! currentPatch%canopy_area_profile(cl,ft,iv) ! Fractional area of leaf layer + ! currentPatch%canopy_area_profile(cl,ft,iv) ! Fractional area of leaf layer ! ! relative to vegetated area ! currentPatch%layer_height_profile(cl,ft,iv) ! Elevation of layer in m ! @@ -1473,7 +1473,7 @@ subroutine leaf_area_profile( currentSite ) use EDtypesMod , only : area, dinc_ed, hitemax, n_hite_bins ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type) , intent(inout) :: currentSite @@ -1481,10 +1481,10 @@ subroutine leaf_area_profile( currentSite ) ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort - real(r8) :: remainder !Thickness of layer at bottom of canopy. - real(r8) :: fleaf ! fraction of cohort incepting area that is leaves. - integer :: ft ! Plant functional type index. - integer :: iv ! Vertical leaf layer index + real(r8) :: remainder !Thickness of layer at bottom of canopy. + real(r8) :: fleaf ! fraction of cohort incepting area that is leaves. + integer :: ft ! Plant functional type index. + integer :: iv ! Vertical leaf layer index integer :: cl ! Canopy layer index real(r8) :: fraction_exposed ! how much of this layer is not covered by snow? real(r8) :: layer_top_hite ! notional top height of this canopy layer (m) @@ -1499,7 +1499,6 @@ subroutine leaf_area_profile( currentSite ) real(r8) :: max_chite ! top of cohort canopy (m) real(r8) :: lai ! summed lai for checking m2 m-2 real(r8) :: leaf_c ! leaf carbon [kg] - real(r8) :: saicheck ! diagnostic check for Satellite phenology mode !---------------------------------------------------------------------- @@ -1509,27 +1508,27 @@ subroutine leaf_area_profile( currentSite ) ! Here we are trying to generate a profile of leaf area, indexed by 'z' and by pft ! We assume that each point in the canopy recieved the light attenuated by the average - ! leaf area index above it, irrespective of PFT identity... + ! leaf area index above it, irrespective of PFT identity... ! Each leaf is defined by how deep in the canopy it is, in terms of LAI units. (FIX(RF,032414), GB) - currentPatch => currentSite%oldest_patch + currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) ! -------------------------------------------------------------------------------- - ! Calculate tree and canopy areas. + ! Calculate tree and canopy areas. ! calculate tree lai and sai. ! -------------------------------------------------------------------------------- currentPatch%canopy_layer_tlai(:) = 0._r8 - currentPatch%ncan(:,:) = 0 - currentPatch%nrad(:,:) = 0 + currentPatch%ncan(:,:) = 0 + currentPatch%nrad(:,:) = 0 patch_lai = 0._r8 currentPatch%tlai_profile(:,:,:) = 0._r8 - currentPatch%tsai_profile(:,:,:) = 0._r8 + currentPatch%tsai_profile(:,:,:) = 0._r8 currentPatch%elai_profile(:,:,:) = 0._r8 - currentPatch%esai_profile(:,:,:) = 0._r8 + currentPatch%esai_profile(:,:,:) = 0._r8 currentPatch%layer_height_profile(:,:,:) = 0._r8 - currentPatch%canopy_area_profile(:,:,:) = 0._r8 + currentPatch%canopy_area_profile(:,:,:) = 0._r8 currentPatch%canopy_mask(:,:) = 0 ! ------------------------------------------------------------------------------ @@ -1541,7 +1540,7 @@ subroutine leaf_area_profile( currentSite ) currentCohort => currentPatch%tallest - do while(associated(currentCohort)) + do while(associated(currentCohort)) ft = currentCohort%pft cl = currentCohort%canopy_layer @@ -1554,34 +1553,20 @@ subroutine leaf_area_profile( currentSite ) currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) if (hlm_use_sp .eq. ifalse) then currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & currentPatch%canopy_layer_tlai, currentCohort%treelai , & - currentCohort%vcmax25top,4) - else - ! If we are using satellite phenology, conduct a check against the calculated sai - saicheck = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & - currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai, currentCohort%treelai , & - currentCohort%vcmax25top,4) - - if ( debug ) write(fates_log(), *) 'SP mode: sai check: ', saicheck - + currentCohort%vcmax25top,4) end if - if ( debug ) write(fates_log(), *) 'currentCohort%canopy_layer: ', cl - if ( debug ) write(fates_log(), *) 'currentCohort%pft: ', ft - if ( debug ) write(fates_log(), *) 'currentCohort%treesai: ', currentCohort%treesai - if ( debug ) write(fates_log(), *) 'currentCohort%treelai: ', currentCohort%treelai - - currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area - currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area + currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area + currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area ! Number of actual vegetation layers in this cohort's crown - currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) + currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) currentPatch%ncan(cl,ft) = max(currentPatch%ncan(cl,ft),currentCohort%NV) @@ -1589,47 +1574,47 @@ subroutine leaf_area_profile( currentSite ) currentPatch%canopy_layer_tlai(cl) = currentPatch%canopy_layer_tlai(cl) + currentCohort%lai - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo !currentCohort if(smooth_leaf_distribution == 1)then ! ----------------------------------------------------------------------------- - ! we are going to ignore the concept of canopy layers, and put all of the leaf - ! area into height banded bins. using the same domains as we had before, except + ! we are going to ignore the concept of canopy layers, and put all of the leaf + ! area into height banded bins. using the same domains as we had before, except ! that CL always = 1 ! ----------------------------------------------------------------------------- - ! this is a crude way of dividing up the bins. Should it be a function of actual maximum height? - dh = 1.0_r8*(HITEMAX/N_HITE_BINS) - do iv = 1,N_HITE_BINS + ! this is a crude way of dividing up the bins. Should it be a function of actual maximum height? + dh = 1.0_r8*(HITEMAX/N_HITE_BINS) + do iv = 1,N_HITE_BINS if (iv == 1) then minh(iv) = 0.0_r8 maxh(iv) = dh - else + else minh(iv) = (iv-1)*dh maxh(iv) = (iv)*dh endif enddo currentCohort => currentPatch%shortest - do while(associated(currentCohort)) + do while(associated(currentCohort)) ft = currentCohort%pft min_chite = currentCohort%hite - currentCohort%hite * EDPftvarcon_inst%crown(ft) - max_chite = currentCohort%hite - do iv = 1,N_HITE_BINS + max_chite = currentCohort%hite + do iv = 1,N_HITE_BINS frac_canopy(iv) = 0.0_r8 ! this layer is in the middle of the canopy - if(max_chite > maxh(iv).and.min_chite < minh(iv))then + if(max_chite > maxh(iv).and.min_chite < minh(iv))then frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*EDPftvarcon_inst%crown(ft))) - ! this is the layer with the bottom of the canopy in it. - elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then + ! this is the layer with the bottom of the canopy in it. + elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) - ! this is the layer with the top of the canopy in it. - elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then + ! this is the layer with the top of the canopy in it. + elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) - elseif(max_chite < maxh(iv).and.min_chite > minh(iv))then !the whole cohort is within this layer. + elseif(max_chite < maxh(iv).and.min_chite > minh(iv))then !the whole cohort is within this layer. frac_canopy(iv) = 1.0_r8 endif @@ -1638,33 +1623,26 @@ subroutine leaf_area_profile( currentSite ) currentCohort%lai currentPatch%tsai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) + frac_canopy(iv) * & currentCohort%sai - if ( debug ) write(fates_log(), *) 'currentCohort%pft,iv: ', ft,iv - if ( debug ) write(fates_log(), *) 'currentPatch%tlai_profile(1,ft,iv): ', currentPatch%tlai_profile(1,ft,iv) - if ( debug ) write(fates_log(), *) 'currentPatch%tsai_profile(1,ft,iv): ', currentPatch%tsai_profile(1,ft,iv) !snow burial - if(currentSite%snow_depth > maxh(iv))then + if(currentSite%snow_depth > maxh(iv))then fraction_exposed = 0._r8 endif - if(currentSite%snow_depth < minh(iv))then + if(currentSite%snow_depth < minh(iv))then fraction_exposed = 1._r8 endif - if(currentSite%snow_depth >= minh(iv) .and. currentSite%snow_depth <= maxh(iv)) then !only partly hidden... + if(currentSite%snow_depth >= minh(iv) .and. currentSite%snow_depth <= maxh(iv)) then !only partly hidden... fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(currentSite%snow_depth-minh(iv))/dh))) endif - if ( debug ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) - currentPatch%elai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) * fraction_exposed currentPatch%esai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) * fraction_exposed - if ( debug ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) - enddo ! (iv) hite bins currentCohort => currentCohort%taller - enddo !currentCohort + enddo !currentCohort ! ----------------------------------------------------------------------------- ! Perform a leaf area conservation check on the LAI profile @@ -1679,32 +1657,32 @@ subroutine leaf_area_profile( currentSite ) endif - else ! smooth leaf distribution + else ! smooth leaf distribution ! ----------------------------------------------------------------------------- ! Standard canopy layering model. - ! Go through all cohorts and add their leaf area - ! and canopy area to the accumulators. + ! Go through all cohorts and add their leaf area + ! and canopy area to the accumulators. ! ----------------------------------------------------------------------------- currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - ft = currentCohort%pft + do while(associated(currentCohort)) + ft = currentCohort%pft cl = currentCohort%canopy_layer ! ---------------------------------------------------------------- - ! How much of each tree is stem area index? Assuming that there is + ! How much of each tree is stem area index? Assuming that there is ! This may indeed be zero if there is a sensecent grass ! ---------------------------------------------------------------- - if( (currentCohort%treelai+currentCohort%treesai) > 0._r8)then - fleaf = currentCohort%lai / (currentCohort%lai + currentCohort%sai) + if( (currentCohort%treelai+currentCohort%treesai) > 0._r8)then + fleaf = currentCohort%lai / (currentCohort%lai + currentCohort%sai) else fleaf = 0._r8 endif - currentPatch%nrad(cl,ft) = currentPatch%ncan(cl,ft) + currentPatch%nrad(cl,ft) = currentPatch%ncan(cl,ft) if (currentPatch%nrad(cl,ft) > nlevleaf ) then write(fates_log(), *) 'Number of radiative leaf layers is larger' @@ -1718,8 +1696,8 @@ subroutine leaf_area_profile( currentSite ) ! -------------------------------------------------------------------------- - ! Whole layers. Make a weighted average of the leaf area in each layer - ! before dividing it by the total area. Fill up layer for whole layers. + ! Whole layers. Make a weighted average of the leaf area in each layer + ! before dividing it by the total area. Fill up layer for whole layers. ! -------------------------------------------------------------------------- do iv = 1,currentCohort%NV @@ -1755,7 +1733,7 @@ subroutine leaf_area_profile( currentSite ) (dinc_ed*real(currentCohort%nv-1,r8)) if(remainder > dinc_ed )then write(fates_log(), *)'ED: issue with remainder', & - currentCohort%treelai,currentCohort%treesai,dinc_ed, & + currentCohort%treelai,currentCohort%treesai,dinc_ed, & currentCohort%NV,remainder call endrun(msg=errMsg(sourcefile, __LINE__)) endif @@ -1782,7 +1760,7 @@ subroutine leaf_area_profile( currentSite ) currentPatch%layer_height_profile(cl,ft,iv) = currentPatch%layer_height_profile(cl,ft,iv) + & (remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & - (layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. + (layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. end do @@ -1811,7 +1789,7 @@ subroutine leaf_area_profile( currentSite ) write(fates_log(), *) 'ED: fracarea', currentCohort%pft, & currentCohort%c_area/currentPatch%total_canopy_area endif - currentCohort => currentCohort%taller + currentCohort => currentCohort%taller enddo !currentCohort call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1848,7 +1826,7 @@ subroutine leaf_area_profile( currentSite ) write(fates_log(), *) 'ED: fracarea', currentCohort%pft, & currentCohort%c_area/currentPatch%total_canopy_area endif - currentCohort => currentCohort%taller + currentCohort => currentCohort%taller enddo !currentCohort call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1861,8 +1839,6 @@ subroutine leaf_area_profile( currentSite ) currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) / & currentPatch%canopy_area_profile(cl,ft,iv) - write(fates_log(), *) 'currentPatch%tlai_profile(cl,ft,iv): ', currentPatch%tlai_profile(cl,ft,iv) - write(fates_log(), *) 'currentPatch%canopy_area_profile(cl,ft,iv): ', currentPatch%canopy_area_profile(cl,ft,iv) currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) / & currentPatch%canopy_area_profile(cl,ft,iv) @@ -1893,7 +1869,7 @@ subroutine leaf_area_profile( currentSite ) do ft = 1,numpft do iv = 1, currentPatch%nrad(cl,ft) if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then - currentPatch%canopy_mask(cl,ft) = 1 + currentPatch%canopy_mask(cl,ft) = 1 endif end do !iv enddo !ft @@ -1903,9 +1879,9 @@ subroutine leaf_area_profile( currentSite ) end if - currentPatch => currentPatch%younger + currentPatch => currentPatch%younger - enddo !patch + enddo !patch return end subroutine leaf_area_profile @@ -1924,7 +1900,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) use FatesInterfaceTypesMod , only : bc_out_type ! - ! !ARGUMENTS + ! !ARGUMENTS integer, intent(in) :: nsites type(ed_site_type), intent(inout), target :: sites(nsites) integer, intent(in) :: fcolumn(nsites) @@ -1942,16 +1918,16 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) do s = 1,nsites ifp = 0 - total_patch_area = 0._r8 + total_patch_area = 0._r8 total_canopy_area = 0._r8 bc_out(s)%canopy_fraction_pa(:) = 0._r8 currentPatch => sites(s)%oldest_patch c = fcolumn(s) do while(associated(currentPatch)) - !if(currentPatch%nocomp_pft_label.ne.0)then + !if(currentPatch%nocomp_pft_label.ne.0)then ! only increase ifp for veg patches, not bareground (in SP mode) ifp = ifp+1 - !endif ! stay with ifp=0 for bareground patch. + !endif ! stay with ifp=0 for bareground patch. if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area currentPatch%total_canopy_area = currentPatch%area @@ -1976,7 +1952,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! weight = min(1.0_r8,currentCohort%lai/currentPatch%lai) ! bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & ! EDPftvarcon_inst%dleaf(currentCohort%pft)*weight - ! currentCohort => currentCohort%taller + ! currentCohort => currentCohort%taller ! enddo ! end if @@ -1989,11 +1965,11 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) - ! We are assuming here that grass is all located underneath tree canopies. + ! We are assuming here that grass is all located underneath tree canopies. ! The alternative is to assume it is all spatial distinct from tree canopies. ! In which case, the bare area would have to be reduced by the grass area... - ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants - ! currentPatch%area/AREA is the fraction of the soil covered by this patch. + ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants + ! currentPatch%area/AREA is the fraction of the soil covered by this patch. if(currentPatch%area.gt.0.0_r8)then bc_out(s)%canopy_fraction_pa(ifp) = & min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) @@ -2014,16 +1990,11 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) - write(fates_log(),*) 's, ifp: ', s, ifp - write(fates_log(),*) 'EDCanopyStructure pre: bc_out(s)%tlai_pa(ifp): ', bc_out(s)%tlai_pa(ifp) - bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') - write(fates_log(),*) 'EDCanopyStructure post: bc_out(s)%tlai_pa(ifp): ', bc_out(s)%tlai_pa(ifp) - !if(debug) then ! write(fates_log(),*) 'ifp: ', ifp ! write(fates_log(),*) 'bc_out(s)%elai_pa(ifp): ', bc_out(s)%elai_pa(ifp) @@ -2036,7 +2007,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! patches which shall under-go photosynthesis ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let ! FATES internal variables decide if photosynthesis is possible - ! we are essentially calculating it inside FATES to tell the + ! we are essentially calculating it inside FATES to tell the ! host to tell itself when to do things (circuitous). Just have ! to determine where else it is used @@ -2069,7 +2040,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) if(currentPatch%nocomp_pft_label.ne.0)then ! for vegetated patches only ifp = ifp+1 bc_out(s)%canopy_fraction_pa(ifp) = bc_out(s)%canopy_fraction_pa(ifp)/total_patch_area - else ! for the bareground patch (in SP mode). + else ! for the bareground patch (in SP mode). bc_out(s)%canopy_fraction_pa(ifp) =0.0_r8 endif ! veg patch @@ -2086,11 +2057,11 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! For recruitment, we initialized their water, but flagged them ! to not be included in the site level balance yet, for they ! will demand the water for their initialization on the first hydraulics time-step - + if (hlm_use_planthydro.eq.itrue) then call UpdateH2OVeg(sites(s),bc_out(s),bc_out(s)%plant_stored_h2o_si,1) end if - + end do ! This call to RecruitWaterStorage() makes an accounting of @@ -2099,7 +2070,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! a flux, it is just accounting for diagnostics purposes. The water ! will not actually be moved until the beginning of the first hydraulics ! call during the fast timestep sequence - + if (hlm_use_planthydro.eq.itrue) then call RecruitWaterStorage(nsites,sites,bc_out) end if @@ -2230,7 +2201,7 @@ function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) res z = 1 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) z = max(z,currentCohort%canopy_layer) currentCohort => currentCohort%shorter enddo @@ -2238,7 +2209,7 @@ function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) res if(include_substory)then arealayer = 0.0 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) if(currentCohort%canopy_layer == z) then call carea_allom(currentCohort%dbh,currentCohort%n,site_spread,currentCohort%pft,c_area) arealayer = arealayer + c_area @@ -2246,7 +2217,7 @@ function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) res currentCohort => currentCohort%shorter enddo - ! Does the bottom layer have more than a full canopy? + ! Does the bottom layer have more than a full canopy? ! If so we need to make another layer. if(arealayer > currentPatch%area)then z = z + 1 diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 924c4fbd55..68763c5a97 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -3,7 +3,7 @@ module EDPhysiologyMod #include "shr_assert.h" ! ============================================================================ - ! Miscellaneous physiology routines from ED. + ! Miscellaneous physiology routines from ED. ! ============================================================================ use FatesGlobals, only : fates_log @@ -119,14 +119,14 @@ module EDPhysiologyMod public :: ZeroAllocationRates public :: PreDisturbanceLitterFluxes - public :: PreDisturbanceIntegrateLitter + public :: PreDisturbanceIntegrateLitter public :: SeedIn logical, parameter :: debug = .false. ! local debug flag character(len=*), parameter, private :: sourcefile = & __FILE__ - integer, parameter :: dleafon_drycheck = 100 ! Drought deciduous leaves max days on check parameter + integer, parameter :: dleafon_drycheck = 100 ! Drought deciduous leaves max days on check parameter ! ============================================================================ @@ -141,7 +141,7 @@ subroutine ZeroLitterFluxes( currentSite ) ! call sequence. - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type), pointer :: currentPatch @@ -163,7 +163,7 @@ end subroutine ZeroLitterFluxes subroutine ZeroAllocationRates( currentSite ) - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type), pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort @@ -172,7 +172,7 @@ subroutine ZeroAllocationRates( currentSite ) do while(associated(currentPatch)) currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) ! This sets turnover and growth rates to zero call currentCohort%prt%ZeroRates() @@ -191,7 +191,7 @@ end subroutine ZeroAllocationRates subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! ----------------------------------------------------------------------------------- - ! + ! ! This subroutine calculates all of the different litter input and output fluxes ! associated with seed turnover, seed influx, litterfall from live and ! dead plants, germination, and fragmentation. @@ -203,29 +203,27 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! with disturbance. Those fluxes are handled elsewhere (EDPatchDynamcisMod) ! because the fluxes are potentially cross patch, and also dealing ! patch areas that are changing. - ! + ! ! ----------------------------------------------------------------------------------- - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout) :: currentSite type(ed_patch_type), intent(inout) :: currentPatch type(bc_in_type), intent(in) :: bc_in ! ! !LOCAL VARIABLES: - type(site_massbal_type), pointer :: site_mass - type(litter_type), pointer :: litt ! Points to the litter object for + type(site_massbal_type), pointer :: site_mass + type(litter_type), pointer :: litt ! Points to the litter object for ! the different element types integer :: el ! Litter element loop index integer :: nlev_eff_decomp ! Number of active layers over which ! fragmentation fluxes are transfered !------------------------------------------------------------------------------------ - ! Calculate the fragmentation rates + ! Calculate the fragmentation rates call fragmentation_scaler(currentPatch, bc_in) - write(fates_log(),*) 'PreDistLittFlux: frag_scaler: ', currentPatch%fragmentation_scaler - do el = 1, num_elements @@ -233,9 +231,9 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! Calculate loss rate of viable seeds to litter call SeedDecay(litt) - + ! Calculate seed germination rate, the status flags prevent - ! germination from occuring when the site is in a drought + ! germination from occuring when the site is in a drought ! (for drought deciduous) or too cold (for cold deciduous) call SeedGermination(litt, currentSite%cstatus, currentSite%dstatus) @@ -260,7 +258,7 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ( sum(litt%ag_cwd_frag) + sum(litt%bg_cwd_frag) + & sum(litt%leaf_fines_frag) + sum(litt%root_fines_frag) + & sum(litt%seed_decay) + sum(litt%seed_germ_decay)) - + end do @@ -273,14 +271,14 @@ subroutine PreDisturbanceIntegrateLitter(currentPatch) ! ----------------------------------------------------------------------------------- ! - ! This step applies the litter fluxes to the prognostic state variables. + ! This step applies the litter fluxes to the prognostic state variables. ! This procedure is called in response to fluxes generated from: - ! 1) seed rain, + ! 1) seed rain, ! 2) non-disturbance generating turnover ! 3) litter fall from living plants ! 4) fragmentation ! - ! This routine does NOT accomodate the litter fluxes associated with + ! This routine does NOT accomodate the litter fluxes associated with ! disturbance generation. That will happen after this call. ! Fluxes associated with FIRE also happen after this step. ! @@ -295,7 +293,7 @@ subroutine PreDisturbanceIntegrateLitter(currentPatch) ! Locals - type(litter_type), pointer :: litt + type(litter_type), pointer :: litt integer :: el ! Loop counter for litter element type integer :: pft ! pft loop counter integer :: c ! CWD loop counter @@ -320,7 +318,7 @@ subroutine PreDisturbanceIntegrateLitter(currentPatch) ! Note that the recruitment scheme will use seed_germ ! for its construction costs. litt%seed_germ(pft) = litt%seed_germ(pft) + & - litt%seed_germ_in(pft) - & + litt%seed_germ_in(pft) - & litt%seed_germ_decay(pft) @@ -366,11 +364,11 @@ end subroutine PreDisturbanceIntegrateLitter subroutine trim_canopy( currentSite ) ! ! !DESCRIPTION: - ! Canopy trimming / leaf optimisation. Removes leaves in negative annual carbon balance. + ! Canopy trimming / leaf optimisation. Removes leaves in negative annual carbon balance. ! ! !USES: - ! !ARGUMENTS + ! !ARGUMENTS type (ed_site_type),intent(inout), target :: currentSite ! ! !LOCAL VARIABLES: @@ -379,7 +377,7 @@ subroutine trim_canopy( currentSite ) integer :: z ! leaf layer integer :: ipft ! pft index - logical :: trimmed ! was this layer trimmed in this year? If not expand the canopy. + logical :: trimmed ! was this layer trimmed in this year? If not expand the canopy. real(r8) :: tar_bl ! target leaf biomass (leaves flushed, trimmed) real(r8) :: tar_bfr ! target fine-root biomass (leaves flushed, trimmed) real(r8) :: bfr_per_bleaf ! ratio of fine root per leaf biomass @@ -394,7 +392,7 @@ subroutine trim_canopy( currentSite ) real(r8) :: struct_c ! structure carbon [kg] real(r8) :: leaf_inc ! LAI-only portion of the vegetation increment of dinc_ed real(r8) :: lai_canopy_above ! the LAI in the canopy layers above the layer of interest - real(r8) :: lai_layers_above ! the LAI in the leaf layers, within the current canopy, + real(r8) :: lai_layers_above ! the LAI in the leaf layers, within the current canopy, ! above the leaf layer of interest real(r8) :: lai_current ! the LAI in the current leaf layer real(r8) :: cumulative_lai ! whole canopy cumulative LAI, top down, to the leaf layer of interest @@ -406,8 +404,8 @@ subroutine trim_canopy( currentSite ) ! LAPACK linear least squares fit variables ! The standard equation for a linear fit, y = mx + b, is converted to a linear system, AX=B and has - ! the form: [n sum(x); sum(x) sum(x^2)] * [b; m] = [sum(y); sum(x*y)] where - ! n is the number of leaf layers + ! the form: [n sum(x); sum(x) sum(x^2)] * [b; m] = [sum(y); sum(x*y)] where + ! n is the number of leaf layers ! x is yearly_net_uptake minus the leaf cost aka the net-net uptake ! y is the cumulative lai for the current cohort ! b is the y-intercept i.e. the cumulative lai that has zero net-net uptake @@ -428,7 +426,7 @@ subroutine trim_canopy( currentSite ) real(r8) :: work(workmax) ! work array real(r8) :: initial_trim ! Initial trim - real(r8) :: optimum_trim ! Optimum trim value + real(r8) :: optimum_trim ! Optimum trim value real(r8) :: initial_laimem ! Initial laimemory real(r8) :: optimum_laimem ! Optimum laimemory @@ -448,7 +446,7 @@ subroutine trim_canopy( currentSite ) icohort = 1 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) ! Save off the incoming trim and laimemory initial_trim = currentCohort%canopy_trim @@ -469,12 +467,12 @@ subroutine trim_canopy( currentSite ) currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & currentPatch%canopy_layer_tlai, currentCohort%treelai, & - currentCohort%vcmax25top,0 ) + currentCohort%vcmax25top,0 ) currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) @@ -503,7 +501,7 @@ subroutine trim_canopy( currentSite ) nnu_clai_a(:,:) = 0._r8 nnu_clai_b(:,:) = 0._r8 - !Leaf cost vs netuptake for each leaf layer. + !Leaf cost vs netuptake for each leaf layer. do z = 1, currentCohort%nv ! Calculate the cumulative total vegetation area index (no snow occlusion, stems and leaves) @@ -517,11 +515,11 @@ subroutine trim_canopy( currentSite ) cumulative_lai_cohort = lai_layers_above + 0.5*lai_current ! Now add in the lai above the current cohort for calculating the sla leaf level - lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) cumulative_lai = lai_canopy_above + cumulative_lai_cohort ! There was activity this year in this leaf layer. This should only occur for bottom most leaf layer - if (currentCohort%year_net_uptake(z) /= 999._r8)then + if (currentCohort%year_net_uptake(z) /= 999._r8)then ! Calculate sla_levleaf following the sla profile with overlying leaf area ! Scale for leaf nitrogen profile @@ -536,9 +534,9 @@ subroutine trim_canopy( currentSite ) end if !Leaf Cost kgC/m2/year-1 - !decidous costs. + !decidous costs. if (prt_params%season_decid(ipft) == itrue .or. & - prt_params%stress_decid(ipft) == itrue )then + prt_params%stress_decid(ipft) == itrue )then ! Leaf cost at leaf level z accounting for sla profile (kgC/m2) currentCohort%leaf_cost = 1._r8/(sla_levleaf*1000.0_r8) @@ -572,9 +570,9 @@ subroutine trim_canopy( currentSite ) endif ! Construct the arrays for a least square fit of the net_net_uptake versus the cumulative lai - ! if at least nll leaf layers are present in the current cohort and only for the bottom nll + ! if at least nll leaf layers are present in the current cohort and only for the bottom nll ! leaf layers. - if (currentCohort%nv > nll .and. currentCohort%nv - z < nll) then + if (currentCohort%nv > nll .and. currentCohort%nv - z < nll) then ! Build the A matrix for the LHS of the linear system. A = [n sum(x); sum(x) sum(x^2)] ! where n = nll and x = yearly_net_uptake-leafcost @@ -586,7 +584,7 @@ subroutine trim_canopy( currentSite ) ! Build the B matrix for the RHS of the linear system. B = [sum(y); sum(x*y)] ! where x = yearly_net_uptake-leafcost and y = cumulative_lai_cohort nnu_clai_b(1,1) = nnu_clai_b(1,1) + cumulative_lai_cohort - nnu_clai_b(2,1) = nnu_clai_b(2,1) + (cumulative_lai_cohort * & + nnu_clai_b(2,1) = nnu_clai_b(2,1) + (cumulative_lai_cohort * & (currentCohort%year_net_uptake(z) - currentCohort%leaf_cost)) end if @@ -600,13 +598,13 @@ subroutine trim_canopy( currentSite ) ! currentCohort%canopy_trim,currentCohort%leaf_cost ! endif - ! keep trimming until none of the canopy is in negative carbon balance. + ! keep trimming until none of the canopy is in negative carbon balance. if (currentCohort%hite > EDPftvarcon_inst%hgt_min(ipft)) then currentCohort%canopy_trim = currentCohort%canopy_trim - & EDPftvarcon_inst%trim_inc(ipft) if (prt_params%evergreen(ipft) /= 1)then currentCohort%laimemory = currentCohort%laimemory * & - (1.0_r8 - EDPftvarcon_inst%trim_inc(ipft)) + (1.0_r8 - EDPftvarcon_inst%trim_inc(ipft)) endif trimmed = .true. @@ -614,7 +612,7 @@ subroutine trim_canopy( currentSite ) endif ! hite check endif ! trim limit check endif ! net uptake check - endif ! leaf activity check + endif ! leaf activity check enddo ! z, leaf layer loop ! Compute the optimal cumulative lai based on the cohort net-net uptake profile if at least 2 leaf layers @@ -630,7 +628,7 @@ subroutine trim_canopy( currentSite ) ! endif ! Compute the minimum of 2-norm of of the least squares fit to solve for X - ! Note that dgels returns the solution by overwriting the nnu_clai_b array. + ! Note that dgels returns the solution by overwriting the nnu_clai_b array. ! The result has the form: X = [b; m] ! where b = y-intercept (i.e. the cohort lai that has zero yearly net-net uptake) ! and m is the slope of the linear fit @@ -651,7 +649,7 @@ subroutine trim_canopy( currentSite ) ! Calculate the optimum trim based on the initial canopy trim value if (cumulative_lai_cohort > 0._r8) then ! Sometime cumulative_lai comes in at 0.0? - ! + ! optimum_trim = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_trim optimum_laimem = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_laimem @@ -673,7 +671,7 @@ subroutine trim_canopy( currentSite ) ! Reset activity for the cohort for the start of the next year currentCohort%year_net_uptake(:) = 999.0_r8 - ! Add to trim fraction if cohort not trimmed at all + ! Add to trim fraction if cohort not trimmed at all if ( (.not.trimmed) .and.currentCohort%canopy_trim < 1.0_r8)then currentCohort%canopy_trim = currentCohort%canopy_trim + EDPftvarcon_inst%trim_inc(ipft) endif @@ -682,7 +680,7 @@ subroutine trim_canopy( currentSite ) write(fates_log(),*) 'trimming:',currentCohort%canopy_trim endif - ! currentCohort%canopy_trim = 1.0_r8 !FIX(RF,032414) this turns off ctrim for now. + ! currentCohort%canopy_trim = 1.0_r8 !FIX(RF,032414) this turns off ctrim for now. currentCohort => currentCohort%shorter icohort = icohort + 1 enddo @@ -696,7 +694,7 @@ end subroutine trim_canopy subroutine phenology( currentSite, bc_in ) ! ! !DESCRIPTION: - ! Phenology. + ! Phenology. ! ! !USES: use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm @@ -757,26 +755,26 @@ subroutine phenology( currentSite, bc_in ) ilayer_swater = minloc(abs(bc_in%z_sisl(:)-dphen_soil_depth),dim=1) - ! Parameter of drought decid leaf loss in mm in top layer...FIX(RF,032414) + ! Parameter of drought decid leaf loss in mm in top layer...FIX(RF,032414) ! - this is arbitrary and poorly understood. Needs work. ED_ - !Parameters: defaults from Botta et al. 2000 GCB,6 709-725 + !Parameters: defaults from Botta et al. 2000 GCB,6 709-725 !Parameters, default from from SDGVM model of senesence temp_in_C = 0._r8 - cpatch => CurrentSite%oldest_patch - do while(associated(cpatch)) + 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--------------------! + !-----------------Cold Phenology--------------------! !Zero growing degree and chilling day counters if (currentSite%lat > 0)then ncdstart = 270 !Northern Hemisphere begining November - gddstart = 1 !Northern Hemisphere begining January + gddstart = 1 !Northern Hemisphere begining January else ncdstart = 120 !Southern Hemisphere beginning May gddstart = 181 !Northern Hemisphere begining July @@ -796,7 +794,7 @@ subroutine phenology( currentSite, bc_in ) endif !GDD accumulation function, which also depends on chilling days. - ! -68 + 638 * (-0.001 * ncd) + ! -68 + 638 * (-0.001 * ncd) gdd_threshold = ED_val_phen_a + ED_val_phen_b*exp(ED_val_phen_c*real(currentSite%nchilldays,r8)) !Accumulate temperature of last 10 days. @@ -824,27 +822,27 @@ subroutine phenology( currentSite, bc_in ) 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 - ! beginnning of the accumulation period, to prevend erroneous autumn leaf flushing. + !this logic is to prevent GDD accumulating after the leaves have fallen and before the + ! beginnning of the accumulation period, to prevend erroneous autumn leaf flushing. if(model_day_int>365)then !only do this after the first year to prevent odd behaviour - if(currentSite%lat .gt. 0.0_r8)then !Northern Hemisphere + if(currentSite%lat .gt. 0.0_r8)then !Northern Hemisphere ! In the north, don't accumulate when we are past the leaf fall date. - ! Accumulation starts on day 1 of year in NH. + ! Accumulation starts on day 1 of year in NH. ! The 180 is to prevent going into an 'always off' state after initialization if( model_day_int .gt. currentSite%cleafoffdate.and.hlm_day_of_year.gt.180)then ! currentSite%grow_deg_days = 0._r8 endif - else !Southern Hemisphere + else !Southern Hemisphere ! In the South, don't accumulate after the leaf off date, and before the start of - ! the accumulation phase (day 181). - if(model_day_int .gt. currentSite%cleafoffdate.and.hlm_day_of_year.lt.gddstart) then! + ! the accumulation phase (day 181). + if(model_day_int .gt. currentSite%cleafoffdate.and.hlm_day_of_year.lt.gddstart) then! currentSite%grow_deg_days = 0._r8 endif endif - endif !year1 + endif !year1 - ! Calculate the number of days since the leaves last came on + ! Calculate the number of days since the leaves last came on ! and off. If this is the beginning of the simulation, that day might ! not had occured yet, so set it to last year to get things rolling @@ -863,9 +861,9 @@ subroutine phenology( currentSite, bc_in ) !LEAF ON: COLD DECIDUOUS. Needs to - !1) have exceeded the growing degree day threshold + !1) have exceeded the growing degree day threshold !2) The leaves should not be on already - !3) There should have been at least one chilling day in the counting period. + !3) There should have been at least one chilling day in the counting period. ! this prevents tropical or warm climate plants that are "cold-deciduous" ! from ever re-flushing after they have reached their maximum age (thus ! preventing them from competing @@ -876,9 +874,9 @@ subroutine phenology( currentSite, bc_in ) (dayssincecleafoff > ED_val_phen_mindayson) .and. & (currentSite%nchilldays >= 1)) then currentSite%cstatus = phen_cstat_notcold ! Set to not-cold status (leaves can come on) - currentSite%cleafondate = model_day_int - dayssincecleafon = 0 - currentSite%grow_deg_days = 0._r8 ! zero GDD for the rest of the year until counting season begins. + currentSite%cleafondate = model_day_int + dayssincecleafon = 0 + currentSite%grow_deg_days = 0._r8 ! zero GDD for the rest of the year until counting season begins. if ( debug ) write(fates_log(),*) 'leaves on' endif !GDD @@ -890,7 +888,7 @@ subroutine phenology( currentSite, bc_in ) !1) have exceeded the number of cold days threshold !2) have exceeded the minimum leafon time. !3) The leaves should not be off already - !4) The day of simulation should be larger than the counting period. + !4) The day of simulation should be larger than the counting period. if ( (currentSite%cstatus == phen_cstat_notcold) .and. & @@ -899,12 +897,12 @@ subroutine phenology( currentSite, bc_in ) (dayssincecleafon > ED_val_phen_mindayson) )then currentSite%grow_deg_days = 0._r8 ! The equations for Botta et al - ! are for calculations of + ! are for calculations of ! first flush, but if we dont ! clear this value, it will cause ! leaves to flush later in the year currentSite%cstatus = phen_cstat_iscold ! alter status of site to 'leaves off' - currentSite%cleafoffdate = model_day_int ! record leaf off date + currentSite%cleafoffdate = model_day_int ! record leaf off date if ( debug ) write(fates_log(),*) 'leaves off' endif @@ -916,59 +914,59 @@ subroutine phenology( currentSite, bc_in ) ! plants from re-emerging in areas without at least some cold days if( (currentSite%cstatus == phen_cstat_notcold) .and. & - (dayssincecleafoff > 400)) then ! remove leaves after a whole year - ! when there is no 'off' period. + (dayssincecleafoff > 400)) then ! remove leaves after a whole year + ! when there is no 'off' period. currentSite%grow_deg_days = 0._r8 currentSite%cstatus = phen_cstat_nevercold ! alter status of site to imply that this ! site is never really cold enough ! for cold deciduous - currentSite%cleafoffdate = model_day_int ! record leaf off date + currentSite%cleafoffdate = model_day_int ! record leaf off date if ( debug ) write(fates_log(),*) 'leaves off' endif !-----------------Drought Phenology--------------------! ! Principles of drought-deciduos phenology model... - ! The 'is_drought' flag is false when leaves are on, and true when leaves area off. - ! The following sets those site-level flags, which are acted on in phenology_deciduos. - ! A* The leaves live for either the length of time the soil moisture is over the threshold - ! or the lifetime of the leaves, whichever is shorter. + ! The 'is_drought' flag is false when leaves are on, and true when leaves area off. + ! The following sets those site-level flags, which are acted on in phenology_deciduos. + ! A* The leaves live for either the length of time the soil moisture is over the threshold + ! or the lifetime of the leaves, whichever is shorter. ! B*: If the soil is only wet for a very short time, then the leaves stay on for 100 days - ! C*: The leaves are only permitted to come ON for a 60 day window around when they last came on, + ! C*: The leaves are only permitted to come ON for a 60 day window around when they last came on, ! to prevent 'flickering' on in response to wet season storms - ! D*: We don't allow anything to happen in the first ten days to allow the water memory window - ! to come into equlibirium. - ! E*: If the soil is always wet, the leaves come on at the beginning of the window, and then - ! last for their lifespan. + ! D*: We don't allow anything to happen in the first ten days to allow the water memory window + ! to come into equlibirium. + ! E*: If the soil is always wet, the leaves come on at the beginning of the window, and then + ! last for their lifespan. ! ISSUES - ! 1. It's not clear what water content we should track. Here we are tracking the top layer, - ! but we probably should track something like BTRAN, but BTRAN is defined for each PFT, + ! 1. It's not clear what water content we should track. Here we are tracking the top layer, + ! but we probably should track something like BTRAN, but BTRAN is defined for each PFT, ! and there could potentially be more than one stress-dec PFT.... ? - ! 2. In the beginning, the window is set at an arbitrary time of the year, so the leaves + ! 2. In the beginning, the window is set at an arbitrary time of the year, so the leaves ! might come on in the dry season, using up stored reserves - ! for the stress-dec plants, and potentially killing them. To get around this, + ! for the stress-dec plants, and potentially killing them. To get around this, ! we need to read in the 'leaf on' date from some kind of start-up file - ! but we would need that to happen for every resolution, etc. + ! but we would need that to happen for every resolution, etc. ! 3. Will this methodology properly kill off the stress-dec trees where there is no - ! water stress? What about where the wet period coincides with the warm period? + ! water stress? What about where the wet period coincides with the warm period? ! We would just get them overlapping with the cold-dec trees, even though that isn't appropriate - ! Why don't the drought deciduous trees grow in the North? - ! Is cold decidousness maybe even the same as drought deciduosness there (and so does this - ! distinction actually matter??).... + ! Why don't the drought deciduous trees grow in the North? + ! Is cold decidousness maybe even the same as drought deciduosness there (and so does this + ! distinction actually matter??).... ! Accumulate surface water memory of last 10 days. ! Liquid volume in ground layer (m3/m3) do i_wmem = 1,numWaterMem-1 !shift memory along one currentSite%water_memory(numWaterMem+1-i_wmem) = currentSite%water_memory(numWaterMem-i_wmem) enddo - currentSite%water_memory(1) = bc_in%h2o_liqvol_sl(ilayer_swater) + currentSite%water_memory(1) = bc_in%h2o_liqvol_sl(ilayer_swater) ! Calculate the mean water content over the last 10 days (m3/m3) mean_10day_liqvol = sum(currentSite%water_memory(1:numWaterMem))/real(numWaterMem,r8) - ! In drought phenology, we often need to force the leaves to stay - ! on or off as moisture fluctuates... + ! In drought phenology, we often need to force the leaves to stay + ! on or off as moisture fluctuates... ! Calculate days since leaves have come off, but make a provision ! for the first year of simulation, we have to assume a leaf drop @@ -980,19 +978,19 @@ subroutine phenology( currentSite, bc_in ) dayssincedleafoff = model_day_int - currentSite%dleafoffdate endif - ! the leaves are on. How long have they been on? + ! the leaves are on. How long have they been on? if (model_day_int < currentSite%dleafondate) then dayssincedleafon = model_day_int - (currentSite%dleafondate-365) else - dayssincedleafon = model_day_int - currentSite%dleafondate + dayssincedleafon = model_day_int - currentSite%dleafondate endif ! LEAF ON: DROUGHT DECIDUOUS WETNESS - ! Here, we used a window of oppurtunity to determine if we are + ! Here, we used a window of oppurtunity to determine if we are ! close to the time when then leaves came on last year ! Has it been ... - ! a) a year, plus or minus 1 month since we last had leaf-on? + ! a) a year, plus or minus 1 month since we last had leaf-on? ! b) Has there also been at least a nominaly short amount of "leaf-off" ! c) is the model day at least > 10 (let soil water spin-up) ! Note that cold-starts begin in the "leaf-on" @@ -1017,9 +1015,9 @@ subroutine phenology( currentSite, bc_in ) ! LEAF ON: DROUGHT DECIDUOUS TIME EXCEEDANCE ! If we still haven't done budburst by end of window, then force it - ! If the status is "phen_dstat_moistoff", it means this site currently has - ! leaves off due to actual moisture limitations. - ! So we trigger bud-burst at the end of the month since + ! If the status is "phen_dstat_moistoff", it means this site currently has + ! leaves off due to actual moisture limitations. + ! So we trigger bud-burst at the end of the month since ! last year's bud-burst. If this is imposed, then we set the new ! status to indicate bud-burst was forced by timing @@ -1042,27 +1040,27 @@ subroutine phenology( currentSite, bc_in ) end if end if - ! LEAF OFF: DROUGHT DECIDUOUS LIFESPAN - if the leaf gets to - ! the end of its useful life. A*, E* - ! i.e. Are the leaves rouhgly at the end of their lives? + ! LEAF OFF: DROUGHT DECIDUOUS LIFESPAN - if the leaf gets to + ! the end of its useful life. A*, E* + ! i.e. Are the leaves rouhgly at the end of their lives? if ( (currentSite%dstatus == phen_dstat_moiston .or. & - currentSite%dstatus == phen_dstat_timeon ) .and. & - (dayssincedleafon > canopy_leaf_lifespan) )then + currentSite%dstatus == phen_dstat_timeon ) .and. & + (dayssincedleafon > canopy_leaf_lifespan) )then currentSite%dstatus = phen_dstat_timeoff !alter status of site to 'leaves off' - currentSite%dleafoffdate = model_day_int !record leaf on date + currentSite%dleafoffdate = model_day_int !record leaf on date endif - ! LEAF OFF: DROUGHT DECIDUOUS DRYNESS - if the soil gets too dry, - ! and the leaves have already been on a while... + ! LEAF OFF: DROUGHT DECIDUOUS DRYNESS - if the soil gets too dry, + ! and the leaves have already been on a while... if ( (currentSite%dstatus == phen_dstat_moiston .or. & currentSite%dstatus == phen_dstat_timeon ) .and. & (model_day_int > numWaterMem) .and. & (mean_10day_liqvol <= ED_val_phen_drought_threshold) .and. & - (dayssincedleafon > dleafon_drycheck ) ) then + (dayssincedleafon > dleafon_drycheck ) ) then currentSite%dstatus = phen_dstat_moistoff ! alter status of site to 'leaves off' - currentSite%dleafoffdate = model_day_int ! record leaf on date + currentSite%dleafoffdate = model_day_int ! record leaf on date endif call phenology_leafonoff(currentSite) @@ -1082,8 +1080,8 @@ subroutine phenology_leafonoff(currentSite) type(ed_site_type), intent(inout), target :: currentSite ! ! !LOCAL VARIABLES: - type(ed_patch_type) , pointer :: currentPatch - type(ed_cohort_type), pointer :: currentCohort + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort real(r8) :: leaf_c ! leaf carbon [kg] real(r8) :: sapw_c ! sapwood carbon [kg] @@ -1097,11 +1095,11 @@ subroutine phenology_leafonoff(currentSite) real(r8) :: stem_drop_fraction !------------------------------------------------------------------------ - currentPatch => CurrentSite%oldest_patch + currentPatch => CurrentSite%oldest_patch - do while(associated(currentPatch)) + do while(associated(currentPatch)) currentCohort => currentPatch%tallest - do while(associated(currentCohort)) + do while(associated(currentCohort)) ipft = currentCohort%pft @@ -1121,15 +1119,15 @@ subroutine phenology_leafonoff(currentSite) ! for leaves. Time to signal flushing if (prt_params%season_decid(ipft) == itrue)then - if ( currentSite%cstatus == phen_cstat_notcold )then ! we have just moved to leaves being on . - if (currentCohort%status_coh == leaves_off)then ! Are the leaves currently off? - currentCohort%status_coh = leaves_on ! Leaves are on, so change status to - ! stop flow of carbon out of bstore. + if ( currentSite%cstatus == phen_cstat_notcold )then ! we have just moved to leaves being on . + if (currentCohort%status_coh == leaves_off)then ! Are the leaves currently off? + currentCohort%status_coh = leaves_on ! Leaves are on, so change status to + ! stop flow of carbon out of bstore. if(store_c>nearzero) then ! flush either the amount required from the laimemory, or -most- of the storage pool ! RF: added a criterion to stop the entire store pool emptying and triggering termination mortality - ! n.b. this might not be necessary if we adopted a more gradual approach to leaf flushing... + ! n.b. this might not be necessary if we adopted a more gradual approach to leaf flushing... store_c_transfer_frac = min((EDPftvarcon_inst%phenflush_fraction(ipft)* & currentCohort%laimemory)/store_c,(1.0_r8-carbon_store_buffer)) @@ -1143,12 +1141,12 @@ subroutine phenology_leafonoff(currentSite) store_c_transfer_frac = 0.0_r8 end if - ! This call will request that storage carbon will be transferred to + ! This call will request that storage carbon will be transferred to ! leaf tissues. It is specified as a fraction of the available storage if(prt_params%woody(ipft) == itrue) then call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, store_c_transfer_frac) - currentCohort%laimemory = 0.0_r8 + currentCohort%laimemory = 0.0_r8 else @@ -1156,18 +1154,18 @@ subroutine phenology_leafonoff(currentSite) if (stem_drop_fraction .gt. 0.0_r8) then call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac*currentCohort%laimemory/totalmemory) + store_c_transfer_frac*currentCohort%laimemory/totalmemory) call PRTPhenologyFlush(currentCohort%prt, ipft, sapw_organ, & store_c_transfer_frac*currentCohort%sapwmemory/totalmemory) - call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & + call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & store_c_transfer_frac*currentCohort%structmemory/totalmemory) - else + else call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac) + store_c_transfer_frac) end if @@ -1177,17 +1175,17 @@ subroutine phenology_leafonoff(currentSite) endif endif !pft phenology - endif ! growing season + endif ! growing season !COLD LEAF OFF if (currentSite%cstatus == phen_cstat_nevercold .or. & - currentSite%cstatus == phen_cstat_iscold) then ! past leaf drop day? Leaves still on tree? + currentSite%cstatus == phen_cstat_iscold) then ! past leaf drop day? Leaves still on tree? if (currentCohort%status_coh == leaves_on) then ! leaves have not dropped ! leaf off occur on individuals bigger than specific size for grass if (currentCohort%dbh > EDPftvarcon_inst%phen_cold_size_threshold(ipft) & - .or. prt_params%woody(ipft)==itrue) then + .or. prt_params%woody(ipft)==itrue) then ! This sets the cohort to the "leaves off" flag currentCohort%status_coh = leaves_off @@ -1208,7 +1206,7 @@ subroutine phenology_leafonoff(currentSite) currentCohort%sapwmemory = sapw_c * stem_drop_fraction - currentCohort%structmemory = struct_c * stem_drop_fraction + currentCohort%structmemory = struct_c * stem_drop_fraction call PRTDeciduousTurnover(currentCohort%prt,ipft, & sapw_organ, stem_drop_fraction) @@ -1229,24 +1227,24 @@ subroutine phenology_leafonoff(currentSite) if (prt_params%stress_decid(ipft) == itrue )then if (currentSite%dstatus == phen_dstat_moiston .or. & - currentSite%dstatus == phen_dstat_timeon )then + currentSite%dstatus == phen_dstat_timeon )then - ! we have just moved to leaves being on . - if (currentCohort%status_coh == leaves_off)then + ! we have just moved to leaves being on . + if (currentCohort%status_coh == leaves_off)then - !is it the leaf-on day? Are the leaves currently off? + !is it the leaf-on day? Are the leaves currently off? - currentCohort%status_coh = leaves_on ! Leaves are on, so change status to - ! stop flow of carbon out of bstore. + currentCohort%status_coh = leaves_on ! Leaves are on, so change status to + ! stop flow of carbon out of bstore. if(store_c>nearzero) then - store_c_transfer_frac = & + store_c_transfer_frac = & min((EDPftvarcon_inst%phenflush_fraction(ipft)*currentCohort%laimemory)/store_c, & (1.0_r8-carbon_store_buffer)) if(prt_params%woody(ipft).ne.itrue)then - + totalmemory=currentCohort%laimemory+currentCohort%sapwmemory+currentCohort%structmemory store_c_transfer_frac = min(EDPftvarcon_inst%phenflush_fraction(ipft)*totalmemory/store_c, & (1.0_r8-carbon_store_buffer)) @@ -1257,7 +1255,7 @@ subroutine phenology_leafonoff(currentSite) store_c_transfer_frac = 0.0_r8 endif - ! This call will request that storage carbon will be transferred to + ! This call will request that storage carbon will be transferred to ! leaf tissues. It is specified as a fraction of the available storage if(prt_params%woody(ipft) == itrue) then @@ -1272,18 +1270,18 @@ subroutine phenology_leafonoff(currentSite) if (stem_drop_fraction .gt. 0.0_r8) then call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac*currentCohort%laimemory/totalmemory) + store_c_transfer_frac*currentCohort%laimemory/totalmemory) call PRTPhenologyFlush(currentCohort%prt, ipft, sapw_organ, & store_c_transfer_frac*currentCohort%sapwmemory/totalmemory) - call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & + call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & store_c_transfer_frac*currentCohort%structmemory/totalmemory) else call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac) + store_c_transfer_frac) end if @@ -1297,7 +1295,7 @@ subroutine phenology_leafonoff(currentSite) !DROUGHT LEAF OFF if (currentSite%dstatus == phen_dstat_moistoff .or. & - currentSite%dstatus == phen_dstat_timeoff) then + currentSite%dstatus == phen_dstat_timeoff) then if (currentCohort%status_coh == leaves_on) then ! leaves have not dropped @@ -1313,7 +1311,7 @@ subroutine phenology_leafonoff(currentSite) if(prt_params%woody(ipft).ne.itrue)then currentCohort%sapwmemory = sapw_c * stem_drop_fraction - currentCohort%structmemory = struct_c * stem_drop_fraction + currentCohort%structmemory = struct_c * stem_drop_fraction call PRTDeciduousTurnover(currentCohort%prt,ipft, & sapw_organ, stem_drop_fraction) @@ -1342,21 +1340,21 @@ end subroutine phenology_leafonoff subroutine satellite_phenology(currentSite, bc_in) ! ----------------------------------------------------------------------------------- - ! Takes the daily inputs of leaf area index, stem area index and canopy height and + ! Takes the daily inputs of leaf area index, stem area index and canopy height and ! translates them into a FATES structure with one patch and one cohort per PFT - ! The leaf area of the cohort is modified each day to match that asserted by the HLM + ! The leaf area of the cohort is modified each day to match that asserted by the HLM ! ----------------------------------------------------------------------------------- - ! !USES: - ! - ! !ARGUMENTS: + ! !USES: + ! + ! !ARGUMENTS: type(ed_site_type), intent(inout), target :: currentSite type(bc_in_type), intent(in) :: bc_in class(prt_vartypes), pointer :: prt - ! !LOCAL VARIABLES: - type(ed_patch_type) , pointer :: currentPatch + ! !LOCAL VARIABLES: + type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort real(r8) :: spread ! dummy value of canopy spread to estimate c_area @@ -1368,9 +1366,9 @@ subroutine satellite_phenology(currentSite, bc_in) ! To Do in this routine. - ! Get access to HLM input varialbes. + ! Get access to HLM input varialbes. ! Weight them by PFT - ! Loop around patches, and for each single cohort in each patch + ! Loop around patches, and for each single cohort in each patch ! call assign_cohort_SP_properties to determine cohort height, dbh, 'n', area, leafc from drivers. currentSite%sp_tlai(:) = 0._r8 @@ -1378,18 +1376,18 @@ subroutine satellite_phenology(currentSite, bc_in) currentSite%sp_htop(:) = 0._r8 ! WEIGHTING OF FATES PFTs on to HLM_PFTs - ! 1. Add up the area associated with each FATES PFT + ! 1. Add up the area associated with each FATES PFT ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) ! hlm_pft_map is the area of that land in each FATES PFT (from param file) - ! 2. weight each fates PFT target for lai, sai and htop by the area of the + ! 2. weight each fates PFT target for lai, sai and htop by the area of the ! contrbuting HLM PFTs. currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) fates_pft = currentPatch%nocomp_pft_label - if(fates_pft.ne.0)then + if(fates_pft.ne.0)then do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) @@ -1397,10 +1395,10 @@ subroutine satellite_phenology(currentSite, bc_in) !leaf area index currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & bc_in%hlm_sp_tlai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & - * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) + * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) !stem area index currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & - bc_in%hlm_sp_tsai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & + bc_in%hlm_sp_tsai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) ! canopy height currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) + & @@ -1411,7 +1409,7 @@ subroutine satellite_phenology(currentSite, bc_in) ! weight for total area in each patch/fates_pft ! this is needed because the area of pft_areafrac does not need to sum to 1.0 - if(currentPatch%area.gt.0.0_r8)then + if(currentPatch%area.gt.0.0_r8)then currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) & /(currentPatch%area/area) currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) & @@ -1422,16 +1420,16 @@ subroutine satellite_phenology(currentSite, bc_in) end if ! not bare patch currentPatch => currentPatch%younger - end do ! patch loop + end do ! patch loop ! ------------------------------------------------------------ ! now we have the target lai, sai and htop for each PFT/patch ! find properties of the cohort that go along with that ! 1. Find canopy area from HTOP (height) ! 2. Find 'n' associated with canopy area, given a closed canopy - ! 3. Find 'bleaf' associated with TLAI and canopy area. + ! 3. Find 'bleaf' associated with TLAI and canopy area. ! These things happen in the catchily titled "assign_cohort_SP_properties" routine. - ! ------------------------------------------------------------ + ! ------------------------------------------------------------ currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) @@ -1439,7 +1437,7 @@ subroutine satellite_phenology(currentSite, bc_in) currentCohort => currentPatch%tallest do while (associated(currentCohort)) - ! FIRST SOME CHECKS. + ! FIRST SOME CHECKS. fates_pft =currentCohort%pft if(fates_pft.ne.currentPatch%nocomp_pft_label)then ! does this cohort belong in this PFT patch? write(fates_log(),*) 'wrong PFT label in cohort in SP mode',fates_pft,currentPatch%nocomp_pft_label @@ -1451,7 +1449,7 @@ subroutine satellite_phenology(currentSite, bc_in) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - ! Call routine to invert SP drivers into cohort properites. + ! Call routine to invert SP drivers into cohort properites. call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) currentCohort => currentCohort%shorter @@ -1481,15 +1479,15 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l integer, intent(in) :: init ! are we in the initialization routine? if so do not set leaf_c real(r8), intent(out) :: leaf_c ! leaf carbon estimated to generate target tlai - real(r8) :: dummy_n ! set cohort n to a dummy value of 1.0 + real(r8) :: dummy_n ! set cohort n to a dummy value of 1.0 integer :: fates_pft ! fates pft numer for weighting loop real(r8) :: spread ! dummy value of canopy spread to estimate c_area real(r8) :: check_treelai real(r8) :: canopylai(1:nclmax) real(r8) :: fracerr - real(r8) :: oldcarea + real(r8) :: oldcarea - ! Do some checks + ! Do some checks if(associated(currentCohort%shorter))then write(fates_log(),*) 'SP mode has >1 cohort' write(fates_log(),*) "SP mode >1 cohort: PFT",currentCohort%pft, currentCohort%shorter%pft @@ -1507,8 +1505,8 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l dummy_n = 1.0_r8 ! make n=1 to get area of one tree. spread = 1.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. - ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in - ! SP mode. + ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in + ! SP mode. call carea_allom(currentCohort%dbh,dummy_n,spread,currentCohort%pft,currentCohort%c_area) !------------------------------------------ @@ -1527,7 +1525,7 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) - !check that the inverse calculation of leafc from treelai is the same as the + !check that the inverse calculation of leafc from treelai is the same as the ! standard calculation of treelai from leafc. Maybe can delete eventually? check_treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & @@ -1539,10 +1537,10 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l call endrun(msg=errMsg(sourcefile, __LINE__)) end if - ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area - ! these mean that the canopy area does not exactly add up to the patch area, which causes chaos in - ! the radiation routines. Correct both the area and the 'n' to remove error, and don't use - !! carea_allom in SP mode after this point. + ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area + ! these mean that the canopy area does not exactly add up to the patch area, which causes chaos in + ! the radiation routines. Correct both the area and the 'n' to remove error, and don't use + !! carea_allom in SP mode after this point. if(abs(currentCohort%c_area-parea).gt.nearzero)then ! there is an error if(abs(currentCohort%c_area-parea).lt.10.e-9)then !correct this if it's a very small error @@ -1554,13 +1552,13 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l write(fates_log(),*) 'SPassign, c_area still broken',currentCohort%c_area-parea,currentCohort%c_area-oldcarea call endrun(msg=errMsg(sourcefile, __LINE__)) end if - else + else write(fates_log(),*) 'SPassign, big error in c_area',currentCohort%c_area-parea,currentCohort%pft end if ! still broken end if !small error if(init.eq.ifalse)then - call SetState(currentCohort%prt,leaf_organ,1,leaf_c,1) + call SetState(currentCohort%prt,leaf_organ,1,leaf_c,1) endif ! assert sai @@ -1573,13 +1571,13 @@ end subroutine assign_cohort_SP_properties subroutine SeedIn( currentSite, bc_in ) ! ----------------------------------------------------------------------------------- - ! Flux from plants into the seed pool. + ! Flux from plants into the seed pool. ! It is assumed that allocation to seed on living pools has already been calculated ! at the daily time step. ! Note: Some seed generation can occur during disturbance. It is assumed that ! some plants use their storage upon death to create seeds, but this in only - ! triggered during non-fire and non-logging events. See - ! subroutine mortality_litter_fluxes() and DistributeSeeds(), look for + ! triggered during non-fire and non-logging events. See + ! subroutine mortality_litter_fluxes() and DistributeSeeds(), look for ! parameter allom_frbstor_repro ! ----------------------------------------------------------------------------------- @@ -1589,7 +1587,7 @@ subroutine SeedIn( currentSite, bc_in ) use EDTypesMod, only : homogenize_seed_pfts !use FatesInterfaceTypesMod, only : hlm_use_fixed_biogeog ! For future reduced complexity? ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(bc_in_type), intent(in) :: bc_in @@ -1666,7 +1664,7 @@ subroutine SeedIn( currentSite, bc_in ) ! Loop over all patches again and disperse the mixed seeds into the input flux - ! arrays + ! arrays ! Loop over all patches and sum up the seed input for each PFT currentPatch => currentSite%oldest_patch @@ -1686,9 +1684,9 @@ subroutine SeedIn( currentSite, bc_in ) case(carbon12_element) seed_stoich = 1._r8 case(nitrogen_element) - seed_stoich = prt_params%nitr_recr_stoich(pft) + seed_stoich = prt_params%nitr_recr_stoich(pft) case(phosphorus_element) - seed_stoich = prt_params%phos_recr_stoich(pft) + seed_stoich = prt_params%phos_recr_stoich(pft) case default write(fates_log(), *) 'undefined element specified' write(fates_log(), *) 'while defining forced external seed mass flux' @@ -1701,7 +1699,7 @@ subroutine SeedIn( currentSite, bc_in ) ! Seeds entering externally [kg/site/day] site_mass%seed_in = site_mass%seed_in + seed_in_external*currentPatch%area - end if !use this pft + end if !use this pft enddo @@ -1718,9 +1716,9 @@ end subroutine SeedIn subroutine SeedDecay( litt ) ! ! !DESCRIPTION: - ! Flux from seed pool into leaf litter pool + ! Flux from seed pool into leaf litter pool ! - ! !ARGUMENTS + ! !ARGUMENTS type(litter_type) :: litt ! ! !LOCAL VARIABLES: @@ -1733,7 +1731,7 @@ subroutine SeedDecay( litt ) ! seed_decay is kg/day ! Assume that decay rates are same for all chemical species - do pft = 1,numpft + do pft = 1,numpft litt%seed_decay(pft) = litt%seed(pft) * & EDPftvarcon_inst%seed_decay_rate(pft)*years_per_day @@ -1749,13 +1747,13 @@ end subroutine SeedDecay subroutine SeedGermination( litt, cold_stat, drought_stat ) ! ! !DESCRIPTION: - ! Flux from seed pool into sapling pool + ! Flux from seed pool into sapling pool ! ! !USES: ! ! !ARGUMENTS - type(litter_type) :: litt + type(litter_type) :: litt integer, intent(in) :: cold_stat ! Is the site in cold leaf-off status? integer, intent(in) :: drought_stat ! Is the site in drought leaf-off status? ! @@ -1763,7 +1761,7 @@ subroutine SeedGermination( litt, cold_stat, drought_stat ) integer :: pft - real(r8), parameter :: max_germination = 1.0_r8 ! Cap on germination rates. + real(r8), parameter :: max_germination = 1.0_r8 ! Cap on germination rates. ! KgC/m2/yr Lishcke et al. 2009 ! Turning of this cap? because the cap will impose changes on proportionality @@ -1773,9 +1771,9 @@ subroutine SeedGermination( litt, cold_stat, drought_stat ) !---------------------------------------------------------------------- ! germination_rate is being pulled to PFT parameter; units are 1/yr - ! thus the mortality rate of seed -> recruit (in units of carbon) + ! thus the mortality rate of seed -> recruit (in units of carbon) ! is seed_decay_rate(p)/germination_rate(p) - ! and thus the mortality rate (in units of individuals) is the product of + ! and thus the mortality rate (in units of individuals) is the product of ! that times the ratio of (hypothetical) seed mass to recruit biomass do pft = 1,numpft @@ -1809,12 +1807,12 @@ end subroutine SeedGermination subroutine recruitment( currentSite, currentPatch, bc_in ) ! ! !DESCRIPTION: - ! spawn new cohorts of juveniles of each PFT + ! spawn new cohorts of juveniles of each PFT ! ! !USES: use FatesInterfaceTypesMod, only : hlm_use_ed_prescribed_phys ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type), intent(inout), pointer :: currentPatch type(bc_in_type), intent(in) :: bc_in @@ -1849,7 +1847,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) real(r8) :: mass_avail ! The mass of each nutrient/carbon available in the seed_germination pool [kg] real(r8) :: mass_demand ! Total mass demanded by the plant to achieve the stoichiometric targets ! of all the organs in the recruits. Used for both [kg per plant] and [kg per cohort] - real(r8) :: stem_drop_fraction + real(r8) :: stem_drop_fraction !---------------------------------------------------------------------- @@ -1878,9 +1876,9 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) ! Default assumption is that leaves are on cohortstatus = leaves_on - temp_cohort%laimemory = 0.0_r8 - temp_cohort%sapwmemory = 0.0_r8 - temp_cohort%structmemory = 0.0_r8 + temp_cohort%laimemory = 0.0_r8 + temp_cohort%sapwmemory = 0.0_r8 + temp_cohort%structmemory = 0.0_r8 ! But if the plant is seasonally (cold) deciduous, and the site status is flagged @@ -1894,13 +1892,13 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) if (prt_params%woody(ft).ne.itrue) then temp_cohort%sapwmemory = c_sapw * stem_drop_fraction temp_cohort%structmemory = c_struct * stem_drop_fraction - c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw + c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw c_struct = (1.0_r8 - stem_drop_fraction) * c_struct endif cohortstatus = leaves_off endif - ! Or.. if the plant is drought deciduous, and the site status is flagged as + ! Or.. if the plant is drought deciduous, and the site status is flagged as ! "in a drought", then likewise, set the cohort's status to leaves_off, and remember leaf ! biomass if ((prt_params%stress_decid(ft) == itrue) .and. & @@ -1912,7 +1910,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) if(prt_params%woody(ft).ne.itrue)then temp_cohort%sapwmemory = c_sapw * stem_drop_fraction temp_cohort%structmemory = c_struct * stem_drop_fraction - c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw + c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw c_struct = (1.0_r8 - stem_drop_fraction) * c_struct endif cohortstatus = leaves_off @@ -1940,7 +1938,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) mass_demand = & c_struct*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + & c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & - c_fnrt*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & + c_fnrt*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & c_sapw*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) + & StorageNutrientTarget(ft, element_id, & c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)), & @@ -1953,7 +1951,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) mass_demand = & c_struct*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + & c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & - c_fnrt*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & + c_fnrt*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & c_sapw*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) + & StorageNutrientTarget(ft, element_id, & c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)), & @@ -1972,7 +1970,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) ! Update number density if this is the limiting mass ! ------------------------------------------------------------------------ - temp_cohort%n = min(temp_cohort%n, mass_avail/mass_demand) + temp_cohort%n = min(temp_cohort%n, mass_avail/mass_demand) end do @@ -2054,7 +2052,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) site_mass => currentSite%mass_balance(el) ! Remove mass from the germination pool. However, if we are use prescribed physiology, - ! AND the forced recruitment model, then we are not realling using the prognostic + ! AND the forced recruitment model, then we are not realling using the prognostic ! seed_germination model, so we have to short circuit things. We send all of the ! seed germination mass to an outflux pool, and use an arbitrary generic input flux ! to balance out the new recruits. @@ -2073,8 +2071,8 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) else - currentPatch%litter(el)%seed_germ(ft) = currentPatch%litter(el)%seed_germ(ft) - & - temp_cohort%n / currentPatch%area * & + currentPatch%litter(el)%seed_germ(ft) = currentPatch%litter(el)%seed_germ(ft) - & + temp_cohort%n / currentPatch%area * & (m_struct + m_leaf + m_fnrt + m_sapw + m_store + m_repro) end if @@ -2089,8 +2087,8 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) call prt%CheckInitialConditions() ! This initializes the cohort - call create_cohort(currentSite,currentPatch, temp_cohort%pft, temp_cohort%n, & - temp_cohort%hite, temp_cohort%coage, temp_cohort%dbh, prt, & + call create_cohort(currentSite,currentPatch, temp_cohort%pft, temp_cohort%n, & + temp_cohort%hite, temp_cohort%coage, temp_cohort%dbh, prt, & temp_cohort%laimemory, temp_cohort%sapwmemory, temp_cohort%structmemory, & cohortstatus, recruitstatus, & temp_cohort%canopy_trim,temp_cohort%c_area, & @@ -2128,7 +2126,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) use SFParamsMod , only : SF_val_CWD_frac ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type),intent(inout), target :: currentPatch type(litter_type),intent(inout),target :: litt @@ -2145,7 +2143,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) real(r8) :: dead_n_ilogging ! indirect understory dead-tree density (logging) real(r8) :: dead_n_natural ! understory dead density not associated ! with direct logging - real(r8) :: leaf_m ! mass of the element of interest in the + real(r8) :: leaf_m ! mass of the element of interest in the ! leaf [kg] real(r8) :: fnrt_m ! fine-root [kg] real(r8) :: sapw_m ! sapwood [kg] @@ -2174,7 +2172,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) !---------------------------------------------------------------------- ! ----------------------------------------------------------------------------------- - ! Other direct litter fluxes happen in phenology and in spawn_patches. + ! Other direct litter fluxes happen in phenology and in spawn_patches. ! ----------------------------------------------------------------------------------- numlevsoil = currentSite%nlevsoil @@ -2189,7 +2187,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) currentCohort => currentPatch%shortest do while(associated(currentCohort)) - pft = currentCohort%pft + pft = currentCohort%pft call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil, & bc_in%max_rooting_depth_index_col) @@ -2214,7 +2212,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) ! PART 1 Litter fluxes from non-mortal tissue turnovers Kg/m2/day ! Important note: Turnover has already been removed from the cohorts. ! So, in the next part of this algorithm, when we send the biomass - ! from dying trees to the litter pools, we don't have to worry + ! from dying trees to the litter pools, we don't have to worry ! about double counting. ! --------------------------------------------------------------------------------- @@ -2255,7 +2253,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) prt_params%allom_agb_frac(pft) * currentCohort%n bg_cwd_tot = (sapw_m_turnover + struct_m_turnover) * & - SF_val_CWD_frac(c) * plant_dens * & + SF_val_CWD_frac(c) * plant_dens * & (1.0_r8-prt_params%allom_agb_frac(pft)) do ilyr = 1, numlevsoil @@ -2276,7 +2274,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) ! Total number of dead (n/m2/day) dead_n = -1.0_r8 * currentCohort%dndt/currentPatch%area*years_per_day - if(currentCohort%canopy_layer > 1)then + if(currentCohort%canopy_layer > 1)then ! Total number of dead understory from direct logging ! (it is possible that large harvestable trees are in the understory) @@ -2333,9 +2331,9 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) do c = 1,ncwd - ! Below-ground + ! Below-ground - bg_cwd_tot = (struct_m + sapw_m) * & + bg_cwd_tot = (struct_m + sapw_m) * & SF_val_CWD_frac(c) * dead_n * & (1.0_r8-prt_params%allom_agb_frac(pft)) @@ -2356,12 +2354,12 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) trunk_wood = (struct_m + sapw_m) * & SF_val_CWD_frac(c) * dead_n_dlogging * & - prt_params%allom_agb_frac(pft) + prt_params%allom_agb_frac(pft) site_mass%wood_product = site_mass%wood_product + & trunk_wood * currentPatch%area * logging_export_frac - ! Add AG wood to litter from the non-exported fraction of wood + ! Add AG wood to litter from the non-exported fraction of wood ! from direct anthro sources litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + & @@ -2372,7 +2370,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) ! Add AG wood to litter from indirect anthro sources - litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & + litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & prt_params%allom_agb_frac(pft) @@ -2382,7 +2380,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) else - litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & + litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & SF_val_CWD_frac(c) * dead_n * & prt_params%allom_agb_frac(pft) @@ -2406,7 +2404,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) currentSite%resources_management%delta_biomass_stock = & currentSite%resources_management%delta_biomass_stock + & - (leaf_m + fnrt_m + store_m ) * & + (leaf_m + fnrt_m + store_m ) * & (dead_n_ilogging+dead_n_dlogging) *currentPatch%area currentSite%resources_management%trunk_product_site = & @@ -2417,7 +2415,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) currentSite%resources_management%delta_litter_stock = & currentSite%resources_management%delta_litter_stock + & (struct_m + sapw_m) * & - SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & + SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & currentPatch%area currentSite%resources_management%delta_biomass_stock = & @@ -2434,7 +2432,7 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) currentCohort => currentCohort%taller - enddo ! end loop over cohorts + enddo ! end loop over cohorts return @@ -2443,11 +2441,11 @@ end subroutine CWDInput ! ===================================================================================== - subroutine fragmentation_scaler( currentPatch, bc_in) + subroutine fragmentation_scaler( currentPatch, bc_in) ! ! !DESCRIPTION: ! Simple CWD fragmentation Model - ! FIX(SPM, 091914) this should be a function as it returns a value in + ! FIX(SPM, 091914) this should be a function as it returns a value in ! currentPatch%fragmentation_scaler ! ! !USES: @@ -2456,7 +2454,7 @@ subroutine fragmentation_scaler( currentPatch, bc_in) use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm use FatesConstantsMod, only : pi => pi_const ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_patch_type), intent(inout) :: currentPatch type(bc_in_type), intent(in) :: bc_in @@ -2476,19 +2474,19 @@ subroutine fragmentation_scaler( currentPatch, bc_in) catanf(t1) = 11.75_r8 +(29.7_r8 / pi) * atan( pi * 0.031_r8 * ( t1 - 15.4_r8 )) catanf_30 = catanf(30._r8) - ifp = currentPatch%patchno + ifp = currentPatch%patchno if(currentPatch%nocomp_pft_label.ne.0)then ! Use the hlm temp and moisture decomp fractions by default if ( use_hlm_soil_scalar ) then - + ! Calculate the fragmentation_scaler currentPatch%fragmentation_scaler = min(1.0_r8,max(0.0_r8,bc_in%t_scalar_sisl * bc_in%w_scalar_sisl)) else - + if ( .not. use_century_tfunc ) then - !calculate rate constant scalar for soil temperature,assuming that the base rate constants + !calculate rate constant scalar for soil temperature,assuming that the base rate constants !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) @@ -2498,23 +2496,23 @@ subroutine fragmentation_scaler( currentPatch, bc_in) !Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-tfrz)/10._r8) endif else - ! original century uses an arctangent function to calculate the - ! temperature dependence of decomposition + ! original century uses an arctangent function to calculate the + ! temperature dependence of decomposition t_scalar = max(catanf(bc_in%t_veg24_pa(ifp)-tfrz)/catanf_30,0.01_r8) - endif - - !Moisture Limitations - !BTRAN APPROACH - is quite simple, but max's out decomp at all unstressed - !soil moisture values, which is not realistic. - !litter decomp is proportional to water limitation on average... + endif + + !Moisture Limitations + !BTRAN APPROACH - is quite simple, but max's out decomp at all unstressed + !soil moisture values, which is not realistic. + !litter decomp is proportional to water limitation on average... w_scalar = sum(currentPatch%btran_ft(1:numpft))/real(numpft,r8) ! Calculate the fragmentation_scaler currentPatch%fragmentation_scaler(:) = min(1.0_r8,max(0.0_r8,t_scalar * w_scalar)) endif ! scalar - - endif ! not bare ground + + endif ! not bare ground end subroutine fragmentation_scaler @@ -2524,20 +2522,20 @@ subroutine CWDOut( litt, fragmentation_scaler, nlev_eff_decomp ) ! ! !DESCRIPTION: ! Simple CWD fragmentation Model - ! spawn new cohorts of juveniles of each PFT + ! spawn new cohorts of juveniles of each PFT ! ! !USES: use SFParamsMod, only : SF_val_max_decomp ! - ! !ARGUMENTS + ! !ARGUMENTS type(litter_type),intent(inout),target :: litt real(r8),intent(in) :: fragmentation_scaler(:) ! This is not necessarily every soil layer, this is the number ! of effective layers that are active and can be sent ! to the soil decomposition model - integer,intent(in) :: nlev_eff_decomp + integer,intent(in) :: nlev_eff_decomp ! ! !LOCAL VARIABLES: @@ -2552,27 +2550,27 @@ subroutine CWDOut( litt, fragmentation_scaler, nlev_eff_decomp ) ! moisture scalars and fragmentation scalar associated with specified index value ! is used for ag_cwd_frag and root_fines_frag calculations. - do c = 1,ncwd + do c = 1,ncwd litt%ag_cwd_frag(c) = litt%ag_cwd(c) * SF_val_max_decomp(c) * & years_per_day * fragmentation_scaler(soil_layer_index) - + do ilyr = 1,nlev_eff_decomp litt%bg_cwd_frag(c,ilyr) = litt%bg_cwd(c,ilyr) * SF_val_max_decomp(c) * & years_per_day * fragmentation_scaler(ilyr) enddo end do - ! this is the rate at which dropped leaves stop being part of the burnable pool - ! and begin to be part of the decomposing pool. This should probably be highly - ! sensitive to moisture, but also to the type of leaf thick leaves can dry out - ! before they are decomposed, for example. This section needs further scientific input. + ! this is the rate at which dropped leaves stop being part of the burnable pool + ! and begin to be part of the decomposing pool. This should probably be highly + ! sensitive to moisture, but also to the type of leaf thick leaves can dry out + ! before they are decomposed, for example. This section needs further scientific input. do dcmpy = 1,ndcmpy litt%leaf_fines_frag(dcmpy) = litt%leaf_fines(dcmpy) * & years_per_day * SF_val_max_decomp(dl_sf) * fragmentation_scaler(soil_layer_index) - + do ilyr = 1,nlev_eff_decomp litt%root_fines_frag(dcmpy,ilyr) = litt%root_fines(dcmpy,ilyr) * & years_per_day * SF_val_max_decomp(dl_sf) * fragmentation_scaler(ilyr) From d94ca1a3670ca65b0b689f4dda192c381be515e4 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 12 Aug 2021 15:11:11 -0700 Subject: [PATCH 376/578] removing more diagnostics --- biogeochem/EDCohortDynamicsMod.F90 | 633 ++++++++++++++--------------- biogeochem/EDPhysiologyMod.F90 | 3 - 2 files changed, 315 insertions(+), 321 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 474e7573e8..2fa98aa59f 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1,9 +1,9 @@ module EDCohortDynamicsMod ! ! !DESCRIPTION: - ! Cohort stuctures in ED. + ! Cohort stuctures in ED. ! - ! !USES: + ! !USES: use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log use FatesInterfaceTypesMod , only : hlm_freq_day @@ -67,7 +67,7 @@ module EDCohortDynamicsMod use FatesAllometryMod , only : ForceDBH use FatesAllometryMod , only : tree_lai, tree_sai use FatesAllometryMod , only : set_root_fraction - use PRTGenericMod, only : prt_carbon_allom_hyp + use PRTGenericMod, only : prt_carbon_allom_hyp use PRTGenericMod, only : prt_cnp_flex_allom_hyp use PRTGenericMod, only : prt_vartypes use PRTGenericMod, only : all_carbon_elements @@ -97,9 +97,9 @@ module EDCohortDynamicsMod use PRTAllometricCNPMod, only : acnp_bc_out_id_pefflux use PRTAllometricCNPMod, only : acnp_bc_out_id_nneed use PRTAllometricCNPMod, only : acnp_bc_out_id_pneed - - - use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + + + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) ! CIME globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -133,7 +133,7 @@ module EDCohortDynamicsMod integer, parameter, private :: conserve_dbh_and_number_not_crownarea = 2 integer, parameter, private :: cohort_fusion_conservation_method = conserve_crownarea_and_number_not_dbh - + ! 10/30/09: Created by Rosie Fisher !-------------------------------------------------------------------------------------! @@ -142,7 +142,7 @@ module EDCohortDynamicsMod !-------------------------------------------------------------------------------------! - + subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & prt, laimemory, sapwmemory, structmemory, & status, recruitstatus,ctrim, carea, clayer, spread, bc_in) @@ -159,58 +159,58 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & ! ! !USES: ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type), intent(inout), pointer :: patchptr integer, intent(in) :: pft ! Cohort Plant Functional Type - integer, intent(in) :: clayer ! canopy status of cohort + integer, intent(in) :: clayer ! canopy status of cohort ! (1 = canopy, 2 = understorey, etc.) - integer, intent(in) :: status ! growth status of plant + integer, intent(in) :: status ! growth status of plant ! (2 = leaves on , 1 = leaves off) - integer, intent(in) :: recruitstatus ! recruit status of plant + integer, intent(in) :: recruitstatus ! recruit status of plant ! (1 = recruitment , 0 = other) - real(r8), intent(in) :: nn ! number of individuals in cohort + real(r8), intent(in) :: nn ! number of individuals in cohort ! per 'area' (10000m2 default) real(r8), intent(in) :: hite ! height: meters real(r8), intent(in) :: coage ! cohort age in years real(r8), intent(in) :: dbh ! dbh: cm class(prt_vartypes),target :: prt ! The allocated PARTEH ! object - real(r8), intent(in) :: laimemory ! target leaf biomass- set from + real(r8), intent(in) :: laimemory ! target leaf biomass- set from ! previous year: kGC per indiv - real(r8), intent(in) :: sapwmemory ! target sapwood biomass- set from - ! previous year: kGC per indiv - real(r8), intent(in) :: structmemory ! target structural biomass- set from - ! previous year: kGC per indiv - real(r8), intent(in) :: ctrim ! What is the fraction of the maximum + real(r8), intent(in) :: sapwmemory ! target sapwood biomass- set from + ! previous year: kGC per indiv + real(r8), intent(in) :: structmemory ! target structural biomass- set from + ! previous year: kGC per indiv + real(r8), intent(in) :: ctrim ! What is the fraction of the maximum ! leaf biomass that we are targeting? - real(r8), intent(in) :: spread ! The community assembly effects how + real(r8), intent(in) :: spread ! The community assembly effects how ! spread crowns are in horizontal space real(r8), intent(in) :: carea ! area of cohort ONLY USED IN SP MODE. type(bc_in_type), intent(in) :: bc_in ! External boundary conditions - + ! !LOCAL VARIABLES: type(ed_cohort_type), pointer :: new_cohort ! Pointer to New Cohort structure. - type(ed_cohort_type), pointer :: storesmallcohort - type(ed_cohort_type), pointer :: storebigcohort - integer :: iage ! loop counter for leaf age classes + type(ed_cohort_type), pointer :: storesmallcohort + type(ed_cohort_type), pointer :: storebigcohort + 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 :: nlevrhiz ! number of rhizosphere layers !---------------------------------------------------------------------- - + allocate(new_cohort) call nan_cohort(new_cohort) ! Make everything in the cohort not-a-number - call zero_cohort(new_cohort) ! Zero things that need to be zeroed. + call zero_cohort(new_cohort) ! Zero things that need to be zeroed. ! Point to the PARTEH object new_cohort%prt => prt - + ! The PARTEH cohort object should be allocated and already ! initialized in this routine. call new_cohort%prt%CheckInitialConditions() @@ -225,7 +225,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & new_cohort%patchptr => patchptr - new_cohort%pft = pft + new_cohort%pft = pft new_cohort%status_coh = status new_cohort%n = nn new_cohort%hite = hite @@ -251,12 +251,12 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & ! we don't need to update this ever if cohort age tracking is off call coagetype_class_index(new_cohort%coage, new_cohort%pft, & new_cohort%coage_class,new_cohort%coage_by_pft_class) - + ! This routine may be called during restarts, and at this point in the call sequence ! the actual cohort data is unknown, as this is really only used for allocation ! In these cases, testing if things like biomass are reasonable is pre-mature ! However, in this part of the code, we will pass in nominal values for size, number and type - + if (new_cohort%dbh <= 0._r8 .or. new_cohort%n == 0._r8 .or. new_cohort%pft == 0 ) then write(fates_log(),*) 'ED: something is zero in create_cohort', & new_cohort%dbh,new_cohort%n, & @@ -276,14 +276,12 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & new_cohort%treelai = tree_lai(leaf_c, new_cohort%pft, new_cohort%c_area, & new_cohort%n, new_cohort%canopy_layer, & - patchptr%canopy_layer_tlai,new_cohort%vcmax25top ) - - write(fates_log(),*) 'create_cohort: calling tree_sai' + patchptr%canopy_layer_tlai,new_cohort%vcmax25top ) if(hlm_use_sp.eq.ifalse)then new_cohort%treesai = tree_sai(new_cohort%pft, new_cohort%dbh, new_cohort%canopy_trim, & new_cohort%c_area, new_cohort%n, new_cohort%canopy_layer, & - patchptr%canopy_layer_tlai, new_cohort%treelai,new_cohort%vcmax25top,2 ) + patchptr%canopy_layer_tlai, new_cohort%treelai,new_cohort%vcmax25top,2 ) end if new_cohort%lai = new_cohort%treelai * new_cohort%c_area/patchptr%area @@ -291,7 +289,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & ! Put cohort at the right place in the linked list storebigcohort => patchptr%tallest - storesmallcohort => patchptr%shortest + storesmallcohort => patchptr%shortest if (associated(patchptr%tallest)) then tnull = 0 @@ -304,17 +302,17 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & snull = 0 else snull = 1 - patchptr%shortest => new_cohort + patchptr%shortest => new_cohort endif call InitPRTBoundaryConditions(new_cohort) - + ! Recuits do not have mortality rates, nor have they moved any ! carbon when they are created. They will bias our statistics ! until they have experienced a full day. We need a newly recruited flag. - ! This flag will be set to false after it has experienced + ! This flag will be set to false after it has experienced ! growth, disturbance and mortality. new_cohort%isnew = .true. @@ -331,14 +329,14 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & ! 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 InitPlantHydStates(currentSite,new_cohort) @@ -358,11 +356,11 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & endif endif - + call insert_cohort(new_cohort, patchptr%tallest, patchptr%shortest, tnull, snull, & storebigcohort, storesmallcohort) - patchptr%tallest => storebigcohort + patchptr%tallest => storebigcohort patchptr%shortest => storesmallcohort end subroutine create_cohort @@ -370,7 +368,7 @@ end subroutine create_cohort ! ------------------------------------------------------------------------------------- subroutine InitPRTBoundaryConditions(new_cohort) - + ! Set the boundary conditions that flow in an out of the PARTEH ! allocation hypotheses. Each of these calls to "RegsterBC" are simply ! setting pointers. @@ -394,9 +392,9 @@ subroutine InitPRTBoundaryConditions(new_cohort) select case(hlm_parteh_mode) case (prt_carbon_allom_hyp) - + ! Register boundary conditions for the Carbon Only Allometric Hypothesis - + call new_cohort%prt%RegisterBCInOut(ac_bc_inout_id_dbh,bc_rval = new_cohort%dbh) call new_cohort%prt%RegisterBCInOut(ac_bc_inout_id_netdc,bc_rval = new_cohort%npp_acc) call new_cohort%prt%RegisterBCIn(ac_bc_in_id_pft,bc_ival = new_cohort%pft) @@ -412,7 +410,7 @@ subroutine InitPRTBoundaryConditions(new_cohort) call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdnh4, bc_rval = new_cohort%daily_nh4_uptake) call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdno3, bc_rval = new_cohort%daily_no3_uptake) call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdp, bc_rval = new_cohort%daily_p_uptake) - + call new_cohort%prt%RegisterBCInOut(acnp_bc_inout_id_dbh,bc_rval = new_cohort%dbh) call new_cohort%prt%RegisterBCInOut(acnp_bc_inout_id_rmaint_def,bc_rval = new_cohort%resp_m_def) @@ -421,21 +419,21 @@ subroutine InitPRTBoundaryConditions(new_cohort) call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_pefflux, bc_rval = new_cohort%daily_p_efflux) call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_nneed, bc_rval = new_cohort%daily_n_need) call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_pneed, bc_rval = new_cohort%daily_p_need) - - + + case DEFAULT - + write(fates_log(),*) 'You specified an unknown PRT module' write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) - + end select - + end subroutine InitPRTBoundaryConditions ! ------------------------------------------------------------------------------------! - + subroutine InitPRTObject(prt) ! ----------------------------------------------------------------------------------- @@ -444,7 +442,7 @@ subroutine InitPRTObject(prt) ! The argument that is passed in is a pointer that is then associated with this ! newly allocated object. ! The object that is allocated is the specific extended class for the hypothesis - ! of choice. + ! of choice. ! Following this, the object and its internal mappings are initialized. ! This routine does NOT set any of the initial conditions, or boundary conditions ! such as the organ/element masses. Those are handled after this call. @@ -453,36 +451,36 @@ subroutine InitPRTObject(prt) ! Argument class(prt_vartypes), pointer :: prt - + ! Potential Extended types class(callom_prt_vartypes), pointer :: c_allom_prt class(cnp_allom_prt_vartypes), pointer :: cnp_allom_prt - + select case(hlm_parteh_mode) case (prt_carbon_allom_hyp) - + allocate(c_allom_prt) prt => c_allom_prt - + case (prt_cnp_flex_allom_hyp) - + allocate(cnp_allom_prt) prt => cnp_allom_prt case DEFAULT - + write(fates_log(),*) 'You specified an unknown PRT module' write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) - + end select - + ! This is the call to allocate the data structures in the PRT object ! This call will be extended to each specific class. call prt%InitPRTVartype() - + return end subroutine InitPRTObject @@ -493,14 +491,14 @@ end subroutine InitPRTObject subroutine nan_cohort(cc_p) ! ! !DESCRIPTION: - ! Make all the cohort variables NaN so they aren't used before defined. + ! Make all the cohort variables NaN so they aren't used before defined. ! ! !USES: use FatesConstantsMod, only : fates_unset_int ! - ! !ARGUMENTS + ! !ARGUMENTS type (ed_cohort_type), intent(inout), target :: cc_p ! ! !LOCAL VARIABLES: @@ -509,35 +507,35 @@ subroutine nan_cohort(cc_p) currentCohort => cc_p - currentCohort%taller => null() ! pointer to next tallest cohort - currentCohort%shorter => null() ! pointer to next shorter cohort + currentCohort%taller => null() ! pointer to next tallest cohort + currentCohort%shorter => null() ! pointer to next shorter cohort currentCohort%patchptr => null() ! pointer to patch that cohort is in - nullify(currentCohort%taller) - nullify(currentCohort%shorter) - nullify(currentCohort%patchptr) + nullify(currentCohort%taller) + nullify(currentCohort%shorter) + nullify(currentCohort%patchptr) ! VEGETATION STRUCTURE - currentCohort%pft = fates_unset_int ! pft number + currentCohort%pft = fates_unset_int ! pft number currentCohort%indexnumber = fates_unset_int ! unique number for each cohort. (within clump?) - currentCohort%canopy_layer = fates_unset_int ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) - currentCohort%canopy_layer_yesterday = nan ! recent canopy status of cohort (1 = canopy, 2 = understorey, etc.) + currentCohort%canopy_layer = fates_unset_int ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) + currentCohort%canopy_layer_yesterday = nan ! recent canopy status of cohort (1 = canopy, 2 = understorey, etc.) currentCohort%NV = fates_unset_int ! Number of leaf layers: - currentCohort%status_coh = fates_unset_int ! growth status of plant (2 = leaves on , 1 = leaves off) currentCohort%size_class = fates_unset_int ! size class index currentCohort%size_class_lasttimestep = fates_unset_int ! size class index currentCohort%size_by_pft_class = fates_unset_int ! size by pft classification index currentCohort%coage_class = fates_unset_int ! cohort age class index - currentCohort%coage_by_pft_class = fates_unset_int ! cohort age by pft class index + currentCohort%coage_by_pft_class = fates_unset_int ! cohort age by pft class index - currentCohort%n = nan ! number of individuals in cohort per 'area' (10000m2 default) + currentCohort%n = nan ! number of individuals in cohort per 'area' (10000m2 default) currentCohort%dbh = nan ! 'diameter at breast height' in cm currentCohort%coage = nan ! age of the cohort in years - currentCohort%hite = nan ! height: meters + currentCohort%hite = nan ! height: meters currentCohort%laimemory = nan ! target leaf biomass- set from previous year: kGC per indiv currentCohort%sapwmemory = nan ! target sapwood biomass- set from previous year: kGC per indiv currentCohort%structmemory = nan ! target structural biomass- set from previous year: kGC per indiv - currentCohort%lai = nan ! leaf area index of cohort m2/m2 + currentCohort%lai = nan ! leaf area index of cohort m2/m2 currentCohort%sai = nan ! stem area index of cohort m2/m2 currentCohort%g_sb_laweight = nan ! Total leaf conductance of cohort (stomata+blayer) weighted by leaf-area [m/s]*[m2] currentCohort%canopy_trim = nan ! What is the fraction of the maximum leaf biomass that we are targeting? :- @@ -548,18 +546,18 @@ subroutine nan_cohort(cc_p) currentCohort%treelai = nan ! lai of tree (total leaf area (m2) / canopy area (m2) currentCohort%treesai = nan ! stem area index of tree (total stem area (m2) / canopy area (m2) currentCohort%seed_prod = nan - currentCohort%vcmax25top = nan - currentCohort%jmax25top = nan - currentCohort%tpu25top = nan - currentCohort%kp25top = nan + currentCohort%vcmax25top = nan + currentCohort%jmax25top = nan + currentCohort%tpu25top = nan + currentCohort%kp25top = nan - ! CARBON FLUXES + ! CARBON FLUXES currentCohort%gpp_acc_hold = nan ! GPP: kgC/indiv/year currentCohort%gpp_tstep = nan ! GPP: kgC/indiv/timestep - currentCohort%gpp_acc = nan ! GPP: kgC/indiv/day + currentCohort%gpp_acc = nan ! GPP: kgC/indiv/day currentCohort%npp_acc_hold = nan ! NPP: kgC/indiv/year currentCohort%npp_tstep = nan ! NPP: kGC/indiv/timestep - currentCohort%npp_acc = nan ! NPP: kgC/indiv/day + currentCohort%npp_acc = nan ! NPP: kgC/indiv/day currentCohort%year_net_uptake(:) = nan ! Net uptake of individual leaf layers kgC/m2/year currentCohort%ts_net_uptake(:) = nan ! Net uptake of individual leaf layers kgC/m2/s currentCohort%resp_acc_hold = nan ! RESP: kgC/indiv/year @@ -577,8 +575,8 @@ subroutine nan_cohort(cc_p) currentCohort%daily_p_need = nan currentCohort%daily_n_demand = nan currentCohort%daily_p_demand = nan - - + + currentCohort%c13disc_clm = nan ! C13 discrimination, per mil at indiv/timestep currentCohort%c13disc_acc = nan ! C13 discrimination, per mil at indiv/timestep at indiv/daily at the end of a day @@ -586,9 +584,9 @@ subroutine nan_cohort(cc_p) currentCohort%rdark = nan currentCohort%resp_m = nan ! Maintenance respiration. kGC/cohort/year currentCohort%resp_m_def = nan ! Maintenance respiration deficit kgC/plant - currentCohort%livestem_mr = nan ! Live stem maintenance respiration. kgC/indiv/s-1 - currentCohort%livecroot_mr = nan ! Coarse root maintenance respiration. kgC/indiv/s-1 - currentCohort%froot_mr = nan ! Fine root maintenance respiration. kgC/indiv/s-1 + currentCohort%livestem_mr = nan ! Live stem maintenance respiration. kgC/indiv/s-1 + currentCohort%livecroot_mr = nan ! Coarse root maintenance respiration. kgC/indiv/s-1 + currentCohort%froot_mr = nan ! Fine root maintenance respiration. kgC/indiv/s-1 currentCohort%resp_g_tstep = nan ! Growth respiration. kGC/indiv/timestep @@ -606,10 +604,10 @@ subroutine nan_cohort(cc_p) currentCohort%treesai = nan ! stem area index of tree (total stem area (m2) / canopy area (m2) - ! VARIABLES NEEDED FOR INTEGRATION - currentCohort%dndt = nan ! time derivative of cohort size - currentCohort%dhdt = nan ! time derivative of height - currentCohort%ddbhdt = nan ! time derivative of dbh + ! VARIABLES NEEDED FOR INTEGRATION + currentCohort%dndt = nan ! time derivative of cohort size + currentCohort%dhdt = nan ! time derivative of height + currentCohort%ddbhdt = nan ! time derivative of dbh ! FIRE currentCohort%fraction_crown_burned = nan ! proportion of crown affected by fire @@ -624,12 +622,12 @@ end subroutine nan_cohort subroutine zero_cohort(cc_p) ! ! !DESCRIPTION: - ! Zero variables that need to be accounted for if - ! this cohort is altered before they are defined. + ! Zero variables that need to be accounted for if + ! this cohort is altered before they are defined. ! ! !USES: ! - ! !ARGUMENTS + ! !ARGUMENTS type (ed_cohort_type), intent(inout), target :: cc_p ! ! !LOCAL VARIABLES: @@ -638,8 +636,8 @@ subroutine zero_cohort(cc_p) currentCohort => cc_p - currentCohort%NV = 0 - currentCohort%status_coh = 0 + currentCohort%NV = 0 + currentCohort%status_coh = 0 currentCohort%rdark = 0._r8 currentCohort%resp_m = 0._r8 currentCohort%resp_m_def = 0._r8 @@ -647,7 +645,7 @@ subroutine zero_cohort(cc_p) currentCohort%livestem_mr = 0._r8 currentCohort%livecroot_mr = 0._r8 currentCohort%froot_mr = 0._r8 - currentCohort%fire_mort = 0._r8 + currentCohort%fire_mort = 0._r8 currentcohort%npp_acc = 0._r8 currentcohort%gpp_acc = 0._r8 currentcohort%resp_acc = 0._r8 @@ -656,28 +654,28 @@ subroutine zero_cohort(cc_p) currentcohort%resp_tstep = 0._r8 currentcohort%resp_acc_hold = 0._r8 - currentcohort%year_net_uptake(:) = 999._r8 ! this needs to be 999, or trimming of new cohorts will break. + currentcohort%year_net_uptake(:) = 999._r8 ! this needs to be 999, or trimming of new cohorts will break. currentcohort%ts_net_uptake(:) = 0._r8 - currentcohort%fraction_crown_burned = 0._r8 + currentcohort%fraction_crown_burned = 0._r8 currentCohort%size_class = 1 currentCohort%coage_class = 1 currentCohort%seed_prod = 0._r8 currentCohort%size_class_lasttimestep = 0 - currentcohort%npp_acc_hold = 0._r8 - currentcohort%gpp_acc_hold = 0._r8 - currentcohort%dmort = 0._r8 - currentcohort%g_sb_laweight = 0._r8 - currentcohort%treesai = 0._r8 + currentcohort%npp_acc_hold = 0._r8 + currentcohort%gpp_acc_hold = 0._r8 + currentcohort%dmort = 0._r8 + currentcohort%g_sb_laweight = 0._r8 + currentcohort%treesai = 0._r8 currentCohort%lmort_direct = 0._r8 currentCohort%lmort_infra = 0._r8 currentCohort%lmort_collateral = 0._r8 - currentCohort%l_degrad = 0._r8 + currentCohort%l_degrad = 0._r8 currentCohort%leaf_cost = 0._r8 currentcohort%excl_weight = 0._r8 currentcohort%prom_weight = 0._r8 currentcohort%crownfire_mort = 0._r8 currentcohort%cambial_mort = 0._r8 - currentCohort%c13disc_clm = 0._r8 + currentCohort%c13disc_clm = 0._r8 currentCohort%c13disc_acc = 0._r8 ! Daily nutrient fluxes are INTEGRATED over the course of the @@ -688,31 +686,31 @@ subroutine zero_cohort(cc_p) currentCohort%daily_nh4_uptake = 0._r8 currentCohort%daily_no3_uptake = 0._r8 currentCohort%daily_p_uptake = 0._r8 - + currentCohort%daily_c_efflux = 0._r8 currentCohort%daily_n_efflux = 0._r8 currentCohort%daily_p_efflux = 0._r8 - + currentCohort%daily_n_need = 0._r8 currentCohort%daily_p_need = 0._r8 ! Initialize these as negative currentCohort%daily_p_demand = -9._r8 currentCohort%daily_n_demand = -9._r8 - - + + end subroutine zero_cohort !-------------------------------------------------------------------------------------! subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_in) ! ! !DESCRIPTION: - ! terminates cohorts when they get too small + ! terminates cohorts when they get too small ! ! !USES: - + ! - ! !ARGUMENTS + ! !ARGUMENTS type (ed_site_type) , intent(inout), target :: currentSite type (ed_patch_type), intent(inout), target :: currentPatch integer , intent(in) :: level @@ -722,7 +720,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ ! Important point regarding termination levels. Termination is typically ! called after fusion. We do this so that we can re-capture the biomass that would ! otherwise be lost from termination. The biomass of a fused plant remains in the - ! live pool. However, some plant number densities can be so low that they + ! live pool. However, some plant number densities can be so low that they ! can cause numerical instabilities. Thus, we call terminate_cohorts at level=1 ! before fusion to get rid of these cohorts that are so incredibly sparse, and then ! terminate the remainder at level 2 for various other reasons. @@ -740,7 +738,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ real(r8) :: repro_c ! reproductive carbon [kg] real(r8) :: struct_c ! structural carbon [kg] integer :: terminate ! do we terminate (itrue) or not (ifalse) - integer :: c ! counter for litter size class. + integer :: c ! counter for litter size class. integer :: levcan ! canopy level !---------------------------------------------------------------------- @@ -764,14 +762,14 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ write(fates_log(),*) 'terminating cohorts 0',currentCohort%n/currentPatch%area,currentCohort%dbh,call_index endif endif - + ! The rest of these are only allowed if we are not dealing with a recruit (level 2) if (.not.currentCohort%isnew .and. level == 2) then ! Not enough n or dbh if (currentCohort%n/currentPatch%area <= min_npm2 .or. & ! currentCohort%n <= min_nppatch .or. & - (currentCohort%dbh < 0.00001_r8 .and. store_c < 0._r8) ) then + (currentCohort%dbh < 0.00001_r8 .and. store_c < 0._r8) ) then terminate = itrue if ( debug ) then write(fates_log(),*) 'terminating cohorts 1',currentCohort%n/currentPatch%area,currentCohort%dbh,call_index @@ -779,7 +777,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ endif ! Outside the maximum canopy layer - if (currentCohort%canopy_layer > nclmax ) then + if (currentCohort%canopy_layer > nclmax ) then terminate = itrue if ( debug ) then write(fates_log(),*) 'terminating cohorts 2', currentCohort%canopy_layer,call_index @@ -800,14 +798,14 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ if ( ( struct_c+sapw_c+leaf_c+fnrt_c+store_c ) < 0._r8) then terminate = itrue if ( debug ) then - write(fates_log(),*) 'terminating cohorts 4', & + write(fates_log(),*) 'terminating cohorts 4', & struct_c,sapw_c,leaf_c,fnrt_c,store_c,call_index endif - + endif endif ! if (.not.currentCohort%isnew .and. level == 2) then - if (terminate == itrue) then + if (terminate == itrue) then ! preserve a record of the to-be-terminated cohort for mortality accounting levcan = currentCohort%canopy_layer @@ -818,48 +816,48 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ if(levcan==ican_upper) then currentSite%term_nindivs_canopy(currentCohort%size_class,currentCohort%pft) = & currentSite%term_nindivs_canopy(currentCohort%size_class,currentCohort%pft) + currentCohort%n - + currentSite%term_carbonflux_canopy = currentSite%term_carbonflux_canopy + & currentCohort%n * (struct_c+sapw_c+leaf_c+fnrt_c+store_c+repro_c) else currentSite%term_nindivs_ustory(currentCohort%size_class,currentCohort%pft) = & currentSite%term_nindivs_ustory(currentCohort%size_class,currentCohort%pft) + currentCohort%n - + currentSite%term_carbonflux_ustory = currentSite%term_carbonflux_ustory + & currentCohort%n * (struct_c+sapw_c+leaf_c+fnrt_c+store_c+repro_c) end if - ! put the litter from the terminated cohorts + ! put the litter from the terminated cohorts ! straight into the fragmenting pools if (currentCohort%n.gt.0.0_r8) then call SendCohortToLitter(currentSite,currentPatch, & currentCohort,currentCohort%n,bc_in) end if - + ! Set pointers and remove the current cohort from the list shorterCohort => currentCohort%shorter - + if (.not. associated(tallerCohort)) then currentPatch%tallest => shorterCohort if(associated(shorterCohort)) shorterCohort%taller => null() - else + else tallerCohort%shorter => shorterCohort endif - + if (.not. associated(shorterCohort)) then currentPatch%shortest => tallerCohort if(associated(tallerCohort)) tallerCohort%shorter => null() - else + else shorterCohort%taller => tallerCohort endif - + call DeallocateCohort(currentCohort) deallocate(currentCohort) nullify(currentCohort) - + endif currentCohort => tallerCohort enddo @@ -869,15 +867,15 @@ end subroutine terminate_cohorts ! ===================================================================================== subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) - + ! ----------------------------------------------------------------------------------- ! This routine transfers the existing mass in all pools and all elements ! on a vegetation cohort, into the litter pool. - ! + ! ! Important: (1) This IS NOT turnover, this is not a partial transfer. ! (2) This is from a select number of plants in the cohort. ie this is ! not a "whole-sale" sending of all plants to litter. - ! (3) This does not affect the PER PLANT mass pools, so + ! (3) This does not affect the PER PLANT mass pools, so ! do not update any PARTEH structures. ! (4) The change in plant number density (due to death or termination) ! IS NOT handled here. @@ -893,7 +891,7 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) real(r8) :: nplant ! Number (absolute) ! of plants to transfer type(bc_in_type), intent(in) :: bc_in - + type(litter_type), pointer :: litt ! Litter object for each element type(site_fluxdiags_type),pointer :: flux_diags @@ -910,7 +908,7 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) integer :: pft ! pft index of the cohort integer :: sl ! loop index for soil layers integer :: dcmpy ! loop index for decomposability - + !---------------------------------------------------------------------- pft = ccohort%pft @@ -921,14 +919,14 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) bc_in%max_rooting_depth_index_col) do el=1,num_elements - + leaf_m = ccohort%prt%GetState(leaf_organ, element_list(el)) store_m = ccohort%prt%GetState(store_organ, element_list(el)) sapw_m = ccohort%prt%GetState(sapw_organ, element_list(el)) fnrt_m = ccohort%prt%GetState(fnrt_organ, element_list(el)) struct_m = ccohort%prt%GetState(struct_organ, element_list(el)) repro_m = ccohort%prt%GetState(repro_organ, element_list(el)) - + litt => cpatch%litter(el) flux_diags => csite%flux_diags(el) @@ -958,13 +956,13 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) (1.0_r8 - prt_params%allom_agb_frac(pft)) * nplant enddo - + do dcmpy=1,ndcmpy dcmpy_frac = GetDecompyFrac(pft,leaf_organ,dcmpy) - + litt%leaf_fines(dcmpy) = litt%leaf_fines(dcmpy) + & plant_dens * (leaf_m+repro_m) * dcmpy_frac - + dcmpy_frac = GetDecompyFrac(pft,fnrt_organ,dcmpy) do sl=1,csite%nlevsoil litt%root_fines(dcmpy,sl) = litt%root_fines(dcmpy,sl) + & @@ -979,10 +977,10 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) flux_diags%root_litter_input(pft) = & flux_diags%root_litter_input(pft) + & (fnrt_m+store_m) * nplant - - + + end do - + return end subroutine SendCohortToLitter @@ -998,27 +996,27 @@ subroutine DeallocateCohort(currentCohort) ! inside the cohort structure. This DOES NOT deallocate ! the cohort structure itself. ! ---------------------------------------------------------------------------------- - + type(ed_cohort_type),intent(inout) :: currentCohort - + ! At this point, nothing should be pointing to current Cohort if (hlm_use_planthydro.eq.itrue) call DeallocateHydrCohort(currentCohort) - + ! Deallocate the cohort's PRT structures call currentCohort%prt%DeallocatePRTVartypes() - + ! Deallocate the PRT object deallocate(currentCohort%prt) - + return end subroutine DeallocateCohort - - subroutine fuse_cohorts(currentSite, currentPatch, bc_in) + + subroutine fuse_cohorts(currentSite, currentPatch, bc_in) ! ! !DESCRIPTION: - ! Join similar cohorts to reduce total number + ! Join similar cohorts to reduce total number ! ! !USES: use EDParamsMod , only : ED_val_cohort_size_fusion_tol @@ -1027,10 +1025,10 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) use FatesConstantsMod , only : itrue use FatesConstantsMod, only : days_per_year use EDTypesMod , only : maxCohortsPerPatch - + ! - ! !ARGUMENTS - type (ed_site_type), intent(inout), target :: currentSite + ! !ARGUMENTS + type (ed_site_type), intent(inout), target :: currentSite type (ed_patch_type), intent(inout), target :: currentPatch type (bc_in_type), intent(in) :: bc_in ! @@ -1043,7 +1041,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) type (ed_cohort_type) , pointer :: shorterCohort type (ed_cohort_type) , pointer :: tallerCohort - integer :: i + integer :: i integer :: fusion_took_place integer :: iterate ! do we need to keep fusing to get below maxcohorts? integer :: nocohorts @@ -1052,7 +1050,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) real(r8) :: coage_diff real(r8) :: leaf_c_next ! Leaf carbon * plant density of current (for weighting) real(r8) :: leaf_c_curr ! Leaf carbon * plant density of next (for weighting) - real(r8) :: leaf_c_target + real(r8) :: leaf_c_target real(r8) :: dynamic_size_fusion_tolerance real(r8) :: dynamic_age_fusion_tolerance real(r8) :: dbh @@ -1073,47 +1071,47 @@ 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 - + !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 !because c_area and biomass are non-linear with dbh, this causes several mass inconsistancies - !in theory, all of this routine therefore causes minor losses of C and area, but these are below - !detection limit normally. + !in theory, all of this routine therefore causes minor losses of C and area, but these are below + !detection limit normally. iterate = 1 - fusion_took_place = 0 + fusion_took_place = 0 + - !---------------------------------------------------------------------! ! Keep doing this until nocohorts <= maxcohorts ! !---------------------------------------------------------------------! - - if (associated(currentPatch%shortest)) then + + if (associated(currentPatch%shortest)) then do while(iterate == 1) - + currentCohort => currentPatch%tallest - + ! The following logic continues the loop while the current cohort is not the shortest cohort ! if they point to the same target (ie equivalence), then the loop ends. ! This loop is different than the simple "continue while associated" loop in that ! it omits the last cohort (because it has already been compared by that point) - + do while ( .not.associated(currentCohort,currentPatch%shortest) ) nextc => currentPatch%tallest do while (associated(nextc)) nextnextc => nextc%shorter - diff = abs((currentCohort%dbh - nextc%dbh)/(0.5_r8*(currentCohort%dbh + nextc%dbh))) + diff = abs((currentCohort%dbh - nextc%dbh)/(0.5_r8*(currentCohort%dbh + nextc%dbh))) !Criteria used to divide up the height continuum into different cohorts. if (diff < dynamic_size_fusion_tolerance) then - ! Only fuse if the cohorts are within x years of each other + ! Only fuse if the cohorts are within x years of each other ! if they are the same age we make diff 0- to avoid errors divding by zero !NB if cohort age tracking is off then the age of both should be 0 - ! and hence the age fusion criterion is met + ! and hence the age fusion criterion is met if (abs(currentCohort%coage - nextc%coage) shorterCohort if(associated(shorterCohort)) shorterCohort%taller => null() - else + else tallerCohort%shorter => shorterCohort endif if (.not. associated(shorterCohort)) then currentPatch%shortest => tallerCohort if(associated(tallerCohort)) tallerCohort%shorter => null() - else + else shorterCohort%taller => tallerCohort endif ! At this point, nothing should be pointing to current Cohort ! update hydraulics quantities that are functions of hite & biomasses ! deallocate the hydro structure of nextc - if (hlm_use_planthydro.eq.itrue) then + if (hlm_use_planthydro.eq.itrue) then call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) currentCohort%treelai = tree_lai(leaf_c, & currentCohort%pft, currentCohort%c_area, currentCohort%n, & currentCohort%canopy_layer, currentPatch%canopy_layer_tlai, & - currentCohort%vcmax25top ) - call UpdateSizeDepPlantHydProps(currentSite,currentCohort, bc_in) + currentCohort%vcmax25top ) + 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 endif !pft - endif !index no. - endif ! cohort age diff - endif !diff + endif !index no. + endif ! cohort age diff + endif !diff nextc => nextnextc @@ -1518,12 +1515,12 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) if (associated (currentCohort%shorter)) then currentCohort => currentCohort%shorter endif - + enddo !end currentCohort cohort loop !---------------------------------------------------------------------! ! Is the number of cohorts larger than the maximum? ! - !---------------------------------------------------------------------! + !---------------------------------------------------------------------! nocohorts = 0 currentCohort => currentPatch%tallest do while(associated(currentCohort)) @@ -1537,7 +1534,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) iterate = 1 !---------------------------------------------------------------------! ! Making profile tolerance larger means that more fusion will happen ! - !---------------------------------------------------------------------! + !---------------------------------------------------------------------! dynamic_size_fusion_tolerance = dynamic_size_fusion_tolerance * 1.1_r8 dynamic_age_fusion_tolerance = dynamic_age_fusion_tolerance * 1.1_r8 !write(fates_log(),*) 'maxcohorts exceeded',dynamic_fusion_tolerance @@ -1547,13 +1544,13 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) iterate = 0 endif - else + else if (nocohorts > maxCohortsPerPatch) then iterate = 1 !---------------------------------------------------------------------! ! Making profile tolerance larger means that more fusion will happen ! - !---------------------------------------------------------------------! + !---------------------------------------------------------------------! dynamic_size_fusion_tolerance = dynamic_size_fusion_tolerance * 1.1_r8 !write(fates_log(),*) 'maxcohorts exceeded',dynamic_fusion_tolerance @@ -1563,7 +1560,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) endif end if - + if ( dynamic_size_fusion_tolerance .gt. 100._r8) then ! something has gone terribly wrong and we need to report what write(fates_log(),*) 'exceeded reasonable expectation of cohort fusion.' @@ -1580,9 +1577,9 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) enddo !do while nocohorts>maxcohorts - endif ! patch. + endif ! patch. - if (fusion_took_place == 1) then ! if fusion(s) occured sort cohorts + if (fusion_took_place == 1) then ! if fusion(s) occured sort cohorts call sort_cohorts(currentPatch) endif @@ -1590,7 +1587,7 @@ end subroutine fuse_cohorts !-------------------------------------------------------------------------------------! - subroutine sort_cohorts(patchptr) + subroutine sort_cohorts(patchptr) ! ============================================================================ ! sort cohorts into the correct order DO NOT CHANGE THIS IT WILL BREAK ! ============================================================================ @@ -1599,9 +1596,9 @@ subroutine sort_cohorts(patchptr) type(ed_patch_type) , pointer :: current_patch type(ed_cohort_type), pointer :: current_c, next_c - type(ed_cohort_type), pointer :: shortestc, tallestc - type(ed_cohort_type), pointer :: storesmallcohort - type(ed_cohort_type), pointer :: storebigcohort + type(ed_cohort_type), pointer :: shortestc, tallestc + type(ed_cohort_type), pointer :: storesmallcohort + type(ed_cohort_type), pointer :: storebigcohort integer :: snull,tnull current_patch => patchptr @@ -1609,12 +1606,12 @@ subroutine sort_cohorts(patchptr) shortestc => NULL() storebigcohort => null() storesmallcohort => null() - current_c => current_patch%tallest + current_c => current_patch%tallest - do while (associated(current_c)) + do while (associated(current_c)) next_c => current_c%shorter - tallestc => storebigcohort - shortestc => storesmallcohort + tallestc => storebigcohort + shortestc => storesmallcohort if (associated(tallestc)) then tnull = 0 else @@ -1631,7 +1628,7 @@ subroutine sort_cohorts(patchptr) call insert_cohort(current_c, tallestc, shortestc, tnull, snull, storebigcohort, storesmallcohort) - current_patch%tallest => storebigcohort + current_patch%tallest => storebigcohort current_patch%shortest => storesmallcohort current_c => next_c @@ -1643,24 +1640,24 @@ end subroutine sort_cohorts subroutine insert_cohort(pcc, ptall, pshort, tnull, snull, storebigcohort, storesmallcohort) ! ! !DESCRIPTION: - ! Insert cohort into linked list + ! Insert cohort into linked list ! ! !USES: ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_cohort_type) , intent(inout), target :: pcc type(ed_cohort_type) , intent(inout), target :: ptall type(ed_cohort_type) , intent(inout), target :: pshort integer , intent(in) :: tnull integer , intent(in) :: snull type(ed_cohort_type) , intent(inout),pointer,optional :: storesmallcohort ! storage of the smallest cohort for insertion routine - type(ed_cohort_type) , intent(inout),pointer,optional :: storebigcohort ! storage of the largest cohort for insertion routine + type(ed_cohort_type) , intent(inout),pointer,optional :: storebigcohort ! storage of the largest cohort for insertion routine ! ! !LOCAL VARIABLES: type(ed_patch_type), pointer :: currentPatch type(ed_cohort_type), pointer :: current type(ed_cohort_type), pointer :: tallptr, shortptr, icohort - type(ed_cohort_type), pointer :: ptallest, pshortest + type(ed_cohort_type), pointer :: ptallest, pshortest real(r8) :: tsp integer :: tallptrnull,exitloop !---------------------------------------------------------------------- @@ -1676,21 +1673,21 @@ subroutine insert_cohort(pcc, ptall, pshort, tnull, snull, storebigcohort, store pshortest => null() endif - icohort => pcc ! assign address to icohort local name - !place in the correct place in the linked list of heights - !begin by finding cohort that is just taller than the new cohort + icohort => pcc ! assign address to icohort local name + !place in the correct place in the linked list of heights + !begin by finding cohort that is just taller than the new cohort tsp = icohort%hite current => pshortest exitloop = 0 - !starting with shortest tree on the grid, find tree just - !taller than tree being considered and return its pointer + !starting with shortest tree on the grid, find tree just + !taller than tree being considered and return its pointer if (associated(current)) then do while (associated(current).and.exitloop == 0) if (current%hite < tsp) then - current => current%taller + current => current%taller else - exitloop = 1 + exitloop = 1 endif enddo endif @@ -1703,48 +1700,48 @@ subroutine insert_cohort(pcc, ptall, pshort, tnull, snull, storebigcohort, store tallptrnull = 1 endif - !new cohort is tallest - if (.not.associated(tallptr)) then - !new shorter cohort to the new cohort is the old tallest cohort + !new cohort is tallest + if (.not.associated(tallptr)) then + !new shorter cohort to the new cohort is the old tallest cohort shortptr => ptallest - !new cohort is tallest cohort and next taller remains null + !new cohort is tallest cohort and next taller remains null ptallest => icohort if (present(storebigcohort)) then storebigcohort => icohort end if - currentPatch%tallest => icohort - icohort%patchptr%tallest => icohort - !new cohort is not tallest + currentPatch%tallest => icohort + icohort%patchptr%tallest => icohort + !new cohort is not tallest else - !next shorter cohort to new cohort is the next shorter cohort - !to the cohort just taller than the new cohort + !next shorter cohort to new cohort is the next shorter cohort + !to the cohort just taller than the new cohort shortptr => tallptr%shorter - !new cohort becomes the next shorter cohort to the cohort - !just taller than the new cohort + !new cohort becomes the next shorter cohort to the cohort + !just taller than the new cohort tallptr%shorter => icohort endif - !new cohort is shortest + !new cohort is shortest if (.not.associated(shortptr)) then - !next shorter reamins null - !cohort is placed at the bottom of the list + !next shorter reamins null + !cohort is placed at the bottom of the list pshortest => icohort if (present(storesmallcohort)) then - storesmallcohort => icohort + storesmallcohort => icohort end if - currentPatch%shortest => icohort - icohort%patchptr%shortest => icohort + currentPatch%shortest => icohort + icohort%patchptr%shortest => icohort else - !new cohort is not shortest and becomes next taller cohort - !to the cohort just below it as defined in the previous block + !new cohort is not shortest and becomes next taller cohort + !to the cohort just below it as defined in the previous block shortptr%taller => icohort endif - ! assign taller and shorter links for the new cohort + ! assign taller and shorter links for the new cohort icohort%taller => tallptr - if (tallptrnull == 1) then + if (tallptrnull == 1) then icohort%taller=> null() endif icohort%shorter => shortptr @@ -1755,11 +1752,11 @@ end subroutine insert_cohort subroutine copy_cohort( currentCohort,copyc ) ! ! !DESCRIPTION: - ! Copies all the variables in one cohort into another empty cohort + ! Copies all the variables in one cohort into another empty cohort ! ! !USES: ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_cohort_type), intent(inout) , target :: copyc ! New cohort argument. type(ed_cohort_type), intent(in) , target :: currentCohort ! Old cohort argument. ! @@ -1771,18 +1768,18 @@ subroutine copy_cohort( currentCohort,copyc ) n => copyc n%indexnumber = fates_unset_int - + ! VEGETATION STRUCTURE n%pft = o%pft - n%n = o%n + n%n = o%n n%dbh = o%dbh - n%coage = o%coage + n%coage = o%coage n%hite = o%hite n%laimemory = o%laimemory n%sapwmemory = o%sapwmemory n%structmemory = o%structmemory - n%lai = o%lai - n%sai = o%sai + n%lai = o%lai + n%sai = o%sai n%g_sb_laweight = o%g_sb_laweight n%leaf_cost = o%leaf_cost n%canopy_layer = o%canopy_layer @@ -1790,8 +1787,8 @@ subroutine copy_cohort( currentCohort,copyc ) n%nv = o%nv n%status_coh = o%status_coh n%canopy_trim = o%canopy_trim - n%excl_weight = o%excl_weight - n%prom_weight = o%prom_weight + n%excl_weight = o%excl_weight + n%prom_weight = o%prom_weight n%size_class = o%size_class n%size_class_lasttimestep = o%size_class_lasttimestep n%size_by_pft_class = o%size_by_pft_class @@ -1804,7 +1801,7 @@ subroutine copy_cohort( currentCohort,copyc ) n%vcmax25top = o%vcmax25top n%jmax25top = o%jmax25top n%tpu25top = o%tpu25top - n%kp25top = o%kp25top + n%kp25top = o%kp25top ! CARBON FLUXES n%gpp_acc_hold = o%gpp_acc_hold @@ -1834,7 +1831,7 @@ subroutine copy_cohort( currentCohort,copyc ) n%daily_p_need = o%daily_p_need n%daily_n_demand = o%daily_n_demand n%daily_p_demand = o%daily_p_demand - + ! C13 discrimination n%c13disc_clm = o%c13disc_clm n%c13disc_acc = o%c13disc_acc @@ -1847,7 +1844,7 @@ subroutine copy_cohort( currentCohort,copyc ) n%livestem_mr = o%livestem_mr n%livecroot_mr = o%livecroot_mr n%froot_mr = o%froot_mr - + ! ALLOCATION n%dmort = o%dmort n%seed_prod = o%seed_prod @@ -1868,12 +1865,12 @@ subroutine copy_cohort( currentCohort,copyc ) n%lmort_direct =o%lmort_direct n%lmort_collateral =o%lmort_collateral n%lmort_infra =o%lmort_infra - n%l_degrad =o%l_degrad + n%l_degrad =o%l_degrad ! Flags n%isnew = o%isnew - ! VARIABLES NEEDED FOR INTEGRATION + ! VARIABLES NEEDED FOR INTEGRATION n%dndt = o%dndt n%dhdt = o%dhdt n%ddbhdt = o%ddbhdt @@ -1885,7 +1882,7 @@ subroutine copy_cohort( currentCohort,copyc ) n%cambial_mort = o%cambial_mort ! Plant Hydraulics - + if( hlm_use_planthydro.eq.itrue ) then call CopyCohortHydraulics(n,o) endif @@ -1896,11 +1893,11 @@ subroutine copy_cohort( currentCohort,copyc ) n%size_by_pft_class = o%size_by_pft_class n%coage_class = o%coage_class n%coage_by_pft_class = o%coage_by_pft_class - + !Pointers - n%taller => NULL() ! pointer to next tallest cohort - n%shorter => NULL() ! pointer to next shorter cohort - n%patchptr => o%patchptr ! pointer to patch that cohort is in + n%taller => NULL() ! pointer to next tallest cohort + n%shorter => NULL() ! pointer to next shorter cohort + n%patchptr => o%patchptr ! pointer to patch that cohort is in end subroutine copy_cohort @@ -1911,7 +1908,7 @@ subroutine count_cohorts( currentPatch ) ! ! !USES: ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_patch_type), intent(inout), target :: currentPatch !new site ! ! !LOCAL VARIABLES: @@ -1922,20 +1919,20 @@ subroutine count_cohorts( currentPatch ) currentCohort => currentPatch%shortest currentPatch%countcohorts = 0 - do while (associated(currentCohort)) - currentPatch%countcohorts = currentPatch%countcohorts + 1 - currentCohort => currentCohort%taller + do while (associated(currentCohort)) + currentPatch%countcohorts = currentPatch%countcohorts + 1 + currentCohort => currentCohort%taller enddo backcount = 0 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) backcount = backcount + 1 - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo if (backcount /= currentPatch%countcohorts) then - write(fates_log(),*) 'problem with linked list, not symmetrical' + write(fates_log(),*) 'problem with linked list, not symmetrical' endif end subroutine count_cohorts @@ -1955,8 +1952,8 @@ subroutine UpdateCohortBioPhysRates(currentCohort) ! -------------------------------------------------------------------------------- type(ed_cohort_type),intent(inout) :: currentCohort - - + + real(r8) :: frac_leaf_aclass(max_nleafage) ! Fraction of leaves in each age-class integer :: iage ! loop index for leaf ages integer :: ipft ! plant functional type index @@ -1973,29 +1970,29 @@ subroutine UpdateCohortBioPhysRates(currentCohort) ! If there are leaves, then perform proportional weighting on the four rates ! We assume that leaf age does not effect the specific leaf area, so the mass ! fractions are applicable to these rates - + if(sum(frac_leaf_aclass(1:nleafage))>nearzero) then ipft = currentCohort%pft frac_leaf_aclass(1:nleafage) = frac_leaf_aclass(1:nleafage) / & sum(frac_leaf_aclass(1:nleafage)) - + currentCohort%vcmax25top = sum(EDPftvarcon_inst%vcmax25top(ipft,1:nleafage) * & frac_leaf_aclass(1:nleafage)) - + currentCohort%jmax25top = sum(param_derived%jmax25top(ipft,1:nleafage) * & frac_leaf_aclass(1:nleafage)) - + currentCohort%tpu25top = sum(param_derived%tpu25top(ipft,1:nleafage) * & frac_leaf_aclass(1:nleafage)) - - currentCohort%kp25top = sum(param_derived%kp25top(ipft,1:nleafage) * & + + currentCohort%kp25top = sum(param_derived%kp25top(ipft,1:nleafage) * & frac_leaf_aclass(1:nleafage)) else - - currentCohort%vcmax25top = 0._r8 + + currentCohort%vcmax25top = 0._r8 currentCohort%jmax25top = 0._r8 currentCohort%tpu25top = 0._r8 currentCohort%kp25top = 0._r8 @@ -2006,15 +2003,15 @@ subroutine UpdateCohortBioPhysRates(currentCohort) return end subroutine UpdateCohortBioPhysRates - + ! ============================================================================ subroutine EvaluateAndCorrectDBH(currentCohort,delta_dbh,delta_hite) ! ----------------------------------------------------------------------------------- - ! If the current diameter of a plant is somehow less than what is allometrically - ! consistent with stuctural biomass (or, in the case of grasses, leaf biomass) + ! If the current diameter of a plant is somehow less than what is allometrically + ! consistent with stuctural biomass (or, in the case of grasses, leaf biomass) ! then correct (increase) the dbh to match that. ! ----------------------------------------------------------------------------------- @@ -2022,7 +2019,7 @@ subroutine EvaluateAndCorrectDBH(currentCohort,delta_dbh,delta_hite) type(ed_cohort_type),intent(inout) :: currentCohort real(r8),intent(out) :: delta_dbh real(r8),intent(out) :: delta_hite - + ! locals real(r8) :: dbh real(r8) :: canopy_trim @@ -2036,44 +2033,44 @@ subroutine EvaluateAndCorrectDBH(currentCohort,delta_dbh,delta_hite) real(r8) :: struct_c real(r8) :: hite_out real(r8) :: leaf_c - + dbh = currentCohort%dbh ipft = currentCohort%pft canopy_trim = currentCohort%canopy_trim delta_dbh = 0._r8 delta_hite = 0._r8 - + if( int(prt_params%woody(currentCohort%pft)) == itrue) then struct_c = currentCohort%prt%GetState(struct_organ, all_carbon_elements) - + ! Target sapwood biomass according to allometry and trimming [kgC] call bsap_allom(dbh,ipft,canopy_trim,sapw_area,target_sapw_c) - + ! Target total above ground biomass in woody/fibrous tissues [kgC] call bagw_allom(dbh,ipft,target_agw_c) - - ! Target total below ground biomass in woody/fibrous tissues [kgC] + + ! Target total below ground biomass in woody/fibrous tissues [kgC] call bbgw_allom(dbh,ipft,target_bgw_c) - + ! Target total dead (structrual) biomass [kgC] call bdead_allom( target_agw_c, target_bgw_c, target_sapw_c, ipft, target_struct_c) - + ! ------------------------------------------------------------------------------------ ! If structure is larger than target, then we need to correct some integration errors ! by slightly increasing dbh to match it. ! For grasses, if leaf biomass is larger than target, then we reset dbh to match ! ----------------------------------------------------------------------------------- - + if( (struct_c - target_struct_c ) > calloc_abs_error ) then call ForceDBH( ipft, canopy_trim, dbh, hite_out, bdead=struct_c ) - delta_dbh = dbh - currentCohort%dbh + delta_dbh = dbh - currentCohort%dbh delta_hite = hite_out - currentCohort%hite currentCohort%dbh = dbh currentCohort%hite = hite_out end if - + else ! This returns the sum of leaf carbon over all (age) bins @@ -2084,15 +2081,15 @@ subroutine EvaluateAndCorrectDBH(currentCohort,delta_dbh,delta_hite) if( ( leaf_c - target_leaf_c ) > calloc_abs_error ) then call ForceDBH( ipft, canopy_trim, dbh, hite_out, bl=leaf_c ) - delta_dbh = dbh - currentCohort%dbh + delta_dbh = dbh - currentCohort%dbh delta_hite = hite_out - currentCohort%hite currentCohort%dbh = dbh currentCohort%hite = hite_out end if - + end if return end subroutine EvaluateAndCorrectDBH - + end module EDCohortDynamicsMod diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 68763c5a97..f0df5f9067 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -242,14 +242,11 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! as litter fluxes from live trees call CWDInput(currentSite, currentPatch, litt,bc_in) - ! Only calculate fragmentation flux over layers that are active ! (RGK-Mar2019) SHOULD WE MAX THIS AT 1? DONT HAVE TO nlev_eff_decomp = max(bc_in%max_rooting_depth_index_col, 1) call CWDOut(litt,currentPatch%fragmentation_scaler,nlev_eff_decomp) - write(fates_log(),*) 'PreDistLittFlux: sum ag_cwd_frag: ', sum(litt%ag_cwd_frag) - site_mass => currentSite%mass_balance(el) From ec99726ba4e5a9997228198861145da46ec6d1b2 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 13 Aug 2021 15:47:33 -0700 Subject: [PATCH 377/578] refactoring the linked list for zero patch area with nocomp --- main/EDInitMod.F90 | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 991281ec48..bb06f57de1 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -434,7 +434,6 @@ subroutine init_patches( nsites, sites, bc_in) type(ed_site_type), pointer :: sitep type(ed_patch_type), pointer :: newppft(:) type(ed_patch_type), pointer :: newp - type(ed_patch_type), pointer :: recall_older_patch type(ed_patch_type), pointer :: currentPatch ! List out some nominal patch values that are used for Near Bear Ground initializations @@ -469,7 +468,6 @@ subroutine init_patches( nsites, sites, bc_in) else - allocate(recall_older_patch) do s = 1, nsites sites(s)%sp_tlai(:) = 0._r8 sites(s)%sp_tsai(:) = 0._r8 @@ -536,16 +534,15 @@ subroutine init_patches( nsites, sites, bc_in) sites(s)%youngest_patch => newp sites(s)%oldest_patch => newp is_first_patch = ifalse - else ! the new patch is the 'oldest' one, arbitrarily. + else ! Set pointers for N>1 patches. Note this only happens when nocomp mode s on. ! The new patch is the 'youngest' one, arbitrarily. newp%patchno = nocomp_pft - newp%older => recall_older_patch + newp%older => sites(s)%youngest_patch newp%younger => null() - recall_older_patch%younger => newp + sites(s)%youngest_patch%younger => newp sites(s)%youngest_patch => newp end if - recall_older_patch => newp ! remember this patch for the next one to point at. ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches From 51112204bf678dc9b68d0a80f89e01814b805224 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 13 Aug 2021 16:06:18 -0700 Subject: [PATCH 378/578] Slight refactoring ed_ecosystems_dynamics for simplicity Refactored the do_patch_dynamics check added for SP mode as well as some older duplicate logic checks that can be combined. --- main/EDMainMod.F90 | 310 ++++++++++++++++++++++----------------------- 1 file changed, 149 insertions(+), 161 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 4fcfd82ed0..48820e5ad6 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -1,11 +1,11 @@ module EDMainMod ! =========================================================================== - ! Main ED module. + ! Main ED module. ! ============================================================================ use shr_kind_mod , only : r8 => shr_kind_r8 - + use FatesGlobals , only : fates_log use FatesInterfaceTypesMod , only : hlm_freq_day @@ -13,13 +13,13 @@ module EDMainMod 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_current_day use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_parteh_mode 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 : hlm_use_ed_st3 use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : bc_out_type @@ -52,7 +52,7 @@ module EDMainMod use EDCohortDynamicsMod , only : UpdateCohortBioPhysRates use FatesSoilBGCFluxMod , only : PrepNutrientAquisitionBCs use FatesSoilBGCFluxMod , only : PrepCH4BCs - use SFMainMod , only : fire_model + use SFMainMod , only : fire_model use FatesSizeAgeTypeIndicesMod, only : get_age_class_index use FatesSizeAgeTypeIndicesMod, only : coagetype_class_index use FatesLitterMod , only : litter_type @@ -74,7 +74,7 @@ module EDMainMod use FatesPlantHydraulicsMod , only : UpdateSizeDepPlantHydProps use FatesPlantHydraulicsMod , only : UpdateSizeDepPlantHydStates use FatesPlantHydraulicsMod , only : InitPlantHydStates - use FatesPlantHydraulicsMod , only : UpdateSizeDepRhizHydProps + use FatesPlantHydraulicsMod , only : UpdateSizeDepRhizHydProps use FatesPlantHydraulicsMod , only : AccumulateMortalityWaterStorage use FatesAllometryMod , only : h_allom,tree_sai,tree_lai use FatesPlantHydraulicsMod , only : UpdateSizeDepRhizHydStates @@ -112,18 +112,18 @@ module EDMainMod public :: ed_update_site ! ! !PRIVATE MEMBER FUNCTIONS: - + private :: ed_integrate_state_variables private :: TotalBalanceCheck private :: bypass_dynamics - + logical :: debug = .false. integer, parameter :: final_check_id = -1 - + character(len=*), parameter, private :: sourcefile = & __FILE__ - + ! ! 10/30/09: Created by Rosie Fisher !----------------------------------------------------------------------- @@ -134,7 +134,7 @@ module EDMainMod subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) ! ! !DESCRIPTION: - ! Core of ed model, calling all subsequent vegetation dynamics routines + ! Core of ed model, calling all subsequent vegetation dynamics routines ! ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite @@ -143,7 +143,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) ! ! !LOCAL VARIABLES: type(ed_patch_type), pointer :: currentPatch - integer :: el ! Loop counter for elements + integer :: el ! Loop counter for elements integer :: do_patch_dynamics ! for some modes, we turn off patch dynamics !----------------------------------------------------------------------- @@ -151,9 +151,9 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) if ( hlm_masterproc==itrue ) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& hlm_current_year,'-',hlm_current_month,'-',hlm_current_day - ! Consider moving this towards the end, because some of these + ! Consider moving this towards the end, because some of these ! are being integrated over the short time-step - + do el = 1,num_elements call currentSite%mass_balance(el)%ZeroMassBalFlux() call currentSite%flux_diags(el)%ZeroFluxDiags() @@ -164,9 +164,9 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) call IsItLoggingTime(hlm_masterproc,currentSite) !************************************************************************** - ! Fire, growth, biogeochemistry. + ! Fire, growth, biogeochemistry. !************************************************************************** - + !FIX(SPM,032414) take this out. On startup these values are all zero and on restart it !zeros out values read in the restart file @@ -176,7 +176,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) ! Zero fluxes in and out of litter pools call ZeroLitterFluxes(currentSite) - ! Zero mass balance + ! Zero mass balance call TotalBalanceCheck(currentSite, 0) ! We do not allow phenology while in ST3 mode either, it is hypothetically @@ -185,23 +185,22 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) if (hlm_use_ed_st3.eq.ifalse)then if(hlm_use_sp.eq.ifalse) then call phenology(currentSite, bc_in ) - else + else call satellite_phenology(currentSite, bc_in ) end if ! SP phenology end if if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.ifalse) then ! Bypass if ST3 - call fire_model(currentSite, bc_in) + call fire_model(currentSite, bc_in) ! Calculate disturbance and mortality based on previous timestep vegetation. ! disturbance_rates calls logging mortality and other mortalities, Yi Xu call disturbance_rates(currentSite, bc_in) - end if - if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.ifalse) then ! Integrate state variables from annual rates to daily timestep - call ed_integrate_state_variables(currentSite, bc_in, bc_out ) + call ed_integrate_state_variables(currentSite, bc_in, bc_out ) + else ! ed_intergrate_state_variables is where the new cohort flag ! is set. This flag designates wether a cohort has @@ -210,44 +209,41 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) ! Make sure cohorts are marked as non-recruits call bypass_dynamics(currentSite) - + end if !****************************************************************************** - ! Reproduction, Recruitment and Cohort Dynamics : controls cohort organization + ! Reproduction, Recruitment and Cohort Dynamics : controls cohort organization !****************************************************************************** - if(hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.ifalse) then + if(hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.ifalse) then currentPatch => currentSite%oldest_patch - do while (associated(currentPatch)) - + do while (associated(currentPatch)) + ! adds small cohort of each PFT call recruitment(currentSite, currentPatch, bc_in) - + currentPatch => currentPatch%younger enddo - end if - - call TotalBalanceCheck(currentSite,1) + call TotalBalanceCheck(currentSite,1) - if( hlm_use_ed_st3.eq.ifalse .and.hlm_use_sp.eq.ifalse ) then currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) - + ! puts cohorts in right order - call sort_cohorts(currentPatch) + call sort_cohorts(currentPatch) ! kills cohorts that are too few call terminate_cohorts(currentSite, currentPatch, 1, 10, bc_in ) ! fuses similar cohorts call fuse_cohorts(currentSite,currentPatch, bc_in ) - + ! kills cohorts for various other reasons call terminate_cohorts(currentSite, currentPatch, 2, 10, bc_in ) - - + + currentPatch => currentPatch%younger enddo end if @@ -259,58 +255,50 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) !********************************************************************************* do_patch_dynamics = itrue - if(hlm_use_ed_st3.eq.itrue)then - do_patch_dynamics = ifalse - end if - - if(hlm_use_nocomp.eq.itrue)then - ! n.b. the this is currently set to false to get around a memory leak that occurs - ! when we have multiple patches for each PFT. + if(hlm_use_ed_st3.eq.itrue .or. & + hlm_use_nocomp.eq.itrue .or. & + hlm_use_sp.eq.itrue)then + ! n.b. this is currently set to false to get around a memory leak that occurs + ! when we have multiple patches for each PFT. ! when this is fixed, we will need another option for 'one patch per PFT' vs 'multiple patches per PFT' - do_patch_dynamics = ifalse - end if - - if(hlm_use_sp.eq.itrue)then ! cover for potential changes in nocomp logic above. + ! hlm_use_sp check provides cover for potential changes in nocomp logic (nocomp required by spmode, but + ! not the other way around). do_patch_dynamics = ifalse end if - + ! make new patches from disturbed land if (do_patch_dynamics.eq.itrue ) then call spawn_patches(currentSite, bc_in) - end if - call TotalBalanceCheck(currentSite,3) + call TotalBalanceCheck(currentSite,3) + + ! fuse on the spawned patches. + call fuse_patches(currentSite, bc_in ) - ! fuse on the spawned patches. - if ( do_patch_dynamics.eq.itrue ) then - call fuse_patches(currentSite, bc_in ) - ! If using BC FATES hydraulics, update the rhizosphere geometry ! based on the new cohort-patch structure - ! 'rhizosphere geometry' (column-level root biomass + rootfr --> root length + ! '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) end if - end if - ! SP has changes in leaf carbon but we don't expect them to be in balance. - call TotalBalanceCheck(currentSite,4) + ! SP has changes in leaf carbon but we don't expect them to be in balance. + call TotalBalanceCheck(currentSite,4) - ! kill patches that are too small - if ( do_patch_dynamics.eq.itrue ) then - call terminate_patches(currentSite) + ! kill patches that are too small + call terminate_patches(currentSite) end if call TotalBalanceCheck(currentSite,5) - + end subroutine ed_ecosystem_dynamics !-------------------------------------------------------------------------------! subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! - + ! !DESCRIPTION: ! FIX(SPM,032414) refactor so everything goes through interface ! @@ -318,7 +306,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) use FatesInterfaceTypesMod, only : hlm_use_cohort_age_tracking use FatesConstantsMod, only : itrue ! !ARGUMENTS: - + type(ed_site_type) , intent(inout) :: currentSite type(bc_in_type) , intent(in) :: bc_in type(bc_out_type) , intent(inout) :: bc_out @@ -329,7 +317,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type) , pointer :: currentCohort - integer :: c ! Counter for litter size class + integer :: c ! Counter for litter size class integer :: ft ! Counter for PFT integer :: io_si ! global site index for history writing integer :: iscpf ! index for the size-class x pft multiplexed bins @@ -374,7 +362,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! Update Canopy Biomass Pools currentCohort => currentPatch%shortest - do while(associated(currentCohort)) + do while(associated(currentCohort)) ft = currentCohort%pft @@ -387,20 +375,20 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! ----------------------------------------------------------------------------- ! ----------------------------------------------------------------------------- ! Identify the net carbon gain for this dynamics interval - ! Set the available carbon pool, identify allocation portions, and + ! Set the available carbon pool, identify allocation portions, and ! decrement the available carbon pool to zero. ! ----------------------------------------------------------------------------- - - + + if (hlm_use_ed_prescribed_phys .eq. itrue) then if (currentCohort%canopy_layer .eq. 1) then currentCohort%npp_acc = EDPftvarcon_inst%prescribed_npp_canopy(ft) & - * currentCohort%c_area / currentCohort%n / hlm_days_per_year + * currentCohort%c_area / currentCohort%n / hlm_days_per_year else currentCohort%npp_acc = EDPftvarcon_inst%prescribed_npp_understory(ft) & * currentCohort%c_area / currentCohort%n / hlm_days_per_year endif - + ! We don't explicitly define a respiration rate for prescribe phys ! but we do need to pass mass balance. So we say it is zero respiration currentCohort%gpp_acc = currentCohort%npp_acc @@ -416,15 +404,15 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! ! convert from kgC/indiv/day into kgC/indiv/year ! _acc_hold is remembered until the next dynamics step (used for I/O) - ! _acc will be reset soon and will be accumulated on the next leaf + ! _acc will be reset soon and will be accumulated on the next leaf ! photosynthesis step ! ----------------------------------------------------------------------------- - + currentCohort%npp_acc_hold = currentCohort%npp_acc * real(hlm_days_per_year,r8) currentCohort%gpp_acc_hold = currentCohort%gpp_acc * real(hlm_days_per_year,r8) currentCohort%resp_acc_hold = currentCohort%resp_acc * real(hlm_days_per_year,r8) - + ! Conduct Maintenance Turnover (parteh) if(debug) call currentCohort%prt%CheckMassConservation(ft,3) if(any(currentSite%dstatus == [phen_dstat_moiston,phen_dstat_timeon])) then @@ -446,10 +434,10 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! ----------------------------------------------------------------------------- ! Growth and Allocation (PARTEH) ! ----------------------------------------------------------------------------- - + call currentCohort%prt%DailyPRT() - + ! Update the mass balance tracking for the daily nutrient uptake flux ! Then zero out the daily uptakes, they have been used ! ----------------------------------------------------------------------------- @@ -457,64 +445,64 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) if(hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp ) then ! Mass balance for N uptake - currentSite%mass_balance(element_pos(nitrogen_element))%net_root_uptake = & + currentSite%mass_balance(element_pos(nitrogen_element))%net_root_uptake = & currentSite%mass_balance(element_pos(nitrogen_element))%net_root_uptake + & (currentCohort%daily_nh4_uptake+currentCohort%daily_no3_uptake- & currentCohort%daily_n_efflux)*currentCohort%n - + ! Mass balance for P uptake - currentSite%mass_balance(element_pos(phosphorus_element))%net_root_uptake = & - currentSite%mass_balance(element_pos(phosphorus_element))%net_root_uptake + & + currentSite%mass_balance(element_pos(phosphorus_element))%net_root_uptake = & + currentSite%mass_balance(element_pos(phosphorus_element))%net_root_uptake + & (currentCohort%daily_p_uptake-currentCohort%daily_p_efflux)*currentCohort%n - + ! mass balance for C efflux (if any) - currentSite%mass_balance(element_pos(carbon12_element))%net_root_uptake = & - currentSite%mass_balance(element_pos(carbon12_element))%net_root_uptake - & + currentSite%mass_balance(element_pos(carbon12_element))%net_root_uptake = & + currentSite%mass_balance(element_pos(carbon12_element))%net_root_uptake - & currentCohort%daily_c_efflux*currentCohort%n - + ! size class index iscpf = currentCohort%size_by_pft_class - + ! Diagnostics for uptake, by size and pft, [kgX/ha/day] - + io_si = currentSite%h_gid - + fates_hist%hvars(ih_nh4uptake_scpf)%r82d(io_si,iscpf) = & fates_hist%hvars(ih_nh4uptake_scpf)%r82d(io_si,iscpf) + & currentCohort%daily_nh4_uptake*currentCohort%n fates_hist%hvars(ih_no3uptake_scpf)%r82d(io_si,iscpf) = & - fates_hist%hvars(ih_no3uptake_scpf)%r82d(io_si,iscpf) + & + fates_hist%hvars(ih_no3uptake_scpf)%r82d(io_si,iscpf) + & currentCohort%daily_no3_uptake*currentCohort%n fates_hist%hvars(ih_puptake_scpf)%r82d(io_si,iscpf) = & - fates_hist%hvars(ih_puptake_scpf)%r82d(io_si,iscpf) + & + fates_hist%hvars(ih_puptake_scpf)%r82d(io_si,iscpf) + & currentCohort%daily_p_uptake*currentCohort%n - + fates_hist%hvars(ih_nh4uptake_si)%r81d(io_si) = & - fates_hist%hvars(ih_nh4uptake_si)%r81d(io_si) + & + fates_hist%hvars(ih_nh4uptake_si)%r81d(io_si) + & currentCohort%daily_nh4_uptake*currentCohort%n fates_hist%hvars(ih_no3uptake_si)%r81d(io_si) = & - fates_hist%hvars(ih_no3uptake_si)%r81d(io_si) + & + fates_hist%hvars(ih_no3uptake_si)%r81d(io_si) + & currentCohort%daily_no3_uptake*currentCohort%n fates_hist%hvars(ih_puptake_si)%r81d(io_si) = & - fates_hist%hvars(ih_puptake_si)%r81d(io_si) + & + fates_hist%hvars(ih_puptake_si)%r81d(io_si) + & currentCohort%daily_p_uptake*currentCohort%n - + ! Diagnostics on efflux, size and pft [kgX/ha/day] - currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_efflux_scpf(iscpf) = & - currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_efflux_scpf(iscpf) + & + currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_efflux_scpf(iscpf) = & + currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_efflux_scpf(iscpf) + & currentCohort%daily_n_efflux*currentCohort%n - - currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_efflux_scpf(iscpf) = & - currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_efflux_scpf(iscpf) + & + + currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_efflux_scpf(iscpf) = & + currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_efflux_scpf(iscpf) + & currentCohort%daily_p_efflux*currentCohort%n - - currentSite%flux_diags(element_pos(carbon12_element))%nutrient_efflux_scpf(iscpf) = & - currentSite%flux_diags(element_pos(carbon12_element))%nutrient_efflux_scpf(iscpf) + & + + currentSite%flux_diags(element_pos(carbon12_element))%nutrient_efflux_scpf(iscpf) = & + currentSite%flux_diags(element_pos(carbon12_element))%nutrient_efflux_scpf(iscpf) + & currentCohort%daily_c_efflux*currentCohort%n ! Diagnostics on plant nutrient need @@ -533,7 +521,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) currentCohort%gpp_acc * currentCohort%n site_cmass%aresp_acc = site_cmass%aresp_acc + & currentCohort%resp_acc * currentCohort%n - + call currentCohort%prt%CheckMassConservation(ft,5) ! Update the leaf biophysical rates based on proportion of leaf @@ -544,10 +532,10 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! This cohort has grown, it is no longer "new" currentCohort%isnew = .false. - + ! Update the plant height (if it has grown) call h_allom(currentCohort%dbh,ft,currentCohort%hite) - + currentCohort%dhdt = (currentCohort%hite-hite_old)/hlm_freq_day currentCohort%ddbhdt = (currentCohort%dbh-dbh_old)/hlm_freq_day @@ -557,9 +545,9 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) currentCohort%npp_acc = 0.0_r8 currentCohort%gpp_acc = 0.0_r8 currentCohort%resp_acc = 0.0_r8 - - ! BOC...update tree 'hydraulic geometry' - ! (size --> heights of elements --> hydraulic path lengths --> + + ! BOC...update tree 'hydraulic geometry' + ! (size --> heights of elements --> hydraulic path lengths --> ! maximum node-to-node conductances) if( (hlm_use_planthydro.eq.itrue) .and. do_growthrecruiteffects) then call UpdateSizeDepPlantHydProps(currentSite,currentCohort, bc_in) @@ -585,10 +573,10 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) currentPatch => currentPatch%older end do - - + + ! When plants die, the water goes with them. This effects - ! the water balance. + ! the water balance. if( hlm_use_planthydro == itrue ) then currentPatch => currentSite%youngest_patch @@ -602,22 +590,22 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) currentPatch => currentPatch%older end do end if - + ! With growth and mortality rates now calculated we can determine the seed rain ! fluxes. However, because this is potentially a cross-patch mixing model ! we will calculate this as a group call SeedIn(currentSite,bc_in) - + ! Calculate all other litter fluxes ! ----------------------------------------------------------------------------------- currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - + call PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in) - + call PreDisturbanceIntegrateLitter(currentPatch ) @@ -632,15 +620,15 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) call FluxIntoLitterPools(currentsite, bc_in, bc_out) - ! Update cohort number. - ! This needs to happen after the CWD_input and seed_input calculations as they - ! assume the pre-mortality currentCohort%n. - + ! Update cohort number. + ! This needs to happen after the CWD_input and seed_input calculations as they + ! assume the pre-mortality currentCohort%n. + currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - currentCohort%n = max(0._r8,currentCohort%n + currentCohort%dndt * hlm_freq_day ) + do while(associated(currentCohort)) + currentCohort%n = max(0._r8,currentCohort%n + currentCohort%dndt * hlm_freq_day ) currentCohort => currentCohort%taller enddo currentPatch => currentPatch%older @@ -657,8 +645,8 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) ! Calls routines to consolidate the ED growth process. ! Canopy Structure to assign canopy layers to cohorts ! Canopy Spread to figure out the size of tree crowns - ! Trim_canopy to figure out the target leaf biomass. - ! Extra recruitment to fill empty patches. + ! Trim_canopy to figure out the target leaf biomass. + ! Extra recruitment to fill empty patches. ! ! !USES: use EDCanopyStructureMod , only : canopy_spread, canopy_structure @@ -669,7 +657,7 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) type(bc_out_type) , intent(inout) :: bc_out ! ! !LOCAL VARIABLES: - type (ed_patch_type) , pointer :: currentPatch + type (ed_patch_type) , pointer :: currentPatch !----------------------------------------------------------------------- if(hlm_use_sp.eq.ifalse)then call canopy_spread(currentSite) @@ -685,17 +673,17 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) - - ! Is termination really needed here? + + ! Is termination really needed here? ! Canopy_structure just called it several times! (rgk) - call terminate_cohorts(currentSite, currentPatch, 1, 11, bc_in) + call terminate_cohorts(currentSite, currentPatch, 1, 11, bc_in) call terminate_cohorts(currentSite, currentPatch, 2, 11, bc_in) ! This cohort count is used in the photosynthesis loop call count_cohorts(currentPatch) - currentPatch => currentPatch%younger + currentPatch => currentPatch%younger enddo ! The HLMs need to know about nutrient demand, and/or @@ -705,28 +693,28 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) ! The HLM methane module needs information about ! rooting mass, distributions, respiration rates and NPP call PrepCH4BCs(currentSite,bc_in,bc_out) - + ! FIX(RF,032414). This needs to be monthly, not annual ! If this is the second to last day of the year, then perform trimming if( hlm_day_of_year == hlm_days_per_year-1) then if(hlm_use_sp.eq.ifalse)then - call trim_canopy(currentSite) + call trim_canopy(currentSite) endif endif end subroutine ed_update_site !-------------------------------------------------------------------------------! - + subroutine TotalBalanceCheck (currentSite, call_index ) ! ! !DESCRIPTION: - ! This routine looks at the mass flux in and out of the FATES and compares it to + ! This routine looks at the mass flux in and out of the FATES and compares it to ! the change in total stocks (states). - ! Fluxes in are NPP. Fluxes out are decay of CWD and litter into SOM pools. + ! Fluxes in are NPP. Fluxes out are decay of CWD and litter into SOM pools. ! ! !ARGUMENTS: type(ed_site_type) , intent(inout) :: currentSite @@ -739,7 +727,7 @@ subroutine TotalBalanceCheck (currentSite, call_index ) real(r8) :: seed_stock ! total seed mass in Kg/site real(r8) :: total_stock ! total ED carbon in Kg/site real(r8) :: change_in_stock ! Change since last time we set ed_allsites_inst%old_stock in this routine. KgC/site - real(r8) :: error ! How much carbon did we gain or lose (should be zero!) + real(r8) :: error ! How much carbon did we gain or lose (should be zero!) real(r8) :: error_frac ! Error as a fraction of total biomass real(r8) :: net_flux ! Difference between recorded fluxes in and out. KgC/site real(r8) :: flux_in ! mass flux into fates control volume @@ -753,11 +741,11 @@ subroutine TotalBalanceCheck (currentSite, call_index ) integer :: el ! loop counter for element types - ! nb. There is no time associated with these variables - ! because this routine can be called between any two - ! arbitrary points in code, even if no time has passed. - ! Also, the carbon pools are per site/gridcell, so that - ! we can account for the changing areas of patches. + ! nb. There is no time associated with these variables + ! because this routine can be called between any two + ! arbitrary points in code, even if no time has passed. + ! Also, the carbon pools are per site/gridcell, so that + ! we can account for the changing areas of patches. type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type) , pointer :: currentCohort @@ -771,32 +759,32 @@ subroutine TotalBalanceCheck (currentSite, call_index ) change_in_stock = 0.0_r8 - + ! Loop through the number of elements in the system do el = 1, num_elements - + site_mass => currentSite%mass_balance(el) call SiteMassStock(currentSite,el,total_stock,biomass_stock,litter_stock,seed_stock) change_in_stock = total_stock - site_mass%old_stock - flux_in = site_mass%seed_in + & + flux_in = site_mass%seed_in + & site_mass%net_root_uptake + & site_mass%gpp_acc + & site_mass%flux_generic_in + & site_mass%patch_resize_err flux_out = site_mass%wood_product + & - site_mass%burn_flux_to_atm + & - site_mass%seed_out + & + site_mass%burn_flux_to_atm + & + site_mass%seed_out + & site_mass%flux_generic_out + & - site_mass%frag_out + & - site_mass%aresp_acc + site_mass%frag_out + & + site_mass%aresp_acc net_flux = flux_in - flux_out - error = abs(net_flux - change_in_stock) + error = abs(net_flux - change_in_stock) if(change_in_stock>0.0)then @@ -823,19 +811,19 @@ subroutine TotalBalanceCheck (currentSite, call_index ) write(fates_log(),*) 'burn_flux_to_atm: ',site_mass%burn_flux_to_atm write(fates_log(),*) 'seed_out: ',site_mass%seed_out write(fates_log(),*) 'flux_generic_out: ',site_mass%flux_generic_out - write(fates_log(),*) 'frag_out: ',site_mass%frag_out + write(fates_log(),*) 'frag_out: ',site_mass%frag_out write(fates_log(),*) 'aresp_acc: ',site_mass%aresp_acc write(fates_log(),*) 'error=net_flux-dstock:', error write(fates_log(),*) 'biomass', biomass_stock write(fates_log(),*) 'litter',litter_stock write(fates_log(),*) 'seeds',seed_stock write(fates_log(),*) 'total stock', total_stock - write(fates_log(),*) 'previous total',site_mass%old_stock + write(fates_log(),*) 'previous total',site_mass%old_stock write(fates_log(),*) 'lat lon',currentSite%lat,currentSite%lon - + ! If this is the first day of simulation, carbon balance reports but does not end the run ! if(( hlm_current_year*10000 + hlm_current_month*100 + hlm_current_day).ne.hlm_reference_date) then - + currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) litt => currentPatch%litter(el) @@ -876,7 +864,7 @@ subroutine TotalBalanceCheck (currentSite, call_index ) write(fates_log(),*) 'C efflux: ',currentCohort%daily_c_efflux*currentCohort%n end if - + currentCohort => currentCohort%shorter enddo !end cohort loop end if @@ -885,7 +873,7 @@ subroutine TotalBalanceCheck (currentSite, call_index ) write(fates_log(),*) 'aborting on date:',hlm_current_year,hlm_current_month,hlm_current_day call endrun(msg=errMsg(sourcefile, __LINE__)) !end if - + endif ! This is the last check of the sequence, where we update our total @@ -896,11 +884,11 @@ subroutine TotalBalanceCheck (currentSite, call_index ) end if end do - end if ! not SP mode + end if ! not SP mode end subroutine TotalBalanceCheck - + ! ===================================================================================== - + subroutine bypass_dynamics(currentSite) ! ---------------------------------------------------------------------------------- @@ -912,15 +900,15 @@ subroutine bypass_dynamics(currentSite) ! Arguments type(ed_site_type) , intent(inout), target :: currentSite - + ! Locals type(ed_patch_type), pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort - + currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) currentCohort => currentPatch%shortest - do while(associated(currentCohort)) + do while(associated(currentCohort)) currentCohort%isnew=.false. @@ -956,7 +944,7 @@ subroutine bypass_dynamics(currentSite) enddo currentPatch => currentPatch%older enddo - + end subroutine bypass_dynamics end module EDMainMod From 443550de1a9a54ef194c9c3e1128c0ae95b659ef Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 25 Aug 2021 14:59:48 -0600 Subject: [PATCH 379/578] reverting all the area_pft indexing commits --- biogeochem/EDCanopyStructureMod.F90 | 4 ++-- main/EDInitMod.F90 | 14 +++++++------- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 6d3b6f723b..261d087d3b 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1924,10 +1924,10 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentPatch => sites(s)%oldest_patch c = fcolumn(s) do while(associated(currentPatch)) - !if(currentPatch%nocomp_pft_label.ne.0)then + if(currentPatch%nocomp_pft_label.ne.0)then ! only increase ifp for veg patches, not bareground (in SP mode) ifp = ifp+1 - !endif ! stay with ifp=0 for bareground patch. + endif ! stay with ifp=0 for bareground patch. if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area currentPatch%total_canopy_area = currentPatch%area diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index bb06f57de1..89d800df3a 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -133,7 +133,7 @@ subroutine init_site_vars( site_in, bc_in, bc_out ) allocate(site_in%dz_soil(site_in%nlevsoil)) allocate(site_in%z_soil(site_in%nlevsoil)) - allocate(site_in%area_pft(0:numpft)) ! Changing to zero indexing + allocate(site_in%area_pft(1:numpft)) ! Changing to zero indexing allocate(site_in%use_this_pft(1:numpft)) ! SP mode @@ -327,11 +327,11 @@ subroutine set_site_properties( nsites, sites,bc_in ) end do !hlm_pft do ft = 1,numpft - ! if(sites(s)%area_pft(ft).lt.0.01_r8.and.sites(s)%area_pft(ft).gt.0.0_r8)then - ! write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) - ! sites(s)%area_pft(ft)=0.0_r8 - ! ! remove tiny patches to prevent numerical errors in terminate patches - ! endif + if(sites(s)%area_pft(ft).lt.0.01_r8.and.sites(s)%area_pft(ft).gt.0.0_r8)then + write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) + sites(s)%area_pft(ft)=0.0_r8 + ! remove tiny patches to prevent numerical errors in terminate patches + endif if(sites(s)%area_pft(ft).lt.0._r8)then write(fates_log(),*) 'negative area',s,ft,sites(s)%area_pft(ft) call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -482,7 +482,7 @@ subroutine init_patches( nsites, sites, bc_in) if(hlm_use_nocomp.eq.itrue)then num_new_patches = numpft if(hlm_use_sp.eq.itrue)then - !num_new_patches = numpft + 1 ! bare ground patch in SP mode. + num_new_patches = numpft + 1 ! bare ground patch in SP mode. start_patch = 0 ! start at the bare ground patch endif ! allocate(newppft(numpft)) From 8f28a6d978f78ef08cc1f5797abd5ef0c9fd39f9 Mon Sep 17 00:00:00 2001 From: Yilin Fang Date: Thu, 26 Aug 2021 21:26:19 -0700 Subject: [PATCH 380/578] Add back 1D solve. --- biogeophys/FatesPlantHydraulicsMod.F90 | 909 ++++++++++++++++++++++++- main/FatesHydraulicsMemMod.F90 | 2 +- 2 files changed, 908 insertions(+), 3 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 191e7f309e..13f8db49dd 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -1395,8 +1395,8 @@ subroutine InitHydrSites(sites,bc_in) ! layers used if(aggregate_layers) then ! csite_hydr%i_rhiz_t = 11 !one big layer - csite_hydr%i_rhiz_t = 6 !top 5 layer aggregate -! csite_hydr%i_rhiz_t = 2 !no aggregate +! csite_hydr%i_rhiz_t = 6 !top 5 layer aggregate + csite_hydr%i_rhiz_t = 2 !no aggregate csite_hydr%i_rhiz_b = bc_in(s)%nlevsoil csite_hydr%nlevrhiz = csite_hydr%i_rhiz_b - csite_hydr%i_rhiz_t + 2 !ideally to be read in from the parameter file @@ -2785,7 +2785,32 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) sapflow,rootuptake(1:nlevrhiz),wb_err_plant,dwat_plant, & dth_layershell_col,site_hydr%num_nodes) #endif + else + ! --------------------------------------------------------------------------------- + ! 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 + ! ----------------------------------------------------------------------------------- + + 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,sites(s)%lat,sites(s)%lon) + end if ! Remember the error for the cohort @@ -3350,6 +3375,886 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort,cohort_hydr,ordered, kbg_layer return end subroutine OrderLayersForSolve1D + ! ===================================================================================== + + + subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & + ordered,kbg_layer, sapflow,rootuptake,& + wb_err_plant,dwat_plant,dth_layershell_col,lat_tmp,lon_tmp) + + ! ------------------------------------------------------------------------------- + ! 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]) + + ! 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] + + + 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) :: rootfr ! rooting fraction of this layer (used for diagnostics) + real(r8) :: lat_tmp, lon_tmp !for debugging + ! 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 = 30 ! 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] + + + 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 + real(r8) :: ajac(n_hypool_tot,n_hypool_tot) + integer :: info,ipiv(n_hypool_tot) + + 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) + write(fates_log(),*) 'hydro stability lat/lon: ',lat_tmp,lon_tmp + +! 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. +! nsteps = 1 + 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)) + + !cap capillary pressure + psi_node(i) = max(-1e5_r8,psi_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)) + !cap capillary pressure + psi_node(i) = max(-1e5_r8,psi_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 0 + ajac(:,:) = 0._r8 + do i=1,n_hypool_tot + if(i==1) then + ajac(i,i) = tris_b(i) + ajac(i,i+1) = tris_c(i) + elseif(i==n_hypool_tot) then + ajac(i,i-1)= tris_a(i) + ajac(i,i) = tris_b(i) + else + ajac(i,i-1)= tris_a(i) + ajac(i,i) = tris_b(i) + ajac(i,i+1) = tris_c(i) + endif + enddo + ipiv = 0 + call DGESV(n_hypool_tot,1,ajac(1:n_hypool_tot,1:n_hypool_tot),n_hypool_tot,ipiv,tris_r,n_hypool_tot,info) + dth_node(1:n_hypool_tot) = tris_r(1:n_hypool_tot) +#endif + if(tri_ierr == 1) then +! if(info > 0) 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 +#if 0 +if( q_top_eff > 0.0 .and. (w_tot_beg-w_tot_end) == 0._r8) then + print *,'zero dth--',dth_node,'th-',th_node,'wb-',w_tot_beg,w_tot_end + print *,'tris_a',tris_a + print *,'tris_b',tris_b + print *,'tris_c',tris_c + print *,'tris_r',tris_r + stop +endif +#endif + + wb_step_err = (q_top_eff*dt_substep) - (w_tot_beg-w_tot_end) + !if(lon_tmp == 120._r8 .and. lat_tmp == -34._r8) then + ! write(fates_log(),*)'Grid with problem -',wb_step_err,q_top_eff,'th-',dth_node(1:5),'w_totb',w_tot_beg,w_tot_end + !endif + !linear solver error cannot be avoided + !if(abs(wb_step_err)>1*max_wb_step_err .or. any(dth_node(:).ne.dth_node(:)) )then + if( any(dth_node(:).ne.dth_node(:)) )then + !if(abs(wb_step_err)>1*max_wb_step_err .or. any(dth_node(:).ne.dth_node(:)) )then + !solution_found = .false. + 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 + + ! If desired, check and trap water contents + ! that are negative + if(trap_neg_wc) then + if( any(th_node(:)<0._r8) ) then + solution_found = .false. + error_code = 3 + error_arr(:) = th_node(:) + exit + end if + 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)) + !cap capillary pressure + psi_node(i) = max(-1e5_r8,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)) + !cap capillary pressure + psi_node(i) = max(-1e5_r8,psi_node(i)) + end do + + ! If desired, check and trap pressures that are supersaturated + if(trap_supersat_psi) then + do i = 1,n_hypool_plant + if(psi_node(i)>wrf_plant(pm_node(i),ft)%p%get_thsat()) then + solution_found = .false. + error_code = 4 + end if + end do + do i = n_hypool_plant+1,n_hypool_tot + if(psi_node(i)>site_hydr%wrf_soil(ilayer)%p%get_thsat()) then + solution_found = .false. + error_code = 4 + end if + end do + if(error_code==4) then + error_arr(:) = th_node(:) + end if + end if + + ! Accumulate the water balance error of the layer over the sub-steps + ! for diagnostic purposes + ! [kg/m2] + wb_err_layer = wb_err_layer + wb_step_err + + ! ------------------------------------------------------------------------- + ! Diagnostics + ! ------------------------------------------------------------------------- + + ! Sapflow at the base of the tree is the flux rate + ! between the transporting root node and the first stem node + ! (note: a path j is between node i and i+1) + ! [kg] = [kg/s] * [s] + + i = n_hypool_ag + sapflow_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,wb_err_layer + write(fates_log(),*)'transpiration demand: ', dt_step*q_top_eff,' kg/step/plant','dt',dt_step,'iter',iter + + 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), psi_node(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,r8)) + ! Save the number of sub-steps we ultimately used + cohort_hydr%iterh2 = max(cohort_hydr%iterh2,real(nsteps,r8)) + + ! 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, 'dt_step',dt_step + 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, & diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index d159cdce54..61a458ab4b 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -10,7 +10,7 @@ module FatesHydraulicsMemMod implicit none private - logical, parameter, public :: use_2d_hydrosolve = .true. + logical, parameter, public :: use_2d_hydrosolve = .false. ! Number of soil layers for indexing cohort fine root quanitities From 28473d095b7d832b8bb5fb5b67096cff8d9aab40 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux <7565064+glemieux@users.noreply.github.com> Date: Wed, 1 Sep 2021 11:28:22 -0700 Subject: [PATCH 381/578] Update biogeochem/EDPhysiologyMod.F90 Updating the element id from a number to the element parameter name to clarify. Co-authored-by: Charlie Koven --- biogeochem/EDPhysiologyMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index f0df5f9067..859f6e3534 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1555,7 +1555,7 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l end if !small error if(init.eq.ifalse)then - call SetState(currentCohort%prt,leaf_organ,1,leaf_c,1) + call SetState(currentCohort%prt, leaf_organ, carbon12_element, leaf_c, 1) endif ! assert sai From a260f31d6f31464457b06de6f97761aa6df9b1db Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 1 Sep 2021 18:04:39 -0600 Subject: [PATCH 382/578] adding hist var for sp lai by pft --- main/FatesHistoryInterfaceMod.F90 | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 97f3342b43..b06cb828f4 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -505,6 +505,7 @@ module FatesHistoryInterfaceMod ! indices to (site x pft) variables integer :: ih_biomass_si_pft integer :: ih_leafbiomass_si_pft + integer :: ih_splai_si_pft integer :: ih_storebiomass_si_pft integer :: ih_nindivs_si_pft integer :: ih_recruitment_si_pft @@ -1792,6 +1793,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) 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, & + hio_splai_si_pft => this%hvars(ih_splai_si_pft)%r82d, & hio_storebiomass_si_pft => this%hvars(ih_storebiomass_si_pft)%r82d, & hio_nindivs_si_pft => this%hvars(ih_nindivs_si_pft)%r82d, & hio_recruitment_si_pft => this%hvars(ih_recruitment_si_pft)%r82d, & @@ -2131,6 +2133,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_harvest_carbonflux_si(io_si) = sites(s)%harvest_carbon_flux + do i_pft = 1,numpft + hio_splai_si_pft(io_si,i_pft) = sites(s)%sp_tlai(i_pft) + end do + + ipa = 0 cpatch => sites(s)%oldest_patch do while(associated(cpatch)) @@ -4337,6 +4344,11 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_leafbiomass_si_pft ) + call this%set_history_var(vname='PFT_SP_LAI', units='m2/m2', & + long='total PFT-level LAI', use_default='active', & + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_splai_si_pft ) + call this%set_history_var(vname='PFTstorebiomass', units='gC/m2', & long='total PFT level stored biomass', use_default='active', & avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & From 455617d9edc070b197f5a62625e878e929225175 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 2 Sep 2021 13:51:24 -0600 Subject: [PATCH 383/578] removing init and c_leaf arguments to assign_cohort_SP_properties --- biogeochem/EDPhysiologyMod.F90 | 15 +++++++-------- main/EDInitMod.F90 | 6 ++++-- 2 files changed, 11 insertions(+), 10 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 859f6e3534..6b0d38c815 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1447,7 +1447,8 @@ subroutine satellite_phenology(currentSite, bc_in) end if ! Call routine to invert SP drivers into cohort properites. - call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) + call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft), & + currentSite%sp_tsai(fates_pft), currentPatch%area) currentCohort => currentCohort%shorter end do !cohort loop @@ -1458,7 +1459,7 @@ end subroutine satellite_phenology ! ===================================================================================== - subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,leaf_c) + subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea) ! -----------------------------------------------------------------------------------! ! Takes the daily inputs of leaf area index, stem area index and canopy height and @@ -1473,9 +1474,8 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l real(r8), intent(in) :: tsai ! target stem area index from SP inputs real(r8), intent(in) :: htop ! target tree height from SP inputs real(r8), intent(in) :: parea ! patch area for this PFT - integer, intent(in) :: init ! are we in the initialization routine? if so do not set leaf_c - real(r8), intent(out) :: leaf_c ! leaf carbon estimated to generate target tlai + real(r8) :: leaf_c ! leaf carbon estimated to generate target tlai real(r8) :: dummy_n ! set cohort n to a dummy value of 1.0 integer :: fates_pft ! fates pft numer for weighting loop real(r8) :: spread ! dummy value of canopy spread to estimate c_area @@ -1551,13 +1551,12 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l end if else write(fates_log(),*) 'SPassign, big error in c_area',currentCohort%c_area-parea,currentCohort%pft + call endrun(msg=errMsg(sourcefile, __LINE__)) end if ! still broken end if !small error - if(init.eq.ifalse)then - call SetState(currentCohort%prt, leaf_organ, carbon12_element, leaf_c, 1) - endif - + call SetState(currentCohort%prt, leaf_organ, carbon12_element, leaf_c, 1) + ! assert sai currentCohort%treesai = tsai diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 89d800df3a..e086257356 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -739,11 +739,13 @@ subroutine init_cohorts( site_in, patch_in, bc_in) ! h,dbh,leafc,n from SP values or from small initial size. if(hlm_use_sp.eq.itrue)then - init = itrue + ! At this point, we do not know the bc_in values of tlai tsai and htop, ! so this is initializing to an arbitrary value for the very first timestep. ! Not sure if there's a way around this or not. - call assign_cohort_SP_properties(temp_cohort, 0.5_r8,0.2_r8, 0.1_r8,patch_in%area,init,c_leaf) + call assign_cohort_SP_properties(temp_cohort, 0.5_r8,0.2_r8, 0.1_r8,patch_in%area) + + c_leaf = temp_cohort%prt%GetState(leaf_organ, carbon12_element) else temp_cohort%hite = EDPftvarcon_inst%hgt_min(pft) From 919e27fd54d06e25e9707b91d28bc29e8d3fa440 Mon Sep 17 00:00:00 2001 From: ckoven Date: Thu, 2 Sep 2021 20:50:21 -0600 Subject: [PATCH 384/578] Revert "removing init and c_leaf arguments to assign_cohort_SP_properties" This reverts commit 455617d9edc070b197f5a62625e878e929225175. --- biogeochem/EDPhysiologyMod.F90 | 15 ++++++++------- main/EDInitMod.F90 | 6 ++---- 2 files changed, 10 insertions(+), 11 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 6b0d38c815..859f6e3534 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1447,8 +1447,7 @@ subroutine satellite_phenology(currentSite, bc_in) end if ! Call routine to invert SP drivers into cohort properites. - call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft), & - currentSite%sp_tsai(fates_pft), currentPatch%area) + call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) currentCohort => currentCohort%shorter end do !cohort loop @@ -1459,7 +1458,7 @@ end subroutine satellite_phenology ! ===================================================================================== - subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea) + subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,leaf_c) ! -----------------------------------------------------------------------------------! ! Takes the daily inputs of leaf area index, stem area index and canopy height and @@ -1474,8 +1473,9 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea) real(r8), intent(in) :: tsai ! target stem area index from SP inputs real(r8), intent(in) :: htop ! target tree height from SP inputs real(r8), intent(in) :: parea ! patch area for this PFT + integer, intent(in) :: init ! are we in the initialization routine? if so do not set leaf_c + real(r8), intent(out) :: leaf_c ! leaf carbon estimated to generate target tlai - real(r8) :: leaf_c ! leaf carbon estimated to generate target tlai real(r8) :: dummy_n ! set cohort n to a dummy value of 1.0 integer :: fates_pft ! fates pft numer for weighting loop real(r8) :: spread ! dummy value of canopy spread to estimate c_area @@ -1551,12 +1551,13 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea) end if else write(fates_log(),*) 'SPassign, big error in c_area',currentCohort%c_area-parea,currentCohort%pft - call endrun(msg=errMsg(sourcefile, __LINE__)) end if ! still broken end if !small error - call SetState(currentCohort%prt, leaf_organ, carbon12_element, leaf_c, 1) - + if(init.eq.ifalse)then + call SetState(currentCohort%prt, leaf_organ, carbon12_element, leaf_c, 1) + endif + ! assert sai currentCohort%treesai = tsai diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index e086257356..89d800df3a 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -739,13 +739,11 @@ subroutine init_cohorts( site_in, patch_in, bc_in) ! h,dbh,leafc,n from SP values or from small initial size. if(hlm_use_sp.eq.itrue)then - + init = itrue ! At this point, we do not know the bc_in values of tlai tsai and htop, ! so this is initializing to an arbitrary value for the very first timestep. ! Not sure if there's a way around this or not. - call assign_cohort_SP_properties(temp_cohort, 0.5_r8,0.2_r8, 0.1_r8,patch_in%area) - - c_leaf = temp_cohort%prt%GetState(leaf_organ, carbon12_element) + call assign_cohort_SP_properties(temp_cohort, 0.5_r8,0.2_r8, 0.1_r8,patch_in%area,init,c_leaf) else temp_cohort%hite = EDPftvarcon_inst%hgt_min(pft) From 5664f68ba89e05544af4035642b4e9dbed10b3fc Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 3 Sep 2021 12:59:46 -0600 Subject: [PATCH 385/578] changing area_pft indexing in init --- main/EDInitMod.F90 | 33 +++++++++++++++++---------------- main/EDTypesMod.F90 | 2 -- 2 files changed, 17 insertions(+), 18 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 89d800df3a..49b811f54c 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -133,7 +133,12 @@ subroutine init_site_vars( site_in, bc_in, bc_out ) allocate(site_in%dz_soil(site_in%nlevsoil)) allocate(site_in%z_soil(site_in%nlevsoil)) - allocate(site_in%area_pft(1:numpft)) ! Changing to zero indexing + if (hlm_use_nocomp .eq. itrue) then + allocate(site_in%area_pft(1:numpft)) + else ! SP and nocomp require a bare-ground patch. + allocate(site_in%area_pft(0:numpft)) + endif + allocate(site_in%use_this_pft(1:numpft)) ! SP mode @@ -331,7 +336,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) sites(s)%area_pft(ft)=0.0_r8 ! remove tiny patches to prevent numerical errors in terminate patches - endif + endif if(sites(s)%area_pft(ft).lt.0._r8)then write(fates_log(),*) 'negative area',s,ft,sites(s)%area_pft(ft) call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -344,8 +349,9 @@ subroutine set_site_properties( nsites, sites,bc_in ) ! the bare ground will no longer be proscribed and should emerge from FATES ! this may or may not be the right way to deal with this? - if(hlm_use_sp.eq.ifalse)then ! when not in SP mode, subsume bare ground evenly into the existing patches. - !n.b. that it might be better if nocomp mode used the same bare groud logic as SP mode. + if(hlm_use_nocomp.eq.ifalse)then ! when not in nocomp (i.e. or SP) mode, + ! subsume bare ground evenly into the existing patches. + sumarea = sum(sites(s)%area_pft(1:numpft)) do ft = 1,numpft if(sumarea.gt.0._r8)then @@ -356,23 +362,23 @@ subroutine set_site_properties( nsites, sites,bc_in ) ! all pfts and let the model figure out whether land should be bare or not. end if end do !ft - else ! for sp mode, assert a bare ground patch + else ! for sp and nocomp mode, assert a bare ground patch if needed sumarea = sum(sites(s)%area_pft(1:numpft)) ! In all the other FATES modes, bareground is the area in which plants - ! do not grow of their own accord. In SP mod wweassert that the canopy is full for - ! each PFT patche. Thus, we also need to assert a bare ground area in - ! order to not have all of the ground filled by leaves. + ! do not grow of their own accord. In SP mode we assert that the canopy is full for + ! each PFT patch. Thus, we also need to assert a bare ground area in + ! order to not have all of the ground filled by leaves. ! Further to that, one could calculate bare ground as the remaining area when ! all fhe canopies are accounted for, but this means we don't pass balance checks - ! on canopy are inside FATES, and so in SP mode, we define the bare groud + ! on canopy are inside FATES, and so in SP mode, we define the bare groud ! patch as having a PFT identifier as zero. if(sumarea.lt.area)then !make some bare ground - sites(s)%area_bareground = area - sumarea + sites(s)%area_pft(0) = area - sumarea else - sites(s)%area_bareground = 0.0_r8 + sites(s)%area_pft(0) = 0.0_r8 end if end if !sp mode end if !fixed biogeog @@ -516,11 +522,6 @@ subroutine init_patches( nsites, sites, bc_in) newparea = area end if !nocomp mode - if(hlm_use_sp.eq.itrue.and.n.eq.0)then ! bare ground patch - newparea = sites(s)%area_bareground - nocomp_pft = 0 - end if - if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode allocate(newp) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 0c7e8ef56e..b7d3eedb96 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -701,8 +701,6 @@ module EDTypesMod real(r8), allocatable :: sp_tsai(:) ! target TSAI per FATES pft real(r8), allocatable :: sp_htop(:) ! target HTOP per FATES pft - real(r8) :: area_bareground ! in SP mode we assert a bare ground fraction - ! Mass Balance (allocation for each element) type(site_massbal_type), pointer :: mass_balance(:) From 482fc9410a4afa0edb5a502fd294d2099059fbc3 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 3 Sep 2021 13:19:39 -0600 Subject: [PATCH 386/578] debug --- main/EDInitMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 49b811f54c..77266ef149 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -134,9 +134,9 @@ subroutine init_site_vars( site_in, bc_in, bc_out ) allocate(site_in%z_soil(site_in%nlevsoil)) if (hlm_use_nocomp .eq. itrue) then - allocate(site_in%area_pft(1:numpft)) + allocate(site_in%area_pft(0:numpft)) else ! SP and nocomp require a bare-ground patch. - allocate(site_in%area_pft(0:numpft)) + allocate(site_in%area_pft(1:numpft)) endif allocate(site_in%use_this_pft(1:numpft)) From d2892e4a729b504385a7d97692a527c64c8bf61a Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 3 Sep 2021 13:49:40 -0600 Subject: [PATCH 387/578] fixing loop bounds --- main/EDInitMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 77266ef149..c3b503a729 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -488,7 +488,6 @@ subroutine init_patches( nsites, sites, bc_in) if(hlm_use_nocomp.eq.itrue)then num_new_patches = numpft if(hlm_use_sp.eq.itrue)then - num_new_patches = numpft + 1 ! bare ground patch in SP mode. start_patch = 0 ! start at the bare ground patch endif ! allocate(newppft(numpft)) From c009135046fe23a394f12730a8e57232e1d08ebd Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 3 Sep 2021 14:57:24 -0600 Subject: [PATCH 388/578] indexing bc_outs to ignore the bare-groun PFTs entirely. --- biogeochem/EDCanopyStructureMod.F90 | 158 ++++++++++++++-------------- 1 file changed, 79 insertions(+), 79 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 261d087d3b..1ce56c17af 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1924,97 +1924,97 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentPatch => sites(s)%oldest_patch c = fcolumn(s) do while(associated(currentPatch)) - if(currentPatch%nocomp_pft_label.ne.0)then - ! only increase ifp for veg patches, not bareground (in SP mode) - ifp = ifp+1 - endif ! stay with ifp=0 for bareground patch. - if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then - write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area - currentPatch%total_canopy_area = currentPatch%area - endif + ifp = ifp+1 - if (associated(currentPatch%tallest)) then - bc_out(s)%htop_pa(ifp) = currentPatch%tallest%hite - else - ! FIX(RF,040113) - should this be a parameter for the minimum possible vegetation height? - bc_out(s)%htop_pa(ifp) = 0.1_r8 - endif + if(currentPatch%nocomp_pft_label.ne.0)then ! ignore the bare-ground-PFT patch entirely for these BC outs - bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) - ! Use leaf area weighting for all cohorts in the patch to define the characteristic - ! leaf width used by the HLM - ! ---------------------------------------------------------------------------- - ! bc_out(s)%dleaf_pa(ifp) = 0.0_r8 - ! if(currentPatch%lai>1.0e-9_r8) then - ! currentCohort => currentPatch%shortest - ! do while(associated(currentCohort)) - ! weight = min(1.0_r8,currentCohort%lai/currentPatch%lai) - ! bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & - ! EDPftvarcon_inst%dleaf(currentCohort%pft)*weight - ! currentCohort => currentCohort%taller - ! enddo - ! end if - - ! Roughness length and displacement height are not PFT properties, they are - ! properties of the canopy assemblage. Defining this needs an appropriate model. - ! Right now z0 and d are pft level parameters. For the time being we will just - ! use the 1st index until a suitable model is defined. (RGK 04-2017) - ! ----------------------------------------------------------------------------- - bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(1) * bc_out(s)%htop_pa(ifp) - bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) - bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) - - ! We are assuming here that grass is all located underneath tree canopies. - ! The alternative is to assume it is all spatial distinct from tree canopies. - ! In which case, the bare area would have to be reduced by the grass area... - ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants - ! currentPatch%area/AREA is the fraction of the soil covered by this patch. - if(currentPatch%area.gt.0.0_r8)then - bc_out(s)%canopy_fraction_pa(ifp) = & - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) - else - bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 - endif + if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then + write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area + currentPatch%total_canopy_area = currentPatch%area + endif - bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & - (currentPatch%area/AREA) + if (associated(currentPatch%tallest)) then + bc_out(s)%htop_pa(ifp) = currentPatch%tallest%hite + else + ! FIX(RF,040113) - should this be a parameter for the minimum possible vegetation height? + bc_out(s)%htop_pa(ifp) = 0.1_r8 + endif - total_patch_area = total_patch_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area + bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) + + ! Use leaf area weighting for all cohorts in the patch to define the characteristic + ! leaf width used by the HLM + ! ---------------------------------------------------------------------------- + ! bc_out(s)%dleaf_pa(ifp) = 0.0_r8 + ! if(currentPatch%lai>1.0e-9_r8) then + ! currentCohort => currentPatch%shortest + ! do while(associated(currentCohort)) + ! weight = min(1.0_r8,currentCohort%lai/currentPatch%lai) + ! bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & + ! EDPftvarcon_inst%dleaf(currentCohort%pft)*weight + ! currentCohort => currentCohort%taller + ! enddo + ! end if + + ! Roughness length and displacement height are not PFT properties, they are + ! properties of the canopy assemblage. Defining this needs an appropriate model. + ! Right now z0 and d are pft level parameters. For the time being we will just + ! use the 1st index until a suitable model is defined. (RGK 04-2017) + ! ----------------------------------------------------------------------------- + bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) + + ! We are assuming here that grass is all located underneath tree canopies. + ! The alternative is to assume it is all spatial distinct from tree canopies. + ! In which case, the bare area would have to be reduced by the grass area... + ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants + ! currentPatch%area/AREA is the fraction of the soil covered by this patch. + + if(currentPatch%area.gt.0.0_r8)then + bc_out(s)%canopy_fraction_pa(ifp) = & + min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) + else + bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 + endif - total_canopy_area = total_canopy_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & + (currentPatch%area/AREA) - bc_out(s)%nocomp_pft_label_pa(ifp) = currentPatch%nocomp_pft_label + total_patch_area = total_patch_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area - ! Calculate area indices for output boundary to HLM - ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles - ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) + total_canopy_area = total_canopy_area + bc_out(s)%canopy_fraction_pa(ifp) - bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') - bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') - bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') - bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') + bc_out(s)%nocomp_pft_label_pa(ifp) = currentPatch%nocomp_pft_label - !if(debug) then - ! write(fates_log(),*) 'ifp: ', ifp - ! write(fates_log(),*) 'bc_out(s)%elai_pa(ifp): ', bc_out(s)%elai_pa(ifp) - ! write(fates_log(),*) 'bc_out(s)%tlai_pa(ifp): ', bc_out(s)%tlai_pa(ifp) - ! write(fates_log(),*) 'bc_out(s)%esai_pa(ifp): ', bc_out(s)%esai_pa(ifp) - ! write(fates_log(),*) 'bc_out(s)%tsai_pa(ifp): ', bc_out(s)%tsai_pa(ifp) - !end if + ! Calculate area indices for output boundary to HLM + ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles + ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) - ! Fraction of vegetation free of snow. This is used to flag those - ! patches which shall under-go photosynthesis - ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let - ! FATES internal variables decide if photosynthesis is possible - ! we are essentially calculating it inside FATES to tell the - ! host to tell itself when to do things (circuitous). Just have - ! to determine where else it is used + bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') + bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') + bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') + bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') - if ((bc_out(s)%elai_pa(ifp) + bc_out(s)%esai_pa(ifp)) > 0._r8) then - bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 1.0_r8 - else - bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 0.0_r8 + ! Fraction of vegetation free of snow. This is used to flag those + ! patches which shall under-go photosynthesis + ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let + ! FATES internal variables decide if photosynthesis is possible + ! we are essentially calculating it inside FATES to tell the + ! host to tell itself when to do things (circuitous). Just have + ! to determine where else it is used + + if ((bc_out(s)%elai_pa(ifp) + bc_out(s)%esai_pa(ifp)) > 0._r8) then + bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 1.0_r8 + else + bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 0.0_r8 + end if + + else ! nocomp or SP, and currentPatch%nocomp_pft_label .eq. 0 + + total_patch_area = total_patch_area + currentPatch%area/AREA + end if currentPatch => currentPatch%younger end do From 3507ad3aa14a0bcae0d19de9529f70c9e625aeac Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 3 Sep 2021 15:24:23 -0600 Subject: [PATCH 389/578] Revert "adding hist var for sp lai by pft" This reverts commit a260f31d6f31464457b06de6f97761aa6df9b1db. --- main/FatesHistoryInterfaceMod.F90 | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index b06cb828f4..97f3342b43 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -505,7 +505,6 @@ module FatesHistoryInterfaceMod ! indices to (site x pft) variables integer :: ih_biomass_si_pft integer :: ih_leafbiomass_si_pft - integer :: ih_splai_si_pft integer :: ih_storebiomass_si_pft integer :: ih_nindivs_si_pft integer :: ih_recruitment_si_pft @@ -1793,7 +1792,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) 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, & - hio_splai_si_pft => this%hvars(ih_splai_si_pft)%r82d, & hio_storebiomass_si_pft => this%hvars(ih_storebiomass_si_pft)%r82d, & hio_nindivs_si_pft => this%hvars(ih_nindivs_si_pft)%r82d, & hio_recruitment_si_pft => this%hvars(ih_recruitment_si_pft)%r82d, & @@ -2133,11 +2131,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_harvest_carbonflux_si(io_si) = sites(s)%harvest_carbon_flux - do i_pft = 1,numpft - hio_splai_si_pft(io_si,i_pft) = sites(s)%sp_tlai(i_pft) - end do - - ipa = 0 cpatch => sites(s)%oldest_patch do while(associated(cpatch)) @@ -4344,11 +4337,6 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_leafbiomass_si_pft ) - call this%set_history_var(vname='PFT_SP_LAI', units='m2/m2', & - long='total PFT-level LAI', use_default='active', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_splai_si_pft ) - call this%set_history_var(vname='PFTstorebiomass', units='gC/m2', & long='total PFT level stored biomass', use_default='active', & avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & From 70c319557375d650c7dbe1075215a7e662eddd9a Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 3 Sep 2021 15:52:42 -0600 Subject: [PATCH 390/578] bugfixes --- biogeochem/EDCanopyStructureMod.F90 | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 1ce56c17af..08e6c0513f 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1925,10 +1925,10 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) c = fcolumn(s) do while(associated(currentPatch)) - ifp = ifp+1 - if(currentPatch%nocomp_pft_label.ne.0)then ! ignore the bare-ground-PFT patch entirely for these BC outs + ifp = ifp+1 + if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area currentPatch%total_canopy_area = currentPatch%area @@ -2040,11 +2040,8 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) if(currentPatch%nocomp_pft_label.ne.0)then ! for vegetated patches only ifp = ifp+1 bc_out(s)%canopy_fraction_pa(ifp) = bc_out(s)%canopy_fraction_pa(ifp)/total_patch_area - else ! for the bareground patch (in SP mode). - bc_out(s)%canopy_fraction_pa(ifp) =0.0_r8 endif ! veg patch - currentPatch => currentPatch%younger end do From cc5b2edaf298e88b3d2e9b59113782ed74caf3e4 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 14 Sep 2021 22:13:27 -0600 Subject: [PATCH 391/578] added fire variables to allow nocomp to pass restart comparison with fire on --- main/FatesRestartInterfaceMod.F90 | 34 +++++++++++++++++++++++++++++++ 1 file changed, 34 insertions(+) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 81ae74f975..69cc2e3f8b 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -36,6 +36,7 @@ module FatesRestartInterfaceMod use FatesLitterMod, only : litter_type use FatesLitterMod, only : ncwd use FatesLitterMod, only : ndcmpy + use EDTypesMod, only : nfsc use PRTGenericMod, only : prt_global use PRTGenericMod, only : num_elements @@ -174,6 +175,8 @@ module FatesRestartInterfaceMod integer :: ir_lfines_frag_litt integer :: ir_rfines_frag_litt + integer :: ir_scorch_ht_pa_pft + integer :: ir_litter_moisture_pa_nfsc ! Site level integer :: ir_watermem_siwm @@ -920,6 +923,13 @@ subroutine define_restart_vars(this, initialize_variables) long_name='are of the ED patch', units='m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_area_pa ) + call this%set_restart_var(vname='fates_scorch_ht_pa_pft', vtype=cohort_r8, & + long_name='scorch height', units='m', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_scorch_ht_pa_pft) + + call this%set_restart_var(vname='fates_litter_moisture_pa_nfsc', vtype=cohort_r8, & + long_name='scorch height', units='m', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_litter_moisture_pa_nfsc) ! Site Level Diagnostics over multiple nutrients @@ -1974,6 +1984,18 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ,io_idx_co,cohortsperpatch endif + io_idx_pa_pft = io_idx_co_1st + do i = 1,numpft + this%rvars(ir_scorch_ht_pa_pft)%r81d(io_idx_pa_pft) = cpatch%scorch_ht(i) + io_idx_pa_pft = io_idx_pa_pft + 1 + end do + + io_idx_pa_cwd = io_idx_co_1st + do i = 1,nfsc + this%rvars(ir_litter_moisture_pa_nfsc)%r81d(io_idx_pa_cwd) = cpatch%litter_moisture(i) + io_idx_pa_cwd = io_idx_pa_cwd + 1 + end do + ! -------------------------------------------------------------------------- ! Send litter to the restart arrays ! Each element has its own variable, so we have to make sure @@ -2761,6 +2783,18 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ,io_idx_co,cohortsperpatch endif + io_idx_pa_pft = io_idx_co_1st + do i = 1,numpft + cpatch%scorch_ht(i) = this%rvars(ir_scorch_ht_pa_pft)%r81d(io_idx_pa_pft) + io_idx_pa_pft = io_idx_pa_pft + 1 + end do + + io_idx_pa_cwd = io_idx_co_1st + do i = 1,nfsc + cpatch%litter_moisture(i) = this%rvars(ir_litter_moisture_pa_nfsc)%r81d(io_idx_pa_cwd) + io_idx_pa_cwd = io_idx_pa_cwd + 1 + end do + ! -------------------------------------------------------------------------- ! Pull litter from the restart arrays ! Each element has its own variable, so we have to make sure From 54e35d19932ea2a827ef6cb6d94b8431cdb898f7 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 15 Sep 2021 16:50:33 -0700 Subject: [PATCH 392/578] correcting the location of the ncl cohort index assignment --- main/FatesRestartInterfaceMod.F90 | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 69cc2e3f8b..5fe3b267a1 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -774,7 +774,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates cohort- daily ammonium [NH4] uptake', & units='kg/plant/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_nh4_uptake_co ) - + call this%set_restart_var(vname='fates_daily_no3_uptake', vtype=cohort_r8, & long_name='fates cohort- daily ammonium [NO3] uptake', & units='kg/plant/day', flushval = flushzero, & @@ -976,7 +976,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name_base='seed bank fragmentation flux (germinated)', & units='kg/m2', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seedgerm_decay_litt) - + call this%RegisterCohortVector(symbol_base='fates_ag_cwd_frag', vtype=cohort_r8, & long_name_base='above ground CWD frag flux', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & @@ -1132,7 +1132,7 @@ subroutine define_restart_vars(this, initialize_variables) units='kg/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_errh2o ) - + end if @@ -1752,7 +1752,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_ib = io_idx_co_1st io_idx_si_wmem = io_idx_co_1st io_idx_si_vtmem = io_idx_co_1st - + io_idx_pa_ncl = io_idx_co_1st ! Hydraulics counters lyr = hydraulic layer, shell = rhizosphere shell io_idx_si_lyr_shell = io_idx_co_1st @@ -2009,7 +2009,6 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_cwsl = io_idx_co_1st io_idx_pa_dcsl = io_idx_co_1st io_idx_pa_dc = io_idx_co_1st - io_idx_pa_ncl = io_idx_co_1st litt => cpatch%litter(el+1) @@ -2179,7 +2178,7 @@ end subroutine set_restart_vectors ! ==================================================================================== - subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in, bc_out) + subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in, bc_out) ! ---------------------------------------------------------------------------------- ! This subroutine takes a peak at the restart file to determine how to allocate @@ -2493,7 +2492,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & rio_daily_nh4_uptake_co => this%rvars(ir_daily_nh4_uptake_co)%r81d, & - rio_daily_no3_uptake_co => this%rvars(ir_daily_no3_uptake_co)%r81d, & + rio_daily_no3_uptake_co => this%rvars(ir_daily_no3_uptake_co)%r81d, & rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & From b549a24331d68514aa95089bd027db04d02c0e4e Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 22 Sep 2021 16:58:03 -0600 Subject: [PATCH 393/578] auto-indented EDCanopyStructureMod.F90 --- biogeochem/EDCanopyStructureMod.F90 | 3360 +++++++++++++-------------- 1 file changed, 1680 insertions(+), 1680 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index bc72fa85a7..f86d50570c 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -61,1134 +61,1134 @@ module EDCanopyStructureMod character(len=*), parameter, private :: sourcefile = & __FILE__ - + real(r8), parameter :: area_target_precision = 1.0E-11_r8 ! Area conservation - ! will attempt to reduce errors - ! below this level - + ! will attempt to reduce errors + ! below this level + real(r8), parameter :: area_check_precision = 1.0E-7_r8 ! Area conservation checks must - ! be within this absolute tolerance + ! be within this absolute tolerance real(r8), parameter :: area_check_rel_precision = 1.0E-4_r8 ! Area conservation checks must - ! be within this relative tolerance + ! be within this relative tolerance + + real(r8), parameter :: similar_height_tol = 1.0E-3_r8 ! I think trees that differ by 1mm + ! can be roughly considered the same right? + + + ! 10/30/09: Created by Rosie Fisher + ! 2017/2018: Modifications and updates by Ryan Knox + ! ============================================================================ + +contains + + ! ============================================================================ + subroutine canopy_structure( currentSite , bc_in ) + ! + ! !DESCRIPTION: + ! create cohort instance + ! + ! This routine allocates the 'canopy_layer' attribute to each cohort + ! All top leaves in the same canopy layer get the same light resources. + ! The first canopy layer is the 'canopy' or 'overstorey'. The second is the 'understorey'. + ! More than two layers is not permitted at the moment + ! Seeds germinating into the 3rd or higher layers are automatically removed. + ! + ! ------Perfect Plasticity----- + ! The idea of these canopy layers derives originally from Purves et al. 2009 + ! Their concept is that, given enoughplasticity in canopy position, size, shape and depth + ! all of the gound area will be filled perfectly by leaves, and additional leaves will have + ! to exist in the understorey. + ! Purves et al. use the concept of 'Z*' to assume that the height required to attain a place in the + ! canopy is spatially uniform. In this implementation, described in Fisher et al. (2010, New Phyt) we + ! extent that concept to assume that position in the canopy has some random element, and that BOTH height + ! and chance combine to determine whether trees get into the canopy. + ! Thus, when the canopy is closed and there is excess area, some of it must be demoted + ! If we demote -all- the trees less than a given height, there is a massive advantage in being the cohort that is + ! the biggest when the canopy is closed. + ! In this implementation, the amount demoted, ('weight') is a function of the height weighted by the competitive exclusion + ! parameter (ED_val_comp_excln). + + ! Complexity in this routine results from a few things. + ! Firstly, the complication of the demotion amount sometimes being larger than the cohort area (for a very small, short cohort) + ! Second, occasionaly, disturbance (specifically fire) can cause the canopy layer to become less than closed, + ! without changing the area of the patch. If this happens, then some of the plants in the lower layer need to be 'promoted' so + ! all of the routine has to happen in both the downwards and upwards directions. + ! + ! The order of events here is therefore: + ! (The entire subroutine has a single outer 'patch' loop. + ! Section 1: figure out the total area, and whether there are >1 canopy layers at all. + ! + ! Sorts out cohorts into canopy and understorey layers... + ! + ! !USES: + + use EDParamsMod, only : ED_val_comp_excln + use EDTypesMod , only : min_patch_area + + ! + ! !ARGUMENTS + type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type), intent(in) :: bc_in + + ! + ! !LOCAL VARIABLES: + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + integer :: i_lyr ! current layer index + integer :: z ! Current number of canopy layers. (1= canopy, 2 = understorey) + integer :: ipft + real(r8) :: arealayer(nclmax+2) ! Amount of plant area currently in each canopy layer + integer :: patch_area_counter ! count iterations used to solve canopy areas + logical :: area_not_balanced ! logical controlling if the patch layer areas + ! have successfully been redistributed + integer :: return_code ! math checks on variables will return>0 if problems exist + + ! We only iterate because of possible imprecisions generated by the cohort + ! termination process. These should be super small, so at the most + ! try to re-balance 3 times. If that doesn't give layer areas + ! within tolerance of canopy area, there is something wrong + + integer, parameter :: max_patch_iterations = 10 + + + !---------------------------------------------------------------------- + currentPatch => currentSite%oldest_patch + ! + ! zero site-level demotion / promotion tracking info + currentSite%demotion_rate(:) = 0._r8 + currentSite%promotion_rate(:) = 0._r8 + currentSite%demotion_carbonflux = 0._r8 + currentSite%promotion_carbonflux = 0._r8 + + + ! + ! Section 1: Check total canopy area. + ! + do while (associated(currentPatch)) ! Patch loop + + ! ------------------------------------------------------------------------------ + ! Perform numerical checks on some cohort and patch structures + ! ------------------------------------------------------------------------------ + + ! canopy layer has a special bounds check + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if( currentCohort%canopy_layer < 1 .or. currentCohort%canopy_layer > nclmax+1 ) then + write(fates_log(),*) 'lat:',currentSite%lat + write(fates_log(),*) 'lon:',currentSite%lon + write(fates_log(),*) 'BOGUS CANOPY LAYER: ',currentCohort%canopy_layer + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + currentCohort => currentCohort%shorter + enddo + + + ! Does any layer have excess area in it? Keep going until it does not... + patch_area_counter = 0 + area_not_balanced = .true. + + do while(area_not_balanced) + + ! --------------------------------------------------------------------------- + ! Demotion Phase: Identify upper layers that are too full, and demote them to + ! the layers below. + ! --------------------------------------------------------------------------- + + ! Its possible that before we even enter this scheme + ! some cohort numbers are very low. Terminate them. + call terminate_cohorts(currentSite, currentPatch, 1, 12, bc_in) + + ! Calculate how many layers we have in this canopy + ! This also checks the understory to see if its crown + ! area is large enough to warrant a temporary sub-understory layer + z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) + + do i_lyr = 1,z ! Loop around the currently occupied canopy layers. + call DemoteFromLayer(currentSite, currentPatch, i_lyr, bc_in) + end do + + ! After demotions, we may then again have cohorts that are very very + ! very sparse, remove them + call terminate_cohorts(currentSite, currentPatch, 1,13,bc_in) + + call fuse_cohorts(currentSite, currentPatch, bc_in) + + ! Remove cohorts for various other reasons + call terminate_cohorts(currentSite, currentPatch, 2,13,bc_in) + + + ! --------------------------------------------------------------------------------------- + ! Promotion Phase: Identify if any upper-layers are underful and layers below them + ! have cohorts that can be split and promoted to the layer above. + ! --------------------------------------------------------------------------------------- + + ! Re-calculate Number of layers without the false substory + z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) + + ! We only promote if we have at least two layers + if (z>1) then + + do i_lyr=1,z-1 + call PromoteIntoLayer(currentSite, currentPatch, i_lyr) + end do + + ! Remove cohorts that are incredibly sparse + call terminate_cohorts(currentSite, currentPatch, 1,14,bc_in) + + call fuse_cohorts(currentSite, currentPatch, bc_in) + + ! Remove cohorts for various other reasons + call terminate_cohorts(currentSite, currentPatch, 2,14,bc_in) + + end if + + ! --------------------------------------------------------------------------------------- + ! Check on Layer Area (if the layer differences are not small + ! Continue trying to demote/promote. Its possible on the first pass through, + ! that cohort fusion has nudged the areas a little bit. + ! --------------------------------------------------------------------------------------- + + z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) + area_not_balanced = .false. + do i_lyr = 1,z + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer(i_lyr)) + if( ((arealayer(i_lyr)-currentPatch%area)/currentPatch%area > area_check_rel_precision) .or. & + ((arealayer(i_lyr)-currentPatch%area) > area_check_precision ) ) then + area_not_balanced = .true. + endif + enddo + + ! --------------------------------------------------------------------------------------- + ! Gracefully exit if too many iterations have gone by + ! --------------------------------------------------------------------------------------- + + patch_area_counter = patch_area_counter + 1 + if(patch_area_counter > max_patch_iterations .and. area_not_balanced) then + write(fates_log(),*) 'PATCH AREA CHECK NOT CLOSING' + write(fates_log(),*) 'patch area:',currentpatch%area + do i_lyr = 1,z + write(fates_log(),*) 'layer: ',i_lyr,' area: ',arealayer(i_lyr) + write(fates_log(),*) 'rel error: ',(arealayer(i_lyr)-currentPatch%area)/currentPatch%area + write(fates_log(),*) 'abs error: ',arealayer(i_lyr)-currentPatch%area + enddo + write(fates_log(),*) 'lat:',currentSite%lat + write(fates_log(),*) 'lon:',currentSite%lon + write(fates_log(),*) 'spread:',currentSite%spread + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + write(fates_log(),*) 'coh ilayer:',currentCohort%canopy_layer + write(fates_log(),*) 'coh dbh:',currentCohort%dbh + write(fates_log(),*) 'coh pft:',currentCohort%pft + write(fates_log(),*) 'coh n:',currentCohort%n + write(fates_log(),*) 'coh carea:',currentCohort%c_area + ipft=currentCohort%pft + write(fates_log(),*) 'maxh:',prt_params%allom_dbh_maxheight(ipft) + write(fates_log(),*) 'lmode: ',prt_params%allom_lmode(ipft) + write(fates_log(),*) 'd2bl2: ',prt_params%allom_d2bl2(ipft) + write(fates_log(),*) 'd2bl_ediff: ',prt_params%allom_blca_expnt_diff(ipft) + write(fates_log(),*) 'd2ca_min: ',prt_params%allom_d2ca_coefficient_min(ipft) + write(fates_log(),*) 'd2ca_max: ',prt_params%allom_d2ca_coefficient_max(ipft) + currentCohort => currentCohort%shorter + enddo + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + enddo ! do while(area_not_balanced) + + + ! Set current canopy layer occupancy indicator. + currentPatch%NCL_p = min(nclmax,z) + + ! ------------------------------------------------------------------------------------------- + ! if we are using "strict PPA", then calculate a z_star value as + ! the height of the smallest tree in the canopy + ! loop from top to bottom and locate the shortest cohort in level 1 whose shorter + ! neighbor is in level 2 set zstar as the ehight of that shortest level 1 cohort + ! ------------------------------------------------------------------------------------------- + + if ( ED_val_comp_excln .lt. 0.0_r8) then + currentPatch%zstar = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer .eq. 2)then + if (associated(currentCohort%taller)) then + if (currentCohort%taller%canopy_layer .eq. 1 ) then + currentPatch%zstar = currentCohort%taller%hite + endif + endif + endif + currentCohort => currentCohort%shorter + enddo + endif + + currentPatch => currentPatch%younger + enddo !patch + + return + end subroutine canopy_structure + + + ! ============================================================================================== + + + subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) + + use EDParamsMod, only : ED_val_comp_excln + use SFParamsMod, only : SF_val_CWD_frac + + ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite + type(ed_patch_type), intent(inout), target :: currentPatch + integer, intent(in) :: i_lyr ! Current canopy layer of interest + type(bc_in_type), intent(in) :: bc_in + + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer :: currentCohort + type(ed_cohort_type), pointer :: copyc + type(ed_cohort_type), pointer :: nextc ! The next cohort in line + integer :: i_cwd ! Index for CWD pool + real(r8) :: cc_loss ! cohort crown area loss in demotion (m2) + real(r8) :: leaf_c ! leaf carbon [kg] + real(r8) :: fnrt_c ! fineroot carbon [kg] + real(r8) :: sapw_c ! sapwood carbon [kg] + real(r8) :: store_c ! storage carbon [kg] + real(r8) :: struct_c ! structure carbon [kg] + real(r8) :: scale_factor ! for prob. exclusion - scales weight to a fraction + real(r8) :: scale_factor_min ! "" minimum before exeedance of 1 + real(r8) :: scale_factor_res ! "" applied to residual areas + real(r8) :: area_res ! residual area to demote after weakest cohort hits max + real(r8) :: newarea + real(r8) :: demote_area + real(r8) :: sumweights + real(r8) :: sumequal ! for rank-ordered same-size cohorts + ! this tallies their excluded area + real(r8) :: arealayer ! the area of the current canopy layer + logical :: tied_size_with_neighbors + real(r8) :: total_crownarea_of_tied_cohorts + + ! First, determine how much total canopy area we have in this layer + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer) + + demote_area = arealayer - currentPatch%area + + if ( demote_area > area_target_precision ) then + + ! Is this layer currently over-occupied? + ! In that case, we need to work out which cohorts to demote. + ! We go in order from shortest to tallest for ranked demotion + + sumweights = 0.0_r8 + currentCohort => currentPatch%shortest + do while (associated(currentCohort)) + call carea_allom(currentCohort%dbh,currentCohort%n, & + currentSite%spread,currentCohort%pft,currentCohort%c_area) + + if(debug) then + if(currentCohort%c_area<0._r8)then + write(fates_log(),*) 'negative c_area stage 1d: ',currentCohort%dbh,i_lyr,currentCohort%n, & + currentSite%spread,currentCohort%pft,currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + if( currentCohort%canopy_layer == i_lyr)then + + if (ED_val_comp_excln .ge. 0.0_r8 ) then + + ! ---------------------------------------------------------- + ! Stochastic method. + ! Weight cohort demotion by inverse size to a constant power. + ! In this hypothesis, it is assumed that even the tallest + ! cohorts have a chance (although smaller) of being forced + ! to the understory. + ! ---------------------------------------------------------- + + currentCohort%excl_weight = 1._r8 / (currentCohort%hite**ED_val_comp_excln) + sumweights = sumweights + currentCohort%excl_weight + + else + + ! ----------------------------------------------------------- + ! Rank ordered deterministic method + ! ----------------------------------------------------------- + ! If there are cohorts that have the exact same height (which is possible, really) + ! we don't want to unilaterally promote/demote one before the others. + ! So we <>mote them as a unit + ! now we need to go through and figure out how many equal-size cohorts there are. + ! then we need to go through, add up the collective crown areas of all equal-sized + ! and equal-canopy-layer cohorts, + ! and then demote from each as if they were a single group + + total_crownarea_of_tied_cohorts = currentCohort%c_area + + tied_size_with_neighbors = .false. + nextc => currentCohort%taller + do while (associated(nextc)) + if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then + if( nextc%canopy_layer .eq. currentCohort%canopy_layer ) then + tied_size_with_neighbors = .true. + total_crownarea_of_tied_cohorts = & + total_crownarea_of_tied_cohorts + nextc%c_area + end if + else + exit + endif + nextc => nextc%taller + end do + + if ( tied_size_with_neighbors ) then + + currentCohort%excl_weight = & + max(0.0_r8,min(currentCohort%c_area, & + (currentCohort%c_area/total_crownarea_of_tied_cohorts) * & + (demote_area - sumweights) )) + + sumequal = currentCohort%excl_weight + + nextc => currentCohort%taller + do while (associated(nextc)) + if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then + if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then + ! now we know the total crown area of all equal-sized, + ! equal-canopy-layer cohorts + nextc%excl_weight = & + max(0.0_r8,min(nextc%c_area, & + (nextc%c_area/total_crownarea_of_tied_cohorts) * & + (demote_area - sumweights) )) + sumequal = sumequal + nextc%excl_weight + end if + else + exit + endif + nextc => nextc%taller + end do + + ! Update the current cohort pointer to the last similar cohort + ! Its ok if this is not in the right layer + if(associated(nextc))then + currentCohort => nextc%shorter + else + currentCohort => currentPatch%tallest + end if + sumweights = sumweights + sumequal + + else + currentCohort%excl_weight = & + max(min(currentCohort%c_area, demote_area - sumweights ), 0._r8) + sumweights = sumweights + currentCohort%excl_weight + end if + + endif + endif + currentCohort => currentCohort%taller + enddo + + ! If this is probabalistic demotion, we need to do a round of normalization. + ! And then a few rounds where we pre-calculate the demotion areas + ! and adjust things if the demoted area wants to be greater than + ! what is available. The math is too hard to explain here, see + ! the tech note section on promotion/demotion. + + if (ED_val_comp_excln .ge. 0.0_r8 ) then + + scale_factor_min = 1.e10_r8 + scale_factor = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + + if(currentCohort%canopy_layer == i_lyr) then + + currentCohort%excl_weight = currentCohort%excl_weight/sumweights + if( 1._r8/currentCohort%excl_weight < scale_factor_min ) & + scale_factor_min = 1._r8/currentCohort%excl_weight + + scale_factor = scale_factor + currentCohort%excl_weight * currentCohort%c_area + + endif + currentCohort => currentCohort%shorter + enddo + + ! This is the factor by which we need to multiply + ! the demotion probabilities, so the sum result equals + ! the total amount to demote + + scale_factor = demote_area/scale_factor + + if(scale_factor <= scale_factor_min) then + + ! Trivial case, all of the demotion fractions are less than 1. + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then + currentCohort%excl_weight = currentCohort%c_area * currentCohort%excl_weight * scale_factor + + if(debug) then + if((currentCohort%excl_weight > (currentCohort%c_area+area_target_precision)) .or. & + (currentCohort%excl_weight < 0._r8) ) then + write(fates_log(),*) 'exclusion area too big (1)' + write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area + write(fates_log(),*) 'dbh: ',currentCohort%dbh + write(fates_log(),*) 'n: ',currentCohort%n + write(fates_log(),*) 'spread: ',currentSite%spread + write(fates_log(),*) 'pft: ',currentCohort%pft + write(fates_log(),*) 'currentCohort%excl_weight: ',currentCohort%excl_weight + write(fates_log(),*) 'excess: ',currentCohort%excl_weight - currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + endif + currentCohort => currentCohort%shorter + enddo + + else + + + ! Non-trivial case, at least 1 cohort's demotion + ! rate would exceed its area, given the trivial scale factor + + area_res = 0._r8 + scale_factor_res = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then + area_res = area_res + & + currentCohort%c_area * currentCohort%excl_weight * & + scale_factor_min + scale_factor_res = scale_factor_res + & + currentCohort%c_area * & + (1._r8 - (currentCohort%excl_weight * scale_factor_min)) + endif + currentCohort => currentCohort%shorter + enddo + + area_res = demote_area - area_res + + scale_factor_res = area_res / scale_factor_res + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then + + currentCohort%excl_weight = currentCohort%c_area * & + (currentCohort%excl_weight * scale_factor_min + & + (1._r8 - (currentCohort%excl_weight*scale_factor_min) ) * scale_factor_res) + + if(debug)then + if((currentCohort%excl_weight > & + (currentCohort%c_area+area_target_precision)) .or. & + (currentCohort%excl_weight < 0._r8) ) then + write(fates_log(),*) 'exclusion area error (2)' + write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area + write(fates_log(),*) 'currentCohort%excl_weight: ', & + currentCohort%excl_weight + write(fates_log(),*) 'excess: ', & + currentCohort%excl_weight - currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + endif + currentCohort => currentCohort%shorter + enddo + + end if + + end if + + + ! perform a check and see if the demotions meet the demand + sumweights = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then + sumweights = sumweights + currentCohort%excl_weight + end if + currentCohort => currentCohort%shorter + end do + + if (abs(sumweights - demote_area) > area_check_precision ) then + write(fates_log(),*) 'demotions dont add up' + write(fates_log(),*) 'sum demotions: ',sumweights + write(fates_log(),*) 'area needed to be demoted: ',demote_area + write(fates_log(),*) 'excess: ',sumweights - demote_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + ! Weights have been calculated. Now move them to the lower layer + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + + if(currentCohort%canopy_layer == i_lyr )then + + cc_loss = currentCohort%excl_weight + leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) + sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) + struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) + + if ( (cc_loss-currentCohort%c_area) > -nearzero .and. & + (cc_loss-currentCohort%c_area) < area_target_precision ) then + + ! If the whole cohort is being demoted, just change its + ! layer index + + currentCohort%canopy_layer = i_lyr+1 + + ! keep track of number and biomass of demoted cohort + currentSite%demotion_rate(currentCohort%size_class) = & + currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & + (leaf_c + store_c + fnrt_c + sapw_c + struct_c) * currentCohort%n + + elseif( (cc_loss < currentCohort%c_area) .and. & + (cc_loss > area_target_precision) ) then + + ! If only part of the cohort is demoted + ! then it must be split (little more complicated) + + ! Make a copy of the current cohort. The copy and the original + ! conserve total number density of the original. The copy + ! remains in the upper-story. The original is the one + ! demoted to the understory + + + allocate(copyc) + + ! Initialize the PARTEH object and point to the + ! correct boundary condition fields + copyc%prt => null() + call InitPRTObject(copyc%prt) + call InitPRTBoundaryConditions(copyc) + + if( hlm_use_planthydro.eq.itrue ) then + call InitHydrCohort(currentSite,copyc) + endif + + call copy_cohort(currentCohort, copyc) + + newarea = currentCohort%c_area - cc_loss + copyc%n = currentCohort%n*newarea/currentCohort%c_area + currentCohort%n = currentCohort%n - copyc%n + + copyc%canopy_layer = i_lyr !the taller cohort is the copy + + ! Demote the current cohort to the understory. + currentCohort%canopy_layer = i_lyr + 1 + + ! keep track of number and biomass of demoted cohort + currentSite%demotion_rate(currentCohort%size_class) = & + currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & + (leaf_c + store_c + fnrt_c + sapw_c + struct_c) * currentCohort%n + + call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + currentCohort%pft,currentCohort%c_area) + + !----------- Insert copy into linked list ------------------------! + copyc%shorter => currentCohort + if(associated(currentCohort%taller))then + copyc%taller => currentCohort%taller + currentCohort%taller%shorter => copyc + else + currentPatch%tallest => copyc + copyc%taller => null() + endif + currentCohort%taller => copyc + + elseif(cc_loss > currentCohort%c_area)then + + write(fates_log(),*) 'more area than the cohort has is being demoted' + write(fates_log(),*) 'loss:',cc_loss + write(fates_log(),*) 'existing area:',currentCohort%c_area + write(fates_log(),*) 'excess: ',cc_loss - currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end if + + ! kill the ones which go into canopy layers that are not allowed + + if(currentCohort%canopy_layer>nclmax )then + + ! put the litter from the terminated cohorts + ! straight into the fragmenting pools + call SendCohortToLitter(currentSite,currentPatch, & + currentCohort,currentCohort%n,bc_in) + + currentCohort%n = 0.0_r8 + currentCohort%c_area = 0.0_r8 + currentCohort%canopy_layer = i_lyr + + end if + + call carea_allom(currentCohort%dbh,currentCohort%n, & + currentSite%spread,currentCohort%pft,currentCohort%c_area) + + endif !canopy layer = i_ly + + currentCohort => currentCohort%shorter + enddo !currentCohort + + + ! Update the area calculations of the current layer + ! And the layer below that may or may not had recieved + ! Demotions + + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer) + + if ( (abs(arealayer - currentPatch%area)/arealayer > area_check_rel_precision ) .or. & + (abs(arealayer - currentPatch%area) > area_check_precision) ) then + write(fates_log(),*) 'demotion did not trim area within tolerance' + write(fates_log(),*) 'arealayer:',arealayer + write(fates_log(),*) 'patch%area:',currentPatch%area + write(fates_log(),*) 'ilayer: ',i_lyr + write(fates_log(),*) 'bias:',arealayer - currentPatch%area + write(fates_log(),*) 'rel bias:',(arealayer - currentPatch%area)/arealayer + write(fates_log(),*) 'demote_area:',demote_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + end if + + return + end subroutine DemoteFromLayer + + ! ============================================================================================== + + subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) + + ! ------------------------------------------------------------------------------------------- + ! Check whether the intended 'full' layers are actually filling all the space. + ! If not, promote some fraction of cohorts upwards. + ! THIS SECTION MIGHT BE TRIGGERED BY A FIRE OR MORTALITY EVENT, FOLLOWED BY A PATCH FUSION, + ! SO THE TOP LAYER IS NO LONGER FULL. + ! ------------------------------------------------------------------------------------------- + + use EDParamsMod, only : ED_val_comp_excln + + ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite + type(ed_patch_type), intent(inout), target :: currentPatch + integer, intent(in) :: i_lyr ! Current canopy layer of interest + + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer :: currentCohort + type(ed_cohort_type), pointer :: copyc + type(ed_cohort_type), pointer :: nextc ! the next cohort, or used for looping + ! cohorts against the current + + real(r8) :: scale_factor ! for prob. exclusion - scales weight to a fraction + real(r8) :: scale_factor_min ! "" minimum before exeedance of 1 + real(r8) :: scale_factor_res ! "" applied to residual areas + real(r8) :: area_res ! residual area to demote after weakest cohort hits max + real(r8) :: promote_area + real(r8) :: newarea + real(r8) :: sumweights + real(r8) :: sumequal ! for tied cohorts, the sum of weights in + ! their group + real(r8) :: cc_gain ! cohort crown area gain in promotion (m2) + real(r8) :: arealayer_current ! area (m2) of the current canopy layer + real(r8) :: arealayer_below ! area (m2) of the layer below the current layer + real(r8) :: leaf_c ! leaf carbon [kg] + real(r8) :: fnrt_c ! fineroot carbon [kg] + real(r8) :: sapw_c ! sapwood carbon [kg] + real(r8) :: store_c ! storage carbon [kg] + real(r8) :: struct_c ! structure carbon [kg] + + logical :: tied_size_with_neighbors + real(r8) :: total_crownarea_of_tied_cohorts + + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr+1,arealayer_below) + + + ! how much do we need to gain? + promote_area = currentPatch%area - arealayer_current + + if( promote_area > area_target_precision ) then + + if(arealayer_below <= promote_area ) then + + ! --------------------------------------------------------------------------- + ! Promote all cohorts from layer below if that whole layer has area smaller + ! than the tolerance on the gains needed into current layer + ! --------------------------------------------------------------------------- + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + !look at the cohorts in the canopy layer below... + if(currentCohort%canopy_layer == i_lyr+1)then + + leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) + sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) + struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) + + currentCohort%canopy_layer = i_lyr + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + currentCohort%pft,currentCohort%c_area) + ! keep track of number and biomass of promoted cohort + currentSite%promotion_rate(currentCohort%size_class) = & + currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & + (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n + + endif + currentCohort => currentCohort%shorter + enddo + + else + + ! --------------------------------------------------------------------------- + ! This is the non-trivial case where the lower layer can accomodate + ! more than what is necessary. + ! --------------------------------------------------------------------------- + + + ! figure out with what weighting we need to promote cohorts. + ! This is the opposite of the demotion weighting... + + sumweights = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + currentCohort%pft,currentCohort%c_area) + if(currentCohort%canopy_layer == i_lyr+1)then !look at the cohorts in the canopy layer below... + + if (ED_val_comp_excln .ge. 0.0_r8 ) then + + ! ------------------------------------------------------------------ + ! Stochastic case, as above (in demotion portion of code) + ! ------------------------------------------------------------------ + + currentCohort%prom_weight = currentCohort%hite**ED_val_comp_excln + sumweights = sumweights + currentCohort%prom_weight + else + + ! ------------------------------------------------------------------ + ! Rank ordered deterministic method + ! If there are cohorts that have the exact same height (which is possible, really) + ! we don't want to unilaterally promote/demote one before the others. + ! So we <>mote them as a unit + ! now we need to go through and figure out how many equal-size cohorts there are. + ! then we need to go through, add up the collective crown areas of all equal-sized + ! and equal-canopy-layer cohorts, + ! and then demote from each as if they were a single group + ! ------------------------------------------------------------------ + + total_crownarea_of_tied_cohorts = currentCohort%c_area + tied_size_with_neighbors = .false. + nextc => currentCohort%shorter + do while (associated(nextc)) + if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then + if( nextc%canopy_layer .eq. currentCohort%canopy_layer ) then + tied_size_with_neighbors = .true. + total_crownarea_of_tied_cohorts = & + total_crownarea_of_tied_cohorts + nextc%c_area + end if + else + exit + endif + nextc => nextc%shorter + end do + + if ( tied_size_with_neighbors ) then + + currentCohort%prom_weight = & + max(0.0_r8,min(currentCohort%c_area, & + (currentCohort%c_area/total_crownarea_of_tied_cohorts) * & + (promote_area - sumweights) )) + sumequal = currentCohort%prom_weight + + nextc => currentCohort%shorter + do while (associated(nextc)) + if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then + if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then + ! now we know the total crown area of all equal-sized, + ! equal-canopy-layer cohorts + nextc%prom_weight = & + max(0.0_r8,min(nextc%c_area, & + (nextc%c_area/total_crownarea_of_tied_cohorts) * & + (promote_area - sumweights) )) + sumequal = sumequal + nextc%prom_weight + end if + else + exit + endif + nextc => nextc%shorter + end do + + ! Update the current cohort pointer to the last similar cohort + ! Its ok if this is not in the right layer + if(associated(nextc))then + currentCohort => nextc%taller + else + currentCohort => currentPatch%shortest + end if + sumweights = sumweights + sumequal + + else + currentCohort%prom_weight = & + max(min(currentCohort%c_area, promote_area - sumweights ), 0._r8) + sumweights = sumweights + currentCohort%prom_weight + + end if + + endif + endif + currentCohort => currentCohort%shorter + enddo !currentCohort + + + ! If this is probabalistic promotion, we need to do a round of normalization. + ! And then a few rounds where we pre-calculate the promotion areas + ! and adjust things if the promoted area wants to be greater than + ! what is available. + + if (ED_val_comp_excln .ge. 0.0_r8 ) then + + scale_factor_min = 1.e10_r8 + scale_factor = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + + if(currentCohort%canopy_layer == (i_lyr+1) ) then + + currentCohort%prom_weight = currentCohort%prom_weight/sumweights + if( 1._r8/currentCohort%prom_weight < scale_factor_min ) & + scale_factor_min = 1._r8/currentCohort%prom_weight + + scale_factor = scale_factor + currentCohort%prom_weight * currentCohort%c_area + + endif + currentCohort => currentCohort%shorter + enddo + + ! This is the factor by which we need to multiply + ! the demotion probabilities, so the sum result equals + ! the total amount to demote + scale_factor = promote_area/scale_factor + + + if(scale_factor <= scale_factor_min) then + + ! Trivial case, all of the demotion fractions + ! are less than 1. + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1) ) then + currentCohort%prom_weight = currentCohort%c_area * & + currentCohort%prom_weight * scale_factor + + if(debug)then + if((currentCohort%prom_weight > & + (currentCohort%c_area+area_target_precision)) .or. & + (currentCohort%prom_weight < 0._r8) ) then + write(fates_log(),*) 'promotion area too big (1)' + write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area + write(fates_log(),*) 'currentCohort%prom_weight: ', & + currentCohort%prom_weight + write(fates_log(),*) 'excess: ', & + currentCohort%prom_weight - currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + endif + currentCohort => currentCohort%shorter + enddo + + else + + ! Non-trivial case, at least 1 cohort's promotion + ! rate would exceed its area, given the trivial scale factor + + area_res = 0._r8 + scale_factor_res = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1) ) then + area_res = area_res + & + currentCohort%c_area*currentCohort%prom_weight*scale_factor_min + scale_factor_res = scale_factor_res + & + currentCohort%c_area * & + (1._r8 - (currentCohort%prom_weight * scale_factor_min)) + endif + currentCohort => currentCohort%shorter + enddo + + area_res = promote_area - area_res + + scale_factor_res = area_res / scale_factor_res + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1)) then + + currentCohort%prom_weight = currentCohort%c_area * & + (currentCohort%prom_weight * scale_factor_min + & + (1._r8 - (currentCohort%prom_weight*scale_factor_min) ) * & + scale_factor_res) + + if(debug)then + if((currentCohort%prom_weight > & + (currentCohort%c_area+area_target_precision)) .or. & + (currentCohort%prom_weight < 0._r8) ) then + write(fates_log(),*) 'promotion area error (2)' + write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area + write(fates_log(),*) 'currentCohort%prom_weight: ', & + currentCohort%prom_weight + write(fates_log(),*) 'excess: ', & + currentCohort%prom_weight - currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + endif + currentCohort => currentCohort%shorter + enddo + + end if + + end if - real(r8), parameter :: similar_height_tol = 1.0E-3_r8 ! I think trees that differ by 1mm - ! can be roughly considered the same right? + ! lets perform a check and see if the promotions meet the demand + sumweights = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1)) then + sumweights = sumweights + currentCohort%prom_weight + end if + currentCohort => currentCohort%shorter + end do + + if(debug)then + if (abs(sumweights - promote_area) > area_check_precision ) then + write(fates_log(),*) 'promotions dont add up' + write(fates_log(),*) 'sum promotions: ',sumweights + write(fates_log(),*) 'area needed to be promoted: ',promote_area + write(fates_log(),*) 'excess: ',sumweights - promote_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if - ! 10/30/09: Created by Rosie Fisher - ! 2017/2018: Modifications and updates by Ryan Knox - ! ============================================================================ + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) -contains - ! ============================================================================ - subroutine canopy_structure( currentSite , bc_in ) - ! - ! !DESCRIPTION: - ! create cohort instance - ! - ! This routine allocates the 'canopy_layer' attribute to each cohort - ! All top leaves in the same canopy layer get the same light resources. - ! The first canopy layer is the 'canopy' or 'overstorey'. The second is the 'understorey'. - ! More than two layers is not permitted at the moment - ! Seeds germinating into the 3rd or higher layers are automatically removed. - ! - ! ------Perfect Plasticity----- - ! The idea of these canopy layers derives originally from Purves et al. 2009 - ! Their concept is that, given enoughplasticity in canopy position, size, shape and depth - ! all of the gound area will be filled perfectly by leaves, and additional leaves will have - ! to exist in the understorey. - ! Purves et al. use the concept of 'Z*' to assume that the height required to attain a place in the - ! canopy is spatially uniform. In this implementation, described in Fisher et al. (2010, New Phyt) we - ! extent that concept to assume that position in the canopy has some random element, and that BOTH height - ! and chance combine to determine whether trees get into the canopy. - ! Thus, when the canopy is closed and there is excess area, some of it must be demoted - ! If we demote -all- the trees less than a given height, there is a massive advantage in being the cohort that is - ! the biggest when the canopy is closed. - ! In this implementation, the amount demoted, ('weight') is a function of the height weighted by the competitive exclusion - ! parameter (ED_val_comp_excln). - - ! Complexity in this routine results from a few things. - ! Firstly, the complication of the demotion amount sometimes being larger than the cohort area (for a very small, short cohort) - ! Second, occasionaly, disturbance (specifically fire) can cause the canopy layer to become less than closed, - ! without changing the area of the patch. If this happens, then some of the plants in the lower layer need to be 'promoted' so - ! all of the routine has to happen in both the downwards and upwards directions. - ! - ! The order of events here is therefore: - ! (The entire subroutine has a single outer 'patch' loop. - ! Section 1: figure out the total area, and whether there are >1 canopy layers at all. - ! - ! Sorts out cohorts into canopy and understorey layers... - ! - ! !USES: - - use EDParamsMod, only : ED_val_comp_excln - use EDTypesMod , only : min_patch_area - - ! - ! !ARGUMENTS - type(ed_site_type) , intent(inout), target :: currentSite - type(bc_in_type), intent(in) :: bc_in - - ! - ! !LOCAL VARIABLES: - type(ed_patch_type) , pointer :: currentPatch - type(ed_cohort_type), pointer :: currentCohort - integer :: i_lyr ! current layer index - integer :: z ! Current number of canopy layers. (1= canopy, 2 = understorey) - integer :: ipft - real(r8) :: arealayer(nclmax+2) ! Amount of plant area currently in each canopy layer - integer :: patch_area_counter ! count iterations used to solve canopy areas - logical :: area_not_balanced ! logical controlling if the patch layer areas - ! have successfully been redistributed - integer :: return_code ! math checks on variables will return>0 if problems exist - - ! We only iterate because of possible imprecisions generated by the cohort - ! termination process. These should be super small, so at the most - ! try to re-balance 3 times. If that doesn't give layer areas - ! within tolerance of canopy area, there is something wrong - - integer, parameter :: max_patch_iterations = 10 - - - !---------------------------------------------------------------------- - currentPatch => currentSite%oldest_patch - ! - ! zero site-level demotion / promotion tracking info - currentSite%demotion_rate(:) = 0._r8 - currentSite%promotion_rate(:) = 0._r8 - currentSite%demotion_carbonflux = 0._r8 - currentSite%promotion_carbonflux = 0._r8 - - - ! - ! Section 1: Check total canopy area. - ! - do while (associated(currentPatch)) ! Patch loop - - ! ------------------------------------------------------------------------------ - ! Perform numerical checks on some cohort and patch structures - ! ------------------------------------------------------------------------------ - - ! canopy layer has a special bounds check - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if( currentCohort%canopy_layer < 1 .or. currentCohort%canopy_layer > nclmax+1 ) then - write(fates_log(),*) 'lat:',currentSite%lat - write(fates_log(),*) 'lon:',currentSite%lon - write(fates_log(),*) 'BOGUS CANOPY LAYER: ',currentCohort%canopy_layer - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - currentCohort => currentCohort%shorter - enddo - - - ! Does any layer have excess area in it? Keep going until it does not... - patch_area_counter = 0 - area_not_balanced = .true. - - do while(area_not_balanced) - - ! --------------------------------------------------------------------------- - ! Demotion Phase: Identify upper layers that are too full, and demote them to - ! the layers below. - ! --------------------------------------------------------------------------- - - ! Its possible that before we even enter this scheme - ! some cohort numbers are very low. Terminate them. - call terminate_cohorts(currentSite, currentPatch, 1, 12, bc_in) - - ! Calculate how many layers we have in this canopy - ! This also checks the understory to see if its crown - ! area is large enough to warrant a temporary sub-understory layer - z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) - - do i_lyr = 1,z ! Loop around the currently occupied canopy layers. - call DemoteFromLayer(currentSite, currentPatch, i_lyr, bc_in) - end do - - ! After demotions, we may then again have cohorts that are very very - ! very sparse, remove them - call terminate_cohorts(currentSite, currentPatch, 1,13,bc_in) - - call fuse_cohorts(currentSite, currentPatch, bc_in) - - ! Remove cohorts for various other reasons - call terminate_cohorts(currentSite, currentPatch, 2,13,bc_in) - - - ! --------------------------------------------------------------------------------------- - ! Promotion Phase: Identify if any upper-layers are underful and layers below them - ! have cohorts that can be split and promoted to the layer above. - ! --------------------------------------------------------------------------------------- - - ! Re-calculate Number of layers without the false substory - z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) - - ! We only promote if we have at least two layers - if (z>1) then - - do i_lyr=1,z-1 - call PromoteIntoLayer(currentSite, currentPatch, i_lyr) - end do - - ! Remove cohorts that are incredibly sparse - call terminate_cohorts(currentSite, currentPatch, 1,14,bc_in) - - call fuse_cohorts(currentSite, currentPatch, bc_in) - - ! Remove cohorts for various other reasons - call terminate_cohorts(currentSite, currentPatch, 2,14,bc_in) - - end if - - ! --------------------------------------------------------------------------------------- - ! Check on Layer Area (if the layer differences are not small - ! Continue trying to demote/promote. Its possible on the first pass through, - ! that cohort fusion has nudged the areas a little bit. - ! --------------------------------------------------------------------------------------- - - z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) - area_not_balanced = .false. - do i_lyr = 1,z - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer(i_lyr)) - if( ((arealayer(i_lyr)-currentPatch%area)/currentPatch%area > area_check_rel_precision) .or. & - ((arealayer(i_lyr)-currentPatch%area) > area_check_precision ) ) then - area_not_balanced = .true. - endif - enddo - - ! --------------------------------------------------------------------------------------- - ! Gracefully exit if too many iterations have gone by - ! --------------------------------------------------------------------------------------- - - patch_area_counter = patch_area_counter + 1 - if(patch_area_counter > max_patch_iterations .and. area_not_balanced) then - write(fates_log(),*) 'PATCH AREA CHECK NOT CLOSING' - write(fates_log(),*) 'patch area:',currentpatch%area - do i_lyr = 1,z - write(fates_log(),*) 'layer: ',i_lyr,' area: ',arealayer(i_lyr) - write(fates_log(),*) 'rel error: ',(arealayer(i_lyr)-currentPatch%area)/currentPatch%area - write(fates_log(),*) 'abs error: ',arealayer(i_lyr)-currentPatch%area - enddo - write(fates_log(),*) 'lat:',currentSite%lat - write(fates_log(),*) 'lon:',currentSite%lon - write(fates_log(),*) 'spread:',currentSite%spread - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - write(fates_log(),*) 'coh ilayer:',currentCohort%canopy_layer - write(fates_log(),*) 'coh dbh:',currentCohort%dbh - write(fates_log(),*) 'coh pft:',currentCohort%pft - write(fates_log(),*) 'coh n:',currentCohort%n - write(fates_log(),*) 'coh carea:',currentCohort%c_area - ipft=currentCohort%pft - write(fates_log(),*) 'maxh:',prt_params%allom_dbh_maxheight(ipft) - write(fates_log(),*) 'lmode: ',prt_params%allom_lmode(ipft) - write(fates_log(),*) 'd2bl2: ',prt_params%allom_d2bl2(ipft) - write(fates_log(),*) 'd2bl_ediff: ',prt_params%allom_blca_expnt_diff(ipft) - write(fates_log(),*) 'd2ca_min: ',prt_params%allom_d2ca_coefficient_min(ipft) - write(fates_log(),*) 'd2ca_max: ',prt_params%allom_d2ca_coefficient_max(ipft) - currentCohort => currentCohort%shorter - enddo - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - enddo ! do while(area_not_balanced) - - - ! Set current canopy layer occupancy indicator. - currentPatch%NCL_p = min(nclmax,z) - - ! ------------------------------------------------------------------------------------------- - ! if we are using "strict PPA", then calculate a z_star value as - ! the height of the smallest tree in the canopy - ! loop from top to bottom and locate the shortest cohort in level 1 whose shorter - ! neighbor is in level 2 set zstar as the ehight of that shortest level 1 cohort - ! ------------------------------------------------------------------------------------------- - - if ( ED_val_comp_excln .lt. 0.0_r8) then - currentPatch%zstar = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer .eq. 2)then - if (associated(currentCohort%taller)) then - if (currentCohort%taller%canopy_layer .eq. 1 ) then - currentPatch%zstar = currentCohort%taller%hite - endif - endif - endif - currentCohort => currentCohort%shorter - enddo - endif - - currentPatch => currentPatch%younger - enddo !patch - - return - end subroutine canopy_structure - - - ! ============================================================================================== - - - subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) - - use EDParamsMod, only : ED_val_comp_excln - use SFParamsMod, only : SF_val_CWD_frac - - ! !ARGUMENTS - type(ed_site_type), intent(inout), target :: currentSite - type(ed_patch_type), intent(inout), target :: currentPatch - integer, intent(in) :: i_lyr ! Current canopy layer of interest - type(bc_in_type), intent(in) :: bc_in - - ! !LOCAL VARIABLES: - type(ed_cohort_type), pointer :: currentCohort - type(ed_cohort_type), pointer :: copyc - type(ed_cohort_type), pointer :: nextc ! The next cohort in line - integer :: i_cwd ! Index for CWD pool - real(r8) :: cc_loss ! cohort crown area loss in demotion (m2) - real(r8) :: leaf_c ! leaf carbon [kg] - real(r8) :: fnrt_c ! fineroot carbon [kg] - real(r8) :: sapw_c ! sapwood carbon [kg] - real(r8) :: store_c ! storage carbon [kg] - real(r8) :: struct_c ! structure carbon [kg] - real(r8) :: scale_factor ! for prob. exclusion - scales weight to a fraction - real(r8) :: scale_factor_min ! "" minimum before exeedance of 1 - real(r8) :: scale_factor_res ! "" applied to residual areas - real(r8) :: area_res ! residual area to demote after weakest cohort hits max - real(r8) :: newarea - real(r8) :: demote_area - real(r8) :: sumweights - real(r8) :: sumequal ! for rank-ordered same-size cohorts - ! this tallies their excluded area - real(r8) :: arealayer ! the area of the current canopy layer - logical :: tied_size_with_neighbors - real(r8) :: total_crownarea_of_tied_cohorts - - ! First, determine how much total canopy area we have in this layer - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer) - - demote_area = arealayer - currentPatch%area - - if ( demote_area > area_target_precision ) then - - ! Is this layer currently over-occupied? - ! In that case, we need to work out which cohorts to demote. - ! We go in order from shortest to tallest for ranked demotion - - sumweights = 0.0_r8 - currentCohort => currentPatch%shortest - do while (associated(currentCohort)) - call carea_allom(currentCohort%dbh,currentCohort%n, & - currentSite%spread,currentCohort%pft,currentCohort%c_area) - - if(debug) then - if(currentCohort%c_area<0._r8)then - write(fates_log(),*) 'negative c_area stage 1d: ',currentCohort%dbh,i_lyr,currentCohort%n, & - currentSite%spread,currentCohort%pft,currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if( currentCohort%canopy_layer == i_lyr)then - - if (ED_val_comp_excln .ge. 0.0_r8 ) then - - ! ---------------------------------------------------------- - ! Stochastic method. - ! Weight cohort demotion by inverse size to a constant power. - ! In this hypothesis, it is assumed that even the tallest - ! cohorts have a chance (although smaller) of being forced - ! to the understory. - ! ---------------------------------------------------------- - - currentCohort%excl_weight = 1._r8 / (currentCohort%hite**ED_val_comp_excln) - sumweights = sumweights + currentCohort%excl_weight - - else - - ! ----------------------------------------------------------- - ! Rank ordered deterministic method - ! ----------------------------------------------------------- - ! If there are cohorts that have the exact same height (which is possible, really) - ! we don't want to unilaterally promote/demote one before the others. - ! So we <>mote them as a unit - ! now we need to go through and figure out how many equal-size cohorts there are. - ! then we need to go through, add up the collective crown areas of all equal-sized - ! and equal-canopy-layer cohorts, - ! and then demote from each as if they were a single group - - total_crownarea_of_tied_cohorts = currentCohort%c_area - - tied_size_with_neighbors = .false. - nextc => currentCohort%taller - do while (associated(nextc)) - if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then - if( nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - tied_size_with_neighbors = .true. - total_crownarea_of_tied_cohorts = & - total_crownarea_of_tied_cohorts + nextc%c_area - end if - else - exit - endif - nextc => nextc%taller - end do - - if ( tied_size_with_neighbors ) then - - currentCohort%excl_weight = & - max(0.0_r8,min(currentCohort%c_area, & - (currentCohort%c_area/total_crownarea_of_tied_cohorts) * & - (demote_area - sumweights) )) - - sumequal = currentCohort%excl_weight - - nextc => currentCohort%taller - do while (associated(nextc)) - if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then - if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - ! now we know the total crown area of all equal-sized, - ! equal-canopy-layer cohorts - nextc%excl_weight = & - max(0.0_r8,min(nextc%c_area, & - (nextc%c_area/total_crownarea_of_tied_cohorts) * & - (demote_area - sumweights) )) - sumequal = sumequal + nextc%excl_weight - end if - else - exit - endif - nextc => nextc%taller - end do - - ! Update the current cohort pointer to the last similar cohort - ! Its ok if this is not in the right layer - if(associated(nextc))then - currentCohort => nextc%shorter - else - currentCohort => currentPatch%tallest - end if - sumweights = sumweights + sumequal - - else - currentCohort%excl_weight = & - max(min(currentCohort%c_area, demote_area - sumweights ), 0._r8) - sumweights = sumweights + currentCohort%excl_weight - end if - - endif - endif - currentCohort => currentCohort%taller - enddo - - ! If this is probabalistic demotion, we need to do a round of normalization. - ! And then a few rounds where we pre-calculate the demotion areas - ! and adjust things if the demoted area wants to be greater than - ! what is available. The math is too hard to explain here, see - ! the tech note section on promotion/demotion. - - if (ED_val_comp_excln .ge. 0.0_r8 ) then - - scale_factor_min = 1.e10_r8 - scale_factor = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - - if(currentCohort%canopy_layer == i_lyr) then - - currentCohort%excl_weight = currentCohort%excl_weight/sumweights - if( 1._r8/currentCohort%excl_weight < scale_factor_min ) & - scale_factor_min = 1._r8/currentCohort%excl_weight - - scale_factor = scale_factor + currentCohort%excl_weight * currentCohort%c_area - - endif - currentCohort => currentCohort%shorter - enddo - - ! This is the factor by which we need to multiply - ! the demotion probabilities, so the sum result equals - ! the total amount to demote - - scale_factor = demote_area/scale_factor - - if(scale_factor <= scale_factor_min) then - - ! Trivial case, all of the demotion fractions are less than 1. - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then - currentCohort%excl_weight = currentCohort%c_area * currentCohort%excl_weight * scale_factor - - if(debug) then - if((currentCohort%excl_weight > (currentCohort%c_area+area_target_precision)) .or. & - (currentCohort%excl_weight < 0._r8) ) then - write(fates_log(),*) 'exclusion area too big (1)' - write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area - write(fates_log(),*) 'dbh: ',currentCohort%dbh - write(fates_log(),*) 'n: ',currentCohort%n - write(fates_log(),*) 'spread: ',currentSite%spread - write(fates_log(),*) 'pft: ',currentCohort%pft - write(fates_log(),*) 'currentCohort%excl_weight: ',currentCohort%excl_weight - write(fates_log(),*) 'excess: ',currentCohort%excl_weight - currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - endif - currentCohort => currentCohort%shorter - enddo - - else - - - ! Non-trivial case, at least 1 cohort's demotion - ! rate would exceed its area, given the trivial scale factor - - area_res = 0._r8 - scale_factor_res = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then - area_res = area_res + & - currentCohort%c_area * currentCohort%excl_weight * & - scale_factor_min - scale_factor_res = scale_factor_res + & - currentCohort%c_area * & - (1._r8 - (currentCohort%excl_weight * scale_factor_min)) - endif - currentCohort => currentCohort%shorter - enddo - - area_res = demote_area - area_res - - scale_factor_res = area_res / scale_factor_res - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then - - currentCohort%excl_weight = currentCohort%c_area * & - (currentCohort%excl_weight * scale_factor_min + & - (1._r8 - (currentCohort%excl_weight*scale_factor_min) ) * scale_factor_res) - - if(debug)then - if((currentCohort%excl_weight > & - (currentCohort%c_area+area_target_precision)) .or. & - (currentCohort%excl_weight < 0._r8) ) then - write(fates_log(),*) 'exclusion area error (2)' - write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area - write(fates_log(),*) 'currentCohort%excl_weight: ', & - currentCohort%excl_weight - write(fates_log(),*) 'excess: ', & - currentCohort%excl_weight - currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - endif - currentCohort => currentCohort%shorter - enddo - - end if - - end if - - - ! perform a check and see if the demotions meet the demand - sumweights = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then - sumweights = sumweights + currentCohort%excl_weight - end if - currentCohort => currentCohort%shorter - end do - - if (abs(sumweights - demote_area) > area_check_precision ) then - write(fates_log(),*) 'demotions dont add up' - write(fates_log(),*) 'sum demotions: ',sumweights - write(fates_log(),*) 'area needed to be demoted: ',demote_area - write(fates_log(),*) 'excess: ',sumweights - demote_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - ! Weights have been calculated. Now move them to the lower layer - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - - if(currentCohort%canopy_layer == i_lyr )then - - cc_loss = currentCohort%excl_weight - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) - fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) - sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) - struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) - - if ( (cc_loss-currentCohort%c_area) > -nearzero .and. & - (cc_loss-currentCohort%c_area) < area_target_precision ) then - - ! If the whole cohort is being demoted, just change its - ! layer index - - currentCohort%canopy_layer = i_lyr+1 - - ! keep track of number and biomass of demoted cohort - currentSite%demotion_rate(currentCohort%size_class) = & - currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n - currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & - (leaf_c + store_c + fnrt_c + sapw_c + struct_c) * currentCohort%n - - elseif( (cc_loss < currentCohort%c_area) .and. & - (cc_loss > area_target_precision) ) then - - ! If only part of the cohort is demoted - ! then it must be split (little more complicated) - - ! Make a copy of the current cohort. The copy and the original - ! conserve total number density of the original. The copy - ! remains in the upper-story. The original is the one - ! demoted to the understory - - - allocate(copyc) - - ! Initialize the PARTEH object and point to the - ! correct boundary condition fields - copyc%prt => null() - call InitPRTObject(copyc%prt) - call InitPRTBoundaryConditions(copyc) - - if( hlm_use_planthydro.eq.itrue ) then - call InitHydrCohort(currentSite,copyc) - endif - - call copy_cohort(currentCohort, copyc) - - newarea = currentCohort%c_area - cc_loss - copyc%n = currentCohort%n*newarea/currentCohort%c_area - currentCohort%n = currentCohort%n - copyc%n - - copyc%canopy_layer = i_lyr !the taller cohort is the copy - - ! Demote the current cohort to the understory. - currentCohort%canopy_layer = i_lyr + 1 - - ! keep track of number and biomass of demoted cohort - currentSite%demotion_rate(currentCohort%size_class) = & - currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n - currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & - (leaf_c + store_c + fnrt_c + sapw_c + struct_c) * currentCohort%n - - call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) - - !----------- Insert copy into linked list ------------------------! - copyc%shorter => currentCohort - if(associated(currentCohort%taller))then - copyc%taller => currentCohort%taller - currentCohort%taller%shorter => copyc - else - currentPatch%tallest => copyc - copyc%taller => null() - endif - currentCohort%taller => copyc - - elseif(cc_loss > currentCohort%c_area)then - - write(fates_log(),*) 'more area than the cohort has is being demoted' - write(fates_log(),*) 'loss:',cc_loss - write(fates_log(),*) 'existing area:',currentCohort%c_area - write(fates_log(),*) 'excess: ',cc_loss - currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - - end if - - ! kill the ones which go into canopy layers that are not allowed - - if(currentCohort%canopy_layer>nclmax )then - - ! put the litter from the terminated cohorts - ! straight into the fragmenting pools - call SendCohortToLitter(currentSite,currentPatch, & - currentCohort,currentCohort%n,bc_in) - - currentCohort%n = 0.0_r8 - currentCohort%c_area = 0.0_r8 - currentCohort%canopy_layer = i_lyr - - end if - - call carea_allom(currentCohort%dbh,currentCohort%n, & - currentSite%spread,currentCohort%pft,currentCohort%c_area) - - endif !canopy layer = i_ly - - currentCohort => currentCohort%shorter - enddo !currentCohort - - - ! Update the area calculations of the current layer - ! And the layer below that may or may not had recieved - ! Demotions - - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer) - - if ( (abs(arealayer - currentPatch%area)/arealayer > area_check_rel_precision ) .or. & - (abs(arealayer - currentPatch%area) > area_check_precision) ) then - write(fates_log(),*) 'demotion did not trim area within tolerance' - write(fates_log(),*) 'arealayer:',arealayer - write(fates_log(),*) 'patch%area:',currentPatch%area - write(fates_log(),*) 'ilayer: ',i_lyr - write(fates_log(),*) 'bias:',arealayer - currentPatch%area - write(fates_log(),*) 'rel bias:',(arealayer - currentPatch%area)/arealayer - write(fates_log(),*) 'demote_area:',demote_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - end if - - return - end subroutine DemoteFromLayer - - ! ============================================================================================== - - subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) - - ! ------------------------------------------------------------------------------------------- - ! Check whether the intended 'full' layers are actually filling all the space. - ! If not, promote some fraction of cohorts upwards. - ! THIS SECTION MIGHT BE TRIGGERED BY A FIRE OR MORTALITY EVENT, FOLLOWED BY A PATCH FUSION, - ! SO THE TOP LAYER IS NO LONGER FULL. - ! ------------------------------------------------------------------------------------------- - - use EDParamsMod, only : ED_val_comp_excln - - ! !ARGUMENTS - type(ed_site_type), intent(inout), target :: currentSite - type(ed_patch_type), intent(inout), target :: currentPatch - integer, intent(in) :: i_lyr ! Current canopy layer of interest - - ! !LOCAL VARIABLES: - type(ed_cohort_type), pointer :: currentCohort - type(ed_cohort_type), pointer :: copyc - type(ed_cohort_type), pointer :: nextc ! the next cohort, or used for looping - ! cohorts against the current - - real(r8) :: scale_factor ! for prob. exclusion - scales weight to a fraction - real(r8) :: scale_factor_min ! "" minimum before exeedance of 1 - real(r8) :: scale_factor_res ! "" applied to residual areas - real(r8) :: area_res ! residual area to demote after weakest cohort hits max - real(r8) :: promote_area - real(r8) :: newarea - real(r8) :: sumweights - real(r8) :: sumequal ! for tied cohorts, the sum of weights in - ! their group - real(r8) :: cc_gain ! cohort crown area gain in promotion (m2) - real(r8) :: arealayer_current ! area (m2) of the current canopy layer - real(r8) :: arealayer_below ! area (m2) of the layer below the current layer - real(r8) :: leaf_c ! leaf carbon [kg] - real(r8) :: fnrt_c ! fineroot carbon [kg] - real(r8) :: sapw_c ! sapwood carbon [kg] - real(r8) :: store_c ! storage carbon [kg] - real(r8) :: struct_c ! structure carbon [kg] - - logical :: tied_size_with_neighbors - real(r8) :: total_crownarea_of_tied_cohorts - - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr+1,arealayer_below) - - - ! how much do we need to gain? - promote_area = currentPatch%area - arealayer_current - - if( promote_area > area_target_precision ) then - - if(arealayer_below <= promote_area ) then - - ! --------------------------------------------------------------------------- - ! Promote all cohorts from layer below if that whole layer has area smaller - ! than the tolerance on the gains needed into current layer - ! --------------------------------------------------------------------------- - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - !look at the cohorts in the canopy layer below... - if(currentCohort%canopy_layer == i_lyr+1)then - - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) - fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) - sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) - struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) - - currentCohort%canopy_layer = i_lyr - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + !All the trees in this layer need to promote some area upwards... + if( (currentCohort%canopy_layer == i_lyr+1) ) then + + cc_gain = currentCohort%prom_weight + leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) + sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) + struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) + + if ( (cc_gain-currentCohort%c_area) > -nearzero .and. & + (cc_gain-currentCohort%c_area) < area_target_precision ) then + + currentCohort%canopy_layer = i_lyr + + ! keep track of number and biomass of promoted cohort + currentSite%promotion_rate(currentCohort%size_class) = & + currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n + + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & + (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n + + elseif ( (cc_gain < currentCohort%c_area) .and. & + (cc_gain > area_target_precision) ) then + + allocate(copyc) + + ! Initialize the PARTEH object and point to the + ! correct boundary condition fields + copyc%prt => null() + call InitPRTObject(copyc%prt) + call InitPRTBoundaryConditions(copyc) + + if( hlm_use_planthydro.eq.itrue ) then + call InitHydrCohort(CurrentSite,copyc) + endif + call copy_cohort(currentCohort, copyc) !makes an identical copy... + + newarea = currentCohort%c_area - cc_gain !new area of existing cohort + + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + currentCohort%pft,currentCohort%c_area) + + ! number of individuals in promoted cohort. + copyc%n = currentCohort%n*cc_gain/currentCohort%c_area + + ! number of individuals in cohort remaining in understorey + currentCohort%n = currentCohort%n - copyc%n + + currentCohort%canopy_layer = i_lyr + 1 ! keep current cohort in the understory. + copyc%canopy_layer = i_lyr ! promote copy to the higher canopy layer. + + ! keep track of number and biomass of promoted cohort + currentSite%promotion_rate(copyc%size_class) = & + currentSite%promotion_rate(copyc%size_class) + copyc%n + + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & + (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * copyc%n + + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) - ! keep track of number and biomass of promoted cohort - currentSite%promotion_rate(currentCohort%size_class) = & - currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n - currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & - (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n - - endif - currentCohort => currentCohort%shorter - enddo - - else - - ! --------------------------------------------------------------------------- - ! This is the non-trivial case where the lower layer can accomodate - ! more than what is necessary. - ! --------------------------------------------------------------------------- - - - ! figure out with what weighting we need to promote cohorts. - ! This is the opposite of the demotion weighting... - - sumweights = 0.0_r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) - if(currentCohort%canopy_layer == i_lyr+1)then !look at the cohorts in the canopy layer below... - - if (ED_val_comp_excln .ge. 0.0_r8 ) then - - ! ------------------------------------------------------------------ - ! Stochastic case, as above (in demotion portion of code) - ! ------------------------------------------------------------------ - - currentCohort%prom_weight = currentCohort%hite**ED_val_comp_excln - sumweights = sumweights + currentCohort%prom_weight - else - - ! ------------------------------------------------------------------ - ! Rank ordered deterministic method - ! If there are cohorts that have the exact same height (which is possible, really) - ! we don't want to unilaterally promote/demote one before the others. - ! So we <>mote them as a unit - ! now we need to go through and figure out how many equal-size cohorts there are. - ! then we need to go through, add up the collective crown areas of all equal-sized - ! and equal-canopy-layer cohorts, - ! and then demote from each as if they were a single group - ! ------------------------------------------------------------------ - - total_crownarea_of_tied_cohorts = currentCohort%c_area - tied_size_with_neighbors = .false. - nextc => currentCohort%shorter - do while (associated(nextc)) - if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then - if( nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - tied_size_with_neighbors = .true. - total_crownarea_of_tied_cohorts = & - total_crownarea_of_tied_cohorts + nextc%c_area - end if - else - exit - endif - nextc => nextc%shorter - end do - - if ( tied_size_with_neighbors ) then - - currentCohort%prom_weight = & - max(0.0_r8,min(currentCohort%c_area, & - (currentCohort%c_area/total_crownarea_of_tied_cohorts) * & - (promote_area - sumweights) )) - sumequal = currentCohort%prom_weight - - nextc => currentCohort%shorter - do while (associated(nextc)) - if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then - if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - ! now we know the total crown area of all equal-sized, - ! equal-canopy-layer cohorts - nextc%prom_weight = & - max(0.0_r8,min(nextc%c_area, & - (nextc%c_area/total_crownarea_of_tied_cohorts) * & - (promote_area - sumweights) )) - sumequal = sumequal + nextc%prom_weight - end if - else - exit - endif - nextc => nextc%shorter - end do - - ! Update the current cohort pointer to the last similar cohort - ! Its ok if this is not in the right layer - if(associated(nextc))then - currentCohort => nextc%taller - else - currentCohort => currentPatch%shortest - end if - sumweights = sumweights + sumequal - - else - currentCohort%prom_weight = & - max(min(currentCohort%c_area, promote_area - sumweights ), 0._r8) - sumweights = sumweights + currentCohort%prom_weight - - end if - - endif - endif - currentCohort => currentCohort%shorter - enddo !currentCohort - - - ! If this is probabalistic promotion, we need to do a round of normalization. - ! And then a few rounds where we pre-calculate the promotion areas - ! and adjust things if the promoted area wants to be greater than - ! what is available. - - if (ED_val_comp_excln .ge. 0.0_r8 ) then - - scale_factor_min = 1.e10_r8 - scale_factor = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - - if(currentCohort%canopy_layer == (i_lyr+1) ) then - - currentCohort%prom_weight = currentCohort%prom_weight/sumweights - if( 1._r8/currentCohort%prom_weight < scale_factor_min ) & - scale_factor_min = 1._r8/currentCohort%prom_weight - - scale_factor = scale_factor + currentCohort%prom_weight * currentCohort%c_area - - endif - currentCohort => currentCohort%shorter - enddo - - ! This is the factor by which we need to multiply - ! the demotion probabilities, so the sum result equals - ! the total amount to demote - scale_factor = promote_area/scale_factor - - - if(scale_factor <= scale_factor_min) then - - ! Trivial case, all of the demotion fractions - ! are less than 1. - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1) ) then - currentCohort%prom_weight = currentCohort%c_area * & - currentCohort%prom_weight * scale_factor - - if(debug)then - if((currentCohort%prom_weight > & - (currentCohort%c_area+area_target_precision)) .or. & - (currentCohort%prom_weight < 0._r8) ) then - write(fates_log(),*) 'promotion area too big (1)' - write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area - write(fates_log(),*) 'currentCohort%prom_weight: ', & - currentCohort%prom_weight - write(fates_log(),*) 'excess: ', & - currentCohort%prom_weight - currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - endif - currentCohort => currentCohort%shorter - enddo - - else - - ! Non-trivial case, at least 1 cohort's promotion - ! rate would exceed its area, given the trivial scale factor - - area_res = 0._r8 - scale_factor_res = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1) ) then - area_res = area_res + & - currentCohort%c_area*currentCohort%prom_weight*scale_factor_min - scale_factor_res = scale_factor_res + & - currentCohort%c_area * & - (1._r8 - (currentCohort%prom_weight * scale_factor_min)) - endif - currentCohort => currentCohort%shorter - enddo - - area_res = promote_area - area_res - - scale_factor_res = area_res / scale_factor_res - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1)) then - - currentCohort%prom_weight = currentCohort%c_area * & - (currentCohort%prom_weight * scale_factor_min + & - (1._r8 - (currentCohort%prom_weight*scale_factor_min) ) * & - scale_factor_res) - - if(debug)then - if((currentCohort%prom_weight > & - (currentCohort%c_area+area_target_precision)) .or. & - (currentCohort%prom_weight < 0._r8) ) then - write(fates_log(),*) 'promotion area error (2)' - write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area - write(fates_log(),*) 'currentCohort%prom_weight: ', & - currentCohort%prom_weight - write(fates_log(),*) 'excess: ', & - currentCohort%prom_weight - currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - endif - currentCohort => currentCohort%shorter - enddo - - end if - - end if - - - ! lets perform a check and see if the promotions meet the demand - sumweights = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1)) then - sumweights = sumweights + currentCohort%prom_weight - end if - currentCohort => currentCohort%shorter - end do - - if(debug)then - if (abs(sumweights - promote_area) > area_check_precision ) then - write(fates_log(),*) 'promotions dont add up' - write(fates_log(),*) 'sum promotions: ',sumweights - write(fates_log(),*) 'area needed to be promoted: ',promote_area - write(fates_log(),*) 'excess: ',sumweights - promote_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - - - !All the trees in this layer need to promote some area upwards... - if( (currentCohort%canopy_layer == i_lyr+1) ) then - - cc_gain = currentCohort%prom_weight - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) - fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) - sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) - struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) - - if ( (cc_gain-currentCohort%c_area) > -nearzero .and. & - (cc_gain-currentCohort%c_area) < area_target_precision ) then - - currentCohort%canopy_layer = i_lyr - - ! keep track of number and biomass of promoted cohort - currentSite%promotion_rate(currentCohort%size_class) = & - currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n - - currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & - (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n - - elseif ( (cc_gain < currentCohort%c_area) .and. & - (cc_gain > area_target_precision) ) then - - allocate(copyc) - - ! Initialize the PARTEH object and point to the - ! correct boundary condition fields - copyc%prt => null() - call InitPRTObject(copyc%prt) - call InitPRTBoundaryConditions(copyc) - - if( hlm_use_planthydro.eq.itrue ) then - call InitHydrCohort(CurrentSite,copyc) - endif - call copy_cohort(currentCohort, copyc) !makes an identical copy... - - newarea = currentCohort%c_area - cc_gain !new area of existing cohort - - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) - - ! number of individuals in promoted cohort. - copyc%n = currentCohort%n*cc_gain/currentCohort%c_area - - ! number of individuals in cohort remaining in understorey - currentCohort%n = currentCohort%n - copyc%n - - currentCohort%canopy_layer = i_lyr + 1 ! keep current cohort in the understory. - copyc%canopy_layer = i_lyr ! promote copy to the higher canopy layer. - - ! keep track of number and biomass of promoted cohort - currentSite%promotion_rate(copyc%size_class) = & - currentSite%promotion_rate(copyc%size_class) + copyc%n - - currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & - (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * copyc%n - - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) - call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) - - !----------- Insert copy into linked list ------------------------! - copyc%shorter => currentCohort - if(associated(currentCohort%taller))then - copyc%taller => currentCohort%taller - currentCohort%taller%shorter => copyc - else - currentPatch%tallest => copyc - copyc%taller => null() - endif - currentCohort%taller => copyc - - elseif(cc_gain > currentCohort%c_area)then - - write(fates_log(),*) 'more area than the cohort has is being promoted' - write(fates_log(),*) 'loss:',cc_gain - write(fates_log(),*) 'existing area:',currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - - endif - - endif ! if(currentCohort%canopy_layer == i_lyr+1) then - currentCohort => currentCohort%shorter - enddo !currentCohort - - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) - - if ((abs(arealayer_current - currentPatch%area)/arealayer_current > & - area_check_rel_precision ) .or. & - (abs(arealayer_current - currentPatch%area) > area_check_precision) ) then - write(fates_log(),*) 'promotion did not bring area within tolerance' - write(fates_log(),*) 'arealayer:',arealayer_current - write(fates_log(),*) 'patch%area:',currentPatch%area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - end if - - end if - - return - end subroutine PromoteIntoLayer + call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) + + !----------- Insert copy into linked list ------------------------! + copyc%shorter => currentCohort + if(associated(currentCohort%taller))then + copyc%taller => currentCohort%taller + currentCohort%taller%shorter => copyc + else + currentPatch%tallest => copyc + copyc%taller => null() + endif + currentCohort%taller => copyc + + elseif(cc_gain > currentCohort%c_area)then + + write(fates_log(),*) 'more area than the cohort has is being promoted' + write(fates_log(),*) 'loss:',cc_gain + write(fates_log(),*) 'existing area:',currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + + endif + + endif ! if(currentCohort%canopy_layer == i_lyr+1) then + currentCohort => currentCohort%shorter + enddo !currentCohort + + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) + + if ((abs(arealayer_current - currentPatch%area)/arealayer_current > & + area_check_rel_precision ) .or. & + (abs(arealayer_current - currentPatch%area) > area_check_precision) ) then + write(fates_log(),*) 'promotion did not bring area within tolerance' + write(fates_log(),*) 'arealayer:',arealayer_current + write(fates_log(),*) 'patch%area:',currentPatch%area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end if + + end if + + return + end subroutine PromoteIntoLayer ! ============================================================================ @@ -1223,9 +1223,9 @@ subroutine canopy_spread( currentSite ) currentCohort => currentPatch%tallest do while (associated(currentCohort)) call carea_allom(currentCohort%dbh,currentCohort%n, & - currentSite%spread,currentCohort%pft,currentCohort%c_area) + currentSite%spread,currentCohort%pft,currentCohort%c_area) if( ( int(prt_params%woody(currentCohort%pft)) .eq. itrue ) .and. & - (currentCohort%canopy_layer .eq. 1 ) ) then + (currentCohort%canopy_layer .eq. 1 ) ) then sitelevel_canopyarea = sitelevel_canopyarea + currentCohort%c_area endif currentCohort => currentCohort%shorter @@ -1253,9 +1253,9 @@ end subroutine canopy_spread subroutine canopy_summarization( nsites, sites, bc_in ) - ! ---------------------------------------------------------------------------------- - ! Much of this routine was once ed_clm_link minus all the IO and history stuff - ! --------------------------------------------------------------------------------- + ! ---------------------------------------------------------------------------------- + ! Much of this routine was once ed_clm_link minus all the IO and history stuff + ! --------------------------------------------------------------------------------- use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking use EDPatchDynamicsMod , only : set_patchno @@ -1284,13 +1284,13 @@ subroutine canopy_summarization( nsites, sites, bc_in ) real(r8) :: struct_c ! structure carbon [kg] !---------------------------------------------------------------------- - + if ( debug ) then write(fates_log(),*) 'in canopy_summarization' endif do s = 1,nsites - + ! -------------------------------------------------------------------------------- ! Set the patch indices (this is usefull mostly for communicating with a host or ! driving model. Loops through all patches and sets cpatch%patchno to the integer @@ -1301,16 +1301,16 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentPatch => sites(s)%oldest_patch do while(associated(currentPatch)) - + !zero cohort-summed variables. currentPatch%total_canopy_area = 0.0_r8 currentPatch%total_tree_area = 0.0_r8 canopy_leaf_area = 0.0_r8 - + !update cohort quantitie s currentCohort => currentPatch%shortest do while(associated(currentCohort)) - + ft = currentCohort%pft @@ -1319,34 +1319,34 @@ subroutine canopy_summarization( nsites, sites, bc_in ) struct_c = currentCohort%prt%GetState(struct_organ, all_carbon_elements) fnrt_c = currentCohort%prt%GetState(fnrt_organ, all_carbon_elements) store_c = currentCohort%prt%GetState(store_organ, all_carbon_elements) - + ! Update the cohort's index within the size bin classes ! Update the cohort's index within the SCPF classification system call sizetype_class_index(currentCohort%dbh,currentCohort%pft, & currentCohort%size_class,currentCohort%size_by_pft_class) if (hlm_use_cohort_age_tracking .eq. itrue) then - call coagetype_class_index(currentCohort%coage,currentCohort%pft, & - currentCohort%coage_class,currentCohort%coage_by_pft_class) - end if - + call coagetype_class_index(currentCohort%coage,currentCohort%pft, & + currentCohort%coage_class,currentCohort%coage_by_pft_class) + end if + if(hlm_use_sp.eq.ifalse)then - call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& - currentCohort%pft,currentCohort%c_area) + call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& + currentCohort%pft,currentCohort%c_area) endif currentCohort%treelai = tree_lai(leaf_c, & currentCohort%pft, currentCohort%c_area, currentCohort%n, & currentCohort%canopy_layer, currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) canopy_leaf_area = canopy_leaf_area + currentCohort%treelai *currentCohort%c_area - + if(currentCohort%canopy_layer==1)then currentPatch%total_canopy_area = currentPatch%total_canopy_area + currentCohort%c_area if( int(prt_params%woody(ft))==itrue)then currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area endif endif - + ! adding checks for SP and NOCOMP modes. if(currentPatch%nocomp_pft_label.eq.0)then write(fates_log(),*) 'cohorts in barepatch',currentPatch%total_canopy_area,currentPatch%nocomp_pft_label @@ -1370,25 +1370,25 @@ subroutine canopy_summarization( nsites, sites, bc_in ) ! Check for erroneous zero values. if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then write(fates_log(),*) 'FATES: dbh or n is zero in canopy_summarization', & - currentCohort%dbh,currentCohort%n + currentCohort%dbh,currentCohort%n call endrun(msg=errMsg(sourcefile, __LINE__)) endif if(currentCohort%pft == 0.or.currentCohort%canopy_trim <= 0._r8)then write(fates_log(),*) 'FATES: PFT or trim is zero in canopy_summarization', & - currentCohort%pft,currentCohort%canopy_trim + currentCohort%pft,currentCohort%canopy_trim call endrun(msg=errMsg(sourcefile, __LINE__)) endif if( (sapw_c + leaf_c + fnrt_c) <= 0._r8)then write(fates_log(),*) 'FATES: alive biomass is zero in canopy_summarization', & - sapw_c + leaf_c + fnrt_c + sapw_c + leaf_c + fnrt_c call endrun(msg=errMsg(sourcefile, __LINE__)) endif currentCohort => currentCohort%taller - + enddo ! ends 'do while(associated(currentCohort)) - + if ( currentPatch%total_canopy_area>currentPatch%area ) then if ( currentPatch%total_canopy_area-currentPatch%area > 0.001_r8 ) then write(fates_log(),*) 'FATES: canopy area bigger than area', & @@ -1402,14 +1402,14 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentPatch => currentPatch%younger end do !patch loop - + call leaf_area_profile(sites(s)) - + end do ! site loop - + return end subroutine canopy_summarization - + ! ==================================================================================== subroutine UpdateFatesAvgSnowDepth(sites,bc_in) @@ -1431,10 +1431,10 @@ subroutine UpdateFatesAvgSnowDepth(sites,bc_in) end subroutine UpdateFatesAvgSnowDepth - ! ===================================================================================== + ! ===================================================================================== + + subroutine leaf_area_profile( currentSite ) - subroutine leaf_area_profile( currentSite ) - ! ----------------------------------------------------------------------------------- ! This subroutine calculates how leaf and stem areas are distributed ! in vertical and horizontal space. @@ -1471,7 +1471,7 @@ subroutine leaf_area_profile( currentSite ) ! !USES: use EDtypesMod , only : area, dinc_ed, hitemax, n_hite_bins - + ! ! !ARGUMENTS type(ed_site_type) , intent(inout) :: currentSite @@ -1499,7 +1499,7 @@ subroutine leaf_area_profile( currentSite ) real(r8) :: max_chite ! top of cohort canopy (m) real(r8) :: lai ! summed lai for checking m2 m-2 real(r8) :: leaf_c ! leaf carbon [kg] - + !---------------------------------------------------------------------- @@ -1510,7 +1510,7 @@ subroutine leaf_area_profile( currentSite ) ! We assume that each point in the canopy recieved the light attenuated by the average ! leaf area index above it, irrespective of PFT identity... ! Each leaf is defined by how deep in the canopy it is, in terms of LAI units. (FIX(RF,032414), GB) - + currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) @@ -1535,153 +1535,153 @@ subroutine leaf_area_profile( currentSite ) ! It is remotely possible that in deserts we will not have any canopy ! area, ie not plants at all... ! ------------------------------------------------------------------------------ - + if (currentPatch%total_canopy_area > nearzero ) then - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) - ft = currentCohort%pft - cl = currentCohort%canopy_layer + ft = currentCohort%pft + cl = currentCohort%canopy_layer - ! Calculate LAI of layers above - ! Note that the canopy_layer_lai is also calculated in this loop - ! but since we go top down in terms of plant size, we should be okay + ! Calculate LAI of layers above + ! Note that the canopy_layer_lai is also calculated in this loop + ! but since we go top down in terms of plant size, we should be okay - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & - currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & + currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) - if (hlm_use_sp .eq. ifalse) then - currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & - currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai, currentCohort%treelai , & - currentCohort%vcmax25top,4) - end if + if (hlm_use_sp .eq. ifalse) then + currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & + currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai, currentCohort%treelai , & + currentCohort%vcmax25top,4) + end if - currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area - currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area + currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area + currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area - ! Number of actual vegetation layers in this cohort's crown - currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) + ! Number of actual vegetation layers in this cohort's crown + currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) - currentPatch%ncan(cl,ft) = max(currentPatch%ncan(cl,ft),currentCohort%NV) + currentPatch%ncan(cl,ft) = max(currentPatch%ncan(cl,ft),currentCohort%NV) - patch_lai = patch_lai + currentCohort%lai + patch_lai = patch_lai + currentCohort%lai - currentPatch%canopy_layer_tlai(cl) = currentPatch%canopy_layer_tlai(cl) + currentCohort%lai + currentPatch%canopy_layer_tlai(cl) = currentPatch%canopy_layer_tlai(cl) + currentCohort%lai - currentCohort => currentCohort%shorter - - enddo !currentCohort + currentCohort => currentCohort%shorter - if(smooth_leaf_distribution == 1)then + enddo !currentCohort - ! ----------------------------------------------------------------------------- - ! we are going to ignore the concept of canopy layers, and put all of the leaf - ! area into height banded bins. using the same domains as we had before, except - ! that CL always = 1 - ! ----------------------------------------------------------------------------- - - ! this is a crude way of dividing up the bins. Should it be a function of actual maximum height? - dh = 1.0_r8*(HITEMAX/N_HITE_BINS) - do iv = 1,N_HITE_BINS - if (iv == 1) then - minh(iv) = 0.0_r8 - maxh(iv) = dh - else - minh(iv) = (iv-1)*dh - maxh(iv) = (iv)*dh - endif - enddo - - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - ft = currentCohort%pft - min_chite = currentCohort%hite - currentCohort%hite * EDPftvarcon_inst%crown(ft) - max_chite = currentCohort%hite + if(smooth_leaf_distribution == 1)then + + ! ----------------------------------------------------------------------------- + ! we are going to ignore the concept of canopy layers, and put all of the leaf + ! area into height banded bins. using the same domains as we had before, except + ! that CL always = 1 + ! ----------------------------------------------------------------------------- + + ! this is a crude way of dividing up the bins. Should it be a function of actual maximum height? + dh = 1.0_r8*(HITEMAX/N_HITE_BINS) do iv = 1,N_HITE_BINS - frac_canopy(iv) = 0.0_r8 - ! this layer is in the middle of the canopy - if(max_chite > maxh(iv).and.min_chite < minh(iv))then - frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*EDPftvarcon_inst%crown(ft))) - ! this is the layer with the bottom of the canopy in it. - elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then - frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) - ! this is the layer with the top of the canopy in it. - elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then - frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) - elseif(max_chite < maxh(iv).and.min_chite > minh(iv))then !the whole cohort is within this layer. - frac_canopy(iv) = 1.0_r8 + if (iv == 1) then + minh(iv) = 0.0_r8 + maxh(iv) = dh + else + minh(iv) = (iv-1)*dh + maxh(iv) = (iv)*dh endif - - ! no m2 of leaf per m2 of ground in each height class - currentPatch%tlai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) + frac_canopy(iv) * & - currentCohort%lai - currentPatch%tsai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) + frac_canopy(iv) * & - currentCohort%sai - - !snow burial + enddo + + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + ft = currentCohort%pft + min_chite = currentCohort%hite - currentCohort%hite * EDPftvarcon_inst%crown(ft) + max_chite = currentCohort%hite + do iv = 1,N_HITE_BINS + frac_canopy(iv) = 0.0_r8 + ! this layer is in the middle of the canopy + if(max_chite > maxh(iv).and.min_chite < minh(iv))then + frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*EDPftvarcon_inst%crown(ft))) + ! this is the layer with the bottom of the canopy in it. + elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then + frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) + ! this is the layer with the top of the canopy in it. + elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then + frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) + elseif(max_chite < maxh(iv).and.min_chite > minh(iv))then !the whole cohort is within this layer. + frac_canopy(iv) = 1.0_r8 + endif + + ! no m2 of leaf per m2 of ground in each height class + currentPatch%tlai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) + frac_canopy(iv) * & + currentCohort%lai + currentPatch%tsai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) + frac_canopy(iv) * & + currentCohort%sai + + !snow burial if(currentSite%snow_depth > maxh(iv))then - fraction_exposed = 0._r8 - endif + fraction_exposed = 0._r8 + endif if(currentSite%snow_depth < minh(iv))then - fraction_exposed = 1._r8 - endif + fraction_exposed = 1._r8 + endif if(currentSite%snow_depth >= minh(iv) .and. currentSite%snow_depth <= maxh(iv)) then !only partly hidden... - fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(currentSite%snow_depth-minh(iv))/dh))) - endif - - currentPatch%elai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) * fraction_exposed - currentPatch%esai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) * fraction_exposed - - enddo ! (iv) hite bins - - currentCohort => currentCohort%taller - - enddo !currentCohort - - ! ----------------------------------------------------------------------------- - ! Perform a leaf area conservation check on the LAI profile - lai = 0.0_r8 - do ft = 1,numpft - lai = lai+ sum(currentPatch%tlai_profile(1,ft,:)) - enddo - - if(lai > patch_lai)then - write(fates_log(), *) 'FATES: problem with lai assignments' - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - - - else ! smooth leaf distribution + fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(currentSite%snow_depth-minh(iv))/dh))) + endif + + currentPatch%elai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) * fraction_exposed + currentPatch%esai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) * fraction_exposed + + enddo ! (iv) hite bins + + currentCohort => currentCohort%taller + + enddo !currentCohort + + ! ----------------------------------------------------------------------------- + ! Perform a leaf area conservation check on the LAI profile + lai = 0.0_r8 + do ft = 1,numpft + lai = lai+ sum(currentPatch%tlai_profile(1,ft,:)) + enddo + + if(lai > patch_lai)then + write(fates_log(), *) 'FATES: problem with lai assignments' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + + else ! smooth leaf distribution + + ! ----------------------------------------------------------------------------- + ! Standard canopy layering model. + ! Go through all cohorts and add their leaf area + ! and canopy area to the accumulators. + ! ----------------------------------------------------------------------------- - ! ----------------------------------------------------------------------------- - ! Standard canopy layering model. - ! Go through all cohorts and add their leaf area - ! and canopy area to the accumulators. - ! ----------------------------------------------------------------------------- - currentCohort => currentPatch%shortest do while(associated(currentCohort)) ft = currentCohort%pft cl = currentCohort%canopy_layer - + ! ---------------------------------------------------------------- ! How much of each tree is stem area index? Assuming that there is ! This may indeed be zero if there is a sensecent grass ! ---------------------------------------------------------------- - + if( (currentCohort%treelai+currentCohort%treesai) > 0._r8)then fleaf = currentCohort%lai / (currentCohort%lai + currentCohort%sai) else fleaf = 0._r8 endif - + currentPatch%nrad(cl,ft) = currentPatch%ncan(cl,ft) if (currentPatch%nrad(cl,ft) > nlevleaf ) then @@ -1699,22 +1699,22 @@ subroutine leaf_area_profile( currentSite ) ! Whole layers. Make a weighted average of the leaf area in each layer ! before dividing it by the total area. Fill up layer for whole layers. ! -------------------------------------------------------------------------- - + do iv = 1,currentCohort%NV - + ! This loop builds the arrays that define the effective (not snow covered) ! and total (includes snow covered) area indices for leaves and stems ! We calculate the absolute elevation of each layer to help determine if the layer ! is obscured by snow. - + layer_top_hite = currentCohort%hite - & - ( real(iv-1,r8)/currentCohort%NV * currentCohort%hite * & - EDPftvarcon_inst%crown(currentCohort%pft) ) - + ( real(iv-1,r8)/currentCohort%NV * currentCohort%hite * & + EDPftvarcon_inst%crown(currentCohort%pft) ) + layer_bottom_hite = currentCohort%hite - & - ( real(iv,r8)/currentCohort%NV * currentCohort%hite * & - EDPftvarcon_inst%crown(currentCohort%pft) ) - + ( real(iv,r8)/currentCohort%NV * currentCohort%hite * & + EDPftvarcon_inst%crown(currentCohort%pft) ) + fraction_exposed = 1.0_r8 if(currentSite%snow_depth > layer_top_hite)then fraction_exposed = 0._r8 @@ -1725,55 +1725,55 @@ subroutine leaf_area_profile( currentSite ) if(currentSite%snow_depth >= layer_bottom_hite .and. & currentSite%snow_depth <= layer_top_hite) then !only partly hidden... fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(currentSite%snow_depth -layer_bottom_hite)/ & - (layer_top_hite-layer_bottom_hite )))) + (layer_top_hite-layer_bottom_hite )))) endif - + if(iv==currentCohort%NV) then remainder = (currentCohort%treelai + currentCohort%treesai) - & - (dinc_ed*real(currentCohort%nv-1,r8)) + (dinc_ed*real(currentCohort%nv-1,r8)) if(remainder > dinc_ed )then write(fates_log(), *)'ED: issue with remainder', & - currentCohort%treelai,currentCohort%treesai,dinc_ed, & - currentCohort%NV,remainder + currentCohort%treelai,currentCohort%treesai,dinc_ed, & + currentCohort%NV,remainder call endrun(msg=errMsg(sourcefile, __LINE__)) endif else remainder = dinc_ed end if - + currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) + & - remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area - + remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%elai_profile(cl,ft,iv) = currentPatch%elai_profile(cl,ft,iv) + & - remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & - fraction_exposed - + remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & + fraction_exposed + currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) + & - remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area - + remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%esai_profile(cl,ft,iv) = currentPatch%esai_profile(cl,ft,iv) + & - remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area * & - fraction_exposed - + remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area * & + fraction_exposed + currentPatch%canopy_area_profile(cl,ft,iv) = currentPatch%canopy_area_profile(cl,ft,iv) + & - currentCohort%c_area/currentPatch%total_canopy_area - + currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%layer_height_profile(cl,ft,iv) = currentPatch%layer_height_profile(cl,ft,iv) + & - (remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & - (layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. - + (remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & + (layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. + end do - + currentCohort => currentCohort%taller - + enddo !cohort - + ! -------------------------------------------------------------------------- - + ! If there is an upper-story, the top canopy layer ! should have a value of exactly 1.0 in its top leaf layer ! -------------------------------------------------------------------------- - + if ( (currentPatch%NCL_p > 1) .and. & (sum(currentPatch%canopy_area_profile(1,:,1)) < 0.9999 )) then write(fates_log(), *) 'FATES: canopy_area_profile was less than 1 at the canopy top' @@ -1792,9 +1792,9 @@ subroutine leaf_area_profile( currentSite ) currentCohort => currentCohort%taller enddo !currentCohort call endrun(msg=errMsg(sourcefile, __LINE__)) - + end if - + ! -------------------------------------------------------------------------- ! In the following loop we are now normalizing the effective and @@ -1809,57 +1809,57 @@ subroutine leaf_area_profile( currentSite ) do cl = 1,currentPatch%NCL_p do iv = 1,currentPatch%ncan(cl,ft) - + if( debug .and. sum(currentPatch%canopy_area_profile(cl,:,iv)) > 1.0001_r8 ) then - + write(fates_log(), *) 'FATES: A canopy_area_profile exceeded 1.0' write(fates_log(), *) 'cl: ',cl write(fates_log(), *) 'iv: ',iv write(fates_log(), *) 'sum(cpatch%canopy_area_profile(cl,:,iv)): ', & - sum(currentPatch%canopy_area_profile(cl,:,iv)) - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - if(currentCohort%canopy_layer==cl)then - write(fates_log(), *) 'FATES: cohorts in layer cl = ',cl, & - currentCohort%dbh,currentCohort%c_area, & - currentPatch%total_canopy_area,currentPatch%area - write(fates_log(), *) 'ED: fracarea', currentCohort%pft, & - currentCohort%c_area/currentPatch%total_canopy_area - endif - currentCohort => currentCohort%taller - enddo !currentCohort - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end do - + sum(currentPatch%canopy_area_profile(cl,:,iv)) + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + if(currentCohort%canopy_layer==cl)then + write(fates_log(), *) 'FATES: cohorts in layer cl = ',cl, & + currentCohort%dbh,currentCohort%c_area, & + currentPatch%total_canopy_area,currentPatch%area + write(fates_log(), *) 'ED: fracarea', currentCohort%pft, & + currentCohort%c_area/currentPatch%total_canopy_area + endif + currentCohort => currentCohort%taller + enddo !currentCohort + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do + do ft = 1,numpft do iv = 1,currentPatch%ncan(cl,ft) if( currentPatch%canopy_area_profile(cl,ft,iv) > nearzero ) then - + currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) / & - currentPatch%canopy_area_profile(cl,ft,iv) - + currentPatch%canopy_area_profile(cl,ft,iv) + currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) / & - currentPatch%canopy_area_profile(cl,ft,iv) - + currentPatch%canopy_area_profile(cl,ft,iv) + currentPatch%elai_profile(cl,ft,iv) = currentPatch%elai_profile(cl,ft,iv) / & - currentPatch%canopy_area_profile(cl,ft,iv) - + currentPatch%canopy_area_profile(cl,ft,iv) + currentPatch%esai_profile(cl,ft,iv) = currentPatch%esai_profile(cl,ft,iv) / & - currentPatch%canopy_area_profile(cl,ft,iv) + currentPatch%canopy_area_profile(cl,ft,iv) end if - + if(currentPatch%tlai_profile(cl,ft,iv)>nearzero )then currentPatch%layer_height_profile(cl,ft,iv) = currentPatch%layer_height_profile(cl,ft,iv) & - /currentPatch%tlai_profile(cl,ft,iv) + /currentPatch%tlai_profile(cl,ft,iv) end if - + enddo - + enddo enddo - + ! -------------------------------------------------------------------------- ! Set the mask that identifies which PFT x can-layer combinations have ! scattering elements in them. @@ -1874,247 +1874,247 @@ subroutine leaf_area_profile( currentSite ) end do !iv enddo !ft enddo ! loop over cl - + endif !leaf distribution - + end if - + currentPatch => currentPatch%younger - + enddo !patch - + return - end subroutine leaf_area_profile + end subroutine leaf_area_profile - ! ====================================================================================== + ! ====================================================================================== subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) - ! ---------------------------------------------------------------------------------- - ! The purpose of this routine is to package output boundary conditions related - ! to vegetation coverage to the host land model. - ! ---------------------------------------------------------------------------------- - - use EDTypesMod , only : ed_patch_type, ed_cohort_type, & - ed_site_type, AREA - use FatesInterfaceTypesMod , only : bc_out_type - - ! - ! !ARGUMENTS - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) - integer, intent(in) :: fcolumn(nsites) - type(bc_out_type), intent(inout) :: bc_out(nsites) - - ! Locals - type (ed_cohort_type) , pointer :: currentCohort - integer :: s, ifp, c, p - type (ed_patch_type) , pointer :: currentPatch - real(r8) :: bare_frac_area - real(r8) :: total_patch_area - real(r8) :: total_canopy_area - real(r8) :: total_patch_leaf_stem_area - real(r8) :: weight ! Weighting for cohort variables in patch - - do s = 1,nsites - - ifp = 0 - total_patch_area = 0._r8 - total_canopy_area = 0._r8 - bc_out(s)%canopy_fraction_pa(:) = 0._r8 - bc_out(s)%dleaf_pa(:) = 0._r8 - bc_out(s)%z0m_pa(:) = 0._r8 - bc_out(s)%displa_pa(:) = 0._r8 - currentPatch => sites(s)%oldest_patch - c = fcolumn(s) - do while(associated(currentPatch)) + ! ---------------------------------------------------------------------------------- + ! The purpose of this routine is to package output boundary conditions related + ! to vegetation coverage to the host land model. + ! ---------------------------------------------------------------------------------- + + use EDTypesMod , only : ed_patch_type, ed_cohort_type, & + ed_site_type, AREA + use FatesInterfaceTypesMod , only : bc_out_type + + ! + ! !ARGUMENTS + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + integer, intent(in) :: fcolumn(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + ! Locals + type (ed_cohort_type) , pointer :: currentCohort + integer :: s, ifp, c, p + type (ed_patch_type) , pointer :: currentPatch + real(r8) :: bare_frac_area + real(r8) :: total_patch_area + real(r8) :: total_canopy_area + real(r8) :: total_patch_leaf_stem_area + real(r8) :: weight ! Weighting for cohort variables in patch + + do s = 1,nsites + + ifp = 0 + total_patch_area = 0._r8 + total_canopy_area = 0._r8 + bc_out(s)%canopy_fraction_pa(:) = 0._r8 + bc_out(s)%dleaf_pa(:) = 0._r8 + bc_out(s)%z0m_pa(:) = 0._r8 + bc_out(s)%displa_pa(:) = 0._r8 + currentPatch => sites(s)%oldest_patch + c = fcolumn(s) + do while(associated(currentPatch)) if(currentPatch%nocomp_pft_label.ne.0)then ! ignore the bare-ground-PFT patch entirely for these BC outs - ifp = ifp+1 - - if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then - write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area - currentPatch%total_canopy_area = currentPatch%area - endif - - if (associated(currentPatch%tallest)) then - bc_out(s)%htop_pa(ifp) = currentPatch%tallest%hite - else - ! FIX(RF,040113) - should this be a parameter for the minimum possible vegetation height? - bc_out(s)%htop_pa(ifp) = 0.1_r8 - endif - - bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) - - ! Use canopy-only crown area weighting for all cohorts in the patch to define the characteristic - ! Roughness length and displacement height used by the HLM - ! use total LAI + SAI to weight the leaft characteristic dimension - ! ---------------------------------------------------------------------------- - - if (currentPatch%total_canopy_area > nearzero) then - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - if (currentCohort%canopy_layer .eq. 1) then - weight = min(1.0_r8,currentCohort%c_area/currentPatch%total_canopy_area) - bc_out(s)%z0m_pa(ifp) = bc_out(s)%z0m_pa(ifp) + & - EDPftvarcon_inst%z0mr(currentCohort%pft) * currentCohort%hite * weight - bc_out(s)%displa_pa(ifp) = bc_out(s)%displa_pa(ifp) + & - EDPftvarcon_inst%displar(currentCohort%pft) * currentCohort%hite * weight - endif - currentCohort => currentCohort%taller - end do - - ! for lai, scale to total LAI + SAI in patch. first add up all the LAI and SAI in the patch - total_patch_leaf_stem_area = 0._r8 - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - - ! mkae sure that allometries are correct - call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& - currentCohort%pft,currentCohort%c_area) - - currentCohort%treelai = tree_lai(currentCohort%prt%GetState(leaf_organ, all_carbon_elements), & - currentCohort%pft, currentCohort%c_area, currentCohort%n, & - currentCohort%canopy_layer, currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) - - currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & - currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai, currentCohort%treelai , & - currentCohort%vcmax25top,4) - - total_patch_leaf_stem_area = total_patch_leaf_stem_area + & - (currentCohort%treelai + currentCohort%treesai) * currentCohort%c_area - currentCohort => currentCohort%taller - end do - - ! make sure there is some leaf and stem area - if (total_patch_leaf_stem_area > nearzero) then - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - ! weight dleaf by the relative totals of leaf and stem area - weight = (currentCohort%treelai + currentCohort%treesai) * currentCohort%c_area / total_patch_leaf_stem_area - bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & - EDPftvarcon_inst%dleaf(currentCohort%pft) * weight - currentCohort => currentCohort%taller - end do - else - ! dummy case - bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) - endif - else - ! if no canopy, then use dummy values (first PFT) of aerodynamic properties - bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(1) * bc_out(s)%htop_pa(ifp) - bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) - bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) - endif - ! ----------------------------------------------------------------------------- - - ! We are assuming here that grass is all located underneath tree canopies. - ! The alternative is to assume it is all spatial distinct from tree canopies. - ! In which case, the bare area would have to be reduced by the grass area... - ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants - ! currentPatch%area/AREA is the fraction of the soil covered by this patch. - + ifp = ifp+1 + + if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then + write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area + currentPatch%total_canopy_area = currentPatch%area + endif + + if (associated(currentPatch%tallest)) then + bc_out(s)%htop_pa(ifp) = currentPatch%tallest%hite + else + ! FIX(RF,040113) - should this be a parameter for the minimum possible vegetation height? + bc_out(s)%htop_pa(ifp) = 0.1_r8 + endif + + bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) + + ! Use canopy-only crown area weighting for all cohorts in the patch to define the characteristic + ! Roughness length and displacement height used by the HLM + ! use total LAI + SAI to weight the leaft characteristic dimension + ! ---------------------------------------------------------------------------- + + if (currentPatch%total_canopy_area > nearzero) then + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + if (currentCohort%canopy_layer .eq. 1) then + weight = min(1.0_r8,currentCohort%c_area/currentPatch%total_canopy_area) + bc_out(s)%z0m_pa(ifp) = bc_out(s)%z0m_pa(ifp) + & + EDPftvarcon_inst%z0mr(currentCohort%pft) * currentCohort%hite * weight + bc_out(s)%displa_pa(ifp) = bc_out(s)%displa_pa(ifp) + & + EDPftvarcon_inst%displar(currentCohort%pft) * currentCohort%hite * weight + endif + currentCohort => currentCohort%taller + end do + + ! for lai, scale to total LAI + SAI in patch. first add up all the LAI and SAI in the patch + total_patch_leaf_stem_area = 0._r8 + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + + ! mkae sure that allometries are correct + call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& + currentCohort%pft,currentCohort%c_area) + + currentCohort%treelai = tree_lai(currentCohort%prt%GetState(leaf_organ, all_carbon_elements), & + currentCohort%pft, currentCohort%c_area, currentCohort%n, & + currentCohort%canopy_layer, currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + + currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & + currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai, currentCohort%treelai , & + currentCohort%vcmax25top,4) + + total_patch_leaf_stem_area = total_patch_leaf_stem_area + & + (currentCohort%treelai + currentCohort%treesai) * currentCohort%c_area + currentCohort => currentCohort%taller + end do + + ! make sure there is some leaf and stem area + if (total_patch_leaf_stem_area > nearzero) then + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + ! weight dleaf by the relative totals of leaf and stem area + weight = (currentCohort%treelai + currentCohort%treesai) * currentCohort%c_area / total_patch_leaf_stem_area + bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & + EDPftvarcon_inst%dleaf(currentCohort%pft) * weight + currentCohort => currentCohort%taller + end do + else + ! dummy case + bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) + endif + else + ! if no canopy, then use dummy values (first PFT) of aerodynamic properties + bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) + endif + ! ----------------------------------------------------------------------------- + + ! We are assuming here that grass is all located underneath tree canopies. + ! The alternative is to assume it is all spatial distinct from tree canopies. + ! In which case, the bare area would have to be reduced by the grass area... + ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants + ! currentPatch%area/AREA is the fraction of the soil covered by this patch. + if(currentPatch%area.gt.0.0_r8)then - bc_out(s)%canopy_fraction_pa(ifp) = & - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) + bc_out(s)%canopy_fraction_pa(ifp) = & + min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) else bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 endif - bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & - (currentPatch%area/AREA) - - total_patch_area = total_patch_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area - - total_canopy_area = total_canopy_area + bc_out(s)%canopy_fraction_pa(ifp) - + bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & + (currentPatch%area/AREA) + + total_patch_area = total_patch_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area + + total_canopy_area = total_canopy_area + bc_out(s)%canopy_fraction_pa(ifp) + bc_out(s)%nocomp_pft_label_pa(ifp) = currentPatch%nocomp_pft_label - ! Calculate area indices for output boundary to HLM - ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles - ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) - - bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') - bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') - bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') - bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') - - ! Fraction of vegetation free of snow. This is used to flag those - ! patches which shall under-go photosynthesis - ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let - ! FATES internal variables decide if photosynthesis is possible - ! we are essentially calculating it inside FATES to tell the - ! host to tell itself when to do things (circuitous). Just have - ! to determine where else it is used - - if ((bc_out(s)%elai_pa(ifp) + bc_out(s)%esai_pa(ifp)) > 0._r8) then - bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 1.0_r8 - else - bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 0.0_r8 - end if - + ! Calculate area indices for output boundary to HLM + ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles + ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) + + bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') + bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') + bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') + bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') + + ! Fraction of vegetation free of snow. This is used to flag those + ! patches which shall under-go photosynthesis + ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let + ! FATES internal variables decide if photosynthesis is possible + ! we are essentially calculating it inside FATES to tell the + ! host to tell itself when to do things (circuitous). Just have + ! to determine where else it is used + + if ((bc_out(s)%elai_pa(ifp) + bc_out(s)%esai_pa(ifp)) > 0._r8) then + bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 1.0_r8 + else + bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 0.0_r8 + end if + else ! nocomp or SP, and currentPatch%nocomp_pft_label .eq. 0 - + total_patch_area = total_patch_area + currentPatch%area/AREA - + + end if + currentPatch => currentPatch%younger + end do + + ! Apply patch and canopy area corrections + ! If the difference is above reasonable math precision, apply a fix + ! If the difference is way above reasonable math precision, gracefully exit + + if(abs(total_patch_area-1.0_r8) > rsnbl_math_prec ) then + + if(abs(total_patch_area-1.0_r8) > 1.0e-8_r8 )then + write(fates_log(),*) 'total area is wrong in update_hlm_dynamics',total_patch_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(debug) then + write(fates_log(),*) 'imprecise patch areas in update_hlm_dynamics',total_patch_area end if - currentPatch => currentPatch%younger - end do - - ! Apply patch and canopy area corrections - ! If the difference is above reasonable math precision, apply a fix - ! If the difference is way above reasonable math precision, gracefully exit - - if(abs(total_patch_area-1.0_r8) > rsnbl_math_prec ) then - - if(abs(total_patch_area-1.0_r8) > 1.0e-8_r8 )then - write(fates_log(),*) 'total area is wrong in update_hlm_dynamics',total_patch_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if(debug) then - write(fates_log(),*) 'imprecise patch areas in update_hlm_dynamics',total_patch_area - end if - - currentPatch => sites(s)%oldest_patch - ifp = 0 - do while(associated(currentPatch)) + + currentPatch => sites(s)%oldest_patch + ifp = 0 + do while(associated(currentPatch)) if(currentPatch%nocomp_pft_label.ne.0)then ! for vegetated patches only - ifp = ifp+1 - bc_out(s)%canopy_fraction_pa(ifp) = bc_out(s)%canopy_fraction_pa(ifp)/total_patch_area + ifp = ifp+1 + bc_out(s)%canopy_fraction_pa(ifp) = bc_out(s)%canopy_fraction_pa(ifp)/total_patch_area endif ! veg patch - currentPatch => currentPatch%younger - end do - - endif - - ! If running hydro, perform a final check to make sure that we - ! have conserved water. Since this is the very end of the dynamics - ! cycle. No water should had been added or lost to the site during dynamics. - ! With growth and death, we may have shuffled it around. - ! For recruitment, we initialized their water, but flagged them - ! to not be included in the site level balance yet, for they - ! will demand the water for their initialization on the first hydraulics time-step - - if (hlm_use_planthydro.eq.itrue) then - call UpdateH2OVeg(sites(s),bc_out(s),bc_out(s)%plant_stored_h2o_si,1) - end if - - end do - - ! This call to RecruitWaterStorage() makes an accounting of - ! how much water is used to intialize newly recruited plants. - ! However, it does not actually move water from the soil or create - ! a flux, it is just accounting for diagnostics purposes. The water - ! will not actually be moved until the beginning of the first hydraulics - ! call during the fast timestep sequence - - if (hlm_use_planthydro.eq.itrue) then - call RecruitWaterStorage(nsites,sites,bc_out) - end if + currentPatch => currentPatch%younger + end do + + endif + + ! If running hydro, perform a final check to make sure that we + ! have conserved water. Since this is the very end of the dynamics + ! cycle. No water should had been added or lost to the site during dynamics. + ! With growth and death, we may have shuffled it around. + ! For recruitment, we initialized their water, but flagged them + ! to not be included in the site level balance yet, for they + ! will demand the water for their initialization on the first hydraulics time-step + + if (hlm_use_planthydro.eq.itrue) then + call UpdateH2OVeg(sites(s),bc_out(s),bc_out(s)%plant_stored_h2o_si,1) + end if + + end do + + ! This call to RecruitWaterStorage() makes an accounting of + ! how much water is used to intialize newly recruited plants. + ! However, it does not actually move water from the soil or create + ! a flux, it is just accounting for diagnostics purposes. The water + ! will not actually be moved until the beginning of the first hydraulics + ! call during the fast timestep sequence + + if (hlm_use_planthydro.eq.itrue) then + call RecruitWaterStorage(nsites,sites,bc_out) + end if end subroutine update_hlm_dynamics @@ -2123,152 +2123,152 @@ end subroutine update_hlm_dynamics function calc_areaindex(cpatch,ai_type) result(ai) - ! ---------------------------------------------------------------------------------- - ! This subroutine calculates the exposed leaf area index of a patch - ! this is the square meters of leaf per square meter of ground area - ! It does so by integrating over the depth and functional type profile of leaf area - ! which are per area of crown. This value has to be scaled by crown area to convert - ! to ground area. - ! ---------------------------------------------------------------------------------- - - ! Arguments - type(ed_patch_type),intent(in), target :: cpatch - character(len=*),intent(in) :: ai_type - - integer :: cl,ft - real(r8) :: ai - ! TODO: THIS MIN LAI IS AN ARTIFACT FROM TESTING LONG-AGO AND SHOULD BE REMOVED - ! THIS HAS BEEN KEPT THUS FAR TO MAINTAIN B4B IN TESTING OTHER COMMITS - real(r8),parameter :: ai_min = 0.1_r8 - - real(r8),pointer :: ai_profile - - ai = 0._r8 - if (trim(ai_type) == 'elai') then - do cl = 1,cpatch%NCL_p - do ft = 1,numpft - ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & - cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft))) - enddo - enddo - elseif (trim(ai_type) == 'tlai') then - do cl = 1,cpatch%NCL_p - do ft = 1,numpft - ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & - cpatch%tlai_profile(cl,ft,1:cpatch%nrad(cl,ft))) - enddo - enddo - - elseif (trim(ai_type) == 'esai') then - do cl = 1,cpatch%NCL_p - do ft = 1,numpft - ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & - cpatch%esai_profile(cl,ft,1:cpatch%nrad(cl,ft))) - enddo - enddo - elseif (trim(ai_type) == 'tsai') then - do cl = 1,cpatch%NCL_p - do ft = 1,numpft - ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & - cpatch%tsai_profile(cl,ft,1:cpatch%nrad(cl,ft))) - enddo - enddo - else - - write(fates_log(),*) 'Unsupported area index sent to calc_areaindex' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ai = max(ai_min,ai) - - return + ! ---------------------------------------------------------------------------------- + ! This subroutine calculates the exposed leaf area index of a patch + ! this is the square meters of leaf per square meter of ground area + ! It does so by integrating over the depth and functional type profile of leaf area + ! which are per area of crown. This value has to be scaled by crown area to convert + ! to ground area. + ! ---------------------------------------------------------------------------------- + + ! Arguments + type(ed_patch_type),intent(in), target :: cpatch + character(len=*),intent(in) :: ai_type + + integer :: cl,ft + real(r8) :: ai + ! TODO: THIS MIN LAI IS AN ARTIFACT FROM TESTING LONG-AGO AND SHOULD BE REMOVED + ! THIS HAS BEEN KEPT THUS FAR TO MAINTAIN B4B IN TESTING OTHER COMMITS + real(r8),parameter :: ai_min = 0.1_r8 + + real(r8),pointer :: ai_profile + + ai = 0._r8 + if (trim(ai_type) == 'elai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + elseif (trim(ai_type) == 'tlai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%tlai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + + elseif (trim(ai_type) == 'esai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%esai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + elseif (trim(ai_type) == 'tsai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%tsai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + else + + write(fates_log(),*) 'Unsupported area index sent to calc_areaindex' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ai = max(ai_min,ai) + + return end function calc_areaindex ! =============================================================================================== - + subroutine CanopyLayerArea(currentPatch,site_spread,layer_index,layer_area) - - ! -------------------------------------------------------------------------------------------- - ! This function calculates the total crown area footprint for a desired layer of the canopy - ! within a patch. - ! The return units are the same as patch%area, which is m2 - ! --------------------------------------------------------------------------------------------- - - ! Arguments - type(ed_patch_type),intent(inout), target :: currentPatch - real(r8),intent(in) :: site_spread - integer,intent(in) :: layer_index - real(r8),intent(inout) :: layer_area - - type(ed_cohort_type), pointer :: currentCohort - - - layer_area = 0.0_r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - call carea_allom(currentCohort%dbh,currentCohort%n,site_spread, & - currentCohort%pft,currentCohort%c_area) - if (currentCohort%canopy_layer .eq. layer_index) then - layer_area = layer_area + currentCohort%c_area - end if - currentCohort => currentCohort%shorter - enddo - return + + ! -------------------------------------------------------------------------------------------- + ! This function calculates the total crown area footprint for a desired layer of the canopy + ! within a patch. + ! The return units are the same as patch%area, which is m2 + ! --------------------------------------------------------------------------------------------- + + ! Arguments + type(ed_patch_type),intent(inout), target :: currentPatch + real(r8),intent(in) :: site_spread + integer,intent(in) :: layer_index + real(r8),intent(inout) :: layer_area + + type(ed_cohort_type), pointer :: currentCohort + + + layer_area = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + call carea_allom(currentCohort%dbh,currentCohort%n,site_spread, & + currentCohort%pft,currentCohort%c_area) + if (currentCohort%canopy_layer .eq. layer_index) then + layer_area = layer_area + currentCohort%c_area + end if + currentCohort => currentCohort%shorter + enddo + return end subroutine CanopyLayerArea ! =============================================================================================== - + function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) result(z) - ! -------------------------------------------------------------------------------------------- - ! Calculate the number of canopy layers in this patch. - ! This simple call only determines total layering by querying the cohorts - ! which layer they are in, it doesn't do any size evaluation. - ! It may also, optionally, account for the temporary "substory", which is the imaginary - ! layer below the understory which will be needed to temporarily accomodate demotions from - ! the understory in the event the understory has reached maximum allowable area. - ! -------------------------------------------------------------------------------------------- - - type(ed_patch_type),target :: currentPatch - real(r8),intent(in) :: site_spread - logical :: include_substory - - type(ed_cohort_type),pointer :: currentCohort - - integer :: z - real(r8) :: c_area - real(r8) :: arealayer - - z = 1 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - z = max(z,currentCohort%canopy_layer) - currentCohort => currentCohort%shorter - enddo - - if(include_substory)then - arealayer = 0.0 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == z) then - call carea_allom(currentCohort%dbh,currentCohort%n,site_spread,currentCohort%pft,c_area) - arealayer = arealayer + c_area - end if - currentCohort => currentCohort%shorter - enddo - - ! Does the bottom layer have more than a full canopy? - ! If so we need to make another layer. - if(arealayer > currentPatch%area)then - z = z + 1 + ! -------------------------------------------------------------------------------------------- + ! Calculate the number of canopy layers in this patch. + ! This simple call only determines total layering by querying the cohorts + ! which layer they are in, it doesn't do any size evaluation. + ! It may also, optionally, account for the temporary "substory", which is the imaginary + ! layer below the understory which will be needed to temporarily accomodate demotions from + ! the understory in the event the understory has reached maximum allowable area. + ! -------------------------------------------------------------------------------------------- + + type(ed_patch_type),target :: currentPatch + real(r8),intent(in) :: site_spread + logical :: include_substory + + type(ed_cohort_type),pointer :: currentCohort + + integer :: z + real(r8) :: c_area + real(r8) :: arealayer + + z = 1 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + z = max(z,currentCohort%canopy_layer) + currentCohort => currentCohort%shorter + enddo + + if(include_substory)then + arealayer = 0.0 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == z) then + call carea_allom(currentCohort%dbh,currentCohort%n,site_spread,currentCohort%pft,c_area) + arealayer = arealayer + c_area + end if + currentCohort => currentCohort%shorter + enddo + + ! Does the bottom layer have more than a full canopy? + ! If so we need to make another layer. + if(arealayer > currentPatch%area)then + z = z + 1 if(hlm_use_sp.eq.itrue)then write(fates_log(),*) 'SPmode, canopy_layer full:',arealayer,currentPatch%area end if - endif - end if - + endif + end if + end function NumPotentialCanopyLayers end module EDCanopyStructureMod From d1658dbb07125baa3e3607033b90617567ac0b6b Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 22 Sep 2021 17:02:04 -0600 Subject: [PATCH 394/578] deleted trailing whitespace that somehow crept in everywhere --- biogeochem/EDCanopyStructureMod.F90 | 348 ++++++++++++++-------------- 1 file changed, 174 insertions(+), 174 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index f86d50570c..46db5845f1 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1,8 +1,8 @@ module EDCanopyStructureMod ! ===================================================================================== - ! Code to determine whether the canopy is closed, and which plants are either in the - ! understorey or overstorey. This is obviosuly far too complicated for it's own good + ! Code to determine whether the canopy is closed, and which plants are either in the + ! understorey or overstorey. This is obviosuly far too complicated for it's own good ! ===================================================================================== use FatesConstantsMod , only : r8 => fates_r8 @@ -66,7 +66,7 @@ module EDCanopyStructureMod ! will attempt to reduce errors ! below this level - real(r8), parameter :: area_check_precision = 1.0E-7_r8 ! Area conservation checks must + real(r8), parameter :: area_check_precision = 1.0E-7_r8 ! Area conservation checks must ! be within this absolute tolerance real(r8), parameter :: area_check_rel_precision = 1.0E-4_r8 ! Area conservation checks must ! be within this relative tolerance @@ -91,34 +91,34 @@ subroutine canopy_structure( currentSite , bc_in ) ! All top leaves in the same canopy layer get the same light resources. ! The first canopy layer is the 'canopy' or 'overstorey'. The second is the 'understorey'. ! More than two layers is not permitted at the moment - ! Seeds germinating into the 3rd or higher layers are automatically removed. + ! Seeds germinating into the 3rd or higher layers are automatically removed. ! ! ------Perfect Plasticity----- ! The idea of these canopy layers derives originally from Purves et al. 2009 ! Their concept is that, given enoughplasticity in canopy position, size, shape and depth ! all of the gound area will be filled perfectly by leaves, and additional leaves will have - ! to exist in the understorey. + ! to exist in the understorey. ! Purves et al. use the concept of 'Z*' to assume that the height required to attain a place in the ! canopy is spatially uniform. In this implementation, described in Fisher et al. (2010, New Phyt) we ! extent that concept to assume that position in the canopy has some random element, and that BOTH height - ! and chance combine to determine whether trees get into the canopy. + ! and chance combine to determine whether trees get into the canopy. ! Thus, when the canopy is closed and there is excess area, some of it must be demoted - ! If we demote -all- the trees less than a given height, there is a massive advantage in being the cohort that is - ! the biggest when the canopy is closed. + ! If we demote -all- the trees less than a given height, there is a massive advantage in being the cohort that is + ! the biggest when the canopy is closed. ! In this implementation, the amount demoted, ('weight') is a function of the height weighted by the competitive exclusion - ! parameter (ED_val_comp_excln). + ! parameter (ED_val_comp_excln). - ! Complexity in this routine results from a few things. + ! Complexity in this routine results from a few things. ! Firstly, the complication of the demotion amount sometimes being larger than the cohort area (for a very small, short cohort) - ! Second, occasionaly, disturbance (specifically fire) can cause the canopy layer to become less than closed, - ! without changing the area of the patch. If this happens, then some of the plants in the lower layer need to be 'promoted' so - ! all of the routine has to happen in both the downwards and upwards directions. + ! Second, occasionaly, disturbance (specifically fire) can cause the canopy layer to become less than closed, + ! without changing the area of the patch. If this happens, then some of the plants in the lower layer need to be 'promoted' so + ! all of the routine has to happen in both the downwards and upwards directions. ! ! The order of events here is therefore: - ! (The entire subroutine has a single outer 'patch' loop. - ! Section 1: figure out the total area, and whether there are >1 canopy layers at all. + ! (The entire subroutine has a single outer 'patch' loop. + ! Section 1: figure out the total area, and whether there are >1 canopy layers at all. ! - ! Sorts out cohorts into canopy and understorey layers... + ! Sorts out cohorts into canopy and understorey layers... ! ! !USES: @@ -126,7 +126,7 @@ subroutine canopy_structure( currentSite , bc_in ) use EDTypesMod , only : min_patch_area ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type) , intent(inout), target :: currentSite type(bc_in_type), intent(in) :: bc_in @@ -135,7 +135,7 @@ subroutine canopy_structure( currentSite , bc_in ) type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort integer :: i_lyr ! current layer index - integer :: z ! Current number of canopy layers. (1= canopy, 2 = understorey) + integer :: z ! Current number of canopy layers. (1= canopy, 2 = understorey) integer :: ipft real(r8) :: arealayer(nclmax+2) ! Amount of plant area currently in each canopy layer integer :: patch_area_counter ! count iterations used to solve canopy areas @@ -152,8 +152,8 @@ subroutine canopy_structure( currentSite , bc_in ) !---------------------------------------------------------------------- - currentPatch => currentSite%oldest_patch - ! + currentPatch => currentSite%oldest_patch + ! ! zero site-level demotion / promotion tracking info currentSite%demotion_rate(:) = 0._r8 currentSite%promotion_rate(:) = 0._r8 @@ -162,9 +162,9 @@ subroutine canopy_structure( currentSite , bc_in ) ! - ! Section 1: Check total canopy area. + ! Section 1: Check total canopy area. ! - do while (associated(currentPatch)) ! Patch loop + do while (associated(currentPatch)) ! Patch loop ! ------------------------------------------------------------------------------ ! Perform numerical checks on some cohort and patch structures @@ -173,7 +173,7 @@ subroutine canopy_structure( currentSite , bc_in ) ! canopy layer has a special bounds check currentCohort => currentPatch%tallest do while (associated(currentCohort)) - if( currentCohort%canopy_layer < 1 .or. currentCohort%canopy_layer > nclmax+1 ) then + if( currentCohort%canopy_layer < 1 .or. currentCohort%canopy_layer > nclmax+1 ) then write(fates_log(),*) 'lat:',currentSite%lat write(fates_log(),*) 'lon:',currentSite%lon write(fates_log(),*) 'BOGUS CANOPY LAYER: ',currentCohort%canopy_layer @@ -199,11 +199,11 @@ subroutine canopy_structure( currentSite , bc_in ) call terminate_cohorts(currentSite, currentPatch, 1, 12, bc_in) ! Calculate how many layers we have in this canopy - ! This also checks the understory to see if its crown + ! This also checks the understory to see if its crown ! area is large enough to warrant a temporary sub-understory layer z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) - do i_lyr = 1,z ! Loop around the currently occupied canopy layers. + do i_lyr = 1,z ! Loop around the currently occupied canopy layers. call DemoteFromLayer(currentSite, currentPatch, i_lyr, bc_in) end do @@ -228,7 +228,7 @@ subroutine canopy_structure( currentSite , bc_in ) ! We only promote if we have at least two layers if (z>1) then - do i_lyr=1,z-1 + do i_lyr=1,z-1 call PromoteIntoLayer(currentSite, currentPatch, i_lyr) end do @@ -275,7 +275,7 @@ subroutine canopy_structure( currentSite , bc_in ) write(fates_log(),*) 'lon:',currentSite%lon write(fates_log(),*) 'spread:',currentSite%spread currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) write(fates_log(),*) 'coh ilayer:',currentCohort%canopy_layer write(fates_log(),*) 'coh dbh:',currentCohort%dbh write(fates_log(),*) 'coh pft:',currentCohort%pft @@ -296,13 +296,13 @@ subroutine canopy_structure( currentSite , bc_in ) enddo ! do while(area_not_balanced) - ! Set current canopy layer occupancy indicator. - currentPatch%NCL_p = min(nclmax,z) + ! Set current canopy layer occupancy indicator. + currentPatch%NCL_p = min(nclmax,z) ! ------------------------------------------------------------------------------------------- - ! if we are using "strict PPA", then calculate a z_star value as - ! the height of the smallest tree in the canopy - ! loop from top to bottom and locate the shortest cohort in level 1 whose shorter + ! if we are using "strict PPA", then calculate a z_star value as + ! the height of the smallest tree in the canopy + ! loop from top to bottom and locate the shortest cohort in level 1 whose shorter ! neighbor is in level 2 set zstar as the ehight of that shortest level 1 cohort ! ------------------------------------------------------------------------------------------- @@ -373,8 +373,8 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) if ( demote_area > area_target_precision ) then - ! Is this layer currently over-occupied? - ! In that case, we need to work out which cohorts to demote. + ! Is this layer currently over-occupied? + ! In that case, we need to work out which cohorts to demote. ! We go in order from shortest to tallest for ranked demotion sumweights = 0.0_r8 @@ -412,7 +412,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) ! Rank ordered deterministic method ! ----------------------------------------------------------- ! If there are cohorts that have the exact same height (which is possible, really) - ! we don't want to unilaterally promote/demote one before the others. + ! we don't want to unilaterally promote/demote one before the others. ! So we <>mote them as a unit ! now we need to go through and figure out how many equal-size cohorts there are. ! then we need to go through, add up the collective crown areas of all equal-sized @@ -449,7 +449,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) do while (associated(nextc)) if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - ! now we know the total crown area of all equal-sized, + ! now we know the total crown area of all equal-sized, ! equal-canopy-layer cohorts nextc%excl_weight = & max(0.0_r8,min(nextc%c_area, & @@ -475,7 +475,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) else currentCohort%excl_weight = & max(min(currentCohort%c_area, demote_area - sumweights ), 0._r8) - sumweights = sumweights + currentCohort%excl_weight + sumweights = sumweights + currentCohort%excl_weight end if endif @@ -496,7 +496,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) currentCohort => currentPatch%tallest do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then + if(currentCohort%canopy_layer == i_lyr) then currentCohort%excl_weight = currentCohort%excl_weight/sumweights if( 1._r8/currentCohort%excl_weight < scale_factor_min ) & @@ -505,7 +505,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) scale_factor = scale_factor + currentCohort%excl_weight * currentCohort%c_area endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo ! This is the factor by which we need to multiply @@ -520,7 +520,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) currentCohort => currentPatch%tallest do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then + if(currentCohort%canopy_layer == i_lyr) then currentCohort%excl_weight = currentCohort%c_area * currentCohort%excl_weight * scale_factor if(debug) then @@ -539,7 +539,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) end if endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo else @@ -551,8 +551,8 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) area_res = 0._r8 scale_factor_res = 0._r8 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then area_res = area_res + & currentCohort%c_area * currentCohort%excl_weight * & scale_factor_min @@ -560,7 +560,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) currentCohort%c_area * & (1._r8 - (currentCohort%excl_weight * scale_factor_min)) endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo area_res = demote_area - area_res @@ -568,8 +568,8 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) scale_factor_res = area_res / scale_factor_res currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then currentCohort%excl_weight = currentCohort%c_area * & (currentCohort%excl_weight * scale_factor_min + & @@ -590,7 +590,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) end if endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo end if @@ -601,7 +601,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) ! perform a check and see if the demotions meet the demand sumweights = 0._r8 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) if(currentCohort%canopy_layer == i_lyr) then sumweights = sumweights + currentCohort%excl_weight end if @@ -672,13 +672,13 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) call copy_cohort(currentCohort, copyc) newarea = currentCohort%c_area - cc_loss - copyc%n = currentCohort%n*newarea/currentCohort%c_area + copyc%n = currentCohort%n*newarea/currentCohort%c_area currentCohort%n = currentCohort%n - copyc%n copyc%canopy_layer = i_lyr !the taller cohort is the copy ! Demote the current cohort to the understory. - currentCohort%canopy_layer = i_lyr + 1 + currentCohort%canopy_layer = i_lyr + 1 ! keep track of number and biomass of demoted cohort currentSite%demotion_rate(currentCohort%size_class) = & @@ -690,7 +690,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) - !----------- Insert copy into linked list ------------------------! + !----------- Insert copy into linked list ------------------------! copyc%shorter => currentCohort if(associated(currentCohort%taller))then copyc%taller => currentCohort%taller @@ -713,9 +713,9 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) ! kill the ones which go into canopy layers that are not allowed - if(currentCohort%canopy_layer>nclmax )then + if(currentCohort%canopy_layer>nclmax )then - ! put the litter from the terminated cohorts + ! put the litter from the terminated cohorts ! straight into the fragmenting pools call SendCohortToLitter(currentSite,currentPatch, & currentCohort,currentCohort%n,bc_in) @@ -732,7 +732,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) endif !canopy layer = i_ly currentCohort => currentCohort%shorter - enddo !currentCohort + enddo !currentCohort ! Update the area calculations of the current layer @@ -766,7 +766,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! ------------------------------------------------------------------------------------------- ! Check whether the intended 'full' layers are actually filling all the space. ! If not, promote some fraction of cohorts upwards. - ! THIS SECTION MIGHT BE TRIGGERED BY A FIRE OR MORTALITY EVENT, FOLLOWED BY A PATCH FUSION, + ! THIS SECTION MIGHT BE TRIGGERED BY A FIRE OR MORTALITY EVENT, FOLLOWED BY A PATCH FUSION, ! SO THE TOP LAYER IS NO LONGER FULL. ! ------------------------------------------------------------------------------------------- @@ -809,7 +809,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! how much do we need to gain? - promote_area = currentPatch%area - arealayer_current + promote_area = currentPatch%area - arealayer_current if( promote_area > area_target_precision ) then @@ -820,10 +820,10 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! than the tolerance on the gains needed into current layer ! --------------------------------------------------------------------------- - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - !look at the cohorts in the canopy layer below... - if(currentCohort%canopy_layer == i_lyr+1)then + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + !look at the cohorts in the canopy layer below... + if(currentCohort%canopy_layer == i_lyr+1)then leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) @@ -831,7 +831,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) - currentCohort%canopy_layer = i_lyr + currentCohort%canopy_layer = i_lyr call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) ! keep track of number and biomass of promoted cohort @@ -841,7 +841,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo else @@ -853,14 +853,14 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! figure out with what weighting we need to promote cohorts. - ! This is the opposite of the demotion weighting... + ! This is the opposite of the demotion weighting... sumweights = 0.0_r8 - currentCohort => currentPatch%tallest + currentCohort => currentPatch%tallest do while (associated(currentCohort)) call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) - if(currentCohort%canopy_layer == i_lyr+1)then !look at the cohorts in the canopy layer below... + if(currentCohort%canopy_layer == i_lyr+1)then !look at the cohorts in the canopy layer below... if (ED_val_comp_excln .ge. 0.0_r8 ) then @@ -875,7 +875,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! ------------------------------------------------------------------ ! Rank ordered deterministic method ! If there are cohorts that have the exact same height (which is possible, really) - ! we don't want to unilaterally promote/demote one before the others. + ! we don't want to unilaterally promote/demote one before the others. ! So we <>mote them as a unit ! now we need to go through and figure out how many equal-size cohorts there are. ! then we need to go through, add up the collective crown areas of all equal-sized @@ -911,7 +911,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) do while (associated(nextc)) if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - ! now we know the total crown area of all equal-sized, + ! now we know the total crown area of all equal-sized, ! equal-canopy-layer cohorts nextc%prom_weight = & max(0.0_r8,min(nextc%c_area, & @@ -937,13 +937,13 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) else currentCohort%prom_weight = & max(min(currentCohort%c_area, promote_area - sumweights ), 0._r8) - sumweights = sumweights + currentCohort%prom_weight + sumweights = sumweights + currentCohort%prom_weight end if endif endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo !currentCohort @@ -959,7 +959,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) currentCohort => currentPatch%tallest do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1) ) then + if(currentCohort%canopy_layer == (i_lyr+1) ) then currentCohort%prom_weight = currentCohort%prom_weight/sumweights if( 1._r8/currentCohort%prom_weight < scale_factor_min ) & @@ -968,7 +968,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) scale_factor = scale_factor + currentCohort%prom_weight * currentCohort%c_area endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo ! This is the factor by which we need to multiply @@ -984,7 +984,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) currentCohort => currentPatch%tallest do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1) ) then + if(currentCohort%canopy_layer == (i_lyr+1) ) then currentCohort%prom_weight = currentCohort%c_area * & currentCohort%prom_weight * scale_factor @@ -1003,7 +1003,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) end if endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo else @@ -1014,15 +1014,15 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) area_res = 0._r8 scale_factor_res = 0._r8 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1) ) then + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1) ) then area_res = area_res + & currentCohort%c_area*currentCohort%prom_weight*scale_factor_min scale_factor_res = scale_factor_res + & currentCohort%c_area * & (1._r8 - (currentCohort%prom_weight * scale_factor_min)) endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo area_res = promote_area - area_res @@ -1030,8 +1030,8 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) scale_factor_res = area_res / scale_factor_res currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1)) then + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1)) then currentCohort%prom_weight = currentCohort%c_area * & (currentCohort%prom_weight * scale_factor_min + & @@ -1053,7 +1053,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) end if endif - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo end if @@ -1064,7 +1064,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! lets perform a check and see if the promotions meet the demand sumweights = 0._r8 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) if(currentCohort%canopy_layer == (i_lyr+1)) then sumweights = sumweights + currentCohort%prom_weight end if @@ -1082,10 +1082,10 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) end if currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) - !All the trees in this layer need to promote some area upwards... + !All the trees in this layer need to promote some area upwards... if( (currentCohort%canopy_layer == i_lyr+1) ) then cc_gain = currentCohort%prom_weight @@ -1128,14 +1128,14 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) - ! number of individuals in promoted cohort. - copyc%n = currentCohort%n*cc_gain/currentCohort%c_area + ! number of individuals in promoted cohort. + copyc%n = currentCohort%n*cc_gain/currentCohort%c_area - ! number of individuals in cohort remaining in understorey + ! number of individuals in cohort remaining in understorey currentCohort%n = currentCohort%n - copyc%n - currentCohort%canopy_layer = i_lyr + 1 ! keep current cohort in the understory. - copyc%canopy_layer = i_lyr ! promote copy to the higher canopy layer. + currentCohort%canopy_layer = i_lyr + 1 ! keep current cohort in the understory. + copyc%canopy_layer = i_lyr ! promote copy to the higher canopy layer. ! keep track of number and biomass of promoted cohort currentSite%promotion_rate(copyc%size_class) = & @@ -1148,7 +1148,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) currentCohort%pft,currentCohort%c_area) call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) - !----------- Insert copy into linked list ------------------------! + !----------- Insert copy into linked list ------------------------! copyc%shorter => currentCohort if(associated(currentCohort%taller))then copyc%taller => currentCohort%taller @@ -1157,7 +1157,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) currentPatch%tallest => copyc copyc%taller => null() endif - currentCohort%taller => copyc + currentCohort%taller => copyc elseif(cc_gain > currentCohort%c_area)then @@ -1170,7 +1170,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) endif ! if(currentCohort%canopy_layer == i_lyr+1) then currentCohort => currentCohort%shorter - enddo !currentCohort + enddo !currentCohort call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) @@ -1195,20 +1195,20 @@ end subroutine PromoteIntoLayer subroutine canopy_spread( currentSite ) ! ! !DESCRIPTION: - ! Calculates the spatial spread of tree canopies based on canopy closure. + ! Calculates the spatial spread of tree canopies based on canopy closure. ! ! !USES: use EDTypesMod , only : AREA - use EDParamsMod, only : ED_val_canopy_closure_thresh + use EDParamsMod, only : ED_val_canopy_closure_thresh ! - ! !ARGUMENTS + ! !ARGUMENTS type (ed_site_type), intent(inout), target :: currentSite ! ! !LOCAL VARIABLES: type (ed_cohort_type), pointer :: currentCohort type (ed_patch_type) , pointer :: currentPatch real(r8) :: sitelevel_canopyarea ! Amount of canopy in top layer at the site level - real(r8) :: inc ! Arbitrary daily incremental change in canopy area + real(r8) :: inc ! Arbitrary daily incremental change in canopy area integer :: z !---------------------------------------------------------------------- @@ -1216,7 +1216,7 @@ subroutine canopy_spread( currentSite ) currentPatch => currentSite%oldest_patch - sitelevel_canopyarea = 0.0_r8 + sitelevel_canopyarea = 0.0_r8 do while (associated(currentPatch)) !calculate canopy area in each patch... @@ -1239,8 +1239,8 @@ subroutine canopy_spread( currentSite ) ! squash the tree canopies and make them taller and thinner if( sitelevel_canopyarea/AREA .gt. ED_val_canopy_closure_thresh ) then currentSite%spread = currentSite%spread - inc - else - currentSite%spread = currentSite%spread + inc + else + currentSite%spread = currentSite%spread + inc endif ! put within bounds to make sure it stays between 0 and 1 @@ -1264,7 +1264,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) use EDtypesMod , only : area use FatesConstantsMod , only : itrue - ! !ARGUMENTS + ! !ARGUMENTS integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) type(bc_in_type) , intent(in) :: bc_in(nsites) @@ -1275,8 +1275,8 @@ subroutine canopy_summarization( nsites, sites, bc_in ) integer :: s integer :: ft ! plant functional type integer :: ifp ! the number of the vegetated patch (1,2,3). In SP mode bareground patch is 0 - integer :: patchn ! identification number for each patch. - real(r8) :: canopy_leaf_area ! total amount of leaf area in the vegetated area. m2. + integer :: patchn ! identification number for each patch. + real(r8) :: canopy_leaf_area ! total amount of leaf area in the vegetated area. m2. real(r8) :: leaf_c ! leaf carbon [kg] real(r8) :: fnrt_c ! fineroot carbon [kg] real(r8) :: sapw_c ! sapwood carbon [kg] @@ -1292,8 +1292,8 @@ subroutine canopy_summarization( nsites, sites, bc_in ) do s = 1,nsites ! -------------------------------------------------------------------------------- - ! Set the patch indices (this is usefull mostly for communicating with a host or - ! driving model. Loops through all patches and sets cpatch%patchno to the integer + ! Set the patch indices (this is usefull mostly for communicating with a host or + ! driving model. Loops through all patches and sets cpatch%patchno to the integer ! order of oldest to youngest where the oldest is 1. ! -------------------------------------------------------------------------------- call set_patchno( sites(s) ) @@ -1302,12 +1302,12 @@ subroutine canopy_summarization( nsites, sites, bc_in ) do while(associated(currentPatch)) - !zero cohort-summed variables. + !zero cohort-summed variables. currentPatch%total_canopy_area = 0.0_r8 currentPatch%total_tree_area = 0.0_r8 canopy_leaf_area = 0.0_r8 - !update cohort quantitie s + !update cohort quantitie s currentCohort => currentPatch%shortest do while(associated(currentCohort)) @@ -1367,7 +1367,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) end if end if !sp mode - ! Check for erroneous zero values. + ! Check for erroneous zero values. if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then write(fates_log(),*) 'FATES: dbh or n is zero in canopy_summarization', & currentCohort%dbh,currentCohort%n @@ -1436,11 +1436,11 @@ end subroutine UpdateFatesAvgSnowDepth subroutine leaf_area_profile( currentSite ) ! ----------------------------------------------------------------------------------- - ! This subroutine calculates how leaf and stem areas are distributed + ! This subroutine calculates how leaf and stem areas are distributed ! in vertical and horizontal space. ! ! The following cohort level diagnostics are updated here: - ! + ! ! currentCohort%treelai ! LAI per unit crown area (m2/m2) ! currentCohort%treesai ! SAI per unit crown area (m2/m2) ! currentCohort%lai ! LAI per unit canopy area (m2/m2) @@ -1449,10 +1449,10 @@ subroutine leaf_area_profile( currentSite ) ! ! layers needed to describe this crown ! ! The following patch level diagnostics are updated here: - ! + ! ! currentPatch%canopy_layer_tlai(cl) ! total leaf area index of canopy layer ! currentPatch%ncan(cl,ft) ! number of vegetation layers needed - ! ! in this patch's pft/canopy-layer + ! ! in this patch's pft/canopy-layer ! currentPatch%nrad(cl,ft) ! same as ncan, but does not include ! ! layers occluded by snow ! ! CURRENTLY SAME AS NCAN @@ -1462,7 +1462,7 @@ subroutine leaf_area_profile( currentSite ) ! currentPatch%elai_profile(cl,ft,iv) ! non-snow covered m2 of leaves per m2 of PFT footprint ! currentPatch%tsai_profile(cl,ft,iv) ! m2 of stems per m2 of PFT footprint ! currentPatch%esai_profile(cl,ft,iv) ! non-snow covered m2 of stems per m2 of PFT footprint - ! currentPatch%canopy_area_profile(cl,ft,iv) ! Fractional area of leaf layer + ! currentPatch%canopy_area_profile(cl,ft,iv) ! Fractional area of leaf layer ! ! relative to vegetated area ! currentPatch%layer_height_profile(cl,ft,iv) ! Elevation of layer in m ! @@ -1473,7 +1473,7 @@ subroutine leaf_area_profile( currentSite ) use EDtypesMod , only : area, dinc_ed, hitemax, n_hite_bins ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type) , intent(inout) :: currentSite @@ -1481,10 +1481,10 @@ subroutine leaf_area_profile( currentSite ) ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort - real(r8) :: remainder !Thickness of layer at bottom of canopy. - real(r8) :: fleaf ! fraction of cohort incepting area that is leaves. - integer :: ft ! Plant functional type index. - integer :: iv ! Vertical leaf layer index + real(r8) :: remainder !Thickness of layer at bottom of canopy. + real(r8) :: fleaf ! fraction of cohort incepting area that is leaves. + integer :: ft ! Plant functional type index. + integer :: iv ! Vertical leaf layer index integer :: cl ! Canopy layer index real(r8) :: fraction_exposed ! how much of this layer is not covered by snow? real(r8) :: layer_top_hite ! notional top height of this canopy layer (m) @@ -1508,27 +1508,27 @@ subroutine leaf_area_profile( currentSite ) ! Here we are trying to generate a profile of leaf area, indexed by 'z' and by pft ! We assume that each point in the canopy recieved the light attenuated by the average - ! leaf area index above it, irrespective of PFT identity... + ! leaf area index above it, irrespective of PFT identity... ! Each leaf is defined by how deep in the canopy it is, in terms of LAI units. (FIX(RF,032414), GB) - currentPatch => currentSite%oldest_patch + currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) ! -------------------------------------------------------------------------------- - ! Calculate tree and canopy areas. + ! Calculate tree and canopy areas. ! calculate tree lai and sai. ! -------------------------------------------------------------------------------- currentPatch%canopy_layer_tlai(:) = 0._r8 - currentPatch%ncan(:,:) = 0 - currentPatch%nrad(:,:) = 0 + currentPatch%ncan(:,:) = 0 + currentPatch%nrad(:,:) = 0 patch_lai = 0._r8 currentPatch%tlai_profile(:,:,:) = 0._r8 - currentPatch%tsai_profile(:,:,:) = 0._r8 + currentPatch%tsai_profile(:,:,:) = 0._r8 currentPatch%elai_profile(:,:,:) = 0._r8 - currentPatch%esai_profile(:,:,:) = 0._r8 + currentPatch%esai_profile(:,:,:) = 0._r8 currentPatch%layer_height_profile(:,:,:) = 0._r8 - currentPatch%canopy_area_profile(:,:,:) = 0._r8 + currentPatch%canopy_area_profile(:,:,:) = 0._r8 currentPatch%canopy_mask(:,:) = 0 ! ------------------------------------------------------------------------------ @@ -1540,7 +1540,7 @@ subroutine leaf_area_profile( currentSite ) currentCohort => currentPatch%tallest - do while(associated(currentCohort)) + do while(associated(currentCohort)) ft = currentCohort%pft cl = currentCohort%canopy_layer @@ -1553,20 +1553,20 @@ subroutine leaf_area_profile( currentSite ) currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) if (hlm_use_sp .eq. ifalse) then currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & currentPatch%canopy_layer_tlai, currentCohort%treelai , & - currentCohort%vcmax25top,4) + currentCohort%vcmax25top,4) end if - currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area - currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area + currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area + currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area ! Number of actual vegetation layers in this cohort's crown - currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) + currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) currentPatch%ncan(cl,ft) = max(currentPatch%ncan(cl,ft),currentCohort%NV) @@ -1574,47 +1574,47 @@ subroutine leaf_area_profile( currentSite ) currentPatch%canopy_layer_tlai(cl) = currentPatch%canopy_layer_tlai(cl) + currentCohort%lai - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo !currentCohort if(smooth_leaf_distribution == 1)then ! ----------------------------------------------------------------------------- - ! we are going to ignore the concept of canopy layers, and put all of the leaf - ! area into height banded bins. using the same domains as we had before, except + ! we are going to ignore the concept of canopy layers, and put all of the leaf + ! area into height banded bins. using the same domains as we had before, except ! that CL always = 1 ! ----------------------------------------------------------------------------- - ! this is a crude way of dividing up the bins. Should it be a function of actual maximum height? - dh = 1.0_r8*(HITEMAX/N_HITE_BINS) - do iv = 1,N_HITE_BINS + ! this is a crude way of dividing up the bins. Should it be a function of actual maximum height? + dh = 1.0_r8*(HITEMAX/N_HITE_BINS) + do iv = 1,N_HITE_BINS if (iv == 1) then minh(iv) = 0.0_r8 maxh(iv) = dh - else + else minh(iv) = (iv-1)*dh maxh(iv) = (iv)*dh endif enddo currentCohort => currentPatch%shortest - do while(associated(currentCohort)) + do while(associated(currentCohort)) ft = currentCohort%pft min_chite = currentCohort%hite - currentCohort%hite * EDPftvarcon_inst%crown(ft) - max_chite = currentCohort%hite - do iv = 1,N_HITE_BINS + max_chite = currentCohort%hite + do iv = 1,N_HITE_BINS frac_canopy(iv) = 0.0_r8 ! this layer is in the middle of the canopy - if(max_chite > maxh(iv).and.min_chite < minh(iv))then + if(max_chite > maxh(iv).and.min_chite < minh(iv))then frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*EDPftvarcon_inst%crown(ft))) - ! this is the layer with the bottom of the canopy in it. - elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then + ! this is the layer with the bottom of the canopy in it. + elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) - ! this is the layer with the top of the canopy in it. - elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then + ! this is the layer with the top of the canopy in it. + elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) - elseif(max_chite < maxh(iv).and.min_chite > minh(iv))then !the whole cohort is within this layer. + elseif(max_chite < maxh(iv).and.min_chite > minh(iv))then !the whole cohort is within this layer. frac_canopy(iv) = 1.0_r8 endif @@ -1642,7 +1642,7 @@ subroutine leaf_area_profile( currentSite ) currentCohort => currentCohort%taller - enddo !currentCohort + enddo !currentCohort ! ----------------------------------------------------------------------------- ! Perform a leaf area conservation check on the LAI profile @@ -1657,32 +1657,32 @@ subroutine leaf_area_profile( currentSite ) endif - else ! smooth leaf distribution + else ! smooth leaf distribution ! ----------------------------------------------------------------------------- ! Standard canopy layering model. - ! Go through all cohorts and add their leaf area - ! and canopy area to the accumulators. + ! Go through all cohorts and add their leaf area + ! and canopy area to the accumulators. ! ----------------------------------------------------------------------------- currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - ft = currentCohort%pft + do while(associated(currentCohort)) + ft = currentCohort%pft cl = currentCohort%canopy_layer ! ---------------------------------------------------------------- - ! How much of each tree is stem area index? Assuming that there is + ! How much of each tree is stem area index? Assuming that there is ! This may indeed be zero if there is a sensecent grass ! ---------------------------------------------------------------- - if( (currentCohort%treelai+currentCohort%treesai) > 0._r8)then - fleaf = currentCohort%lai / (currentCohort%lai + currentCohort%sai) + if( (currentCohort%treelai+currentCohort%treesai) > 0._r8)then + fleaf = currentCohort%lai / (currentCohort%lai + currentCohort%sai) else fleaf = 0._r8 endif - currentPatch%nrad(cl,ft) = currentPatch%ncan(cl,ft) + currentPatch%nrad(cl,ft) = currentPatch%ncan(cl,ft) if (currentPatch%nrad(cl,ft) > nlevleaf ) then write(fates_log(), *) 'Number of radiative leaf layers is larger' @@ -1696,8 +1696,8 @@ subroutine leaf_area_profile( currentSite ) ! -------------------------------------------------------------------------- - ! Whole layers. Make a weighted average of the leaf area in each layer - ! before dividing it by the total area. Fill up layer for whole layers. + ! Whole layers. Make a weighted average of the leaf area in each layer + ! before dividing it by the total area. Fill up layer for whole layers. ! -------------------------------------------------------------------------- do iv = 1,currentCohort%NV @@ -1733,7 +1733,7 @@ subroutine leaf_area_profile( currentSite ) (dinc_ed*real(currentCohort%nv-1,r8)) if(remainder > dinc_ed )then write(fates_log(), *)'ED: issue with remainder', & - currentCohort%treelai,currentCohort%treesai,dinc_ed, & + currentCohort%treelai,currentCohort%treesai,dinc_ed, & currentCohort%NV,remainder call endrun(msg=errMsg(sourcefile, __LINE__)) endif @@ -1760,7 +1760,7 @@ subroutine leaf_area_profile( currentSite ) currentPatch%layer_height_profile(cl,ft,iv) = currentPatch%layer_height_profile(cl,ft,iv) + & (remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & - (layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. + (layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. end do @@ -1789,7 +1789,7 @@ subroutine leaf_area_profile( currentSite ) write(fates_log(), *) 'ED: fracarea', currentCohort%pft, & currentCohort%c_area/currentPatch%total_canopy_area endif - currentCohort => currentCohort%taller + currentCohort => currentCohort%taller enddo !currentCohort call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1826,7 +1826,7 @@ subroutine leaf_area_profile( currentSite ) write(fates_log(), *) 'ED: fracarea', currentCohort%pft, & currentCohort%c_area/currentPatch%total_canopy_area endif - currentCohort => currentCohort%taller + currentCohort => currentCohort%taller enddo !currentCohort call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1869,7 +1869,7 @@ subroutine leaf_area_profile( currentSite ) do ft = 1,numpft do iv = 1, currentPatch%nrad(cl,ft) if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then - currentPatch%canopy_mask(cl,ft) = 1 + currentPatch%canopy_mask(cl,ft) = 1 endif end do !iv enddo !ft @@ -1879,9 +1879,9 @@ subroutine leaf_area_profile( currentSite ) end if - currentPatch => currentPatch%younger + currentPatch => currentPatch%younger - enddo !patch + enddo !patch return end subroutine leaf_area_profile @@ -1900,7 +1900,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) use FatesInterfaceTypesMod , only : bc_out_type ! - ! !ARGUMENTS + ! !ARGUMENTS integer, intent(in) :: nsites type(ed_site_type), intent(inout), target :: sites(nsites) integer, intent(in) :: fcolumn(nsites) @@ -1919,7 +1919,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) do s = 1,nsites ifp = 0 - total_patch_area = 0._r8 + total_patch_area = 0._r8 total_canopy_area = 0._r8 bc_out(s)%canopy_fraction_pa(:) = 0._r8 bc_out(s)%dleaf_pa(:) = 0._r8 @@ -1981,7 +1981,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & currentPatch%canopy_layer_tlai, currentCohort%treelai , & - currentCohort%vcmax25top,4) + currentCohort%vcmax25top,4) total_patch_leaf_stem_area = total_patch_leaf_stem_area + & (currentCohort%treelai + currentCohort%treesai) * currentCohort%c_area @@ -2010,11 +2010,11 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) endif ! ----------------------------------------------------------------------------- - ! We are assuming here that grass is all located underneath tree canopies. + ! We are assuming here that grass is all located underneath tree canopies. ! The alternative is to assume it is all spatial distinct from tree canopies. ! In which case, the bare area would have to be reduced by the grass area... - ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants - ! currentPatch%area/AREA is the fraction of the soil covered by this patch. + ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants + ! currentPatch%area/AREA is the fraction of the soil covered by this patch. if(currentPatch%area.gt.0.0_r8)then bc_out(s)%canopy_fraction_pa(ifp) = & @@ -2045,7 +2045,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! patches which shall under-go photosynthesis ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let ! FATES internal variables decide if photosynthesis is possible - ! we are essentially calculating it inside FATES to tell the + ! we are essentially calculating it inside FATES to tell the ! host to tell itself when to do things (circuitous). Just have ! to determine where else it is used @@ -2242,7 +2242,7 @@ function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) res z = 1 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) z = max(z,currentCohort%canopy_layer) currentCohort => currentCohort%shorter enddo @@ -2250,7 +2250,7 @@ function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) res if(include_substory)then arealayer = 0.0 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) if(currentCohort%canopy_layer == z) then call carea_allom(currentCohort%dbh,currentCohort%n,site_spread,currentCohort%pft,c_area) arealayer = arealayer + c_area @@ -2258,7 +2258,7 @@ function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) res currentCohort => currentCohort%shorter enddo - ! Does the bottom layer have more than a full canopy? + ! Does the bottom layer have more than a full canopy? ! If so we need to make another layer. if(arealayer > currentPatch%area)then z = z + 1 From 532ec07941ea3486467a64a8225beb091a7cf47d Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 27 Sep 2021 11:51:34 -0400 Subject: [PATCH 395/578] Update biogeophys/FatesPlantHydraulicsMod.F90 Co-authored-by: Rosie Fisher --- biogeophys/FatesPlantHydraulicsMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 0fce8b36cd..12d6c152ab 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -849,7 +849,6 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) real(r8) :: frk ! the exponent parameter of the cohort rooting depth function, a PFT based parameter - ! end of Junyan's addition ! We allow the transporting root to donate a fraction of its volume to the absorbing From c7845caebbc3988ff5e168905bb034846425e099 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 27 Sep 2021 11:52:02 -0400 Subject: [PATCH 396/578] Update biogeophys/FatesPlantHydraulicsMod.F90 Co-authored-by: Rosie Fisher --- biogeophys/FatesPlantHydraulicsMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 12d6c152ab..bb43929935 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -836,7 +836,6 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) real(r8) :: norm ! total root fraction used <1 integer :: nlevrhiz ! number of rhizosphere levels - ! added by Junyan May 29, 2020 real(r8) :: dbh ! the dbh of current cohort [m] real(r8) :: dbh_0 ! the dbh of the sappling at recuitment [m] From eb77f66bfdc35d864e0a491aad8a107d9fd74ae0 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 27 Sep 2021 11:52:46 -0400 Subject: [PATCH 397/578] Update biogeophys/FatesPlantHydraulicsMod.F90 Co-authored-by: Rosie Fisher --- biogeophys/FatesPlantHydraulicsMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index bb43929935..3af5079c06 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -974,7 +974,6 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! We have a condition, where we may ignore the first layer ! ------------------------------------------------------------------------------ - ! norm = 1._r8 - & ! zeng2001_crootfr(roota, rootb,site_hydr%zi_rhiz(1)-site_hydr%dz_rhiz(1), site_hydr%zi_rhiz(nlevrhiz)) From b2ccfe3baea60ddd7b32fba5973ddc4186f52b99 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 27 Sep 2021 11:54:30 -0400 Subject: [PATCH 398/578] Update biogeophys/FatesPlantHydraulicsMod.F90 Co-authored-by: Rosie Fisher --- biogeophys/FatesPlantHydraulicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 3af5079c06..e251dd7392 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -992,7 +992,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j)-site_hydr%dz_rhiz(j),z_fr)) if(debug)then - write(fates_log(),*) 'check rooting depth of cohort - Junyan, line 987' + write(fates_log(),*) 'check rooting depth of cohort ' write(fates_log(),*) 'dbh: ',ccohort%dbh,' sice class: ',ccohort%size_class write(fates_log(),*) 'site_hydr%dz_rhiz(j) is: ', site_hydr%dz_rhiz(j) write(fates_log(),*) 'z_max cohort: ',z_fr From aad3bbb17a855195a0cbf9236ea05464d1154c73 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 27 Sep 2021 11:55:10 -0400 Subject: [PATCH 399/578] Update biogeophys/FatesPlantHydraulicsMod.F90 Co-authored-by: Rosie Fisher --- biogeophys/FatesPlantHydraulicsMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index e251dd7392..6623e2af00 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -1608,7 +1608,6 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) ! 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. - ! Notes by Junyan, July 16. 2020 ! modify the accessable soil layer equal to z_fr_0 ! ! ---------------------------------------------------------------------------------- From 4bee85e78454e3fa410e47affcd6d61872f285c7 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 27 Sep 2021 11:55:27 -0400 Subject: [PATCH 400/578] Update biogeophys/FatesPlantHydraulicsMod.F90 Co-authored-by: Rosie Fisher --- biogeophys/FatesPlantHydraulicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 6623e2af00..1d929b789b 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -1626,7 +1626,7 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) 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) :: roota !root distribution 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) From fdc8646bb62fccaae123dd1f38c620ebaf952481 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 27 Sep 2021 11:56:01 -0400 Subject: [PATCH 401/578] Update biogeophys/FatesPlantHydraulicsMod.F90 Co-authored-by: Rosie Fisher --- biogeophys/FatesPlantHydraulicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 1d929b789b..2c474ccc43 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -1627,7 +1627,7 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) integer :: s, j, ft integer :: nstep !number of time steps real(r8) :: roota !root distribution parameter a - real(r8) :: rootb !root distriubiton parameter b + real(r8) :: rootb !root distribution 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) From 695a439332d39a329c9c8923eca93e615779bb91 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 27 Sep 2021 11:56:13 -0400 Subject: [PATCH 402/578] Update biogeophys/FatesPlantHydraulicsMod.F90 Co-authored-by: Rosie Fisher --- biogeophys/FatesPlantHydraulicsMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 2c474ccc43..b38d58a2d3 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -3351,7 +3351,6 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! cohort_hydr%l_aroot_layer(ilayer) is units [m/plant] ! site_hydr%l_aroot_layer(ilayer) is units [m/site] - ! Junyan added if statement to handle zero l_aroot_layer condition if (site_hydr%l_aroot_layer(ilayer) Date: Mon, 27 Sep 2021 11:56:23 -0400 Subject: [PATCH 403/578] Update biogeophys/FatesPlantHydraulicsMod.F90 Co-authored-by: Rosie Fisher --- biogeophys/FatesPlantHydraulicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index b38d58a2d3..dadfe65391 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -4370,7 +4370,7 @@ function zeng2001_crootfr(a, b, z, z_max) result(crootfr) if(present(z_max))then ! If the soil depth is larger than the maximum rooting depth of the cohort, - ! then the cumulative root frection of that layer equals that of the maximum rooting depth + ! then the cumulative root fraction of that layer equals that of the maximum rooting depth crootfr = 1._r8 - .5_r8*(exp(-a*min(z,z_max)) + exp(-b*min(z,z_max))) ! end of Junyan addition crootfr_max = 1._r8 - .5_r8*(exp(-a*z_max) + exp(-b*z_max)) From ea14e775e690f360fc6ea3060d7cdcf05dde649c Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 27 Sep 2021 11:56:41 -0400 Subject: [PATCH 404/578] Update biogeophys/FatesPlantHydraulicsMod.F90 Co-authored-by: Rosie Fisher --- biogeophys/FatesPlantHydraulicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index dadfe65391..58babee43a 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -4457,7 +4457,7 @@ subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_s ! r_node_shell(1:nshells) = 0 ! v_shell(1:k) = 0 - end if ! end line 4439 + end if return end subroutine shellGeom From b7fd5f5a5a0b9f7e351d1140484a74884a9579e2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 27 Sep 2021 11:59:23 -0400 Subject: [PATCH 405/578] Removed unnecessary manual attribution statement (author history in github) --- biogeophys/FatesPlantHydraulicsMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 58babee43a..8baf2b4df5 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -969,7 +969,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! to the layer-by-layer absorbing root (which is now a hybrid compartment) ! ------------------------------------------------------------------------------ ccohort_hydr%v_troot = (1._r8-t2aroot_vol_donate_frac) * v_troot - ! modified by Junyan May 29, 2020 + ! Partition the total absorbing root lengths and volumes into the active soil layers ! We have a condition, where we may ignore the first layer ! ------------------------------------------------------------------------------ From 11eeacc4d3022a5bb280354be63886ac1ee659b4 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 27 Sep 2021 14:55:27 -0600 Subject: [PATCH 406/578] auto-set margins and deleted trailing whitespace --- biogeophys/EDSurfaceAlbedoMod.F90 | 2220 ++++++++++++++--------------- 1 file changed, 1110 insertions(+), 1110 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 6bbc767f95..1655c59819 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -1,15 +1,15 @@ module EDSurfaceRadiationMod - - !------------------------------------------------------------------------------------- - ! EDSurfaceRadiation - ! - ! This module contains function and type definitions for all things related - ! to radiative transfer in ED modules at the land surface. - ! - !------------------------------------------------------------------------------------- + + !------------------------------------------------------------------------------------- + ! EDSurfaceRadiation + ! + ! This module contains function and type definitions for all things related + ! to radiative transfer in ED modules at the land surface. + ! + !------------------------------------------------------------------------------------- #include "shr_assert.h" - + use EDTypesMod , only : ed_patch_type, ed_site_type use EDTypesMod , only : maxPatchesPerSite use EDTypesMod , only : maxpft @@ -42,148 +42,148 @@ module EDSurfaceRadiationMod public :: ED_Norman_Radiation ! Surface albedo and two-stream fluxes public :: PatchNormanRadiation public :: ED_SunShadeFracs - + logical :: debug = .false. ! for debugging this module - -! real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) - ! (/ 0.80_r8, 0.55_r8 /) - -!parameters of canopy snow reflectance model. -! the parameters in the 2-stream model are not directly analagous to those here -! and so they are stored here for now in common with the ice parameters above. -! in principle these could be moved to the parameter file. - - real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) - (/ 0.80_r8, 0.55_r8 /) - real(r8), public :: rho_snow(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) - (/ 0.80_r8, 0.55_r8 /) - real(r8), public :: tau_snow(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) - (/ 0.01_r8, 0.01_r8 /) + + ! real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + ! (/ 0.80_r8, 0.55_r8 /) + + !parameters of canopy snow reflectance model. + ! the parameters in the 2-stream model are not directly analagous to those here + ! and so they are stored here for now in common with the ice parameters above. + ! in principle these could be moved to the parameter file. + + real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + (/ 0.80_r8, 0.55_r8 /) + real(r8), public :: rho_snow(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + (/ 0.80_r8, 0.55_r8 /) + real(r8), public :: tau_snow(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + (/ 0.01_r8, 0.01_r8 /) contains - + subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) - ! - - ! - ! !USES: - use EDPftvarcon , only : EDPftvarcon_inst - use EDtypesMod , only : ed_patch_type - use EDTypesMod , only : ed_site_type - - - ! !ARGUMENTS: - - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) ! FATES site vector - type(bc_in_type), intent(in) :: bc_in(nsites) - type(bc_out_type), intent(inout) :: bc_out(nsites) - - - ! !LOCAL VARIABLES: - integer :: s ! site loop counter - integer :: ifp ! patch loop counter - integer :: ib ! radiation broad band counter - type(ed_patch_type), pointer :: currentPatch ! patch pointer - - !----------------------------------------------------------------------- - ! ------------------------------------------------------------------------------- - ! TODO (mv, 2014-10-29) the filter here is different than below - ! this is needed to have the VOC's be bfb - this needs to be - ! re-examined int he future - ! RGK,2016-08-06: FATES is still incompatible with VOC emission module - ! ------------------------------------------------------------------------------- - - - do s = 1, nsites - - ifp = 0 - currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) - if(currentpatch%nocomp_pft_label.ne.0)then - ! do not do albedo calculations for bare ground patch in SP mode - ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein - ! ifp=1 is the first vegetated patch. - ifp = ifp+1 - - currentPatch%f_sun (:,:,:) = 0._r8 - currentPatch%fabd_sun_z (:,:,:) = 0._r8 - currentPatch%fabd_sha_z (:,:,:) = 0._r8 - currentPatch%fabi_sun_z (:,:,:) = 0._r8 - currentPatch%fabi_sha_z (:,:,:) = 0._r8 - currentPatch%fabd (:) = 0._r8 - currentPatch%fabi (:) = 0._r8 - - ! zero diagnostic radiation profiles - currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 - - currentPatch%solar_zenith_flag = bc_in(s)%filter_vegzen_pa(ifp) - currentPatch%solar_zenith_angle = bc_in(s)%coszen_pa(ifp) - currentPatch%gnd_alb_dif(1:hlm_numSWb) = bc_in(s)%albgr_dif_rb(1:hlm_numSWb) - currentPatch%gnd_alb_dir(1:hlm_numSWb) = bc_in(s)%albgr_dir_rb(1:hlm_numSWb) - currentPatch%fcansno = bc_in(s)%fcansno_pa(ifp) - - if(currentPatch%solar_zenith_flag )then - - bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%fabd_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM - bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM - bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM - - if (maxval(currentPatch%nrad(1,:))==0)then - !there are no leaf layers in this patch. it is effectively bare ground. - ! no radiation is absorbed - bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 - bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 - do ib = 1,hlm_numSWb - bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) - bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) - bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 + ! + + ! + ! !USES: + use EDPftvarcon , only : EDPftvarcon_inst + use EDtypesMod , only : ed_patch_type + use EDTypesMod , only : ed_site_type + + + ! !ARGUMENTS: + + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) ! FATES site vector + type(bc_in_type), intent(in) :: bc_in(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + + ! !LOCAL VARIABLES: + integer :: s ! site loop counter + integer :: ifp ! patch loop counter + integer :: ib ! radiation broad band counter + type(ed_patch_type), pointer :: currentPatch ! patch pointer + + !----------------------------------------------------------------------- + ! ------------------------------------------------------------------------------- + ! TODO (mv, 2014-10-29) the filter here is different than below + ! this is needed to have the VOC's be bfb - this needs to be + ! re-examined int he future + ! RGK,2016-08-06: FATES is still incompatible with VOC emission module + ! ------------------------------------------------------------------------------- + + + do s = 1, nsites + + ifp = 0 + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + if(currentpatch%nocomp_pft_label.ne.0)then + ! do not do albedo calculations for bare ground patch in SP mode + ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein + ! ifp=1 is the first vegetated patch. + ifp = ifp+1 + + currentPatch%f_sun (:,:,:) = 0._r8 + currentPatch%fabd_sun_z (:,:,:) = 0._r8 + currentPatch%fabd_sha_z (:,:,:) = 0._r8 + currentPatch%fabi_sun_z (:,:,:) = 0._r8 + currentPatch%fabi_sha_z (:,:,:) = 0._r8 + currentPatch%fabd (:) = 0._r8 + currentPatch%fabi (:) = 0._r8 + + ! zero diagnostic radiation profiles + currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 + + currentPatch%solar_zenith_flag = bc_in(s)%filter_vegzen_pa(ifp) + currentPatch%solar_zenith_angle = bc_in(s)%coszen_pa(ifp) + currentPatch%gnd_alb_dif(1:hlm_numSWb) = bc_in(s)%albgr_dif_rb(1:hlm_numSWb) + currentPatch%gnd_alb_dir(1:hlm_numSWb) = bc_in(s)%albgr_dir_rb(1:hlm_numSWb) + currentPatch%fcansno = bc_in(s)%fcansno_pa(ifp) + + if(currentPatch%solar_zenith_flag )then + + bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%fabd_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM + + if (maxval(currentPatch%nrad(1,:))==0)then + !there are no leaf layers in this patch. it is effectively bare ground. + ! no radiation is absorbed + bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 + bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 + do ib = 1,hlm_numSWb + bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) + bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) + bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 !bc_out(s)%ftid_parb(ifp,ib)= 1.0_r8 bc_out(s)%ftid_parb(ifp,ib)= 0.0_r8 - bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 - enddo - - else - - call PatchNormanRadiation (currentPatch, & - bc_out(s)%albd_parb(ifp,:), & - bc_out(s)%albi_parb(ifp,:), & - bc_out(s)%fabd_parb(ifp,:), & - bc_out(s)%fabi_parb(ifp,:), & - bc_out(s)%ftdd_parb(ifp,:), & - bc_out(s)%ftid_parb(ifp,:), & - bc_out(s)%ftii_parb(ifp,:)) - - - endif ! is there vegetation? - - end if ! if the vegetation and zenith filter is active + bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 + enddo + + else + + call PatchNormanRadiation (currentPatch, & + bc_out(s)%albd_parb(ifp,:), & + bc_out(s)%albi_parb(ifp,:), & + bc_out(s)%fabd_parb(ifp,:), & + bc_out(s)%fabi_parb(ifp,:), & + bc_out(s)%ftdd_parb(ifp,:), & + bc_out(s)%ftid_parb(ifp,:), & + bc_out(s)%ftii_parb(ifp,:)) + + + endif ! is there vegetation? + + end if ! if the vegetation and zenith filter is active endif ! not bare ground - currentPatch => currentPatch%younger - end do ! Loop linked-list patches - enddo ! Loop Sites - - return - end subroutine ED_Norman_Radiation - + currentPatch => currentPatch%younger + end do ! Loop linked-list patches + enddo ! Loop Sites - ! ====================================================================================== + return + end subroutine ED_Norman_Radiation + + + ! ====================================================================================== subroutine PatchNormanRadiation (currentPatch, & - albd_parb_out, & ! (ifp,ib) - albi_parb_out, & ! (ifp,ib) - fabd_parb_out, & ! (ifp,ib) - fabi_parb_out, & ! (ifp,ib) - ftdd_parb_out, & ! (ifp,ib) - ftid_parb_out, & ! (ifp,ib) - ftii_parb_out) ! (ifp,ib) + albd_parb_out, & ! (ifp,ib) + albi_parb_out, & ! (ifp,ib) + fabd_parb_out, & ! (ifp,ib) + fabi_parb_out, & ! (ifp,ib) + ftdd_parb_out, & ! (ifp,ib) + ftid_parb_out, & ! (ifp,ib) + ftii_parb_out) ! (ifp,ib) ! ----------------------------------------------------------------------------------- ! @@ -199,7 +199,7 @@ subroutine PatchNormanRadiation (currentPatch, & ! ----------------------------------------------------------------------------------- ! !ARGUMENTS: ! ----------------------------------------------------------------------------------- - + type(ed_patch_type), intent(inout), target :: currentPatch real(r8), intent(inout) :: albd_parb_out(hlm_numSWb) real(r8), intent(inout) :: albi_parb_out(hlm_numSWb) @@ -249,1021 +249,1021 @@ subroutine PatchNormanRadiation (currentPatch, & real(r8) :: phi2b(maxpft) real(r8) :: laisum ! cumulative lai+sai for canopy layer (at middle of layer) real(r8) :: angle - + real(r8),parameter :: tolerance = 0.000000001_r8 - - + + integer, parameter :: max_diag_nlevleaf = 4 integer, parameter :: diag_nlevleaf = min(nlevleaf,max_diag_nlevleaf) ! for diagnostics, write a small number of leaf layers - + real(r8) :: denom real(r8) :: lai_reduction(nclmax) - + integer :: fp,iv,s ! array indices integer :: ib ! waveband number real(r8) :: cosz ! 0.001 <= coszen <= 1.000 real(r8) :: chil real(r8) :: gdir - + real(r8), parameter :: forc_dir(n_rad_stream_types) = (/ 1.0_r8, 0.0_r8 /) ! These are binary switches used real(r8), parameter :: forc_dif(n_rad_stream_types) = (/ 0.0_r8, 1.0_r8 /) ! to turn off and on radiation streams - + associate(& rhol => EDPftvarcon_inst%rhol , & ! Input: [real(r8) (:) ] leaf reflectance: 1=vis, 2=nir rhos => EDPftvarcon_inst%rhos , & ! Input: [real(r8) (:) ] stem reflectance: 1=vis, 2=nir taul => EDPftvarcon_inst%taul , & ! Input: [real(r8) (:) ] leaf transmittance: 1=vis, 2=nir taus => EDPftvarcon_inst%taus , & ! Input: [real(r8) (:) ] stem transmittance: 1=vis, 2=nir xl => EDPftvarcon_inst%xl , & ! Input: [real(r8) (:) ] ecophys const - leaf/stem orientation index - clumping_index => EDPftvarcon_inst%clumping_index) + clumping_index => EDPftvarcon_inst%clumping_index) ! Initialize local arrays - weighted_dir_tr(:) = 0._r8 - weighted_dif_down(:) = 0._r8 - weighted_dif_up(:) = 0._r8 - - tr_dir_z(:,:,:) = 0._r8 - tr_dif_z(:,:,:) = 0._r8 - lai_change(:,:,:) = 0._r8 - Dif_up(:,:,:) = 0._r8 - Dif_dn(:,:,:) = 0._r8 - refl_dif(:,:,:,:) = 0.0_r8 - tran_dif(:,:,:,:) = 0.0_r8 - dif_ratio(:,:,:,:) = 0.0_r8 - - - ! Initialize the ouput arrays - ! --------------------------------------------------------------------------------- - albd_parb_out(1:hlm_numSWb) = 0.0_r8 - albi_parb_out(1:hlm_numSWb) = 0.0_r8 - fabd_parb_out(1:hlm_numSWb) = 0.0_r8 - fabi_parb_out(1:hlm_numSWb) = 0.0_r8 - ftdd_parb_out(1:hlm_numSWb) = 1.0_r8 - ftid_parb_out(1:hlm_numSWb) = 1.0_r8 - ftii_parb_out(1:hlm_numSWb) = 1.0_r8 - - ! Is this pft/canopy layer combination present in this patch? - rho_layer(:,:,:,:)=0.0_r8 - tau_layer(:,:,:,:)=0.0_r8 - f_abs(:,:,:,:)=0.0_r8 - f_abs_leaf(:,:,:,:)=0._r8 - do L = 1,nclmax - do ft = 1,numpft - currentPatch%canopy_mask(L,ft) = 0 - do iv = 1, currentPatch%nrad(L,ft) - if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then - currentPatch%canopy_mask(L,ft) = 1 - ! layer level reflectance qualities - do ib = 1,hlm_numSWb !vis, nir - if(currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv).gt.0.0_r8) then - frac_lai = currentPatch%elai_profile(L,ft,iv)/& - (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) + weighted_dir_tr(:) = 0._r8 + weighted_dif_down(:) = 0._r8 + weighted_dif_up(:) = 0._r8 + + tr_dir_z(:,:,:) = 0._r8 + tr_dif_z(:,:,:) = 0._r8 + lai_change(:,:,:) = 0._r8 + Dif_up(:,:,:) = 0._r8 + Dif_dn(:,:,:) = 0._r8 + refl_dif(:,:,:,:) = 0.0_r8 + tran_dif(:,:,:,:) = 0.0_r8 + dif_ratio(:,:,:,:) = 0.0_r8 + + + ! Initialize the ouput arrays + ! --------------------------------------------------------------------------------- + albd_parb_out(1:hlm_numSWb) = 0.0_r8 + albi_parb_out(1:hlm_numSWb) = 0.0_r8 + fabd_parb_out(1:hlm_numSWb) = 0.0_r8 + fabi_parb_out(1:hlm_numSWb) = 0.0_r8 + ftdd_parb_out(1:hlm_numSWb) = 1.0_r8 + ftid_parb_out(1:hlm_numSWb) = 1.0_r8 + ftii_parb_out(1:hlm_numSWb) = 1.0_r8 + + ! Is this pft/canopy layer combination present in this patch? + rho_layer(:,:,:,:)=0.0_r8 + tau_layer(:,:,:,:)=0.0_r8 + f_abs(:,:,:,:)=0.0_r8 + f_abs_leaf(:,:,:,:)=0._r8 + do L = 1,nclmax + do ft = 1,numpft + currentPatch%canopy_mask(L,ft) = 0 + do iv = 1, currentPatch%nrad(L,ft) + if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then + currentPatch%canopy_mask(L,ft) = 1 + ! layer level reflectance qualities + do ib = 1,hlm_numSWb !vis, nir + if(currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv).gt.0.0_r8) then + frac_lai = currentPatch%elai_profile(L,ft,iv)/& + (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) + else + frac_lai = 1.0_r8 + endif + !frac_lai = 1.0_r8 ! make the same as previous codebase, in theory. + frac_sai = 1.0_r8 - frac_lai + f_abs(L,ft,iv,ib) = 1.0_r8 - (frac_lai*(rhol(ft,ib) + taul(ft,ib))+& + frac_sai*(rhos(ft,ib) + taus(ft,ib))) + f_abs_leaf(L,ft,iv,ib) = frac_lai*(1.0_r8 - rhol(ft,ib) - taul(ft,ib))/f_abs(L,ft,iv,ib) + + rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) + tau_layer(L,ft,iv,ib)=frac_lai*taul(ft,ib)+frac_sai*taus(ft,ib) + + ! adjust reflectance and transmittance for canopy snow + rho_layer(L,ft,iv,ib)=rho_layer(L,ft,iv,ib)*(1.0_r8- currentPatch%fcansno) & + + rho_snow(ib) * currentPatch%fcansno + tau_layer(L,ft,iv,ib)=tau_layer(L,ft,iv,ib)*(1.0_r8- currentPatch%fcansno) & + + tau_snow(ib) * currentPatch%fcansno + end do !ib + endif + end do !iv + end do !ft + end do !L + + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Direct beam extinction coefficient, k_dir. PFT specific. + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + cosz = max(0.001_r8, currentPatch%solar_zenith_angle ) !copied from previous radiation code... + do ft = 1,numpft + sb = (90._r8 - (acos(cosz)*180._r8/pi_const)) * (pi_const / 180._r8) + chil = xl(ft) !min(max(xl(ft), -0.4_r8), 0.6_r8 ) + if ( abs(chil) <= 0.01_r8) then + chil = 0.01_r8 + end if + phi1b(ft) = 0.5_r8 - 0.633_r8*chil - 0.330_r8*chil*chil + phi2b(ft) = 0.877_r8 * (1._r8 - 2._r8*phi1b(ft)) !0 = horiz leaves, 1 - vert leaves. + gdir = phi1b(ft) + phi2b(ft) * sin(sb) + !how much direct light penetrates a singleunit of lai? + k_dir(ft) = clumping_index(ft) * gdir / sin(sb) + end do !FT + + + + + !do this once for one unit of diffuse, and once for one unit of direct radiation + do radtype = 1, n_rad_stream_types + + ! Extract information that needs to be provided by ED into local array. + ! RGK: NOT SURE WHY WE NEED FTWEIGHT ... + ! ------------------------------------------------------------------------------ + + ftweight(:,:,:) = 0._r8 + do L = 1,currentPatch%NCL_p + do ft = 1,numpft + do iv = 1, currentPatch%nrad(L,ft) + !this is already corrected for area in CLAP + ftweight(L,ft,iv) = currentPatch%canopy_area_profile(L,ft,iv) + end do !iv + end do !ft1 + end do !L + if (sum(ftweight(1,:,1))<0.999_r8)then + write(fates_log(),*) 'canopy not full',ftweight(1,:,1) + endif + if (sum(ftweight(1,:,1))>1.0001_r8)then + write(fates_log(),*) 'canopy too full',ftweight(1,:,1) + endif + + do L = 1,currentPatch%NCL_p !start at the top canopy layer (1 is the top layer.) + + weighted_dir_tr(L) = 0.0_r8 + weighted_fsun(L) = 0._r8 + weighted_dif_ratio(L,1:hlm_numSWb) = 0._r8 + + !Each canopy layer (canopy, understorey) has multiple 'parallel' pft's + + do ft =1,numpft + + if (currentPatch%canopy_mask(L,ft) == 1)then !only do calculation if there are the appropriate leaves. + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Diffuse transmittance, tr_dif, do each layer with thickness elai_z. + ! Estimated do nine sky angles in increments of 10 degrees + ! PFT specific... + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + tr_dif_z(L,ft,:) = 0._r8 + do iv = 1,currentPatch%nrad(L,ft) + do j = 1,9 + angle = (5._r8 + real(j - 1,r8) * 10._r8) * pi_const / 180._r8 + gdir = phi1b(ft) + phi2b(ft) * sin(angle) + tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-clumping_index(ft) * & + gdir / sin(angle) * & + (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))) * & + sin(angle)*cos(angle) + end do + + tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) * 2._r8 * (10._r8 * pi_const / 180._r8) + + end do + + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Direct beam transmittance, tr_dir_z, uses cumulative LAI above layer J to give + ! unscattered direct beam onto layer J. do each PFT section. + ! This is just an decay curve based on k_dir. (leaf & sun angle) + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + if (L==1)then + tr_dir_z(L,ft,1) = 1._r8 + else + tr_dir_z(L,ft,1) = weighted_dir_tr(L-1) + endif + laisum = 0.00_r8 + !total direct beam getting to the bottom of the top canopy. + do iv = 1,currentPatch%nrad(L,ft) + laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) + lai_change(L,ft,iv) = 0.0_r8 + if (( ftweight(L,ft,iv+1) > 0.0_r8 ) .and. ( ftweight(L,ft,iv+1) < ftweight(L,ft,iv) ))then + !where there is a partly empty leaf layer, some fluxes go straight through. + lai_change(L,ft,iv) = ftweight(L,ft,iv)-ftweight(L,ft,iv+1) + endif + if (ftweight(L,ft,iv+1) - ftweight(L,ft,iv) > 1.e-10_r8)then + write(fates_log(),*) 'lower layer has more coverage. This is wrong' , & + ftweight(L,ft,iv),ftweight(L,ft,iv+1),ftweight(L,ft,iv+1)-ftweight(L,ft,iv) + endif + + !n.b. in theory lai_change could be calculated daily in the ED code. + !This is light coming striaght through the canopy. + if (L==1)then + tr_dir_z(L,ft,iv+1) = exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + else + tr_dir_z(L,ft,iv+1) = weighted_dir_tr(L-1)*exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + endif + + if (iv == 1)then + !this is the top layer. + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & + ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) + else + !the lai_change(iv) affects the light incident on layer iv+2 not iv+1 + ! light coming from the layer above (iv-1) goes through iv and onto iv+1. + if (lai_change(L,ft,iv-1) > 0.0_r8)then + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv)* & + lai_change(L,ft,iv-1) / ftweight(L,ft,1) + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv-1)* & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) + else + !account fot the light that comes striaght down from unfilled layers above. + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & + ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) + endif + endif + + end do + + !add up all the weighted contributions from the different PFT columns. + weighted_dir_tr(L) = weighted_dir_tr(L) + tr_dir_z(L,ft,currentPatch%nrad(L,ft)+1)*ftweight(L,ft,1) + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Sunlit and shaded fraction of leaf layer + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + + !laisum = 0._r8 + do iv = 1,currentPatch%nrad(L,ft) + ! Cumulative leaf area. Original code uses cumulative lai do layer. + ! Now use cumulative lai at center of layer. + ! Same as tr_dir_z calcualtions, but in the middle of the layer? FIX(RF,032414)-WHY? + if (iv == 1) then + laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) + else + laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) + end if + + + if (L == 1)then !top canopy layer + currentPatch%f_sun(L,ft,iv) = exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + else + currentPatch%f_sun(L,ft,iv) = weighted_fsun(L-1)* exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + endif + + if ( iv > 1 ) then ! becasue we are looking at this layer (not the next) + ! we only ever add fluxes if iv>1 + if (lai_change(L,ft,iv-1) > 0.0_r8)then + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv) * & + lai_change(L,ft,iv-1)/ftweight(L,ft,1) + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv-1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) + else + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv-1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + endif + + end do !iv + + weighted_fsun(L) = weighted_fsun(L) + currentPatch%f_sun(L,ft,currentPatch%nrad(L,ft))* & + ftweight(L,ft,1) + + ! instance where the first layer ftweight is used a proxy for the whole column. FTWA + ! this is possibly a source of slight error. If we use the ftweight at the top of the PFT column, + ! then we willl underestimate fsun, but if we use ftweight at the bottom of the column, we will + ! underestimate it. Really, we should be tracking the release of direct light from the column as it tapers + ! towards the ground. Is that necessary to get energy closure? It would be quite hard... + endif !present. + end do!pft loop + end do !L + + + do L = currentPatch%NCL_p,1, -1 !start at the bottom and work up. + do ft = 1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + + !==============================================================================! + ! Iterative solution do scattering + !==============================================================================! + + do ib = 1,hlm_numSWb !vis, nir + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Leaf scattering coefficient and terms do diffuse radiation reflected + ! and transmitted by a layer + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + + do iv = 1,currentPatch%nrad(L,ft) + !How much diffuse light is intercepted and then reflected? + refl_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * rho_layer(L,ft,iv,ib) + !How much diffuse light in this layer is transmitted? + tran_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * & + tau_layer(L,ft,iv,ib) + tr_dif_z(L,ft,iv) + end do + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Ratio of upward to forward diffuse fluxes, dif_ratio + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Soil diffuse reflectance (ratio of down to up radiation). + iv = currentPatch%nrad(L,ft) + 1 + if (L == currentPatch%NCL_p)then !nearest the soil + dif_ratio(L,ft,iv,ib) = currentPatch%gnd_alb_dif(ib) !bc_in(s)%albgr_dif_rb(ib) + else + dif_ratio(L,ft,iv,ib) = weighted_dif_ratio(L+1,ib) + end if + ! Canopy layers, working upwardfrom soil with dif_ratio(iv+1) known + ! FIX(RF,032414) ray tracing eqution - need to find derivation of this... + ! for each unit going down, there are x units going up. + do iv = currentPatch%nrad(L,ft),1, -1 + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv+1,ib) * & + tran_dif(L,ft,iv,ib)*tran_dif(L,ft,iv,ib) / & + (1._r8 - dif_ratio(L,ft,iv+1,ib) * refl_dif(L,ft,iv,ib)) & + + refl_dif(L,ft,iv,ib) + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) * & + ftweight(L,ft,iv)/ftweight(L,ft,1) + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) + dif_ratio(L,ft,iv+1,ib) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + end do + weighted_dif_ratio(L,ib) = weighted_dif_ratio(L,ib) + & + dif_ratio(L,ft,1,ib) * ftweight(L,ft,1) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + end do!hlm_numSWb + endif ! currentPatch%canopy_mask + end do!ft + end do!L + currentPatch%radiation_error = 0.0_r8 + do ib = 1,hlm_numSWb + Dif_dn(:,:,:) = 0.00_r8 + Dif_up(:,:,:) = 0.00_r8 + do L = 1, currentPatch%NCL_p !work down from the top of the canopy. + weighted_dif_down(L) = 0._r8 + do ft = 1, numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! First estimates do downward and upward diffuse flux + ! + ! Dif_dn = forward diffuse flux onto layer J + ! Dif_up = Upward diffuse flux above layer J + ! + ! Solved here without direct beam radiation and using dif_ratio = Dif_up / Dif_dn + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! downward diffuse flux onto the top surface of the canopy + + if (L == 1)then + Dif_dn(L,ft,1) = forc_dif(radtype) + else + Dif_dn(L,ft,1) = weighted_dif_down(L-1) + end if + ! forward diffuse flux within the canopy and at soil, working forward through canopy + do iv = 1,currentPatch%nrad(L,ft) + denom = refl_dif(L,ft,iv,ib) * dif_ratio(L,ft,iv,ib) + denom = 1._r8 - denom + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) / & + denom *ftweight(L,ft,iv)/ftweight(L,ft,1) + if (iv > 1)then + if (lai_change(L,ft,iv-1) > 0.0_r8)then + !here we are thinking about whether the layer above had an laichange, + !but calculating the flux onto the layer below. + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv)* & + lai_change(L,ft,iv-1)/ftweight(L,ft,1) + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv-1)* & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1)/ftweight(L,ft,1)) + else + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif else - frac_lai = 1.0_r8 + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) endif - !frac_lai = 1.0_r8 ! make the same as previous codebase, in theory. - frac_sai = 1.0_r8 - frac_lai - f_abs(L,ft,iv,ib) = 1.0_r8 - (frac_lai*(rhol(ft,ib) + taul(ft,ib))+& - frac_sai*(rhos(ft,ib) + taus(ft,ib))) - f_abs_leaf(L,ft,iv,ib) = frac_lai*(1.0_r8 - rhol(ft,ib) - taul(ft,ib))/f_abs(L,ft,iv,ib) - - rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) - tau_layer(L,ft,iv,ib)=frac_lai*taul(ft,ib)+frac_sai*taus(ft,ib) - - ! adjust reflectance and transmittance for canopy snow - rho_layer(L,ft,iv,ib)=rho_layer(L,ft,iv,ib)*(1.0_r8- currentPatch%fcansno) & - + rho_snow(ib) * currentPatch%fcansno - tau_layer(L,ft,iv,ib)=tau_layer(L,ft,iv,ib)*(1.0_r8- currentPatch%fcansno) & - + tau_snow(ib) * currentPatch%fcansno - end do !ib - endif - end do !iv - end do !ft - end do !L - - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Direct beam extinction coefficient, k_dir. PFT specific. - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - cosz = max(0.001_r8, currentPatch%solar_zenith_angle ) !copied from previous radiation code... - do ft = 1,numpft - sb = (90._r8 - (acos(cosz)*180._r8/pi_const)) * (pi_const / 180._r8) - chil = xl(ft) !min(max(xl(ft), -0.4_r8), 0.6_r8 ) - if ( abs(chil) <= 0.01_r8) then - chil = 0.01_r8 - end if - phi1b(ft) = 0.5_r8 - 0.633_r8*chil - 0.330_r8*chil*chil - phi2b(ft) = 0.877_r8 * (1._r8 - 2._r8*phi1b(ft)) !0 = horiz leaves, 1 - vert leaves. - gdir = phi1b(ft) + phi2b(ft) * sin(sb) - !how much direct light penetrates a singleunit of lai? - k_dir(ft) = clumping_index(ft) * gdir / sin(sb) - end do !FT - - - - - !do this once for one unit of diffuse, and once for one unit of direct radiation - do radtype = 1, n_rad_stream_types - - ! Extract information that needs to be provided by ED into local array. - ! RGK: NOT SURE WHY WE NEED FTWEIGHT ... - ! ------------------------------------------------------------------------------ - - ftweight(:,:,:) = 0._r8 - do L = 1,currentPatch%NCL_p - do ft = 1,numpft - do iv = 1, currentPatch%nrad(L,ft) - !this is already corrected for area in CLAP - ftweight(L,ft,iv) = currentPatch%canopy_area_profile(L,ft,iv) - end do !iv - end do !ft1 - end do !L - if (sum(ftweight(1,:,1))<0.999_r8)then - write(fates_log(),*) 'canopy not full',ftweight(1,:,1) - endif - if (sum(ftweight(1,:,1))>1.0001_r8)then - write(fates_log(),*) 'canopy too full',ftweight(1,:,1) - endif - - do L = 1,currentPatch%NCL_p !start at the top canopy layer (1 is the top layer.) - - weighted_dir_tr(L) = 0.0_r8 - weighted_fsun(L) = 0._r8 - weighted_dif_ratio(L,1:hlm_numSWb) = 0._r8 - - !Each canopy layer (canopy, understorey) has multiple 'parallel' pft's - - do ft =1,numpft - - if (currentPatch%canopy_mask(L,ft) == 1)then !only do calculation if there are the appropriate leaves. - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Diffuse transmittance, tr_dif, do each layer with thickness elai_z. - ! Estimated do nine sky angles in increments of 10 degrees - ! PFT specific... - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - tr_dif_z(L,ft,:) = 0._r8 - do iv = 1,currentPatch%nrad(L,ft) - do j = 1,9 - angle = (5._r8 + real(j - 1,r8) * 10._r8) * pi_const / 180._r8 - gdir = phi1b(ft) + phi2b(ft) * sin(angle) - tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-clumping_index(ft) * & - gdir / sin(angle) * & - (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))) * & - sin(angle)*cos(angle) - end do - - tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) * 2._r8 * (10._r8 * pi_const / 180._r8) - - end do - - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Direct beam transmittance, tr_dir_z, uses cumulative LAI above layer J to give - ! unscattered direct beam onto layer J. do each PFT section. - ! This is just an decay curve based on k_dir. (leaf & sun angle) - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - if (L==1)then - tr_dir_z(L,ft,1) = 1._r8 - else - tr_dir_z(L,ft,1) = weighted_dir_tr(L-1) - endif - laisum = 0.00_r8 - !total direct beam getting to the bottom of the top canopy. - do iv = 1,currentPatch%nrad(L,ft) - laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) - lai_change(L,ft,iv) = 0.0_r8 - if (( ftweight(L,ft,iv+1) > 0.0_r8 ) .and. ( ftweight(L,ft,iv+1) < ftweight(L,ft,iv) ))then - !where there is a partly empty leaf layer, some fluxes go straight through. - lai_change(L,ft,iv) = ftweight(L,ft,iv)-ftweight(L,ft,iv+1) - endif - if (ftweight(L,ft,iv+1) - ftweight(L,ft,iv) > 1.e-10_r8)then - write(fates_log(),*) 'lower layer has more coverage. This is wrong' , & - ftweight(L,ft,iv),ftweight(L,ft,iv+1),ftweight(L,ft,iv+1)-ftweight(L,ft,iv) - endif - - !n.b. in theory lai_change could be calculated daily in the ED code. - !This is light coming striaght through the canopy. - if (L==1)then - tr_dir_z(L,ft,iv+1) = exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - else - tr_dir_z(L,ft,iv+1) = weighted_dir_tr(L-1)*exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - endif - - if (iv == 1)then - !this is the top layer. - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & - ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) - else - !the lai_change(iv) affects the light incident on layer iv+2 not iv+1 - ! light coming from the layer above (iv-1) goes through iv and onto iv+1. - if (lai_change(L,ft,iv-1) > 0.0_r8)then - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv)* & - lai_change(L,ft,iv-1) / ftweight(L,ft,1) - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv-1)* & - (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) - else - !account fot the light that comes striaght down from unfilled layers above. - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & - ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) - endif - endif - - end do - - !add up all the weighted contributions from the different PFT columns. - weighted_dir_tr(L) = weighted_dir_tr(L) + tr_dir_z(L,ft,currentPatch%nrad(L,ft)+1)*ftweight(L,ft,1) - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Sunlit and shaded fraction of leaf layer - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - - !laisum = 0._r8 - do iv = 1,currentPatch%nrad(L,ft) - ! Cumulative leaf area. Original code uses cumulative lai do layer. - ! Now use cumulative lai at center of layer. - ! Same as tr_dir_z calcualtions, but in the middle of the layer? FIX(RF,032414)-WHY? - if (iv == 1) then - laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) - else - laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) - end if - - - if (L == 1)then !top canopy layer - currentPatch%f_sun(L,ft,iv) = exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - else - currentPatch%f_sun(L,ft,iv) = weighted_fsun(L-1)* exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - endif - - if ( iv > 1 ) then ! becasue we are looking at this layer (not the next) - ! we only ever add fluxes if iv>1 - if (lai_change(L,ft,iv-1) > 0.0_r8)then - currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & - currentPatch%f_sun(L,ft,iv) * & - lai_change(L,ft,iv-1)/ftweight(L,ft,1) - currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & - currentPatch%f_sun(L,ft,iv-1) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) - else - currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & - currentPatch%f_sun(L,ft,iv-1) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - endif - endif - - end do !iv - - weighted_fsun(L) = weighted_fsun(L) + currentPatch%f_sun(L,ft,currentPatch%nrad(L,ft))* & - ftweight(L,ft,1) - - ! instance where the first layer ftweight is used a proxy for the whole column. FTWA - ! this is possibly a source of slight error. If we use the ftweight at the top of the PFT column, - ! then we willl underestimate fsun, but if we use ftweight at the bottom of the column, we will - ! underestimate it. Really, we should be tracking the release of direct light from the column as it tapers - ! towards the ground. Is that necessary to get energy closure? It would be quite hard... - endif !present. - end do!pft loop - end do !L - - - do L = currentPatch%NCL_p,1, -1 !start at the bottom and work up. - do ft = 1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - - !==============================================================================! - ! Iterative solution do scattering - !==============================================================================! - - do ib = 1,hlm_numSWb !vis, nir - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Leaf scattering coefficient and terms do diffuse radiation reflected - ! and transmitted by a layer - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - - do iv = 1,currentPatch%nrad(L,ft) - !How much diffuse light is intercepted and then reflected? - refl_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * rho_layer(L,ft,iv,ib) - !How much diffuse light in this layer is transmitted? - tran_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * & - tau_layer(L,ft,iv,ib) + tr_dif_z(L,ft,iv) - end do - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Ratio of upward to forward diffuse fluxes, dif_ratio - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Soil diffuse reflectance (ratio of down to up radiation). - iv = currentPatch%nrad(L,ft) + 1 - if (L == currentPatch%NCL_p)then !nearest the soil - dif_ratio(L,ft,iv,ib) = currentPatch%gnd_alb_dif(ib) !bc_in(s)%albgr_dif_rb(ib) - else - dif_ratio(L,ft,iv,ib) = weighted_dif_ratio(L+1,ib) - end if - ! Canopy layers, working upwardfrom soil with dif_ratio(iv+1) known - ! FIX(RF,032414) ray tracing eqution - need to find derivation of this... - ! for each unit going down, there are x units going up. - do iv = currentPatch%nrad(L,ft),1, -1 - dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv+1,ib) * & - tran_dif(L,ft,iv,ib)*tran_dif(L,ft,iv,ib) / & - (1._r8 - dif_ratio(L,ft,iv+1,ib) * refl_dif(L,ft,iv,ib)) & - + refl_dif(L,ft,iv,ib) - dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) * & - ftweight(L,ft,iv)/ftweight(L,ft,1) - dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) + dif_ratio(L,ft,iv+1,ib) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - end do - weighted_dif_ratio(L,ib) = weighted_dif_ratio(L,ib) + & - dif_ratio(L,ft,1,ib) * ftweight(L,ft,1) - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - end do!hlm_numSWb - endif ! currentPatch%canopy_mask - end do!ft - end do!L - currentPatch%radiation_error = 0.0_r8 - do ib = 1,hlm_numSWb - Dif_dn(:,:,:) = 0.00_r8 - Dif_up(:,:,:) = 0.00_r8 - do L = 1, currentPatch%NCL_p !work down from the top of the canopy. - weighted_dif_down(L) = 0._r8 - do ft = 1, numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! First estimates do downward and upward diffuse flux - ! - ! Dif_dn = forward diffuse flux onto layer J - ! Dif_up = Upward diffuse flux above layer J - ! - ! Solved here without direct beam radiation and using dif_ratio = Dif_up / Dif_dn - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! downward diffuse flux onto the top surface of the canopy - - if (L == 1)then - Dif_dn(L,ft,1) = forc_dif(radtype) - else - Dif_dn(L,ft,1) = weighted_dif_down(L-1) - end if - ! forward diffuse flux within the canopy and at soil, working forward through canopy - do iv = 1,currentPatch%nrad(L,ft) - denom = refl_dif(L,ft,iv,ib) * dif_ratio(L,ft,iv,ib) - denom = 1._r8 - denom - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) / & - denom *ftweight(L,ft,iv)/ftweight(L,ft,1) - if (iv > 1)then - if (lai_change(L,ft,iv-1) > 0.0_r8)then - !here we are thinking about whether the layer above had an laichange, - !but calculating the flux onto the layer below. - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv)* & - lai_change(L,ft,iv-1)/ftweight(L,ft,1) - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv-1)* & - (ftweight(L,ft,1)-ftweight(L,ft,iv-1)/ftweight(L,ft,1)) - else - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - endif - else - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - endif - end do - - weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & - ftweight(L,ft,1) - - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - endif !present - end do !ft - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is the the (incomplete) understorey? - !Add on the radiation going through the canopy gaps. - weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1)*(1.0-sum(ftweight(L,:,1))) - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - endif - end do !L - - do L = currentPatch%NCL_p,1 ,-1 !work up from the bottom. - weighted_dif_up(L) = 0._r8 - do ft = 1, numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - !Bounce diffuse radiation off soil surface. - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%NCL_p)then !is this the bottom layer ? - Dif_up(L,ft,iv) = currentPatch%gnd_alb_dif(ib) * Dif_dn(L,ft,iv) - else - Dif_up(L,ft,iv) = weighted_dif_up(L+1) - end if - ! Upward diffuse flux within the canopy and above the canopy, working upward through canopy - - do iv = currentPatch%nrad(L,ft), 1, -1 - if (lai_change(L,ft,iv) > 0.0_r8)then - Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * & - ftweight(L,ft,iv) / ftweight(L,ft,1) - Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & - tran_dif(L,ft,iv,ib) * lai_change(L,ft,iv)/ftweight(L,ft,1) - Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - !nb is this the right constuction? - ! the radiation that hits the empty space is not reflected. - else - Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * ftweight(L,ft,iv) - Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * (1.0_r8-ftweight(L,ft,iv)) - endif - end do - - weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - endif !present - end do !ft - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? - !Add on the radiation coming up through the canopy gaps. - !diffuse to diffuse - weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & - weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) - !direct to diffuse - weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & - weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) * currentPatch%gnd_alb_dir(ib) - endif - end do !L - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! 3. Iterative calculation of forward and upward diffuse fluxes, iNCL_puding - ! scattered direct beam - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - - ! Flag to exit iteration loop: 0 = exit and 1 = iterate - irep = 1 - ! Iteration loop - iter = 0 - do while(irep ==1 .and. iter<50) - - iter = iter + 1 - irep = 0 - do L = 1,currentPatch%NCL_p !working from the top down - weighted_dif_down(L) = 0._r8 - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - ! forward diffuse flux within the canopy and at soil, working forward through canopy - ! with Dif_up -from previous iteration-. Dif_dn(1) is the forward diffuse flux onto the canopy. - ! Note: down = forward flux onto next layer - if (L == 1)then !is this the top layer? - Dif_dn(L,ft,1) = forc_dif(radtype) - else - Dif_dn(L,ft,1) = weighted_dif_down(L-1) - end if - down_rad = 0._r8 - - do iv = 1, currentPatch%nrad(L,ft) - ! down rad'n is the sum of the down and upwards reflected diffuse fluxes... - down_rad = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) + & + end do + + weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & + ftweight(L,ft,1) + + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif !present + end do !ft + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is the the (incomplete) understorey? + !Add on the radiation going through the canopy gaps. + weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1)*(1.0-sum(ftweight(L,:,1))) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif + end do !L + + do L = currentPatch%NCL_p,1 ,-1 !work up from the bottom. + weighted_dif_up(L) = 0._r8 + do ft = 1, numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + !Bounce diffuse radiation off soil surface. + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then !is this the bottom layer ? + Dif_up(L,ft,iv) = currentPatch%gnd_alb_dif(ib) * Dif_dn(L,ft,iv) + else + Dif_up(L,ft,iv) = weighted_dif_up(L+1) + end if + ! Upward diffuse flux within the canopy and above the canopy, working upward through canopy + + do iv = currentPatch%nrad(L,ft), 1, -1 + if (lai_change(L,ft,iv) > 0.0_r8)then + Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * & + ftweight(L,ft,iv) / ftweight(L,ft,1) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & + tran_dif(L,ft,iv,ib) * lai_change(L,ft,iv)/ftweight(L,ft,1) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + !nb is this the right constuction? + ! the radiation that hits the empty space is not reflected. + else + Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * ftweight(L,ft,iv) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * (1.0_r8-ftweight(L,ft,iv)) + endif + end do + + weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif !present + end do !ft + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? + !Add on the radiation coming up through the canopy gaps. + !diffuse to diffuse + weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & + weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) + !direct to diffuse + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & + weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) * currentPatch%gnd_alb_dir(ib) + endif + end do !L + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! 3. Iterative calculation of forward and upward diffuse fluxes, iNCL_puding + ! scattered direct beam + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + + ! Flag to exit iteration loop: 0 = exit and 1 = iterate + irep = 1 + ! Iteration loop + iter = 0 + do while(irep ==1 .and. iter<50) + + iter = iter + 1 + irep = 0 + do L = 1,currentPatch%NCL_p !working from the top down + weighted_dif_down(L) = 0._r8 + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + ! forward diffuse flux within the canopy and at soil, working forward through canopy + ! with Dif_up -from previous iteration-. Dif_dn(1) is the forward diffuse flux onto the canopy. + ! Note: down = forward flux onto next layer + if (L == 1)then !is this the top layer? + Dif_dn(L,ft,1) = forc_dif(radtype) + else + Dif_dn(L,ft,1) = weighted_dif_down(L-1) + end if + down_rad = 0._r8 + + do iv = 1, currentPatch%nrad(L,ft) + ! down rad'n is the sum of the down and upwards reflected diffuse fluxes... + down_rad = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) + & Dif_up(L,ft,iv+1) * refl_dif(L,ft,iv,ib) - !... plus the direct beam intercepted and intransmitted by this layer. - down_rad = down_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - & + !... plus the direct beam intercepted and intransmitted by this layer. + down_rad = down_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - & exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & currentPatch%esai_profile(L,ft,iv)) )) * tau_layer(L,ft,iv,ib) - !... plus the direct beam intercepted and intransmitted by this layer. - ! modified to spread it out over the whole of incomplete layers. - - down_rad = down_rad *(ftweight(L,ft,iv)/ftweight(L,ft,1)) - - if (iv > 1)then - if (lai_change(L,ft,iv-1) > 0.0_r8)then - down_rad = down_rad + Dif_dn(L,ft,iv) * lai_change(L,ft,iv-1)/ftweight(L,ft,1) - down_rad = down_rad + Dif_dn(L,ft,iv-1) * (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ & - ftweight(L,ft,1) - else - down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & - ftweight(L,ft,1) - endif - else - down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & - ftweight(L,ft,1) - endif - - !this is just Dif down, plus refl up, plus dir intercepted and turned into dif... , - if (abs(down_rad - Dif_dn(L,ft,iv+1)) > tolerance)then - irep = 1 - end if - Dif_dn(L,ft,iv+1) = down_rad - - end do !iv - - weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & - ftweight(L,ft,1) - - endif !present - end do!ft - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? - weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1) * & - (1.0_r8-sum(ftweight(L,1:numpft,1))) - end if - end do ! do L loop - - do L = 1, currentPatch%NCL_p ! working from the top down. - weighted_dif_up(L) = 0._r8 - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - ! Upward diffuse flux at soil or from lower canopy (forward diffuse and unscattered direct beam) - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%NCL_p)then !In the bottom canopy layer, reflect off the soil - Dif_up(L,ft,iv) = Dif_dn(L,ft,iv) * currentPatch%gnd_alb_dif(ib) + & - forc_dir(radtype) * tr_dir_z(L,ft,iv) * currentPatch%gnd_alb_dir(ib) - else !In the other canopy layers, reflect off the underlying vegetation. - Dif_up(L,ft,iv) = weighted_dif_up(L+1) - end if - - ! Upward diffuse flux within and above the canopy, working upward through canopy - ! with Dif_dn from previous interation. Note: up = upward flux above current layer - do iv = currentPatch%nrad(L,ft),1,-1 - !this is radiation up, by layer transmittance, by - - !reflection of the lower layer, - up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) - up_rad = up_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - exp(-k_dir(ft) * & - (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))))* & - rho_layer(L,ft,iv,ib) - up_rad = up_rad + Dif_up(L,ft,iv+1) * tran_dif(L,ft,iv,ib) - up_rad = up_rad * ftweight(L,ft,iv)/ftweight(L,ft,1) - up_rad = up_rad + Dif_up(L,ft,iv+1) *(ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - ! THE LOWER LAYER FLUX IS HOMOGENIZED, SO WE DON"T CONSIDER THE LAI_CHANGE HERE... - - if (abs(up_rad - Dif_up(L,ft,iv)) > tolerance) then !are we close to the tolerance level? - irep = 1 - end if - Dif_up(L,ft,iv) = up_rad - - end do !iv - weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) - end if !present - end do!ft - - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? - !Add on the radiation coming up through the canopy gaps. - weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & - weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) - weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & - weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1)))*currentPatch%gnd_alb_dir(ib) - end if - end do!L - end do ! do while over iter - - abs_rad(ib) = 0._r8 - tr_soili = 0._r8 - tr_soild = 0._r8 - - do L = 1, currentPatch%NCL_p !working from the top down. - abs_dir_z(:,:) = 0._r8 - abs_dif_z(:,:) = 0._r8 - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - !==============================================================================! - ! Compute absorbed flux densities - !==============================================================================! - - ! Absorbed direct beam and diffuse do leaf layers - do iv = 1, currentPatch%nrad(L,ft) - Abs_dir_z(ft,iv) = ftweight(L,ft,iv)* forc_dir(radtype) * tr_dir_z(L,ft,iv) * & + !... plus the direct beam intercepted and intransmitted by this layer. + ! modified to spread it out over the whole of incomplete layers. + + down_rad = down_rad *(ftweight(L,ft,iv)/ftweight(L,ft,1)) + + if (iv > 1)then + if (lai_change(L,ft,iv-1) > 0.0_r8)then + down_rad = down_rad + Dif_dn(L,ft,iv) * lai_change(L,ft,iv-1)/ftweight(L,ft,1) + down_rad = down_rad + Dif_dn(L,ft,iv-1) * (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ & + ftweight(L,ft,1) + else + down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & + ftweight(L,ft,1) + endif + else + down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & + ftweight(L,ft,1) + endif + + !this is just Dif down, plus refl up, plus dir intercepted and turned into dif... , + if (abs(down_rad - Dif_dn(L,ft,iv+1)) > tolerance)then + irep = 1 + end if + Dif_dn(L,ft,iv+1) = down_rad + + end do !iv + + weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & + ftweight(L,ft,1) + + endif !present + end do!ft + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? + weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1) * & + (1.0_r8-sum(ftweight(L,1:numpft,1))) + end if + end do ! do L loop + + do L = 1, currentPatch%NCL_p ! working from the top down. + weighted_dif_up(L) = 0._r8 + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + ! Upward diffuse flux at soil or from lower canopy (forward diffuse and unscattered direct beam) + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then !In the bottom canopy layer, reflect off the soil + Dif_up(L,ft,iv) = Dif_dn(L,ft,iv) * currentPatch%gnd_alb_dif(ib) + & + forc_dir(radtype) * tr_dir_z(L,ft,iv) * currentPatch%gnd_alb_dir(ib) + else !In the other canopy layers, reflect off the underlying vegetation. + Dif_up(L,ft,iv) = weighted_dif_up(L+1) + end if + + ! Upward diffuse flux within and above the canopy, working upward through canopy + ! with Dif_dn from previous interation. Note: up = upward flux above current layer + do iv = currentPatch%nrad(L,ft),1,-1 + !this is radiation up, by layer transmittance, by + + !reflection of the lower layer, + up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) + up_rad = up_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - exp(-k_dir(ft) * & + (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))))* & + rho_layer(L,ft,iv,ib) + up_rad = up_rad + Dif_up(L,ft,iv+1) * tran_dif(L,ft,iv,ib) + up_rad = up_rad * ftweight(L,ft,iv)/ftweight(L,ft,1) + up_rad = up_rad + Dif_up(L,ft,iv+1) *(ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + ! THE LOWER LAYER FLUX IS HOMOGENIZED, SO WE DON"T CONSIDER THE LAI_CHANGE HERE... + + if (abs(up_rad - Dif_up(L,ft,iv)) > tolerance) then !are we close to the tolerance level? + irep = 1 + end if + Dif_up(L,ft,iv) = up_rad + + end do !iv + weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) + end if !present + end do!ft + + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? + !Add on the radiation coming up through the canopy gaps. + weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & + weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & + weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1)))*currentPatch%gnd_alb_dir(ib) + end if + end do!L + end do ! do while over iter + + abs_rad(ib) = 0._r8 + tr_soili = 0._r8 + tr_soild = 0._r8 + + do L = 1, currentPatch%NCL_p !working from the top down. + abs_dir_z(:,:) = 0._r8 + abs_dif_z(:,:) = 0._r8 + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + !==============================================================================! + ! Compute absorbed flux densities + !==============================================================================! + + ! Absorbed direct beam and diffuse do leaf layers + do iv = 1, currentPatch%nrad(L,ft) + Abs_dir_z(ft,iv) = ftweight(L,ft,iv)* forc_dir(radtype) * tr_dir_z(L,ft,iv) * & (1.00_r8 - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & - currentPatch%esai_profile(L,ft,iv)) )) * f_abs(L,ft,iv,ib) - Abs_dif_z(ft,iv) = ftweight(L,ft,iv)* ((Dif_dn(L,ft,iv) + & + currentPatch%esai_profile(L,ft,iv)) )) * f_abs(L,ft,iv,ib) + Abs_dif_z(ft,iv) = ftweight(L,ft,iv)* ((Dif_dn(L,ft,iv) + & Dif_up(L,ft,iv+1)) * (1.00_r8 - tr_dif_z(L,ft,iv)) * f_abs(L,ft,iv,ib)) - end do - - ! Absorbed direct beam and diffuse do soil - if (L == currentPatch%NCL_p)then - iv = currentPatch%nrad(L,ft) + 1 - Abs_dif_z(ft,iv) = ftweight(L,ft,1)*Dif_dn(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dif(ib) ) - Abs_dir_z(ft,iv) = ftweight(L,ft,1)*forc_dir(radtype) * & - tr_dir_z(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dir(ib) ) - tr_soild = tr_soild + ftweight(L,ft,1)*forc_dir(radtype) * tr_dir_z(L,ft,iv) - tr_soili = tr_soili + ftweight(L,ft,1)*Dif_dn(L,ft,iv) - end if - - ! Absorbed radiation, shaded and sunlit portions of leaf layers - !here we get one unit of diffuse radiation... how much of - !it is absorbed? - if (ib == ivis) then ! only set the absorbed PAR for the visible light band. - do iv = 1, currentPatch%nrad(L,ft) - if (radtype==idirect) then - if ( debug ) then - write(fates_log(),*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) - write(fates_log(),*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & - currentPatch%fabd_sun_z(L,ft,iv) - endif - currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - (1._r8 - currentPatch%f_sun(L,ft,iv))*f_abs_leaf(L,ft,iv,ib) - currentPatch%fabd_sun_z(L,ft,iv) =( Abs_dif_z(ft,iv) * & - currentPatch%f_sun(L,ft,iv) + & - Abs_dir_z(ft,iv))*f_abs_leaf(L,ft,iv,ib) - else - currentPatch%fabi_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - (1._r8 - currentPatch%f_sun(L,ft,iv))*f_abs_leaf(L,ft,iv,ib) - currentPatch%fabi_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - currentPatch%f_sun(L,ft,iv)*f_abs_leaf(L,ft,iv,ib) - endif - if ( debug ) then - write(fates_log(),*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & - currentPatch%fabd_sun_z(L,ft,iv) - endif - end do - endif ! ib - - - !==============================================================================! - ! Sum fluxes - !==============================================================================! - ! Solar radiation absorbed by ground - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%NCL_p)then - abs_rad(ib) = abs_rad(ib) + (Abs_dir_z(ft,iv) + Abs_dif_z(ft,iv)) - end if - ! Solar radiation absorbed by vegetation and sunlit/shaded leaves - do iv = 1,currentPatch%nrad(L,ft) - if (radtype == idirect)then - currentPatch%fabd(ib) = currentPatch%fabd(ib) + & - Abs_dir_z(ft,iv)+Abs_dif_z(ft,iv) - ! bc_out(s)%fabd_parb_out(ib) = currentPatch%fabd(ib) - else - currentPatch%fabi(ib) = currentPatch%fabi(ib) + Abs_dif_z(ft,iv) - ! bc_out(s)%fabi_parb_out(ib) = currentPatch%fabi(ib) - endif - end do - - ! Albefor - if (L==1)then !top canopy layer. - if (radtype == idirect)then - albd_parb_out(ib) = albd_parb_out(ib) + & - Dif_up(L,ft,1) * ftweight(L,ft,1) - else - albi_parb_out(ib) = albi_parb_out(ib) + & - Dif_up(L,ft,1) * ftweight(L,ft,1) - end if - end if - - ! pass normalized PAR profiles for use in diagnostic averaging for history fields - if (ib == ivis) then ! only diagnose PAR profiles for the visible band - do iv = 1, currentPatch%nrad(L,ft) - currentPatch%nrmlzd_parprof_pft_dir_z(radtype,L,ft,iv) = & - forc_dir(radtype) * tr_dir_z(L,ft,iv) - currentPatch%nrmlzd_parprof_pft_dif_z(radtype,L,ft,iv) = & - Dif_dn(L,ft,iv) + Dif_up(L,ft,iv) - ! - currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) = & - currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) + & - (forc_dir(radtype) * tr_dir_z(L,ft,iv)) * & - (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) - currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) = & - currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) + & - (Dif_dn(L,ft,iv) + Dif_up(L,ft,iv)) * & - (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) - end do - end if ! ib = visible - end if ! present - end do !ft - if (radtype == idirect)then - fabd_parb_out(ib) = currentPatch%fabd(ib) - else - fabi_parb_out(ib) = currentPatch%fabi(ib) - endif - - - !radiation absorbed from fluxes through unfilled part of lower canopy. - if (currentPatch%NCL_p > 1.and.L == currentPatch%NCL_p)then - abs_rad(ib) = abs_rad(ib) + weighted_dif_down(L-1) * & - (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dif(ib) ) - abs_rad(ib) = abs_rad(ib) + forc_dir(radtype) * weighted_dir_tr(L-1) * & - (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dir(ib) ) - tr_soili = tr_soili + weighted_dif_down(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) - tr_soild = tr_soild + forc_dir(radtype) * weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) - endif - - if (radtype == idirect)then - currentPatch%tr_soil_dir(ib) = tr_soild - currentPatch%tr_soil_dir_dif(ib) = tr_soili - currentPatch%sabs_dir(ib) = abs_rad(ib) - ftdd_parb_out(ib) = tr_soild - ftid_parb_out(ib) = tr_soili - else - currentPatch%tr_soil_dif(ib) = tr_soili - currentPatch%sabs_dif(ib) = abs_rad(ib) - ftii_parb_out(ib) = tr_soili - end if - - end do!l - - - !==============================================================================! - ! Conservation check - !==============================================================================! - ! Total radiation balance: absorbed = incoming - outgoing - - if (radtype == idirect)then - error = abs(currentPatch%sabs_dir(ib) - (currentPatch%tr_soil_dir(ib) * & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + & - currentPatch%tr_soil_dir_dif(ib) * (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) - if ( abs(error) > 0.0001)then - write(fates_log(),*)'dir ground absorption error',error,currentPatch%sabs_dir(ib), & - currentPatch%tr_soil_dir(ib)* & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) - write(fates_log(),*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ) - - do ft =1,3 - iv = currentPatch%nrad(1,ft) + 1 - write(fates_log(),*) 'abs soil fluxes', Abs_dir_z(ft,iv),Abs_dif_z(ft,iv) - end do - - end if - else - if ( abs(currentPatch%sabs_dif(ib)-(currentPatch%tr_soil_dif(ib) * & - (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) > 0.0001_r8)then - write(fates_log(),*)'dif ground absorption error',currentPatch%sabs_dif(ib) , & - (currentPatch%tr_soil_dif(ib)* & - (1.0_r8-currentPatch%gnd_alb_dif(ib) )),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) - endif - endif - - if (radtype == idirect)then - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) - currentPatch%radiation_error = currentPatch%radiation_error + error - else - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) - currentPatch%radiation_error = currentPatch%radiation_error + error - endif - lai_reduction(:) = 0.0_r8 - do L = 1, currentPatch%NCL_p - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - do iv = 1, currentPatch%nrad(L,ft) - if (lai_change(L,ft,iv) > 0.0_r8)then - lai_reduction(L) = max(lai_reduction(L),lai_change(L,ft,iv)) - endif - enddo - endif - enddo - enddo - - if (radtype == idirect)then - !here we are adding a within-ED radiation scheme tolerance, and then adding the diffrence onto the albedo - !it is important that the lower boundary for this is ~1000 times smaller than the tolerance in surface albedo. - if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then - albd_parb_out(ib) = albd_parb_out(ib) + error - !this terms adds the error back on to the albedo. While this is partly inexcusable, it is - ! in the medium term a solution that - ! prevents the model from crashing with small and occasional energy balances issues. - ! These are extremely difficult to debug, many have been solved already, leading - ! to the complexity of this code, but where the system generates occasional errors, we - ! will deal with them for now. - end if - if (abs(error) > 0.15_r8)then - write(fates_log(),*) 'Large Dir Radn consvn error',error ,ib - write(fates_log(),*) 'diags', albd_parb_out(ib), ftdd_parb_out(ib), & - ftid_parb_out(ib), fabd_parb_out(ib) - write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno - write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) - - albd_parb_out(ib) = albd_parb_out(ib) + error - end if - else - - if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then - albi_parb_out(ib) = albi_parb_out(ib) + error - end if - - if (abs(error) > 0.15_r8)then - write(fates_log(),*) 'lg Dif Radn consvn error',error ,ib - write(fates_log(),*) 'diags', albi_parb_out(ib), ftii_parb_out(ib), & - fabi_parb_out(ib) - !write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - !write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - !write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - !write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno - write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) - !write(fates_log(),*) 'rhol',rhol(1:numpft,:) - !write(fates_log(),*) 'ftw',sum(ftweight(1,1:numpft,1)),ftweight(1,1:numpft,1) - !write(fates_log(),*) 'present',currentPatch%canopy_mask(1,1:numpft) - !write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:numpft,1) - - albi_parb_out(ib) = albi_parb_out(ib) + error - end if - - if (radtype == idirect)then - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) - else - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) - endif - - if (abs(error) > 0.00000001_r8)then - write(fates_log(),*) 'there is still error after correction',error ,ib - end if - - end if - end do !hlm_numSWb - - enddo ! rad-type - - - end associate - return + end do + + ! Absorbed direct beam and diffuse do soil + if (L == currentPatch%NCL_p)then + iv = currentPatch%nrad(L,ft) + 1 + Abs_dif_z(ft,iv) = ftweight(L,ft,1)*Dif_dn(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dif(ib) ) + Abs_dir_z(ft,iv) = ftweight(L,ft,1)*forc_dir(radtype) * & + tr_dir_z(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dir(ib) ) + tr_soild = tr_soild + ftweight(L,ft,1)*forc_dir(radtype) * tr_dir_z(L,ft,iv) + tr_soili = tr_soili + ftweight(L,ft,1)*Dif_dn(L,ft,iv) + end if + + ! Absorbed radiation, shaded and sunlit portions of leaf layers + !here we get one unit of diffuse radiation... how much of + !it is absorbed? + if (ib == ivis) then ! only set the absorbed PAR for the visible light band. + do iv = 1, currentPatch%nrad(L,ft) + if (radtype==idirect) then + if ( debug ) then + write(fates_log(),*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) + write(fates_log(),*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & + currentPatch%fabd_sun_z(L,ft,iv) + endif + currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv))*f_abs_leaf(L,ft,iv,ib) + currentPatch%fabd_sun_z(L,ft,iv) =( Abs_dif_z(ft,iv) * & + currentPatch%f_sun(L,ft,iv) + & + Abs_dir_z(ft,iv))*f_abs_leaf(L,ft,iv,ib) + else + currentPatch%fabi_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv))*f_abs_leaf(L,ft,iv,ib) + currentPatch%fabi_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + currentPatch%f_sun(L,ft,iv)*f_abs_leaf(L,ft,iv,ib) + endif + if ( debug ) then + write(fates_log(),*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & + currentPatch%fabd_sun_z(L,ft,iv) + endif + end do + endif ! ib + + + !==============================================================================! + ! Sum fluxes + !==============================================================================! + ! Solar radiation absorbed by ground + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then + abs_rad(ib) = abs_rad(ib) + (Abs_dir_z(ft,iv) + Abs_dif_z(ft,iv)) + end if + ! Solar radiation absorbed by vegetation and sunlit/shaded leaves + do iv = 1,currentPatch%nrad(L,ft) + if (radtype == idirect)then + currentPatch%fabd(ib) = currentPatch%fabd(ib) + & + Abs_dir_z(ft,iv)+Abs_dif_z(ft,iv) + ! bc_out(s)%fabd_parb_out(ib) = currentPatch%fabd(ib) + else + currentPatch%fabi(ib) = currentPatch%fabi(ib) + Abs_dif_z(ft,iv) + ! bc_out(s)%fabi_parb_out(ib) = currentPatch%fabi(ib) + endif + end do + + ! Albefor + if (L==1)then !top canopy layer. + if (radtype == idirect)then + albd_parb_out(ib) = albd_parb_out(ib) + & + Dif_up(L,ft,1) * ftweight(L,ft,1) + else + albi_parb_out(ib) = albi_parb_out(ib) + & + Dif_up(L,ft,1) * ftweight(L,ft,1) + end if + end if + + ! pass normalized PAR profiles for use in diagnostic averaging for history fields + if (ib == ivis) then ! only diagnose PAR profiles for the visible band + do iv = 1, currentPatch%nrad(L,ft) + currentPatch%nrmlzd_parprof_pft_dir_z(radtype,L,ft,iv) = & + forc_dir(radtype) * tr_dir_z(L,ft,iv) + currentPatch%nrmlzd_parprof_pft_dif_z(radtype,L,ft,iv) = & + Dif_dn(L,ft,iv) + Dif_up(L,ft,iv) + ! + currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) = & + currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) + & + (forc_dir(radtype) * tr_dir_z(L,ft,iv)) * & + (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) + currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) = & + currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) + & + (Dif_dn(L,ft,iv) + Dif_up(L,ft,iv)) * & + (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) + end do + end if ! ib = visible + end if ! present + end do !ft + if (radtype == idirect)then + fabd_parb_out(ib) = currentPatch%fabd(ib) + else + fabi_parb_out(ib) = currentPatch%fabi(ib) + endif + + + !radiation absorbed from fluxes through unfilled part of lower canopy. + if (currentPatch%NCL_p > 1.and.L == currentPatch%NCL_p)then + abs_rad(ib) = abs_rad(ib) + weighted_dif_down(L-1) * & + (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dif(ib) ) + abs_rad(ib) = abs_rad(ib) + forc_dir(radtype) * weighted_dir_tr(L-1) * & + (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dir(ib) ) + tr_soili = tr_soili + weighted_dif_down(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) + tr_soild = tr_soild + forc_dir(radtype) * weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) + endif + + if (radtype == idirect)then + currentPatch%tr_soil_dir(ib) = tr_soild + currentPatch%tr_soil_dir_dif(ib) = tr_soili + currentPatch%sabs_dir(ib) = abs_rad(ib) + ftdd_parb_out(ib) = tr_soild + ftid_parb_out(ib) = tr_soili + else + currentPatch%tr_soil_dif(ib) = tr_soili + currentPatch%sabs_dif(ib) = abs_rad(ib) + ftii_parb_out(ib) = tr_soili + end if + + end do!l + + + !==============================================================================! + ! Conservation check + !==============================================================================! + ! Total radiation balance: absorbed = incoming - outgoing + + if (radtype == idirect)then + error = abs(currentPatch%sabs_dir(ib) - (currentPatch%tr_soil_dir(ib) * & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + & + currentPatch%tr_soil_dir_dif(ib) * (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) + if ( abs(error) > 0.0001)then + write(fates_log(),*)'dir ground absorption error',error,currentPatch%sabs_dir(ib), & + currentPatch%tr_soil_dir(ib)* & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) + write(fates_log(),*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + + do ft =1,3 + iv = currentPatch%nrad(1,ft) + 1 + write(fates_log(),*) 'abs soil fluxes', Abs_dir_z(ft,iv),Abs_dif_z(ft,iv) + end do + + end if + else + if ( abs(currentPatch%sabs_dif(ib)-(currentPatch%tr_soil_dif(ib) * & + (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) > 0.0001_r8)then + write(fates_log(),*)'dif ground absorption error',currentPatch%sabs_dif(ib) , & + (currentPatch%tr_soil_dif(ib)* & + (1.0_r8-currentPatch%gnd_alb_dif(ib) )),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) + endif + endif + + if (radtype == idirect)then + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) + currentPatch%radiation_error = currentPatch%radiation_error + error + else + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) + currentPatch%radiation_error = currentPatch%radiation_error + error + endif + lai_reduction(:) = 0.0_r8 + do L = 1, currentPatch%NCL_p + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + do iv = 1, currentPatch%nrad(L,ft) + if (lai_change(L,ft,iv) > 0.0_r8)then + lai_reduction(L) = max(lai_reduction(L),lai_change(L,ft,iv)) + endif + enddo + endif + enddo + enddo + + if (radtype == idirect)then + !here we are adding a within-ED radiation scheme tolerance, and then adding the diffrence onto the albedo + !it is important that the lower boundary for this is ~1000 times smaller than the tolerance in surface albedo. + if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then + albd_parb_out(ib) = albd_parb_out(ib) + error + !this terms adds the error back on to the albedo. While this is partly inexcusable, it is + ! in the medium term a solution that + ! prevents the model from crashing with small and occasional energy balances issues. + ! These are extremely difficult to debug, many have been solved already, leading + ! to the complexity of this code, but where the system generates occasional errors, we + ! will deal with them for now. + end if + if (abs(error) > 0.15_r8)then + write(fates_log(),*) 'Large Dir Radn consvn error',error ,ib + write(fates_log(),*) 'diags', albd_parb_out(ib), ftdd_parb_out(ib), & + ftid_parb_out(ib), fabd_parb_out(ib) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) + + albd_parb_out(ib) = albd_parb_out(ib) + error + end if + else + + if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then + albi_parb_out(ib) = albi_parb_out(ib) + error + end if + + if (abs(error) > 0.15_r8)then + write(fates_log(),*) 'lg Dif Radn consvn error',error ,ib + write(fates_log(),*) 'diags', albi_parb_out(ib), ftii_parb_out(ib), & + fabi_parb_out(ib) + !write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) + !write(fates_log(),*) 'rhol',rhol(1:numpft,:) + !write(fates_log(),*) 'ftw',sum(ftweight(1,1:numpft,1)),ftweight(1,1:numpft,1) + !write(fates_log(),*) 'present',currentPatch%canopy_mask(1,1:numpft) + !write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:numpft,1) + + albi_parb_out(ib) = albi_parb_out(ib) + error + end if + + if (radtype == idirect)then + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) + else + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) + endif + + if (abs(error) > 0.00000001_r8)then + write(fates_log(),*) 'there is still error after correction',error ,ib + end if + + end if + end do !hlm_numSWb + + enddo ! rad-type + + + end associate + return end subroutine PatchNormanRadiation ! ====================================================================================== subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) - - implicit none - - ! 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) - - - ! locals - type (ed_patch_type),pointer :: cpatch ! c"urrent" patch - real(r8) :: sunlai - real(r8) :: shalai - real(r8) :: elai - integer :: CL - integer :: FT - integer :: iv - integer :: s - integer :: ifp - - - do s = 1,nsites - ifp = 0 - cpatch => sites(s)%oldest_patch + implicit none + + ! 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) + + + ! locals + type (ed_patch_type),pointer :: cpatch ! c"urrent" patch + real(r8) :: sunlai + real(r8) :: shalai + real(r8) :: elai + integer :: CL + integer :: FT + integer :: iv + integer :: s + integer :: ifp + + + do s = 1,nsites - do while (associated(cpatch)) + ifp = 0 + cpatch => sites(s)%oldest_patch + + do while (associated(cpatch)) if(cpatch%nocomp_pft_label.ne.0)then !only for veg patches - ! do not do albedo calculations for bare ground patch in SP mode - ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein + ! do not do albedo calculations for bare ground patch in SP mode + ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein ! ifp=1 is the first vegetated patch. - ifp=ifp+1 - - if( debug ) write(fates_log(),*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft - - ! zero out various datas - cpatch%ed_parsun_z(:,:,:) = 0._r8 - cpatch%ed_parsha_z(:,:,:) = 0._r8 - cpatch%ed_laisun_z(:,:,:) = 0._r8 - cpatch%ed_laisha_z(:,:,:) = 0._r8 - - bc_out(s)%fsun_pa(ifp) = 0._r8 - - sunlai = 0._r8 - shalai = 0._r8 - - cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 - cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 - cpatch%parprof_dir_z(:,:) = 0._r8 - cpatch%parprof_dif_z(:,:) = 0._r8 - - ! Loop over patches to calculate laisun_z and laisha_z for each layer. - ! Derive canopy laisun, laisha, and fsun from layer sums. - ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from - ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. - - ! cpatch%f_sun is calculated in the surface_albedo routine... - - do CL = 1, cpatch%NCL_p - do FT = 1,numpft - - if( debug ) write(fates_log(),*) 'edsurfRad_5601',CL,FT,cpatch%nrad(CL,ft) - - do iv = 1, cpatch%nrad(CL,ft) !NORMAL CASE. - - ! FIX(SPM,040114) - existing comment - ! ** Should this be elai or tlai? Surely we only do radiation for elai? - - cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + ifp=ifp+1 + + if( debug ) write(fates_log(),*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft + + ! zero out various datas + cpatch%ed_parsun_z(:,:,:) = 0._r8 + cpatch%ed_parsha_z(:,:,:) = 0._r8 + cpatch%ed_laisun_z(:,:,:) = 0._r8 + cpatch%ed_laisha_z(:,:,:) = 0._r8 + + bc_out(s)%fsun_pa(ifp) = 0._r8 + + sunlai = 0._r8 + shalai = 0._r8 + + cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 + cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 + cpatch%parprof_dir_z(:,:) = 0._r8 + cpatch%parprof_dif_z(:,:) = 0._r8 + + ! Loop over patches to calculate laisun_z and laisha_z for each layer. + ! Derive canopy laisun, laisha, and fsun from layer sums. + ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from + ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. + + ! cpatch%f_sun is calculated in the surface_albedo routine... + + do CL = 1, cpatch%NCL_p + do FT = 1,numpft + + if( debug ) write(fates_log(),*) 'edsurfRad_5601',CL,FT,cpatch%nrad(CL,ft) + + do iv = 1, cpatch%nrad(CL,ft) !NORMAL CASE. + + ! FIX(SPM,040114) - existing comment + ! ** Should this be elai or tlai? Surely we only do radiation for elai? + + cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & cpatch%f_sun(CL,ft,iv) - - if ( debug ) write(fates_log(),*) 'edsurfRad 570 ',cpatch%elai_profile(CL,ft,iv) - if ( debug ) write(fates_log(),*) 'edsurfRad 571 ',cpatch%f_sun(CL,ft,iv) - - cpatch%ed_laisha_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + + if ( debug ) write(fates_log(),*) 'edsurfRad 570 ',cpatch%elai_profile(CL,ft,iv) + if ( debug ) write(fates_log(),*) 'edsurfRad 571 ',cpatch%f_sun(CL,ft,iv) + + cpatch%ed_laisha_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & (1._r8 - cpatch%f_sun(CL,ft,iv)) - - end do - - !needed for the VOC emissions, etc. - sunlai = sunlai + sum(cpatch%ed_laisun_z(CL,ft,1:cpatch%nrad(CL,ft))) - shalai = shalai + sum(cpatch%ed_laisha_z(CL,ft,1:cpatch%nrad(CL,ft))) - - end do - end do - - if(sunlai+shalai > 0._r8)then - bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) - else - bc_out(s)%fsun_pa(ifp) = 0._r8 - endif - - if(bc_out(s)%fsun_pa(ifp) > 1._r8)then - write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & + + end do + + !needed for the VOC emissions, etc. + sunlai = sunlai + sum(cpatch%ed_laisun_z(CL,ft,1:cpatch%nrad(CL,ft))) + shalai = shalai + sum(cpatch%ed_laisha_z(CL,ft,1:cpatch%nrad(CL,ft))) + + end do + end do + + if(sunlai+shalai > 0._r8)then + bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) + else + bc_out(s)%fsun_pa(ifp) = 0._r8 + endif + + if(bc_out(s)%fsun_pa(ifp) > 1._r8)then + write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & sunlai,shalai - endif + endif + + elai = calc_areaindex(cpatch,'elai') + + bc_out(s)%laisun_pa(ifp) = elai*bc_out(s)%fsun_pa(ifp) + bc_out(s)%laisha_pa(ifp) = elai*(1.0_r8-bc_out(s)%fsun_pa(ifp)) + + ! Absorbed PAR profile through canopy + ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo + ! are canopy integrated so that layer values equal big leaf values. + + if ( debug ) write(fates_log(),*) 'edsurfRad 645 ',cpatch%NCL_p,numpft + + do CL = 1, cpatch%NCL_p + do FT = 1,numpft + + if ( debug ) write(fates_log(),*) 'edsurfRad 649 ',cpatch%nrad(CL,ft) + + do iv = 1, cpatch%nrad(CL,ft) + + if ( debug ) then + write(fates_log(),*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) + write(fates_log(),*) 'edsurfRad 654 ', bc_in(s)%solad_parb(ifp,ipar) + write(fates_log(),*) 'edsurfRad 655 ', bc_in(s)%solai_parb(ifp,ipar) + write(fates_log(),*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) + write(fates_log(),*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) + endif + + cpatch%ed_parsun_z(CL,ft,iv) = & + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(CL,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(CL,ft,iv) + + if ( debug )write(fates_log(),*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) + + cpatch%ed_parsha_z(CL,ft,iv) = & + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(CL,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(CL,ft,iv) + + if ( debug ) write(fates_log(),*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) + + end do !iv + end do !FT + end do !CL + cpatch%radiation_error = cpatch%radiation_error * (bc_in(s)%solad_parb(ifp,ipar)+ & + bc_in(s)%solai_parb(ifp,ipar)) + ! output the actual PAR profiles through the canopy for diagnostic purposes + + do CL = 1, cpatch%NCL_p + do FT = 1,numpft + do iv = 1, cpatch%nrad(CL,ft) + cpatch%parprof_pft_dir_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dir_z(idirect,CL,FT,iv)) + & + (bc_in(s)%solai_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dir_z(idiffuse,CL,FT,iv)) + cpatch%parprof_pft_dif_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dif_z(idirect,CL,FT,iv)) + & + (bc_in(s)%solai_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dif_z(idiffuse,CL,FT,iv)) + end do ! iv + end do ! FT + end do ! CL + + do CL = 1, cpatch%NCL_p + do iv = 1, maxval(cpatch%nrad(CL,:)) + cpatch%parprof_dir_z(CL,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_dir_z(idirect,CL,iv)) + & + (bc_in(s)%solai_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_dir_z(idiffuse,CL,iv)) + cpatch%parprof_dif_z(CL,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_dif_z(idirect,CL,iv)) + & + (bc_in(s)%solai_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_dif_z(idiffuse,CL,iv)) + end do ! iv + end do ! CL + endif ! not bareground patch + cpatch => cpatch%younger + enddo + + + enddo + return - elai = calc_areaindex(cpatch,'elai') - - bc_out(s)%laisun_pa(ifp) = elai*bc_out(s)%fsun_pa(ifp) - bc_out(s)%laisha_pa(ifp) = elai*(1.0_r8-bc_out(s)%fsun_pa(ifp)) - - ! Absorbed PAR profile through canopy - ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo - ! are canopy integrated so that layer values equal big leaf values. - - if ( debug ) write(fates_log(),*) 'edsurfRad 645 ',cpatch%NCL_p,numpft - - do CL = 1, cpatch%NCL_p - do FT = 1,numpft - - if ( debug ) write(fates_log(),*) 'edsurfRad 649 ',cpatch%nrad(CL,ft) - - do iv = 1, cpatch%nrad(CL,ft) - - if ( debug ) then - write(fates_log(),*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) - write(fates_log(),*) 'edsurfRad 654 ', bc_in(s)%solad_parb(ifp,ipar) - write(fates_log(),*) 'edsurfRad 655 ', bc_in(s)%solai_parb(ifp,ipar) - write(fates_log(),*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) - write(fates_log(),*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) - endif - - cpatch%ed_parsun_z(CL,ft,iv) = & - bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(CL,ft,iv) + & - bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(CL,ft,iv) - - if ( debug )write(fates_log(),*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) - - cpatch%ed_parsha_z(CL,ft,iv) = & - bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(CL,ft,iv) + & - bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(CL,ft,iv) - - if ( debug ) write(fates_log(),*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) - - end do !iv - end do !FT - end do !CL - cpatch%radiation_error = cpatch%radiation_error * (bc_in(s)%solad_parb(ifp,ipar)+ & - bc_in(s)%solai_parb(ifp,ipar)) - ! output the actual PAR profiles through the canopy for diagnostic purposes - - do CL = 1, cpatch%NCL_p - do FT = 1,numpft - do iv = 1, cpatch%nrad(CL,ft) - cpatch%parprof_pft_dir_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dir_z(idirect,CL,FT,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dir_z(idiffuse,CL,FT,iv)) - cpatch%parprof_pft_dif_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dif_z(idirect,CL,FT,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dif_z(idiffuse,CL,FT,iv)) - end do ! iv - end do ! FT - end do ! CL - - do CL = 1, cpatch%NCL_p - do iv = 1, maxval(cpatch%nrad(CL,:)) - cpatch%parprof_dir_z(CL,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dir_z(idirect,CL,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dir_z(idiffuse,CL,iv)) - cpatch%parprof_dif_z(CL,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dif_z(idirect,CL,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dif_z(idiffuse,CL,iv)) - end do ! iv - end do ! CL - endif ! not bareground patch - cpatch => cpatch%younger - enddo - - - enddo - return - end subroutine ED_SunShadeFracs @@ -1278,7 +1278,7 @@ end subroutine ED_SunShadeFracs ! real(r8),intent(in),dimension(:,:) :: forc_solad ! => atm2lnd_inst%forc_solad_grc, direct radiation (W/m**2 ! real(r8),intent(in),dimension(:,:) :: forc_solai ! => atm2lnd_inst%forc_solai_grc, diffuse radiation (W/m**2) ! real(r8),intent(in),dimension(:,:) :: fsa ! => solarabs_inst%fsa_patch, solar radiation absorbed (total) (W/m**2) -! real(r8),intent(in),dimension(:,:) :: fsr ! => solarabs_inst%fsr_patch, solar radiation reflected (W/m**2) +! real(r8),intent(in),dimension(:,:) :: fsr ! => solarabs_inst%fsr_patch, solar radiation reflected (W/m**2) ! integer :: p ! integer :: fp @@ -1295,6 +1295,6 @@ end subroutine ED_SunShadeFracs ! end do ! return ! end subroutine ED_CheckSolarBalance - + end module EDSurfaceRadiationMod From 95f3391927e21e681b7fd8ecb55bd1abc1cdfa7f Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Tue, 28 Sep 2021 09:40:00 -0600 Subject: [PATCH 407/578] Updates to history variable names and units for consistency and to conform with CF conventions --- main/FatesConstantsMod.F90 | 45 +- main/FatesHistoryInterfaceMod.F90 | 2373 +++++++++++++++-------------- 2 files changed, 1225 insertions(+), 1193 deletions(-) diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 7e19856aa2..31c463cbf3 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -23,7 +23,7 @@ module FatesConstantsMod ! Used to check if a parameter was specified in the parameter file (or left as _) real(fates_r8), parameter, public :: fates_check_param_set = 9.9e32_fates_r8 - + ! Integer equivalent of true (in case some compilers dont auto convert) integer, parameter, public :: itrue = 1 @@ -46,7 +46,7 @@ module FatesConstantsMod integer, public, parameter :: prescribed_n_uptake = 1 integer, public, parameter :: coupled_n_uptake = 2 - + integer, public, parameter :: cohort_np_comp_scaling = 1 ! This flag definition indicates that EVERY cohort on ! the column should compete independently in the soil ! BGC nitrogen and phosphorus acquisition scheme. @@ -59,11 +59,11 @@ module FatesConstantsMod ! nutrients are turned off in FATES, or, that the ! plants are not coupled with below ground chemistry. In ! this situation, we send token boundary condition information. - - + + ! This flag specifies the scaling of how we present ! nutrient competitors to the HLM's soil BGC model - + integer, public, parameter :: fates_np_comp_scaling = cohort_np_comp_scaling real(fates_r8), parameter, public :: secondary_age_threshold = 94._fates_r8 ! less than this value is young secondary land @@ -72,9 +72,9 @@ module FatesConstantsMod ! integer labels for specifying harvest units integer, parameter, public :: hlm_harvest_area_fraction = 1 ! Code for harvesting by area - integer, parameter, public :: hlm_harvest_carbon = 2 ! Code for harvesting based on carbon extracted. + integer, parameter, public :: hlm_harvest_carbon = 2 ! Code for harvesting based on carbon extracted. + - ! Error Tolerances ! Allowable error in carbon allocations, should be applied to estimates @@ -88,7 +88,7 @@ module FatesConstantsMod ! multiplying each by their original sum, and then seeing if their addition ! matches the original sum. Other simple examples of rounding errors ! are simply changing the orders: a*b*c .ne. a*c*b - ! This value here is used as an error expectation comparison + ! This value here is used as an error expectation comparison ! for multiplication/division procedures, also allowing for 3 orders ! of magnitude of buffer error (ie instead of 1e-15) real(fates_r8), parameter, public :: rsnbl_math_prec = 1.0e-12_fates_r8 @@ -97,7 +97,7 @@ module FatesConstantsMod real(fates_r8), parameter, public :: tinyr8 = tiny(1.0_fates_r8) ! We mostly use this in place of logical comparisons - ! between reals with zero, as the chances are their + ! between reals with zero, as the chances are their ! precisions are preventing perfect zero in comparison real(fates_r8), parameter, public :: nearzero = 1.0e-30_fates_r8 @@ -110,10 +110,10 @@ module FatesConstantsMod ! Conversion factor: miligrams per kilogram real(fates_r8), parameter, public :: mg_per_kg = 1.0e6_fates_r8 - + ! Conversion factor: grams per kilograms real(fates_r8), parameter, public :: g_per_kg = 1000.0_fates_r8 - + ! Conversion factor: kilograms per gram real(fates_r8), parameter, public :: kg_per_g = 0.001_fates_r8 @@ -128,7 +128,7 @@ module FatesConstantsMod ! Conversion factor: milimoles per mole real(fates_r8), parameter, public :: mmol_per_mol = 1000.0_fates_r8 - + ! Conversion factor: micromoles per mole real(fates_r8), parameter, public :: umol_per_mol = 1.0E6_fates_r8 @@ -141,9 +141,15 @@ module FatesConstantsMod ! Conversion factor: milimeters per meter real(fates_r8), parameter, public :: mm_per_m = 1.0E3_fates_r8 + ! Conversion factor: meters per centimeter + real(fates_r8), parameter, public :: m_per_cm = 1.0E-2_fates_r8 + ! Conversion factor: m2 per ha real(fates_r8), parameter, public :: m2_per_ha = 1.0e4_fates_r8 + ! Conversion factor: m2 per km2 + real(fates_r8), parameter, public :: m2_per_km2 = 1.0e6_fates_r8 + ! Conversion factor: cm2 per m2 real(fates_r8), parameter, public :: cm2_per_m2 = 10000.0_fates_r8 @@ -167,27 +173,30 @@ module FatesConstantsMod ! Conversion: days per second real(fates_r8), parameter, public :: days_per_sec = 1.0_fates_r8/86400.0_fates_r8 - ! Conversion: days per year. assume HLM uses 365 day calendar. + ! Conversion: days per year. assume HLM uses 365 day calendar. ! If we need to link to 365.25-day-calendared HLM, rewire to pass through interface real(fates_r8), parameter, public :: days_per_year = 365.00_fates_r8 - - ! Conversion: years per day. assume HLM uses 365 day calendar. + + ! Conversion: years per day. assume HLM uses 365 day calendar. ! If we need to link to 365.25-day-calendared HLM, rewire to pass through interface real(fates_r8), parameter, public :: years_per_day = 1.0_fates_r8/365.00_fates_r8 ! Conversion: months per year real(fates_r8), parameter, public :: months_per_year = 12.0_fates_r8 + ! Conversion: Joules per kiloJoules + real(fates_r8), parameter, public :: J_per_kJ = 1000.0_fates_r8 + ! Physical constants ! universal gas constant [J/K/kmol] real(fates_r8), parameter, public :: rgas_J_K_kmol = 8314.4598_fates_r8 ! freezing point of water at 1 atm (K) - real(fates_r8), parameter, public :: t_water_freeze_k_1atm = 273.15_fates_r8 + real(fates_r8), parameter, public :: t_water_freeze_k_1atm = 273.15_fates_r8 ! freezing point of water at triple point (K) - real(fates_r8), parameter, public :: t_water_freeze_k_triple = 273.16_fates_r8 + real(fates_r8), parameter, public :: t_water_freeze_k_triple = 273.16_fates_r8 ! Density of fresh liquid water (kg/m3) real(fates_r8), parameter, public :: dens_fresh_liquid_water = 1.0E3_fates_r8 @@ -207,7 +216,7 @@ module FatesConstantsMod real(fates_r8), parameter, public :: fates_tiny = tiny(g_per_kg) ! Geometric Constants - + ! PI real(fates_r8), parameter, public :: pi_const = 3.14159265359_fates_r8 diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 97f3342b43..80032ce6b0 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -18,7 +18,7 @@ module FatesHistoryInterfaceMod use EDTypesMod , only : site_fluxdiags_type use EDtypesMod , only : ed_site_type use EDtypesMod , only : ed_cohort_type - use EDtypesMod , only : ed_patch_type + use EDtypesMod , only : ed_patch_type use EDtypesMod , only : AREA use EDtypesMod , only : AREA_INV use EDTypesMod , only : numWaterMem @@ -47,10 +47,10 @@ module FatesHistoryInterfaceMod use FatesInterfaceTypesMod , only : hlm_model_day use FatesInterfaceTypesMod , only : nlevcoage - ! FIXME(bja, 2016-10) need to remove CLM dependancy + ! FIXME(bja, 2016-10) need to remove CLM dependancy use EDPftvarcon , only : EDPftvarcon_inst use PRTParametersMod , only : prt_params - + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg use shr_infnan_mod , only : isnan => shr_infnan_isnan @@ -84,26 +84,26 @@ module FatesHistoryInterfaceMod ! as distinct classes such as PFTs or fuel size bins, there are multiple different dimensions in ! which it is possible to output history variables to better understand what's going on. ! - ! a key point is that, while the number of patches or cohorts can in principle be large, and - ! the age and size indices of a given patch or cohort can be finely resolved, we collapse these - ! continuously varying indices into bins of time-invariant width for the purposes of history + ! a key point is that, while the number of patches or cohorts can in principle be large, and + ! the age and size indices of a given patch or cohort can be finely resolved, we collapse these + ! continuously varying indices into bins of time-invariant width for the purposes of history ! outputting. This is because a given patch or cohort may not persist across a given interval - ! of history averaging, so it is better to output all patches of cohorts whose index is within + ! of history averaging, so it is better to output all patches of cohorts whose index is within ! a given interval along the size or age bin. ! - ! Another particularity of the issue of FATES shifting its subgrid structure frequently + ! Another particularity of the issue of FATES shifting its subgrid structure frequently ! and possibly having multiple (or zero) patches or cohorts within a given bin is that, if you - ! want to output an average quantities across some dimension, such as a mean carbon flux across + ! want to output an average quantities across some dimension, such as a mean carbon flux across ! patch area of a given age, in general it is better to output both the numerator and denominator - ! of the averaging calculation separately, rather than the average itself, and then calculate - ! the average in post-processing. So, e.g. this means outputting both the patch area and the - ! product of the flux within each patch and the patch area as separate variables. Doing this + ! of the averaging calculation separately, rather than the average itself, and then calculate + ! the average in post-processing. So, e.g. this means outputting both the patch area and the + ! product of the flux within each patch and the patch area as separate variables. Doing this ! allows conservation even when the weights are changing rapidly and simplifies the logic when ! the number of patches or cohorts may be anywhere from zero to a large number. ! - ! So what this means is that anything that is disaggregated at the patch area requires + ! So what this means is that anything that is disaggregated at the patch area requires ! outputting the patch age distribution (in units of patch area / site area) as the denominator - ! of the average and then calculating the numerator of the average as XXX times the patch + ! of the average and then calculating the numerator of the average as XXX times the patch ! area so (so in units of XXX * patch area / site area). For cohort-level quantities, ! this requires outputting the number density (in units of individuals per site area), etc. ! @@ -114,7 +114,7 @@ module FatesHistoryInterfaceMod ! age = the age bin dimension ! height = the height bin dimension ! cwdsc = the coarse woody debris size class dimension - ! + ! ! Since the netcdf interface can only handle variables with a certain number of dimensions, ! we have create some "multiplexed" dimensions that combine two or more dimensions into a ! single dimension. Examples of these are the following: @@ -126,25 +126,25 @@ module FatesHistoryInterfaceMod ! scagpft = size class bin x age bin x PFT ! agepft = age bin x PFT ! agefuel = age bin x fuel size class - + ! A recipe for adding a new history variable to this module: ! (1) decide what time frequency it makes sense to update the variable at, and what dimension(s) ! you want to output the variable on - ! (2) add the ih_ integer variable in the immediately following section of the module. + ! (2) add the ih_ integer variable in the immediately following section of the module. ! use the suffix as outlined above for the dimension you are using. - ! (3) define a corresponding hio_ variable by associating it to the ih_ variable - ! in the associate section of the subroutine that corresponds to the time-updating + ! (3) define a corresponding hio_ variable by associating it to the ih_ variable + ! in the associate section of the subroutine that corresponds to the time-updating ! frequency that you've chosen - ! (i.e. if half-hourly, then work in subroutine update_history_prod; if daily, + ! (i.e. if half-hourly, then work in subroutine update_history_prod; if daily, ! then work in subroutine update_history_dyn) - ! (4) within that subroutine, add the logic that passes the information from the - ! fates-native variable (possibly on a patch or cohort structure) to the history + ! (4) within that subroutine, add the logic that passes the information from the + ! fates-native variable (possibly on a patch or cohort structure) to the history ! hio_ variable that you've associated to. - ! (5) add the variable name, metadata, units, dimension, updating frequency, the ih_ variable + ! (5) add the variable name, metadata, units, dimension, updating frequency, the ih_ variable ! index, etc via a call to the set_history_var method in the subroutine define_history_vars. ! - + ! Indices to 1D Patch variables integer :: ih_storec_si @@ -178,7 +178,7 @@ module FatesHistoryInterfaceMod integer :: ih_pefflux_si integer :: ih_nneed_si integer :: ih_pneed_si - + integer :: ih_trimming_si integer :: ih_area_plant_si integer :: ih_area_trees_si @@ -205,7 +205,7 @@ module FatesHistoryInterfaceMod integer :: ih_burn_flux_elem ! Size-class x PFT mass states - + integer :: ih_bstor_canopy_si_scpf integer :: ih_bstor_understory_si_scpf integer :: ih_bleaf_canopy_si_scpf @@ -249,14 +249,9 @@ module FatesHistoryInterfaceMod integer :: ih_daily_temp integer :: ih_daily_rh integer :: ih_daily_prec - - 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 @@ -301,7 +296,7 @@ module FatesHistoryInterfaceMod integer :: ih_nep_si integer :: ih_hr_si - + integer :: ih_c_stomata_si integer :: ih_c_lblayer_si @@ -336,7 +331,7 @@ module FatesHistoryInterfaceMod integer :: ih_h2oveg_recruit_si integer :: ih_h2oveg_growturn_err_si integer :: ih_h2oveg_hydro_err_si - + integer :: ih_site_cstatus_si integer :: ih_site_dstatus_si integer :: ih_gdd_si @@ -353,10 +348,8 @@ module FatesHistoryInterfaceMod integer :: ih_fire_fdi_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 @@ -377,8 +370,8 @@ module FatesHistoryInterfaceMod integer :: ih_npp_agsw_si_scpf integer :: ih_npp_agdw_si_scpf integer :: ih_npp_stor_si_scpf - - + + integer :: ih_mortality_canopy_si_scpf integer :: ih_mortality_understory_si_scpf integer :: ih_nplant_canopy_si_scpf @@ -401,7 +394,7 @@ module FatesHistoryInterfaceMod integer :: ih_m4_si_scpf integer :: ih_m5_si_scpf integer :: ih_m6_si_scpf - integer :: ih_m7_si_scpf + integer :: ih_m7_si_scpf integer :: ih_m8_si_scpf integer :: ih_m9_si_scpf integer :: ih_m10_si_scpf @@ -418,7 +411,7 @@ module FatesHistoryInterfaceMod integer :: ih_ar_agsapm_si_scpf integer :: ih_ar_crootm_si_scpf integer :: ih_ar_frootm_si_scpf - + integer :: ih_c13disc_si_scpf ! indices to (site x scls [size class bins]) variables @@ -450,7 +443,7 @@ module FatesHistoryInterfaceMod integer :: ih_m4_si_scls integer :: ih_m5_si_scls integer :: ih_m6_si_scls - integer :: ih_m7_si_scls + integer :: ih_m7_si_scls integer :: ih_m8_si_scls integer :: ih_m9_si_scls integer :: ih_m10_si_scls @@ -538,30 +531,30 @@ module FatesHistoryInterfaceMod integer :: ih_leaf_height_dist_si_height ! Indices to hydraulics variables - + integer :: ih_errh2o_scpf integer :: ih_tran_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 - integer :: ih_ath_scpf - integer :: ih_tth_scpf - integer :: ih_sth_scpf - integer :: ih_lth_scpf - integer :: ih_awp_scpf - integer :: ih_twp_scpf - integer :: ih_swp_scpf - integer :: ih_lwp_scpf - integer :: ih_aflc_scpf - integer :: ih_tflc_scpf - integer :: ih_sflc_scpf - integer :: ih_lflc_scpf + integer :: ih_iterh1_scpf + integer :: ih_iterh2_scpf + integer :: ih_supsub_scpf + integer :: ih_ath_scpf + integer :: ih_tth_scpf + integer :: ih_sth_scpf + integer :: ih_lth_scpf + integer :: ih_awp_scpf + integer :: ih_twp_scpf + integer :: ih_swp_scpf + integer :: ih_lwp_scpf + integer :: ih_aflc_scpf + integer :: ih_tflc_scpf + 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 @@ -571,7 +564,7 @@ module FatesHistoryInterfaceMod 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 @@ -580,7 +573,7 @@ module FatesHistoryInterfaceMod 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 @@ -640,21 +633,21 @@ module FatesHistoryInterfaceMod integer, parameter, public :: fates_history_num_dim_kinds = 50 type, public :: fates_history_interface_type - + ! Instance of the list of history output varialbes type(fates_history_variable_type), allocatable :: hvars(:) integer, private :: num_history_vars_ - + ! Instanteat one registry of the different dimension/kinds (dk) ! All output variables will have a pointer to one of these dk's type(fates_io_variable_kind_type) :: dim_kinds(fates_history_num_dim_kinds) - + ! This is a structure that explains where FATES patch boundaries ! on each thread point to in the host IO array, this structure is ! allocated by number of threads. This could be dynamically ! allocated, but is unlikely to change...? type(fates_io_dimension_type) :: dim_bounds(fates_history_num_dimensions) - + !! THESE WERE EXPLICITLY PRIVATE WHEN TYPE WAS PUBLIC integer, private :: patch_index_, column_index_, levgrnd_index_, levscpf_index_ integer, private :: levscls_index_, levpft_index_, levage_index_ @@ -666,14 +659,14 @@ module FatesHistoryInterfaceMod integer, private :: levelcwd_index_, levelage_index_ integer, private :: levcacls_index_, levcapf_index_ - + contains - + procedure :: Init procedure :: SetThreadBoundsEach procedure :: initialize_history_vars procedure :: assemble_history_output_types - + procedure :: update_history_dyn procedure :: update_history_hifrq procedure :: update_history_hydraulics @@ -729,16 +722,16 @@ module FatesHistoryInterfaceMod procedure, private :: set_levagepft_index procedure, private :: set_levheight_index procedure, private :: set_levagefuel_index - + procedure, private :: set_levelem_index procedure, private :: set_levelpft_index procedure, private :: set_levelcwd_index procedure, private :: set_levelage_index procedure, public :: flush_hvars - + end type fates_history_interface_type - + character(len=*), parameter :: sourcefile = & __FILE__ @@ -747,11 +740,11 @@ module FatesHistoryInterfaceMod type(fates_history_interface_type), public :: fates_hist - + contains ! ====================================================================== - + subroutine Init(this, num_threads, fates_bounds) use FatesIODimensionsMod, only : patch, column, levgrnd, levscpf @@ -847,17 +840,17 @@ subroutine Init(this, num_threads, fates_bounds) call this%set_levscag_index(dim_count) call this%dim_bounds(dim_count)%Init(levscag, num_threads, & fates_bounds%sizeage_class_begin, fates_bounds%sizeage_class_end) - + dim_count = dim_count + 1 call this%set_levscagpft_index(dim_count) call this%dim_bounds(dim_count)%Init(levscagpft, num_threads, & fates_bounds%sizeagepft_class_begin, fates_bounds%sizeagepft_class_end) - + dim_count = dim_count + 1 call this%set_levagepft_index(dim_count) call this%dim_bounds(dim_count)%Init(levagepft, num_threads, & fates_bounds%agepft_class_begin, fates_bounds%agepft_class_end) - + dim_count = dim_count + 1 call this%set_levheight_index(dim_count) call this%dim_bounds(dim_count)%Init(levheight, num_threads, & @@ -872,7 +865,7 @@ subroutine Init(this, num_threads, fates_bounds) call this%set_levelpft_index(dim_count) call this%dim_bounds(dim_count)%Init(levelpft, num_threads, & fates_bounds%elpft_begin, fates_bounds%elpft_end) - + dim_count = dim_count + 1 call this%set_levelcwd_index(dim_count) call this%dim_bounds(dim_count)%Init(levelcwd, num_threads, & @@ -882,12 +875,12 @@ subroutine Init(this, num_threads, fates_bounds) call this%set_levelage_index(dim_count) call this%dim_bounds(dim_count)%Init(levelage, num_threads, & fates_bounds%elage_begin, fates_bounds%elage_end) - + dim_count = dim_count + 1 call this%set_levagefuel_index(dim_count) call this%dim_bounds(dim_count)%Init(levagefuel, num_threads, & fates_bounds%agefuel_begin, fates_bounds%agefuel_end) - + end subroutine Init ! ====================================================================== @@ -903,7 +896,7 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) type(fates_bounds_type), intent(in) :: thread_bounds integer :: index - + index = this%patch_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%patch_begin, thread_bounds%patch_end) @@ -935,43 +928,43 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) index = this%levpft_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%pft_class_begin, thread_bounds%pft_class_end) - + index = this%levage_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%age_class_begin, thread_bounds%age_class_end) - + index = this%levfuel_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%fuel_begin, thread_bounds%fuel_end) - + index = this%levcwdsc_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%cwdsc_begin, thread_bounds%cwdsc_end) - + index = this%levcan_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%can_begin, thread_bounds%can_end) - + index = this%levcnlf_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%cnlf_begin, thread_bounds%cnlf_end) - + index = this%levcnlfpft_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%cnlfpft_begin, thread_bounds%cnlfpft_end) - + index = this%levscag_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%sizeage_class_begin, thread_bounds%sizeage_class_end) - + index = this%levscagpft_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%sizeagepft_class_begin, thread_bounds%sizeagepft_class_end) - + index = this%levagepft_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%agepft_class_begin, thread_bounds%agepft_class_end) - + index = this%levheight_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%height_begin, thread_bounds%height_end) @@ -983,7 +976,7 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) index = this%levelpft_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%elpft_begin, thread_bounds%elpft_end) - + index = this%levelcwd_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%elcwd_begin, thread_bounds%elcwd_end) @@ -991,17 +984,17 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) index = this%levelage_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%elage_begin, thread_bounds%elage_end) - + index = this%levagefuel_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%agefuel_begin, thread_bounds%agefuel_end) - - - + + + end subroutine SetThreadBoundsEach - + ! =================================================================================== subroutine assemble_history_output_types(this) @@ -1082,24 +1075,24 @@ subroutine assemble_history_output_types(this) call this%set_dim_indices(site_elem_r8, 1, this%column_index()) call this%set_dim_indices(site_elem_r8, 2, this%levelem_index()) - + call this%set_dim_indices(site_elpft_r8, 1, this%column_index()) call this%set_dim_indices(site_elpft_r8, 2, this%levelpft_index()) call this%set_dim_indices(site_elcwd_r8, 1, this%column_index()) call this%set_dim_indices(site_elcwd_r8, 2, this%levelcwd_index()) - + call this%set_dim_indices(site_elage_r8, 1, this%column_index()) call this%set_dim_indices(site_elage_r8, 2, this%levelage_index()) call this%set_dim_indices(site_agefuel_r8, 1, this%column_index()) call this%set_dim_indices(site_agefuel_r8, 2, this%levagefuel_index()) - + end subroutine assemble_history_output_types - + ! =================================================================================== - + subroutine set_dim_indices(this, dk_name, idim, dim_index) use FatesIOVariableKindMod , only : iotype_index @@ -1138,7 +1131,7 @@ subroutine set_dim_indices(this, dk_name, idim, dim_index) this%dim_bounds(dim_index)%lower_bound + 1 end subroutine set_dim_indices - + ! ======================================================================= subroutine set_patch_index(this, index) implicit none @@ -1407,7 +1400,7 @@ integer function levelem_index(this) end function levelem_index ! ====================================================================================== - + subroutine set_levelpft_index(this, index) implicit none class(fates_history_interface_type), intent(inout) :: this @@ -1459,17 +1452,17 @@ subroutine set_levagefuel_index(this, index) integer, intent(in) :: index this%levagefuel_index_ = index end subroutine set_levagefuel_index - + integer function levagefuel_index(this) implicit none class(fates_history_interface_type), intent(in) :: this levagefuel_index = this%levagefuel_index_ end function levagefuel_index - + ! ====================================================================================== subroutine flush_hvars(this,nc,upfreq_in) - + class(fates_history_interface_type) :: this integer,intent(in) :: nc integer,intent(in) :: upfreq_in @@ -1479,23 +1472,23 @@ subroutine flush_hvars(this,nc,upfreq_in) do ivar=1,ubound(this%hvars,1) if (this%hvars(ivar)%upfreq == upfreq_in) then ! Only flush variables with update on dynamics step call this%hvars(ivar)%flush(nc, this%dim_bounds, this%dim_kinds) - + end if end do - + end subroutine flush_hvars - + ! ===================================================================================== - + subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype, & - hlms, flushval, upfreq, ivar, initialize, index) + hlms, upfreq, ivar, initialize, index) use FatesUtilsMod, only : check_hlm_list use FatesInterfaceTypesMod, only : hlm_name implicit none - + ! arguments class(fates_history_interface_type), intent(inout) :: this character(len=*), intent(in) :: vname @@ -1505,44 +1498,45 @@ subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype character(len=*), intent(in) :: avgflag character(len=*), intent(in) :: vtype character(len=*), intent(in) :: hlms - real(r8), intent(in) :: flushval ! IF THE TYPE IS AN INT WE WILL round with NINT integer, intent(in) :: upfreq - logical, intent(in) :: initialize - integer, intent(inout) :: ivar - integer, intent(inout) :: index ! This is the index for the variable of + logical, intent(in) :: initialize + integer, intent(inout) :: ivar + integer, intent(inout) :: index ! This is the index for the variable of ! interest that is associated with an ! explict name (for fast reference during update) ! A zero is passed back when the variable is ! not used - ! locals - integer :: ub1, lb1, ub2, lb2 ! Bounds for allocating the var - integer :: ityp + integer :: ub1, lb1, ub2, lb2 ! Bounds for allocating the var + integer :: ityp + real(r8), :: flushval + logical :: write_var - logical :: write_var + flushval = hlm_hio_ignore_val !for now do this (ACF 09/27/21) + ! we need to flush this to 0.0 in FATES write_var = check_hlm_list(trim(hlms), trim(hlm_name)) if( write_var ) then ivar = ivar+1 - index = ivar - + index = ivar + if (initialize) then - call this%hvars(ivar)%Init(vname, units, long, use_default, & - vtype, avgflag, flushval, upfreq, & - fates_history_num_dim_kinds, this%dim_kinds, this%dim_bounds) + call this%hvars(ivar)%Init(vname, units, long, use_default, & + vtype, avgflag, flushval, upfreq, fates_history_num_dim_kinds, & + this%dim_kinds, this%dim_bounds) end if else index = 0 end if - + return end subroutine set_history_var - + ! ==================================================================================== - + subroutine init_dim_kinds_maps(this) - + ! ---------------------------------------------------------------------------------- ! This subroutine simply initializes the structures that define the different ! array and type formats for different IO variables @@ -1566,10 +1560,10 @@ subroutine init_dim_kinds_maps(this) use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8 implicit none - + ! Arguments class(fates_history_interface_type), intent(inout) :: this - + integer :: index @@ -1660,7 +1654,7 @@ subroutine init_dim_kinds_maps(this) ! site x element x pft index = index + 1 call this%dim_kinds(index)%Init(site_elpft_r8, 2) - + ! site x element x cwd index = index + 1 call this%dim_kinds(index)%Init(site_elcwd_r8, 2) @@ -1682,14 +1676,14 @@ end subroutine init_dim_kinds_maps ! ==================================================================================== - + subroutine update_history_dyn(this,nc,nsites,sites) - + ! --------------------------------------------------------------------------------- ! This is the call to update the history IO arrays that are expected to only change ! after Ecosystem Dynamics have been processed. ! --------------------------------------------------------------------------------- - + use EDtypesMod , only : nfsc use FatesLitterMod , only : ncwd @@ -1711,7 +1705,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) integer , intent(in) :: nc ! clump index integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) - + ! Locals type(litter_type), pointer :: litt_c ! Pointer to the carbon12 litter pool type(litter_type), pointer :: litt ! Generic pointer to any litter pool @@ -1722,7 +1716,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) integer :: s ! The local site index integer :: io_si ! The site index of the IO array integer :: ilyr ! Soil index for nlevsoil - integer :: ipa, ipa2 ! The local "I"ndex of "PA"tches + integer :: ipa, ipa2 ! The local "I"ndex of "PA"tches 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 @@ -1739,18 +1733,18 @@ subroutine update_history_dyn(this,nc,nsites,sites) integer :: height_bin_max, height_bin_min ! which height bin a given cohort's canopy is in integer :: i_heightbin ! iterator for height bins integer :: el ! Loop index for elements - integer :: model_day_int ! integer model day from reference + integer :: model_day_int ! integer model day from reference integer :: ageclass_since_anthrodist ! what is the equivalent age class for ! time-since-anthropogenic-disturbance of secondary forest real(r8) :: store_max ! The target nutrient mass for storage element of interest [kg] real(r8) :: n_perm2 ! individuals per m2 for the whole column real(r8) :: dbh ! diameter ("at breast height") - real(r8) :: coage ! cohort age + real(r8) :: coage ! cohort age real(r8) :: npp_partition_error ! a check that the NPP partitions sum to carbon allocation real(r8) :: frac_canopy_in_bin ! fraction of a leaf's canopy that is within a given height bin real(r8) :: binbottom,bintop ! edges of height bins - + real(r8) :: gpp_cached ! variable used to cache gpp value in previous time step; for C13 discrimination ! The following are all carbon states, turnover and net allocation flux variables @@ -1781,14 +1775,14 @@ subroutine update_history_dyn(this,nc,nsites,sites) real(r8), parameter :: tiny = 1.e-5_r8 ! some small number real(r8), parameter :: reallytalltrees = 1000. ! some large number (m) - + integer :: tmp associate( hio_npatches_si => this%hvars(ih_npatches_si)%r81d, & hio_ncohorts_si => this%hvars(ih_ncohorts_si)%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_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, & @@ -1804,9 +1798,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_fire_nignitions_si => this%hvars(ih_fire_nignitions_si)%r81d, & hio_fire_fdi_si => this%hvars(ih_fire_fdi_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, & @@ -1816,7 +1808,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) 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_fragmentation_scaler_sl => this%hvars(ih_fragmentation_scaler_sl)%r82d, & + hio_fragmentation_scaler_sl => this%hvars(ih_fragmentation_scaler_sl)%r82d, & 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, & @@ -1825,16 +1817,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_litter_out_elem => this%hvars(ih_litter_out_elem)%r82d, & hio_seed_bank_elem => this%hvars(ih_seed_bank_elem)%r82d, & hio_seeds_in_local_elem => this%hvars(ih_seeds_in_local_elem)%r82d, & - hio_seed_in_extern_elem => this%hvars(ih_seeds_in_extern_elem)%r82d, & + hio_seed_in_extern_elem => this%hvars(ih_seeds_in_extern_elem)%r82d, & hio_seed_decay_elem => this%hvars(ih_seed_decay_elem)%r82d, & hio_seed_germ_elem => this%hvars(ih_seed_germ_elem)%r82d, & - 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, & @@ -1886,19 +1873,19 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_agb_si_scpf => this%hvars(ih_agb_si_scpf)%r82d, & hio_nplant_si_scpf => this%hvars(ih_nplant_si_scpf)%r82d, & hio_nplant_si_capf => this%hvars(ih_nplant_si_capf)%r82d, & - + hio_m1_si_scpf => this%hvars(ih_m1_si_scpf)%r82d, & hio_m2_si_scpf => this%hvars(ih_m2_si_scpf)%r82d, & hio_m3_si_scpf => this%hvars(ih_m3_si_scpf)%r82d, & hio_m4_si_scpf => this%hvars(ih_m4_si_scpf)%r82d, & hio_m5_si_scpf => this%hvars(ih_m5_si_scpf)%r82d, & hio_m6_si_scpf => this%hvars(ih_m6_si_scpf)%r82d, & - hio_m7_si_scpf => this%hvars(ih_m7_si_scpf)%r82d, & + hio_m7_si_scpf => this%hvars(ih_m7_si_scpf)%r82d, & hio_m8_si_scpf => this%hvars(ih_m8_si_scpf)%r82d, & hio_m9_si_scpf => this%hvars(ih_m9_si_scpf)%r82d, & hio_m10_si_scpf => this%hvars(ih_m10_si_scpf)%r82d, & hio_m10_si_capf => this%hvars(ih_m10_si_capf)%r82d, & - + hio_crownfiremort_si_scpf => this%hvars(ih_crownfiremort_si_scpf)%r82d, & hio_cambialfiremort_si_scpf => this%hvars(ih_cambialfiremort_si_scpf)%r82d, & @@ -1916,8 +1903,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m9_si_scls => this%hvars(ih_m9_si_scls)%r82d, & hio_m10_si_scls => this%hvars(ih_m10_si_scls)%r82d, & hio_m10_si_cacls => this%hvars(ih_m10_si_cacls)%r82d, & - - hio_c13disc_si_scpf => this%hvars(ih_c13disc_si_scpf)%r82d, & + + hio_c13disc_si_scpf => this%hvars(ih_c13disc_si_scpf)%r82d, & hio_cwd_elcwd => this%hvars(ih_cwd_elcwd)%r82d, & hio_cwd_ag_elem => this%hvars(ih_cwd_ag_elem)%r82d, & @@ -2029,8 +2016,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_cbal_err_fates_si => this%hvars(ih_cbal_err_fates_si)%r81d, & hio_err_fates_si => this%hvars(ih_err_fates_si)%r82d ) - - + + ! If we don't have dynamics turned on, we just abort these diagnostics @@ -2041,11 +2028,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! --------------------------------------------------------------------------------- ! Loop through the FATES scale hierarchy and fill the history IO arrays ! --------------------------------------------------------------------------------- - + do s = 1,nsites io_si = sites(s)%h_gid - + ! 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 @@ -2077,7 +2064,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_site_nchilldays_si(io_si) = real(sites(s)%nchilldays,r8) hio_site_ncolddays_si(io_si) = real(sites(s)%ncolddays,r8) - + hio_gdd_si(io_si) = sites(s)%grow_deg_days hio_cleafoff_si(io_si) = real(model_day_int - sites(s)%cleafoffdate,r8) hio_cleafon_si(io_si) = real(model_day_int - sites(s)%cleafondate,r8) @@ -2091,11 +2078,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! track total wood product accumulation at the site level hio_woodproduct_si(io_si) = sites(s)%resources_management%trunk_product_site & - * AREA_INV * g_per_kg - + * AREA_INV + ! site-level fire variables hio_nesterov_fire_danger_si(io_si) = sites(s)%acc_NI - hio_fire_nignitions_si(io_si) = sites(s)%NF_successful + hio_fire_nignitions_si(io_si) = sites(s)%NF_successful / m2_per_km2 / sec_per_day hio_fire_fdi_si(io_si) = sites(s)%FDI ! If hydraulics are turned on, track the error terms @@ -2134,7 +2121,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ipa = 0 cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - + ! Increment the number of patches per site hio_npatches_si(io_si) = hio_npatches_si(io_si) + 1._r8 @@ -2160,9 +2147,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then hio_fraction_secondary_forest_si(io_si) = hio_fraction_secondary_forest_si(io_si) + & cpatch%area * AREA_INV - + ageclass_since_anthrodist = get_age_class_index(cpatch%age_since_anthro_disturbance) - + hio_agesince_anthrodist_si_age(io_si,ageclass_since_anthrodist) = & hio_agesince_anthrodist_si_age(io_si,ageclass_since_anthrodist) & + cpatch%area * AREA_INV @@ -2171,7 +2158,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_secondaryforest_area_si_age(io_si,cpatch%age_class) & + 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 @@ -2182,39 +2169,39 @@ subroutine update_history_dyn(this,nc,nsites,sites) end do hio_area_burnt_si_age(io_si,cpatch%age_class) = hio_area_burnt_si_age(io_si,cpatch%age_class) + & - cpatch%frac_burnt * cpatch%area * AREA_INV + cpatch%frac_burnt * cpatch%area * AREA_INV / s_per_day ! hio_fire_rate_of_spread_front_si_age(io_si, cpatch%age_class) = hio_fire_rate_of_spread_si_age(io_si, cpatch%age_class) + & ! cpatch%ros_front * cpatch*frac_burnt * cpatch%area * AREA_INV hio_fire_intensity_si_age(io_si, cpatch%age_class) = hio_fire_intensity_si_age(io_si, cpatch%age_class) + & - cpatch%FI * cpatch%frac_burnt * cpatch%area * AREA_INV + cpatch%FI * cpatch%frac_burnt * cpatch%area * AREA_INV * J_per_kJ 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 * g_per_kg * cpatch%area * AREA_INV - + 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)) - + ft = ccohort%pft call sizetype_class_index(ccohort%dbh, ccohort%pft, ccohort%size_class, ccohort%size_by_pft_class) call coagetype_class_index(ccohort%coage, ccohort%pft, & ccohort%coage_class, ccohort%coage_by_pft_class) - + ! Increment the number of cohorts per site hio_ncohorts_si(io_si) = hio_ncohorts_si(io_si) + 1._r8 - + 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 @@ -2242,7 +2229,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! write(fates_log(),*) ' c_area, treelai, frac_canopy_in_bin:', ccohort%c_area, ccohort%treelai, frac_canopy_in_bin ! endif end do - + if (ccohort%canopy_layer .eq. 1) then ! calculate the area of canopy that is within each height bin hio_canopy_height_dist_si_height(io_si,height_bin_max) = & @@ -2252,114 +2239,108 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! Update biomass components ! Mass pools [kgC] do el = 1, num_elements - + sapw_m = ccohort%prt%GetState(sapw_organ, element_list(el)) struct_m = ccohort%prt%GetState(struct_organ, element_list(el)) leaf_m = ccohort%prt%GetState(leaf_organ, element_list(el)) fnrt_m = ccohort%prt%GetState(fnrt_organ, element_list(el)) store_m = ccohort%prt%GetState(store_organ, element_list(el)) repro_m = ccohort%prt%GetState(repro_organ, element_list(el)) - - + + alive_m = leaf_m + fnrt_m + sapw_m total_m = alive_m + store_m + struct_m - + ! Plant multi-element states and fluxes ! Zero states, and set the fluxes if( element_list(el).eq.carbon12_element )then this%hvars(ih_storec_si)%r81d(io_si) = & - this%hvars(ih_storec_si)%r81d(io_si) + ccohort%n * store_m + this%hvars(ih_storec_si)%r81d(io_si) + ccohort%n * store_m / m2_per_ha this%hvars(ih_leafc_si)%r81d(io_si) = & - this%hvars(ih_leafc_si)%r81d(io_si) + ccohort%n * leaf_m + this%hvars(ih_leafc_si)%r81d(io_si) + ccohort%n * leaf_m / m2_per_ha this%hvars(ih_fnrtc_si)%r81d(io_si) = & - this%hvars(ih_fnrtc_si)%r81d(io_si) + ccohort%n * fnrt_m + this%hvars(ih_fnrtc_si)%r81d(io_si) + ccohort%n * fnrt_m / m2_per_ha this%hvars(ih_reproc_si)%r81d(io_si) = & - this%hvars(ih_reproc_si)%r81d(io_si)+ ccohort%n * repro_m + this%hvars(ih_reproc_si)%r81d(io_si)+ ccohort%n * repro_m / m2_per_ha this%hvars(ih_sapwc_si)%r81d(io_si) = & - this%hvars(ih_sapwc_si)%r81d(io_si)+ ccohort%n * sapw_m + this%hvars(ih_sapwc_si)%r81d(io_si)+ ccohort%n * sapw_m / m2_per_ha this%hvars(ih_totvegc_si)%r81d(io_si) = & - this%hvars(ih_totvegc_si)%r81d(io_si)+ ccohort%n * total_m - - hio_bleaf_si(io_si) = hio_bleaf_si(io_si) + n_perm2 * leaf_m * g_per_kg - hio_bstore_si(io_si) = hio_bstore_si(io_si) + n_perm2 * store_m * g_per_kg - hio_bdead_si(io_si) = hio_bdead_si(io_si) + n_perm2 * struct_m * g_per_kg - hio_balive_si(io_si) = hio_balive_si(io_si) + n_perm2 * alive_m * g_per_kg - - hio_bsapwood_si(io_si) = hio_bsapwood_si(io_si) + n_perm2 * sapw_m * g_per_kg - hio_bfineroot_si(io_si) = hio_bfineroot_si(io_si) + n_perm2 * fnrt_m * g_per_kg - hio_btotal_si(io_si) = hio_btotal_si(io_si) + n_perm2 * total_m * g_per_kg - - hio_agb_si(io_si) = hio_agb_si(io_si) + n_perm2 * g_per_kg * & + this%hvars(ih_totvegc_si)%r81d(io_si)+ ccohort%n * total_m / m2_per_ha + + hio_bdead_si(io_si) = hio_bdead_si(io_si) + n_perm2 * struct_m + hio_balive_si(io_si) = hio_balive_si(io_si) + n_perm2 * alive_m + + hio_agb_si(io_si) = hio_agb_si(io_si) + n_perm2 * & ( leaf_m + (sapw_m + struct_m + store_m) * prt_params%allom_agb_frac(ccohort%pft) ) - - + + ! Update PFT partitioned biomass components hio_leafbiomass_si_pft(io_si,ft) = hio_leafbiomass_si_pft(io_si,ft) + & - (ccohort%n * AREA_INV) * leaf_m * g_per_kg - + (ccohort%n * AREA_INV) * leaf_m + hio_storebiomass_si_pft(io_si,ft) = hio_storebiomass_si_pft(io_si,ft) + & (ccohort%n * AREA_INV) * store_m * g_per_kg - + hio_nindivs_si_pft(io_si,ft) = hio_nindivs_si_pft(io_si,ft) + & ccohort%n * AREA_INV - + hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & - (ccohort%n * AREA_INV) * total_m * g_per_kg + (ccohort%n * AREA_INV) * total_m ! update total biomass per age bin hio_biomass_si_age(io_si,cpatch%age_class) = hio_biomass_si_age(io_si,cpatch%age_class) & + total_m * ccohort%n * AREA_INV - + ! track the total biomass on all secondary lands if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then hio_biomass_secondary_forest_si(io_si) = hio_biomass_secondary_forest_si(io_si) + & total_m * ccohort%n * AREA_INV endif - + elseif(element_list(el).eq.nitrogen_element)then store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) this%hvars(ih_storen_si)%r81d(io_si) = & - this%hvars(ih_storen_si)%r81d(io_si) + ccohort%n * store_m + this%hvars(ih_storen_si)%r81d(io_si) + ccohort%n * store_m / m2_per_ha this%hvars(ih_storentfrac_si)%r81d(io_si) = & - this%hvars(ih_storentfrac_si)%r81d(io_si) + ccohort%n * store_max + this%hvars(ih_storentfrac_si)%r81d(io_si) + ccohort%n * store_max / m2_per_ha this%hvars(ih_leafn_si)%r81d(io_si) = & - this%hvars(ih_leafn_si)%r81d(io_si) + ccohort%n * leaf_m + this%hvars(ih_leafn_si)%r81d(io_si) + ccohort%n * leaf_m / m2_per_ha this%hvars(ih_fnrtn_si)%r81d(io_si) = & - this%hvars(ih_fnrtn_si)%r81d(io_si) + ccohort%n * fnrt_m + this%hvars(ih_fnrtn_si)%r81d(io_si) + ccohort%n * fnrt_m / m2_per_ha this%hvars(ih_repron_si)%r81d(io_si) = & - this%hvars(ih_repron_si)%r81d(io_si) + ccohort%n * repro_m + this%hvars(ih_repron_si)%r81d(io_si) + ccohort%n * repro_m / m2_per_ha this%hvars(ih_sapwn_si)%r81d(io_si) = & - this%hvars(ih_sapwn_si)%r81d(io_si) + ccohort%n * sapw_m + this%hvars(ih_sapwn_si)%r81d(io_si) + ccohort%n * sapw_m / m2_per_ha this%hvars(ih_totvegn_si)%r81d(io_si) = & - this%hvars(ih_totvegn_si)%r81d(io_si) + ccohort%n * total_m + this%hvars(ih_totvegn_si)%r81d(io_si) + ccohort%n * total_m / m2_per_ha + - elseif(element_list(el).eq.phosphorus_element) then store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) - + this%hvars(ih_storep_si)%r81d(io_si) = & - this%hvars(ih_storep_si)%r81d(io_si) + ccohort%n * store_m + this%hvars(ih_storep_si)%r81d(io_si) + ccohort%n * store_m / m2_per_ha this%hvars(ih_storeptfrac_si)%r81d(io_si) = & - this%hvars(ih_storeptfrac_si)%r81d(io_si) + ccohort%n * store_max + this%hvars(ih_storeptfrac_si)%r81d(io_si) + ccohort%n * store_max / m2_per_ha this%hvars(ih_leafp_si)%r81d(io_si) = & - this%hvars(ih_leafp_si)%r81d(io_si) + ccohort%n * leaf_m + this%hvars(ih_leafp_si)%r81d(io_si) + ccohort%n * leaf_m / m2_per_ha this%hvars(ih_fnrtp_si)%r81d(io_si) = & - this%hvars(ih_fnrtp_si)%r81d(io_si) + ccohort%n * fnrt_m + this%hvars(ih_fnrtp_si)%r81d(io_si) + ccohort%n * fnrt_m / m2_per_ha this%hvars(ih_reprop_si)%r81d(io_si) = & - this%hvars(ih_reprop_si)%r81d(io_si) + ccohort%n * repro_m + this%hvars(ih_reprop_si)%r81d(io_si) + ccohort%n * repro_m / m2_per_ha this%hvars(ih_sapwp_si)%r81d(io_si) = & - this%hvars(ih_sapwp_si)%r81d(io_si) + ccohort%n * sapw_m + this%hvars(ih_sapwp_si)%r81d(io_si) + ccohort%n * sapw_m / m2_per_ha this%hvars(ih_totvegp_si)%r81d(io_si) = & - this%hvars(ih_totvegp_si)%r81d(io_si)+ ccohort%n * total_m + this%hvars(ih_totvegp_si)%r81d(io_si)+ ccohort%n * total_m / m2_per_ha end if - + end do - + ! Update PFT crown area @@ -2374,13 +2355,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! update pft-resolved NPP and GPP fluxes hio_gpp_si_pft(io_si, ft) = hio_gpp_si_pft(io_si, ft) + & - ccohort%gpp_acc_hold * n_perm2 + ccohort%gpp_acc_hold * n_perm2 / days_per_year / sec_per_day hio_npp_si_pft(io_si, ft) = hio_npp_si_pft(io_si, ft) + & - ccohort%npp_acc_hold * n_perm2 - + ccohort%npp_acc_hold * n_perm2 / days_per_year / sec_per_day + - ! Site by Size-Class x PFT (SCPF) + ! Site by Size-Class x PFT (SCPF) ! ------------------------------------------------------------------------ dbh = ccohort%dbh !-0.5*(1./365.25)*ccohort%ddbhdt @@ -2395,7 +2376,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) leaf_m_turnover = ccohort%prt%GetTurnover(leaf_organ, carbon12_element) * days_per_year fnrt_m_turnover = ccohort%prt%GetTurnover(fnrt_organ, carbon12_element) * days_per_year struct_m_turnover = ccohort%prt%GetTurnover(struct_organ, carbon12_element) * days_per_year - + ! Net change from allocation and transport [kgC/day] * [day/yr] = [kgC/yr] sapw_m_net_alloc = ccohort%prt%GetNetAlloc(sapw_organ, carbon12_element) * days_per_year store_m_net_alloc = ccohort%prt%GetNetAlloc(store_organ, carbon12_element) * days_per_year @@ -2413,22 +2394,22 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_npp_croot_si(io_si) = hio_npp_croot_si(io_si) + (sapw_m_net_alloc + struct_m_net_alloc) * n_perm2 * & (1._r8-prt_params%allom_agb_frac(ccohort%pft)) hio_npp_stor_si(io_si) = hio_npp_stor_si(io_si) + store_m_net_alloc * n_perm2 - + associate( scpf => ccohort%size_by_pft_class, & scls => ccohort%size_class, & cacls => ccohort%coage_class, & capf => ccohort%coage_by_pft_class) - - + + gpp_cached = hio_gpp_si_scpf(io_si,scpf) - + hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + & n_perm2*ccohort%gpp_acc_hold ! [kgC/m2/yr] hio_npp_totl_si_scpf(io_si,scpf) = hio_npp_totl_si_scpf(io_si,scpf) + & ccohort%npp_acc_hold *n_perm2 - - + + hio_npp_leaf_si_scpf(io_si,scpf) = hio_npp_leaf_si_scpf(io_si,scpf) + & leaf_m_net_alloc*n_perm2 hio_npp_fnrt_si_scpf(io_si,scpf) = hio_npp_fnrt_si_scpf(io_si,scpf) + & @@ -2474,7 +2455,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%lmort_direct+ccohort%lmort_collateral+ccohort%lmort_infra) * ccohort%n hio_m8_si_scpf(io_si,scpf) = hio_m8_si_scpf(io_si,scpf) + ccohort%frmort*ccohort%n hio_m9_si_scpf(io_si,scpf) = hio_m9_si_scpf(io_si,scpf) + ccohort%smort*ccohort%n - + if (hlm_use_cohort_age_tracking .eq.itrue) then hio_m10_si_scpf(io_si,scpf) = hio_m10_si_scpf(io_si,scpf) + ccohort%asmort*ccohort%n hio_m10_si_capf(io_si,capf) = hio_m10_si_capf(io_si,capf) + ccohort%asmort*ccohort%n @@ -2482,7 +2463,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m10_si_cacls(io_si,cacls) = hio_m10_si_cacls(io_si,cacls)+ & ccohort%asmort*ccohort%n end if - + hio_m1_si_scls(io_si,scls) = hio_m1_si_scls(io_si,scls) + ccohort%bmort*ccohort%n hio_m2_si_scls(io_si,scls) = hio_m2_si_scls(io_si,scls) + ccohort%hmort*ccohort%n hio_m3_si_scls(io_si,scls) = hio_m3_si_scls(io_si,scls) + ccohort%cmort*ccohort%n @@ -2491,9 +2472,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m8_si_scls(io_si,scls) = hio_m8_si_scls(io_si,scls) + & ccohort%frmort*ccohort%n hio_m9_si_scls(io_si,scls) = hio_m9_si_scls(io_si,scls) + ccohort%smort*ccohort%n - - - + + + !C13 discrimination if(gpp_cached + ccohort%gpp_acc_hold > 0.0_r8)then hio_c13disc_si_scpf(io_si,scpf) = ((hio_c13disc_si_scpf(io_si,scpf) * gpp_cached) + & @@ -2521,8 +2502,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) repro_m = ccohort%prt%GetState(repro_organ, carbon12_element) alive_m = leaf_m + fnrt_m + sapw_m total_m = alive_m + store_m + struct_m - - + + ! number density by size and biomass hio_agb_si_scls(io_si,scls) = hio_agb_si_scls(io_si,scls) + & total_m * ccohort%n * prt_params%allom_agb_frac(ccohort%pft) * AREA_INV @@ -2537,22 +2518,22 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! update size-class x patch-age related quantities iscag = get_sizeage_class_index(ccohort%dbh,cpatch%age) - + hio_nplant_si_scag(io_si,iscag) = hio_nplant_si_scag(io_si,iscag) + ccohort%n hio_nplant_si_scls(io_si,scls) = hio_nplant_si_scls(io_si,scls) + ccohort%n - - + + ! update size, age, and PFT - indexed quantities iscagpft = get_sizeagepft_class_index(ccohort%dbh,cpatch%age,ccohort%pft) - + hio_nplant_si_scagpft(io_si,iscagpft) = hio_nplant_si_scagpft(io_si,iscagpft) + ccohort%n ! update age and PFT - indexed quantities iagepft = get_agepft_class_index(cpatch%age,ccohort%pft) - + hio_npp_si_agepft(io_si,iagepft) = hio_npp_si_agepft(io_si,iagepft) + & ccohort%n * ccohort%npp_acc_hold * AREA_INV @@ -2563,7 +2544,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) if (ccohort%canopy_layer .eq. 1) then hio_nplant_canopy_si_scag(io_si,iscag) = hio_nplant_canopy_si_scag(io_si,iscag) + ccohort%n hio_mortality_canopy_si_scag(io_si,iscag) = hio_mortality_canopy_si_scag(io_si,iscag) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n hio_ddbh_canopy_si_scag(io_si,iscag) = hio_ddbh_canopy_si_scag(io_si,iscag) + & ccohort%ddbhdt*ccohort%n @@ -2572,7 +2553,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_m * ccohort%n - hio_canopy_biomass_si(io_si) = hio_canopy_biomass_si(io_si) + n_perm2 * total_m * g_per_kg + hio_canopy_biomass_si(io_si) = hio_canopy_biomass_si(io_si) + n_perm2 * total_m !hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & ! (ccohort%bmort + ccohort%hmort + ccohort%cmort + & @@ -2580,7 +2561,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%frmort + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%frmort + & ccohort%smort + ccohort%asmort) * ccohort%n + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & ccohort%n * sec_per_day * days_per_year @@ -2614,17 +2595,17 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%n * sec_per_day * days_per_year hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * & total_m * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_m * & ccohort%n * g_per_kg * ha_per_m2 - + hio_carbon_balance_canopy_si_scls(io_si,scls) = hio_carbon_balance_canopy_si_scls(io_si,scls) + & ccohort%n * ccohort%npp_acc_hold - - + + hio_leaf_md_canopy_si_scls(io_si,scls) = hio_leaf_md_canopy_si_scls(io_si,scls) + & leaf_m_turnover * ccohort%n hio_root_md_canopy_si_scls(io_si,scls) = hio_root_md_canopy_si_scls(io_si,scls) + & @@ -2650,7 +2631,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) repro_m_net_alloc * ccohort%n hio_npp_stor_canopy_si_scls(io_si,scls) = hio_npp_stor_canopy_si_scls(io_si,scls) + & store_m_net_alloc * ccohort%n - + hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) = & hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) + & ccohort%canopy_layer_yesterday * ccohort%n @@ -2666,10 +2647,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_bleaf_understory_si_scpf(io_si,scpf) = hio_bleaf_understory_si_scpf(io_si,scpf) + & leaf_m * ccohort%n hio_understory_biomass_si(io_si) = hio_understory_biomass_si(io_si) + & - n_perm2 * total_m * g_per_kg + n_perm2 * total_m !hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & - ! (ccohort%bmort + ccohort%hmort + ccohort%cmort + + ! (ccohort%bmort + ccohort%hmort + ccohort%cmort + ! ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & @@ -2702,13 +2683,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! sum of all mortality hio_mortality_understory_si_scls(io_si,scls) = hio_mortality_understory_si_scls(io_si,scls) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & ccohort%n * sec_per_day * days_per_year - + hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * & total_m * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_m * & @@ -2742,7 +2723,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) repro_m_net_alloc * ccohort%n hio_npp_stor_understory_si_scls(io_si,scls) = hio_npp_stor_understory_si_scls(io_si,scls) + & store_m_net_alloc * ccohort%n - + hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) = & hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) + & ccohort%canopy_layer_yesterday * ccohort%n @@ -2771,7 +2752,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) i_scpf = (ccohort%pft-1)*nlevsclass+1 hio_growthflux_si_scpf(io_si,i_scpf) = hio_growthflux_si_scpf(io_si,i_scpf) + ccohort%n * days_per_year ccohort%size_class_lasttimestep = 1 - + end if ! resolve some canopy area profiles, both total and of occupied leaves @@ -2784,34 +2765,30 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_crownarea_si_cnlf(io_si, cnlf_indx) = hio_crownarea_si_cnlf(io_si, cnlf_indx) + & ccohort%c_area / AREA end do - + ccohort => ccohort%taller enddo ! cohort loop - + ! Patch specific variables that are already calculated - ! These things are all duplicated. Should they all be converted to LL or array structures RF? + ! 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 - + ! Update Fire Variables - hio_spitfire_ros_si(io_si) = hio_spitfire_ros_si(io_si) + cpatch%ROS_front * cpatch%area * AREA_INV - hio_fire_ros_area_product_si(io_si)= hio_fire_ros_area_product_si(io_si) + & - cpatch%frac_burnt * cpatch%ROS_front * cpatch%area * AREA_INV - hio_effect_wspeed_si(io_si) = hio_effect_wspeed_si(io_si) + cpatch%effect_wspeed * cpatch%area * AREA_INV + hio_spitfire_ros_si(io_si) = hio_spitfire_ros_si(io_si) + cpatch%ROS_front * cpatch%area * AREA_INV / sec_per_min + hio_effect_wspeed_si(io_si) = hio_effect_wspeed_si(io_si) + cpatch%effect_wspeed * cpatch%area * AREA_INV / sec_per_min 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_intensity_si(io_si) = hio_fire_intensity_si(io_si) + cpatch%FI * cpatch%area * AREA_INV * J_per_kJ + hio_fire_area_si(io_si) = hio_fire_area_si(io_si) + cpatch%frac_burnt * cpatch%area * AREA_INV / sec_per_day 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_sav_si(io_si) = hio_fire_fuel_sav_si(io_si) + cpatch%fuel_sav * cpatch%area * AREA_INV / m_per_cm 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 + hio_sum_fuel_si(io_si) = hio_sum_fuel_si(io_si) + cpatch%sum_fuel * cpatch%area * AREA_INV do ilyr = 1,sites(s)%nlevsoil hio_fragmentation_scaler_sl(io_si,ilyr) = hio_fragmentation_scaler_sl(io_si,ilyr) + cpatch%fragmentation_scaler(ilyr) * cpatch%area * AREA_INV end do - + do i_fuel = 1,nfsc i_agefuel = get_agefuel_class_index(cpatch%age,i_fuel) @@ -2830,23 +2807,23 @@ subroutine update_history_dyn(this,nc,nsites,sites) 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 + cpatch%FI * cpatch%frac_burnt * cpatch%area * AREA_INV * J_per_kJ ! Update Litter Flux Variables litt_c => cpatch%litter(element_pos(carbon12_element)) flux_diags_c => sites(s)%flux_diags(element_pos(carbon12_element)) - + do i_cwd = 1, ncwd hio_cwd_ag_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_si_cwdsc(io_si, i_cwd) + & litt_c%ag_cwd(i_cwd)*cpatch%area * AREA_INV * g_per_kg hio_cwd_bg_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_si_cwdsc(io_si, i_cwd) + & sum(litt_c%bg_cwd(i_cwd,:)) * cpatch%area * AREA_INV * g_per_kg - + hio_cwd_ag_out_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_out_si_cwdsc(io_si, i_cwd) + & litt_c%ag_cwd_frag(i_cwd)*cpatch%area * AREA_INV * g_per_kg - + hio_cwd_bg_out_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_out_si_cwdsc(io_si, i_cwd) + & sum(litt_c%bg_cwd_frag(i_cwd,:)) * cpatch%area * AREA_INV * g_per_kg @@ -2886,7 +2863,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m6_si_scls(io_si,i_scls) = hio_m6_si_scls(io_si,i_scls) + & (sites(s)%term_nindivs_canopy(i_scls,i_pft) + & sites(s)%term_nindivs_ustory(i_scls,i_pft)) * days_per_year - + ! ! add termination mortality to canopy and understory mortality @@ -2907,8 +2884,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m4_si_scpf(io_si,i_scpf) = sites(s)%imort_rate(i_scls, i_pft) hio_m4_si_scls(io_si,i_scls) = hio_m4_si_scls(io_si,i_scls) + sites(s)%imort_rate(i_scls, i_pft) ! - ! add imort to other mortality terms. consider imort as understory mortality even if it happens in - ! cohorts that may have been promoted as part of the patch creation, and use the pre-calculated site-level + ! add imort to other mortality terms. consider imort as understory mortality even if it happens in + ! cohorts that may have been promoted as part of the patch creation, and use the pre-calculated site-level ! values to avoid biasing the results by the dramatically-reduced number densities in cohorts that are subject to imort hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & sites(s)%imort_rate(i_scls, i_pft) @@ -2946,10 +2923,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! carbon flux associated with mortality of trees dying by fire hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & sites(s)%fmort_carbonflux_canopy - + hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & sites(s)%fmort_carbonflux_ustory - + ! ! for scag variables, also treat as happening in the newly-disurbed patch @@ -2963,13 +2940,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) sites(s)%growthflux_fusion(i_scls, i_pft) * days_per_year - - + + end do end do ! - + ! treat carbon flux from imort the same way hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & sites(s)%imort_carbonflux @@ -2988,7 +2965,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! pass the recruitment rate as a flux to the history, and then reset the recruitment buffer do i_pft = 1, numpft - hio_recruitment_si_pft(io_si,i_pft) = sites(s)%recruitment_rate(i_pft) * days_per_year + hio_recruitment_si_pft(io_si,i_pft) = sites(s)%recruitment_rate(i_pft) * days_per_year / m2_per_ha end do sites(s)%recruitment_rate(:) = 0._r8 @@ -2997,21 +2974,21 @@ subroutine update_history_dyn(this,nc,nsites,sites) do i_scls = 1,nlevsclass i_scpf = (i_pft-1)*nlevsclass + i_scls - hio_mortality_si_pft(io_si,i_pft) = hio_mortality_si_pft(io_si,i_pft) + & + hio_mortality_si_pft(io_si,i_pft) = (hio_mortality_si_pft(io_si,i_pft) + & hio_m1_si_scpf(io_si,i_scpf) + & hio_m2_si_scpf(io_si,i_scpf) + & hio_m3_si_scpf(io_si,i_scpf) + & hio_m4_si_scpf(io_si,i_scpf) + & hio_m5_si_scpf(io_si,i_scpf) + & hio_m6_si_scpf(io_si,i_scpf) + & - hio_m7_si_scpf(io_si,i_scpf) + & + hio_m7_si_scpf(io_si,i_scpf) + & hio_m8_si_scpf(io_si,i_scpf) + & hio_m9_si_scpf(io_si,i_scpf) + & - hio_m10_si_scpf(io_si,i_scpf) + hio_m10_si_scpf(io_si,i_scpf)) / m2_per_ha end do end do - + ! ------------------------------------------------------------------------------ ! Some carbon only litter diagnostics (legacy) ! ------------------------------------------------------------------------------ @@ -3022,7 +2999,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) sum(flux_diags%cwd_bg_input(:)) + & sum(flux_diags%leaf_litter_input(:)) + & sum(flux_diags%root_litter_input(:))) * & - g_per_kg * AREA_INV * days_per_sec + AREA_INV * days_per_sec hio_litter_out_si(io_si) = 0._r8 hio_seed_bank_si(io_si) = 0._r8 @@ -3030,32 +3007,32 @@ subroutine update_history_dyn(this,nc,nsites,sites) cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - + litt => cpatch%litter(element_pos(carbon12_element)) - + area_frac = cpatch%area * AREA_INV - + ! Sum up all output fluxes (fragmentation) kgC/m2/day -> gC/m2/s hio_litter_out_si(io_si) = hio_litter_out_si(io_si) + & (sum(litt%leaf_fines_frag(:)) + & sum(litt%root_fines_frag(:,:)) + & sum(litt%ag_cwd_frag(:)) + & sum(litt%bg_cwd_frag(:,:))) * & - area_frac * g_per_kg * days_per_sec + area_frac * days_per_sec ! Sum up total seed bank (germinated and ungerminated) hio_seed_bank_si(io_si) = hio_seed_bank_si(io_si) + & (sum(litt%seed(:))+sum(litt%seed_germ(:))) * & - area_frac * g_per_kg * days_per_sec + area_frac * days_per_sec ! Sum up the input flux into the seed bank (local and external) hio_seeds_in_si(io_si) = hio_seeds_in_si(io_si) + & (sum(litt%seed_in_local(:)) + sum(litt%seed_in_extern(:))) * & - area_frac * g_per_kg * days_per_sec - + area_frac * days_per_sec + cpatch => cpatch%younger end do - + ! ------------------------------------------------------------------------------ ! Diagnostics discretized by element type @@ -3064,15 +3041,15 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_cwd_elcwd(io_si,:) = 0._r8 do el = 1, num_elements - + flux_diags => sites(s)%flux_diags(el) - + ! Sum up all input litter fluxes (above below, fines, cwd) [kg/ha/day] - hio_litter_in_elem(io_si, el) = & - sum(flux_diags%cwd_ag_input(:)) + & + hio_litter_in_elem(io_si, el) = & + sum(flux_diags%cwd_ag_input(:)) + & sum(flux_diags%cwd_bg_input(:)) + & sum(flux_diags%leaf_litter_input(:)) + & - sum(flux_diags%root_litter_input(:)) + sum(flux_diags%root_litter_input(:)) / m2_per_ha / sec_per_day hio_cwd_ag_elem(io_si,el) = 0._r8 hio_cwd_bg_elem(io_si,el) = 0._r8 @@ -3085,7 +3062,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_seeds_in_local_elem(io_si,el) = 0._r8 hio_seed_in_extern_elem(io_si,el) = 0._r8 hio_litter_out_elem(io_si,el) = 0._r8 - + ! Plant multi-element states and fluxes ! Zero states, and set the fluxes if(element_list(el).eq.carbon12_element)then @@ -3098,12 +3075,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_cefflux_scpf)%r82d(io_si,:) = & sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) - - this%hvars(ih_cefflux_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) - + + this%hvars(ih_cefflux_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) / & + m2_per_ha / sec_per_day + elseif(element_list(el).eq.nitrogen_element)then - + this%hvars(ih_totvegn_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_leafn_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_fnrtn_scpf)%r82d(io_si,:) = 0._r8 @@ -3118,14 +3096,16 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_nneed_scpf)%r82d(io_si,:) = & sites(s)%flux_diags(el)%nutrient_need_scpf(:) - + this%hvars(ih_nneed_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_need_scpf(:),dim=1) + sum(sites(s)%flux_diags(el)%nutrient_need_scpf(:),dim=1) / & + m2_per_ha / sec_per_day + + this%hvars(ih_nefflux_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) / & + m2_per_ha / sec_per_day + - this%hvars(ih_nefflux_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) - - elseif(element_list(el).eq.phosphorus_element)then this%hvars(ih_totvegp_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_leafp_scpf)%r82d(io_si,:) = 0._r8 @@ -3137,16 +3117,18 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_reprop_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_pefflux_scpf)%r82d(io_si,:) = & sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) - + this%hvars(ih_pneed_scpf)%r82d(io_si,:) = & sites(s)%flux_diags(el)%nutrient_need_scpf(:) this%hvars(ih_pneed_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_need_scpf(:),dim=1) - - this%hvars(ih_pefflux_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) - + sum(sites(s)%flux_diags(el)%nutrient_need_scpf(:),dim=1) / & + m2_per_ha / sec_per_day + + this%hvars(ih_pefflux_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) / & + m2_per_ha / sec_per_day + end if @@ -3157,48 +3139,48 @@ subroutine update_history_dyn(this,nc,nsites,sites) area_frac = cpatch%area * AREA_INV - - + + ! Sum up all output fluxes (fragmentation) hio_litter_out_elem(io_si,el) = hio_litter_out_elem(io_si,el) + & (sum(litt%leaf_fines_frag(:)) + & sum(litt%root_fines_frag(:,:)) + & - sum(litt%ag_cwd_frag(:)) + & + sum(litt%ag_cwd_frag(:)) + & sum(litt%bg_cwd_frag(:,:)) + & sum(litt%seed_decay(:)) + & - sum(litt%seed_germ_decay(:))) * cpatch%area + sum(litt%seed_germ_decay(:))) * cpatch%area / m2_per_ha / sec_per_day - hio_seed_bank_elem(io_si,el) = hio_seed_bank_elem(io_si,el) + & - sum(litt%seed(:)) * cpatch%area + hio_seed_bank_elem(io_si,el) = hio_seed_bank_elem(io_si,el) + & + sum(litt%seed(:)) * cpatch%area / m2_per_ha hio_seed_germ_elem(io_si,el) = hio_seed_germ_elem(io_si,el) + & - sum(litt%seed_germ(:)) * cpatch%area - - hio_seed_decay_elem(io_si,el) = hio_seed_decay_elem(io_si,el) + & + sum(litt%seed_germ(:)) * cpatch%area / m2_per_ha / sec_per_day + + hio_seed_decay_elem(io_si,el) = hio_seed_decay_elem(io_si,el) + & sum(litt%seed_decay(:) + litt%seed_germ_decay(:) ) * cpatch%area - hio_seeds_in_local_elem(io_si,el) = hio_seeds_in_local_elem(io_si,el) + & - sum(litt%seed_in_local(:)) * cpatch%area + hio_seeds_in_local_elem(io_si,el) = hio_seeds_in_local_elem(io_si,el) + & + sum(litt%seed_in_local(:)) * cpatch%area / m2_per_ha / sec_per_day - hio_seed_in_extern_elem(io_si,el) = hio_seed_in_extern_elem(io_si,el) + & - sum(litt%seed_in_extern(:)) * cpatch%area + hio_seed_in_extern_elem(io_si,el) = hio_seed_in_extern_elem(io_si,el) + & + sum(litt%seed_in_extern(:)) * cpatch%area / m2_per_ha / sec_per_day ! Litter State Variables hio_cwd_ag_elem(io_si,el) = hio_cwd_ag_elem(io_si,el) + & sum(litt%ag_cwd(:)) * cpatch%area - + hio_cwd_bg_elem(io_si,el) = hio_cwd_bg_elem(io_si,el) + & sum(litt%bg_cwd(:,:)) * cpatch%area - - hio_fines_ag_elem(io_si,el) = hio_fines_ag_elem(io_si,el) + & + + hio_fines_ag_elem(io_si,el) = hio_fines_ag_elem(io_si,el) + & sum(litt%leaf_fines(:)) * cpatch%area - + hio_fines_bg_elem(io_si,el) = hio_fines_bg_elem(io_si,el) + & sum(litt%root_fines(:,:)) * cpatch%area do cwd=1,ncwd elcwd = (el-1)*ncwd+cwd - hio_cwd_elcwd(io_si,elcwd) = hio_cwd_elcwd(io_si,elcwd) + & + hio_cwd_elcwd(io_si,elcwd) = hio_cwd_elcwd(io_si,elcwd) + & (litt%ag_cwd(cwd) + sum(litt%bg_cwd(cwd,:))) * cpatch%area end do @@ -3214,78 +3196,78 @@ subroutine update_history_dyn(this,nc,nsites,sites) store_m = ccohort%prt%GetState(store_organ, element_list(el)) repro_m = ccohort%prt%GetState(repro_organ, element_list(el)) total_m = sapw_m+struct_m+leaf_m+fnrt_m+store_m+repro_m - - + + i_scpf = ccohort%size_by_pft_class if(element_list(el).eq.carbon12_element)then - this%hvars(ih_totvegc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_totvegc_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_totvegc_scpf)%r82d(io_si,i_scpf) + total_m * ccohort%n - this%hvars(ih_leafc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_leafc_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_leafc_scpf)%r82d(io_si,i_scpf) + leaf_m * ccohort%n - this%hvars(ih_fnrtc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_fnrtc_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_fnrtc_scpf)%r82d(io_si,i_scpf) + fnrt_m * ccohort%n - this%hvars(ih_sapwc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_sapwc_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_sapwc_scpf)%r82d(io_si,i_scpf) + sapw_m * ccohort%n - this%hvars(ih_storec_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storec_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_storec_scpf)%r82d(io_si,i_scpf) + store_m * ccohort%n - this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) + repro_m * ccohort%n elseif(element_list(el).eq.nitrogen_element)then store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) - this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) + total_m * ccohort%n - this%hvars(ih_leafn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_leafn_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_leafn_scpf)%r82d(io_si,i_scpf) + leaf_m * ccohort%n - this%hvars(ih_fnrtn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_fnrtn_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_fnrtn_scpf)%r82d(io_si,i_scpf) + fnrt_m * ccohort%n - this%hvars(ih_sapwn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_sapwn_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_sapwn_scpf)%r82d(io_si,i_scpf) + sapw_m * ccohort%n - this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) + store_m * ccohort%n - this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) + repro_m * ccohort%n - + if (ccohort%canopy_layer .eq. 1) then - this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n else - this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n end if - + elseif(element_list(el).eq.phosphorus_element)then store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) - this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) + total_m * ccohort%n - this%hvars(ih_leafp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_leafp_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_leafp_scpf)%r82d(io_si,i_scpf) + leaf_m * ccohort%n - this%hvars(ih_fnrtp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_fnrtp_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_fnrtp_scpf)%r82d(io_si,i_scpf) + fnrt_m * ccohort%n - this%hvars(ih_sapwp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_sapwp_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_sapwp_scpf)%r82d(io_si,i_scpf) + sapw_m * ccohort%n - this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) + store_m * ccohort%n - this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) + repro_m * ccohort%n if (ccohort%canopy_layer .eq. 1) then - this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n else - this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n end if - + end if - + ccohort => ccohort%shorter end do - + cpatch => cpatch%younger end do @@ -3302,19 +3284,19 @@ subroutine update_history_dyn(this,nc,nsites,sites) do i_pft = 1, numpft do i_scls = 1,nlevsclass i_scpf = (i_pft-1)*nlevsclass + i_scls - + if( hio_nplant_canopy_si_scpf(io_si,i_scpf)>nearzero ) then this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) / & hio_nplant_canopy_si_scpf(io_si,i_scpf) end if - + if( hio_nplant_understory_si_scpf(io_si,i_scpf)>nearzero ) then this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) / & hio_nplant_understory_si_scpf(io_si,i_scpf) end if - + end do end do elseif(element_list(el).eq.phosphorus_element)then @@ -3330,19 +3312,19 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) /& hio_nplant_canopy_si_scpf(io_si,i_scpf) - + end if if( hio_nplant_understory_si_scpf(io_si,i_scpf)>nearzero ) then this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) /& hio_nplant_understory_si_scpf(io_si,i_scpf) end if - + end do end do end if end do - + ! pass demotion rates and associated carbon fluxes to history do i_scls = 1,nlevsclass hio_demotion_rate_si_scls(io_si,i_scls) = sites(s)%demotion_rate(i_scls) * days_per_year @@ -3354,10 +3336,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_promotion_carbonflux_si(io_si) = sites(s)%promotion_carbonflux * g_per_kg * ha_per_m2 * days_per_sec ! ! mortality-associated carbon fluxes - + hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & sites(s)%term_carbonflux_canopy * g_per_kg * days_per_sec * ha_per_m2 - + hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & sites(s)%term_carbonflux_ustory * g_per_kg * days_per_sec * ha_per_m2 @@ -3371,7 +3353,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) do i_cwd = 1, ncwd hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) + & flux_diags_c%cwd_ag_input(i_cwd) * g_per_kg - + hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) + & flux_diags_c%cwd_bg_input(i_cwd) * g_per_kg @@ -3384,19 +3366,19 @@ subroutine update_history_dyn(this,nc,nsites,sites) end do enddo ! site loop - + end associate return end subroutine update_history_dyn - + subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! --------------------------------------------------------------------------------- ! This is the call to update the history IO arrays that are expected to only change ! after rapid timescale productivity calculations (gpp and respiration). ! --------------------------------------------------------------------------------- - + use EDTypesMod , only : nclmax, nlevleaf ! ! Arguments @@ -3406,11 +3388,11 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) 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 :: ipa ! The local "I"ndex of "PA"tches 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 @@ -3500,18 +3482,18 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ) - ! Flush the relevant history variables + ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=2) per_dt_tstep = 1.0_r8/dt_tstep do s = 1,nsites - + io_si = sites(s)%h_gid - + hio_nep_si(io_si) = -bc_in(s)%tot_het_resp ! (gC/m2/s) hio_hr_si(io_si) = bc_in(s)%tot_het_resp - + ipa = 0 cpatch => sites(s)%oldest_patch @@ -3519,7 +3501,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) canopy_area_by_age(1:nlevage) = 0._r8 do while(associated(cpatch)) - + patch_area_by_age(cpatch%age_class) = & patch_area_by_age(cpatch%age_class) + cpatch%area @@ -3530,36 +3512,36 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_c_stomata_si_age(io_si,cpatch%age_class) = & hio_c_stomata_si_age(io_si,cpatch%age_class) + & cpatch%c_stomata * cpatch%total_canopy_area - + hio_c_lblayer_si_age(io_si,cpatch%age_class) = & hio_c_lblayer_si_age(io_si,cpatch%age_class) + & cpatch%c_lblayer * cpatch%total_canopy_area - + hio_c_stomata_si(io_si) = hio_c_stomata_si(io_si) + & cpatch%c_stomata * cpatch%total_canopy_area - + hio_c_lblayer_si(io_si) = hio_c_lblayer_si(io_si) + & cpatch%c_lblayer * cpatch%total_canopy_area ccohort => cpatch%shortest do while(associated(ccohort)) - + n_perm2 = ccohort%n * AREA_INV - + if ( .not. ccohort%isnew ) then npp = ccohort%npp_tstep resp_g = ccohort%resp_g_tstep aresp = ccohort%resp_tstep - + ! Calculate index for the scpf class associate( scpf => ccohort%size_by_pft_class, & scls => ccohort%size_class ) - + ! scale up cohort fluxes to the site level hio_npp_si(io_si) = hio_npp_si(io_si) + & npp * 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) + & @@ -3595,7 +3577,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! Maint AR (kgC/m2/yr) hio_ar_maint_si_scpf(io_si,scpf) = hio_ar_maint_si_scpf(io_si,scpf) + & (ccohort%resp_m/dt_tstep) * n_perm2 * sec_per_day * days_per_year - + ! Maintenance AR partition variables are stored as rates (kgC/plant/s) ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) hio_ar_agsapm_si_scpf(io_si,scpf) = hio_ar_agsapm_si_scpf(io_si,scpf) + & @@ -3625,9 +3607,9 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! ! bulk fluxes are in gC / m2 / s hio_gpp_canopy_si(io_si) = hio_gpp_canopy_si(io_si) + & - ccohort%gpp_tstep * g_per_kg * n_perm2 * per_dt_tstep + ccohort%gpp_tstep * g_per_kg * n_perm2 * per_dt_tstep hio_ar_canopy_si(io_si) = hio_ar_canopy_si(io_si) + & - aresp * g_per_kg * n_perm2 * per_dt_tstep + aresp * g_per_kg * n_perm2 * per_dt_tstep ! ! size-resolved respiration fluxes are in kg C / ha / yr @@ -3640,16 +3622,16 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_froot_mr_canopy_si_scls(io_si,scls) = hio_froot_mr_canopy_si_scls(io_si,scls) + & ccohort%froot_mr * ccohort%n * sec_per_day * days_per_year hio_resp_g_canopy_si_scls(io_si,scls) = hio_resp_g_canopy_si_scls(io_si,scls) + & - resp_g * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + resp_g * ccohort%n * sec_per_day * days_per_year * per_dt_tstep hio_resp_m_canopy_si_scls(io_si,scls) = hio_resp_m_canopy_si_scls(io_si,scls) + & - ccohort%resp_m * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + ccohort%resp_m * ccohort%n * sec_per_day * days_per_year * per_dt_tstep else ! ! bulk fluxes are in gC / m2 / s hio_gpp_understory_si(io_si) = hio_gpp_understory_si(io_si) + & - ccohort%gpp_tstep * g_per_kg * n_perm2 * per_dt_tstep + ccohort%gpp_tstep * g_per_kg * n_perm2 * per_dt_tstep hio_ar_understory_si(io_si) = hio_ar_understory_si(io_si) + & - aresp * g_per_kg * n_perm2 * per_dt_tstep + aresp * g_per_kg * n_perm2 * per_dt_tstep ! ! size-resolved respiration fluxes are in kg C / ha / yr @@ -3662,9 +3644,9 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_froot_mr_understory_si_scls(io_si,scls) = hio_froot_mr_understory_si_scls(io_si,scls) + & ccohort%froot_mr * ccohort%n * sec_per_day * days_per_year hio_resp_g_understory_si_scls(io_si,scls) = hio_resp_g_understory_si_scls(io_si,scls) + & - resp_g * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + resp_g * ccohort%n * sec_per_day * days_per_year * per_dt_tstep hio_resp_m_understory_si_scls(io_si,scls) = hio_resp_m_understory_si_scls(io_si,scls) + & - ccohort%resp_m * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + ccohort%resp_m * ccohort%n * sec_per_day * days_per_year * per_dt_tstep endif end associate endif @@ -3685,7 +3667,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) do ican=1,nclmax ! cpatch%ncl_p ? do ileaf=1,nlevleaf ! cpatch%ncan(ican,ipft) ? ! calculate where we are on multiplexed dimensions - cnlfpft_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax + cnlfpft_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax cnlf_indx = ileaf + (ican-1) * nlevleaf ! ! first do all the canopy x leaf x pft calculations @@ -3795,9 +3777,9 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_c_stomata_si_age(io_si,ipa2) = 0._r8 hio_c_lblayer_si_age(io_si,ipa2) = 0._r8 end if - + end do - + ! Normalize resistance diagnostics if ( sum(canopy_area_by_age(1:nlevage)) .gt. tiny) then hio_c_stomata_si(io_si) = hio_c_stomata_si(io_si) / sum(canopy_area_by_age(1:nlevage)) @@ -3810,7 +3792,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) enddo ! site loop end associate - + end subroutine update_history_hifrq ! ===================================================================================== @@ -3821,12 +3803,12 @@ 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 ! after rapid timescale productivity calculations (gpp and respiration). ! --------------------------------------------------------------------------------- - + use FatesHydraulicsMemMod, only : ed_cohort_hydr_type, nshell use FatesHydraulicsMemMod, only : ed_site_hydr_type use EDTypesMod , only : maxpft - + ! Arguments class(fates_history_interface_type) :: this integer , intent(in) :: nc ! clump index @@ -3834,11 +3816,11 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) 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 :: ipa ! The local "I"ndex of "PA"tches integer :: ft ! functional type index ! 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 @@ -3880,37 +3862,37 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) real(r8), parameter :: iterh2_dx = 1._r8 real(r8) :: iterh2_histx(iterh2_nhist) real(r8) :: iterh2_histy(iterh2_nhist) - + logical, parameter :: print_iterations = .false. - + 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_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, & - hio_tth_scpf => this%hvars(ih_tth_scpf)%r82d, & - hio_sth_scpf => this%hvars(ih_sth_scpf)%r82d, & - hio_lth_scpf => this%hvars(ih_lth_scpf)%r82d, & - hio_awp_scpf => this%hvars(ih_awp_scpf)%r82d, & - hio_twp_scpf => this%hvars(ih_twp_scpf)%r82d, & - hio_swp_scpf => this%hvars(ih_swp_scpf)%r82d, & - hio_lwp_scpf => this%hvars(ih_lwp_scpf)%r82d, & - hio_aflc_scpf => this%hvars(ih_aflc_scpf)%r82d, & - hio_tflc_scpf => this%hvars(ih_tflc_scpf)%r82d, & - hio_sflc_scpf => this%hvars(ih_sflc_scpf)%r82d, & - hio_lflc_scpf => this%hvars(ih_lflc_scpf)%r82d, & + 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, & + hio_tth_scpf => this%hvars(ih_tth_scpf)%r82d, & + hio_sth_scpf => this%hvars(ih_sth_scpf)%r82d, & + hio_lth_scpf => this%hvars(ih_lth_scpf)%r82d, & + hio_awp_scpf => this%hvars(ih_awp_scpf)%r82d, & + hio_twp_scpf => this%hvars(ih_twp_scpf)%r82d, & + hio_swp_scpf => this%hvars(ih_swp_scpf)%r82d, & + hio_lwp_scpf => this%hvars(ih_lwp_scpf)%r82d, & + hio_aflc_scpf => this%hvars(ih_aflc_scpf)%r82d, & + hio_tflc_scpf => this%hvars(ih_tflc_scpf)%r82d, & + hio_sflc_scpf => this%hvars(ih_sflc_scpf)%r82d, & + hio_lflc_scpf => this%hvars(ih_lflc_scpf)%r82d, & hio_btran_scpf => this%hvars(ih_btran_scpf)%r82d, & 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_rootwgt_soilvwc_si => this%hvars(ih_rootwgt_soilvwc_si)%r81d, & - hio_rootwgt_soilvwcsat_si => this%hvars(ih_rootwgt_soilvwcsat_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, & @@ -3922,7 +3904,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) hio_rootuptake50_scpf => this%hvars(ih_rootuptake50_scpf)%r82d, & hio_rootuptake100_scpf => this%hvars(ih_rootuptake100_scpf)%r82d ) - ! Flush the relevant history variables + ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=4) if(print_iterations) then @@ -3938,23 +3920,23 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) jr2 = site_hydr%i_rhiz_b io_si = sites(s)%h_gid - + hio_h2oveg_si(io_si) = site_hydr%h2oveg hio_h2oveg_hydro_err_si(io_si) = site_hydr%h2oveg_hydro_err - - + + ! 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) @@ -3968,13 +3950,13 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) 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) @@ -4012,10 +3994,10 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) ccohort => ccohort%taller enddo ! cohort loop cpatch => cpatch%younger - end do !patch loop + end do !patch loop end if - + do ipft = 1, numpft do iscls = 1,nlevsclass iscpf = (ipft-1)*nlevsclass + iscls @@ -4032,82 +4014,82 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) ipa = 0 cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - + ccohort => cpatch%shortest do while(associated(ccohort)) ccohort_hydr => ccohort%co_hydr - + if ( .not. ccohort%isnew ) then ! Calculate index for the scpf class iscpf = ccohort%size_by_pft_class - + ! scale up cohort fluxes to their sites number_fraction_rate = (ccohort%n / nplant_scpf(iscpf))/dt_tstep - + ! scale cohorts to mean quantity number_fraction = (ccohort%n / nplant_scpf(iscpf)) - + hio_errh2o_scpf(io_si,iscpf) = hio_errh2o_scpf(io_si,iscpf) + & ccohort_hydr%errh2o * number_fraction_rate ! [kg/indiv/s] - + hio_tran_scpf(io_si,iscpf) = hio_tran_scpf(io_si,iscpf) + & (ccohort_hydr%qtop) * number_fraction_rate ! [kg/indiv/s] - + hio_iterh1_scpf(io_si,iscpf) = hio_iterh1_scpf(io_si,iscpf) + & ccohort_hydr%iterh1/ncohort_scpf(iscpf) - + hio_iterh2_scpf(io_si,iscpf) = hio_iterh2_scpf(io_si,iscpf) + & ccohort_hydr%iterh2/ncohort_scpf(iscpf) - + 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) + & mean_aroot * number_fraction ! [m3 m-3] - + hio_tth_scpf(io_si,iscpf) = hio_tth_scpf(io_si,iscpf) + & ccohort_hydr%th_troot * number_fraction ! [m3 m-3] - + 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) + & mean_aroot * number_fraction ! [MPa] - + hio_twp_scpf(io_si,iscpf) = hio_twp_scpf(io_si,iscpf) + & 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] 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) + & - mean_aroot * number_fraction - + mean_aroot * number_fraction + hio_tflc_scpf(io_si,iscpf) = hio_tflc_scpf(io_si,iscpf) + & - ccohort_hydr%ftc_troot * number_fraction - + ccohort_hydr%ftc_troot * number_fraction + hio_sflc_scpf(io_si,iscpf) = hio_sflc_scpf(io_si,iscpf) + & - ccohort_hydr%ftc_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%ftc_ag(1) * number_fraction - + ccohort_hydr%ftc_ag(1) * number_fraction + hio_btran_scpf(io_si,iscpf) = hio_btran_scpf(io_si,iscpf) + & ccohort_hydr%btran * number_fraction ! [-] - + endif ccohort => ccohort%taller @@ -4140,11 +4122,11 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) end if - + enddo ! site loop end associate - + end subroutine update_history_hydraulics ! ==================================================================================== @@ -4155,11 +4137,11 @@ integer function num_history_vars(this) class(fates_history_interface_type), intent(in) :: this num_history_vars = this%num_history_vars_ - + end function num_history_vars - + ! ==================================================================================== - + subroutine initialize_history_vars(this) implicit none @@ -4172,21 +4154,21 @@ subroutine initialize_history_vars(this) ! Allocate the list of history output variable objects allocate(this%hvars(this%num_history_vars())) - + ! construct the object that defines all of the IO variables call this%define_history_vars(initialize_variables=.true.) - + end subroutine initialize_history_vars - + ! ==================================================================================== - + subroutine define_history_vars(this, initialize_variables) - + ! --------------------------------------------------------------------------------- - ! + ! ! REGISTRY OF HISTORY OUTPUT VARIABLES ! - ! This subroutine is called in two contexts, either in count mode or inialize mode + ! This subroutine is called in two contexts, either in count mode or initialize mode ! In count mode, we just walk through the list of registerred variables, compare ! if the variable of interest list the current host model and add it to the count ! if true. This count is used just to allocate the variable space. After this @@ -4199,23 +4181,23 @@ subroutine define_history_vars(this, initialize_variables) ! indices which may not be relevant to FATES, are flushed to this value. So ! in that case, lakes and crops that are not controlled by FATES will zero'd ! and when values are scaled up to the land-grid, the zero's for non FATES will - ! be included. This is good and correct if nothing is there. + ! be included. This is good and correct if nothing is there. ! ! But, what if crops exist in the host model and occupy a fraction of the land-surface ! shared with natural vegetation? In that case, you want to flush your arrays ! with a value that the HLM treats as "do not average" - ! + ! ! If your HLM makes use of, and you want, INTEGER OUTPUT, pass the flushval as ! a real. The applied flush value will use the NINT() intrinsic function ! --------------------------------------------------------------------------------- use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 - use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 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, site_agefuel_r8 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 use FatesIOVariableKindMod, only : site_scagpft_r8, site_agepft_r8 @@ -4224,644 +4206,685 @@ subroutine define_history_vars(this, initialize_variables) implicit none - + class(fates_history_interface_type), intent(inout) :: this logical, intent(in) :: initialize_variables ! are we 'count'ing or 'initializ'ing? integer :: ivar - character(len=10) :: tempstring - + character(len=10) :: tempstring + ivar=0 - + ! Site level counting variables - call this%set_history_var(vname='ED_NPATCHES', units='none', & - long='Total number of ED patches per site', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_npatches_si) - - call this%set_history_var(vname='ED_NCOHORTS', units='none', & - long='Total number of ED cohorts per site', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_ncohorts_si) - + call this%set_history_var(vname='FATES_NPATCHES', units='', & + long='total number of patches per site', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_npatches_si) + + call this%set_history_var(vname='FATES_NCOHORTS', units='', & + long='total number of cohorts per site', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_ncohorts_si) + ! Patch variables - call this%set_history_var(vname='TRIMMING', units='none', & - long='Degree to which canopy expansion is limited by leaf economics', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_trimming_si) - - call this%set_history_var(vname='AREA_PLANT', units='m2/m2', & - long='area occupied by all plants', use_default='active', & - 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/m2', & - long='area occupied by woody plants', use_default='active', & - 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', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_site_cstatus_si ) - - call this%set_history_var(vname='SITE_DROUGHT_STATUS', units='0,1,2,3', & - long='Site level drought status, <2 too dry for leaves, >=2 not-too dry', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_site_dstatus_si) - - call this%set_history_var(vname='SITE_GDD', units='degC', & - long='site level growing degree days', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_gdd_si) - - call this%set_history_var(vname='SITE_NCHILLDAYS', units = 'days', & - long='site level number of chill days', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_site_nchilldays_si) - - call this%set_history_var(vname='SITE_NCOLDDAYS', units = 'days', & - long='site level number of cold days', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_site_ncolddays_si) - - call this%set_history_var(vname='SITE_DAYSINCE_COLDLEAFOFF', units='days', & - long='site level days elapsed since cold leaf drop', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_cleafoff_si) - - call this%set_history_var(vname='SITE_DAYSINCE_COLDLEAFON', units='days', & - long='site level days elapsed since cold leaf flush', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_cleafon_si) - - call this%set_history_var(vname='SITE_DAYSINCE_DROUGHTLEAFOFF', units='days', & - long='site level days elapsed since drought leaf drop', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_dleafoff_si) - - call this%set_history_var(vname='SITE_DAYSINCE_DROUGHTLEAFON', units='days', & - long='site level days elapsed since drought leaf flush', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_dleafon_si) - - call this%set_history_var(vname='SITE_MEANLIQVOL_DROUGHTPHEN', units='m3/m3', & - long='site level mean liquid water volume for drought phen', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_meanliqvol_si) - - call this%set_history_var(vname='CANOPY_SPREAD', units='0-1', & - long='Scaling factor between tree basal area and canopy area', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_canopy_spread_si) - - call this%set_history_var(vname='PFTbiomass', units='gC/m2', & - long='total PFT level biomass', use_default='active', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_pft ) - - call this%set_history_var(vname='PFTleafbiomass', units='gC/m2', & - long='total PFT level leaf biomass', use_default='active', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_leafbiomass_si_pft ) - - call this%set_history_var(vname='PFTstorebiomass', units='gC/m2', & - long='total PFT level stored biomass', use_default='active', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_storebiomass_si_pft ) - - call this%set_history_var(vname='PFTcrownarea', units='m2/m2', & - long='total PFT level crown area', use_default='inactive', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_crownarea_si_pft ) - - call this%set_history_var(vname='PFTcanopycrownarea', units='m2/m2', & - long='total PFT-level canopy-layer crown area', use_default='inactive', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_canopycrownarea_si_pft ) - - call this%set_history_var(vname='PFTgpp', units='kg C m-2 y-1', & - long='total PFT-level GPP', use_default='active', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_gpp_si_pft ) - - call this%set_history_var(vname='PFTnpp', units='kg C m-2 y-1', & - long='total PFT-level NPP', use_default='active', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_npp_si_pft ) - - call this%set_history_var(vname='PFTnindivs', units='indiv / m2', & - long='total PFT level number of individuals', use_default='active', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_nindivs_si_pft ) - - call this%set_history_var(vname='RECRUITMENT', units='indiv/ha/yr', & - long='Rate of recruitment by PFT', use_default='active', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_recruitment_si_pft ) - - call this%set_history_var(vname='MORTALITY', units='indiv/ha/yr', & - long='Rate of total mortality by PFT', use_default='active', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_mortality_si_pft ) + call this%set_history_var(vname='FATES_TRIMMING', units='', & + long='degree to which canopy expansion is limited by leaf economics (0-1)', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_trimming_si) + + call this%set_history_var(vname='FATES_AREA_PLANTS', units='m2 m-2', & + long='area occupied by all plants', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index=ih_area_plant_si) + + call this%set_history_var(vname='FATES_AREA_TREES', units='m2 m-2', & + long='area occupied by woody plants', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_area_trees_si) + + call this%set_history_var(vname='FATES_COLD_STATUS', units='', & + long='site-level cold status, 0=not cold-dec, 1=too cold for leaves, 2=not too cold', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_site_cstatus_si) + + call this%set_history_var(vname='FATES_DROUGHT_STATUS', & + units='', & + long='site-level drought status, <2 too dry for leaves, >=2 not too dry', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_site_dstatus_si) + + call this%set_history_var(vname='FATES_GDD', units='degC', & + long='site-level growing degree days', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index=ih_gdd_si) + + call this%set_history_var(vname='FATES_NCHILLDAYS', units = 'days', & + long='site-level number of chill days', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_site_nchilldays_si) + + call this%set_history_var(vname='FATES_NCOLDDAYS', units = 'days', & + long='site-level number of cold days', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_site_ncolddays_si) + + call this%set_history_var(vname='FATES_DAYSINCE_COLDLEAFOFF', & + units='days', long='site-level days elapsed since cold leaf drop', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_cleafoff_si) + + call this%set_history_var(vname='FATES_DAYSINCE_COLDLEAFON', & + units='days', long='site-level days elapsed since cold leaf flush', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_cleafon_si) + + call this%set_history_var(vname='FATES_DAYSINCE_DROUGHTLEAFOFF', & + units='days', long='site level days elapsed since drought leaf drop', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_dleafoff_si) + + call this%set_history_var(vname='FATES_DAYSINCE_DROUGHTLEAFON', & + units='days', & + long='site-level days elapsed since drought leaf flush', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_dleafon_si) + + call this%set_history_var(vname='FATES_MEANLIQVOL_DROUGHTPHEN', & + units='m3 m-3', & + long='site-level mean liquid water volume for drought phen', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_meanliqvol_si) + + call this%set_history_var(vname='FATES_CANOPY_SPREAD', units='', & + long='scaling factor (0-1) between tree basal area and canopy area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_canopy_spread_si) + + call this%set_history_var(vname='FATES_VEGC_PF', units='kg m-2', & + long='total PFT-level biomass in kg of carbon per land area', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_biomass_si_pft) + + call this%set_history_var(vname='FATES_LEAFC_PF', units='kg m-2', & + long='total PFT-level leaf biomass in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_leafbiomass_si_pft) + + call this%set_history_var(vname='FATES_STOREC_PF', units='kg m-2', & + long='total PFT-level stored biomass in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_storebiomass_si_pft) + + call this%set_history_var(vname='FATES_CROWNAREA_PF', units='m2 m-2', & + long='total PFT-level crown area per m2 land area', & + use_default='inactive', avgflag='A', vtype=site_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_crownarea_si_pft) + + call this%set_history_var(vname='FATES_CANOPYCROWNAREA_PF', & + units='m2 m-2', long='total PFT-level canopy-layer crown area per m2 land area', & + use_default='inactive', avgflag='A', vtype=site_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_canopycrownarea_si_pft) + + call this%set_history_var(vname='FATES_GPP_PF', units='kg m-2 s-1', & + long='total PFT-level GPP in kg carbon per m2 land area per second', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_gpp_si_pft) + + call this%set_history_var(vname='FATES_NPP_PF', units='kg m-2 yr-1', & + long='total PFT-level NPP in kg carbon per m2 land area per second', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_npp_si_pft) + + call this%set_history_var(vname='FATES_NINDIVS_PF', units='m-2', & + long='total PFT-level number of individuals per m2 land area', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_nindivs_si_pft) + + call this%set_history_var(vname='FATES_RECRUITMENT_PF', & + units='m-2 yr-1', & + long='PFT-level recruitment rate in number of individuals per m2 land area per year', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_recruitment_si_pft) + + call this%set_history_var(vname='FATES_MORTALITY_PF', units='m-2 yr-1', & + long='PFT-level mortality rate in number of individuals per m2 land area per year', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_mortality_si_pft) ! patch age class variables - call this%set_history_var(vname='PATCH_AREA_BY_AGE', units='m2/m2', & - long='patch area by age bin', 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_si_age ) - - call this%set_history_var(vname='LAI_BY_AGE', units='m2/m2', & - long='leaf area index by age bin', 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_lai_si_age ) - - call this%set_history_var(vname='CANOPY_AREA_BY_AGE', units='m2/m2', & - long='canopy area by age bin', 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_canopy_area_si_age ) - - call this%set_history_var(vname='NCL_BY_AGE', units='--', & - long='number of canopy levels by age bin', use_default='inactive', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_ncl_si_age ) - - call this%set_history_var(vname='NPATCH_BY_AGE', units='--', & - long='number of patches by age bin', use_default='inactive', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_npatches_si_age ) + call this%set_history_var(vname='FATES_PATCHAREA_AP', units='m2 m-2', & + long='patch area by age bin per m2 land area', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index=ih_area_si_age) + + call this%set_history_var(vname='FATES_LAI_AP', units='m2 m-2', & + long='leaf area index by age bin per m2 land area', & + use_default='active', avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_lai_si_age) + + call this%set_history_var(vname='FATES_CANOPYAREA_AP', units='m2 m-2', & + long='canopy area by age bin per m2 land area', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index=ih_canopy_area_si_age) + + call this%set_history_var(vname='FATES_NCL_AP', units='', & + long='number of canopy levels by age bin', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_ncl_si_age) + + call this%set_history_var(vname='FATES_NPATCH_AP', units='', & + long='number of patches by age bin', use_default='inactive', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_npatches_si_age) if ( ED_val_comp_excln .lt. 0._r8 ) then ! only valid when "strict ppa" enabled tempstring = 'active' else tempstring = 'inactive' endif - - call this%set_history_var(vname='ZSTAR_BY_AGE', units='m', & - long='product of zstar and patch area by age bin (divide by PATCH_AREA_BY_AGE to get mean zstar)', & - use_default=trim(tempstring), & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_zstar_si_age ) - - call this%set_history_var(vname='CANOPY_HEIGHT_DIST', units='m2/m2', & - long='canopy height distribution', use_default='active', & - avgflag='A', vtype=site_height_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_canopy_height_dist_si_height ) - - call this%set_history_var(vname='LEAF_HEIGHT_DIST', units='m2/m2', & - long='leaf height distribution', use_default='active', & - avgflag='A', vtype=site_height_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_leaf_height_dist_si_height ) - - call this%set_history_var(vname='BIOMASS_BY_AGE', units='kgC/m2', & - long='Total Biomass within a given patch age bin', & - use_default='inactive', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_age ) - - ! Secondary forest area and age diagnostics - - call this%set_history_var(vname='SECONDARY_FOREST_FRACTION', units='m2/m2', & - long='Secondary forest fraction', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fraction_secondary_forest_si ) - call this%set_history_var(vname='WOOD_PRODUCT', units='gC/m2', & - long='Total wood product from logging', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_woodproduct_si ) + call this%set_history_var(vname='FATES_ZSTAR_AP', units='m', & + long='product of zstar and patch area by age bin (divide by FATES_PATCHAREA_AP to get mean zstar)', & + use_default=trim(tempstring), avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_zstar_si_age) + + call this%set_history_var(vname='FATES_CANOPYAREA_HT', units='m2 m-2', & + long='canopy area height distribution', & + use_default='active', avgflag='A', vtype=site_height_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_canopy_height_dist_si_height) + + call this%set_history_var(vname='FATES_LEAFAREA_HT', units='m2 m-2', & + long='leaf area height distribution', use_default='active', & + avgflag='A', vtype=site_height_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_leaf_height_dist_si_height) + + call this%set_history_var(vname='FATES_VEGC_AP', units='kg m-2', & + long='total biomass within a given patch age bin in kg carbon per m2 land area', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_biomass_si_age) - call this%set_history_var(vname='SECONDARY_FOREST_BIOMASS', units='kgC/m2', & - long='Biomass on secondary lands (per total site area, mult by SECONDARY_FOREST_FRACTION to get per secondary forest area)',& - use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_biomass_secondary_forest_si ) - - call this%set_history_var(vname='SECONDARY_AREA_AGE_ANTHRO_DIST', units='m2/m2', & - long='Secondary forest patch area age distribution since anthropgenic disturbance', & - use_default='inactive', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_agesince_anthrodist_si_age ) - - call this%set_history_var(vname='SECONDARY_AREA_PATCH_AGE_DIST', units='m2/m2', & - long='Secondary forest patch area age distribution since any kind of disturbance', & - use_default='inactive', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_secondaryforest_area_si_age ) + ! Secondary forest area and age diagnostics + call this%set_history_var(vname='FATES_SECONDARY_FOREST_FRACTION', & + units='m2 m-2', long='secondary forest fraction', & + use_default='inactive', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + flushval=hlm_hio_ignore_val, upfreq=1, ivar=ivar, & + initialize=initialize_variables, index=ih_fraction_secondary_forest_si) + + call this%set_history_var(vname='FATES_WOOD_PRODUCT', units='kg m-2', & + long='total wood product from logging in kg carbon per m2 land area', & + use_default='inactive', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_woodproduct_si) + + call this%set_history_var(vname='FATES_SECONDARY_FOREST_VEGC', & + units='kg m-2', & + long='biomass on secondary lands in kg carbon per m2 land area (mult by FATES_SECONDARY_FOREST_FRACTION to get per secondary forest area)', & + use_default='inactive', avgflag='A', vtype=site_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_biomass_secondary_forest_si) + + call this%set_history_var(vname='FATES_SECONDARY_AREA_ANTHRO_DIST_AP', & + units='m2 m-2', & + long='secondary forest patch area age distribution since anthropgenic disturbance', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_agesince_anthrodist_si_age) + + call this%set_history_var(vname='FATES_SECONDARY_AREA_DIST_AP', & + units='m2 m-2', & + long='secondary forest patch area age distribution since any kind of disturbance', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_secondaryforest_area_si_age) ! Fire Variables - call this%set_history_var(vname='FIRE_NESTEROV_INDEX', units='none', & - long='nesterov_fire_danger index', use_default='active', & - 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_IGNITIONS', units='number/km2/day', & - long='number of successful ignitions', 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_nignitions_si) - - call this%set_history_var(vname='FIRE_FDI', units='none', & - long='probability that an ignition will lead to a fire', 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_fdi_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=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=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=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=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/day', & - long='spitfire fire area burn fraction', 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_area_si ) - - call this%set_history_var(vname='FIRE_FUEL_MEF', units='m', & - long='spitfire fuel moisture', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_mef_si ) - - call this%set_history_var(vname='FIRE_FUEL_BULKD', units='kg biomass/m3', & - long='spitfire fuel bulk density', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_bulkd_si ) - - call this%set_history_var(vname='FIRE_FUEL_EFF_MOIST', units='m', & - long='spitfire fuel moisture', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_eff_moist_si ) - - call this%set_history_var(vname='FIRE_FUEL_SAV', units='per m', & - long='spitfire fuel surface/volume ', use_default='active', & - avgflag='A', vtype=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=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='FRAGMENTATION_SCALER_SL', units='unitless (0-1)', & - long='factor by which litter/cwd fragmentation proceeds relative to max rate by soil layer', & - use_default='active', & - avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fragmentation_scaler_sl ) - - 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='FUEL_AMOUNT_BY_NFSC', units='kg C / m2', & - long='spitfire size-resolved fuel quantity', 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_fuel_amount_si_fuel ) - - call this%set_history_var(vname='FUEL_AMOUNT_AGEFUEL', units='kg C / m2', & - long='spitfire fuel quantity in each age x fuel class ', use_default='active', & - avgflag='A', vtype=site_agefuel_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fuel_amount_age_fuel ) - - call this%set_history_var(vname='AREA_BURNT_BY_PATCH_AGE', units='m2/m2/day', & - 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 ) - + call this%set_history_var(vname='FATES_NESTEROV_INDEX', units='', & + long='nesterov fire danger index', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_nesterov_fire_danger_si) + + call this%set_history_var(vname='FATES_IGNITIONS', & + units='m-2 s-1', & + long='number of successful fire ignitions per m2 land area per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_fire_nignitions_si) + + call this%set_history_var(vname='FATES_FDI', units='1', & + long='Fire Danger Index (probability that an ignition will lead to a fire)', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_fire_fdi_si) + + call this%set_history_var(vname='FATES_ROS', units='m s-1', & + long='fire rate of spread in meters per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_spitfire_ros_si) + + call this%set_history_var(vname='FATES_EFFECT_WSPEED', units='m s-1', & + long ='effective wind speed for fire spread in meters per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_effect_wspeed_si) + + call this%set_history_var(vname='FATES_FUELCONSUMED', units='kg m-2', & + long ='total fuel consumed in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_tfc_ros_si) + + call this%set_history_var(vname='FATES_FIRE_INTENSITY', & + units='J m-1 s-1', & + long='spitfire surface fireline intensity in J per m per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_fire_intensity_si) + + call this%set_history_var(vname='FATES_FIRE_INTENSITY_BURNFRAC', & + units='J m-1 s-1', & + long='product of surface fire intensity and burned area fraction -- divide by FATES_BURNFRAC to get area-weighted mean intensity', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_fire_intensity_area_product_si) + + call this%set_history_var(vname='FATES_BURNFRAC', units='1 s-1', & + long='burned area fraction per second', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_fire_area_si) + + call this%set_history_var(vname='FATES_FUEL_MEF', units='1', & + long='fuel moisture of extinction (volumetric)', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_fire_fuel_mef_si) + + call this%set_history_var(vname='FATES_FUEL_BULKD', & + units='kg m-3', long='fuel bulk density in kg per m3', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fire_fuel_bulkd_si ) + + call this%set_history_var(vname='FATES_FUEL_EFF_MOIST', units='1', & + long='spitfire fuel moisture (volumetric)', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_fire_fuel_eff_moist_si) + + call this%set_history_var(vname='FATES_FUEL_SAV', units='per m', & + long='spitfire fuel surface area to volume ratio', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fire_fuel_sav_si) + + call this%set_history_var(vname='FATES_FUEL_AMOUNT', units='kg m-2', & + long='total ground fuel related to FATES_ROS (omits 1000hr fuels) in kg C per m2 land area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_sum_fuel_si) + + call this%set_history_var(vname='FATES_FRAGMENTATION_SCALER_SL', units='', & + long='factor (0-1) by which litter/cwd fragmentation proceeds relative to max rate by soil layer', & + use_default='active', avgflag='A', vtype=site_ground_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fragmentation_scaler_sl) + + call this%set_history_var(vname='FATES_FUEL_MOISTURE_FC', units='1', & + long='spitfire fuel class-level fuel moisture (volumetric)', & + use_default='active', avgflag='A', vtype=site_fuel_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_litter_moisture_si_fuel) + + call this%set_history_var(vname='FATES_FUEL_AMOUNT_FC', units='kg m-2', & + long='spitfire fuel-class level fuel amount in kg carbon per m2 land area', + use_default='active', avgflag='A', vtype=site_fuel_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fuel_amount_si_fuel) + + call this%set_history_var(vname='FATES_FUEL_AMOUNT_FCAF', units='kg m-2', & + long='spitfire fuel quantity in each age x fuel class in kg carbon per m2 land area', & + use_default='inactive', avgflag='A', vtype=site_agefuel_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fuel_amount_age_fuel) + + call this%set_history_var(vname='FATES_BURNFRAC_AP', units='1 s-1', & + long='spitfire fraction area burnt (per second) by patch age', & + use_default='active', avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_area_burnt_si_age) + + call this%set_history_var(vname='FATES_FIRE_INTENSITY_BURNFRAC_AP', & + units='J m-1 s-1', & + long='product of fire intensity and burned area, resolved by patch age (so divide by FATES_BURNFRAC_AP to get burned-area-weighted-average intensity)', & + use_default='active', avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fire_intensity_si_age) + + call this%set_history_var(vname='FATES_FUEL_AMOUNT_AP', units='kg m-2', & + long='spitfire ground fuel (kg carbon per m2) related to FATES_ROS (omits 1000hr fuels) within each patch age bin (divide by FATES_PATCHAREA_AP to get fuel per unit area of that-age patch)', & + use_default='active', avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fire_sum_fuel_si_age) + + call this%set_history_var(vname='FATES_FUEL_BURNT_BURNFRAC_FC', units='1', & + long='product of fraction (0-1) of fuel burnt and burnt fraction (divide by FATES_BURNFRAC to get burned-area-weighted mean fraction fuel burnt)', & + use_default='active', avgflag='A', vtype=site_fuel_r8, & + hlms='CLM:ALM', 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', & - long='FATES litter flux in', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_litter_in_si ) - - call this%set_history_var(vname='LITTER_OUT', units='gC m-2 s-1', & - long='FATES litter flux out', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_litter_out_si ) - - call this%set_history_var(vname='SEED_BANK', units='gC m-2', & - long='Total Seed Mass of all PFTs', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_seed_bank_si ) + call this%set_history_var(vname='FATES_LITTER_IN', units='kg m-2 s-1', & + long='litter flux in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_litter_in_si) + + call this%set_history_var(vname='FATES_LITTER_OUT', units='kg m-2 s-1', & + long='litter flux out in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_litter_out_si) + + call this%set_history_var(vname='FATES_SEED_BANK', units='kg m-2', & + long='total seed mass of all PFTs in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_seed_bank_si) + + call this%set_history_var(vname='FATES_SEEDS_IN', units='kg m-2 s-1', & + long='seed production rate in kg carbon per m2 second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_seeds_in_si) + + call this%set_history_var(vname='FATES_LITTER_IN_EL', units='kg m-2 s-1', & + long='litter flux in in kg element per m2 per second', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_litter_in_elem) + + call this%set_history_var(vname='FATES_LITTER_OUT_EL', units='kg m-2 s-1', & + long='litter flux out (fragmentation only) in kg element per m2 per second', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_litter_out_elem) + + call this%set_history_var(vname='FATES_SEED_BANK_EL', units='kg m-2', & + long='element-level total seed mass of all PFTs in kg element per m2', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_seed_bank_elem) + + call this%set_history_var(vname='FATES_SEEDS_IN_LOCAL_EL', & + units='kg m-2 s-1', & + long='within-site, element-level seed production rate in kg element per m2 per second', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_seeds_in_local_elem) + + call this%set_history_var(vname='FATES_SEEDS_IN_EXTERN_EL', & + units='kg m-2 s-1', long='external seed influx rate in kg element per m2 per second', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_seeds_in_extern_elem) + + call this%set_history_var(vname='FATES_SEED_GERM_EL', units='kg m-2 s-1', & + long='seed mass converted into new cohorts in kg element per m2 per s', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_seed_germ_elem) + + call this%set_history_var(vname='FATES_SEED_DECAY_EL', units='kg m-2 s-1', & + long='seed mass decay (germinated and un-germinated) in kg element per m2 per second', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_seed_decay_elem ) - call this%set_history_var(vname='SEEDS_IN', units='gC m-2 s-1', & - long='Seed Production Rate', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_seeds_in_si ) - - call this%set_history_var(vname='LITTER_IN_ELEM', units='kg ha-1 d-1', & - long='FATES litter flux in', 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_litter_in_elem ) - - call this%set_history_var(vname='LITTER_OUT_ELEM', units='kg ha-1 d-1', & - long='FATES litter flux out (fragmentation only)', 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_litter_out_elem ) - - call this%set_history_var(vname='SEED_BANK_ELEM', units='kg ha-1', & - long='Total Seed Mass of all PFTs', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_seed_bank_elem ) - - call this%set_history_var(vname='SEEDS_IN_LOCAL_ELEM', units='kg ha-1 d-1', & - long='Within Site Seed Production Rate', 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_seeds_in_local_elem ) - - call this%set_history_var(vname='SEEDS_IN_EXTERN_ELEM', units='kg ha-1 d-1', & - long='External Seed Influx Rate', 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_seeds_in_extern_elem ) - - call this%set_history_var(vname='SEED_GERM_ELEM', units='kg ha-1 d-1', & - long='Seed mass converted into new cohorts', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_seed_germ_elem ) - - call this%set_history_var(vname='SEED_DECAY_ELEM', units='kg ha-1 d-1', & - long='Seed mass decay (germinated and un-germinated)', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_seed_decay_elem ) - - ! SITE LEVEL CARBON STATE VARIABLES - call this%set_history_var(vname='STOREC', units='kgC ha-1', & - long='Total carbon in live plant storage', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_storec_si ) - - call this%set_history_var(vname='TOTVEGC', units='kgC ha-1', & - long='Total carbon in live plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_totvegc_si ) - - call this%set_history_var(vname='SAPWC', units='kgC ha-1', & - long='Total carbon in live plant sapwood', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_sapwc_si ) - - call this%set_history_var(vname='LEAFC', units='kgC ha-1', & - long='Total carbon in live plant leaves', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_leafc_si ) - - call this%set_history_var(vname='FNRTC', units='kgC ha-1', & - long='Total carbon in live plant fine-roots', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fnrtc_si ) - call this%set_history_var(vname='REPROC', units='kgC ha-1', & - long='Total carbon in live plant reproductive tissues', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_reproc_si ) + call this%set_history_var(vname='FATES_STOREC', units='kg m-2', & + long='total biomass in live plant storage in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_storec_si) + + call this%set_history_var(vname='FATES_VEGC', units='kg m-2', & + long='total biomass in live plants in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_totvegc_si) + + call this%set_history_var(vname='FATES_SAPWOODC', units='kg m-2', & + long='total biomass in live plant sapwood in kg carbon per m2', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_sapwc_si) + + call this%set_history_var(vname='FATES_LEAFC', units='kg m-2', & + long='total biomass in live plant leaves in kg carbon per m2', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_leafc_si) + + call this%set_history_var(vname='FATES_FINEROOTC', units='kg m-2', & + long='total biomass in live plant fine roots in kg carbon per m2', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fnrtc_si) + + call this%set_history_var(vname='FATES_REPROC', units='kg m-2', & + long='total biomass in live plant reproductive tissues in kg carbon per m2', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_reproc_si) + + call this%set_history_var(vname='FATES_CEFFLUX', units='kg m-2 s-1', & + long='carbon efflux, root to soil, in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_cefflux_si) - call this%set_history_var(vname='CEFFLUX', units='kgC/ha/day', & - long='carbon efflux, root to soil', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cefflux_si ) - nitrogen_active_if: if(any(element_list(:)==nitrogen_element)) then - call this%set_history_var(vname='STOREN', units='kgN ha-1', & - long='Total nitrogen in live plant storage', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_storen_si ) - - call this%set_history_var(vname='STOREN_TFRAC', units='-', & - long='Storage N fraction of target', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_storentfrac_si ) - - call this%set_history_var(vname='TOTVEGN', units='kgN ha-1', & - long='Total nitrogen in live plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_totvegn_si ) - - call this%set_history_var(vname='SAPWN', units='kgN ha-1', & - long='Total nitrogen in live plant sapwood', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_sapwn_si ) - - call this%set_history_var(vname='LEAFN', units='kgN ha-1', & - long='Total nitrogen in live plant leaves', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_leafn_si ) - - call this%set_history_var(vname='FNRTN', units='kgN ha-1', & - long='Total nitrogen in live plant fine-roots', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fnrtn_si ) - - call this%set_history_var(vname='REPRON', units='kgN ha-1', & - long='Total nitrogen in live plant reproductive tissues', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_repron_si ) - - call this%set_history_var(vname='NH4UPTAKE', units='kgN d-1 ha-1', & - long='Ammonium uptake rate by plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_nh4uptake_si ) - - call this%set_history_var(vname='NO3UPTAKE', units='kgN d-1 ha-1', & - long='Nitrate uptake rate by plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_no3uptake_si ) - - call this%set_history_var(vname='NEFFLUX', units='kgN d-1 ha-1', & - long='Nitrogen effluxed from plant (unused)', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_nefflux_si ) - - call this%set_history_var(vname='NNEED', units='kgN d-1 ha-1', & - long='Plant nitrogen need (algorithm dependent)', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_nneed_si ) - + call this%set_history_var(vname='FATES_STOREN', units='kg m-2', & + long='total nitrogen in live plant storage', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_storen_si) + + call this%set_history_var(vname='FATES_STOREN_TFRAC', units='1', & + long='storage N fraction of target', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_storentfrac_si) + + call this%set_history_var(vname='FATES_VEGN', units='kg m-2', & + long='total nitrogen in live plants', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_totvegn_si) + + call this%set_history_var(vname='FATES_SAPWOODN', units='kg m-2', & + long='total nitrogen in live plant sapwood', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_sapwn_si) + + call this%set_history_var(vname='FATES_LEAFN', units='kg m-2', & + long='total nitrogen in live plant leaves', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_leafn_si) + + call this%set_history_var(vname='FATES_FINEROOTN', units='kg m-2', & + long='total nitrogen in live plant fine-roots', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fnrtn_si) + + call this%set_history_var(vname='FATES_REPRON', units='kg m-2', & + long='total nitrogen in live plant reproductive tissues', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_repron_si) + + call this%set_history_var(vname='FATES_NH4UPTAKE', units='kg m-2 s-1', & + long='ammonium uptake rate by plants in kg NH4 per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_nh4uptake_si) + + call this%set_history_var(vname='FATES_NO3UPTAKE', units='kg m-2 s-1', & + long='nitrate uptake rate by plants in kg NO3 per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_no3uptake_si) + + call this%set_history_var(vname='FATES_NEFFLUX', units='kg m-2 s-1', & + long='nitrogen effluxed from plant in kg N per m2 per second (unused)', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_nefflux_si) + + call this%set_history_var(vname='FATES_NNEED', units='kg m-2 s-1', & + long='plant nitrogen need (algorithm dependent) in kg N per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_nneed_si) + end if nitrogen_active_if - + phosphorus_active_if: if(any(element_list(:)==phosphorus_element)) then - call this%set_history_var(vname='STOREP', units='kgP ha-1', & - long='Total phosphorus in live plant storage', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_storep_si ) - - call this%set_history_var(vname='STOREP_TFRAC', units='fraction', & - long='Storage P fraction of target', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_storeptfrac_si ) - - call this%set_history_var(vname='TOTVEGP', units='kgP ha-1', & - long='Total phosphorus in live plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_totvegp_si ) - - call this%set_history_var(vname='SAPWP', units='kgP ha-1', & - long='Total phosphorus in live plant sapwood', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_sapwp_si ) - - call this%set_history_var(vname='LEAFP', units='kgP ha-1', & - long='Total phosphorus in live plant leaves', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_leafp_si ) - - call this%set_history_var(vname='FNRTP', units='kgP ha-1', & - long='Total phosphorus in live plant fine-roots', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fnrtp_si ) - - call this%set_history_var(vname='REPROP', units='kgP ha-1', & - long='Total phosphorus in live plant reproductive tissues', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_reprop_si ) - - call this%set_history_var(vname='PUPTAKE', units='kgP ha-1 d-1', & - long='Mineralized phosphorus uptake rate of plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_puptake_si ) - - call this%set_history_var(vname='PEFFLUX', units='kgP ha-1 d-1', & - long='Phosphorus effluxed from plant (unused)', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_pefflux_si ) - - call this%set_history_var(vname='PNEED', units='kgP ha-1 d-1', & - long='Plant phosphorus need (algorithm dependent)', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_pneed_si ) + call this%set_history_var(vname='FATES_STOREP', units='kg m-2', & + long='total phosphorus in live plant storage', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_storep_si) + + call this%set_history_var(vname='FATES_STOREP_TFRAC', units='1', & + long='storage P fraction of target', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, & + index = ih_storeptfrac_si) + + call this%set_history_var(vname='FATES_VEGP', units='kg m-2', & + long='total phosphorus in live plants', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_totvegp_si) + + call this%set_history_var(vname='FATES_SAPWOODP', units='kg m-2', & + long='Total phosphorus in live plant sapwood', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_sapwp_si) + + call this%set_history_var(vname='FATES_LEAFP', units='kg m-2', & + long='total phosphorus in live plant leaves', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_leafp_si) + + call this%set_history_var(vname='FATES_FINEROOTP', units='kg m-2', & + long='total phosphorus in live plant fine roots', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fnrtp_si) + + call this%set_history_var(vname='FATES_REPROP', units='kg m-2', & + long='total phosphorus in live plant reproductive tissues', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_reprop_si) + + call this%set_history_var(vname='FATES_PUPTAKE', units='kg m-2 s-1', & + long='mineralized phosphorus uptake rate of plants in kg P per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_puptake_si) + + call this%set_history_var(vname='FATES_PEFFLUX', units='kg m-2 s-1', & + long='phosphorus effluxed from plant in kg P per m2 per second (unused)', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_pefflux_si) + + call this%set_history_var(vname='FATES_PNEED', units='kg m-2 s-1', & + long='plant phosphorus need (algorithm dependent) in kg P per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_pneed_si) end if phosphorus_active_if - - ! Consider deprecating the "ED_" variables (RGK 08-2020) - ! They have been replaced, eg. STOREC = ED_bstore - - call this%set_history_var(vname='ED_bstore', units='gC m-2', & - long='Storage biomass', use_default='active', & - 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=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=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=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=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=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=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=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=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=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_understory_biomass_si ) + call this%set_history_var(vname='FATES_STRUCTC', units='kg m-2', & + long='structural biomass in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_bdead_si) + + call this%set_history_var(vname='FATES_NONSTRUCTC', units='kg m-2', & + long='non-structural biomass (sapwood + leaf + fineroot) in kg carbon per m2', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_balive_si) + + call this%set_history_var(vname='FATES_ABOVE_VEGC', units='kg m-2', & + long='aboveground biomass in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_agb_si) + + call this%set_history_var(vname='FATES_CANOPY_VEGC', units='kg m-2', & + long='biomass of canopy plants in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_canopy_biomass_si) + + call this%set_history_var(vname='FATES_UNDERSTORY_VEGC', units='kg m-2', & + long='biomass of understory plants in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_understory_biomass_si) ! disturbance rates - call this%set_history_var(vname='PRIMARYLAND_PATCHFUSION_ERROR', units='m2 m-2 d-1', & - long='Error in total primary lands associated with patch fusion', use_default='active', & + + call this%set_history_var(vname='FATES_PRIMARYLAND_PATCHFUSION_ERROR', & + units='m2 m-2 yr-1', & + long='error in total primary lands associated with patch fusion', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_primaryland_fusion_error_si ) - call this%set_history_var(vname='DISTURBANCE_RATE_P2P', units='m2 m-2 d-1', & + call this%set_history_var(vname='FATES_DISTURBANCE_RATE_P2P', units='m2 m-2 d-1', & long='Disturbance rate from primary to primary lands', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_disturbance_rate_p2p_si ) @@ -4901,7 +4924,7 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_harvest_carbonflux_si ) - ! Canopy Resistance + ! Canopy Resistance call this%set_history_var(vname='C_STOMATA', units='umol m-2 s-1', & long='mean stomatal conductance', use_default='active', & @@ -4941,7 +4964,7 @@ subroutine define_history_vars(this, initialize_variables) 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 + ! Canopy resistance call this%set_history_var(vname='C_STOMATA_BY_AGE', units='umol m-2 s-1', & long='mean stomatal conductance - by patch age', use_default='inactive', & @@ -5197,7 +5220,7 @@ subroutine define_history_vars(this, initialize_variables) ! size class by age dimensioned variables call this%set_history_var(vname='NPLANT_SCAG',units = 'plants/ha', & - long='number of plants per hectare in each size x age class', use_default='active', & + long='number of plants per hectare in each size x age class', use_default='inactive', & avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scag ) @@ -5250,7 +5273,7 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='SCORCH_HEIGHT',units = 'm', & long='SPITFIRE Flame Scorch Height (calculated per PFT in each patch age bin)', & - use_default='active', & + use_default='inactive', & avgflag='A', vtype=site_agepft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_scorch_height_si_agepft ) @@ -5362,7 +5385,7 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='AGB_SCPF', units = 'kgC/m2', & long='Aboveground biomass by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_agb_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_agb_si_scpf ) call this%set_history_var(vname='NPLANT_SCPF', units = 'N/ha', & long='stem number density by pft/size', use_default='inactive', & @@ -5378,7 +5401,7 @@ subroutine define_history_vars(this, initialize_variables) long='background mortality by pft/size', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m1_si_scpf ) - + call this%set_history_var(vname='M2_SCPF', units = 'N/ha/yr', & long='hydraulic mortality by pft/size',use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & @@ -5433,7 +5456,7 @@ subroutine define_history_vars(this, initialize_variables) long='age senescence mortality by pft/size',use_default='inactive', & avgflag='A', vtype =site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m10_si_scpf ) - + call this%set_history_var(vname='M10_CAPF',units='N/ha/yr', & long='age senescence mortality by pft/cohort age',use_default='inactive', & avgflag='A', vtype =site_coage_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & @@ -5447,7 +5470,7 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='C13disc_SCPF', units = 'per mil', & long='C13 discrimination by pft/size',use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_c13disc_si_scpf ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_c13disc_si_scpf ) call this%set_history_var(vname='BSTOR_CANOPY_SCPF', units = 'kgC/ha', & long='biomass carbon in storage pools of canopy plants by pft/size', use_default='inactive', & @@ -5520,7 +5543,7 @@ subroutine define_history_vars(this, initialize_variables) long='total autotrophic respiration per m2 per year by pft/size',use_default='inactive',& avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_si_scpf ) - + call this%set_history_var(vname='AR_GROW_SCPF',units = 'kgC/m2/yr', & long='growth autotrophic respiration per m2 per year by pft/size',use_default='inactive',& avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & @@ -5540,7 +5563,7 @@ subroutine define_history_vars(this, initialize_variables) long='above-ground sapwood maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_agsapm_si_scpf ) - + call this%set_history_var(vname='AR_CROOTM_SCPF',units = 'kgC/m2/yr', & long='below-ground sapwood maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & @@ -5602,7 +5625,7 @@ subroutine define_history_vars(this, initialize_variables) long='number of canopy plants by size class', use_default='active', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_canopy_si_scls ) - + call this%set_history_var(vname='LAI_CANOPY_SCLS', units = 'm2/m2', & long='Leaf are index (LAI) by size class', use_default='active', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & @@ -5647,7 +5670,7 @@ subroutine define_history_vars(this, initialize_variables) long='background mortality by size', use_default='active', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m1_si_scls ) - + call this%set_history_var(vname='M2_SCLS', units = 'N/ha/yr', & long='hydraulic mortality by size',use_default='active', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & @@ -5691,7 +5714,7 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='M10_SCLS', units = 'N/ha/yr', & long='age senescence mortality by size',use_default='active', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m10_si_scls ) + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m10_si_scls ) call this%set_history_var(vname='M10_CACLS', units = 'N/ha/yr', & long='age senescence mortality by cohort age',use_default='active', & @@ -5707,7 +5730,7 @@ subroutine define_history_vars(this, initialize_variables) long='CARBON_BALANCE for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_carbon_balance_understory_si_scls ) - + call this%set_history_var(vname='MORTALITY_UNDERSTORY_SCLS', units = 'indiv/ha/yr', & long='total mortality of understory trees by size class', use_default='active', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & @@ -5737,7 +5760,7 @@ subroutine define_history_vars(this, initialize_variables) long='LEAF_MD for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leaf_md_canopy_si_scls ) - + call this%set_history_var(vname='ROOT_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & long='ROOT_MD for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & @@ -5762,82 +5785,82 @@ subroutine define_history_vars(this, initialize_variables) long='SEED_PROD for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_seed_prod_canopy_si_scls ) - + call this%set_history_var(vname='NPP_LEAF_CANOPY_SCLS', units = 'kg C / ha / yr', & long='NPP_LEAF for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=-999.9_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_canopy_si_scls ) - + call this%set_history_var(vname='NPP_FROOT_CANOPY_SCLS', units = 'kg C / ha / yr', & long='NPP_FROOT for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_fnrt_canopy_si_scls ) - + call this%set_history_var(vname='NPP_BSW_CANOPY_SCLS', units = 'kg C / ha / yr', & long='NPP_BSW for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_sapw_canopy_si_scls ) - + call this%set_history_var(vname='NPP_BDEAD_CANOPY_SCLS', units = 'kg C / ha / yr', & long='NPP_BDEAD for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_dead_canopy_si_scls ) - + call this%set_history_var(vname='NPP_BSEED_CANOPY_SCLS', units = 'kg C / ha / yr', & long='NPP_BSEED for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_seed_canopy_si_scls ) - + call this%set_history_var(vname='NPP_STORE_CANOPY_SCLS', units = 'kg C / ha / yr', & long='NPP_STORE for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stor_canopy_si_scls ) - + call this%set_history_var(vname='LEAF_MR', units = 'kg C / m2 / yr', & long='RDARK (leaf maintenance respiration)', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_leaf_mr_si ) - + call this%set_history_var(vname='FROOT_MR', units = 'kg C / m2 / yr', & long='fine root maintenance respiration)', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_froot_mr_si ) - + call this%set_history_var(vname='LIVECROOT_MR', units = 'kg C / m2 / yr', & long='live coarse root maintenance respiration)', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livecroot_mr_si ) - + call this%set_history_var(vname='LIVESTEM_MR', units = 'kg C / m2 / yr', & long='live stem maintenance respiration)', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livestem_mr_si ) - + call this%set_history_var(vname='RDARK_CANOPY_SCLS', units = 'kg C / ha / yr', & long='RDARK for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_rdark_canopy_si_scls ) - + call this%set_history_var(vname='LIVESTEM_MR_CANOPY_SCLS', units = 'kg C / ha / yr', & long='LIVESTEM_MR for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livestem_mr_canopy_si_scls ) - + call this%set_history_var(vname='LIVECROOT_MR_CANOPY_SCLS', units = 'kg C / ha / yr', & long='LIVECROOT_MR for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livecroot_mr_canopy_si_scls ) - + call this%set_history_var(vname='FROOT_MR_CANOPY_SCLS', units = 'kg C / ha / yr', & long='FROOT_MR for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_froot_mr_canopy_si_scls ) - + call this%set_history_var(vname='RESP_G_CANOPY_SCLS', units = 'kg C / ha / yr', & long='RESP_G for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_g_canopy_si_scls ) - + call this%set_history_var(vname='RESP_M_CANOPY_SCLS', units = 'kg C / ha / yr', & long='RESP_M for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & @@ -5847,7 +5870,7 @@ subroutine define_history_vars(this, initialize_variables) long='LEAF_MD for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leaf_md_understory_si_scls ) - + call this%set_history_var(vname='ROOT_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='ROOT_MD for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & @@ -5857,7 +5880,7 @@ subroutine define_history_vars(this, initialize_variables) long='BSTORE_MD for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstore_md_understory_si_scls ) - + call this%set_history_var(vname='BDEAD_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='BDEAD_MD for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & @@ -5867,67 +5890,67 @@ subroutine define_history_vars(this, initialize_variables) long='BSW_MD for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bsw_md_understory_si_scls ) - + call this%set_history_var(vname='SEED_PROD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='SEED_PROD for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_seed_prod_understory_si_scls ) - + call this%set_history_var(vname='NPP_LEAF_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='NPP_LEAF for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_understory_si_scls ) - + call this%set_history_var(vname='NPP_FROOT_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='NPP_FROOT for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_fnrt_understory_si_scls ) - + call this%set_history_var(vname='NPP_BSW_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='NPP_BSW for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_sapw_understory_si_scls ) - + call this%set_history_var(vname='NPP_BDEAD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='NPP_BDEAD for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_dead_understory_si_scls ) - + call this%set_history_var(vname='NPP_BSEED_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='NPP_BSEED for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_seed_understory_si_scls ) - + call this%set_history_var(vname='NPP_STORE_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='NPP_STORE for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stor_understory_si_scls ) - + call this%set_history_var(vname='RDARK_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='RDARK for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_rdark_understory_si_scls ) - + call this%set_history_var(vname='LIVESTEM_MR_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='LIVESTEM_MR for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livestem_mr_understory_si_scls ) - + call this%set_history_var(vname='LIVECROOT_MR_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='LIVECROOT_MR for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livecroot_mr_understory_si_scls ) - + call this%set_history_var(vname='FROOT_MR_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='FROOT_MR for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_froot_mr_understory_si_scls ) - + call this%set_history_var(vname='RESP_G_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='RESP_G for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_g_understory_si_scls ) - + call this%set_history_var(vname='RESP_M_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='RESP_M for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & @@ -5945,17 +5968,17 @@ subroutine define_history_vars(this, initialize_variables) long='heterotrophic respiration', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_hr_si ) - + call this%set_history_var(vname='Fire_Closs', units='gC/m^2/s', & long='ED/SPitfire Carbon loss to atmosphere', use_default='active', & 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, & @@ -5997,7 +6020,7 @@ subroutine define_history_vars(this, initialize_variables) long='total vegetation carbon mass in live plants by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_totvegc_scpf ) - + call this%set_history_var(vname='LEAFC_SCPF', units='kgC/ha', & long='leaf carbon mass by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & @@ -6007,22 +6030,22 @@ subroutine define_history_vars(this, initialize_variables) long='fine-root carbon mass by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fnrtc_scpf ) - + call this%set_history_var(vname='SAPWC_SCPF', units='kgC/ha', & long='sapwood carbon mass by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sapwc_scpf ) - + call this%set_history_var(vname='STOREC_SCPF', units='kgC/ha', & long='storage carbon mass by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storec_scpf ) - + call this%set_history_var(vname='REPROC_SCPF', units='kgC/ha', & long='reproductive carbon mass (on plant) by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_reproc_scpf ) - + call this%set_history_var(vname='CEFFLUX_SCPF', units='kg/ha/day', & long='carbon efflux, root to soil, by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & @@ -6064,7 +6087,7 @@ subroutine define_history_vars(this, initialize_variables) long='storage nitrogen fraction of target,in understory, by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storentfrac_understory_scpf ) - + call this%set_history_var(vname='REPRON_SCPF', units='kgN/ha', & long='reproductive nitrogen mass (on plant) by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & @@ -6089,7 +6112,7 @@ subroutine define_history_vars(this, initialize_variables) long='plant N need (algorithm dependent), by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nneed_scpf ) - + end if nitrogen_active_if2 ! PHOSPHORUS @@ -6128,7 +6151,7 @@ subroutine define_history_vars(this, initialize_variables) long='storage phosphorus fraction of target,in understory, by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storeptfrac_understory_scpf ) - + call this%set_history_var(vname='REPROP_SCPF', units='kgP/ha', & long='reproductive phosphorus mass (on plant) by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & @@ -6148,7 +6171,7 @@ subroutine define_history_vars(this, initialize_variables) long='plant P need (algorithm dependent), by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_pneed_scpf ) - + end if phosphorus_active_if2 ! organ-partitioned NPP / allocation fluxes @@ -6186,7 +6209,7 @@ subroutine define_history_vars(this, initialize_variables) ! PLANT HYDRAULICS hydro_active_if: if(hlm_use_planthydro.eq.itrue) then - + call this%set_history_var(vname='FATES_ERRH2O_SCPF', units='kg/indiv/s', & long='mean individual water balance error', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & @@ -6207,34 +6230,34 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sapflow_si ) - + call this%set_history_var(vname='FATES_ITERH1_SCPF', units='count/indiv/step', & long='water balance error iteration diagnostic 1', & 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_iterh1_scpf ) - + call this%set_history_var(vname='FATES_ITERH2_SCPF', units='count/indiv/step', & long='water balance error iteration diagnostic 2', & 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_iterh2_scpf ) - + 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_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_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_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, & @@ -6244,47 +6267,47 @@ subroutine define_history_vars(this, initialize_variables) 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_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_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_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_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_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_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_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_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_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, & @@ -6294,42 +6317,42 @@ subroutine define_history_vars(this, initialize_variables) 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, & @@ -6359,21 +6382,21 @@ subroutine define_history_vars(this, initialize_variables) long='amount of water in new recruits', use_default='inactive', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_recruit_si ) - + call this%set_history_var(vname='H2OVEG_GROWTURN_ERR', units = 'kg/m2', & long='cumulative net borrowed (+) or lost (-) from plant_stored_h2o due to combined growth & turnover', use_default='inactive', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_growturn_err_si ) - + call this%set_history_var(vname='H2OVEG_HYDRO_ERR', units = 'kg/m2', & long='cumulative net borrowed (+) from plant_stored_h2o due to plant hydrodynamics', use_default='inactive', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_hydro_err_si ) - end if hydro_active_if + end if hydro_active_if ! Must be last thing before return this%num_history_vars_ = ivar - + end subroutine define_history_vars From 7abd73fcf0f8504f617aa53612abe8c64138222b Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Tue, 28 Sep 2021 12:53:30 -0600 Subject: [PATCH 408/578] updates to history variable names and units --- main/FatesHistoryInterfaceMod.F90 | 1397 ++++++++++++++++------------- 1 file changed, 751 insertions(+), 646 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 80032ce6b0..3e6fe944c4 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2095,26 +2095,29 @@ subroutine update_history_dyn(this,nc,nsites,sites) end if ! error in primary lands from patch fusion - hio_primaryland_fusion_error_si(io_si) = sites(s)%primary_land_patchfusion_error + hio_primaryland_fusion_error_si(io_si) = sites(s)%primary_land_patchfusion_error * days_per_year ! output site-level disturbance rates - hio_disturbance_rate_p2p_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_primary(1:N_DIST_TYPES)) - hio_disturbance_rate_p2s_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_secondary(1:N_DIST_TYPES)) - hio_disturbance_rate_s2s_si(io_si) = sum(sites(s)%disturbance_rates_secondary_to_secondary(1:N_DIST_TYPES)) + hio_disturbance_rate_p2p_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_primary(1:N_DIST_TYPES)) * days_per_year + hio_disturbance_rate_p2s_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_secondary(1:N_DIST_TYPES)) * days_per_year + hio_disturbance_rate_s2s_si(io_si) = sum(sites(s)%disturbance_rates_secondary_to_secondary(1:N_DIST_TYPES)) * days_per_year - hio_fire_disturbance_rate_si(io_si) = sites(s)%disturbance_rates_primary_to_primary(dtype_ifire) + & + hio_fire_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ifire) + & sites(s)%disturbance_rates_primary_to_secondary(dtype_ifire) + & - sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifire) + sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifire)) * & + days_per_year - hio_logging_disturbance_rate_si(io_si) = sites(s)%disturbance_rates_primary_to_primary(dtype_ilog) + & + hio_logging_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ilog) + & sites(s)%disturbance_rates_primary_to_secondary(dtype_ilog) + & - sites(s)%disturbance_rates_secondary_to_secondary(dtype_ilog) + sites(s)%disturbance_rates_secondary_to_secondary(dtype_ilog)) * & + days_per_year - hio_fall_disturbance_rate_si(io_si) = sites(s)%disturbance_rates_primary_to_primary(dtype_ifall) + & + hio_fall_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ifall) + & sites(s)%disturbance_rates_primary_to_secondary(dtype_ifall) + & - sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifall) + sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifall)) * & + days_per_year - hio_potential_disturbance_rate_si(io_si) = sum(sites(s)%potential_disturbance_rates(1:N_DIST_TYPES)) + hio_potential_disturbance_rate_si(io_si) = sum(sites(s)%potential_disturbance_rates(1:N_DIST_TYPES)) * days_per_year hio_harvest_carbonflux_si(io_si) = sites(s)%harvest_carbon_flux @@ -2405,38 +2408,48 @@ subroutine update_history_dyn(this,nc,nsites,sites) gpp_cached = hio_gpp_si_scpf(io_si,scpf) hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + & - n_perm2*ccohort%gpp_acc_hold ! [kgC/m2/yr] + n_perm2*ccohort%gpp_acc_hold / & + days_per_year / sec_per_day ! [kgC/m2/s] hio_npp_totl_si_scpf(io_si,scpf) = hio_npp_totl_si_scpf(io_si,scpf) + & - ccohort%npp_acc_hold *n_perm2 + ccohort%npp_acc_hold *n_perm2 / & + days_per_year / sec_per_day hio_npp_leaf_si_scpf(io_si,scpf) = hio_npp_leaf_si_scpf(io_si,scpf) + & - leaf_m_net_alloc*n_perm2 + leaf_m_net_alloc*n_perm2 / & + days_per_year / sec_per_day hio_npp_fnrt_si_scpf(io_si,scpf) = hio_npp_fnrt_si_scpf(io_si,scpf) + & - fnrt_m_net_alloc*n_perm2 + fnrt_m_net_alloc*n_perm2 / & + days_per_year / sec_per_day hio_npp_bgsw_si_scpf(io_si,scpf) = hio_npp_bgsw_si_scpf(io_si,scpf) + & sapw_m_net_alloc*n_perm2* & - (1._r8-prt_params%allom_agb_frac(ccohort%pft)) + (1._r8-prt_params%allom_agb_frac(ccohort%pft)) / & + days_per_year / sec_per_day hio_npp_agsw_si_scpf(io_si,scpf) = hio_npp_agsw_si_scpf(io_si,scpf) + & sapw_m_net_alloc*n_perm2* & - prt_params%allom_agb_frac(ccohort%pft) + prt_params%allom_agb_frac(ccohort%pft) / & + days_per_year / sec_per_day hio_npp_bgdw_si_scpf(io_si,scpf) = hio_npp_bgdw_si_scpf(io_si,scpf) + & struct_m_net_alloc*n_perm2* & - (1._r8-prt_params%allom_agb_frac(ccohort%pft)) + (1._r8-prt_params%allom_agb_frac(ccohort%pft)) / & + days_per_year / sec_per_day hio_npp_agdw_si_scpf(io_si,scpf) = hio_npp_agdw_si_scpf(io_si,scpf) + & struct_m_net_alloc*n_perm2* & - prt_params%allom_agb_frac(ccohort%pft) + prt_params%allom_agb_frac(ccohort%pft) / & + days_per_year / sec_per_day hio_npp_seed_si_scpf(io_si,scpf) = hio_npp_seed_si_scpf(io_si,scpf) + & - repro_m_net_alloc*n_perm2 + repro_m_net_alloc*n_perm2 / & + days_per_year / sec_per_day hio_npp_stor_si_scpf(io_si,scpf) = hio_npp_stor_si_scpf(io_si,scpf) + & - store_m_net_alloc*n_perm2 + store_m_net_alloc*n_perm2 / & + days_per_year / sec_per_day ! Woody State Variables (basal area growth increment) if ( int(prt_params%woody(ft)) == itrue) then - ! basal area [m2/ha] + ! basal area [m2/m2] hio_ba_si_scpf(io_si,scpf) = hio_ba_si_scpf(io_si,scpf) + & - 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*ccohort%n + 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*ccohort%n / m2_per_ha ! also by size class only hio_ba_si_scls(io_si,scls) = hio_ba_si_scls(io_si,scls) + & @@ -2444,7 +2457,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! growth increment hio_ddbh_si_scpf(io_si,scpf) = hio_ddbh_si_scpf(io_si,scpf) + & - ccohort%ddbhdt*ccohort%n + ccohort%ddbhdt*ccohort%n / m2_per_ha end if @@ -2484,11 +2497,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) endif ! number density [/ha] - hio_nplant_si_scpf(io_si,scpf) = hio_nplant_si_scpf(io_si,scpf) + ccohort%n + hio_nplant_si_scpf(io_si,scpf) = hio_nplant_si_scpf(io_si,scpf) + ccohort%n / m2_per_ha ! number density along the cohort age dimension if (hlm_use_cohort_age_tracking .eq.itrue) then - hio_nplant_si_capf(io_si,capf) = hio_nplant_si_capf(io_si,capf) + ccohort%n + hio_nplant_si_capf(io_si,capf) = hio_nplant_si_capf(io_si,capf) + ccohort%n / m2_per_ha hio_nplant_si_cacls(io_si,cacls) = hio_nplant_si_cacls(io_si,cacls)+ccohort%n end if @@ -2519,35 +2532,35 @@ subroutine update_history_dyn(this,nc,nsites,sites) iscag = get_sizeage_class_index(ccohort%dbh,cpatch%age) - hio_nplant_si_scag(io_si,iscag) = hio_nplant_si_scag(io_si,iscag) + ccohort%n + hio_nplant_si_scag(io_si,iscag) = hio_nplant_si_scag(io_si,iscag) + ccohort%n / m2_per_ha - hio_nplant_si_scls(io_si,scls) = hio_nplant_si_scls(io_si,scls) + ccohort%n + hio_nplant_si_scls(io_si,scls) = hio_nplant_si_scls(io_si,scls) + ccohort%n / m2_per_ha ! update size, age, and PFT - indexed quantities iscagpft = get_sizeagepft_class_index(ccohort%dbh,cpatch%age,ccohort%pft) - hio_nplant_si_scagpft(io_si,iscagpft) = hio_nplant_si_scagpft(io_si,iscagpft) + ccohort%n + hio_nplant_si_scagpft(io_si,iscagpft) = hio_nplant_si_scagpft(io_si,iscagpft) + ccohort%n / m2_per_ha ! update age and PFT - indexed quantities iagepft = get_agepft_class_index(cpatch%age,ccohort%pft) hio_npp_si_agepft(io_si,iagepft) = hio_npp_si_agepft(io_si,iagepft) + & - ccohort%n * ccohort%npp_acc_hold * AREA_INV + ccohort%n * ccohort%npp_acc_hold * AREA_INV / days_per_year / sec_per_day hio_biomass_si_agepft(io_si,iagepft) = hio_biomass_si_agepft(io_si,iagepft) + & total_m * ccohort%n * AREA_INV ! update SCPF/SCLS- and canopy/subcanopy- partitioned quantities if (ccohort%canopy_layer .eq. 1) then - hio_nplant_canopy_si_scag(io_si,iscag) = hio_nplant_canopy_si_scag(io_si,iscag) + ccohort%n + hio_nplant_canopy_si_scag(io_si,iscag) = hio_nplant_canopy_si_scag(io_si,iscag) + ccohort%n / m2_per_ha hio_mortality_canopy_si_scag(io_si,iscag) = hio_mortality_canopy_si_scag(io_si,iscag) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha hio_ddbh_canopy_si_scag(io_si,iscag) = hio_ddbh_canopy_si_scag(io_si,iscag) + & - ccohort%ddbhdt*ccohort%n + ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha hio_bstor_canopy_si_scpf(io_si,scpf) = hio_bstor_canopy_si_scpf(io_si,scpf) + & store_m * ccohort%n hio_bleaf_canopy_si_scpf(io_si,scpf) = hio_bleaf_canopy_si_scpf(io_si,scpf) + & @@ -2576,13 +2589,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%n * ccohort%canopy_trim hio_crown_area_canopy_si_scls(io_si,scls) = hio_crown_area_canopy_si_scls(io_si,scls) + & ccohort%c_area - hio_gpp_canopy_si_scpf(io_si,scpf) = hio_gpp_canopy_si_scpf(io_si,scpf) + & - n_perm2*ccohort%gpp_acc_hold + hio_gpp_canopy_si_scpf(io_si,scpf) = hio_gpp_canopy_si_scpf(io_si,scpf) + & + n_perm2*ccohort%gpp_acc_hold / days_per_year / sec_per_day hio_ar_canopy_si_scpf(io_si,scpf) = hio_ar_canopy_si_scpf(io_si,scpf) + & - n_perm2*ccohort%resp_acc_hold + n_perm2*ccohort%resp_acc_hold / days_per_year / sec_per_day ! growth increment hio_ddbh_canopy_si_scpf(io_si,scpf) = hio_ddbh_canopy_si_scpf(io_si,scpf) + & - ccohort%ddbhdt*ccohort%n + ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha hio_ddbh_canopy_si_scls(io_si,scls) = hio_ddbh_canopy_si_scls(io_si,scls) + & ccohort%ddbhdt*ccohort%n @@ -2636,12 +2649,12 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) + & ccohort%canopy_layer_yesterday * ccohort%n else - hio_nplant_understory_si_scag(io_si,iscag) = hio_nplant_understory_si_scag(io_si,iscag) + ccohort%n + hio_nplant_understory_si_scag(io_si,iscag) = hio_nplant_understory_si_scag(io_si,iscag) + ccohort%n / m2_per_ha hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha hio_ddbh_understory_si_scag(io_si,iscag) = hio_ddbh_understory_si_scag(io_si,iscag) + & - ccohort%ddbhdt*ccohort%n + ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & store_m * ccohort%n hio_bleaf_understory_si_scpf(io_si,scpf) = hio_bleaf_understory_si_scpf(io_si,scpf) + & @@ -2670,13 +2683,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_crown_area_understory_si_scls(io_si,scls) = hio_crown_area_understory_si_scls(io_si,scls) + & ccohort%c_area hio_gpp_understory_si_scpf(io_si,scpf) = hio_gpp_understory_si_scpf(io_si,scpf) + & - n_perm2*ccohort%gpp_acc_hold + n_perm2*ccohort%gpp_acc_hold / days_per_year / sec_per_day hio_ar_understory_si_scpf(io_si,scpf) = hio_ar_understory_si_scpf(io_si,scpf) + & - n_perm2*ccohort%resp_acc_hold + n_perm2*ccohort%resp_acc_hold / days_per_year / sec_per_day ! growth increment hio_ddbh_understory_si_scpf(io_si,scpf) = hio_ddbh_understory_si_scpf(io_si,scpf) + & - ccohort%ddbhdt*ccohort%n + ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha hio_ddbh_understory_si_scls(io_si,scls) = hio_ddbh_understory_si_scls(io_si,scls) + & ccohort%ddbhdt*ccohort%n @@ -2937,7 +2950,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! while in this loop, pass the fusion-induced growth rate flux to history hio_growthflux_fusion_si_scpf(io_si,i_scpf) = hio_growthflux_fusion_si_scpf(io_si,i_scpf) + & - sites(s)%growthflux_fusion(i_scls, i_pft) * days_per_year + sites(s)%growthflux_fusion(i_scls, i_pft) * days_per_year / m2_per_ha @@ -3332,16 +3345,16 @@ subroutine update_history_dyn(this,nc,nsites,sites) end do ! ! convert kg C / ha / day to gc / m2 / sec - hio_demotion_carbonflux_si(io_si) = sites(s)%demotion_carbonflux * g_per_kg * ha_per_m2 * days_per_sec - hio_promotion_carbonflux_si(io_si) = sites(s)%promotion_carbonflux * g_per_kg * ha_per_m2 * days_per_sec + hio_demotion_carbonflux_si(io_si) = sites(s)%demotion_carbonflux * ha_per_m2 * days_per_sec + hio_promotion_carbonflux_si(io_si) = sites(s)%promotion_carbonflux * ha_per_m2 * days_per_sec ! ! mortality-associated carbon fluxes hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & - sites(s)%term_carbonflux_canopy * g_per_kg * days_per_sec * ha_per_m2 + sites(s)%term_carbonflux_canopy * days_per_sec * ha_per_m2 hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & - sites(s)%term_carbonflux_ustory * g_per_kg * days_per_sec * ha_per_m2 + sites(s)%term_carbonflux_ustory * days_per_sec * ha_per_m2 ! and zero the site-level termination carbon flux variable sites(s)%term_carbonflux_canopy = 0._r8 @@ -3511,17 +3524,17 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! Canopy resitance terms hio_c_stomata_si_age(io_si,cpatch%age_class) = & hio_c_stomata_si_age(io_si,cpatch%age_class) + & - cpatch%c_stomata * cpatch%total_canopy_area + cpatch%c_stomata * cpatch%total_canopy_area / umol_per_mol hio_c_lblayer_si_age(io_si,cpatch%age_class) = & hio_c_lblayer_si_age(io_si,cpatch%age_class) + & - cpatch%c_lblayer * cpatch%total_canopy_area + cpatch%c_lblayer * cpatch%total_canopy_area / umol_per_mol hio_c_stomata_si(io_si) = hio_c_stomata_si(io_si) + & - cpatch%c_stomata * cpatch%total_canopy_area + cpatch%c_stomata * cpatch%total_canopy_area / umol_per_mol hio_c_lblayer_si(io_si) = hio_c_lblayer_si(io_si) + & - cpatch%c_lblayer * cpatch%total_canopy_area + cpatch%c_lblayer * cpatch%total_canopy_area / umol_per_mol ccohort => cpatch%shortest do while(associated(ccohort)) @@ -3540,16 +3553,16 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! scale up cohort fluxes to the site level hio_npp_si(io_si) = hio_npp_si(io_si) + & - npp * g_per_kg * n_perm2 * per_dt_tstep + npp * 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 + ccohort%gpp_tstep * n_perm2 * per_dt_tstep hio_aresp_si(io_si) = hio_aresp_si(io_si) + & - aresp * g_per_kg * n_perm2 * per_dt_tstep + aresp * n_perm2 * per_dt_tstep hio_growth_resp_si(io_si) = hio_growth_resp_si(io_si) + & - resp_g * g_per_kg * n_perm2 * per_dt_tstep + resp_g * 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 + ccohort%resp_m * n_perm2 * per_dt_tstep ! Add up the total Net Ecosystem Production ! for this timestep. [gC/m2/s] @@ -3598,18 +3611,18 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! accumulate fluxes per patch age bin hio_gpp_si_age(io_si,cpatch%age_class) = hio_gpp_si_age(io_si,cpatch%age_class) & - + ccohort%gpp_tstep * ccohort%n * g_per_kg * per_dt_tstep + + ccohort%gpp_tstep * ccohort%n * per_dt_tstep hio_npp_si_age(io_si,cpatch%age_class) = hio_npp_si_age(io_si,cpatch%age_class) & - + npp * ccohort%n * g_per_kg * per_dt_tstep + + npp * ccohort%n * per_dt_tstep ! accumulate fluxes on canopy- and understory- separated fluxes if (ccohort%canopy_layer .eq. 1) then ! ! bulk fluxes are in gC / m2 / s hio_gpp_canopy_si(io_si) = hio_gpp_canopy_si(io_si) + & - ccohort%gpp_tstep * g_per_kg * n_perm2 * per_dt_tstep + ccohort%gpp_tstep * n_perm2 * per_dt_tstep hio_ar_canopy_si(io_si) = hio_ar_canopy_si(io_si) + & - aresp * g_per_kg * n_perm2 * per_dt_tstep + aresp * n_perm2 * per_dt_tstep ! ! size-resolved respiration fluxes are in kg C / ha / yr @@ -3629,9 +3642,9 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! ! bulk fluxes are in gC / m2 / s hio_gpp_understory_si(io_si) = hio_gpp_understory_si(io_si) + & - ccohort%gpp_tstep * g_per_kg * n_perm2 * per_dt_tstep + ccohort%gpp_tstep * n_perm2 * per_dt_tstep hio_ar_understory_si(io_si) = hio_ar_understory_si(io_si) + & - aresp * g_per_kg * n_perm2 * per_dt_tstep + aresp * n_perm2 * per_dt_tstep ! ! size-resolved respiration fluxes are in kg C / ha / yr @@ -3656,7 +3669,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) do ileaf=1,ccohort%nv cnlf_indx = ileaf + (ican-1) * nlevleaf hio_ts_net_uptake_si_cnlf(io_si, cnlf_indx) = hio_ts_net_uptake_si_cnlf(io_si, cnlf_indx) + & - ccohort%ts_net_uptake(ileaf) * g_per_kg * per_dt_tstep * ccohort%c_area / AREA + ccohort%ts_net_uptake(ileaf) * per_dt_tstep * ccohort%c_area / AREA end do ccohort => ccohort%taller @@ -4879,911 +4892,1003 @@ subroutine define_history_vars(this, initialize_variables) ! disturbance rates call this%set_history_var(vname='FATES_PRIMARYLAND_PATCHFUSION_ERROR', & - units='m2 m-2 yr-1', & - long='error in total primary lands associated with patch fusion', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_primaryland_fusion_error_si ) - - call this%set_history_var(vname='FATES_DISTURBANCE_RATE_P2P', units='m2 m-2 d-1', & - long='Disturbance rate from primary to primary lands', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_disturbance_rate_p2p_si ) - - call this%set_history_var(vname='DISTURBANCE_RATE_P2S', units='m2 m-2 d-1', & - long='Disturbance rate from primary to secondary lands', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_disturbance_rate_p2s_si ) - - call this%set_history_var(vname='DISTURBANCE_RATE_S2S', units='m2 m-2 d-1', & - long='Disturbance rate from secondary to secondary lands', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_disturbance_rate_s2s_si ) - - call this%set_history_var(vname='DISTURBANCE_RATE_FIRE', units='m2 m-2 d-1', & - long='Disturbance rate from fire', 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_disturbance_rate_si ) - - call this%set_history_var(vname='DISTURBANCE_RATE_LOGGING', units='m2 m-2 d-1', & - long='Disturbance rate from logging', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_logging_disturbance_rate_si ) - - call this%set_history_var(vname='DISTURBANCE_RATE_TREEFALL', units='m2 m-2 d-1', & - long='Disturbance rate from treefall', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fall_disturbance_rate_si ) - - call this%set_history_var(vname='DISTURBANCE_RATE_POTENTIAL', units='m2 m-2 d-1', & - long='Potential (i.e., including unresolved) disturbance rate', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_potential_disturbance_rate_si ) - - call this%set_history_var(vname='HARVEST_CARBON_FLUX', units='kg C m-2 d-1', & - long='Harvest carbon flux', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_harvest_carbonflux_si ) + units='m2 m-2 yr-1', & + long='error in total primary lands associated with patch fusion', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_primaryland_fusion_error_si) + + call this%set_history_var(vname='FATES_DISTURBANCE_RATE_P2P', & + units='m2 m-2 yr-1', & + long='disturbance rate from primary to primary lands', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_disturbance_rate_p2p_si) + + call this%set_history_var(vname='FATES_DISTURBANCE_RATE_P2S', & + units='m2 m-2 yr-1', & + long='disturbance rate from primary to secondary lands', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_disturbance_rate_p2s_si ) + + call this%set_history_var(vname='FATES_DISTURBANCE_RATE_S2S', & + units='m2 m-2 yr-1', & + long='disturbance rate from secondary to secondary lands', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_disturbance_rate_s2s_si) + + call this%set_history_var(vname='FATES_DISTURBANCE_RATE_FIRE', & + units='m2 m-2 yr-1', long='disturbance rate from fire', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fire_disturbance_rate_si) + + call this%set_history_var(vname='FATES_DISTURBANCE_RATE_LOGGING', & + units='m2 m-2 yr-1', long='disturbance rate from logging', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_logging_disturbance_rate_si) + + call this%set_history_var(vname='FATES_DISTURBANCE_RATE_TREEFALL', & + units='m2 m-2 yr-1', long='disturbance rate from treefall', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fall_disturbance_rate_si) + + call this%set_history_var(vname='FATES_DISTURBANCE_RATE_POTENTIAL', & + units='m2 m-2 yr-1', & + long='potential (i.e., including unresolved) disturbance rate', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_potential_disturbance_rate_si) + + call this%set_history_var(vname='FATES_HARVEST_CARBON_FLUX', & + units='kg m-2 yr-1', & + long='harvest carbon flux in kg carbon per m2 per year', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_harvest_carbonflux_si) ! Canopy Resistance - call this%set_history_var(vname='C_STOMATA', units='umol m-2 s-1', & - long='mean stomatal conductance', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_c_stomata_si ) + call this%set_history_var(vname='FATES_STOMATAL_COND', & + units='mol m-2 s-1', long='mean stomatal conductance', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_c_stomata_si) - call this%set_history_var(vname='C_LBLAYER', units='umol m-2 s-1', & - long='mean leaf boundary layer conductance', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_c_lblayer_si ) + call this%set_history_var(vname='FATES_LBLAYER_COND', units='mol m-2 s-1', & + long='mean leaf boundary layer conductance', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_c_lblayer_si) ! Ecosystem Carbon Fluxes (updated rapidly, upfreq=2) - 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='FATES_NPP', units='kg m-2 s-1', & + long='net primary production in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + 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=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='FATES_GPP', units='kg m-2 s-1', & + long='gross primary production in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + 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=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='FATES_AUTO_RESP', units='kg m-2 s-1', & + long='autotrophic respiration in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + 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=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='FATES_GROWTH_RESP', units='kg m-2 s-1', & + long='growth respiration in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + 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=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_maint_resp_si ) + call this%set_history_var(vname='FATES_MAINT_RESP', units='kg m-2 s-1', & + long='maintenance respiration in kg carbon per m2 land area per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_maint_resp_si) ! Canopy resistance - call this%set_history_var(vname='C_STOMATA_BY_AGE', units='umol m-2 s-1', & - long='mean stomatal conductance - by patch age', use_default='inactive', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_c_stomata_si_age ) + call this%set_history_var(vname='FATES_STOMATAL_COND_AP', & + units='mol m-2 s-1', long='mean stomatal conductance - by patch age', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_c_stomata_si_age) - call this%set_history_var(vname='C_LBLAYER_BY_AGE', units='umol m-2 s-1', & - long='mean leaf boundary layer conductance - by patch age', use_default='inactive', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_c_lblayer_si_age ) + call this%set_history_var(vname='FATES_LBLAYER_COND_AP', & + units='mol m-2 s-1', & + long='mean leaf boundary layer conductance - by patch age', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_c_lblayer_si_age) ! fast fluxes by age bin - call this%set_history_var(vname='NPP_BY_AGE', units='gC/m^2/s', & - long='net primary productivity by age bin', use_default='inactive', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_npp_si_age ) + call this%set_history_var(vname='FATES_NPP_AP', units='kg m-2 s-1', & + long='net primary productivity by age bin in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_si_age) - call this%set_history_var(vname='GPP_BY_AGE', units='gC/m^2/s', & - long='gross primary productivity by age bin', use_default='inactive', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_gpp_si_age ) + call this%set_history_var(vname='FATES_GPP_AP', units='kg m-2 s-1', & + long='gross primary productivity by age bin in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_gpp_si_age) ! 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=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=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='FATES_GPP_CANOPY', units='kg m-2 s-1', & + long='gross primary production of canopy plants in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_gpp_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=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='FATES_AUTO_RESP_CANOPY', & + units='kg m-2 s-1', & + long='autotrophic respiration of canopy plants in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, i & + ndex = ih_ar_canopy_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=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_ar_understory_si ) + call this%set_history_var(vname='FATES_GPP_UNDERSTORY', & + units='kg m-2 s-1', & + long='gross primary production of understory plants in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_gpp_understory_si) + call this%set_history_var(vname='FATES_AUTO_RESP_UNDERSTORY', & + units='kg m-2 s-1', & + long='autotrophic respiration of understory plants in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_ar_understory_si) ! fast radiative fluxes resolved through the canopy - call this%set_history_var(vname='PARSUN_Z_CNLF', units='W/m2', & - long='PAR absorbed in the sun by each canopy and leaf layer', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parsun_z_si_cnlf ) - - call this%set_history_var(vname='PARSHA_Z_CNLF', units='W/m2', & - long='PAR absorbed in the shade by each canopy and leaf layer', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parsha_z_si_cnlf ) - - call this%set_history_var(vname='PARSUN_Z_CNLFPFT', units='W/m2', & - long='PAR absorbed in the sun by each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parsun_z_si_cnlfpft ) - - call this%set_history_var(vname='PARSHA_Z_CNLFPFT', units='W/m2', & - long='PAR absorbed in the shade by each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parsha_z_si_cnlfpft ) - - call this%set_history_var(vname='PARSUN_Z_CAN', units='W/m2', & + + call this%set_history_var(vname='FATES_PARSUN_Z_CLLL', units='W m-2', & + long='PAR absorbed in the sun by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_parsun_z_si_cnlf) + + call this%set_history_var(vname='FATES_PARSHA_Z_CLLL', units='W m-2', & + long='PAR absorbed in the shade by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_parsha_z_si_cnlf) + + call this%set_history_var(vname='FATES_PARSUN_Z_CLLLPF', units='W m-2', & + long='PAR absorbed in the sun by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parsun_z_si_cnlfpft) + + call this%set_history_var(vname='FATES_PARSHA_Z_CLLLPF', units='W m-2', & + long='PAR absorbed in the shade by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parsha_z_si_cnlfpft) + + call this%set_history_var(vname='FATES_PARSUN_Z_CL', units='W m-2', & long='PAR absorbed in the sun by top leaf layer in each canopy layer', & - use_default='inactive', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parsun_top_si_can ) + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parsun_top_si_can ) - call this%set_history_var(vname='PARSHA_Z_CAN', units='W/m2', & + call this%set_history_var(vname='FATES_PARSHA_Z_CL', units='W m-2', & long='PAR absorbed in the shade by top leaf layer in each canopy layer', & - use_default='inactive', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parsha_top_si_can ) - - call this%set_history_var(vname='LAISUN_Z_CNLF', units='m2/m2', & - long='LAI in the sun by each canopy and leaf layer', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_laisun_z_si_cnlf ) - - call this%set_history_var(vname='LAISHA_Z_CNLF', units='m2/m2', & - long='LAI in the shade by each canopy and leaf layer', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_laisha_z_si_cnlf ) - - call this%set_history_var(vname='LAISUN_Z_CNLFPFT', units='m2/m2', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parsha_top_si_can) + + call this%set_history_var(vname='FATES_LAISUN_Z_CLLL', units='m2 m-2', & + long='LAI in the sun by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisun_z_si_cnlf) + + call this%set_history_var(vname='FATES_LAISHA_Z_CLLL', units='m2 m-2', & + long='LAI in the shade by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisha_z_si_cnlf) + + call this%set_history_var(vname='FATES_LAISUN_Z_CLLLPF', units='m2 m-2', & long='LAI in the sun by each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_laisun_z_si_cnlfpft ) - - call this%set_history_var(vname='LAISHA_Z_CNLFPFT', units='m2/m2', & - long='LAI in the shade by each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_laisha_z_si_cnlfpft ) - - call this%set_history_var(vname='LAISUN_TOP_CAN', units='m2/m2', & - long='LAI in the sun by the top leaf layer of each canopy layer', & - use_default='inactive', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_laisun_top_si_can ) - - call this%set_history_var(vname='LAISHA_TOP_CAN', units='m2/m2', & - long='LAI in the shade by the top leaf layer of each canopy layer', & - use_default='inactive', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_laisha_top_si_can ) - - call this%set_history_var(vname='FABD_SUN_CNLFPFT', units='fraction', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisun_z_si_cnlfpft) + + call this%set_history_var(vname='FATES_LAISHA_Z_CLLLPF', units='m2 m-2', & + long='LAI in the shade by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisha_z_si_cnlfpft) + + call this%set_history_var(vname='FATES_LAISUN_TOP_CL', units='m2 m-2', & + long='LAI in the sun by the top leaf layer of each canopy layer', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisun_top_si_can) + + call this%set_history_var(vname='FATES_LAISHA_TOP_CL', units='m2 m-2', & + long='LAI in the shade by the top leaf layer of each canopy layer', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisha_top_si_can) + + call this%set_history_var(vname='FATES_FABD_SUN_CLLLPF', units='1', & long='sun fraction of direct light absorbed by each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabd_sun_si_cnlfpft ) + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sun_si_cnlfpft) - call this%set_history_var(vname='FABD_SHA_CNLFPFT', units='fraction', & + call this%set_history_var(vname='FATES_FABD_SHA_CLLLPF', units='1', & long='shade fraction of direct light absorbed by each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabd_sha_si_cnlfpft ) + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sha_si_cnlfpft) - call this%set_history_var(vname='FABI_SUN_CNLFPFT', units='fraction', & + call this%set_history_var(vname='FATES_FABI_SUN_CLLLPF', units='1', & long='sun fraction of indirect light absorbed by each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabi_sun_si_cnlfpft ) + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sun_si_cnlfpft) - call this%set_history_var(vname='FABI_SHA_CNLFPFT', units='fraction', & + call this%set_history_var(vname='FATES_FABI_SHA_CLLLPF', units='1', & long='shade fraction of indirect light absorbed by each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabi_sha_si_cnlfpft ) + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sha_si_cnlfpft) - call this%set_history_var(vname='FABD_SUN_CNLF', units='fraction', & + call this%set_history_var(vname='FATES_FABD_SUN_CLLL', units='1', & long='sun fraction of direct light absorbed by each canopy and leaf layer', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabd_sun_si_cnlf ) + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sun_si_cnlf) - call this%set_history_var(vname='FABD_SHA_CNLF', units='fraction', & + call this%set_history_var(vname='FATES_FABD_SHA_CLLL', units='1', & long='shade fraction of direct light absorbed by each canopy and leaf layer', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabd_sha_si_cnlf ) + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sha_si_cnlf) - call this%set_history_var(vname='FABI_SUN_CNLF', units='fraction', & + call this%set_history_var(vname='FATES_FABI_SUN_CLL', units='1', & long='sun fraction of indirect light absorbed by each canopy and leaf layer', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabi_sun_si_cnlf ) + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sun_si_cnlf) - call this%set_history_var(vname='FABI_SHA_CNLF', units='fraction', & + call this%set_history_var(vname='FATES_FABI_SHA_CLL', units='1', & long='shade fraction of indirect light absorbed by each canopy and leaf layer', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabi_sha_si_cnlf ) - - call this%set_history_var(vname='PARPROF_DIR_CNLFPFT', units='W/m2', & - long='Radiative profile of direct PAR through each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parprof_dir_si_cnlfpft ) - - call this%set_history_var(vname='PARPROF_DIF_CNLFPFT', units='W/m2', & - long='Radiative profile of diffuse PAR through each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parprof_dif_si_cnlfpft ) - - call this%set_history_var(vname='PARPROF_DIR_CNLF', units='W/m2', & - long='Radiative profile of direct PAR through each canopy and leaf layer (averaged across PFTs)', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parprof_dir_si_cnlf ) - - call this%set_history_var(vname='PARPROF_DIF_CNLF', units='W/m2', & - long='Radiative profile of diffuse PAR through each canopy and leaf layer (averaged across PFTs)', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parprof_dif_si_cnlf ) - - call this%set_history_var(vname='FABD_SUN_TOPLF_BYCANLAYER', units='fraction', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sha_si_cnlf) + + call this%set_history_var(vname='FATES_PARPROF_DIR_CLLLPF', units='W m-2', & + long='radiative profile of direct PAR through each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parprof_dir_si_cnlfpft) + + call this%set_history_var(vname='FATES_PARPROF_DIF_CLLLPF', units='W m-2', & + long='radiative profile of diffuse PAR through each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parprof_dif_si_cnlfpft) + + call this%set_history_var(vname='FATES_PARPROF_DIR_CLLL', units='W m-2', & + long='radiative profile of direct PAR through each canopy and leaf layer (averaged across PFTs)', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parprof_dir_si_cnlf) + + call this%set_history_var(vname='FATES_PARPROF_DIF_CLLL', units='W m-2', & + long='radiative profile of diffuse PAR through each canopy and leaf layer (averaged across PFTs)', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parprof_dif_si_cnlf) + + call this%set_history_var(vname='FATES_FABD_SUN_TOPLF_CL', units='1', & long='sun fraction of direct light absorbed by the top leaf layer of each canopy layer', & - use_default='inactive', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabd_sun_top_si_can ) + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sun_top_si_can) - call this%set_history_var(vname='FABD_SHA_TOPLF_BYCANLAYER', units='fraction', & + call this%set_history_var(vname='FATES_FABD_SHA_TOPLF_CL', units='1', & long='shade fraction of direct light absorbed by the top leaf layer of each canopy layer', & - use_default='inactive', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabd_sha_top_si_can ) + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sha_top_si_can) - call this%set_history_var(vname='FABI_SUN_TOPLF_BYCANLAYER', units='fraction', & + call this%set_history_var(vname='FATES_FABI_SUN_TOPLF_CL', units='1', & long='sun fraction of indirect light absorbed by the top leaf layer of each canopy layer', & - use_default='inactive', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabi_sun_top_si_can ) + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sun_top_si_can) - call this%set_history_var(vname='FABI_SHA_TOPLF_BYCANLAYER', units='fraction', & + call this%set_history_var(vname='FATES_FABI_SHA_TOPLF_CL', units='1', & long='shade fraction of indirect light absorbed by the top leaf layer of each canopy layer', & - use_default='inactive', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabi_sha_top_si_can ) + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sha_top_si_can) !!! canopy-resolved fluxes and structure - call this%set_history_var(vname='NET_C_UPTAKE_CNLF', units='gC/m2/s', & - long='net carbon uptake by each canopy and leaf layer per unit ground area (i.e. divide by CROWNAREA_CNLF to make per leaf area)', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_ts_net_uptake_si_cnlf ) - call this%set_history_var(vname='CROWNAREA_CNLF', units='m2/m2', & + call this%set_history_var(vname='FATES_NET_C_UPTAKE_CLLL', & + units='kg m-2 s-1', & + long='net carbon uptake in kg carbon per m2 per second by each canopy and leaf layer per unit ground area (i.e. divide by CROWNAREA_CLLL to make per leaf area)', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_ts_net_uptake_si_cnlf) + + call this%set_history_var(vname='FATES_CROWNAREA_CLLL', units='m2 m-2', & long='total crown area that is occupied by leaves in each canopy and leaf layer', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_crownarea_si_cnlf ) + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_crownarea_si_cnlf) - call this%set_history_var(vname='CROWNAREA_CAN', units='m2/m2', & - long='total crown area in each canopy layer', & - use_default='active', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_crownarea_si_can ) + call this%set_history_var(vname='FATES_CROWNAREA_CL', units='m2/m2', & + long='total crown area in each canopy layer', use_default='active', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_crownarea_si_can) ! slow carbon fluxes associated with mortality from or transfer betweeen canopy and understory - call this%set_history_var(vname='DEMOTION_CARBONFLUX', units = 'gC/m2/s', & - long='demotion-associated biomass carbon flux from canopy to understory', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_demotion_carbonflux_si ) - - call this%set_history_var(vname='PROMOTION_CARBONFLUX', units = 'gC/m2/s', & - long='promotion-associated biomass carbon flux from understory to canopy', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_promotion_carbonflux_si ) - - call this%set_history_var(vname='MORTALITY_CARBONFLUX_CANOPY', units = 'gC/m2/s', & - long='flux of biomass carbon from live to dead pools from mortality of canopy plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_canopy_mortality_carbonflux_si ) - - call this%set_history_var(vname='MORTALITY_CARBONFLUX_UNDERSTORY', units = 'gC/m2/s', & - long='flux of biomass carbon from live to dead pools from mortality of understory plants',use_default='active',& - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_understory_mortality_carbonflux_si ) + + call this%set_history_var(vname='FATES_DEMOTION_CARBONFLUX', & + units = 'kg m-2 s-1', & + long='demotion-associated biomass carbon flux from canopy to understory in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_demotion_carbonflux_si) + + call this%set_history_var(vname='FATES_PROMOTION_CARBONFLUX', & + units = 'kg m-2 s-1', & + long='promotion-associated biomass carbon flux from understory to canopy in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_promotion_carbonflux_si) + + call this%set_history_var(vname='FATES_MORTALITY_CARBONFLUX_CANOPY', & + units = 'kg m-2 s-1', & + long='flux of biomass carbon from live to dead pools from mortality of canopy plants in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_canopy_mortality_carbonflux_si) + + call this%set_history_var(vname='FATES_MORTALITY_CARBONFLUX_UNDERSTORY', & + units = 'kg m-2 s-1', & + long='flux of biomass carbon from live to dead pools from mortality of understory plants in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_understory_mortality_carbonflux_si) ! size class by age dimensioned variables - call this%set_history_var(vname='NPLANT_SCAG',units = 'plants/ha', & - long='number of plants per hectare in each size x age class', use_default='inactive', & - avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scag ) - - call this%set_history_var(vname='NPLANT_CANOPY_SCAG',units = 'plants/ha', & - long='number of plants per hectare in canopy in each size x age class', use_default='inactive', & - avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_canopy_si_scag ) - - call this%set_history_var(vname='NPLANT_UNDERSTORY_SCAG',units = 'plants/ha', & - long='number of plants per hectare in understory in each size x age class', use_default='inactive', & - avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_understory_si_scag ) - - call this%set_history_var(vname='DDBH_CANOPY_SCAG',units = 'cm/yr/ha', & - long='growth rate of canopy plantsnumber of plants per hectare in canopy in each size x age class', & - use_default='inactive', avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_canopy_si_scag ) - - call this%set_history_var(vname='DDBH_UNDERSTORY_SCAG',units = 'cm/yr/ha', & - long='growth rate of understory plants in each size x age class', use_default='inactive', & - avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_understory_si_scag ) - - call this%set_history_var(vname='MORTALITY_CANOPY_SCAG',units = 'plants/ha/yr', & - long='mortality rate of canopy plants in each size x age class', use_default='inactive', & - avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_canopy_si_scag ) - - call this%set_history_var(vname='MORTALITY_UNDERSTORY_SCAG',units = 'plants/ha/yr', & - long='mortality rate of understory plantsin each size x age class', use_default='inactive', & - avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_understory_si_scag ) + + call this%set_history_var(vname='FATES_NPLANT_SZAC', units = 'm-2', & + long='number of plants per m2 in each size x age class', & + use_default='inactive', avgflag='A', vtype=site_scag_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nplant_si_scag) + + call this%set_history_var(vname='FATES_NPLANT_CANOPY_SZAC', units = 'm-2', & + long='number of plants per m2 in canopy in each size x age class', & + use_default='inactive', avgflag='A', vtype=site_scag_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nplant_canopy_si_scag) + + call this%set_history_var(vname='FATES_NPLANT_UNDERSTORY_SZAC', & + units = 'm-2', & + long='number of plants per m2 in understory in each size x age class', & + use_default='inactive', avgflag='A', vtype=site_scag_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nplant_understory_si_scag) + + call this%set_history_var(vname='FATES_DDBH_CANOPY_SZAC', & + units = 'm m-2 yr-1', & + long='growth rate of canopy plants in meters DBH per m2 per year in canopy in each size x age class', & + use_default='inactive', avgflag='A', vtype=site_scag_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_ddbh_canopy_si_scag) + + call this%set_history_var(vname='FATES_DDBH_UNDERSTORY_SZAC', & + units = 'm m-2 yr-1', & + long='growth rate of understory plants in meters DBH per m2 per year in each size x age class', & + use_default='inactive', avgflag='A', vtype=site_scag_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_ddbh_understory_si_scag) + + call this%set_history_var(vname='FATES_MORTALITY_CANOPY_SZAC', & + units = 'm-2 yr-1', & + long='mortality rate of canopy plants in number of plants per m2 per year in each size x age class', & + use_default='inactive', avgflag='A', vtype=site_scag_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_mortality_canopy_si_scag) + + call this%set_history_var(vname='FATES_MORTALITY_UNDERSTORY_SZAC', & + units = 'm-2 yr-1', & + long='mortality rate of understory plants in number of plants per m2 per year in each size x age class', + use_default='inactive', avgflag='A', vtype=site_scag_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_mortality_understory_si_scag) ! size x age x pft dimensioned - call this%set_history_var(vname='NPLANT_SCAGPFT',units = 'plants/ha', & - long='number of plants per hectare in each size x age x pft class', use_default='inactive', & - avgflag='A', vtype=site_scagpft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scagpft ) + + call this%set_history_var(vname='FATES_NPLANT_SZACPF',units = 'm-2', & + long='number of plants per m2 in each size x age x pft class', & + use_default='inactive', avgflag='A', vtype=site_scagpft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nplant_si_scagpft) ! age x pft dimensioned - call this%set_history_var(vname='NPP_AGEPFT',units = 'kgC/m2/yr', & - long='NPP per PFT in each age bin', use_default='inactive', & - avgflag='A', vtype=site_agepft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_si_agepft ) + call this%set_history_var(vname='FATES_NPP_ACPF',units = 'kg m-2 s-1', & + long='NPP per PFT in each age bin in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_agepft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_npp_si_agepft) - call this%set_history_var(vname='BIOMASS_AGEPFT',units = 'kg C / m2', & - long='biomass per PFT in each age bin', use_default='inactive', & - avgflag='A', vtype=site_agepft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_agepft ) + call this%set_history_var(vname='FATES_VEGC_ACPF',units = 'kg m-2', & + long='biomass per PFT in each age bin in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_agepft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_biomass_si_agepft) - call this%set_history_var(vname='SCORCH_HEIGHT',units = 'm', & - long='SPITFIRE Flame Scorch Height (calculated per PFT in each patch age bin)', & - use_default='inactive', & - avgflag='A', vtype=site_agepft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_scorch_height_si_agepft ) + call this%set_history_var(vname='FATES_SCORCH_HEIGHT_ACPF',units = 'm', & + long='SPITFIRE flame Scorch Height (calculated per PFT in each patch age bin)', & + use_default='inactive', avgflag='A', vtype=site_agepft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_scorch_height_si_agepft) ! Carbon Flux (grid dimension x scpf) (THESE ARE DEFAULT INACTIVE!!! ! (BECAUSE THEY TAKE UP SPACE!!! ! =================================================================================== - call this%set_history_var(vname='GPP_SCPF', units='kgC/m2/yr', & - long='gross primary production by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_gpp_si_scpf ) - - call this%set_history_var(vname='GPP_CANOPY_SCPF', units='kgC/m2/yr', & - long='gross primary production of canopy plants by pft/size ', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_gpp_canopy_si_scpf ) - - call this%set_history_var(vname='AR_CANOPY_SCPF', units='kgC/m2/yr', & - long='autotrophic respiration of canopy plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ar_canopy_si_scpf ) - - call this%set_history_var(vname='GPP_UNDERSTORY_SCPF', units='kgC/m2/yr', & - long='gross primary production of understory plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_gpp_understory_si_scpf ) - - call this%set_history_var(vname='AR_UNDERSTORY_SCPF', units='kgC/m2/yr', & - long='autotrophic respiration of understory plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ar_understory_si_scpf ) - - call this%set_history_var(vname='NPP_SCPF', units='kgC/m2/yr', & - long='total net primary production by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_totl_si_scpf ) - - call this%set_history_var(vname='NPP_LEAF_SCPF', units='kgC/m2/yr', & - long='NPP flux into leaves by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_si_scpf ) - - call this%set_history_var(vname='NPP_SEED_SCPF', units='kgC/m2/yr', & - long='NPP flux into seeds by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_seed_si_scpf ) - - call this%set_history_var(vname='NPP_FNRT_SCPF', units='kgC/m2/yr', & - long='NPP flux into fine roots by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_fnrt_si_scpf ) - - call this%set_history_var(vname='NPP_BGSW_SCPF', units='kgC/m2/yr', & - long='NPP flux into below-ground sapwood by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bgsw_si_scpf ) - - call this%set_history_var(vname='NPP_BGDW_SCPF', units='kgC/m2/yr', & - long='NPP flux into below-ground deadwood by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bgdw_si_scpf ) - - call this%set_history_var(vname='NPP_AGSW_SCPF', units='kgC/m2/yr', & - long='NPP flux into above-ground sapwood by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_agsw_si_scpf ) - - call this%set_history_var(vname = 'NPP_AGDW_SCPF', units='kgC/m2/yr', & - long='NPP flux into above-ground deadwood by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_agdw_si_scpf ) - - call this%set_history_var(vname = 'NPP_STOR_SCPF', units='kgC/m2/yr', & - long='NPP flux into storage by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stor_si_scpf ) - - call this%set_history_var(vname='DDBH_SCPF', units = 'cm/yr/ha', & - long='diameter growth increment by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_si_scpf ) - - call this%set_history_var(vname='GROWTHFLUX_SCPF', units = 'n/yr/ha', & - long='flux of individuals into a given size class bin via growth and recruitment',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_growthflux_si_scpf ) - - call this%set_history_var(vname='GROWTHFLUX_FUSION_SCPF', units = 'n/yr/ha', & - long='flux of individuals into a given size class bin via fusion',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_growthflux_fusion_si_scpf ) - - call this%set_history_var(vname='DDBH_CANOPY_SCPF', units = 'cm/yr/ha', & - long='diameter growth increment by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_canopy_si_scpf ) - - call this%set_history_var(vname='DDBH_UNDERSTORY_SCPF', units = 'cm/yr/ha', & - long='diameter growth increment by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_understory_si_scpf ) - - call this%set_history_var(vname='BA_SCPF', units = 'm2/ha', & - long='basal area by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scpf ) - - call this%set_history_var(vname='AGB_SCPF', units = 'kgC/m2', & - long='Aboveground biomass by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_agb_si_scpf ) - - call this%set_history_var(vname='NPLANT_SCPF', units = 'N/ha', & - long='stem number density by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scpf ) - - call this%set_history_var(vname='NPLANT_CAPF', units = 'N/ha', & - long='stem number density by pft/coage', use_default='inactive', & - avgflag='A', vtype=site_coage_pft_r8, hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_capf ) + call this%set_history_var(vname='FATES_GPP_SZPF', units='kg m-2 s-1', & + long='gross primary production by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_gpp_si_scpf) + + call this%set_history_var(vname='FATES_GPP_CANOPY_SZPF', & + units='kg m-2 s-1', & + long='gross primary production of canopy plants by pft/size in kg carbon per m2 per second', + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_gpp_canopy_si_scpf) + + call this%set_history_var(vname='FATES_AUTO_RESP_CANOPY_SZPF', & + units='kg m-2 s-1', & + long='autotrophic respiration of canopy plants by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_canopy_si_scpf) + + call this%set_history_var(vname='FATES_GPP_UNDERSTORY_SZPF', & + units='kg m-2 s-1', & + long='gross primary production of understory plants by pft/size in kg carbon per m2 per second', + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_gpp_understory_si_scpf) + + call this%set_history_var(vname='FATES_AUTO_RESP_UNDERSTORY_SZPF', & + units='kg m-2 s-1', & + long='autotrophic respiration of understory plants by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_understory_si_scpf) + + call this%set_history_var(vname='FATES_NPP_SZPF', units='kg m-2 s-1', & + long='total net primary production by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_npp_totl_si_scpf) + + call this%set_history_var(vname='FATES_NPP_LEAF_SZPF', units='kg m-2 s-1', & + long='NPP flux into leaves by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_npp_leaf_si_scpf) + + call this%set_history_var(vname='FATES_NPP_SEED_SZPF', units='kg m-2 s-1', & + long='NPP flux into seeds by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_npp_seed_si_scpf) + + call this%set_history_var(vname='FATES_NPP_FINEROOT_SZPF', & + units='kg m-2 s-1', & + long='NPP flux into fine roots by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_npp_fnrt_si_scpf) + + call this%set_history_var(vname='FATES_NPP_BGSAPWOOD_SZPF', & + units='kg m-2 s-1', & + long='NPP flux into below-ground sapwood by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_bgsw_si_scpf) + + call this%set_history_var(vname='FATES_NPP_BGSTRUCT_SZPF', units='kg m-2 s-1', & + long='NPP flux into below-ground structural (deadwood) by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_bgdw_si_scpf) + + call this%set_history_var(vname='FATES_NPP_AGSAPWOOD_SZPF', & + units='kg m-2 s-1', & + long='NPP flux into above-ground sapwood by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_agsw_si_scpf) + + call this%set_history_var(vname = 'FATES_NPP_AGSTRUCT_SZPF', & + units='kg m-2 s-1', & + long='NPP flux into above-ground structural (deadwood) by pft/size in kg carbon per m2 per second', + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_agdw_si_scpf) + + call this%set_history_var(vname = 'FATES_NPP_STORE_SZPF', & + units='kg m-2 s-1', & + long='NPP flux into storage C by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_stor_si_scpf) + + call this%set_history_var(vname='FATES_DDBH_SZPF', units = 'm m-2 yr-1', & + long='diameter growth increment by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_ddbh_si_scpf) + + call this%set_history_var(vname='FATES_GROWTHFLUX_SZPF', & + units = 'm-2 yr-1', & + long='flux of individuals into a given size class bin via growth and recruitment', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_growthflux_si_scpf) + + call this%set_history_var(vname='FATES_GROWTHFLUX_FUSION_SZPF', & + units = 'm-2 yr-1', & + long='flux of individuals into a given size class bin via fusion', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_growthflux_fusion_si_scpf) + + call this%set_history_var(vname='FATES_DDBH_CANOPY_SZPF', & + units = 'm m-2 yr-1', & + long='diameter growth increment by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_ddbh_canopy_si_scpf) + + call this%set_history_var(vname='FATES_DDBH_UNDERSTORY_SZPF', & + units = 'm m-2 yr-1', & + long='diameter growth increment by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_ddbh_understory_si_scpf) + + call this%set_history_var(vname='FATES_BASALAREA_SZPF', units = 'm2 m-2', & + long='basal area by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scpf) + + call this%set_history_var(vname='FATES_VEGC_ABOVEGROUND_SZPF', & + units = 'kg m-2', & + long='aboveground biomass by pft/size in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_agb_si_scpf) + + call this%set_history_var(vname='FATES_NPLANT_SZPF', units = 'm-2', & + long='stem number density by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_nplant_si_scpf) + + call this%set_history_var(vname='FATES_NPLANT_ACPF', units = 'm-2', & + long='stem number density by pft and age class', & + use_default='inactive', avgflag='A', vtype=site_coage_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_nplant_si_capf) call this%set_history_var(vname='M1_SCPF', units = 'N/ha/yr', & long='background mortality by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m1_si_scpf ) call this%set_history_var(vname='M2_SCPF', units = 'N/ha/yr', & long='hydraulic mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m2_si_scpf ) call this%set_history_var(vname='M3_SCPF', units = 'N/ha/yr', & long='carbon starvation mortality by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m3_si_scpf ) call this%set_history_var(vname='M4_SCPF', units = 'N/ha/yr', & long='impact mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m4_si_scpf ) call this%set_history_var(vname='M5_SCPF', units = 'N/ha/yr', & long='fire mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m5_si_scpf ) call this%set_history_var(vname='CROWNFIREMORT_SCPF', units = 'N/ha/yr', & long='crown fire mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_crownfiremort_si_scpf ) call this%set_history_var(vname='CAMBIALFIREMORT_SCPF', units = 'N/ha/yr', & long='cambial fire mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cambialfiremort_si_scpf ) call this%set_history_var(vname='M6_SCPF', units = 'N/ha/yr', & long='termination mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m6_si_scpf ) call this%set_history_var(vname='M7_SCPF', units = 'N/ha/event', & long='logging mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m7_si_scpf ) call this%set_history_var(vname='M8_SCPF', units = 'N/ha/yr', & long='freezing mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m8_si_scpf ) call this%set_history_var(vname='M9_SCPF', units = 'N/ha/yr', & long='senescence mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m9_si_scpf ) call this%set_history_var(vname='M10_SCPF', units = 'N/ha/yr', & long='age senescence mortality by pft/size',use_default='inactive', & - avgflag='A', vtype =site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype =site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m10_si_scpf ) call this%set_history_var(vname='M10_CAPF',units='N/ha/yr', & long='age senescence mortality by pft/cohort age',use_default='inactive', & - avgflag='A', vtype =site_coage_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype =site_coage_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index =ih_m10_si_capf ) call this%set_history_var(vname='MORTALITY_CANOPY_SCPF', units = 'N/ha/yr', & long='total mortality of canopy plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_canopy_si_scpf ) call this%set_history_var(vname='C13disc_SCPF', units = 'per mil', & long='C13 discrimination by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_c13disc_si_scpf ) call this%set_history_var(vname='BSTOR_CANOPY_SCPF', units = 'kgC/ha', & long='biomass carbon in storage pools of canopy plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstor_canopy_si_scpf ) call this%set_history_var(vname='BLEAF_CANOPY_SCPF', units = 'kgC/ha', & long='biomass carbon in leaf of canopy plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bleaf_canopy_si_scpf ) call this%set_history_var(vname='NPLANT_CANOPY_SCPF', units = 'N/ha', & long='stem number of canopy plants density by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_canopy_si_scpf ) call this%set_history_var(vname='MORTALITY_UNDERSTORY_SCPF', units = 'N/ha/yr', & long='total mortality of understory plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_understory_si_scpf ) call this%set_history_var(vname='BSTOR_UNDERSTORY_SCPF', units = 'kgC/ha', & long='biomass carbon in storage pools of understory plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstor_understory_si_scpf ) call this%set_history_var(vname='BLEAF_UNDERSTORY_SCPF', units = 'kgC/ha', & long='biomass carbon in leaf of understory plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bleaf_understory_si_scpf ) call this%set_history_var(vname='NPLANT_UNDERSTORY_SCPF', units = 'N/ha', & long='stem number of understory plants density by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_understory_si_scpf ) call this%set_history_var(vname='CWD_AG_CWDSC', units='gC/m^2', & long='size-resolved AG CWD stocks', use_default='inactive', & - avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_si_cwdsc ) call this%set_history_var(vname='CWD_BG_CWDSC', units='gC/m^2', & long='size-resolved BG CWD stocks', use_default='inactive', & - avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_si_cwdsc ) call this%set_history_var(vname='CWD_AG_IN_CWDSC', units='gC/m^2/y', & long='size-resolved AG CWD input', use_default='inactive', & - avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_in_si_cwdsc ) call this%set_history_var(vname='CWD_BG_IN_CWDSC', units='gC/m^2/y', & long='size-resolved BG CWD input', use_default='inactive', & - avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_in_si_cwdsc ) call this%set_history_var(vname='CWD_AG_OUT_CWDSC', units='gC/m^2/y', & long='size-resolved AG CWD output', use_default='inactive', & - avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_out_si_cwdsc ) call this%set_history_var(vname='CWD_BG_OUT_CWDSC', units='gC/m^2/y', & long='size-resolved BG CWD output', use_default='inactive', & - avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_out_si_cwdsc ) ! Size structured diagnostics that require rapid updates (upfreq=2) call this%set_history_var(vname='AR_SCPF',units = 'kgC/m2/yr', & long='total autotrophic respiration per m2 per year by pft/size',use_default='inactive',& - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_si_scpf ) call this%set_history_var(vname='AR_GROW_SCPF',units = 'kgC/m2/yr', & long='growth autotrophic respiration per m2 per year by pft/size',use_default='inactive',& - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_grow_si_scpf ) call this%set_history_var(vname='AR_MAINT_SCPF',units = 'kgC/m2/yr', & long='maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_maint_si_scpf ) call this%set_history_var(vname='AR_DARKM_SCPF',units = 'kgC/m2/yr', & long='dark portion of maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& - avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_darkm_si_scpf ) call this%set_history_var(vname='AR_AGSAPM_SCPF',units = 'kgC/m2/yr', & long='above-ground sapwood maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& - avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_agsapm_si_scpf ) call this%set_history_var(vname='AR_CROOTM_SCPF',units = 'kgC/m2/yr', & long='below-ground sapwood maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& - avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_crootm_si_scpf ) call this%set_history_var(vname='AR_FROOTM_SCPF',units = 'kgC/m2/yr', & long='fine root maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_frootm_si_scpf ) ! size-class only variables call this%set_history_var(vname='DDBH_CANOPY_SCLS', units = 'cm/yr/ha', & long='diameter growth increment by pft/size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_canopy_si_scls ) call this%set_history_var(vname='DDBH_UNDERSTORY_SCLS', units = 'cm/yr/ha', & long='diameter growth increment by pft/size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_understory_si_scls ) call this%set_history_var(vname='YESTERDAYCANLEV_CANOPY_SCLS', units = 'indiv/ha', & long='Yesterdays canopy level for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_yesterdaycanopylevel_canopy_si_scls ) call this%set_history_var(vname='YESTERDAYCANLEV_UNDERSTORY_SCLS', units = 'indiv/ha', & long='Yesterdays canopy level for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_yesterdaycanopylevel_understory_si_scls ) call this%set_history_var(vname='BA_SCLS', units = 'm2/ha', & long='basal area by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scls ) call this%set_history_var(vname='AGB_SCLS', units = 'kgC/m2', & long='Aboveground biomass by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_agb_si_scls ) call this%set_history_var(vname='BIOMASS_SCLS', units = 'kgC/m2', & long='Total biomass by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_scls ) call this%set_history_var(vname='DEMOTION_RATE_SCLS', units = 'indiv/ha/yr', & long='demotion rate from canopy to understory by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_demotion_rate_si_scls ) call this%set_history_var(vname='PROMOTION_RATE_SCLS', units = 'indiv/ha/yr', & long='promotion rate from understory to canopy by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_promotion_rate_si_scls ) call this%set_history_var(vname='NPLANT_CANOPY_SCLS', units = 'indiv/ha', & long='number of canopy plants by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_canopy_si_scls ) call this%set_history_var(vname='LAI_CANOPY_SCLS', units = 'm2/m2', & long='Leaf are index (LAI) by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_lai_canopy_si_scls ) call this%set_history_var(vname='SAI_CANOPY_SCLS', units = 'm2/m2', & long='stem area index(SAI) by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sai_canopy_si_scls ) call this%set_history_var(vname='MORTALITY_CANOPY_SCLS', units = 'indiv/ha/yr', & long='total mortality of canopy trees by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_canopy_si_scls ) call this%set_history_var(vname='NPLANT_UNDERSTORY_SCLS', units = 'indiv/ha', & long='number of understory plants by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_understory_si_scls ) call this%set_history_var(vname='LAI_UNDERSTORY_SCLS', units = 'indiv/ha', & long='number of understory plants by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_lai_understory_si_scls ) call this%set_history_var(vname='SAI_UNDERSTORY_SCLS', units = 'indiv/ha', & long='number of understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sai_understory_si_scls ) call this%set_history_var(vname='NPLANT_SCLS', units = 'indiv/ha', & long='number of plants by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scls ) call this%set_history_var(vname='NPLANT_CACLS', units = 'indiv/ha', & long='number of plants by coage class', use_default='active', & - avgflag='A', vtype=site_coage_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_coage_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_cacls ) call this%set_history_var(vname='M1_SCLS', units = 'N/ha/yr', & long='background mortality by size', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m1_si_scls ) call this%set_history_var(vname='M2_SCLS', units = 'N/ha/yr', & long='hydraulic mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m2_si_scls ) call this%set_history_var(vname='M3_SCLS', units = 'N/ha/yr', & long='carbon starvation mortality by size', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m3_si_scls ) call this%set_history_var(vname='M4_SCLS', units = 'N/ha/yr', & long='impact mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m4_si_scls ) call this%set_history_var(vname='M5_SCLS', units = 'N/ha/yr', & long='fire mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m5_si_scls ) call this%set_history_var(vname='M6_SCLS', units = 'N/ha/yr', & long='termination mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m6_si_scls ) call this%set_history_var(vname='M7_SCLS', units = 'N/ha/event', & long='logging mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m7_si_scls ) call this%set_history_var(vname='M8_SCLS', units = 'N/ha/event', & long='freezing mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m8_si_scls ) call this%set_history_var(vname='M9_SCLS', units = 'N/ha/yr', & long='senescence mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m9_si_scls ) call this%set_history_var(vname='M10_SCLS', units = 'N/ha/yr', & long='age senescence mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m10_si_scls ) call this%set_history_var(vname='M10_CACLS', units = 'N/ha/yr', & long='age senescence mortality by cohort age',use_default='active', & - avgflag='A', vtype=site_coage_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_coage_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m10_si_cacls ) call this%set_history_var(vname='CARBON_BALANCE_CANOPY_SCLS', units = 'kg C / ha / yr', & long='CARBON_BALANCE for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_carbon_balance_canopy_si_scls ) call this%set_history_var(vname='CARBON_BALANCE_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='CARBON_BALANCE for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_carbon_balance_understory_si_scls ) call this%set_history_var(vname='MORTALITY_UNDERSTORY_SCLS', units = 'indiv/ha/yr', & long='total mortality of understory trees by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_understory_si_scls ) call this%set_history_var(vname='TRIMMING_CANOPY_SCLS', units = 'indiv/ha', & long='trimming term of canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_trimming_canopy_si_scls ) call this%set_history_var(vname='TRIMMING_UNDERSTORY_SCLS', units = 'indiv/ha', & long='trimming term of understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_trimming_understory_si_scls ) call this%set_history_var(vname='CROWN_AREA_CANOPY_SCLS', units = 'm2/ha', & long='total crown area of canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_crown_area_canopy_si_scls ) call this%set_history_var(vname='CROWN_AREA_UNDERSTORY_SCLS', units = 'm2/ha', & long='total crown area of understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_crown_area_understory_si_scls ) call this%set_history_var(vname='LEAF_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & long='LEAF_MD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leaf_md_canopy_si_scls ) call this%set_history_var(vname='ROOT_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & long='ROOT_MD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_root_md_canopy_si_scls ) call this%set_history_var(vname='BSTORE_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & long='BSTORE_MD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstore_md_canopy_si_scls ) call this%set_history_var(vname='BDEAD_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & long='BDEAD_MD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bdead_md_canopy_si_scls ) call this%set_history_var(vname='BSW_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & long='BSW_MD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bsw_md_canopy_si_scls ) call this%set_history_var(vname='SEED_PROD_CANOPY_SCLS', units = 'kg C / ha / yr', & long='SEED_PROD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_seed_prod_canopy_si_scls ) call this%set_history_var(vname='NPP_LEAF_CANOPY_SCLS', units = 'kg C / ha / yr', & @@ -5793,167 +5898,167 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='NPP_FROOT_CANOPY_SCLS', units = 'kg C / ha / yr', & long='NPP_FROOT for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_fnrt_canopy_si_scls ) call this%set_history_var(vname='NPP_BSW_CANOPY_SCLS', units = 'kg C / ha / yr', & long='NPP_BSW for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_sapw_canopy_si_scls ) call this%set_history_var(vname='NPP_BDEAD_CANOPY_SCLS', units = 'kg C / ha / yr', & long='NPP_BDEAD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_dead_canopy_si_scls ) call this%set_history_var(vname='NPP_BSEED_CANOPY_SCLS', units = 'kg C / ha / yr', & long='NPP_BSEED for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_seed_canopy_si_scls ) call this%set_history_var(vname='NPP_STORE_CANOPY_SCLS', units = 'kg C / ha / yr', & long='NPP_STORE for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stor_canopy_si_scls ) call this%set_history_var(vname='LEAF_MR', units = 'kg C / m2 / yr', & long='RDARK (leaf maintenance respiration)', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_leaf_mr_si ) call this%set_history_var(vname='FROOT_MR', units = 'kg C / m2 / yr', & long='fine root maintenance respiration)', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_froot_mr_si ) call this%set_history_var(vname='LIVECROOT_MR', units = 'kg C / m2 / yr', & long='live coarse root maintenance respiration)', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livecroot_mr_si ) call this%set_history_var(vname='LIVESTEM_MR', units = 'kg C / m2 / yr', & long='live stem maintenance respiration)', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livestem_mr_si ) call this%set_history_var(vname='RDARK_CANOPY_SCLS', units = 'kg C / ha / yr', & long='RDARK for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_rdark_canopy_si_scls ) call this%set_history_var(vname='LIVESTEM_MR_CANOPY_SCLS', units = 'kg C / ha / yr', & long='LIVESTEM_MR for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livestem_mr_canopy_si_scls ) call this%set_history_var(vname='LIVECROOT_MR_CANOPY_SCLS', units = 'kg C / ha / yr', & long='LIVECROOT_MR for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livecroot_mr_canopy_si_scls ) call this%set_history_var(vname='FROOT_MR_CANOPY_SCLS', units = 'kg C / ha / yr', & long='FROOT_MR for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_froot_mr_canopy_si_scls ) call this%set_history_var(vname='RESP_G_CANOPY_SCLS', units = 'kg C / ha / yr', & long='RESP_G for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_g_canopy_si_scls ) call this%set_history_var(vname='RESP_M_CANOPY_SCLS', units = 'kg C / ha / yr', & long='RESP_M for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_m_canopy_si_scls ) call this%set_history_var(vname='LEAF_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='LEAF_MD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leaf_md_understory_si_scls ) call this%set_history_var(vname='ROOT_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='ROOT_MD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_root_md_understory_si_scls ) call this%set_history_var(vname='BSTORE_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='BSTORE_MD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstore_md_understory_si_scls ) call this%set_history_var(vname='BDEAD_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='BDEAD_MD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bdead_md_understory_si_scls ) call this%set_history_var(vname='BSW_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='BSW_MD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bsw_md_understory_si_scls ) call this%set_history_var(vname='SEED_PROD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='SEED_PROD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_seed_prod_understory_si_scls ) call this%set_history_var(vname='NPP_LEAF_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='NPP_LEAF for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_understory_si_scls ) call this%set_history_var(vname='NPP_FROOT_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='NPP_FROOT for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_fnrt_understory_si_scls ) call this%set_history_var(vname='NPP_BSW_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='NPP_BSW for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_sapw_understory_si_scls ) call this%set_history_var(vname='NPP_BDEAD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='NPP_BDEAD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_dead_understory_si_scls ) call this%set_history_var(vname='NPP_BSEED_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='NPP_BSEED for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_seed_understory_si_scls ) call this%set_history_var(vname='NPP_STORE_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='NPP_STORE for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stor_understory_si_scls ) call this%set_history_var(vname='RDARK_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='RDARK for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_rdark_understory_si_scls ) call this%set_history_var(vname='LIVESTEM_MR_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='LIVESTEM_MR for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livestem_mr_understory_si_scls ) call this%set_history_var(vname='LIVECROOT_MR_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='LIVECROOT_MR for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livecroot_mr_understory_si_scls ) call this%set_history_var(vname='FROOT_MR_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='FROOT_MR for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_froot_mr_understory_si_scls ) call this%set_history_var(vname='RESP_G_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='RESP_G for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_g_understory_si_scls ) call this%set_history_var(vname='RESP_M_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='RESP_M for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_m_understory_si_scls ) @@ -6177,32 +6282,32 @@ subroutine define_history_vars(this, initialize_variables) ! organ-partitioned NPP / allocation fluxes call this%set_history_var(vname='NPP_LEAF', units='kgC/m2/yr', & long='NPP flux into leaves', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_si ) call this%set_history_var(vname='NPP_SEED', units='kgC/m2/yr', & long='NPP flux into seeds', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_seed_si ) call this%set_history_var(vname='NPP_STEM', units='kgC/m2/yr', & long='NPP flux into stem', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stem_si ) call this%set_history_var(vname='NPP_FROOT', units='kgC/m2/yr', & long='NPP flux into fine roots', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_froot_si ) call this%set_history_var(vname='NPP_CROOT', units='kgC/m2/yr', & long='NPP flux into coarse roots', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_croot_si ) call this%set_history_var(vname='NPP_STOR', units='kgC/m2/yr', & long='NPP flux into storage tissues', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stor_si ) @@ -6212,22 +6317,22 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FATES_ERRH2O_SCPF', units='kg/indiv/s', & long='mean individual water balance error', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_errh2o_scpf ) call this%set_history_var(vname='FATES_TRAN_SCPF', units='kg/indiv/s', & long='mean individual transpiration rate', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_tran_scpf ) call this%set_history_var(vname='FATES_SAPFLOW_SCPF', units='kg/ha/s', & long='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, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sapflow_scpf ) call this%set_history_var(vname='FATES_SAPFLOW_SI', units='kg/ha/s', & long='areal sap flow rate', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sapflow_si ) @@ -6245,67 +6350,67 @@ subroutine define_history_vars(this, initialize_variables) 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, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_ath_scpf ) 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, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_tth_scpf ) 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, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sth_scpf ) 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, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_lth_scpf ) 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, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_awp_scpf ) 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, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_twp_scpf ) 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, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_swp_scpf ) 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, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_lwp_scpf ) 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, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_aflc_scpf ) 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, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_tflc_scpf ) 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, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sflc_scpf ) 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, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_lflc_scpf ) 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, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_btran_scpf ) call this%set_history_var(vname='FATES_ROOTWGT_SOILVWC_SI', units='m3 m-3', & @@ -6370,27 +6475,27 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='H2OVEG', units = 'kg/m2', & long='water stored inside vegetation tissues (leaf, stem, roots)', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_si ) call this%set_history_var(vname='H2OVEG_DEAD', units = 'kg/m2', & long='cumulative plant_stored_h2o in dead biomass due to mortality', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_dead_si ) call this%set_history_var(vname='H2OVEG_RECRUIT', units = 'kg/m2', & long='amount of water in new recruits', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_recruit_si ) call this%set_history_var(vname='H2OVEG_GROWTURN_ERR', units = 'kg/m2', & long='cumulative net borrowed (+) or lost (-) from plant_stored_h2o due to combined growth & turnover', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_growturn_err_si ) call this%set_history_var(vname='H2OVEG_HYDRO_ERR', units = 'kg/m2', & long='cumulative net borrowed (+) from plant_stored_h2o due to plant hydrodynamics', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_hydro_err_si ) end if hydro_active_if From a483d321260a30a3329b3b647ef644dbef5052d4 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Wed, 29 Sep 2021 11:14:51 -0600 Subject: [PATCH 409/578] history variable updates --- main/FatesHistoryInterfaceMod.F90 | 348 +++++++++++++++++------------- 1 file changed, 196 insertions(+), 152 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 3e6fe944c4..114752fe22 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2461,17 +2461,23 @@ subroutine update_history_dyn(this,nc,nsites,sites) end if - hio_m1_si_scpf(io_si,scpf) = hio_m1_si_scpf(io_si,scpf) + ccohort%bmort*ccohort%n - hio_m2_si_scpf(io_si,scpf) = hio_m2_si_scpf(io_si,scpf) + ccohort%hmort*ccohort%n - hio_m3_si_scpf(io_si,scpf) = hio_m3_si_scpf(io_si,scpf) + ccohort%cmort*ccohort%n - hio_m7_si_scpf(io_si,scpf) = hio_m7_si_scpf(io_si,scpf) + & - (ccohort%lmort_direct+ccohort%lmort_collateral+ccohort%lmort_infra) * ccohort%n - hio_m8_si_scpf(io_si,scpf) = hio_m8_si_scpf(io_si,scpf) + ccohort%frmort*ccohort%n - hio_m9_si_scpf(io_si,scpf) = hio_m9_si_scpf(io_si,scpf) + ccohort%smort*ccohort%n + hio_m1_si_scpf(io_si,scpf) = hio_m1_si_scpf(io_si,scpf) + & + ccohort%bmort*ccohort%n / m2_per_ha + hio_m2_si_scpf(io_si,scpf) = hio_m2_si_scpf(io_si,scpf) + & + ccohort%hmort*ccohort%n / m2_per_ha + hio_m3_si_scpf(io_si,scpf) = hio_m3_si_scpf(io_si,scpf) + & + ccohort%cmort*ccohort%n / m2_per_ha + hio_m7_si_scpf(io_si,scpf) = hio_m7_si_scpf(io_si,scpf) + & + (ccohort%lmort_direct + ccohort%lmort_collateral + & + ccohort%lmort_infra) * ccohort%n / m2_per_ha + hio_m8_si_scpf(io_si,scpf) = hio_m8_si_scpf(io_si,scpf) + & + ccohort%frmort*ccohort%n / m2_per_ha + hio_m9_si_scpf(io_si,scpf) = hio_m9_si_scpf(io_si,scpf) + & + ccohort%smort*ccohort%n / m2_per_ha if (hlm_use_cohort_age_tracking .eq.itrue) then - hio_m10_si_scpf(io_si,scpf) = hio_m10_si_scpf(io_si,scpf) + ccohort%asmort*ccohort%n - hio_m10_si_capf(io_si,capf) = hio_m10_si_capf(io_si,capf) + ccohort%asmort*ccohort%n + hio_m10_si_scpf(io_si,scpf) = hio_m10_si_scpf(io_si,scpf) + ccohort%asmort*ccohort%n / m2_per_ha + hio_m10_si_capf(io_si,capf) = hio_m10_si_capf(io_si,capf) + ccohort%asmort*ccohort%n / m2_per_ha hio_m10_si_scls(io_si,scls) = hio_m10_si_scls(io_si,scls) + ccohort%asmort*ccohort%n hio_m10_si_cacls(io_si,cacls) = hio_m10_si_cacls(io_si,cacls)+ & ccohort%asmort*ccohort%n @@ -2562,9 +2568,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_ddbh_canopy_si_scag(io_si,iscag) = hio_ddbh_canopy_si_scag(io_si,iscag) + & ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha hio_bstor_canopy_si_scpf(io_si,scpf) = hio_bstor_canopy_si_scpf(io_si,scpf) + & - store_m * ccohort%n + store_m * ccohort%n / m2_per_ha hio_bleaf_canopy_si_scpf(io_si,scpf) = hio_bleaf_canopy_si_scpf(io_si,scpf) + & - leaf_m * ccohort%n + leaf_m * ccohort%n / m2_per_ha hio_canopy_biomass_si(io_si) = hio_canopy_biomass_si(io_si) + n_perm2 * total_m @@ -2579,7 +2585,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & ccohort%n * sec_per_day * days_per_year - hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + ccohort%n + hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + ccohort%n / m2_per_ha hio_nplant_canopy_si_scls(io_si,scls) = hio_nplant_canopy_si_scls(io_si,scls) + ccohort%n hio_lai_canopy_si_scls(io_si,scls) = hio_lai_canopy_si_scls(io_si,scls) + & ccohort%treelai*ccohort%c_area * AREA_INV @@ -2670,7 +2676,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * sec_per_day * days_per_year + ccohort%n * sec_per_day * days_per_year / m2_per_ha hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + ccohort%n hio_nplant_understory_si_scls(io_si,scls) = hio_nplant_understory_si_scls(io_si,scls) + ccohort%n @@ -2871,7 +2877,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! ! termination mortality. sum of canopy and understory indices hio_m6_si_scpf(io_si,i_scpf) = (sites(s)%term_nindivs_canopy(i_scls,i_pft) + & - sites(s)%term_nindivs_ustory(i_scls,i_pft)) * days_per_year + sites(s)%term_nindivs_ustory(i_scls,i_pft)) * & + days_per_year / m2_per_ha hio_m6_si_scls(io_si,i_scls) = hio_m6_si_scls(io_si,i_scls) + & (sites(s)%term_nindivs_canopy(i_scls,i_pft) + & @@ -2894,7 +2901,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! ! imort on its own - hio_m4_si_scpf(io_si,i_scpf) = sites(s)%imort_rate(i_scls, i_pft) + hio_m4_si_scpf(io_si,i_scpf) = sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha hio_m4_si_scls(io_si,i_scls) = hio_m4_si_scls(io_si,i_scls) + sites(s)%imort_rate(i_scls, i_pft) ! ! add imort to other mortality terms. consider imort as understory mortality even if it happens in @@ -2910,13 +2917,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) sites(s)%imort_rate(i_scls, i_pft) ! fire mortality from the site-level diagnostic rates - hio_m5_si_scpf(io_si,i_scpf) = sites(s)%fmort_rate_canopy(i_scls, i_pft) + & - sites(s)%fmort_rate_ustory(i_scls, i_pft) + hio_m5_si_scpf(io_si,i_scpf) = (sites(s)%fmort_rate_canopy(i_scls, i_pft) + & + sites(s)%fmort_rate_ustory(i_scls, i_pft)) / m2_per_ha hio_m5_si_scls(io_si,i_scls) = hio_m5_si_scls(io_si,i_scls) + & sites(s)%fmort_rate_canopy(i_scls, i_pft) + sites(s)%fmort_rate_ustory(i_scls, i_pft) ! - hio_crownfiremort_si_scpf(io_si,i_scpf) = sites(s)%fmort_rate_crown(i_scls, i_pft) - hio_cambialfiremort_si_scpf(io_si,i_scpf) = sites(s)%fmort_rate_cambial(i_scls, i_pft) + hio_crownfiremort_si_scpf(io_si,i_scpf) = sites(s)%fmort_rate_crown(i_scls, i_pft) / m2_per_ha + hio_cambialfiremort_si_scpf(io_si,i_scpf) = sites(s)%fmort_rate_cambial(i_scls, i_pft) / m2_per_ha ! ! fire components of overall canopy and understory mortality hio_mortality_canopy_si_scpf(io_si,i_scpf) = hio_mortality_canopy_si_scpf(io_si,i_scpf) + & @@ -4369,7 +4376,7 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index=ih_npp_si_pft) - call this%set_history_var(vname='FATES_NINDIVS_PF', units='m-2', & + call this%set_history_var(vname='FATES_NPLANT_PF', units='m-2', & long='total PFT-level number of individuals per m2 land area', & use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & @@ -5502,100 +5509,137 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_nplant_si_capf) - call this%set_history_var(vname='M1_SCPF', units = 'N/ha/yr', & - long='background mortality by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m1_si_scpf ) + call this%set_history_var(vname='FATES_MORTALITY_BACKGROUND_SZPF', & + units = 'm-2 yr-1', & + long='background mortality by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m1_si_scpf) - call this%set_history_var(vname='M2_SCPF', units = 'N/ha/yr', & - long='hydraulic mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m2_si_scpf ) + call this%set_history_var(vname='FATES_MORTALITY_HYDRAULIC_SZPF', & + units = 'm-2 yr-1', & + long='hydraulic mortality by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m2_si_scpf) - call this%set_history_var(vname='M3_SCPF', units = 'N/ha/yr', & - long='carbon starvation mortality by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m3_si_scpf ) + call this%set_history_var(vname='FATES_MORTALITY_CSTARV_SZPF', & + units = 'm-2 yr-1', & + long='carbon starvation mortality by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m3_si_scpf) - call this%set_history_var(vname='M4_SCPF', units = 'N/ha/yr', & - long='impact mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m4_si_scpf ) + call this%set_history_var(vname='FATES_MORTALITY_IMPACT_SZPF', & + units = 'm-2 yr-1', & + long='impact mortality by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m4_si_scpf) - call this%set_history_var(vname='M5_SCPF', units = 'N/ha/yr', & - long='fire mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m5_si_scpf ) + call this%set_history_var(vname='FATES_MORTALITY_FIRE_SZPF', & + units = 'm-2 yr-1', & + long='fire mortality by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m5_si_scpf) - call this%set_history_var(vname='CROWNFIREMORT_SCPF', units = 'N/ha/yr', & - long='crown fire mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_crownfiremort_si_scpf ) + call this%set_history_var(vname='FATES_MORTALITY_CROWNSCORCH_SZPF', & + units = 'm-2 yr-1', & + long='fire mortality from crown scorch by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_crownfiremort_si_scpf) - call this%set_history_var(vname='CAMBIALFIREMORT_SCPF', units = 'N/ha/yr', & - long='cambial fire mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cambialfiremort_si_scpf ) + call this%set_history_var(vname='FATES_MORTALITY_CAMBIALBURN_SZPF', & + units = 'm-2 yr-1', & + long='fire mortality from cambial burn by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cambialfiremort_si_scpf) - call this%set_history_var(vname='M6_SCPF', units = 'N/ha/yr', & - long='termination mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m6_si_scpf ) + call this%set_history_var(vname='FATES_MORTALITY_TERMINATION_SZPF', & + units = 'm-2 yr-1', & + long='termination mortality by pft/size in number pf plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m6_si_scpf) - call this%set_history_var(vname='M7_SCPF', units = 'N/ha/event', & - long='logging mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m7_si_scpf ) + call this%set_history_var(vname='FATES_MORTALITY_LOGGING_SZPF', & + units = 'm-2 event-1', & + long='logging mortality by pft/size in number of plants per m2 per ', & + use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_m7_si_scpf) - call this%set_history_var(vname='M8_SCPF', units = 'N/ha/yr', & - long='freezing mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m8_si_scpf ) + call this%set_history_var(vname='FATES_MORTALITY_FREEZING_SZPF', & + units = 'm-2 yr-1', & + long='freezing mortality by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m8_si_scpf) - call this%set_history_var(vname='M9_SCPF', units = 'N/ha/yr', & - long='senescence mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m9_si_scpf ) + call this%set_history_var(vname='FATES_MORTALITY_SENESCENCE_SZPF', & + units = 'm-2 yr-1', & + long='senescence mortality by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m9_si_scpf) - call this%set_history_var(vname='M10_SCPF', units = 'N/ha/yr', & - long='age senescence mortality by pft/size',use_default='inactive', & - avgflag='A', vtype =site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m10_si_scpf ) + call this%set_history_var(vname='FATES_MORTALITY_AGESCENESCENCE_SZPF', & + units = 'm-2 yr-1', & + long='age senescence mortality by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype =site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_m10_si_scpf) - call this%set_history_var(vname='M10_CAPF',units='N/ha/yr', & - long='age senescence mortality by pft/cohort age',use_default='inactive', & - avgflag='A', vtype =site_coage_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index =ih_m10_si_capf ) + call this%set_history_var(vname='FATES_MORTALITY_AGESCENESCENCE_ACPF', & + units='m-2 yr-1', & + long='age senescence mortality by pft/cohort age in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype =site_coage_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index =ih_m10_si_capf) - call this%set_history_var(vname='MORTALITY_CANOPY_SCPF', units = 'N/ha/yr', & - long='total mortality of canopy plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_canopy_si_scpf ) + call this%set_history_var(vname='FATES_MORTALITY_CANOPY_SZPF', & + units = 'm-2 yr-1', & + long='total mortality of canopy plants by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_mortality_canopy_si_scpf) - call this%set_history_var(vname='C13disc_SCPF', units = 'per mil', & - long='C13 discrimination by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_c13disc_si_scpf ) + call this%set_history_var(vname='FATES_C13DISC_SZPF', units = 'per mil', & + long='C13 discrimination by pft/size',use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_c13disc_si_scpf) - call this%set_history_var(vname='BSTOR_CANOPY_SCPF', units = 'kgC/ha', & - long='biomass carbon in storage pools of canopy plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstor_canopy_si_scpf ) + call this%set_history_var(vname='FATES_STOREC_CANOPY_SZPF', units = 'kg m-2', & + long='biomass in storage pools of canopy plants by pft/size in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_bstor_canopy_si_scpf) - call this%set_history_var(vname='BLEAF_CANOPY_SCPF', units = 'kgC/ha', & - long='biomass carbon in leaf of canopy plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bleaf_canopy_si_scpf ) + call this%set_history_var(vname='FATES_LEAFC_CANOPY_SZPF', & + units = 'kg m-2', & + long='biomass in leaves of canopy plants by pft/size in kg carbon per m2', & + use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, & + index = ih_bleaf_canopy_si_scpf) - call this%set_history_var(vname='NPLANT_CANOPY_SCPF', units = 'N/ha', & - long='stem number of canopy plants density by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_canopy_si_scpf ) + call this%set_history_var(vname='FATES_NPLANT_CANOPY_SZPF', units = 'm-2', & + long='number of canopy plants by size/pft per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nplant_canopy_si_scpf) - call this%set_history_var(vname='MORTALITY_UNDERSTORY_SCPF', units = 'N/ha/yr', & - long='total mortality of understory plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_understory_si_scpf ) + call this%set_history_var(vname='FATES_MORTALITY_UNDERSTORY_SZPF', & + units = 'm-2 yr-1', & + long='total mortality of understory plants by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_mortality_understory_si_scpf) call this%set_history_var(vname='BSTOR_UNDERSTORY_SCPF', units = 'kgC/ha', & long='biomass carbon in storage pools of understory plants by pft/size', use_default='inactive', & @@ -5893,7 +5937,7 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='NPP_LEAF_CANOPY_SCLS', units = 'kg C / ha / yr', & long='NPP_LEAF for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=-999.9_r8, & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_canopy_si_scls ) call this%set_history_var(vname='NPP_FROOT_CANOPY_SCLS', units = 'kg C / ha / yr', & @@ -6066,156 +6110,156 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='NEP', units='gC/m^2/s', & long='net ecosystem production', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_nep_si ) call this%set_history_var(vname='FATES_HR', units='gC/m^2/s', & long='heterotrophic respiration', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_hr_si ) call this%set_history_var(vname='Fire_Closs', units='gC/m^2/s', & long='ED/SPitfire Carbon loss to atmosphere', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & 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, & + avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', & 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, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cbal_err_fates_si ) call this%set_history_var(vname='ERROR_FATES', units='mg/day', & long='total error, FATES mass-balance', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_err_fates_si ) call this%set_history_var(vname='LITTER_FINES_AG_ELEM', units='kg ha-1', & long='mass of above ground litter in fines (leaves,nonviable seed)', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fines_ag_elem ) call this%set_history_var(vname='LITTER_FINES_BG_ELEM', units='kg ha-1', & long='mass of below ground litter in fines (fineroots)', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fines_bg_elem ) call this%set_history_var(vname='LITTER_CWD_BG_ELEM', units='kg ha-1', & long='mass of below ground litter in CWD (coarse roots)', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_elem ) call this%set_history_var(vname='LITTER_CWD_AG_ELEM', units='kg ha-1', & long='mass of above ground litter in CWD (trunks/branches/twigs)', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_elem ) call this%set_history_var(vname='LITTER_CWD', units='kg ha-1', & long='total mass of litter in CWD', use_default='active', & - avgflag='A', vtype=site_elcwd_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_elcwd_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_elcwd ) ! Mass states C/N/P SCPF dimensions ! CARBON call this%set_history_var(vname='TOTVEGC_SCPF', units='kgC/ha', & long='total vegetation carbon mass in live plants by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_totvegc_scpf ) call this%set_history_var(vname='LEAFC_SCPF', units='kgC/ha', & long='leaf carbon mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leafc_scpf ) call this%set_history_var(vname='FNRTC_SCPF', units='kgC/ha', & long='fine-root carbon mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fnrtc_scpf ) call this%set_history_var(vname='SAPWC_SCPF', units='kgC/ha', & long='sapwood carbon mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sapwc_scpf ) call this%set_history_var(vname='STOREC_SCPF', units='kgC/ha', & long='storage carbon mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storec_scpf ) call this%set_history_var(vname='REPROC_SCPF', units='kgC/ha', & long='reproductive carbon mass (on plant) by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_reproc_scpf ) call this%set_history_var(vname='CEFFLUX_SCPF', units='kg/ha/day', & long='carbon efflux, root to soil, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cefflux_scpf ) ! NITROGEN nitrogen_active_if2: if(any(element_list(:)==nitrogen_element)) then call this%set_history_var(vname='TOTVEGN_SCPF', units='kgN/ha', & long='total (live) vegetation nitrogen mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_totvegn_scpf ) call this%set_history_var(vname='LEAFN_SCPF', units='kgN/ha', & long='leaf nitrogen mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leafn_scpf ) call this%set_history_var(vname='FNRTN_SCPF', units='kgN/ha', & long='fine-root nitrogen mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fnrtn_scpf ) call this%set_history_var(vname='SAPWN_SCPF', units='kgN/ha', & long='sapwood nitrogen mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sapwn_scpf ) call this%set_history_var(vname='STOREN_SCPF', units='kgN/ha', & long='storage nitrogen mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storen_scpf ) call this%set_history_var(vname='STOREN_TFRAC_CANOPY_SCPF', units='kgN/ha', & long='storage nitrogen fraction of target,in canopy, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storentfrac_canopy_scpf ) call this%set_history_var(vname='STOREN_TFRAC_UNDERSTORY_SCPF', units='kgN/ha', & long='storage nitrogen fraction of target,in understory, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storentfrac_understory_scpf ) call this%set_history_var(vname='REPRON_SCPF', units='kgN/ha', & long='reproductive nitrogen mass (on plant) by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_repron_scpf ) call this%set_history_var(vname='NH4UPTAKE_SCPF', units='kgN d-1 ha-1', & long='Ammonium uptake rate by plants, size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nh4uptake_scpf ) call this%set_history_var(vname='NO3UPTAKE_SCPF', units='kgN d-1 ha-1', & long='Nitrate uptake rate by plants, size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_no3uptake_scpf ) call this%set_history_var(vname='NEFFLUX_SCPF', units='kgN d-1 ha-1', & long='nitrogen efflux, root to soil, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nefflux_scpf ) call this%set_history_var(vname='NNEED_SCPF', units='kgN d-1 ha-1', & long='plant N need (algorithm dependent), by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nneed_scpf ) end if nitrogen_active_if2 @@ -6224,57 +6268,57 @@ subroutine define_history_vars(this, initialize_variables) phosphorus_active_if2: if(any(element_list(:)==phosphorus_element))then call this%set_history_var(vname='TOTVEGP_SCPF', units='kgP/ha', & long='total (live) vegetation phosphorus mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_totvegp_scpf ) call this%set_history_var(vname='LEAFP_SCPF', units='kgP/ha', & long='leaf phosphorus mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leafp_scpf ) call this%set_history_var(vname='FNRTP_SCPF', units='kgP/ha', & long='fine-root phosphorus mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fnrtp_scpf ) call this%set_history_var(vname='SAPWP_SCPF', units='kgP/ha', & long='sapwood phosphorus mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sapwp_scpf ) call this%set_history_var(vname='STOREP_SCPF', units='kgP/ha', & long='storage phosphorus mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storep_scpf ) call this%set_history_var(vname='STOREP_TFRAC_CANOPY_SCPF', units='kgN/ha', & long='storage phosphorus fraction of target,in canopy, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storeptfrac_canopy_scpf ) call this%set_history_var(vname='STOREP_TFRAC_UNDERSTORY_SCPF', units='kgN/ha', & long='storage phosphorus fraction of target,in understory, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storeptfrac_understory_scpf ) call this%set_history_var(vname='REPROP_SCPF', units='kgP/ha', & long='reproductive phosphorus mass (on plant) by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_reprop_scpf ) call this%set_history_var(vname='PUPTAKE_SCPF', units='kg/ha/day', & long='phosphorus uptake rate by plants, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_puptake_scpf ) call this%set_history_var(vname='PEFFLUX_SCPF', units='kg/ha/day', & long='phosphorus efflux, root to soil, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_pefflux_scpf ) call this%set_history_var(vname='PNEED_SCPF', units='kg/ha/day', & long='plant P need (algorithm dependent), by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_pneed_scpf ) end if phosphorus_active_if2 @@ -6339,13 +6383,13 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FATES_ITERH1_SCPF', units='count/indiv/step', & long='water balance error iteration diagnostic 1', & use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_iterh1_scpf ) call this%set_history_var(vname='FATES_ITERH2_SCPF', units='count/indiv/step', & long='water balance error iteration diagnostic 2', & use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_iterh2_scpf ) call this%set_history_var(vname='FATES_ATH_SCPF', units='m3 m-3', & @@ -6415,62 +6459,62 @@ subroutine define_history_vars(this, initialize_variables) 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, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & 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, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & 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, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & 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, & + avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', & 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, & + avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', & 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, & + avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', & 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, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & 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, & + avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', & 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, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & 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, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & 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, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & 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, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake100_scpf ) call this%set_history_var(vname='H2OVEG', units = 'kg/m2', & From a7b29b4e14e16880f1720ea9297ddfabc54b1952 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 30 Sep 2021 17:39:27 -0400 Subject: [PATCH 410/578] Small fix in batch params script to workaround parser bug --- tools/BatchPatchParams.py | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/tools/BatchPatchParams.py b/tools/BatchPatchParams.py index 57edb7dfcb..ee78ebcbd0 100755 --- a/tools/BatchPatchParams.py +++ b/tools/BatchPatchParams.py @@ -51,8 +51,11 @@ def parse_syscall_str(fnamein,fnameout,param_name,param_val): sys_call_str = "../tools/modify_fates_paramfile.py"+" --fin " + fnamein + \ " --fout " + fnameout + " --var " + param_name + " --silent " +\ - " --val " + param_val + " --overwrite --all" + " --val " + "\" "+param_val+"\"" + " --overwrite --all" + + print(sys_call_str) + return(sys_call_str) From a3b094f290ece99730658b0d7c1c5fd2365cb3ee Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 1 Oct 2021 10:05:33 -0400 Subject: [PATCH 411/578] cleaning up root depth branch --- biogeochem/EDCanopyStructureMod.F90 | 12 ++++++------ biogeochem/FatesAllometryMod.F90 | 2 +- biogeophys/FatesPlantHydraulicsMod.F90 | 24 +++++++++--------------- fire/SFMainMod.F90 | 2 +- main/FatesHistoryInterfaceMod.F90 | 5 +++-- main/FatesHydraulicsMemMod.F90 | 10 +++++----- 6 files changed, 25 insertions(+), 30 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 08e6c0513f..586a4b39af 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1601,19 +1601,19 @@ subroutine leaf_area_profile( currentSite ) currentCohort => currentPatch%shortest do while(associated(currentCohort)) ft = currentCohort%pft - min_chite = currentCohort%hite - currentCohort%hite * EDPftvarcon_inst%crown(ft) + min_chite = currentCohort%hite - currentCohort%hite * prt_params%crown(ft) max_chite = currentCohort%hite do iv = 1,N_HITE_BINS frac_canopy(iv) = 0.0_r8 ! this layer is in the middle of the canopy if(max_chite > maxh(iv).and.min_chite < minh(iv))then - frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*EDPftvarcon_inst%crown(ft))) + frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*prt_params%crown(ft))) ! this is the layer with the bottom of the canopy in it. elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then - frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) + frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*prt_params%crown(ft)) ! this is the layer with the top of the canopy in it. elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then - frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) + frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*prt_params%crown(ft)) elseif(max_chite < maxh(iv).and.min_chite > minh(iv))then !the whole cohort is within this layer. frac_canopy(iv) = 1.0_r8 endif @@ -1709,11 +1709,11 @@ subroutine leaf_area_profile( currentSite ) layer_top_hite = currentCohort%hite - & ( real(iv-1,r8)/currentCohort%NV * currentCohort%hite * & - EDPftvarcon_inst%crown(currentCohort%pft) ) + prt_params%crown(currentCohort%pft) ) layer_bottom_hite = currentCohort%hite - & ( real(iv,r8)/currentCohort%NV * currentCohort%hite * & - EDPftvarcon_inst%crown(currentCohort%pft) ) + prt_params%crown(currentCohort%pft) ) fraction_exposed = 1.0_r8 if(currentSite%snow_depth > layer_top_hite)then diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index c8a38abd8c..6b315d4ef8 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -2005,7 +2005,7 @@ subroutine CrownDepth(height,ft,crown_depth) ! Original FATES crown depth heigh used for hydraulics ! crown_depth = min(height,0.1_r8) - crown_depth = prt_params%crown(ft) * plant_height + crown_depth = prt_params%crown(ft) * height return diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 87cb52fe0d..586d1b3c68 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -85,8 +85,6 @@ module FatesPlantHydraulicsMod 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 @@ -1707,8 +1705,6 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) integer :: element_id ! global element identifier index real(r8) :: leaf_m, store_m, sapw_m ! Element mass in organ tissues real(r8) :: fnrt_m, struct_m, repro_m ! Element mass in organ tissues - real(r8) :: cohort_recruit_water_layer(csite_hydr%nlevrhiz) - real(r8) :: recruit_water_avail_layer(csite_hydr%nlevrhiz) cpatch => ccohort%patchptr csite_hydr => csite%si_hydr @@ -1720,11 +1716,9 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) 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 + csite_hydr%cohort_recruit_water_layer(j) = recruitw*ccohort_hydr%l_aroot_layer(j)/sum_l_aroot end do - recruit_water_avail_layer(:) = 0._r8 - 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) @@ -1733,14 +1727,14 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) 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) + csite_hydr%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)>nearzero) then - n = recruit_water_avail_layer(j)/cohort_recruit_water_layer(j) + if(csite_hydr%cohort_recruit_water_layer(j)>nearzero) then + n = csite_hydr%recruit_water_avail_layer(j)/csite_hydr%cohort_recruit_water_layer(j) nmin = min(n, nmin) endif end do @@ -4315,7 +4309,7 @@ function zeng2001_crootfr(a, b, z, z_max) result(crootfr) if(present(z_max))then ! If the soil depth is larger than the maximum rooting depth of the cohort, ! then the cumulative root fraction of that layer equals that of the maximum rooting depth - crootfr = 1._r8 - .5_r8*(exp(-a*min(z,z_max)) + exp(-b*min(z,z_max)) + crootfr = 1._r8 - .5_r8*(exp(-a*min(z,z_max)) + exp(-b*min(z,z_max))) crootfr_max = 1._r8 - .5_r8*(exp(-a*z_max) + exp(-b*z_max)) crootfr = crootfr/crootfr_max end if @@ -4337,7 +4331,7 @@ end function zeng2001_crootfr ! ===================================================================================== -subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_shell) +subroutine shellGeom(l_aroot_in, rs1_in, 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 @@ -4364,11 +4358,11 @@ subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_s integer :: k ! rhizosphere shell indicies integer :: nshells ! We don't use the global because of unit testing - ! When we have no roots, we use a nominal + + ! When we have no roots, we may choose to use a nominal ! value of 1cm per cubic meter to define the rhizosphere shells ! this "should" help with the transition when roots grow into a layer - - real(r8), parameter :: nominal_l_aroot = 0.01_r8 ! m/m3 + ! real(r8), parameter :: nominal_l_aroot = 0.01_r8 ! m/m3 !----------------------------------------------------------------------- diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 00470cc6de..1d08ae2e51 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -937,7 +937,7 @@ subroutine crown_damage ( currentSite ) (currentCohort%hite-crown_depth))) then currentCohort%fraction_crown_burned = (currentPatch%Scorch_ht(currentCohort%pft) - & - (currentCohort%hite - crown_depth)/crown_depth + (currentCohort%hite - crown_depth))/crown_depth else ! Flames over top of canopy. diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 3699353de5..a6e93d2a34 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1775,6 +1775,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) real(r8) :: struct_m_net_alloc real(r8) :: repro_m_net_alloc real(r8) :: area_frac + real(r8) :: crown_depth type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort @@ -2231,8 +2232,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) endif ! what fraction of a cohort's crown is in this height bin? frac_canopy_in_bin = (min(bintop,ccohort%hite) - & - max(binbottom,ccohort%hite * (1._r8 - EDPftvarcon_inst%crown(ft)))) / & - (ccohort%hite * EDPftvarcon_inst%crown(ft)) + max(binbottom,ccohort%hite-crown_depth)) / & + (crown_depth) ! hio_leaf_height_dist_si_height(io_si,i_heightbin) = & hio_leaf_height_dist_si_height(io_si,i_heightbin) + & diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 9fe0f03acd..f971b4f55b 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -70,9 +70,7 @@ module FatesHydraulicsMemMod ! ---------------------------------------------------------------------------------------------- !temporatory variables - !real(r8), public :: cohort_recruit_water_layer(nlevsoi_hyd_max) ! the recruit water requirement for a - ! single individual at different layer (kg H2o/m2) - !real(r8), public :: recruit_water_avail_layer(nlevsoi_hyd_max) ! the recruit water avaibility from soil (kg H2o/m2) + type, public :: ed_site_hydr_type @@ -185,10 +183,12 @@ module FatesHydraulicsMemMod real(r8), allocatable :: q_flux(:) real(r8), allocatable :: dftc_dpsi_node(:) real(r8), allocatable :: ftc_node(:) - - real(r8), allocatable :: kmax_up(:) real(r8), allocatable :: kmax_dn(:) + + ! Scratch arrays + real(r8) :: cohort_recruit_water_layer(nlevsoi_hyd_max) ! the recruit water requirement for a + real(r8) :: recruit_water_avail_layer(nlevsoi_hyd_max) ! the recruit water avaibility from soil (kg H2o/m2) contains From c94464093e4f1281eaa87dbacb5f1cf94e3d0223 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 1 Oct 2021 13:14:46 -0400 Subject: [PATCH 412/578] Created subroutine for maximum rooting depth, passing that into root bisection method used for getting transporting root depth --- biogeochem/EDCohortDynamicsMod.F90 | 2 +- biogeophys/FatesPlantHydraulicsMod.F90 | 104 ++++++++++++++++++------- 2 files changed, 75 insertions(+), 31 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 2fa98aa59f..ecdb731621 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -324,7 +324,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & call InitHydrCohort(currentSite,new_cohort) ! This calculates node heights - call UpdatePlantHydrNodes(new_cohort%co_hydr,new_cohort%pft, & + call UpdatePlantHydrNodes(new_cohort,new_cohort%pft, & new_cohort%hite,currentSite%si_hydr) ! This calculates volumes and lengths diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 586d1b3c68..59b5ad630e 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -350,7 +350,7 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ccohort_hydr => ccohort%co_hydr ! This calculates node heights - call UpdatePlantHydrNodes(ccohort_hydr,ccohort%pft,ccohort%hite, & + call UpdatePlantHydrNodes(ccohort,ccohort%pft,ccohort%hite, & sites(s)%si_hydr) ! This calculates volumes and lengths @@ -651,7 +651,7 @@ end subroutine UpdatePlantPsiFTCFromTheta ! ===================================================================================== - subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) + subroutine UpdatePlantHydrNodes(ccohort,ft,plant_height,csite_hydr) ! -------------------------------------------------------------------------------- ! This subroutine calculates the nodal heights critical to hydraulics in the plant @@ -668,13 +668,14 @@ subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) ! -------------------------------------------------------------------------------- ! 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 + type(ed_cohort_type), intent(inout) :: ccohort + 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 + type(ed_cohort_hydr_type), pointer :: ccohort_hydr integer :: nlevrhiz ! number of rhizosphere layers real(r8) :: roota ! root profile parameter a zeng2001_crootfr real(r8) :: rootb ! root profile parameter b zeng2001_crootfr @@ -686,7 +687,11 @@ subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) 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 + real(r8) :: z_fr ! Maximum rooting depth of the plant [m] + ccohort_hydr => ccohort%co_hydr + + ! 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 @@ -694,8 +699,9 @@ subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) rootb = prt_params%fnrt_prof_b(ft) nlevrhiz = csite_hydr%nlevrhiz - call CrownDepth(plant_height,ft,crown_depth) - + !call CrownDepth(plant_height,ft,crown_depth) + crown_depth = min(plant_height,0.1_r8) + 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) @@ -715,10 +721,18 @@ subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) ccohort_hydr%z_lower_ag(k) = ccohort_hydr%z_upper_ag(k) - dz_stem enddo + call MaximumRootingDepth(ccohort%dbh,ft,csite_hydr%zi_rhiz(nlevrhiz),z_fr) + ! Transporting Root Node depth [m] (negative from surface) - call bisect_rootfr(roota, rootb, 0._r8, 1.E10_r8, & + call bisect_rootfr(roota, rootb, z_fr, 0._r8, 1.E10_r8, & 0.001_r8, 0.001_r8, 0.5_r8, z_cumul_rf) + + if(z_cumul_rf > csite_hydr%zi_rhiz(nlevrhiz) ) then + print*,"z_cumul_rf > zi_rhiz(nlevrhiz)?",z_cumul_rf,csite_hydr%zi_rhiz(nlevrhiz) + stop + end if + z_cumul_rf = min(z_cumul_rf, abs(csite_hydr%zi_rhiz(nlevrhiz))) ccohort_hydr%z_node_troot = -z_cumul_rf @@ -775,7 +789,7 @@ subroutine UpdateSizeDepPlantHydProps(currentSite,ccohort,bc_in) call SavePreviousCompartmentVolumes(ccohort_hydr) ! This updates all of the z_node positions - call UpdatePlantHydrNodes(ccohort_hydr,ft,ccohort%hite,currentSite%si_hydr) + call UpdatePlantHydrNodes(ccohort,ft,ccohort%hite,currentSite%si_hydr) ! This updates plant compartment volumes, lengths and ! maximum conductances. Make sure for already @@ -862,13 +876,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) struct_c = ccohort%prt%GetState(struct_organ, carbon12_element) roota = prt_params%fnrt_prof_a(ft) rootb = prt_params%fnrt_prof_b(ft) - dbh_max = prt_params%allom_zroot_max_dbh(ft) - dbh_0 = prt_params%allom_zroot_min_dbh(ft) - z_fr_max = prt_params%allom_zroot_max_z(ft) - z_fr_0 = prt_params%allom_zroot_min_z(ft) - frk = prt_params%allom_zroot_k(ft) - dbh = ccohort%dbh - dbh_rev = (dbh - dbh_0)/(dbh_max - dbh_0) + ! Leaf Volumes @@ -926,7 +934,8 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! alternative cross section calculation ! a_sapwood = a_leaf_tot / ( 0.001_r8 + 0.025_r8 * ccohort%hite ) * 1.e-4_r8 - call CrownDepth(ccohort%hite,ft,crown_depth) + !call CrownDepth(ccohort%hite,ft,crown_depth) + crown_depth = min(ccohort%hite,0.1_r8) 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 @@ -962,14 +971,12 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! We have a condition, where we may ignore the first layer ! ------------------------------------------------------------------------------ ! Further, incorporate maximum rooting depth parameterization into these - ! calculations. set the rooting depth of the cohort, using the logistic functionbelow: - ! Junyan Ding 2021 - ! z_fr_max/(1 + ((z_fr_max-z_fr_0)/z_fr_0)*exp(-frk*dbh_rev)) - ! which is constrained by the maximum soil depth: site_hydr%zi_rhiz(nlevrhiz) + ! calculations. - ! The dynamic root growth model by Junyan Ding, June 9, 2021 - z_fr = min(site_hydr%zi_rhiz(nlevrhiz), z_fr_max/(1 + ((z_fr_max-z_fr_0)/z_fr_0)*exp(-frk*dbh_rev))) + + call MaximumRootingDepth(ccohort%dbh,ft,site_hydr%zi_rhiz(nlevrhiz),z_fr) + norm = 1._r8 - & zeng2001_crootfr(roota, rootb,site_hydr%zi_rhiz(1)-site_hydr%dz_rhiz(1), z_fr ) @@ -1210,7 +1217,7 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne call SavePreviousCompartmentVolumes(ccohort_hydr) ! This updates all of the z_node positions - call UpdatePlantHydrNodes(ccohort_hydr,ft,currentCohort%hite,site_hydr) + call UpdatePlantHydrNodes(currentCohort,ft,currentCohort%hite,site_hydr) ! This updates plant compartment volumes, lengths and ! maximum conductances. Make sure for already @@ -4238,7 +4245,43 @@ end subroutine RecruitWaterStorage ! Utility Functions ! ===================================================================================== -subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_new) +subroutine MaximumRootingDepth(dbh,ft,z_max_soil,z_fr) + + ! --------------------------------------------------------------------------------- + ! Calculate the maximum rooting depth of the plant. + ! + ! This is an exponential which is constrained by the maximum soil depth: + ! site_hydr%zi_rhiz(nlevrhiz) + ! The dynamic root growth model by Junyan Ding, June 9, 2021 + ! --------------------------------------------------------------------------------- + + real(r8),intent(in) :: dbh ! Plant dbh + integer,intent(in) :: ft ! Funtional type index + real(r8),intent(in) :: z_max_soil ! Maximum depth of soil (pos convention) [m] + real(r8),intent(out) :: z_fr ! Maximum depth of plant's roots + ! (pos convention) [m] + + real(r8) :: dbh_rel ! Relative dbh of plant between the diameter at which we + ! define the shallowest rooting depth (dbh_0) and the diameter + ! at which we define the deepest rooting depth (dbh_max) + + associate( & + dbh_max => prt_params%allom_zroot_max_dbh(ft), & + dbh_0 => prt_params%allom_zroot_min_dbh(ft), & + z_fr_max => prt_params%allom_zroot_max_z(ft), & + z_fr_0 => prt_params%allom_zroot_min_z(ft), & + frk => prt_params%allom_zroot_k(ft)) + + dbh_rel = min(1._r8,(max(dbh,dbh_0) - dbh_0)/(dbh_max - dbh_0)) + + z_fr = min(z_max_soil, z_fr_max/(1._r8 + ((z_fr_max-z_fr_0)/z_fr_0)*exp(-frk*dbh_rel))) + + end associate + return +end subroutine MaximumRootingDepth + + +subroutine bisect_rootfr(a, b, z_max, lower_init, upper_init, xtol, ytol, crootfr, x_new) ! ! !DESCRIPTION: Bisection routine for getting the inverse of the cumulative root ! distribution. No analytical soln bc crootfr ~ exp(ax) + exp(bx). @@ -4246,7 +4289,8 @@ subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_ne ! !USES: ! ! !ARGUMENTS - real(r8) , intent(in) :: a, b ! pft root distribution constants + real(r8) , intent(in) :: a, b ! pft root distribution constants + real(r8) , intent(in) :: z_max ! maximum rooting depth 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] @@ -4268,12 +4312,12 @@ subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_ne lower = lower_init upper = upper_init - f_lo = zeng2001_crootfr(a, b, lower) - crootfr - f_hi = zeng2001_crootfr(a, b, upper) - crootfr + f_lo = zeng2001_crootfr(a, b, lower, z_max) - crootfr + f_hi = zeng2001_crootfr(a, b, upper, z_max) - 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 + f_new = zeng2001_crootfr(a, b, x_new, z_max) - crootfr if(abs(f_new) .le. ytol) then EXIT end if From 2f1ba5e6b5bc9ed306c3790352ec5119fc27b8ad Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 4 Oct 2021 22:11:52 -0600 Subject: [PATCH 413/578] added fcansno to restart variables --- main/FatesRestartInterfaceMod.F90 | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 5fe3b267a1..f5ff4bbf71 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -138,6 +138,7 @@ module FatesRestartInterfaceMod integer :: ir_lmort_infra_co ! Radiation + integer :: ir_fcansno_pa integer :: ir_solar_zenith_flag_pa integer :: ir_solar_zenith_angle_pa integer :: ir_gnd_alb_dif_pasb @@ -654,6 +655,10 @@ subroutine define_restart_vars(this, initialize_variables) long_name='the number of cohorts per patch', units='unitless', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_ncohort_pa ) + call this%set_restart_var(vname='fates_fcansno_pa', vtype=cohort_r8, & + long_name='Fraction of canopy covered in snow', units='unitless', flushval = flushinvalid, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fcansno_pa ) + call this%set_restart_var(vname='fates_solar_zenith_flag_pa', vtype=cohort_int, & long_name='switch specifying if zenith is positive', units='unitless', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_solar_zenith_flag_pa ) @@ -1651,6 +1656,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_snow_depth_si => this%rvars(ir_snow_depth_si)%r81d, & rio_trunk_product_si => this%rvars(ir_trunk_product_si)%r81d, & rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d, & + rio_fcansno_pa => this%rvars(ir_fcansno_pa)%r81d, & rio_solar_zenith_flag_pa => this%rvars(ir_solar_zenith_flag_pa)%int1d, & rio_solar_zenith_angle_pa => this%rvars(ir_solar_zenith_angle_pa)%r81d, & rio_canopy_layer_co => this%rvars(ir_canopy_layer_co)%int1d, & @@ -1971,6 +1977,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! set cohorts per patch for IO rio_ncohort_pa( io_idx_co_1st ) = cohortsperpatch + rio_fcansno_pa( io_idx_co_1st ) = cpatch%fcansno + ! Set zenith angle info if ( cpatch%solar_zenith_flag ) then rio_solar_zenith_flag_pa(io_idx_co_1st) = itrue @@ -2466,6 +2474,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_snow_depth_si => this%rvars(ir_snow_depth_si)%r81d, & rio_trunk_product_si => this%rvars(ir_trunk_product_si)%r81d, & rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d, & + rio_fcansno_pa => this%rvars(ir_fcansno_pa)%r81d, & rio_solar_zenith_flag_pa => this%rvars(ir_solar_zenith_flag_pa)%int1d, & rio_solar_zenith_angle_pa => this%rvars(ir_solar_zenith_angle_pa)%r81d, & rio_canopy_layer_co => this%rvars(ir_canopy_layer_co)%int1d, & @@ -2770,6 +2779,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) cpatch%nocomp_pft_label = rio_nocomp_pft_label_pa(io_idx_co_1st) cpatch%area = rio_area_pa(io_idx_co_1st) cpatch%age_class = get_age_class_index(cpatch%age) + cpatch%fcansno = rio_fcansno_pa(io_idx_co_1st) ! Set zenith angle info cpatch%solar_zenith_flag = ( rio_solar_zenith_flag_pa(io_idx_co_1st) .eq. itrue ) From 3acbefa34edcbddb2cf1632bf1d9c790734f19d9 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Tue, 5 Oct 2021 14:14:00 -0600 Subject: [PATCH 414/578] more updates to history vars --- main/FatesHistoryInterfaceMod.F90 | 567 +++++++++++++++++------------- 1 file changed, 326 insertions(+), 241 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 114752fe22..7a24da569d 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2453,7 +2453,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! also by size class only hio_ba_si_scls(io_si,scls) = hio_ba_si_scls(io_si,scls) + & - 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*ccohort%n + 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)* & + ccohort%n / m2_per_ha ! growth increment hio_ddbh_si_scpf(io_si,scpf) = hio_ddbh_si_scpf(io_si,scpf) + & @@ -2478,19 +2479,19 @@ subroutine update_history_dyn(this,nc,nsites,sites) if (hlm_use_cohort_age_tracking .eq.itrue) then hio_m10_si_scpf(io_si,scpf) = hio_m10_si_scpf(io_si,scpf) + ccohort%asmort*ccohort%n / m2_per_ha hio_m10_si_capf(io_si,capf) = hio_m10_si_capf(io_si,capf) + ccohort%asmort*ccohort%n / m2_per_ha - hio_m10_si_scls(io_si,scls) = hio_m10_si_scls(io_si,scls) + ccohort%asmort*ccohort%n + hio_m10_si_scls(io_si,scls) = hio_m10_si_scls(io_si,scls) + ccohort%asmort*ccohort%n / m2_per_ha hio_m10_si_cacls(io_si,cacls) = hio_m10_si_cacls(io_si,cacls)+ & - ccohort%asmort*ccohort%n + ccohort%asmort*ccohort%n / m2_per_ha end if - hio_m1_si_scls(io_si,scls) = hio_m1_si_scls(io_si,scls) + ccohort%bmort*ccohort%n - hio_m2_si_scls(io_si,scls) = hio_m2_si_scls(io_si,scls) + ccohort%hmort*ccohort%n - hio_m3_si_scls(io_si,scls) = hio_m3_si_scls(io_si,scls) + ccohort%cmort*ccohort%n + hio_m1_si_scls(io_si,scls) = hio_m1_si_scls(io_si,scls) + ccohort%bmort*ccohort%n / m2_per_ha + hio_m2_si_scls(io_si,scls) = hio_m2_si_scls(io_si,scls) + ccohort%hmort*ccohort%n / m2_per_ha + hio_m3_si_scls(io_si,scls) = hio_m3_si_scls(io_si,scls) + ccohort%cmort*ccohort%n / m2_per_ha hio_m7_si_scls(io_si,scls) = hio_m7_si_scls(io_si,scls) + & - (ccohort%lmort_direct+ccohort%lmort_collateral+ccohort%lmort_infra) * ccohort%n + (ccohort%lmort_direct+ccohort%lmort_collateral+ccohort%lmort_infra) * ccohort%n / m2_per_ha hio_m8_si_scls(io_si,scls) = hio_m8_si_scls(io_si,scls) + & - ccohort%frmort*ccohort%n - hio_m9_si_scls(io_si,scls) = hio_m9_si_scls(io_si,scls) + ccohort%smort*ccohort%n + ccohort%frmort*ccohort%n / m2_per_ha + hio_m9_si_scls(io_si,scls) = hio_m9_si_scls(io_si,scls) + ccohort%smort*ccohort%n / m2_per_ha @@ -2508,7 +2509,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! number density along the cohort age dimension if (hlm_use_cohort_age_tracking .eq.itrue) then hio_nplant_si_capf(io_si,capf) = hio_nplant_si_capf(io_si,capf) + ccohort%n / m2_per_ha - hio_nplant_si_cacls(io_si,cacls) = hio_nplant_si_cacls(io_si,cacls)+ccohort%n + hio_nplant_si_cacls(io_si,cacls) = hio_nplant_si_cacls(io_si,cacls)+ccohort%n / m2_per_ha end if @@ -2586,7 +2587,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%n * sec_per_day * days_per_year hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + ccohort%n / m2_per_ha - hio_nplant_canopy_si_scls(io_si,scls) = hio_nplant_canopy_si_scls(io_si,scls) + ccohort%n + hio_nplant_canopy_si_scls(io_si,scls) = hio_nplant_canopy_si_scls(io_si,scls) + ccohort%n / m2_per_ha hio_lai_canopy_si_scls(io_si,scls) = hio_lai_canopy_si_scls(io_si,scls) + & ccohort%treelai*ccohort%c_area * AREA_INV hio_sai_canopy_si_scls(io_si,scls) = hio_sai_canopy_si_scls(io_si,scls) + & @@ -2611,7 +2612,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * sec_per_day * days_per_year + ccohort%n * sec_per_day * days_per_year / m2_per_ha hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & @@ -2653,7 +2654,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) = & hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) + & - ccohort%canopy_layer_yesterday * ccohort%n + ccohort%canopy_layer_yesterday * ccohort%n / m2_per_ha else hio_nplant_understory_si_scag(io_si,iscag) = hio_nplant_understory_si_scag(io_si,iscag) + ccohort%n / m2_per_ha hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & @@ -2662,9 +2663,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_ddbh_understory_si_scag(io_si,iscag) = hio_ddbh_understory_si_scag(io_si,iscag) + & ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & - store_m * ccohort%n + store_m * ccohort%n / m2_per_ha hio_bleaf_understory_si_scpf(io_si,scpf) = hio_bleaf_understory_si_scpf(io_si,scpf) + & - leaf_m * ccohort%n + leaf_m * ccohort%n / m2_per_ha hio_understory_biomass_si(io_si) = hio_understory_biomass_si(io_si) + & n_perm2 * total_m @@ -2678,8 +2679,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & ccohort%n * sec_per_day * days_per_year / m2_per_ha - hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + ccohort%n - hio_nplant_understory_si_scls(io_si,scls) = hio_nplant_understory_si_scls(io_si,scls) + ccohort%n + hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + ccohort%n / m2_per_ha + hio_nplant_understory_si_scls(io_si,scls) = hio_nplant_understory_si_scls(io_si,scls) + ccohort%n / m2_per_ha hio_lai_understory_si_scls(io_si,scls) = hio_lai_understory_si_scls(io_si,scls) + & ccohort%treelai*ccohort%c_area * AREA_INV hio_sai_understory_si_scls(io_si,scls) = hio_sai_understory_si_scls(io_si,scls) + & @@ -2836,15 +2837,17 @@ subroutine update_history_dyn(this,nc,nsites,sites) do i_cwd = 1, ncwd hio_cwd_ag_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_si_cwdsc(io_si, i_cwd) + & - litt_c%ag_cwd(i_cwd)*cpatch%area * AREA_INV * g_per_kg + litt_c%ag_cwd(i_cwd)*cpatch%area * AREA_INV hio_cwd_bg_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_si_cwdsc(io_si, i_cwd) + & - sum(litt_c%bg_cwd(i_cwd,:)) * cpatch%area * AREA_INV * g_per_kg + sum(litt_c%bg_cwd(i_cwd,:)) * cpatch%area * AREA_INV hio_cwd_ag_out_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_out_si_cwdsc(io_si, i_cwd) + & - litt_c%ag_cwd_frag(i_cwd)*cpatch%area * AREA_INV * g_per_kg + litt_c%ag_cwd_frag(i_cwd)*cpatch%area * AREA_INV / & + days_per_year / sec_per_day hio_cwd_bg_out_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_out_si_cwdsc(io_si, i_cwd) + & - sum(litt_c%bg_cwd_frag(i_cwd,:)) * cpatch%area * AREA_INV * g_per_kg + sum(litt_c%bg_cwd_frag(i_cwd,:)) * cpatch%area * AREA_INV / & + days_per_year / sec_per_day end do @@ -2880,9 +2883,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) sites(s)%term_nindivs_ustory(i_scls,i_pft)) * & days_per_year / m2_per_ha - hio_m6_si_scls(io_si,i_scls) = hio_m6_si_scls(io_si,i_scls) + & - (sites(s)%term_nindivs_canopy(i_scls,i_pft) + & - sites(s)%term_nindivs_ustory(i_scls,i_pft)) * days_per_year + hio_m6_si_scls(io_si,i_scls) = hio_m6_si_scls(io_si,i_scls) + & + (sites(s)%term_nindivs_canopy(i_scls,i_pft) + & + sites(s)%term_nindivs_ustory(i_scls,i_pft)) * & + days_per_year / m2_per_ha ! @@ -2902,7 +2906,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! ! imort on its own hio_m4_si_scpf(io_si,i_scpf) = sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha - hio_m4_si_scls(io_si,i_scls) = hio_m4_si_scls(io_si,i_scls) + sites(s)%imort_rate(i_scls, i_pft) + hio_m4_si_scls(io_si,i_scls) = hio_m4_si_scls(io_si,i_scls) + sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha ! ! add imort to other mortality terms. consider imort as understory mortality even if it happens in ! cohorts that may have been promoted as part of the patch creation, and use the pre-calculated site-level @@ -2920,7 +2924,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m5_si_scpf(io_si,i_scpf) = (sites(s)%fmort_rate_canopy(i_scls, i_pft) + & sites(s)%fmort_rate_ustory(i_scls, i_pft)) / m2_per_ha hio_m5_si_scls(io_si,i_scls) = hio_m5_si_scls(io_si,i_scls) + & - sites(s)%fmort_rate_canopy(i_scls, i_pft) + sites(s)%fmort_rate_ustory(i_scls, i_pft) + (sites(s)%fmort_rate_canopy(i_scls, i_pft) + & + sites(s)%fmort_rate_ustory(i_scls, i_pft)) / m2_per_ha ! hio_crownfiremort_si_scpf(io_si,i_scpf) = sites(s)%fmort_rate_crown(i_scls, i_pft) / m2_per_ha hio_cambialfiremort_si_scpf(io_si,i_scpf) = sites(s)%fmort_rate_cambial(i_scls, i_pft) / m2_per_ha @@ -3347,11 +3352,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! pass demotion rates and associated carbon fluxes to history do i_scls = 1,nlevsclass - hio_demotion_rate_si_scls(io_si,i_scls) = sites(s)%demotion_rate(i_scls) * days_per_year - hio_promotion_rate_si_scls(io_si,i_scls) = sites(s)%promotion_rate(i_scls) * days_per_year + hio_demotion_rate_si_scls(io_si,i_scls) = sites(s)%demotion_rate(i_scls) * days_per_year / m2_per_ha + hio_promotion_rate_si_scls(io_si,i_scls) = sites(s)%promotion_rate(i_scls) * days_per_year / m2_per_ha end do ! - ! convert kg C / ha / day to gc / m2 / sec + ! convert kg C / ha / day to kgc / m2 / sec hio_demotion_carbonflux_si(io_si) = sites(s)%demotion_carbonflux * ha_per_m2 * days_per_sec hio_promotion_carbonflux_si(io_si) = sites(s)%promotion_carbonflux * ha_per_m2 * days_per_sec ! @@ -3372,10 +3377,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) do i_cwd = 1, ncwd hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) + & - flux_diags_c%cwd_ag_input(i_cwd) * g_per_kg + flux_diags_c%cwd_ag_input(i_cwd) / days_per_year / sec_per_day hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) + & - flux_diags_c%cwd_bg_input(i_cwd) * g_per_kg + flux_diags_c%cwd_bg_input(i_cwd) / days_per_year / sec_per_day end do @@ -3586,34 +3591,34 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_livestem_mr_si(io_si) = hio_livestem_mr_si(io_si) + ccohort%livestem_mr & * n_perm2 * sec_per_day * days_per_year - ! Total AR (kgC/m2/yr) = (kgC/plant/step) / (s/step) * (plant/m2) * (s/yr) + ! Total AR (kgC/m2/s) = (kgC/plant/step) / (s/step) * (plant/m2) hio_ar_si_scpf(io_si,scpf) = hio_ar_si_scpf(io_si,scpf) + & - (ccohort%resp_tstep/dt_tstep) * n_perm2 * sec_per_day * days_per_year + (ccohort%resp_tstep/dt_tstep) * n_perm2 - ! Growth AR (kgC/m2/yr) + ! Growth AR (kgC/m2/s) hio_ar_grow_si_scpf(io_si,scpf) = hio_ar_grow_si_scpf(io_si,scpf) + & - (resp_g/dt_tstep) * n_perm2 * sec_per_day * days_per_year + (resp_g/dt_tstep) * n_perm2 - ! Maint AR (kgC/m2/yr) + ! Maint AR (kgC/m2/s) hio_ar_maint_si_scpf(io_si,scpf) = hio_ar_maint_si_scpf(io_si,scpf) + & - (ccohort%resp_m/dt_tstep) * n_perm2 * sec_per_day * days_per_year + (ccohort%resp_m/dt_tstep) * n_perm2 ! Maintenance AR partition variables are stored as rates (kgC/plant/s) - ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + ! (kgC/m2/s) = (kgC/plant/s) * (plant/m2) hio_ar_agsapm_si_scpf(io_si,scpf) = hio_ar_agsapm_si_scpf(io_si,scpf) + & - ccohort%livestem_mr * n_perm2 * sec_per_day * days_per_year + ccohort%livestem_mr * n_perm2 - ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + ! (kgC/m2/s) = (kgC/plant/s) * (plant/m2) hio_ar_darkm_si_scpf(io_si,scpf) = hio_ar_darkm_si_scpf(io_si,scpf) + & - ccohort%rdark * n_perm2 * sec_per_day * days_per_year + ccohort%rdark * n_perm2 - ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + ! (kgC/m2/s) = (kgC/plant/s) * (plant/m2) hio_ar_crootm_si_scpf(io_si,scpf) = hio_ar_crootm_si_scpf(io_si,scpf) + & - ccohort%livecroot_mr * n_perm2 * sec_per_day * days_per_year + ccohort%livecroot_mr * n_perm2 - ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + ! (kgC/m2/s) = (kgC/plant/s) * (plant/m2) hio_ar_frootm_si_scpf(io_si,scpf) = hio_ar_frootm_si_scpf(io_si,scpf) + & - ccohort%froot_mr * n_perm2 * sec_per_day * days_per_year + ccohort%froot_mr * n_perm2 ! accumulate fluxes per patch age bin @@ -4878,7 +4883,7 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_balive_si) - call this%set_history_var(vname='FATES_ABOVE_VEGC', units='kg m-2', & + call this%set_history_var(vname='FATES_VEGC_ABOVEGROUND', units='kg m-2', & long='aboveground biomass in kg carbon per m2 land area', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & @@ -5641,236 +5646,316 @@ subroutine define_history_vars(this, initialize_variables) initialize=initialize_variables, & index = ih_mortality_understory_si_scpf) - call this%set_history_var(vname='BSTOR_UNDERSTORY_SCPF', units = 'kgC/ha', & - long='biomass carbon in storage pools of understory plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstor_understory_si_scpf ) - - call this%set_history_var(vname='BLEAF_UNDERSTORY_SCPF', units = 'kgC/ha', & - long='biomass carbon in leaf of understory plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bleaf_understory_si_scpf ) - - call this%set_history_var(vname='NPLANT_UNDERSTORY_SCPF', units = 'N/ha', & - long='stem number of understory plants density by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_understory_si_scpf ) - - call this%set_history_var(vname='CWD_AG_CWDSC', units='gC/m^2', & - long='size-resolved AG CWD stocks', use_default='inactive', & - avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_si_cwdsc ) - - call this%set_history_var(vname='CWD_BG_CWDSC', units='gC/m^2', & - long='size-resolved BG CWD stocks', use_default='inactive', & - avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_si_cwdsc ) - - call this%set_history_var(vname='CWD_AG_IN_CWDSC', units='gC/m^2/y', & - long='size-resolved AG CWD input', use_default='inactive', & - avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_in_si_cwdsc ) - - call this%set_history_var(vname='CWD_BG_IN_CWDSC', units='gC/m^2/y', & - long='size-resolved BG CWD input', use_default='inactive', & - avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_in_si_cwdsc ) - - call this%set_history_var(vname='CWD_AG_OUT_CWDSC', units='gC/m^2/y', & - long='size-resolved AG CWD output', use_default='inactive', & - avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_out_si_cwdsc ) - - call this%set_history_var(vname='CWD_BG_OUT_CWDSC', units='gC/m^2/y', & - long='size-resolved BG CWD output', use_default='inactive', & - avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_out_si_cwdsc ) + call this%set_history_var(vname='FATES_STOREC_UNDERSTORY_SZPF', & + units = 'kg m-2', & + long='biomass in storage pools of understory plants by pft/size in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_bstor_understory_si_scpf) + + call this%set_history_var(vname='FATES_LEAFC_UNDERSTORY_SZPF', & + units = 'kg m-2', & + long='biomass in leaves of understory plants by pft/size in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_bleaf_understory_si_scpf) + + call this%set_history_var(vname='FATES_NPLANT_UNDERSTORY_SZPF', & + units = 'm-2', & + long='density of understory plants by pft/size in number of plants per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nplant_understory_si_scpf) + + call this%set_history_var(vname='FATES_CWD_ABOVEGROUND_DC', units='kg m-2', & + long='debris class-level aboveground coarse woody debris stocks in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_cwdsc_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cwd_ag_si_cwdsc) + + call this%set_history_var(vname='FATES_CWD_BELOWGROUND_DC', units='kg m-2', & + long='debris class-level belowground coarse woody debris stocks in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_cwdsc_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cwd_bg_si_cwdsc) + + call this%set_history_var(vname='FATES_CWD_ABOVEGROUND_IN_DC', & + units='kg m-2 s-1', & + long='debris class-level aboveground coarse woody debris input in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_cwdsc_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cwd_ag_in_si_cwdsc) + + call this%set_history_var(vname='FATES_CWD_BELOWGROUND_IN_DC', & + units='kg m-2 s-1', & + long='debris class-level belowground coarse woody debris input in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_cwdsc_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cwd_bg_in_si_cwdsc) + + call this%set_history_var(vname='FATES_CWD_ABOVEGROUND_OUT_DC', & + units='kg m-2 s-1', & + long='debris class-level aboveground coarse woody debris output in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_cwdsc_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cwd_ag_out_si_cwdsc) + + call this%set_history_var(vname='FATES_CWD_BELOWGROUND_OUT_DC', & + units='kg m-2 s-1', & + long='debris class-level belowground coarse woody debris output in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_cwdsc_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cwd_bg_out_si_cwdsc) ! Size structured diagnostics that require rapid updates (upfreq=2) - call this%set_history_var(vname='AR_SCPF',units = 'kgC/m2/yr', & - long='total autotrophic respiration per m2 per year by pft/size',use_default='inactive',& - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_si_scpf ) - - call this%set_history_var(vname='AR_GROW_SCPF',units = 'kgC/m2/yr', & - long='growth autotrophic respiration per m2 per year by pft/size',use_default='inactive',& - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_grow_si_scpf ) - - call this%set_history_var(vname='AR_MAINT_SCPF',units = 'kgC/m2/yr', & - long='maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_maint_si_scpf ) - - call this%set_history_var(vname='AR_DARKM_SCPF',units = 'kgC/m2/yr', & - long='dark portion of maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& - avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_darkm_si_scpf ) - - call this%set_history_var(vname='AR_AGSAPM_SCPF',units = 'kgC/m2/yr', & - long='above-ground sapwood maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& - avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_agsapm_si_scpf ) - - call this%set_history_var(vname='AR_CROOTM_SCPF',units = 'kgC/m2/yr', & - long='below-ground sapwood maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& - avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_crootm_si_scpf ) - - call this%set_history_var(vname='AR_FROOTM_SCPF',units = 'kgC/m2/yr', & - long='fine root maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_frootm_si_scpf ) + call this%set_history_var(vname='FATES_AUTO_RESP_SZPF', & + units = 'kg m-2 s-1', & + long='total autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_si_scpf) + + call this%set_history_var(vname='FATES_AUTO_RESP_GROW_SZPF', & + units = 'kg m-2 s-1', & + long='growth autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_grow_si_scpf) + + call this%set_history_var(vname='FATES_AUTO_RESP_MAINT_SZPF', & + units = 'kg m-2 s-1', & + long='maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_maint_si_scpf) + + call this%set_history_var(vname='FATES_AUTO_RESP_DARKMAINT_SZPF', & + units = 'kg m-2 s-1', & + long='dark portion of maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_darkm_si_scpf) + + call this%set_history_var(vname='FATES_AUTO_RESP_AGSAPMAINT_SZPF', & + units = 'kg m-2 s-1', & + long='above-ground sapwood maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_agsapm_si_scpf) + + call this%set_history_var(vname='FATES_AUTO_RESP_BGSAPMAINT_SZPF', & + units = 'kg m-2 s-1', & + long='below-ground sapwood maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_crootm_si_scpf) + + call this%set_history_var(vname='FATES_AUTO_RESP_FROOTMAINT_SZPF', & + units = 'kg m-2 s-1', & + long='fine root maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_frootm_si_scpf) ! size-class only variables - call this%set_history_var(vname='DDBH_CANOPY_SCLS', units = 'cm/yr/ha', & - long='diameter growth increment by pft/size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_canopy_si_scls ) + call this%set_history_var(vname='FATES_DDBH_CANOPY_SZ', & + units = 'm m-2 yr-1', long='diameter growth increment by size of canopy plants', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_ddbh_canopy_si_scls) - call this%set_history_var(vname='DDBH_UNDERSTORY_SCLS', units = 'cm/yr/ha', & - long='diameter growth increment by pft/size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_understory_si_scls ) + call this%set_history_var(vname='FATES_DDBH_UNDERSTORY_SZ', & + units = 'm m-2 yr-1', long='diameter growth increment by size of understory plants', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_ddbh_understory_si_scls) - call this%set_history_var(vname='YESTERDAYCANLEV_CANOPY_SCLS', units = 'indiv/ha', & - long='Yesterdays canopy level for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_yesterdaycanopylevel_canopy_si_scls ) + call this%set_history_var(vname='FATES_YESTERDAYCANLEV_CANOPY_SZ', & + units = 'm-2', & + long='yesterdays canopy level for canopy plants by size class in number of plants per m2', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_yesterdaycanopylevel_canopy_si_scls) - call this%set_history_var(vname='YESTERDAYCANLEV_UNDERSTORY_SCLS', units = 'indiv/ha', & - long='Yesterdays canopy level for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_yesterdaycanopylevel_understory_si_scls ) + call this%set_history_var(vname='FATES_YESTERDAYCANLEV_UNDERSTORY_SZ', & + units = 'm-2', & + long='yesterdays canopy level for understory plants by size class in number of plants per m2', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_yesterdaycanopylevel_understory_si_scls) - call this%set_history_var(vname='BA_SCLS', units = 'm2/ha', & - long='basal area by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scls ) + call this%set_history_var(vname='FATES_BASALAREA_SZ', units = 'm2 m-2', & + long='basal area by size class', use_default='active', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scls) - call this%set_history_var(vname='AGB_SCLS', units = 'kgC/m2', & - long='Aboveground biomass by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_agb_si_scls ) + call this%set_history_var(vname='FATES_VEGC_ABOVEGROUND_SZ', & + units = 'kg m-2', & + long='aboveground biomass by size class in kg carbon per m2', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_agb_si_scls) - call this%set_history_var(vname='BIOMASS_SCLS', units = 'kgC/m2', & - long='Total biomass by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_scls ) + call this%set_history_var(vname='FATES_VEGC_SZ', units = 'kg m-2', & + long='total biomass by size class in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_biomass_si_scls) - call this%set_history_var(vname='DEMOTION_RATE_SCLS', units = 'indiv/ha/yr', & - long='demotion rate from canopy to understory by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_demotion_rate_si_scls ) + call this%set_history_var(vname='FATES_DEMOTION_RATE_SZ', & + units = 'm-2 yr-1', & + long='demotion rate from canopy to understory by size class in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_demotion_rate_si_scls) - call this%set_history_var(vname='PROMOTION_RATE_SCLS', units = 'indiv/ha/yr', & - long='promotion rate from understory to canopy by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_promotion_rate_si_scls ) + call this%set_history_var(vname='FATES_PROMOTION_RATE_SZ', & + units = 'm-2 yr-1', & + long='promotion rate from understory to canopy by size class', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_promotion_rate_si_scls) - call this%set_history_var(vname='NPLANT_CANOPY_SCLS', units = 'indiv/ha', & - long='number of canopy plants by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_canopy_si_scls ) + call this%set_history_var(vname='FATES_NPLANT_CANOPY_SZ', & + units = 'm-2', & + long='number of canopy plants per m2 by size class', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nplant_canopy_si_scls) - call this%set_history_var(vname='LAI_CANOPY_SCLS', units = 'm2/m2', & - long='Leaf are index (LAI) by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_lai_canopy_si_scls ) + call this%set_history_var(vname='FATES_LAI_CANOPY_SZ', units = 'm2 m-2', & + long='leaf area index (LAI) of canopy plants by size class', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_lai_canopy_si_scls) - call this%set_history_var(vname='SAI_CANOPY_SCLS', units = 'm2/m2', & - long='stem area index(SAI) by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sai_canopy_si_scls ) + call this%set_history_var(vname='FATES_SAI_CANOPY_SZ', units = 'm2 m-2', & + long='stem area index (SAI) of canopy plants by size class', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_sai_canopy_si_scls) - call this%set_history_var(vname='MORTALITY_CANOPY_SCLS', units = 'indiv/ha/yr', & - long='total mortality of canopy trees by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_canopy_si_scls ) + call this%set_history_var(vname='FATES_MORTALITY_CANOPY_SZ', & + units = 'm-2 yr-1', & + long='total mortality of canopy trees by size class in number of plants per m2', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_mortality_canopy_si_scls) - call this%set_history_var(vname='NPLANT_UNDERSTORY_SCLS', units = 'indiv/ha', & - long='number of understory plants by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_understory_si_scls ) + call this%set_history_var(vname='FATES_NPLANT_UNDERSTORY_SZ', & + units = 'm-2', & + long='number of understory plants per m2 by size class', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nplant_understory_si_scls) - call this%set_history_var(vname='LAI_UNDERSTORY_SCLS', units = 'indiv/ha', & - long='number of understory plants by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_lai_understory_si_scls ) + call this%set_history_var(vname='FATES_LAI_UNDERSTORY_SZ', & + units = 'm2 m-2', & + long='leaf area index (LAI) of understory plants by size class', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_lai_understory_si_scls) - call this%set_history_var(vname='SAI_UNDERSTORY_SCLS', units = 'indiv/ha', & - long='number of understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sai_understory_si_scls ) + call this%set_history_var(vname='FATES_SAI_UNDERSTORY_SZ', & + units = 'm2 m-2', & + long='stem area index (SAI) of understory plants by size class', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_sai_understory_si_scls) - call this%set_history_var(vname='NPLANT_SCLS', units = 'indiv/ha', & - long='number of plants by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scls ) + call this%set_history_var(vname='FATES_NPLANT_SZ', units = 'm-2', & + long='number of plants per m2 by size class', use_default='active', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scls) - call this%set_history_var(vname='NPLANT_CACLS', units = 'indiv/ha', & - long='number of plants by coage class', use_default='active', & - avgflag='A', vtype=site_coage_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_cacls ) + call this%set_history_var(vname='FATES_NPLANT_AC', units = 'm-2', & + long='number of plants per m2 by cohort age class', & + use_default='active', avgflag='A', vtype=site_coage_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nplant_si_cacls) - call this%set_history_var(vname='M1_SCLS', units = 'N/ha/yr', & - long='background mortality by size', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m1_si_scls ) + call this%set_history_var(vname='FATES_MORTALITY_BACKGROUND_SZ', & + units = 'm-2 yr-1', & + long='background mortality by size in number of plants per m2 per year', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m1_si_scls) - call this%set_history_var(vname='M2_SCLS', units = 'N/ha/yr', & - long='hydraulic mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m2_si_scls ) + call this%set_history_var(vname='FATES_MORTALITY_HYDRAULIC_SZ', & + units = 'm-2 yr-1', & + long='hydraulic mortality by size in number of plants per m2 per year', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m2_si_scls) - call this%set_history_var(vname='M3_SCLS', units = 'N/ha/yr', & - long='carbon starvation mortality by size', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m3_si_scls ) + call this%set_history_var(vname='FATES_MORTALITY_CSTARV_SZ', & + units = 'm-2 yr-1', & + long='carbon starvation mortality by size in number of plants per m2 per year', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m3_si_scls) - call this%set_history_var(vname='M4_SCLS', units = 'N/ha/yr', & - long='impact mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m4_si_scls ) + call this%set_history_var(vname='FATES_MORTALITY_IMPACT_SZ', & + units = 'm-2 yr-1', & + long='impact mortality by size in number of plants per m2 per year', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m4_si_scls) - call this%set_history_var(vname='M5_SCLS', units = 'N/ha/yr', & - long='fire mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m5_si_scls ) + call this%set_history_var(vname='FATES_MORTALITY_FIRE_SZ', & + units = 'm-2 yr-1', & + long='fire mortality by size in number of plants per m2 per year', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m5_si_scls) - call this%set_history_var(vname='M6_SCLS', units = 'N/ha/yr', & - long='termination mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m6_si_scls ) + call this%set_history_var(vname='FATES_MORTALITY_TERMINATION_SZ', & + units = 'm-2 yr-1', & + long='termination mortality by size in number of plants per m2 per year', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m6_si_scls) - call this%set_history_var(vname='M7_SCLS', units = 'N/ha/event', & - long='logging mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m7_si_scls ) + call this%set_history_var(vname='FATES_MORTALITY_LOGGING_SZ', & + units = 'm-2 event-1', & + long='logging mortality by size in number of plants per m2 per event', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m7_si_scls) - call this%set_history_var(vname='M8_SCLS', units = 'N/ha/event', & - long='freezing mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m8_si_scls ) + call this%set_history_var(vname='FATES_MORTALITY_FREEZING_SZPF', & + units = 'm-2 event-1', & + long='freezing mortality by size in number of plants per m2 per event', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m8_si_scls) - call this%set_history_var(vname='M9_SCLS', units = 'N/ha/yr', & - long='senescence mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m9_si_scls ) + call this%set_history_var(vname='FATES_MORTALITY_SENESCENCE_SZ', & + units = 'm-2 yr-1', & + long='senescence mortality by size in number of plants per m2 per event', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m9_si_scls) - call this%set_history_var(vname='M10_SCLS', units = 'N/ha/yr', & - long='age senescence mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m10_si_scls ) + call this%set_history_var(vname='FATES_MORTALITY_AGESCENESCENCE_SZ', & + units = 'm-2 yr-1', & + long='age senescence mortality by size in number of plants per m2 per year', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m10_si_scls) - call this%set_history_var(vname='M10_CACLS', units = 'N/ha/yr', & - long='age senescence mortality by cohort age',use_default='active', & - avgflag='A', vtype=site_coage_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m10_si_cacls ) + call this%set_history_var(vname='FATES_MORTALITY_AGESCENESCENCE_AC', & + units = 'm-2 yr-1', & + long='age senescence mortality by cohort age in number of plants per m2 per year', & + use_default='active', avgflag='A', vtype=site_coage_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m10_si_cacls) - call this%set_history_var(vname='CARBON_BALANCE_CANOPY_SCLS', units = 'kg C / ha / yr', & + call this%set_history_var(vname='FATES_CARBON_BALANCE_CANOPY_SZ', units = 'kg C / ha / yr', & long='CARBON_BALANCE for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_carbon_balance_canopy_si_scls ) From 43683ae1d54f0b4b5352f1d945b678d4335de102 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 6 Oct 2021 09:34:50 -0700 Subject: [PATCH 415/578] fix for issue #790 --- biogeophys/FatesHydroWTFMod.F90 | 184 ++++++++++++++++---------------- 1 file changed, 92 insertions(+), 92 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index cda65a12ae..4fac9d5657 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -29,7 +29,7 @@ module FatesHydroWTFMod real(r8), parameter :: min_ftc = 0.00001_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) @@ -57,16 +57,16 @@ module FatesHydroWTFMod ! into these linear regions, and they only exist reall to handle ! strange cases where the solvers overshoot and predict above and below ! saturation and residual respectively. - + real(r8) :: psi_max ! psi matching max_sf_interp where we start linear interp real(r8) :: psi_min ! psi matching min_sf_interp real(r8) :: dpsidth_max ! dpsi_dth where we start linear interp real(r8) :: dpsidth_min ! dpsi_dth where we start min interp real(r8) :: th_min ! vwc matching min_sf_interp where we start linear interp real(r8) :: th_max ! vwc matching max_sf_interp where we start linear interp - + 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 @@ -80,7 +80,7 @@ module FatesHydroWTFMod procedure, non_overridable :: th_linear_sat procedure, non_overridable :: th_linear_res procedure, non_overridable :: set_min_max - + end type wrf_type @@ -216,83 +216,83 @@ module FatesHydroWTFMod ! are temporary pertubations, probably through fluctuations in precision ! of numerical integration. ! ============================================================================ - + subroutine set_min_max(this,th_res,th_sat) ! This routine uses max_sf_interp and min_sft_interp ! to define the bounds of where the linear ranges start and stop - + class(wrf_type) :: this real(r8),intent(in) :: th_res real(r8),intent(in) :: th_sat - + this%th_max = max_sf_interp*(th_sat-th_res)+th_res this%th_min = min_sf_interp*(th_sat-th_res)+th_res this%psi_max = this%psi_from_th(this%th_max-tiny(this%th_max)) this%dpsidth_max = this%dpsidth_from_th(this%th_max-tiny(this%th_max)) this%psi_min = this%psi_from_th(this%th_min+tiny(this%th_min)) this%dpsidth_min = this%dpsidth_from_th(this%th_min+tiny(this%th_min)) - + end subroutine set_min_max - + ! ============================================================================ - + function psi_linear_res(this,th) result(psi) ! Calculate psi in linear range below residual - + class(wrf_type) :: this real(r8),intent(in) :: th ! vol. wat. cont [m3/m3] real(r8) :: psi ! Matric potential [MPa] - + psi = this%psi_min + this%dpsidth_min * (th-this%th_min) - + end function psi_linear_res - + ! =========================================================================== - + function psi_linear_sat(this,th) result(psi) ! Calculate psi in linear range above saturation - + class(wrf_type) :: this real(r8),intent(in) :: th ! vol. wat. cont [m3/m3] real(r8) :: psi ! Matric potential [MPa] - - psi = this%psi_max + this%dpsidth_max * (th-this%th_max) - + + psi = this%psi_max + this%dpsidth_max * (th-this%th_max) + end function psi_linear_sat ! =========================================================================== - + function th_linear_sat(this,psi) result(th) ! Calculate th from psi in linear range above saturation - + class(wrf_type) :: this real(r8),intent(in) :: psi ! Matric potential [MPa] real(r8) :: th ! vol. wat. cont [m3/m3] - + th = this%th_max + (psi-this%psi_max)/this%dpsidth_max end function th_linear_sat ! =========================================================================== - + function th_linear_res(this,psi) result(th) ! Calculate th from psi in linear range above saturation - + class(wrf_type) :: this real(r8),intent(in) :: psi ! Matric potential [MPa] real(r8) :: th ! vol. wat. cont [m3/m3] - + th = this%th_min + (psi-this%psi_min)/this%dpsidth_min end function th_linear_res - + ! =========================================================================== - + subroutine set_wrf_param_base(this,params_in) class(wrf_type) :: this real(r8),intent(in) :: params_in(:) @@ -384,7 +384,7 @@ subroutine set_wrf_param_vg(this,params_in) this%th_res = params_in(4) call this%set_min_max(this%th_res,this%th_sat) - + return end subroutine set_wrf_param_vg @@ -409,13 +409,13 @@ end subroutine set_wkf_param_vg function get_thsat_vg(this) result(th_sat) class(wrf_type_vg) :: this real(r8) :: th_sat - + th_sat = this%th_sat - + end function get_thsat_vg - + ! ===================================================================================== - + function th_from_psi_vg(this,psi) result(th) ! Van Genuchten (1980) calculation of volumetric water content (theta) @@ -435,9 +435,9 @@ function th_from_psi_vg(this,psi) result(th) ! Linear range for extreme values th = this%th_linear_sat(psi) - + elseif(psithis%th_max)then psi = this%psi_linear_sat(th) - + elseif(th=0._r8) then @@ -658,7 +658,7 @@ subroutine set_wrf_param_cch(this,params_in) this%th_min = fates_unset_r8 this%psi_min = fates_unset_r8 this%dpsidth_min = fates_unset_r8 - + return end subroutine set_wrf_param_cch @@ -680,13 +680,13 @@ end subroutine set_wkf_param_cch function get_thsat_cch(this) result(th_sat) class(wrf_type_cch) :: this real(r8) :: th_sat - + th_sat = this%th_sat - + end function get_thsat_cch - + ! ===================================================================================== - + function th_from_psi_cch(this,psi) result(th) class(wrf_type_cch) :: this @@ -813,7 +813,7 @@ subroutine set_wrf_param_tfs(this,params_in) this%pmedia = int(params_in(9)) call this%set_min_max(this%th_res,this%th_sat) - + return end subroutine set_wrf_param_tfs @@ -822,13 +822,13 @@ end subroutine set_wrf_param_tfs function get_thsat_tfs(this) result(th_sat) class(wrf_type_tfs) :: this real(r8) :: th_sat - + th_sat = this%th_sat - + end function get_thsat_tfs - + ! ===================================================================================== - + function th_from_psi_tfs(this,psi) result(th) class(wrf_type_tfs) :: this @@ -907,43 +907,43 @@ function psi_from_th_tfs(this,th) result(psi) else th_corr = th * this%cap_corr - + ! Perform two rounds of quadratic smoothing, 1st smooth ! the elastic and capilary, and then smooth their ! combined with the caviation - + call solutepsi(th_corr,this%rwc_ft,this%th_sat,this%th_res,this%pinot,psi_sol) call pressurepsi(th_corr,this%rwc_ft,this%th_sat,this%th_res,this%pinot,this%epsil,psi_press) - + psi_elastic = psi_sol + psi_press - + if(this%pmedia == 1) then ! leaves have no capillary region in their PV curves - + psi_capelast = psi_elastic - + else if(this%pmedia <= 4) then ! sapwood has a capillary region - + call capillarypsi(th_corr,this%th_sat,this%cap_int,this%cap_slp,psi_capillary) - + b = -1._r8*(psi_capillary + psi_elastic) c = psi_capillary*psi_elastic psi_capelast = (-b - sqrt(b*b - 4._r8*quad_a1*c))/(2._r8*quad_a1) - + else write(fates_log(),*) 'TFS WRF was called for an inelligable porous media' call endrun(msg=errMsg(sourcefile, __LINE__)) - + end if !porous media - + ! Now lets smooth the result of capilary elastic with cavitation - + psi_cavitation = psi_sol b = -1._r8*(psi_capelast + psi_cavitation) c = psi_capelast*psi_cavitation - + psi = (-b + sqrt(b*b - 4._r8*quad_a2*c))/(2._r8*quad_a2) end if - + return end function psi_from_th_tfs @@ -983,62 +983,62 @@ function dpsidth_from_th_tfs(this,th) result(dpsidth) else th_corr = th*this%cap_corr - + ! Perform two rounds of quadratic smoothing, 1st smooth ! the elastic and capilary, and then smooth their ! combined with the caviation - + call solutepsi(th_corr,this%rwc_ft,this%th_sat,this%th_res,this%pinot,psi_sol) call pressurepsi(th_corr,this%rwc_ft,this%th_sat,this%th_res,this%pinot,this%epsil,psi_press) - + call dsolutepsidth(th,this%th_sat,this%th_res,this%rwc_ft,this%pinot,dsol_dth) call dpressurepsidth(this%th_sat,this%th_res,this%rwc_ft,this%epsil,dpress_dth) - + delast_dth = dsol_dth + dpress_dth psi_elastic = psi_sol + psi_press - - + + if(this%pmedia == 1) then ! leaves have no capillary region in their PV curves - + psi_capelast = psi_elastic dcapelast_dth = delast_dth - + else if(this%pmedia <= 4) then ! sapwood has a capillary region - + call capillarypsi(th,this%th_sat,this%cap_int,this%cap_slp,psi_capillary) - + b = -1._r8*(psi_capillary + psi_elastic) c = psi_capillary*psi_elastic psi_capelast = (-b - sqrt(b*b - 4._r8*quad_a1*c))/(2._r8*quad_a1) - + call dcapillarypsidth(this%cap_slp,this%th_sat,dcap_dth) - + dbdth = -1._r8*(delast_dth + dcap_dth) dcdth = psi_elastic*dcap_dth + delast_dth*psi_capillary - - + + dcapelast_dth = 1._r8/(2._r8*quad_a1) * & (-dbdth - 0.5_r8*((b*b - 4._r8*quad_a1*c)**(-0.5_r8)) * & (2._r8*b*dbdth - 4._r8*quad_a1*dcdth)) - + else write(fates_log(),*) 'TFS WRF was called for an ineligible porous media' call endrun(msg=errMsg(sourcefile, __LINE__)) - + end if !porous media - + ! Now lets smooth the result of capilary elastic with cavitation - + psi_cavitation = psi_sol - + b = -1._r8*(psi_capelast + psi_cavitation) c = psi_capelast*psi_cavitation - + dcav_dth = dsol_dth - + dbdth = -1._r8*(dcapelast_dth + dcav_dth) dcdth = psi_capelast*dcav_dth + dcapelast_dth*psi_cavitation - + dpsidth = 1._r8/(2._r8*quad_a2)*(-dbdth + 0.5_r8*((b*b - 4._r8*quad_a2*c)**(-0.5_r8)) * & (2._r8*b*dbdth - 4._r8*quad_a2*dcdth)) end if @@ -1055,7 +1055,7 @@ function ftc_from_psi_tfs(this,psi) result(ftc) real(r8) :: ftc real(r8) :: psi_eff - psi_eff = min(0._r8,psi) + psi_eff = min(-nearzero,psi) ftc = max(min_ftc,1._r8/(1._r8 + (psi_eff/this%p50)**this%avuln)) @@ -1119,7 +1119,7 @@ subroutine solutepsi(th,rwc_ft,th_sat,th_res,pinot,psi) ! = pino * (rwc_ft - th_res/th_sat)/(th/th_sat - th_res/th_sat ) ! = pino * (th_sat*rwc_ft - th_res)/(th - th_res) ! ----------------------------------------------------------------------------------- - + psi = pinot * (th_sat*rwc_ft - th_res) / (th - th_res) return @@ -1147,7 +1147,7 @@ subroutine dsolutepsidth(th,th_sat,th_res,rwc_ft,pinot,dpsi_dth) ! psi = pinot * (th_sat*rwc_ft - th_res) * (th - th_res)^-1 ! dpsi_dth = -pinot * (th_sat*rwc_ft - th_res) * (th - th_res)^-2 ! ----------------------------------------------------------------------------------- - + dpsi_dth = -1._r8*pinot*(th_sat*rwc_ft - th_res )*(th - th_res)**(-2._r8) return @@ -1236,7 +1236,7 @@ subroutine dcapillarypsidth(cap_slp,th_sat,y) end subroutine dcapillarypsidth ! ===================================================================================== - + subroutine bisect_pv(this,lower, upper, psi, th) ! ! !DESCRIPTION: Bisection routine for getting the inverse of the plant PV curve. From d4e35f06ac27d5be5312937519b681cb4354eddc Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 6 Oct 2021 13:41:20 -0400 Subject: [PATCH 416/578] Encapsulating all write/print statements to logging in either a debug clause, or ensuring there is an endrun following. --- biogeochem/EDCanopyStructureMod.F90 | 9 +- biogeochem/EDCohortDynamicsMod.F90 | 13 +- biogeochem/EDLoggingMortalityMod.F90 | 3 +- biogeochem/EDMortalityFunctionsMod.F90 | 10 +- biogeochem/EDPatchDynamicsMod.F90 | 11 +- biogeochem/EDPhysiologyMod.F90 | 9 - biogeochem/FatesAllometryMod.F90 | 9 +- biogeophys/EDAccumulateFluxesMod.F90 | 4 +- biogeophys/EDBtranMod.F90 | 10 +- biogeophys/EDSurfaceAlbedoMod.F90 | 139 +++++++------ biogeophys/FatesPlantHydraulicsMod.F90 | 33 ++-- biogeophys/FatesPlantRespPhotosynthMod.F90 | 1 + fire/SFMainMod.F90 | 12 +- main/EDInitMod.F90 | 8 +- main/EDMainMod.F90 | 2 + main/EDPftvarcon.F90 | 2 +- main/FatesHistoryInterfaceMod.F90 | 15 +- main/FatesHistoryVariableType.F90 | 15 +- main/FatesIOVariableKindMod.F90 | 8 +- main/FatesInterfaceMod.F90 | 214 ++++++--------------- main/FatesInventoryInitMod.F90 | 10 +- main/FatesParametersInterface.F90 | 1 - main/FatesRestartInterfaceMod.F90 | 3 +- main/FatesRestartVariableType.F90 | 14 +- parteh/PRTParamsFATESMod.F90 | 2 + 25 files changed, 257 insertions(+), 300 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 08e6c0513f..01cc0d32e5 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1930,7 +1930,10 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ifp = ifp+1 if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then - write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area + if(debug)then + write(fates_log(),*) 'ED: canopy area bigger than area', & + currentPatch%total_canopy_area ,currentPatch%area + end if currentPatch%total_canopy_area = currentPatch%area endif @@ -2219,7 +2222,9 @@ function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) res if(arealayer > currentPatch%area)then z = z + 1 if(hlm_use_sp.eq.itrue)then - write(fates_log(),*) 'SPmode, canopy_layer full:',arealayer,currentPatch%area + if(debug)then + write(fates_log(),*) 'SPmode, canopy_layer full:',arealayer,currentPatch%area + end if end if endif diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 2fa98aa59f..420e7c92ad 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1537,7 +1537,6 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) !---------------------------------------------------------------------! dynamic_size_fusion_tolerance = dynamic_size_fusion_tolerance * 1.1_r8 dynamic_age_fusion_tolerance = dynamic_age_fusion_tolerance * 1.1_r8 - !write(fates_log(),*) 'maxcohorts exceeded',dynamic_fusion_tolerance else @@ -1552,7 +1551,6 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) ! Making profile tolerance larger means that more fusion will happen ! !---------------------------------------------------------------------! dynamic_size_fusion_tolerance = dynamic_size_fusion_tolerance * 1.1_r8 - !write(fates_log(),*) 'maxcohorts exceeded',dynamic_fusion_tolerance else @@ -1931,10 +1929,13 @@ subroutine count_cohorts( currentPatch ) currentCohort => currentCohort%shorter enddo - if (backcount /= currentPatch%countcohorts) then - write(fates_log(),*) 'problem with linked list, not symmetrical' - endif - + if(debug) then + if (backcount /= currentPatch%countcohorts) then + write(fates_log(),*) 'problem with linked list, not symmetrical' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + end if + end subroutine count_cohorts ! =================================================================================== diff --git a/biogeochem/EDLoggingMortalityMod.F90 b/biogeochem/EDLoggingMortalityMod.F90 index f1f23d9f33..52178f46cf 100644 --- a/biogeochem/EDLoggingMortalityMod.F90 +++ b/biogeochem/EDLoggingMortalityMod.F90 @@ -73,7 +73,8 @@ module EDLoggingMortalityMod logical, protected :: logging_time ! If true, logging should be ! performed during the current time-step - + logical, parameter :: debug = .false. + ! harvest litter localization specifies how much of the litter from a falling ! tree lands within the newly generated patch, and how much lands outside of ! the new patch, and thus in the original patch. By setting this to zero, diff --git a/biogeochem/EDMortalityFunctionsMod.F90 b/biogeochem/EDMortalityFunctionsMod.F90 index 6eb5ec3097..ca4b3a5dad 100644 --- a/biogeochem/EDMortalityFunctionsMod.F90 +++ b/biogeochem/EDMortalityFunctionsMod.F90 @@ -6,6 +6,8 @@ module EDMortalityFunctionsMod use FatesConstantsMod , only : r8 => fates_r8 use FatesGlobals , only : fates_log + use FatesGlobals , only : endrun => fates_endrun + use FatesGlobals , only : fates_log use EDPftvarcon , only : EDPftvarcon_inst use EDTypesMod , only : ed_cohort_type use EDTypesMod , only : ed_site_type @@ -22,10 +24,15 @@ module EDMortalityFunctionsMod use PRTGenericMod, only : all_carbon_elements use PRTGenericMod, only : store_organ - + use shr_log_mod , only : errMsg => shr_log_errMsg + implicit none private + + logical, parameter :: debug = .false. + character(len=*), parameter, private :: sourcefile = & + __FILE__ public :: mortality_rates public :: Mortality_Derivative @@ -164,6 +171,7 @@ subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort,smort,asmor else write(fates_log(),*) 'dbh problem in mortality_rates', & cohort_in%dbh,cohort_in%pft,cohort_in%n,cohort_in%canopy_layer + call endrun(msg=errMsg(sourcefile, __LINE__)) endif !-------------------------------------------------------------------------------- ! Mortality due to cold and freezing stress (frmort), based on ED2 and: diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index c08e93565e..fda538e36e 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -335,8 +335,8 @@ subroutine disturbance_rates( site_in, bc_in) ! Fires can't burn the whole patch, as this causes /0 errors. if (debug) then if (currentPatch%disturbance_rates(dtype_ifire) > 0.98_r8)then - write(fates_log(),*) 'very high fire areas', & - currentPatch%disturbance_rates(dtype_ifire),currentPatch%frac_burnt + write(fates_log(),*) 'very high fire areas', & + currentPatch%disturbance_rates(dtype_ifire),currentPatch%frac_burnt endif endif @@ -2295,7 +2295,8 @@ subroutine fuse_patches( csite, bc_in ) do while(associated(tpp)) if(.not.associated(currentPatch))then - write(fates_log(),*) 'ED: issue with currentPatch' + write(fates_log(),*) 'FATES fuse_patches(): currentPatch is not associated?' + call endrun(msg=errMsg(sourcefile, __LINE__)) endif if(associated(tpp).and.associated(currentPatch))then @@ -2414,9 +2415,7 @@ subroutine fuse_patches( csite, bc_in ) !------------------------------------------------------------------------! profiletol = ED_val_patch_fusion_tol - - else - ! write(fates_log(),*) 'patches not fused' + endif endif !are both patches the same anthropogenic disturbance category as the disturbance type loop iterator? endif !are both patches associated? diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 859f6e3534..1ca5b06546 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -590,11 +590,6 @@ subroutine trim_canopy( currentSite ) ! Make sure the cohort trim fraction is great than the pft trim limit if (currentCohort%canopy_trim > EDPftvarcon_inst%trim_limit(ipft)) then - ! if ( debug ) then - ! write(fates_log(),*) 'trimming leaves', & - ! currentCohort%canopy_trim,currentCohort%leaf_cost - ! endif - ! keep trimming until none of the canopy is in negative carbon balance. if (currentCohort%hite > EDPftvarcon_inst%hgt_min(ipft)) then currentCohort%canopy_trim = currentCohort%canopy_trim - & @@ -620,10 +615,6 @@ subroutine trim_canopy( currentSite ) call dgels(trans, m, n, nrhs, nnu_clai_a, lda, nnu_clai_b, ldb, work, lwork, info) lwork = int(work(1)) ! Pick the optimum. TBD, can work(1) come back with greater than work size? - ! if (debug) then - ! write(fates_log(),*) 'LLSF lwork output (info, lwork):', info, lwork - ! endif - ! Compute the minimum of 2-norm of of the least squares fit to solve for X ! Note that dgels returns the solution by overwriting the nnu_clai_b array. ! The result has the form: X = [b; m] diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index e47934715d..396cee9a60 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -2448,9 +2448,12 @@ subroutine ForceDBH( ipft, canopy_trim, d, h, bdead, bl ) end if call h_allom(d,ipft,h) - if(counter>10)then - write(fates_log(),*) 'dbh counter: ',counter,' is woody: ',& - int(prt_params%woody(ipft))==itrue + + if(debug) then + if(counter>10)then + write(fates_log(),*) 'dbh counter: ',counter,' is woody: ',& + int(prt_params%woody(ipft))==itrue + end if end if diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index a0fe4dd7df..090b7848b0 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -9,11 +9,11 @@ module EDAccumulateFluxesMod ! Rosie Fisher. March 2014. ! ! !USES: - use FatesGlobals, only : fates_endrun + use FatesGlobals, only : endrun => fates_endrun use FatesGlobals, only : fates_log use shr_log_mod , only : errMsg => shr_log_errMsg use FatesConstantsMod , only : r8 => fates_r8 - + use shr_log_mod , only : errMsg => shr_log_errMsg implicit none private diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index e36642447e..52577b1b92 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -19,11 +19,16 @@ module EDBtranMod use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesGlobals , only : fates_log use FatesAllometryMod , only : set_root_fraction + use shr_log_mod , only : errMsg => shr_log_errMsg + use FatesGlobals, only : endrun => fates_endrun ! implicit none private + + logical, parameter :: debug = .false. + public :: btran_ed public :: get_active_suction_layers public :: check_layer_water @@ -231,10 +236,13 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) temprootr = sum(bc_out(s)%rootr_pasl(ifp,1:bc_in(s)%nlevsoil)) if(abs(1.0_r8-temprootr) > 1.0e-10_r8 .and. temprootr > 1.0e-10_r8)then - write(fates_log(),*) 'error with rootr in canopy fluxes',temprootr,sum_pftgs + + if(debug) write(fates_log(),*) 'error with rootr in canopy fluxes',temprootr,sum_pftgs + do j = 1,bc_in(s)%nlevsoil bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j)/temprootr enddo + end if endif ! not bare ground cpatch => cpatch%younger diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index ebc01b1b69..b77f87b95d 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -44,7 +44,8 @@ module EDSurfaceRadiationMod public :: ED_SunShadeFracs logical :: debug = .false. ! for debugging this module - + character(len=*), parameter, private :: sourcefile = & + __FILE__ real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) (/ 0.80_r8, 0.55_r8 /) @@ -339,13 +340,16 @@ subroutine PatchNormanRadiation (currentPatch, & end do !iv end do !ft1 end do !L - if (sum(ftweight(1,:,1))<0.999_r8)then - write(fates_log(),*) 'canopy not full',ftweight(1,:,1) - endif - if (sum(ftweight(1,:,1))>1.0001_r8)then - write(fates_log(),*) 'canopy too full',ftweight(1,:,1) - endif + if(debug)then + if (sum(ftweight(1,:,1))<0.999_r8)then + write(fates_log(),*) 'canopy not full',ftweight(1,:,1) + endif + if (sum(ftweight(1,:,1))>1.0001_r8)then + write(fates_log(),*) 'canopy too full',ftweight(1,:,1) + endif + end if + do L = 1,currentPatch%NCL_p !start at the top canopy layer (1 is the top layer.) weighted_dir_tr(L) = 0.0_r8 @@ -397,11 +401,13 @@ subroutine PatchNormanRadiation (currentPatch, & !where there is a partly empty leaf layer, some fluxes go straight through. lai_change(L,ft,iv) = ftweight(L,ft,iv)-ftweight(L,ft,iv+1) endif - if (ftweight(L,ft,iv+1) - ftweight(L,ft,iv) > 1.e-10_r8)then - write(fates_log(),*) 'lower layer has more coverage. This is wrong' , & - ftweight(L,ft,iv),ftweight(L,ft,iv+1),ftweight(L,ft,iv+1)-ftweight(L,ft,iv) - endif - + if(debug)then + if (ftweight(L,ft,iv+1) - ftweight(L,ft,iv) > 1.e-10_r8)then + write(fates_log(),*) 'lower layer has more coverage. This is wrong' , & + ftweight(L,ft,iv),ftweight(L,ft,iv+1),ftweight(L,ft,iv+1)-ftweight(L,ft,iv) + endif + end if + !n.b. in theory lai_change could be calculated daily in the ED code. !This is light coming striaght through the canopy. if (L==1)then @@ -922,26 +928,30 @@ subroutine PatchNormanRadiation (currentPatch, & error = abs(currentPatch%sabs_dir(ib) - (currentPatch%tr_soil_dir(ib) * & (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + & currentPatch%tr_soil_dir_dif(ib) * (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) - if ( abs(error) > 0.0001)then - write(fates_log(),*)'dir ground absorption error',error,currentPatch%sabs_dir(ib), & - currentPatch%tr_soil_dir(ib)* & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) - write(fates_log(),*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ) - - do ft =1,3 - iv = currentPatch%nrad(1,ft) + 1 - write(fates_log(),*) 'abs soil fluxes', Abs_dir_z(ft,iv),Abs_dif_z(ft,iv) - end do + if(debug)then + if ( abs(error) > 0.0001)then + write(fates_log(),*)'dir ground absorption error',error,currentPatch%sabs_dir(ib), & + currentPatch%tr_soil_dir(ib)* & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) + write(fates_log(),*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + do ft =1,numpft + iv = currentPatch%nrad(1,ft) + 1 + write(fates_log(),*) 'abs soil fluxes', Abs_dir_z(ft,iv),Abs_dif_z(ft,iv) + end do + end if end if + else - if ( abs(currentPatch%sabs_dif(ib)-(currentPatch%tr_soil_dif(ib) * & - (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) > 0.0001_r8)then - write(fates_log(),*)'dif ground absorption error',currentPatch%sabs_dif(ib) , & - (currentPatch%tr_soil_dif(ib)* & - (1.0_r8-currentPatch%gnd_alb_dif(ib) )),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) - endif + if (debug) then + if ( abs(currentPatch%sabs_dif(ib)-(currentPatch%tr_soil_dif(ib) * & + (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) > 0.0001_r8)then + write(fates_log(),*)'dif ground absorption error',currentPatch%sabs_dif(ib) , & + (currentPatch%tr_soil_dif(ib)* & + (1.0_r8-currentPatch%gnd_alb_dif(ib) )),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) + endif + end if endif if (radtype == idirect)then @@ -976,17 +986,19 @@ subroutine PatchNormanRadiation (currentPatch, & ! to the complexity of this code, but where the system generates occasional errors, we ! will deal with them for now. end if + if (abs(error) > 0.15_r8)then - write(fates_log(),*) 'Large Dir Radn consvn error',error ,ib - write(fates_log(),*) 'diags', albd_parb_out(ib), ftdd_parb_out(ib), & - ftid_parb_out(ib), fabd_parb_out(ib) - write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno - write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) - + if(debug)then + write(fates_log(),*) 'Large Dir Radn consvn error',error ,ib + write(fates_log(),*) 'diags', albd_parb_out(ib), ftdd_parb_out(ib), & + ftid_parb_out(ib), fabd_parb_out(ib) + write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) + end if albd_parb_out(ib) = albd_parb_out(ib) + error end if else @@ -996,20 +1008,21 @@ subroutine PatchNormanRadiation (currentPatch, & end if if (abs(error) > 0.15_r8)then - write(fates_log(),*) '>5% Dif Radn consvn error',error ,ib - write(fates_log(),*) 'diags', albi_parb_out(ib), ftii_parb_out(ib), & - fabi_parb_out(ib) - write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno - write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) - write(fates_log(),*) 'rhol',rhol(1:numpft,:) - write(fates_log(),*) 'ftw',sum(ftweight(1,1:numpft,1)),ftweight(1,1:numpft,1) - write(fates_log(),*) 'present',currentPatch%canopy_mask(1,1:numpft) - write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:numpft,1) - + if(debug)then + write(fates_log(),*) '>5% Dif Radn consvn error',error ,ib + write(fates_log(),*) 'diags', albi_parb_out(ib), ftii_parb_out(ib), & + fabi_parb_out(ib) + write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) + write(fates_log(),*) 'rhol',rhol(1:numpft,:) + write(fates_log(),*) 'ftw',sum(ftweight(1,1:numpft,1)),ftweight(1,1:numpft,1) + write(fates_log(),*) 'present',currentPatch%canopy_mask(1,1:numpft) + write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:numpft,1) + end if albi_parb_out(ib) = albi_parb_out(ib) + error end if @@ -1021,10 +1034,12 @@ subroutine PatchNormanRadiation (currentPatch, & (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) endif - if (abs(error) > 0.00000001_r8)then - write(fates_log(),*) 'there is still error after correction',error ,ib + if(debug) then + if (abs(error) > 0.00000001_r8)then + write(fates_log(),*) 'there is still error after correction',error ,ib + end if end if - + end if end do !hlm_numSWb @@ -1132,11 +1147,13 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) bc_out(s)%fsun_pa(ifp) = 0._r8 endif - if(bc_out(s)%fsun_pa(ifp) > 1._r8)then - write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & - sunlai,shalai - endif - + if(debug)then + if(bc_out(s)%fsun_pa(ifp) > 1._r8)then + write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & + sunlai,shalai + endif + end if + elai = calc_areaindex(cpatch,'elai') bc_out(s)%laisun_pa(ifp) = elai*bc_out(s)%fsun_pa(ifp) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 98aaad6488..de3953a46a 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -2682,16 +2682,17 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) wb_check_site = delta_plant_storage+delta_soil_storage+site_runoff+transp_flux ! Now check on total error - if( abs(wb_check_site) > 1.e-4_r8 ) then - write(fates_log(),*) 'FATES hydro water balance is not so great [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 + if(debug)then + if( abs(wb_check_site) > 1.e-4_r8 ) then + write(fates_log(),*) 'FATES hydro water balance is not so great [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 end if - site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + site_hydr%errh2o_hyd @@ -3868,10 +3869,6 @@ subroutine Report1DError(cohort, site_hydr, ilayer, z_node, v_node, & write(fates_log(),*) 'inner shell kmaxs: ',site_hydr%kmax_lower_shell(:,1)*aroot_frac_plant - - - - deallocate(psi_node) deallocate(h_node) @@ -4897,7 +4894,9 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & enddo if ( nwtn_iter > max_newton_iter) then icnv = icnv_fail_round - write(fates_log(),*) 'Newton hydraulics solve failed',residual_amax,nsd,tm + if(debug)then + write(fates_log(),*) 'Newton hydraulics solve failed',residual_amax,nsd,tm + end if endif ! Three scenarios: @@ -5089,10 +5088,12 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & end do outerloop - if(cohort_hydr%iterh1>1._r8) then - write(fates_log(),*) "hydro solve info: i1: ",cohort_hydr%iterh1,"i2: ",cohort_hydr%iterh2 + if(debug)then + if(cohort_hydr%iterh1>1._r8) then + write(fates_log(),*) "hydro solve info: i1: ",cohort_hydr%iterh1,"i2: ",cohort_hydr%iterh2 + end if end if - + ! Save flux diagnostics ! ------------------------------------------------------ diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 4ff827443b..c58205d89e 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -1212,6 +1212,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then write (fates_log(),*) 'Stomatal model error check - stomatal conductance error:' write (fates_log(),*) gs_mol, gs_mol_err + call endrun(msg=errMsg(sourcefile, __LINE__)) end if enddo !sunsha loop diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 127dfa43f9..0b367b862d 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -65,8 +65,8 @@ module SFMainMod ! The following parameter represents one of the values of hlm_spitfire_mode ! and more of these appear in subroutine area_burnt_intensity below ! NB. The same parameters are set in /src/biogeochem/CNFireFactoryMod - integer :: write_SF = 0 ! for debugging - logical :: debug = .false. ! for debugging + integer :: write_SF = ifalse ! for debugging + logical :: debug = .false. ! for debugging ! ============================================================================ ! ============================================================================ @@ -94,7 +94,7 @@ subroutine fire_model( currentSite, bc_in) currentPatch => currentPatch%older enddo - if(write_SF==1)then + if(write_SF==itrue)then write(fates_log(),*) 'spitfire_mode', hlm_spitfire_mode endif @@ -303,8 +303,10 @@ subroutine charecteristics_of_fuel ( currentSite ) endif currentPatch%fuel_sav = sum(SF_val_SAV(1:nfsc))/(nfsc) ! make average sav to avoid crashing code. - if ( hlm_masterproc == itrue ) write(fates_log(),*) 'problem with spitfire fuel averaging' - + if ( hlm_masterproc == itrue .and. write_SF == itrue)then + write(fates_log(),*) 'problem with spitfire fuel averaging' + end if + ! FIX(SPM,032414) refactor...should not have 0 fuel unless everything is burnt ! off. currentPatch%fuel_eff_moist = 0.0000000001_r8 diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index c3b503a729..35cf871b75 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -333,7 +333,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) do ft = 1,numpft if(sites(s)%area_pft(ft).lt.0.01_r8.and.sites(s)%area_pft(ft).gt.0.0_r8)then - write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) + if(debug) write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) sites(s)%area_pft(ft)=0.0_r8 ! remove tiny patches to prevent numerical errors in terminate patches endif @@ -581,13 +581,13 @@ subroutine init_patches( nsites, sites, bc_in) ! remove or add extra area ! if the oldest patch has enough area, use that sites(s)%oldest_patch%area = sites(s)%oldest_patch%area - (tota-area) - write(*,*) 'fixing patch precision - oldest',s, tota-area + if(debug) write(fates_log(),*) 'fixing patch precision - oldest',s, tota-area else ! or otherwise take the area from the youngest patch. sites(s)%youngest_patch%area = sites(s)%oldest_patch%area - (tota-area) - write(*,*) 'fixing patch precision -youngest ',s, tota-area + if(debug) write(fates_log(),*) 'fixing patch precision -youngest ',s, tota-area endif else !this is a big error not just a precision error. - write(*,*) 'issue with patch area in EDinit',tota-area,tota + write(fates_log(),*) 'issue with patch area in EDinit',tota-area,tota call endrun(msg=errMsg(sourcefile, __LINE__)) endif ! big error end if ! too much patch area diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 48820e5ad6..219e5a1e3c 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -349,6 +349,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) if( currentPatch%age < 0._r8 )then write(fates_log(),*) 'negative patch age?',currentPatch%age, & currentPatch%patchno,currentPatch%area + call endrun(msg=errMsg(sourcefile, __LINE__)) endif ! add age increment to secondary forest patches as well @@ -560,6 +561,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) currentCohort%coage = currentCohort%coage + hlm_freq_day if(currentCohort%coage < 0.0_r8)then write(fates_log(),*) 'negative cohort age?',currentCohort%coage + call endrun(msg=errMsg(sourcefile, __LINE__)) end if ! update cohort age class and age x pft class diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index c89e63df98..eeea523f79 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -1442,7 +1442,7 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'phen_cold_size_threshold = ',EDPftvarcon_inst%phen_cold_size_threshold write(fates_log(),fmt0) 'phen_stem_drop_fraction',EDpftvarcon_inst%phen_stem_drop_fraction write(fates_log(),fmt0) 'fire_alpha_SH = ',EDPftvarcon_inst%fire_alpha_SH - write(fates_log(),fmt0) 'allom_frbstor_repro = ',EDPftvarcon_inst%allom_frbstor_repro + write(fates_log(),fmt0) 'allom_frbstor_repro = ',EDPftvarcon_inst%allom_frbstor_repro write(fates_log(),fmt0) 'hydr_p_taper = ',EDPftvarcon_inst%hydr_p_taper write(fates_log(),fmt0) 'hydr_rs2 = ',EDPftvarcon_inst%hydr_rs2 write(fates_log(),fmt0) 'hydr_srl = ',EDPftvarcon_inst%hydr_srl diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 97f3342b43..94f9e9c25d 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1123,8 +1123,7 @@ subroutine set_dim_indices(this, dk_name, idim, dim_index) write(fates_log(), *) 'Trying to define dimension size to a dim-type structure' write(fates_log(), *) 'but the dimension index does not exist' write(fates_log(), *) 'type: ',dk_name,' ndims: ',this%dim_kinds(ityp)%ndims,' input dim:',idim - stop - !end_run + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if (idim == 1) then @@ -2236,11 +2235,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_leaf_height_dist_si_height(io_si,i_heightbin) = & hio_leaf_height_dist_si_height(io_si,i_heightbin) + & ccohort%c_area * AREA_INV * ccohort%treelai * frac_canopy_in_bin - - ! if ( ( ccohort%c_area * AREA_INV * ccohort%treelai * frac_canopy_in_bin) .lt. 0._r8) then - ! write(fates_log(),*) ' negative hio_leaf_height_dist_si_height:' - ! write(fates_log(),*) ' c_area, treelai, frac_canopy_in_bin:', ccohort%c_area, ccohort%treelai, frac_canopy_in_bin - ! endif end do if (ccohort%canopy_layer .eq. 1) then @@ -4132,11 +4126,8 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) end if if(print_iterations) then -! print*,' Mean solves: ',sum(hio_iterh2_scpf(io_si,:))/real(count(ncohort_scpf(:)>0._r8),r8), & -! ' Mean failures: ',sum(hio_iterh1_scpf(io_si,:))/real(count(ncohort_scpf(:)>0._r8),r8) - write(fmt_char,'(I2)') iterh2_nhist - write(fates_log(),fmt='(A,'//fmt_char//'I5)') 'Solves: ',int(iterh2_histy(:)) - !write(*,*) 'Histogram: ',int(iterh2_histy(:)) + write(fmt_char,'(I2)') iterh2_nhist + write(fates_log(),fmt='(A,'//fmt_char//'I5)') 'Solves: ',int(iterh2_histy(:)) end if diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 index 6457e644f1..75a6d30f3f 100644 --- a/main/FatesHistoryVariableType.F90 +++ b/main/FatesHistoryVariableType.F90 @@ -1,7 +1,8 @@ module FatesHistoryVariableType use FatesConstantsMod, only : r8 => fates_r8 - use FatesGlobals, only : fates_log + use FatesGlobals, only : fates_log + use FatesGlobals , only : endrun => fates_endrun use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : fates_io_variable_kind_type use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 @@ -15,12 +16,16 @@ module FatesHistoryVariableType use FatesIOVariableKindMod, only : site_elem_r8, site_elpft_r8 use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8 use FatesIOVariableKindMod, only : iotype_index, site_agefuel_r8 - + use shr_log_mod , only : errMsg => shr_log_errMsg + implicit none private ! By default everything is private ! Make public necessary subroutines and functions + + character(len=*), parameter, private :: sourcefile = & + __FILE__ ! This type is instanteated in the HLM-FATES interface (clmfates_interfaceMod.F90) @@ -208,8 +213,7 @@ subroutine Init(this, vname, units, long, use_default, & case default write(fates_log(),*) 'Incompatible vtype passed to set_history_var' write(fates_log(),*) 'vtype = ',trim(vtype),' ?' - stop - ! end_run + call endrun(msg=errMsg(sourcefile, __LINE__)) end select end subroutine Init @@ -336,8 +340,7 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case default write(fates_log(),*) 'fates history variable type undefined while flushing history variables' - stop - !end_run + call endrun(msg=errMsg(sourcefile, __LINE__)) end select end subroutine Flush diff --git a/main/FatesIOVariableKindMod.F90 b/main/FatesIOVariableKindMod.F90 index 93b34ebab3..02eb39f594 100644 --- a/main/FatesIOVariableKindMod.F90 +++ b/main/FatesIOVariableKindMod.F90 @@ -3,10 +3,16 @@ module FatesIOVariableKindMod use FatesConstantsMod, only : fates_long_string_length use FatesGlobals, only : fates_log use FatesIODimensionsMod, only : fates_io_dimension_type + use FatesGlobals , only : endrun => fates_endrun + use shr_log_mod , only : errMsg => shr_log_errMsg + implicit none private + character(len=*), parameter, private :: sourcefile = & + __FILE__ + ! FIXME(bja, 2016-10) do these need to be strings, or can they be integer enumerations? ! FIXME(rgk, 2016-11) these should probably be moved to varkindmod? @@ -122,7 +128,7 @@ function iotype_index(iotype_name, num_dim_kinds, dim_kinds) result(dk_index) end if end do write(fates_log(),*) 'An IOTYPE THAT DOESNT EXIST WAS SPECIFIED' - !end_run + call endrun(msg=errMsg(sourcefile, __LINE__)) end function iotype_index diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 5561a78f52..bc7cb4e7ea 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1251,36 +1251,28 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) case('check_allset') if(hlm_numSWb .eq. unset_int) then - if (fates_global_verbose()) then - write(fates_log(), *) 'FATES dimension/parameter unset: num_sw_rad_bbands' - end if + write(fates_log(), *) 'FATES dimension/parameter unset: num_sw_rad_bbands' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_masterproc .eq. unset_int) then - if (fates_global_verbose()) then - write(fates_log(), *) 'FATES parameter unset: hlm_masterproc' - end if + write(fates_log(), *) 'FATES parameter unset: hlm_masterproc' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_numSWb > maxSWb) then - if (fates_global_verbose()) then - write(fates_log(), *) 'FATES sets a maximum number of shortwave bands' - write(fates_log(), *) 'for some scratch-space, maxSWb' - write(fates_log(), *) 'it defaults to 2, but can be increased as needed' - write(fates_log(), *) 'your driver or host model is intending to drive' - write(fates_log(), *) 'FATES with:',hlm_numSWb,' bands.' - write(fates_log(), *) 'please increase maxSWb in EDTypes to match' - write(fates_log(), *) 'or exceed this value' - end if + write(fates_log(), *) 'FATES sets a maximum number of shortwave bands' + write(fates_log(), *) 'for some scratch-space, maxSWb' + write(fates_log(), *) 'it defaults to 2, but can be increased as needed' + write(fates_log(), *) 'your driver or host model is intending to drive' + write(fates_log(), *) 'FATES with:',hlm_numSWb,' bands.' + write(fates_log(), *) 'please increase maxSWb in EDTypes to match' + write(fates_log(), *) 'or exceed this value' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if ( .not.((hlm_use_planthydro.eq.1).or.(hlm_use_planthydro.eq.0)) ) then - if (fates_global_verbose()) then - write(fates_log(), *) 'The FATES namelist planthydro flag must be 0 or 1, exiting' - end if + write(fates_log(), *) 'The FATES namelist planthydro flag must be 0 or 1, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) elseif (hlm_use_planthydro.eq.1 ) then write(fates_log(), *) '!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!' @@ -1293,30 +1285,23 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) end if if ( (hlm_use_lu_harvest .lt. 0).or.(hlm_use_lu_harvest .gt. 1) ) then - if (fates_global_verbose()) then - write(fates_log(), *) 'The FATES lu_harvest flag must be 0 or 1, exiting' - end if + write(fates_log(), *) 'The FATES lu_harvest flag must be 0 or 1, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if ( (hlm_num_lu_harvest_cats .lt. 0) ) then - if (fates_global_verbose()) then - write(fates_log(), *) 'The FATES number of hlm harvest cats must be >= 0, exiting' - end if + write(fates_log(), *) 'The FATES number of hlm harvest cats must be >= 0, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if ( .not.((hlm_use_logging .eq.1).or.(hlm_use_logging.eq.0)) ) then - if (fates_global_verbose()) then - write(fates_log(), *) 'The FATES namelist use_logging flag must be 0 or 1, exiting' - end if + write(fates_log(), *) 'The FATES namelist use_logging flag must be 0 or 1, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if ( ( ANY(EDPftvarcon_inst%mort_ip_age_senescence < fates_check_param_set )) .and. & (hlm_use_cohort_age_tracking .eq.0 ) ) then - write(fates_log(),*) 'Age dependent mortality cannot be on if' write(fates_log(),*) 'cohort age tracking is off.' write(fates_log(),*) 'Set hlm_use_cohort_age_tracking = .true.' @@ -1324,191 +1309,136 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if ( .not.((hlm_use_ed_st3.eq.1).or.(hlm_use_ed_st3.eq.0)) ) then - if (fates_global_verbose()) then - write(fates_log(), *) 'The FATES namelist stand structure flag must be 0 or 1, exiting' - end if + write(fates_log(), *) 'The FATES namelist stand structure flag must be 0 or 1, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if ( .not.((hlm_use_ed_prescribed_phys.eq.1).or.(hlm_use_ed_prescribed_phys.eq.0)) ) then - if (fates_global_verbose()) then - write(fates_log(), *) 'The FATES namelist prescribed physiology flag must be 0 or 1, exiting' - end if + write(fates_log(), *) 'The FATES namelist prescribed physiology flag must be 0 or 1, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if ( hlm_use_ed_prescribed_phys.eq.1 .and. hlm_use_ed_st3.eq.1 ) then - if (fates_global_verbose()) then - write(fates_log(), *) 'FATES ST3 and prescribed physiology cannot both be turned on.' - write(fates_log(), *) 'Review the namelist entries, exiting' - end if + write(fates_log(), *) 'FATES ST3 and prescribed physiology cannot both be turned on.' + write(fates_log(), *) 'Review the namelist entries, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if ( hlm_use_inventory_init.eq.1 .and. hlm_use_cohort_age_tracking .eq.1) then - if (fates_global_verbose()) then - write(fates_log(), *) 'Fates inventory init cannot be used with age dependent mortality' - write(fates_log(), *) 'Set hlm_use_cohort_age_tracking to 0 or turn off inventory init' - end if + write(fates_log(), *) 'Fates inventory init cannot be used with age dependent mortality' + write(fates_log(), *) 'Set hlm_use_cohort_age_tracking to 0 or turn off inventory init' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - - if ( .not.((hlm_use_inventory_init.eq.1).or.(hlm_use_inventory_init.eq.0)) ) then - if (fates_global_verbose()) then - write(fates_log(), *) 'The FATES NL inventory flag must be 0 or 1, exiting' - end if + write(fates_log(), *) 'The FATES NL inventory flag must be 0 or 1, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(trim(hlm_inventory_ctrl_file) .eq. 'unset') then - if (fates_global_verbose()) then - write(fates_log(),*) 'namelist entry for fates inventory control file is unset, exiting' - end if + write(fates_log(),*) 'namelist entry for fates inventory control file is unset, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_ivis .ne. ivis) then - if (fates_global_verbose()) then - write(fates_log(), *) 'FATES assumption about the index of visible shortwave' - write(fates_log(), *) 'radiation is different from the HLM, exiting' - end if + write(fates_log(), *) 'FATES assumption about the index of visible shortwave' + write(fates_log(), *) 'radiation is different from the HLM, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_inir .ne. inir) then - if (fates_global_verbose()) then - write(fates_log(), *) 'FATES assumption about the index of NIR shortwave' - write(fates_log(), *) 'radiation is different from the HLM, exiting' - end if + write(fates_log(), *) 'FATES assumption about the index of NIR shortwave' + write(fates_log(), *) 'radiation is different from the HLM, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_is_restart .eq. unset_int) then - if (fates_global_verbose()) then - write(fates_log(), *) 'FATES parameter unset: hlm_is_restart, exiting' - end if + write(fates_log(), *) 'FATES parameter unset: hlm_is_restart, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_numlevgrnd .eq. unset_int) then - if (fates_global_verbose()) then - write(fates_log(), *) 'FATES dimension/parameter unset: numlevground, exiting' - end if + write(fates_log(), *) 'FATES dimension/parameter unset: numlevground, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(trim(hlm_name) .eq. 'unset') then - if (fates_global_verbose()) then - write(fates_log(),*) 'FATES dimension/parameter unset: hlm_name, exiting' - end if + write(fates_log(),*) 'FATES dimension/parameter unset: hlm_name, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(trim(hlm_nu_com) .eq. 'unset') then - if (fates_global_verbose()) then - write(fates_log(),*) 'FATES dimension/parameter unset: hlm_nu_com, exiting' - end if + write(fates_log(),*) 'FATES dimension/parameter unset: hlm_nu_com, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_nitrogen_spec .eq. unset_int) then - if (fates_global_verbose()) then - write(fates_log(),*) 'FATES parameters unset: hlm_nitrogen_spec, exiting' - end if + write(fates_log(),*) 'FATES parameters unset: hlm_nitrogen_spec, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_phosphorus_spec .eq. unset_int) then - if (fates_global_verbose()) then - write(fates_log(),*) 'FATES parameters unset: hlm_phosphorus_spec, exiting' - end if + write(fates_log(),*) 'FATES parameters unset: hlm_phosphorus_spec, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if( abs(hlm_hio_ignore_val-unset_double)<1e-10 ) then - if (fates_global_verbose()) then - write(fates_log(),*) 'FATES dimension/parameter unset: hio_ignore' - end if + write(fates_log(),*) 'FATES dimension/parameter unset: hio_ignore' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_ipedof .eq. unset_int) then - if (fates_global_verbose()) then - write(fates_log(), *) 'index for the HLMs pedotransfer function unset: hlm_ipedof, exiting' - end if + write(fates_log(), *) 'index for the HLMs pedotransfer function unset: hlm_ipedof, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_max_patch_per_site .eq. unset_int ) then - if (fates_global_verbose()) then - write(fates_log(), *) 'the number of patch-space per site unset: hlm_max_patch_per_site, exiting' - end if + write(fates_log(), *) 'the number of patch-space per site unset: hlm_max_patch_per_site, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) elseif(hlm_max_patch_per_site < maxPatchesPerSite ) then - if (fates_global_verbose()) then - write(fates_log(), *) 'FATES is trying to allocate space for more patches per site, than the HLM has space for.' - write(fates_log(), *) 'hlm_max_patch_per_site (HLM side): ', hlm_max_patch_per_site - write(fates_log(), *) 'maxPatchesPerSite (FATES side): ', maxPatchesPerSite - write(fates_log(), *) - end if + write(fates_log(), *) 'FATES is trying to allocate space for more patches per site, than the HLM has space for.' + write(fates_log(), *) 'hlm_max_patch_per_site (HLM side): ', hlm_max_patch_per_site + write(fates_log(), *) 'maxPatchesPerSite (FATES side): ', maxPatchesPerSite + write(fates_log(), *) call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_parteh_mode .eq. unset_int) then - if (fates_global_verbose()) then - write(fates_log(), *) 'switch deciding which plant reactive transport model to use is unset, hlm_parteh_mode, exiting' - end if + write(fates_log(), *) 'switch deciding which plant reactive transport model to use is unset, hlm_parteh_mode, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_use_ch4 .eq. unset_int) then - if (fates_global_verbose()) then - write(fates_log(), *) 'switch for the HLMs CH4 module unset: hlm_use_ch4, exiting' - end if + write(fates_log(), *) 'switch for the HLMs CH4 module unset: hlm_use_ch4, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_use_vertsoilc .eq. unset_int) then - if (fates_global_verbose()) then - write(fates_log(), *) 'switch for the HLMs soil carbon discretization unset: hlm_use_vertsoilc, exiting' - end if + write(fates_log(), *) 'switch for the HLMs soil carbon discretization unset: hlm_use_vertsoilc, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_spitfire_mode .eq. unset_int) then - if (fates_global_verbose()) then - write(fates_log(), *) 'switch for SPITFIRE unset: hlm_spitfire_mode, exiting' - end if + write(fates_log(), *) 'switch for SPITFIRE unset: hlm_spitfire_mode, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_sf_nofire_def .eq. unset_int) then - if (fates_global_verbose()) then - write(fates_log(), *) 'definition of no-fire mode unset: hlm_sf_nofire_def, exiting' - end if + write(fates_log(), *) 'definition of no-fire mode unset: hlm_sf_nofire_def, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_sf_scalar_lightning_def .eq. unset_int) then - if (fates_global_verbose()) then - write(fates_log(), *) 'definition of scalar lightning mode unset: hlm_sf_scalltng_def, exiting' - end if + write(fates_log(), *) 'definition of scalar lightning mode unset: hlm_sf_scalltng_def, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_sf_successful_ignitions_def .eq. unset_int) then - if (fates_global_verbose()) then - write(fates_log(), *) 'definition of successful ignition mode unset: hlm_sf_successful, exiting' - end if + write(fates_log(), *) 'definition of successful ignition mode unset: hlm_sf_successful, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_sf_anthro_ignitions_def .eq. unset_int) then - if (fates_global_verbose()) then - write(fates_log(), *) 'definition of anthro-ignition mode unset: hlm_sf_anthig_def, exiting' - end if + write(fates_log(), *) 'definition of anthro-ignition mode unset: hlm_sf_anthig_def, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1521,33 +1451,24 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if end if - if(hlm_use_fixed_biogeog.eq.unset_int) then - if(fates_global_verbose()) then - write(fates_log(), *) 'switch for fixed biogeog unset: him_use_fixed_biogeog, exiting' - end if - call endrun(msg=errMsg(sourcefile, __LINE__)) + write(fates_log(), *) 'switch for fixed biogeog unset: him_use_fixed_biogeog, exiting' + 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__)) + write(fates_log(), *) 'switch for no competition mode. ' + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_use_sp.eq.unset_int) then - if(fates_global_verbose()) then - write(fates_log(), *) 'switch for SP mode. ' - end if - call endrun(msg=errMsg(sourcefile, __LINE__)) + write(fates_log(), *) 'switch for SP mode. ' + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(hlm_use_cohort_age_tracking .eq. unset_int) then - if (fates_global_verbose()) then - write(fates_log(), *) 'switch for cohort_age_tracking unset: hlm_use_cohort_age_tracking, exiting' - end if + write(fates_log(), *) 'switch for cohort_age_tracking unset: hlm_use_cohort_age_tracking, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1556,7 +1477,6 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(hlm_use_sp.eq.itrue.and.hlm_use_fixed_biogeog.eq.ifalse)then write(fates_log(), *) 'SP cannot be on if fixed biogeog mode is off. Exiting. ' call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1565,7 +1485,6 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) if (fates_global_verbose()) then write(fates_log(), *) 'Checked. All control parameters sent to FATES.' end if - case default @@ -1695,10 +1614,10 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) end if case('use_sp') - hlm_use_sp = ival - if (fates_global_verbose()) then - write(fates_log(),*) 'Transfering hlm_use_sp= ',ival,' to FATES' - end if + hlm_use_sp = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_use_sp= ',ival,' to FATES' + end if case('use_planthydro') hlm_use_planthydro = ival @@ -1749,11 +1668,8 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) end if case default - if (fates_global_verbose()) then - write(fates_log(), *) 'tag not recognized:',trim(tag) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - ! end_run + write(fates_log(), *) 'fates NL tag not recognized:',trim(tag) + call endrun(msg=errMsg(sourcefile, __LINE__)) end select end if @@ -1766,10 +1682,8 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering hio_ignore_val = ',rval,' to FATES' end if case default - if (fates_global_verbose()) then - write(fates_log(),*) 'tag not recognized:',trim(tag) - end if - ! end_run + write(fates_log(),*) 'fates NL tag not recognized:',trim(tag) + call endrun(msg=errMsg(sourcefile, __LINE__)) end select end if @@ -1795,10 +1709,8 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) end if case default - if (fates_global_verbose()) then - write(fates_log(),*) 'tag not recognized:',trim(tag) - end if - ! end_run + write(fates_log(),*) 'fates NL tag not recognized:',trim(tag) + call endrun(msg=errMsg(sourcefile, __LINE__)) end select end if diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 19596a833e..cc939f6a33 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -484,7 +484,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) write(fates_log(),*) 'Lat: ',sites(s)%lat,' Lon: ',sites(s)%lon write(fates_log(),*) basal_area_pref,' [m2/ha]' write(fates_log(),*) '-------------------------------------------------------' - + ! Update the patch index numbers and fuse the cohorts in the patches ! ---------------------------------------------------------------------------------------- ipa=1 @@ -994,9 +994,11 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & end if if (c_pft .eq. 0 ) then - write(fates_log(), *) 'inventory pft: ',c_pft - write(fates_log(), *) 'SPECIAL CASE TRIGGERED: PFT == 0 and therefore this subroutine' - write(fates_log(), *) 'will assign a cohort with n = n_orig/numpft to every cohort in range 1 to numpft' + if(debug_inv)then + write(fates_log(), *) 'inventory pft: ',c_pft + write(fates_log(), *) 'SPECIAL CASE TRIGGERED: PFT == 0 and therefore this subroutine' + write(fates_log(), *) 'will assign a cohort with n = n_orig/numpft to every cohort in range 1 to numpft' + end if ncohorts_to_create = numpft else ncohorts_to_create = 1 diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 index f69d4ef5bf..2e5895c472 100644 --- a/main/FatesParametersInterface.F90 +++ b/main/FatesParametersInterface.F90 @@ -370,7 +370,6 @@ subroutine SetDimensionSizes(this, is_host_file, num_used_dimensions, dimension_ ! non-empty dimension name, set the size do i = 1, num_used_dimensions if (trim(dimension_names(i)) == trim(dim_name)) then - !write(*, *) '--> ', trim(this%parameters(p)%name), ' setting ', trim(dim_name), ' d = ', d, 'size = ', dimension_sizes(i) this%parameters(p)%dimension_sizes(d) = dimension_sizes(i) exit end if diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 5fe3b267a1..c138724711 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -410,8 +410,7 @@ subroutine set_dim_indices(this, dk_name, idim, dim_index) write(fates_log(), *) 'Trying to define dimension size to a dim-type structure' write(fates_log(), *) 'but the dimension index does not exist' write(fates_log(), *) 'type: ',dk_name,' ndims: ',this%dim_kinds(ityp)%ndims,' input dim:',idim - stop - !end_run + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if (idim == 1) then diff --git a/main/FatesRestartVariableType.F90 b/main/FatesRestartVariableType.F90 index 48152ec955..501dfe7023 100644 --- a/main/FatesRestartVariableType.F90 +++ b/main/FatesRestartVariableType.F90 @@ -3,10 +3,16 @@ module FatesRestartVariableMod use FatesConstantsMod, only : r8 => fates_r8 use FatesGlobals, only : fates_log use FatesIOVariableKindMod, only : fates_io_variable_kind_type - + use FatesGlobals , only : endrun => fates_endrun + use shr_log_mod , only : errMsg => shr_log_errMsg + implicit none private ! Modules are private by default + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + ! This type is instanteated in the HLM-FATES interface (clmfates_interfaceMod.F90) type, public :: fates_restart_variable_type @@ -108,8 +114,7 @@ subroutine Init(this, vname, units, long, vtype, flushval, num_dim_kinds, dim_ki case default write(fates_log(),*) 'Incompatible vtype passed to set_restart_var' write(fates_log(),*) 'vtype = ',trim(vtype),' ?' - stop - ! end_run + call endrun(msg=errMsg(sourcefile, __LINE__)) end select end subroutine Init @@ -200,8 +205,7 @@ subroutine flush(this, thread, dim_bounds, dim_kinds) case default write(fates_log(),*) 'fates history variable type undefined while flushing history variables' - stop - !end_run + call endrun(msg=errMsg(sourcefile, __LINE__)) end select end subroutine Flush diff --git a/parteh/PRTParamsFATESMod.F90 b/parteh/PRTParamsFATESMod.F90 index dce172d47d..3332b38f9b 100644 --- a/parteh/PRTParamsFATESMod.F90 +++ b/parteh/PRTParamsFATESMod.F90 @@ -1016,6 +1016,7 @@ subroutine PRTCheckParams(is_master) write(fates_log(),*) 'the parameter file organ list' write(fates_log(),*) 'fates_prt_organ_id: ',prt_params%organ_id(:) write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) end if if(prt_params%organ_id(io) == store_organ) then write(fates_log(),*) 'with flexible cnp or c-only alloc hypothesese' @@ -1024,6 +1025,7 @@ subroutine PRTCheckParams(is_master) write(fates_log(),*) 'the parameter file organ list' write(fates_log(),*) 'fates_prt_organ_id: ',prt_params%organ_id(:) write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) end if end do From ef9126a51884811af0b4cdb2b1d54dfd52fdc6ed Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 6 Oct 2021 14:22:02 -0400 Subject: [PATCH 417/578] Added metadata fix to the decompmicc parameter --- parameter_files/fates_params_default.cdl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 39adab94f6..8eb8a7cd09 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -167,7 +167,7 @@ variables: fates_eca_alpha_ptase:long_name = "fraction of P from ptase activity sent directly to plant (ECA)" ; double fates_eca_decompmicc(fates_pft) ; fates_eca_decompmicc:units = "gC/m3" ; - fates_eca_decompmicc:long_name = "mean soil microbial decomposer biomass (ECA)" ; + fates_eca_decompmicc:long_name = "maximum soil microbial decomposer biomass found over depth (will be applied at a reference depth w/ exponential attenuation) (ECA)" ; double fates_eca_km_nh4(fates_pft) ; fates_eca_km_nh4:units = "gN/m3" ; fates_eca_km_nh4:long_name = "half-saturation constant for plant nh4 uptake (ECA)" ; From 4acc184bb759da250eedd78635bac9cc4238a439 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 6 Oct 2021 14:33:03 -0400 Subject: [PATCH 418/578] Fixed some text describing parameters in microbial biomass attenuation function --- biogeochem/FatesSoilBGCFluxMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 9f210e8404..45e71dea05 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -677,7 +677,7 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) bc_out%veg_rootc(icomp,id) = bc_out%veg_rootc(icomp,id) + veg_rootc - ! We use a 3 parameter exponential attenuation function to estimate decomposer biomass + ! We use a 2 parameter exponential attenuation function to estimate decomposer biomass ! The parameter EDPftvarcon_inst%decompmicc(pft) is the maximum amount found at depth ! decompmicc_zmax, and the profile attenuates with strength lambda From 9b932c792f3907afb8f8811a5d8f3263ec143643 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Sat, 9 Oct 2021 12:00:35 -0600 Subject: [PATCH 419/578] updates to variable names and units --- main/FatesHistoryInterfaceMod.F90 | 1272 +++++++++++++++++------------ 1 file changed, 733 insertions(+), 539 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 7a24da569d..20fbb3adb7 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2033,24 +2033,24 @@ subroutine update_history_dyn(this,nc,nsites,sites) io_si = sites(s)%h_gid - ! Total carbon model error [kgC/day -> mgC/day] + ! Total carbon model error [kgC/day -> kgC/s] hio_cbal_err_fates_si(io_si) = & - sites(s)%mass_balance(element_pos(carbon12_element))%err_fates * mg_per_kg + sites(s)%mass_balance(element_pos(carbon12_element))%err_fates / sec_per_day - ! Total carbon lost to atmosphere from burning (kgC/site/day -> gC/m2/s) + ! Total carbon lost to atmosphere from burning (kgC/site/day -> kgC/m2/s) hio_fire_c_to_atm_si(io_si) = & sites(s)%mass_balance(element_pos(carbon12_element))%burn_flux_to_atm * & - g_per_kg * ha_per_m2 * days_per_sec + ha_per_m2 * days_per_sec - ! Total model error [kg/day -> mg/day] (all elements) + ! Total model error [kg/day -> kg/s] (all elements) do el = 1, num_elements - hio_err_fates_si(io_si,el) = sites(s)%mass_balance(el)%err_fates * mg_per_kg + hio_err_fates_si(io_si,el) = sites(s)%mass_balance(el)%err_fates / sec_per_day ! 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 + ha_per_m2 * days_per_sec end do @@ -2389,14 +2389,22 @@ subroutine update_history_dyn(this,nc,nsites,sites) repro_m_net_alloc = ccohort%prt%GetNetAlloc(repro_organ, carbon12_element) * days_per_year ! ecosystem-level, organ-partitioned NPP/allocation fluxes - hio_npp_leaf_si(io_si) = hio_npp_leaf_si(io_si) + leaf_m_net_alloc * n_perm2 - hio_npp_seed_si(io_si) = hio_npp_seed_si(io_si) + repro_m_net_alloc * n_perm2 - hio_npp_stem_si(io_si) = hio_npp_stem_si(io_si) + (sapw_m_net_alloc + struct_m_net_alloc) * n_perm2 * & - (prt_params%allom_agb_frac(ccohort%pft)) - hio_npp_froot_si(io_si) = hio_npp_froot_si(io_si) + fnrt_m_net_alloc * n_perm2 - hio_npp_croot_si(io_si) = hio_npp_croot_si(io_si) + (sapw_m_net_alloc + struct_m_net_alloc) * n_perm2 * & - (1._r8-prt_params%allom_agb_frac(ccohort%pft)) - hio_npp_stor_si(io_si) = hio_npp_stor_si(io_si) + store_m_net_alloc * n_perm2 + hio_npp_leaf_si(io_si) = hio_npp_leaf_si(io_si) + & + leaf_m_net_alloc * n_perm2 / days_per_year / sec_per_day + hio_npp_seed_si(io_si) = hio_npp_seed_si(io_si) + & + repro_m_net_alloc * n_perm2 / days_per_year / sec_per_day + hio_npp_stem_si(io_si) = hio_npp_stem_si(io_si) + & + (sapw_m_net_alloc + struct_m_net_alloc) * n_perm2 * & + (prt_params%allom_agb_frac(ccohort%pft)) / & + days_per_year / sec_per_day + hio_npp_froot_si(io_si) = hio_npp_froot_si(io_si) + & + fnrt_m_net_alloc * n_perm2 / days_per_year / sec_per_day + hio_npp_croot_si(io_si) = hio_npp_croot_si(io_si) + & + (sapw_m_net_alloc + struct_m_net_alloc) * n_perm2 * & + (1._r8-prt_params%allom_agb_frac(ccohort%pft)) / & + days_per_year / sec_per_day + hio_npp_stor_si(io_si) = hio_npp_stor_si(io_si) + & + store_m_net_alloc * n_perm2 / days_per_year / sec_per_day associate( scpf => ccohort%size_by_pft_class, & @@ -2411,7 +2419,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) n_perm2*ccohort%gpp_acc_hold / & days_per_year / sec_per_day ! [kgC/m2/s] hio_npp_totl_si_scpf(io_si,scpf) = hio_npp_totl_si_scpf(io_si,scpf) + & - ccohort%npp_acc_hold *n_perm2 / & + ccohort%npp_acc_hold * n_perm2 / & days_per_year / sec_per_day @@ -2595,7 +2603,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_trimming_canopy_si_scls(io_si,scls) = hio_trimming_canopy_si_scls(io_si,scls) + & ccohort%n * ccohort%canopy_trim hio_crown_area_canopy_si_scls(io_si,scls) = hio_crown_area_canopy_si_scls(io_si,scls) + & - ccohort%c_area + ccohort%c_area / m2_per_ha hio_gpp_canopy_si_scpf(io_si,scpf) = hio_gpp_canopy_si_scpf(io_si,scpf) + & n_perm2*ccohort%gpp_acc_hold / days_per_year / sec_per_day hio_ar_canopy_si_scpf(io_si,scpf) = hio_ar_canopy_si_scpf(io_si,scpf) + & @@ -2623,34 +2631,34 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_carbon_balance_canopy_si_scls(io_si,scls) = hio_carbon_balance_canopy_si_scls(io_si,scls) + & - ccohort%n * ccohort%npp_acc_hold + ccohort%n * ccohort%npp_acc_hold / m2_per_ha / days_per_year / sec_per_day hio_leaf_md_canopy_si_scls(io_si,scls) = hio_leaf_md_canopy_si_scls(io_si,scls) + & - leaf_m_turnover * ccohort%n + leaf_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_root_md_canopy_si_scls(io_si,scls) = hio_root_md_canopy_si_scls(io_si,scls) + & - fnrt_m_turnover * ccohort%n + fnrt_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_bsw_md_canopy_si_scls(io_si,scls) = hio_bsw_md_canopy_si_scls(io_si,scls) + & - sapw_m_turnover * ccohort%n + sapw_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_bstore_md_canopy_si_scls(io_si,scls) = hio_bstore_md_canopy_si_scls(io_si,scls) + & - store_m_turnover * ccohort%n + store_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_bdead_md_canopy_si_scls(io_si,scls) = hio_bdead_md_canopy_si_scls(io_si,scls) + & - struct_m_turnover * ccohort%n + struct_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_seed_prod_canopy_si_scls(io_si,scls) = hio_seed_prod_canopy_si_scls(io_si,scls) + & - ccohort%seed_prod * ccohort%n + ccohort%seed_prod * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_npp_leaf_canopy_si_scls(io_si,scls) = hio_npp_leaf_canopy_si_scls(io_si,scls) + & - leaf_m_net_alloc * ccohort%n + leaf_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_npp_fnrt_canopy_si_scls(io_si,scls) = hio_npp_fnrt_canopy_si_scls(io_si,scls) + & - fnrt_m_net_alloc * ccohort%n + fnrt_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_npp_sapw_canopy_si_scls(io_si,scls) = hio_npp_sapw_canopy_si_scls(io_si,scls) + & - sapw_m_net_alloc * ccohort%n + sapw_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_npp_dead_canopy_si_scls(io_si,scls) = hio_npp_dead_canopy_si_scls(io_si,scls) + & - struct_m_net_alloc * ccohort%n + struct_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_npp_seed_canopy_si_scls(io_si,scls) = hio_npp_seed_canopy_si_scls(io_si,scls) + & - repro_m_net_alloc * ccohort%n + repro_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_npp_stor_canopy_si_scls(io_si,scls) = hio_npp_stor_canopy_si_scls(io_si,scls) + & - store_m_net_alloc * ccohort%n + store_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) = & hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) + & @@ -2688,7 +2696,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_trimming_understory_si_scls(io_si,scls) = hio_trimming_understory_si_scls(io_si,scls) + & ccohort%n * ccohort%canopy_trim hio_crown_area_understory_si_scls(io_si,scls) = hio_crown_area_understory_si_scls(io_si,scls) + & - ccohort%c_area + ccohort%c_area / m2_per_ha hio_gpp_understory_si_scpf(io_si,scpf) = hio_gpp_understory_si_scpf(io_si,scpf) + & n_perm2*ccohort%gpp_acc_hold / days_per_year / sec_per_day hio_ar_understory_si_scpf(io_si,scpf) = hio_ar_understory_si_scpf(io_si,scpf) + & @@ -2706,7 +2714,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * sec_per_day * days_per_year + ccohort%n * sec_per_day * days_per_year / m2_per_ha hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & @@ -2716,33 +2724,33 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%n * g_per_kg * ha_per_m2 hio_carbon_balance_understory_si_scls(io_si,scls) = hio_carbon_balance_understory_si_scls(io_si,scls) + & - ccohort%npp_acc_hold * ccohort%n + ccohort%npp_acc_hold * ccohort%n / m2_per_ha hio_leaf_md_understory_si_scls(io_si,scls) = hio_leaf_md_understory_si_scls(io_si,scls) + & - leaf_m_turnover * ccohort%n + leaf_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_root_md_understory_si_scls(io_si,scls) = hio_root_md_understory_si_scls(io_si,scls) + & - fnrt_m_turnover * ccohort%n + fnrt_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_bsw_md_understory_si_scls(io_si,scls) = hio_bsw_md_understory_si_scls(io_si,scls) + & - sapw_m_turnover * ccohort%n + sapw_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_bstore_md_understory_si_scls(io_si,scls) = hio_bstore_md_understory_si_scls(io_si,scls) + & - store_m_turnover * ccohort%n + store_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_bdead_md_understory_si_scls(io_si,scls) = hio_bdead_md_understory_si_scls(io_si,scls) + & - struct_m_turnover * ccohort%n + struct_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_seed_prod_understory_si_scls(io_si,scls) = hio_seed_prod_understory_si_scls(io_si,scls) + & - ccohort%seed_prod * ccohort%n + ccohort%seed_prod * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_npp_leaf_understory_si_scls(io_si,scls) = hio_npp_leaf_understory_si_scls(io_si,scls) + & - leaf_m_net_alloc * ccohort%n + leaf_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_npp_fnrt_understory_si_scls(io_si,scls) = hio_npp_fnrt_understory_si_scls(io_si,scls) + & - fnrt_m_net_alloc * ccohort%n + fnrt_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_npp_sapw_understory_si_scls(io_si,scls) = hio_npp_sapw_understory_si_scls(io_si,scls) + & - sapw_m_net_alloc * ccohort%n + sapw_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_npp_dead_understory_si_scls(io_si,scls) = hio_npp_dead_understory_si_scls(io_si,scls) + & - struct_m_net_alloc * ccohort%n + struct_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_npp_seed_understory_si_scls(io_si,scls) = hio_npp_seed_understory_si_scls(io_si,scls) + & - repro_m_net_alloc * ccohort%n + repro_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_npp_stor_understory_si_scls(io_si,scls) = hio_npp_stor_understory_si_scls(io_si,scls) + & - store_m_net_alloc * ccohort%n + store_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) = & hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) + & @@ -2895,7 +2903,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & - sites(s)%term_nindivs_ustory(i_scls,i_pft) * days_per_year + sites(s)%term_nindivs_ustory(i_scls,i_pft) * days_per_year / m2_per_ha hio_mortality_canopy_si_scpf(io_si,i_scpf) = hio_mortality_canopy_si_scpf(io_si,i_scpf) + & sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year @@ -2914,7 +2922,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & sites(s)%imort_rate(i_scls, i_pft) hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & - sites(s)%imort_rate(i_scls, i_pft) + sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha ! iscag = i_scls ! since imort is by definition something that only happens in newly disturbed patches, treat as such hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & @@ -2942,7 +2950,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) sites(s)%fmort_rate_ustory(i_scls, i_pft) hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & - sites(s)%fmort_rate_ustory(i_scls, i_pft) + sites(s)%fmort_rate_ustory(i_scls, i_pft) / m2_per_ha ! ! carbon flux associated with mortality of trees dying by fire @@ -3099,7 +3107,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_reproc_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_cefflux_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) + sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) / & + m2_per_ha / sec_per_day this%hvars(ih_cefflux_si)%r81d(io_si) = & sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) / & @@ -3117,10 +3126,12 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_repron_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_nefflux_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) + sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) / & + m2_per_ha / sec_per_day this%hvars(ih_nneed_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_need_scpf(:) + sites(s)%flux_diags(el)%nutrient_need_scpf(:) / & + m2_per_ha / sec_per_day this%hvars(ih_nneed_si)%r81d(io_si) = & sum(sites(s)%flux_diags(el)%nutrient_need_scpf(:),dim=1) / & @@ -3141,10 +3152,12 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_reprop_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_pefflux_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) + sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) / & + m2_per_ha / sec_per day this%hvars(ih_pneed_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_need_scpf(:) + sites(s)%flux_diags(el)%nutrient_need_scpf(:) / & + m2_per_ha / sec_per_day this%hvars(ih_pneed_si)%r81d(io_si) = & sum(sites(s)%flux_diags(el)%nutrient_need_scpf(:),dim=1) / & @@ -3192,21 +3205,22 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! Litter State Variables hio_cwd_ag_elem(io_si,el) = hio_cwd_ag_elem(io_si,el) + & - sum(litt%ag_cwd(:)) * cpatch%area + sum(litt%ag_cwd(:)) * cpatch%area / m2_per_ha hio_cwd_bg_elem(io_si,el) = hio_cwd_bg_elem(io_si,el) + & - sum(litt%bg_cwd(:,:)) * cpatch%area + sum(litt%bg_cwd(:,:)) * cpatch%area / m2_per_ha hio_fines_ag_elem(io_si,el) = hio_fines_ag_elem(io_si,el) + & - sum(litt%leaf_fines(:)) * cpatch%area + sum(litt%leaf_fines(:)) * cpatch%area / m2_per_ha hio_fines_bg_elem(io_si,el) = hio_fines_bg_elem(io_si,el) + & - sum(litt%root_fines(:,:)) * cpatch%area + sum(litt%root_fines(:,:)) * cpatch%area / m2_per_ha do cwd=1,ncwd elcwd = (el-1)*ncwd+cwd - hio_cwd_elcwd(io_si,elcwd) = hio_cwd_elcwd(io_si,elcwd) + & - (litt%ag_cwd(cwd) + sum(litt%bg_cwd(cwd,:))) * cpatch%area + hio_cwd_elcwd(io_si,elcwd) = hio_cwd_elcwd(io_si,elcwd) + & + (litt%ag_cwd(cwd) + sum(litt%bg_cwd(cwd,:))) * & + cpatch%area / m2_per_ha end do @@ -3226,34 +3240,46 @@ subroutine update_history_dyn(this,nc,nsites,sites) i_scpf = ccohort%size_by_pft_class if(element_list(el).eq.carbon12_element)then - this%hvars(ih_totvegc_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_totvegc_scpf)%r82d(io_si,i_scpf) + total_m * ccohort%n - this%hvars(ih_leafc_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_leafc_scpf)%r82d(io_si,i_scpf) + leaf_m * ccohort%n - this%hvars(ih_fnrtc_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_fnrtc_scpf)%r82d(io_si,i_scpf) + fnrt_m * ccohort%n - this%hvars(ih_sapwc_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_sapwc_scpf)%r82d(io_si,i_scpf) + sapw_m * ccohort%n - this%hvars(ih_storec_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storec_scpf)%r82d(io_si,i_scpf) + store_m * ccohort%n - this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) + repro_m * ccohort%n + this%hvars(ih_totvegc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_totvegc_scpf)%r82d(io_si,i_scpf) + & + total_m * ccohort%n / m2_per_ha + this%hvars(ih_leafc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_leafc_scpf)%r82d(io_si,i_scpf) + & + leaf_m * ccohort%n / m2_per_ha + this%hvars(ih_fnrtc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_fnrtc_scpf)%r82d(io_si,i_scpf) + & + fnrt_m * ccohort%n / m2_per_ha + this%hvars(ih_sapwc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_sapwc_scpf)%r82d(io_si,i_scpf) + & + sapw_m * ccohort%n / m2_per_ha + this%hvars(ih_storec_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storec_scpf)%r82d(io_si,i_scpf) + & + store_m * ccohort%n / m2_per_ha + this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) + & + repro_m * ccohort%n / m2_per_ha elseif(element_list(el).eq.nitrogen_element)then store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) - this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) + total_m * ccohort%n - this%hvars(ih_leafn_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_leafn_scpf)%r82d(io_si,i_scpf) + leaf_m * ccohort%n - this%hvars(ih_fnrtn_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_fnrtn_scpf)%r82d(io_si,i_scpf) + fnrt_m * ccohort%n - this%hvars(ih_sapwn_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_sapwn_scpf)%r82d(io_si,i_scpf) + sapw_m * ccohort%n - this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) + store_m * ccohort%n - this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) + repro_m * ccohort%n + this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) + & + total_m * ccohort%n / m2_per_ha + this%hvars(ih_leafn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_leafn_scpf)%r82d(io_si,i_scpf) + & + leaf_m * ccohort%n / m2_per_ha + this%hvars(ih_fnrtn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_fnrtn_scpf)%r82d(io_si,i_scpf) + & + fnrt_m * ccohort%n / m2_per_ha + this%hvars(ih_sapwn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_sapwn_scpf)%r82d(io_si,i_scpf) + & + sapw_m * ccohort%n / m2_per_ha + this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) + & + store_m * ccohort%n / m2_per_ha + this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) + & + repro_m * ccohort%n / m2_per_ha if (ccohort%canopy_layer .eq. 1) then this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) = & @@ -3267,18 +3293,24 @@ subroutine update_history_dyn(this,nc,nsites,sites) store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) - this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) + total_m * ccohort%n - this%hvars(ih_leafp_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_leafp_scpf)%r82d(io_si,i_scpf) + leaf_m * ccohort%n - this%hvars(ih_fnrtp_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_fnrtp_scpf)%r82d(io_si,i_scpf) + fnrt_m * ccohort%n - this%hvars(ih_sapwp_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_sapwp_scpf)%r82d(io_si,i_scpf) + sapw_m * ccohort%n - this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) + store_m * ccohort%n - this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) + repro_m * ccohort%n + this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) + & + total_m * ccohort%n / m2_per_ha + this%hvars(ih_leafp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_leafp_scpf)%r82d(io_si,i_scpf) + & + leaf_m * ccohort%n / m2_per_ha + this%hvars(ih_fnrtp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_fnrtp_scpf)%r82d(io_si,i_scpf) + & + fnrt_m * ccohort%n / m2_per_ha + this%hvars(ih_sapwp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_sapwp_scpf)%r82d(io_si,i_scpf) + & + sapw_m * ccohort%n / m2_per_ha + this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) + & + store_m * ccohort%n / m2_per_ha + this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) + & + repro_m * ccohort%n / m2_per_ha if (ccohort%canopy_layer .eq. 1) then this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) = & @@ -3516,8 +3548,8 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) io_si = sites(s)%h_gid - hio_nep_si(io_si) = -bc_in(s)%tot_het_resp ! (gC/m2/s) - hio_hr_si(io_si) = bc_in(s)%tot_het_resp + hio_nep_si(io_si) = -bc_in(s)%tot_het_resp / g_per_kg ! (kgC/m2/s) + hio_hr_si(io_si) = bc_in(s)%tot_het_resp / g_per_kg ipa = 0 cpatch => sites(s)%oldest_patch @@ -3577,19 +3609,19 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ccohort%resp_m * n_perm2 * per_dt_tstep ! Add up the total Net Ecosystem Production - ! for this timestep. [gC/m2/s] + ! for this timestep. [kgC/m2/s] hio_nep_si(io_si) = hio_nep_si(io_si) + & - npp * g_per_kg * n_perm2 * per_dt_tstep + npp * n_perm2 * 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 + * n_perm2 hio_froot_mr_si(io_si) = hio_froot_mr_si(io_si) + ccohort%froot_mr & - * n_perm2 * sec_per_day * days_per_year + * n_perm2 hio_livecroot_mr_si(io_si) = hio_livecroot_mr_si(io_si) + ccohort%livecroot_mr & - * n_perm2 * sec_per_day * days_per_year + * n_perm2 hio_livestem_mr_si(io_si) = hio_livestem_mr_si(io_si) + ccohort%livestem_mr & - * n_perm2 * sec_per_day * days_per_year + * n_perm2 ! Total AR (kgC/m2/s) = (kgC/plant/step) / (s/step) * (plant/m2) hio_ar_si_scpf(io_si,scpf) = hio_ar_si_scpf(io_si,scpf) + & @@ -3637,19 +3669,20 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) aresp * n_perm2 * per_dt_tstep ! - ! size-resolved respiration fluxes are in kg C / ha / yr + ! size-resolved respiration fluxes are in kg C / m2 / s hio_rdark_canopy_si_scls(io_si,scls) = hio_rdark_canopy_si_scls(io_si,scls) + & - ccohort%rdark * ccohort%n * sec_per_day * days_per_year + ccohort%rdark * ccohort%n / m2_per_ha hio_livestem_mr_canopy_si_scls(io_si,scls) = hio_livestem_mr_canopy_si_scls(io_si,scls) + & - ccohort%livestem_mr * ccohort%n * sec_per_day * days_per_year + ccohort%livestem_mr * ccohort%n / m2_per_ha hio_livecroot_mr_canopy_si_scls(io_si,scls) = hio_livecroot_mr_canopy_si_scls(io_si,scls) + & - ccohort%livecroot_mr * ccohort%n * sec_per_day * days_per_year + ccohort%livecroot_mr * ccohort%n / m2_per_ha hio_froot_mr_canopy_si_scls(io_si,scls) = hio_froot_mr_canopy_si_scls(io_si,scls) + & - ccohort%froot_mr * ccohort%n * sec_per_day * days_per_year + ccohort%froot_mr * ccohort%n / m2_per_ha + hio_resp_g_canopy_si_scls(io_si,scls) = hio_resp_g_canopy_si_scls(io_si,scls) + & - resp_g * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + resp_g * ccohort%n * per_dt_tstep / m2_per_ha hio_resp_m_canopy_si_scls(io_si,scls) = hio_resp_m_canopy_si_scls(io_si,scls) + & - ccohort%resp_m * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + ccohort%resp_m * ccohort%n * per_dt_tstep / m2_per_ha else ! ! bulk fluxes are in gC / m2 / s @@ -3659,19 +3692,19 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) aresp * n_perm2 * per_dt_tstep ! - ! size-resolved respiration fluxes are in kg C / ha / yr + ! size-resolved respiration fluxes are in kg C / m2 / s hio_rdark_understory_si_scls(io_si,scls) = hio_rdark_understory_si_scls(io_si,scls) + & - ccohort%rdark * ccohort%n * sec_per_day * days_per_year + ccohort%rdark * ccohort%n / m2_per_ha hio_livestem_mr_understory_si_scls(io_si,scls) = hio_livestem_mr_understory_si_scls(io_si,scls) + & - ccohort%livestem_mr * ccohort%n * sec_per_day * days_per_year + ccohort%livestem_mr * ccohort%n / m2_per_ha hio_livecroot_mr_understory_si_scls(io_si,scls) = hio_livecroot_mr_understory_si_scls(io_si,scls) + & - ccohort%livecroot_mr * ccohort%n * sec_per_day * days_per_year + ccohort%livecroot_mr * ccohort%n / m2_per_ha hio_froot_mr_understory_si_scls(io_si,scls) = hio_froot_mr_understory_si_scls(io_si,scls) + & - ccohort%froot_mr * ccohort%n * sec_per_day * days_per_year + ccohort%froot_mr * ccohort%n / m2_per_ha hio_resp_g_understory_si_scls(io_si,scls) = hio_resp_g_understory_si_scls(io_si,scls) + & - resp_g * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + resp_g * ccohort%n * per_dt_tstep / m2_per_ha hio_resp_m_understory_si_scls(io_si,scls) = hio_resp_m_understory_si_scls(io_si,scls) + & - ccohort%resp_m * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + ccohort%resp_m * ccohort%n * per_dt_tstep / m2_per_ha endif end associate endif @@ -4254,7 +4287,7 @@ subroutine define_history_vars(this, initialize_variables) index=ih_ncohorts_si) ! Patch variables - call this%set_history_var(vname='FATES_TRIMMING', units='', & + call this%set_history_var(vname='FATES_TRIMMING', units='1', & long='degree to which canopy expansion is limited by leaf economics (0-1)', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & @@ -4547,13 +4580,13 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index=ih_fire_intensity_area_product_si) - call this%set_history_var(vname='FATES_BURNFRAC', units='1 s-1', & + call this%set_history_var(vname='FATES_BURNFRAC', units='s-1', & long='burned area fraction per second', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & index=ih_fire_area_si) - call this%set_history_var(vname='FATES_FUEL_MEF', units='1', & + call this%set_history_var(vname='FATES_FUEL_MEF', units='m3 m-3', & long='fuel moisture of extinction (volumetric)', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & @@ -4565,7 +4598,7 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_fire_fuel_bulkd_si ) - call this%set_history_var(vname='FATES_FUEL_EFF_MOIST', units='1', & + call this%set_history_var(vname='FATES_FUEL_EFF_MOIST', units='m3 m-3', & long='spitfire fuel moisture (volumetric)', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_fire_fuel_eff_moist_si) @@ -4588,7 +4621,7 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_fragmentation_scaler_sl) - call this%set_history_var(vname='FATES_FUEL_MOISTURE_FC', units='1', & + call this%set_history_var(vname='FATES_FUEL_MOISTURE_FC', units='m3 m-3', & long='spitfire fuel class-level fuel moisture (volumetric)', & use_default='active', avgflag='A', vtype=site_fuel_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & @@ -4606,7 +4639,7 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_fuel_amount_age_fuel) - call this%set_history_var(vname='FATES_BURNFRAC_AP', units='1 s-1', & + call this%set_history_var(vname='FATES_BURNFRAC_AP', units='s-1', & long='spitfire fraction area burnt (per second) by patch age', & use_default='active', avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & @@ -4726,7 +4759,7 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_leafc_si) - call this%set_history_var(vname='FATES_FINEROOTC', units='kg m-2', & + call this%set_history_var(vname='FATES_FROOTC', units='kg m-2', & long='total biomass in live plant fine roots in kg carbon per m2', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & @@ -4771,7 +4804,7 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_leafn_si) - call this%set_history_var(vname='FATES_FINEROOTN', units='kg m-2', & + call this%set_history_var(vname='FATES_FROOTN', units='kg m-2', & long='total nitrogen in live plant fine-roots', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & @@ -4839,7 +4872,7 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_leafp_si) - call this%set_history_var(vname='FATES_FINEROOTP', units='kg m-2', & + call this%set_history_var(vname='FATES_FROOTP', units='kg m-2', & long='total phosphorus in live plant fine roots', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & @@ -5415,7 +5448,7 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_npp_seed_si_scpf) - call this%set_history_var(vname='FATES_NPP_FINEROOT_SZPF', & + call this%set_history_var(vname='FATES_NPP_FROOT_SZPF', & units='kg m-2 s-1', & long='NPP flux into fine roots by pft/size in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & @@ -5955,20 +5988,27 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_m10_si_cacls) - call this%set_history_var(vname='FATES_CARBON_BALANCE_CANOPY_SZ', units = 'kg C / ha / yr', & - long='CARBON_BALANCE for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_carbon_balance_canopy_si_scls ) + call this%set_history_var(vname='FATES_NPP_CANOPY_SZ', units = 'kg m-2 s-1', & + long='NPP of canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_carbon_balance_canopy_si_scls) - call this%set_history_var(vname='CARBON_BALANCE_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='CARBON_BALANCE for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_carbon_balance_understory_si_scls ) + call this%set_history_var(vname='FATES_NPP_UNDERSTORY_SZ', units = 'kg m-2 s-1', & + long='NPP of understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_carbon_balance_understory_si_scls) - call this%set_history_var(vname='MORTALITY_UNDERSTORY_SCLS', units = 'indiv/ha/yr', & - long='total mortality of understory trees by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_understory_si_scls ) + call this%set_history_var(vname='FATES_MORTALITY_UNDERSTORY_SZ', & + units = 'm-2 yr-1', & + long='total mortality of understory trees by size class in individuals per m2 per year', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_mortality_understory_si_scls) call this%set_history_var(vname='TRIMMING_CANOPY_SCLS', units = 'indiv/ha', & long='trimming term of canopy plants by size class', use_default='inactive', & @@ -5980,464 +6020,618 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_trimming_understory_si_scls ) - call this%set_history_var(vname='CROWN_AREA_CANOPY_SCLS', units = 'm2/ha', & - long='total crown area of canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_crown_area_canopy_si_scls ) + call this%set_history_var(vname='FATES_CROWNAREA_CANOPY_SZ', units = 'm2 m-2', & + long='total crown area of canopy plants by size class', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_crown_area_canopy_si_scls) - call this%set_history_var(vname='CROWN_AREA_UNDERSTORY_SCLS', units = 'm2/ha', & - long='total crown area of understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_crown_area_understory_si_scls ) + call this%set_history_var(vname='FATES_CROWNAREA_UNDERSTORY_SZ', units = 'm2 m-2', & + long='total crown area of understory plants by size class', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_crown_area_understory_si_scls) - call this%set_history_var(vname='LEAF_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='LEAF_MD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leaf_md_canopy_si_scls ) + call this%set_history_var(vname='FATES_LEAFCTURNOVER_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='leaf turnover for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_leaf_md_canopy_si_scls) - call this%set_history_var(vname='ROOT_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='ROOT_MD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_root_md_canopy_si_scls ) + call this%set_history_var(vname='FATES_FROOTCTURNOVER_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='fine root turnover for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_root_md_canopy_si_scls) - call this%set_history_var(vname='BSTORE_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='BSTORE_MD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstore_md_canopy_si_scls ) + call this%set_history_var(vname='FATES_STORECTURNOVER_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='storage turnover for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_bstore_md_canopy_si_scls) - call this%set_history_var(vname='BDEAD_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='BDEAD_MD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bdead_md_canopy_si_scls ) + call this%set_history_var(vname='FATES_STRUCTCTURNOVER_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='structural C turnover for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_bdead_md_canopy_si_scls) - call this%set_history_var(vname='BSW_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='BSW_MD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bsw_md_canopy_si_scls ) + call this%set_history_var(vname='FATES_SAPWOODCTURNOVER_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='sapwood turnover for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_bsw_md_canopy_si_scls) - call this%set_history_var(vname='SEED_PROD_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='SEED_PROD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_seed_prod_canopy_si_scls ) - - call this%set_history_var(vname='NPP_LEAF_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='NPP_LEAF for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_canopy_si_scls ) - - call this%set_history_var(vname='NPP_FROOT_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='NPP_FROOT for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_fnrt_canopy_si_scls ) - - call this%set_history_var(vname='NPP_BSW_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='NPP_BSW for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_sapw_canopy_si_scls ) - - call this%set_history_var(vname='NPP_BDEAD_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='NPP_BDEAD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_dead_canopy_si_scls ) - - call this%set_history_var(vname='NPP_BSEED_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='NPP_BSEED for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_seed_canopy_si_scls ) - - call this%set_history_var(vname='NPP_STORE_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='NPP_STORE for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stor_canopy_si_scls ) - - call this%set_history_var(vname='LEAF_MR', units = 'kg C / m2 / yr', & - long='RDARK (leaf maintenance respiration)', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_leaf_mr_si ) - - call this%set_history_var(vname='FROOT_MR', units = 'kg C / m2 / yr', & - long='fine root maintenance respiration)', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_froot_mr_si ) - - call this%set_history_var(vname='LIVECROOT_MR', units = 'kg C / m2 / yr', & - long='live coarse root maintenance respiration)', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livecroot_mr_si ) - - call this%set_history_var(vname='LIVESTEM_MR', units = 'kg C / m2 / yr', & - long='live stem maintenance respiration)', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livestem_mr_si ) - - call this%set_history_var(vname='RDARK_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='RDARK for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_rdark_canopy_si_scls ) + call this%set_history_var(vname='FATES_SEED_PROD_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='seed production of canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_seed_prod_canopy_si_scls) - call this%set_history_var(vname='LIVESTEM_MR_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='LIVESTEM_MR for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livestem_mr_canopy_si_scls ) + call this%set_history_var(vname='FATES_NPP_LEAF_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='NPP flux into leaves for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_leaf_canopy_si_scls) - call this%set_history_var(vname='LIVECROOT_MR_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='LIVECROOT_MR for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livecroot_mr_canopy_si_scls ) + call this%set_history_var(vname='FATES_NPP_FROOT_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='NPP flux into fine root C for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_fnrt_canopy_si_scls) - call this%set_history_var(vname='FROOT_MR_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='FROOT_MR for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_froot_mr_canopy_si_scls ) + call this%set_history_var(vname='FATES_NPP_SAPWOOD_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='NPP flux into sapwood C for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_sapw_canopy_si_scls) - call this%set_history_var(vname='RESP_G_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='RESP_G for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_g_canopy_si_scls ) + call this%set_history_var(vname='FATES_NPP_STRUCT_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='NPP flux into structural C for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_dead_canopy_si_scls) - call this%set_history_var(vname='RESP_M_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='RESP_M for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_m_canopy_si_scls ) + call this%set_history_var(vname='FATES_NPP_SEED_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='NPP flux into reproductive C for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_seed_canopy_si_scls) - call this%set_history_var(vname='LEAF_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='LEAF_MD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leaf_md_understory_si_scls ) + call this%set_history_var(vname='FATES_NPP_STORE_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='NPP flux into storage C for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_stor_canopy_si_scls) - call this%set_history_var(vname='ROOT_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='ROOT_MD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_root_md_understory_si_scls ) + call this%set_history_var(vname='FATES_AUTO_RESP_LEAFMAINT', & + units = 'kg m-2 s-1', & + long='leaf maintenance autotrophic respiration in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_leaf_mr_si) - call this%set_history_var(vname='BSTORE_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='BSTORE_MD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstore_md_understory_si_scls ) + call this%set_history_var(vname='FATES_AUTO_RESP_FROOTMAINT', & + units = 'kg m-2 s-1', & + long='fine root maintenance autotrophic respiration in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_froot_mr_si) - call this%set_history_var(vname='BDEAD_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='BDEAD_MD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bdead_md_understory_si_scls ) + call this%set_history_var(vname='FATES_AUTO_RESP_CROOTMAINT', & + units = 'kg m-2 s-1', & + long='live coarse root maintenance autotrophic respiration in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_livecroot_mr_si) - call this%set_history_var(vname='BSW_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='BSW_MD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bsw_md_understory_si_scls ) + call this%set_history_var(vname='FATES_AUTO_RESP_LIVESTEMMAINT', & + units = 'kg m-2 s-1', & + long='live stem maintenance autotrophic respiration in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_livestem_mr_si) - call this%set_history_var(vname='SEED_PROD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='SEED_PROD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_seed_prod_understory_si_scls ) - - call this%set_history_var(vname='NPP_LEAF_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='NPP_LEAF for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_understory_si_scls ) - - call this%set_history_var(vname='NPP_FROOT_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='NPP_FROOT for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_fnrt_understory_si_scls ) - - call this%set_history_var(vname='NPP_BSW_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='NPP_BSW for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_sapw_understory_si_scls ) - - call this%set_history_var(vname='NPP_BDEAD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='NPP_BDEAD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_dead_understory_si_scls ) - - call this%set_history_var(vname='NPP_BSEED_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='NPP_BSEED for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_seed_understory_si_scls ) - - call this%set_history_var(vname='NPP_STORE_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='NPP_STORE for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stor_understory_si_scls ) - - call this%set_history_var(vname='RDARK_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='RDARK for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_rdark_understory_si_scls ) + call this%set_history_var(vname='FATES_AUTO_RESP_MAINT_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='maintenance autotrophic respiration for canopy plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_rdark_canopy_si_scls) - call this%set_history_var(vname='LIVESTEM_MR_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='LIVESTEM_MR for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livestem_mr_understory_si_scls ) + call this%set_history_var(vname='FATES_AUTO_RESP_LIVESTEMMAINT_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='live stem maintenance autotrophic respiration for canopy plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, & + index = ih_livestem_mr_canopy_si_scls) - call this%set_history_var(vname='LIVECROOT_MR_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='LIVECROOT_MR for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livecroot_mr_understory_si_scls ) + call this%set_history_var(vname='FATES_AUTO_RESP_CROOTMAINT_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='live coarse root maintenance autotrophic respiration for canopy plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, & + index = ih_livecroot_mr_canopy_si_scls) - call this%set_history_var(vname='FROOT_MR_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='FROOT_MR for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_froot_mr_understory_si_scls ) + call this%set_history_var(vname='FATES_AUTO_RESP_FROOTMAINT_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='live coarse root maintenance autotrophic respiration for canopy plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_froot_mr_canopy_si_scls) - call this%set_history_var(vname='RESP_G_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='RESP_G for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_g_understory_si_scls ) + call this%set_history_var(vname='FATES_AUTO_RESP_GROW_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='growth autotrophic respiration of canopy plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_resp_g_canopy_si_scls) - call this%set_history_var(vname='RESP_M_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='RESP_M for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_m_understory_si_scls ) + call this%set_history_var(vname='FATES_AUTO_RESP_MAINT_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='maintenance autotrophic respiration of canopy plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_resp_m_canopy_si_scls) + + call this%set_history_var(vname='FATES_LEAFCTURNOVER_UNDERSTORY_SZ', & + units = 'kg m-2 s-1', & + long='leaf turnover for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_leaf_md_understory_si_scls) + + call this%set_history_var(vname='FATES_FROOTCTURNOVER_UNDERSTORY_SZ', & + units = 'kg m-2 s-1', & + long='fine root turnover for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_root_md_understory_si_scls) + + call this%set_history_var(vname='FATES_STORECTURNOVER_UNDERSTORY_SZ', & + units = 'kg m-2 s-1', & + long='storage C turnover for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_bstore_md_understory_si_scls) + + call this%set_history_var(vname='FATES_STRUCTCTURNOVER_UNDERSTORY_SZ', & + units = 'kg m-2 s-1', & + long='structural C turnover for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_bdead_md_understory_si_scls) + + call this%set_history_var(vname='FATES_SAPWOODCTURNOVER_UNDERSTORY_SZ', & + units = 'kg m-2 s-1', & + long='sapwood C turnover for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_bsw_md_understory_si_scls) + + call this%set_history_var(vname='FATES_SEED_PROD_UNDERSTORY_SZ', & + units = 'kg m-2 s-1', & + long='seed production of understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_seed_prod_understory_si_scls) + + call this%set_history_var(vname='FATES_NPP_LEAF_UNDERSTORY_SZ', & + units = 'kg m-2 s-1', & + long='NPP flux into leaves for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_leaf_understory_si_scls) + + call this%set_history_var(vname='FATES_NPP_FROOT_UNDERSTORY_SZ', & + units = 'kg m-2 s-1', & + long='NPP flux into fine roots for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_fnrt_understory_si_scls) + + call this%set_history_var(vname='FATES_NPP_SAPWOOD_UNDERSTORY_SZ', & + units = 'kg m-2 s-1', & + long='NPP flux into sapwood C for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_sapw_understory_si_scls) + + call this%set_history_var(vname='FATES_NPP_STRUCT_UNDERSTORY_SZ', & + units = 'kg m-2 s-1', & + long='NPP flux into structural C for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_dead_understory_si_scls) + + call this%set_history_var(vname='FATES_NPP_SEED_UNDERSTORY_SZ', & + units = 'kg m-2 s-1', & + long='NPP flux into reproductive C for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_seed_understory_si_scls) + + call this%set_history_var(vname='FATES_NPP_STORE_UNDERSTORY_SCLS', & + units = 'kg m-2 s-1', & + long='NPP flux into storage C for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_stor_understory_si_scls) + + call this%set_history_var(vname='FATES_AUTO_RESP_MAINT_UNDERSTORY_SZ', & + units = 'kg m-2 s-1', & + long='maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_rdark_understory_si_scls) + + call this%set_history_var(vname='FATES_AUTO_RESP_LIVESTEMMAINT_UNDERSTORY_SZ', & + units = 'kg m-2 s-1', & + long='live stem maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, & + index = ih_livestem_mr_understory_si_scls) + + call this%set_history_var(vname='FATES_AUTO_RESP_CROOTMAINT_UNDERSTORY_SZ', & + units = 'kg m-2 s-1', & + long='live coarse root maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, & + index = ih_livecroot_mr_understory_si_scls) + + call this%set_history_var(vname='FATES_AUTO_RESP_FROOTMAINT_UNDERSTORY_SZ', & + units = 'kg m-2 s-1', & + long='fine root maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, & + index = ih_froot_mr_understory_si_scls) + + call this%set_history_var(vname='FATES_AUTO_RESP_GROW_UNDERSTORY_SZ', & + units = 'kg m-2 s-1', & + long='growth autotrophic respiration of understory plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_resp_g_understory_si_scls) + + call this%set_history_var(vname='FATES_AUTO_RESP_MAINT_UNDERSTORY_SZ', & + units = 'kg m-2 s-1', & + long='maintenance autotrophic respiration of understory plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_resp_m_understory_si_scls) ! CARBON BALANCE VARIABLES THAT DEPEND ON HLM BGC INPUTS - call this%set_history_var(vname='NEP', units='gC/m^2/s', & - long='net ecosystem production', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_nep_si ) - - call this%set_history_var(vname='FATES_HR', units='gC/m^2/s', & - long='heterotrophic respiration', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_hr_si ) - - call this%set_history_var(vname='Fire_Closs', units='gC/m^2/s', & - long='ED/SPitfire Carbon loss to atmosphere', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - 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', & - 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', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cbal_err_fates_si ) - - call this%set_history_var(vname='ERROR_FATES', units='mg/day', & - long='total error, FATES mass-balance', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_err_fates_si ) - - call this%set_history_var(vname='LITTER_FINES_AG_ELEM', units='kg ha-1', & - long='mass of above ground litter in fines (leaves,nonviable seed)', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fines_ag_elem ) - - call this%set_history_var(vname='LITTER_FINES_BG_ELEM', units='kg ha-1', & - long='mass of below ground litter in fines (fineroots)', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fines_bg_elem ) - - call this%set_history_var(vname='LITTER_CWD_BG_ELEM', units='kg ha-1', & - long='mass of below ground litter in CWD (coarse roots)', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_elem ) - - call this%set_history_var(vname='LITTER_CWD_AG_ELEM', units='kg ha-1', & - long='mass of above ground litter in CWD (trunks/branches/twigs)', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_elem ) - - call this%set_history_var(vname='LITTER_CWD', units='kg ha-1', & - long='total mass of litter in CWD', use_default='active', & - avgflag='A', vtype=site_elcwd_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_elcwd ) + call this%set_history_var(vname='FATES_NEP', units='kg m-2 s-1', & + long='net ecosystem production in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_nep_si) - ! Mass states C/N/P SCPF dimensions - ! CARBON - call this%set_history_var(vname='TOTVEGC_SCPF', units='kgC/ha', & - long='total vegetation carbon mass in live plants by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_totvegc_scpf ) - - call this%set_history_var(vname='LEAFC_SCPF', units='kgC/ha', & - long='leaf carbon mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leafc_scpf ) - - call this%set_history_var(vname='FNRTC_SCPF', units='kgC/ha', & - long='fine-root carbon mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fnrtc_scpf ) - - call this%set_history_var(vname='SAPWC_SCPF', units='kgC/ha', & - long='sapwood carbon mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sapwc_scpf ) - - call this%set_history_var(vname='STOREC_SCPF', units='kgC/ha', & - long='storage carbon mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storec_scpf ) - - call this%set_history_var(vname='REPROC_SCPF', units='kgC/ha', & - long='reproductive carbon mass (on plant) by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_reproc_scpf ) - - call this%set_history_var(vname='CEFFLUX_SCPF', units='kg/ha/day', & - long='carbon efflux, root to soil, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cefflux_scpf ) + call this%set_history_var(vname='FATES_HET_RESP', units='kg m-2 s-1', & + long='heterotrophic respiration in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_hr_si) - ! NITROGEN - nitrogen_active_if2: if(any(element_list(:)==nitrogen_element)) then - call this%set_history_var(vname='TOTVEGN_SCPF', units='kgN/ha', & - long='total (live) vegetation nitrogen mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_totvegn_scpf ) + call this%set_history_var(vname='FATES_FIRE_CLOSS', units='kg m-2 s-1', & + long='carbon loss to atmosphere from fire in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fire_c_to_atm_si) - call this%set_history_var(vname='LEAFN_SCPF', units='kgN/ha', & - long='leaf nitrogen mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leafn_scpf ) + call this%set_history_var(vname='FATES_FIRE_FLUX_EL', units='kg m-2 s-1', & + long='loss to atmosphere from fire by element in kg element per m2 per s', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_burn_flux_elem) - call this%set_history_var(vname='FNRTN_SCPF', units='kgN/ha', & - long='fine-root nitrogen mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fnrtn_scpf ) + call this%set_history_var(vname='FATES_CBALANCE_ERROR', & + units='kg s-1', & + long='total carbon error in kg carbon per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_cbal_err_fates_si) - call this%set_history_var(vname='SAPWN_SCPF', units='kgN/ha', & - long='sapwood nitrogen mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sapwn_scpf ) + call this%set_history_var(vname='FATES_ERROR_EL', units='kg s-1', & + long='total mass-balance error in kg per second by element', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_err_fates_si) - call this%set_history_var(vname='STOREN_SCPF', units='kgN/ha', & - long='storage nitrogen mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storen_scpf ) + call this%set_history_var(vname='FATES_LITTER_AG_FINE_EL', units='kg m-2', & + long='mass of aboveground litter in fines (leaves, nonviable seed) by element', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_fines_ag_elem) - call this%set_history_var(vname='STOREN_TFRAC_CANOPY_SCPF', units='kgN/ha', & - long='storage nitrogen fraction of target,in canopy, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storentfrac_canopy_scpf ) + call this%set_history_var(vname='FATES_LITTER_BG_FINE_EL', units='kg m-2', & + long='mass of belowground litter in fines (fineroots) by element', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_fines_bg_elem) - call this%set_history_var(vname='STOREN_TFRAC_UNDERSTORY_SCPF', units='kgN/ha', & - long='storage nitrogen fraction of target,in understory, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storentfrac_understory_scpf ) + call this%set_history_var(vname='FATES_LITTER_BG_CWD_EL', units='kg m-2', & + long='mass of belowground litter in coarse woody debris (coarse roots) by element', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cwd_bg_elem) - call this%set_history_var(vname='REPRON_SCPF', units='kgN/ha', & - long='reproductive nitrogen mass (on plant) by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_repron_scpf ) + call this%set_history_var(vname='FATES_LITTER_AG_CWD_EL', units='kg m-2', & + long='mass of aboveground litter in coarse woody debris (trunks/branches/twigs) by element', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cwd_ag_elem) - call this%set_history_var(vname='NH4UPTAKE_SCPF', units='kgN d-1 ha-1', & - long='Ammonium uptake rate by plants, size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nh4uptake_scpf ) + call this%set_history_var(vname='FATES_LITTER_CWD_ELDC', units='kg m-2', & + long='total mass of litter in coarse woody debris by element and coarse woody debris size', & + use_default='active', avgflag='A', vtype=site_elcwd_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cwd_elcwd) - call this%set_history_var(vname='NO3UPTAKE_SCPF', units='kgN d-1 ha-1', & - long='Nitrate uptake rate by plants, size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_no3uptake_scpf ) + ! Mass states C/N/P SCPF dimensions + ! CARBON + call this%set_history_var(vname='FATES_VEGC_SZPF', units='kg m-2', & + long='total vegetation biomass in live plants by size-class x pft in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_totvegc_scpf) - call this%set_history_var(vname='NEFFLUX_SCPF', units='kgN d-1 ha-1', & - long='nitrogen efflux, root to soil, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nefflux_scpf ) + call this%set_history_var(vname='FATES_LEAFC_SZPF', units='kg m-2', & + long='leaf carbon mass by size-class x pft in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_leafc_scpf) - call this%set_history_var(vname='NNEED_SCPF', units='kgN d-1 ha-1', & - long='plant N need (algorithm dependent), by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nneed_scpf ) + call this%set_history_var(vname='FATES_FROOTC_SZPF', units='kg m-2', & + long='fine-root carbon mass by size-class x pft in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fnrtc_scpf) + + call this%set_history_var(vname='FATES_SAPWOODC_SZPF', units='kg m-2', & + long='sapwood carbon mass by size-class x pft in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_sapwc_scpf) + + call this%set_history_var(vname='FATES_STOREC_SZPF', units='kg m-2', & + long='storage carbon mass by size-class x pft in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_storec_scpf) + + call this%set_history_var(vname='FATES_REPROC_SZPF', units='kg m-2', & + long='reproductive carbon mass (on plant) by size-class x pft in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_reproc_scpf) + + call this%set_history_var(vname='FATES_CEFFLUX_SZPF', units='kg m-2 s-1', & + long='carbon efflux, root to soil, by size-class x pft in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_cefflux_scpf) + + ! NITROGEN + + nitrogen_active_if2: if(any(element_list(:)==nitrogen_element)) then + + call this%set_history_var(vname='FATES_VEGN_SZPF', units='kg m-2', & + long='total (live) vegetation nitrogen mass by size-class x pft in kg N per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_totvegn_scpf) + + call this%set_history_var(vname='FATES_LEAFN_SZPF', units='kg m-2', & + long='leaf nitrogen mass by size-class x pft in kg N per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_leafn_scpf) + + call this%set_history_var(vname='FATES_FROOTN_SZPF', units='kg m-2', & + long='fine-root nitrogen mass by size-class x pft in kg N per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_fnrtn_scpf) + + call this%set_history_var(vname='FATES_SAPWOODN_SZPF', units='kg m-2', & + long='sapwood nitrogen mass by size-class x pft in kg N per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_sapwn_scpf) + + call this%set_history_var(vname='FATES_STOREN_SZPF', units='kg m-2', & + long='storage nitrogen mass by size-class x pft in kg N per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_storen_scpf) + + call this%set_history_var(vname='FATES_STOREN_TFRAC_CANOPY_SZPF', & + units='1', & + long='storage nitrogen fraction (0-1) of target, in canopy, by size-class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_storentfrac_canopy_scpf) + + call this%set_history_var(vname='FATES_STOREN_TFRAC_UNDERSTORY_SZPF', & + units='1', & + long='storage nitrogen fraction (0-1) of target, in understory, by size-class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_storentfrac_understory_scpf) + + call this%set_history_var(vname='FATES_REPRON_SZPF', units='kg m-2', & + long='reproductive nitrogen mass (on plant) by size-class x pft in kg N per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_repron_scpf) + + call this%set_history_var(vname='FATES_NH4UPTAKE_SZPF', & + units='kg m-2 s-1', & + long='ammonium uptake rate by plants by size-class x pft in kg NH4 per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nh4uptake_scpf) + + call this%set_history_var(vname='FATES_NO3UPTAKE_SZPF', & + units='kg m-2 s-1', & + long='nitrate uptake rate by plants by size-class x pft in kg NO3 per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_no3uptake_scpf) + + call this%set_history_var(vname='FATES_NEFFLUX_SZPF', units='kg m-2 s-1', & + long='nitrogen efflux, root to soil, by size-class x pft in kg N per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nefflux_scpf) + + call this%set_history_var(vname='FATES_NNEED_SZPF', units='kg m-2 s-1', & + long='plant N need (algorithm dependent), by size-class x pft in kg N per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nneed_scpf) end if nitrogen_active_if2 ! PHOSPHORUS + phosphorus_active_if2: if(any(element_list(:)==phosphorus_element))then - call this%set_history_var(vname='TOTVEGP_SCPF', units='kgP/ha', & - long='total (live) vegetation phosphorus mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_totvegp_scpf ) - call this%set_history_var(vname='LEAFP_SCPF', units='kgP/ha', & + call this%set_history_var(vname='FATES_VEGP_SZPF', units='kg m-2', & + long='total (live) vegetation phosphorus mass by size-class x pft in kg P per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_totvegp_scpf) + + call this%set_history_var(vname='FATES_LEAFP_SZPF', units='kg m-2', & long='leaf phosphorus mass by size-class x pft', use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leafp_scpf ) - call this%set_history_var(vname='FNRTP_SCPF', units='kgP/ha', & - long='fine-root phosphorus mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fnrtp_scpf ) - - call this%set_history_var(vname='SAPWP_SCPF', units='kgP/ha', & - long='sapwood phosphorus mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sapwp_scpf ) - - call this%set_history_var(vname='STOREP_SCPF', units='kgP/ha', & - long='storage phosphorus mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storep_scpf ) + call this%set_history_var(vname='FATES_FROOTP_SZPF', units='kg m-2', & + long='fine-root phosphorus mass by size-class x pft in kg P per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_fnrtp_scpf) + + call this%set_history_var(vname='FATES_SAPWOODP_SZPF', units='kg m-2', & + long='sapwood phosphorus mass by size-class x pft in kg P per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_sapwp_scpf) + + call this%set_history_var(vname='FATES_STOREP_SZPF', units='kg m-2', & + long='storage phosphorus mass by size-class x pft in kg P per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_storep_scpf) + + call this%set_history_var(vname='FATES_STOREP_TFRAC_CANOPY_SZPF', & + units='1', & + long='storage phosphorus fraction (0-1) of target, in canopy, by size-class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_storeptfrac_canopy_scpf) + + call this%set_history_var(vname='FATES_STOREP_TFRAC_UNDERSTORY_SZPF', & + units='1', & + long='storage phosphorus fraction (0-1) of target, in understory, by size-class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_storeptfrac_understory_scpf) + + call this%set_history_var(vname='FATES_REPROP_SZPF', units='kg m-2', & + long='reproductive phosphorus mass (on plant) by size-class x pft in kg P per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_reprop_scpf) + + call this%set_history_var(vname='FATES_PUPTAKE_SZPF', & + units='kg m-2 s-1', & + long='phosphorus uptake rate by plants, by size-class x pft in kg P per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_puptake_scpf) + + call this%set_history_var(vname='FATES_PEFFLUX_SZPF', & + units='kg m-2 s-1', & + long='phosphorus efflux, root to soil, by size-class x pft in kg P per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_pefflux_scpf) + + call this%set_history_var(vname='FATES_PNEED_SZPF', units='kg m-2 s-1', & + long='plant P need (algorithm dependent), by size-class x pft in kg P per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_pneed_scpf) - call this%set_history_var(vname='STOREP_TFRAC_CANOPY_SCPF', units='kgN/ha', & - long='storage phosphorus fraction of target,in canopy, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storeptfrac_canopy_scpf ) + end if phosphorus_active_if2 - call this%set_history_var(vname='STOREP_TFRAC_UNDERSTORY_SCPF', units='kgN/ha', & - long='storage phosphorus fraction of target,in understory, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storeptfrac_understory_scpf ) + ! organ-partitioned NPP / allocation fluxes - call this%set_history_var(vname='REPROP_SCPF', units='kgP/ha', & - long='reproductive phosphorus mass (on plant) by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_reprop_scpf ) + call this%set_history_var(vname='FATES_NPP_LEAF', units='kg m-2 s-1', & + long='NPP flux into leaves in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_leaf_si) - call this%set_history_var(vname='PUPTAKE_SCPF', units='kg/ha/day', & - long='phosphorus uptake rate by plants, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_puptake_scpf ) + call this%set_history_var(vname='FATES_NPP_SEED', units='kg m-2 s-1', & + long='NPP flux into seeds in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_seed_si) - call this%set_history_var(vname='PEFFLUX_SCPF', units='kg/ha/day', & - long='phosphorus efflux, root to soil, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_pefflux_scpf ) + call this%set_history_var(vname='FATES_NPP_STEM', units='kg m-2 s-1', & + long='NPP flux into stem in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_stem_si) - call this%set_history_var(vname='PNEED_SCPF', units='kg/ha/day', & - long='plant P need (algorithm dependent), by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_pneed_scpf ) + call this%set_history_var(vname='FATES_NPP_FROOT', units='kg m-2 s-1', & + long='NPP flux into fine roots in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_froot_si) - end if phosphorus_active_if2 + call this%set_history_var(vname='FATES_NPP_CROOT', units='kg m-2 s-1', & + long='NPP flux into coarse roots in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_croot_si) - ! organ-partitioned NPP / allocation fluxes - call this%set_history_var(vname='NPP_LEAF', units='kgC/m2/yr', & - long='NPP flux into leaves', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_si ) - - call this%set_history_var(vname='NPP_SEED', units='kgC/m2/yr', & - long='NPP flux into seeds', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_seed_si ) - - call this%set_history_var(vname='NPP_STEM', units='kgC/m2/yr', & - long='NPP flux into stem', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stem_si ) - - call this%set_history_var(vname='NPP_FROOT', units='kgC/m2/yr', & - long='NPP flux into fine roots', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_froot_si ) - - call this%set_history_var(vname='NPP_CROOT', units='kgC/m2/yr', & - long='NPP flux into coarse roots', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_croot_si ) - - call this%set_history_var(vname='NPP_STOR', units='kgC/m2/yr', & - long='NPP flux into storage tissues', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stor_si ) + call this%set_history_var(vname='FATES_NPP_STORE', units='kg m-2 s-1', & + long='NPP flux into storage tissues in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_stor_si) ! PLANT HYDRAULICS From 5222913a5d629b25c6fce83a0a566ef7f6dbb08a Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Sat, 9 Oct 2021 13:32:09 -0600 Subject: [PATCH 420/578] updates to history variables --- main/EDMainMod.F90 | 46 +-- main/FatesHistoryInterfaceMod.F90 | 461 ++++++++++++++++-------------- 2 files changed, 278 insertions(+), 229 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 48820e5ad6..7aa733989d 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -467,29 +467,35 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) io_si = currentSite%h_gid - fates_hist%hvars(ih_nh4uptake_scpf)%r82d(io_si,iscpf) = & - fates_hist%hvars(ih_nh4uptake_scpf)%r82d(io_si,iscpf) + & - currentCohort%daily_nh4_uptake*currentCohort%n + fates_hist%hvars(ih_nh4uptake_scpf)%r82d(io_si,iscpf) = & + fates_hist%hvars(ih_nh4uptake_scpf)%r82d(io_si,iscpf) + & + currentCohort%daily_nh4_uptake*currentCohort%n / & + m2_per_ha / sec_per_day - fates_hist%hvars(ih_no3uptake_scpf)%r82d(io_si,iscpf) = & - fates_hist%hvars(ih_no3uptake_scpf)%r82d(io_si,iscpf) + & - currentCohort%daily_no3_uptake*currentCohort%n + fates_hist%hvars(ih_no3uptake_scpf)%r82d(io_si,iscpf) = & + fates_hist%hvars(ih_no3uptake_scpf)%r82d(io_si,iscpf) + & + currentCohort%daily_no3_uptake*currentCohort%n / & + m2_per_ha / sec_per_day - fates_hist%hvars(ih_puptake_scpf)%r82d(io_si,iscpf) = & - fates_hist%hvars(ih_puptake_scpf)%r82d(io_si,iscpf) + & - currentCohort%daily_p_uptake*currentCohort%n + fates_hist%hvars(ih_puptake_scpf)%r82d(io_si,iscpf) = & + fates_hist%hvars(ih_puptake_scpf)%r82d(io_si,iscpf) + & + currentCohort%daily_p_uptake*currentCohort%n / & + m2_per_ha / sec_per_day - fates_hist%hvars(ih_nh4uptake_si)%r81d(io_si) = & - fates_hist%hvars(ih_nh4uptake_si)%r81d(io_si) + & - currentCohort%daily_nh4_uptake*currentCohort%n + fates_hist%hvars(ih_nh4uptake_si)%r81d(io_si) = & + fates_hist%hvars(ih_nh4uptake_si)%r81d(io_si) + & + currentCohort%daily_nh4_uptake*currentCohort%n / & + m2_per_ha / sec_per_day - fates_hist%hvars(ih_no3uptake_si)%r81d(io_si) = & - fates_hist%hvars(ih_no3uptake_si)%r81d(io_si) + & - currentCohort%daily_no3_uptake*currentCohort%n + fates_hist%hvars(ih_no3uptake_si)%r81d(io_si) = & + fates_hist%hvars(ih_no3uptake_si)%r81d(io_si) + & + currentCohort%daily_no3_uptake*currentCohort%n / & + m2_per_ha / sec_per_day - fates_hist%hvars(ih_puptake_si)%r81d(io_si) = & - fates_hist%hvars(ih_puptake_si)%r81d(io_si) + & - currentCohort%daily_p_uptake*currentCohort%n + fates_hist%hvars(ih_puptake_si)%r81d(io_si) = & + fates_hist%hvars(ih_puptake_si)%r81d(io_si) + & + currentCohort%daily_p_uptake*currentCohort%n / & + m2_per_ha / sec_per_day ! Diagnostics on efflux, size and pft [kgX/ha/day] @@ -948,7 +954,3 @@ subroutine bypass_dynamics(currentSite) end subroutine bypass_dynamics end module EDMainMod - - - - diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 20fbb3adb7..27c8d14ccb 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2601,7 +2601,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_sai_canopy_si_scls(io_si,scls) = hio_sai_canopy_si_scls(io_si,scls) + & ccohort%treesai*ccohort%c_area * AREA_INV hio_trimming_canopy_si_scls(io_si,scls) = hio_trimming_canopy_si_scls(io_si,scls) + & - ccohort%n * ccohort%canopy_trim + ccohort%n * ccohort%canopy_trim / m2_per_ha hio_crown_area_canopy_si_scls(io_si,scls) = hio_crown_area_canopy_si_scls(io_si,scls) + & ccohort%c_area / m2_per_ha hio_gpp_canopy_si_scpf(io_si,scpf) = hio_gpp_canopy_si_scpf(io_si,scpf) + & @@ -2694,7 +2694,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_sai_understory_si_scls(io_si,scls) = hio_sai_understory_si_scls(io_si,scls) + & ccohort%treelai*ccohort%c_area * AREA_INV hio_trimming_understory_si_scls(io_si,scls) = hio_trimming_understory_si_scls(io_si,scls) + & - ccohort%n * ccohort%canopy_trim + ccohort%n * ccohort%canopy_trim / m2_per_ha hio_crown_area_understory_si_scls(io_si,scls) = hio_crown_area_understory_si_scls(io_si,scls) + & ccohort%c_area / m2_per_ha hio_gpp_understory_si_scpf(io_si,scpf) = hio_gpp_understory_si_scpf(io_si,scpf) + & @@ -4005,7 +4005,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) mean_soil_matpot = mean_soil_matpot + psi*layer_areaweight areaweight = areaweight + layer_areaweight - hio_soilmatpot_sl(io_si,jsoil) = psi + hio_soilmatpot_sl(io_si,jsoil) = psi * pa_per_mpa hio_soilvwc_sl(io_si,jsoil) = vwc hio_soilvwcsat_sl(io_si,jsoil) = vwc_sat @@ -4013,12 +4013,13 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) 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_rootwgt_soilmatpot_si(io_si) = mean_soil_matpot/areaweight * pa_per_mpa - hio_rootuptake_si(io_si) = sum(site_hydr%rootuptake_sl,dim=1) + hio_rootuptake_si(io_si) = sum(site_hydr%rootuptake_sl,dim=1) / m2_per_ha 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) + hio_rootuptake_sl(io_si,jr1:jr2) = site_hydr%rootuptake_sl(1:nlevrhiz) / + m2_per_ha + hio_rootuptake_si(io_si) = sum(site_hydr%sapflow_scpf) / m2_per_ha ! Normalization counters nplant_scpf(:) = 0._r8 @@ -4059,11 +4060,11 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) 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) + hio_sapflow_scpf(io_si,iscpf) = site_hydr%sapflow_scpf(iscls, ipft) / m2_per_ha + hio_rootuptake0_scpf(io_si,iscpf) = site_hydr%rootuptake0_scpf(iscls,ipft) / m2_per_ha + hio_rootuptake10_scpf(io_si,iscpf) = site_hydr%rootuptake10_scpf(iscls,ipft) / m2_per_ha + hio_rootuptake50_scpf(io_si,iscpf) = site_hydr%rootuptake50_scpf(iscls,ipft) / m2_per_ha + hio_rootuptake100_scpf(io_si,iscpf) = site_hydr%rootuptake100_scpf(iscls,ipft) / m2_per_ha hio_iterh1_scpf(io_si,iscpf) = 0._r8 hio_iterh2_scpf(io_si,iscpf) = 0._r8 end do @@ -4120,16 +4121,16 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) sum(ccohort_hydr%v_aroot_layer(:)) hio_awp_scpf(io_si,iscpf) = hio_awp_scpf(io_si,iscpf) + & - mean_aroot * number_fraction ! [MPa] + mean_aroot * number_fraction * pa_per_mpa ! [Pa] hio_twp_scpf(io_si,iscpf) = hio_twp_scpf(io_si,iscpf) + & - ccohort_hydr%psi_troot * number_fraction ! [MPa] + ccohort_hydr%psi_troot * number_fraction * pa_per_mpa ! [Pa] hio_swp_scpf(io_si,iscpf) = hio_swp_scpf(io_si,iscpf) + & - ccohort_hydr%psi_ag(2) * number_fraction ! [MPa] + ccohort_hydr%psi_ag(2) * number_fraction * pa_per_mpa ! [Pa] 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 * pa_per_mpa ! [Pa] mean_aroot = sum(ccohort_hydr%ftc_aroot(:)*ccohort_hydr%v_aroot_layer(:)) / & sum(ccohort_hydr%v_aroot_layer(:)) @@ -4633,7 +4634,7 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_fuel_amount_si_fuel) - call this%set_history_var(vname='FATES_FUEL_AMOUNT_FCAF', units='kg m-2', & + call this%set_history_var(vname='FATES_FUEL_AMOUNT_APFC', units='kg m-2', & long='spitfire fuel quantity in each age x fuel class in kg carbon per m2 land area', & use_default='inactive', avgflag='A', vtype=site_agefuel_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & @@ -5205,13 +5206,13 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_fabd_sha_si_cnlf) - call this%set_history_var(vname='FATES_FABI_SUN_CLL', units='1', & + call this%set_history_var(vname='FATES_FABI_SUN_CLLL', units='1', & long='sun fraction of indirect light absorbed by each canopy and leaf layer', & use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_fabi_sun_si_cnlf) - call this%set_history_var(vname='FATES_FABI_SHA_CLL', units='1', & + call this%set_history_var(vname='FATES_FABI_SHA_CLLL', units='1', & long='shade fraction of indirect light absorbed by each canopy and leaf layer', & use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & @@ -5280,7 +5281,7 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_crownarea_si_cnlf) - call this%set_history_var(vname='FATES_CROWNAREA_CL', units='m2/m2', & + call this%set_history_var(vname='FATES_CROWNAREA_CL', units='m2 m-2', & long='total crown area in each canopy layer', use_default='active', & avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_crownarea_si_can) @@ -5317,47 +5318,47 @@ subroutine define_history_vars(this, initialize_variables) ! size class by age dimensioned variables - call this%set_history_var(vname='FATES_NPLANT_SZAC', units = 'm-2', & + call this%set_history_var(vname='FATES_NPLANT_APSZ', units = 'm-2', & long='number of plants per m2 in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_nplant_si_scag) - call this%set_history_var(vname='FATES_NPLANT_CANOPY_SZAC', units = 'm-2', & + call this%set_history_var(vname='FATES_NPLANT_CANOPY_APSZ', units = 'm-2', & long='number of plants per m2 in canopy in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_nplant_canopy_si_scag) - call this%set_history_var(vname='FATES_NPLANT_UNDERSTORY_SZAC', & + call this%set_history_var(vname='FATES_NPLANT_UNDERSTORY_APSZ', & units = 'm-2', & long='number of plants per m2 in understory in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_nplant_understory_si_scag) - call this%set_history_var(vname='FATES_DDBH_CANOPY_SZAC', & + call this%set_history_var(vname='FATES_DDBH_CANOPY_APSZ', & units = 'm m-2 yr-1', & long='growth rate of canopy plants in meters DBH per m2 per year in canopy in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_ddbh_canopy_si_scag) - call this%set_history_var(vname='FATES_DDBH_UNDERSTORY_SZAC', & + call this%set_history_var(vname='FATES_DDBH_UNDERSTORY_APSZ', & units = 'm m-2 yr-1', & long='growth rate of understory plants in meters DBH per m2 per year in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_ddbh_understory_si_scag) - call this%set_history_var(vname='FATES_MORTALITY_CANOPY_SZAC', & + call this%set_history_var(vname='FATES_MORTALITY_CANOPY_APSZ', & units = 'm-2 yr-1', & long='mortality rate of canopy plants in number of plants per m2 per year in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_mortality_canopy_si_scag) - call this%set_history_var(vname='FATES_MORTALITY_UNDERSTORY_SZAC', & + call this%set_history_var(vname='FATES_MORTALITY_UNDERSTORY_APSZ', & units = 'm-2 yr-1', & long='mortality rate of understory plants in number of plants per m2 per year in each size x age class', use_default='inactive', avgflag='A', vtype=site_scag_r8, & @@ -5366,26 +5367,26 @@ subroutine define_history_vars(this, initialize_variables) ! size x age x pft dimensioned - call this%set_history_var(vname='FATES_NPLANT_SZACPF',units = 'm-2', & + call this%set_history_var(vname='FATES_NPLANT_APSZPF',units = 'm-2', & long='number of plants per m2 in each size x age x pft class', & use_default='inactive', avgflag='A', vtype=site_scagpft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_nplant_si_scagpft) ! age x pft dimensioned - call this%set_history_var(vname='FATES_NPP_ACPF',units = 'kg m-2 s-1', & + call this%set_history_var(vname='FATES_NPP_APPF',units = 'kg m-2 s-1', & long='NPP per PFT in each age bin in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_agepft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_npp_si_agepft) - call this%set_history_var(vname='FATES_VEGC_ACPF',units = 'kg m-2', & + call this%set_history_var(vname='FATES_VEGC_APPF',units = 'kg m-2', & long='biomass per PFT in each age bin in kg carbon per m2', & use_default='inactive', avgflag='A', vtype=site_agepft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_biomass_si_agepft) - call this%set_history_var(vname='FATES_SCORCH_HEIGHT_ACPF',units = 'm', & + call this%set_history_var(vname='FATES_SCORCH_HEIGHT_APPF',units = 'm', & long='SPITFIRE flame Scorch Height (calculated per PFT in each patch age bin)', & use_default='inactive', avgflag='A', vtype=site_agepft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & @@ -5960,7 +5961,7 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_m7_si_scls) - call this%set_history_var(vname='FATES_MORTALITY_FREEZING_SZPF', & + call this%set_history_var(vname='FATES_MORTALITY_FREEZING_SZ', & units = 'm-2 event-1', & long='freezing mortality by size in number of plants per m2 per event', & use_default='active', avgflag='A', vtype=site_size_r8, & @@ -6010,15 +6011,19 @@ subroutine define_history_vars(this, initialize_variables) initialize=initialize_variables, & index = ih_mortality_understory_si_scls) - call this%set_history_var(vname='TRIMMING_CANOPY_SCLS', units = 'indiv/ha', & - long='trimming term of canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_trimming_canopy_si_scls ) + call this%set_history_var(vname='FATES_TRIMMING_CANOPY_SZ', units = 'm-2', & + long='trimming term of canopy plants weighted by plant density, by size class', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_trimming_canopy_si_scls) - call this%set_history_var(vname='TRIMMING_UNDERSTORY_SCLS', units = 'indiv/ha', & - long='trimming term of understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_trimming_understory_si_scls ) + call this%set_history_var(vname='FATES_TRIMMING_UNDERSTORY_SZ', & + units = 'm-2', & + long='trimming term of understory plants weighted by plant density, by size class', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_trimming_understory_si_scls) call this%set_history_var(vname='FATES_CROWNAREA_CANOPY_SZ', units = 'm2 m-2', & long='total crown area of canopy plants by size class', & @@ -6270,7 +6275,7 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_seed_understory_si_scls) - call this%set_history_var(vname='FATES_NPP_STORE_UNDERSTORY_SCLS', & + call this%set_history_var(vname='FATES_NPP_STORE_UNDERSTORY_SZ', & units = 'kg m-2 s-1', & long='NPP flux into storage C for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & @@ -6638,28 +6643,31 @@ subroutine define_history_vars(this, initialize_variables) hydro_active_if: if(hlm_use_planthydro.eq.itrue) then - call this%set_history_var(vname='FATES_ERRH2O_SCPF', units='kg/indiv/s', & - long='mean individual water balance error', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_errh2o_scpf ) - - call this%set_history_var(vname='FATES_TRAN_SCPF', units='kg/indiv/s', & - long='mean individual transpiration rate', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_tran_scpf ) - - call this%set_history_var(vname='FATES_SAPFLOW_SCPF', units='kg/ha/s', & - long='areal sap flow rate dimensioned by size x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sapflow_scpf ) - - call this%set_history_var(vname='FATES_SAPFLOW_SI', units='kg/ha/s', & - long='areal sap flow rate', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sapflow_si ) - - - call this%set_history_var(vname='FATES_ITERH1_SCPF', units='count/indiv/step', & + call this%set_history_var(vname='FATES_ERRH2O_SZPF', units='kg s-1', & + long='mean individual water balance error in kg per individual per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_errh2o_scpf) + + call this%set_history_var(vname='FATES_TRAN_SZPF', units='kg s-1', & + long='mean individual transpiration rate in kg per individual per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_tran_scpf) + + call this%set_history_var(vname='FATES_SAPFLOW_SZPF', units='kg m-2 s-1', & + long='areal sap flow rate dimensioned by size x pft in kg per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_sapflow_scpf) + + call this%set_history_var(vname='FATES_SAPFLOW', units='kg m-2 s-1', & + long='areal sap flow rate in kg per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=4, ivar=ivar, initialize=initialize_variables, & + index = ih_sapflow_si) + + call this%set_history_var(vname='FATES_ITERH1_SZPF', units='count/indiv/step', & long='water balance error iteration diagnostic 1', & use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & @@ -6671,155 +6679,194 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_iterh2_scpf ) - 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', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_ath_scpf ) - - 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', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_tth_scpf ) - - 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', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sth_scpf ) - - 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', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_lth_scpf ) - - 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', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_awp_scpf ) - - 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', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_twp_scpf ) - - 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', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_swp_scpf ) - - 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', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_lwp_scpf ) - - 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', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_aflc_scpf ) - - 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', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_tflc_scpf ) - - 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', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sflc_scpf ) + call this%set_history_var(vname='FATES_ROOTH2O_ABS_SZPF', & + units='m3 m-3', & + long='absorbing volumetric root water content by size class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_ath_scpf) + + call this%set_history_var(vname='FATES_ROOTH2O_TRANS_SZPF', & + units='m3 m-3', & + long='transporting volumetric root water content by size class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_tth_scpf) + + call this%set_history_var(vname='FATES_STEMH2O_SZPF', units='m3 m-3', & + long='stem volumetric water content by size class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_sth_scpf) + + call this%set_history_var(vname='FATES_LEAFH2O_SZPF', units='m3 m-3', & + long='leaf volumetric water content by size class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_lth_scpf) + + call this%set_history_var(vname='FATES_ROOTH2O_POT_SZPF', units='Pa', & + long='absorbing root water potential by size class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_awp_scpf) + + call this%set_history_var(vname='FATES_ROOTH2O_TRANSPOT_SZPF', & + units='Pa', long='transporting root water potential by size class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_twp_scpf) + + call this%set_history_var(vname='FATES_STEMH2O_POT_SZPF', units='Pa', & + long='stem water potential by size class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_swp_scpf) + + call this%set_history_var(vname='FATES_LEAFH2O_POT_SZPF', units='Pa', & + long='leaf water potential by size class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_lwp_scpf) + + call this%set_history_var(vname='FATES_ROOT_ABSFRAC_SZPF', units='1', & + long='absorbing root fraction (0-1) of condutivity by size class x pft', & + use_default='active', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_aflc_scpf) + + call this%set_history_var(vname='FATES_ROOT_TRANSFRAC_SZPF', units='1', & + long='transporting root fraction (0-1) of condutivity by size class x pft', & + use_default='active', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_tflc_scpf) + + call this%set_history_var(vname='FATES_STEMH2O_FRAC_SZPF', units='1', & + long='stem water fraction (0-1) of condutivity by size class x pft', & + use_default='active', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_sflc_scpf) + + call this%set_history_var(vname='FATES_LEAFH2O_FRAC_SZPF', units='1', & + long='leaf water fraction (0-1) of condutivity by size class x pft', & + use_default='active', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_lflc_scpf) + + call this%set_history_var(vname='FATES_BTRAN_SZPF', units='1', & + long='mean individual level BTRAN by size class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_btran_scpf) + + call this%set_history_var(vname='FATES_ROOTWGT_SOILVWC', units='m3 m-3', & + long='soil volumetric water content, weighted by root area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=4, ivar=ivar, initialize=initialize_variables, & + index = ih_rootwgt_soilvwc_si) - 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', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_lflc_scpf ) + call this%set_history_var(vname='FATES_ROOTWGT_SOILVWCSAT', & + 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', & + upfreq=4, ivar=ivar, initialize=initialize_variables, & + index = ih_rootwgt_soilvwcsat_si) - 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', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_btran_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', & - 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', & - 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', & - 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', & - 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', & - 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', & - 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', & - 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', & - 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', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake0_scpf ) + call this%set_history_var(vname='FATES_ROOTWGT_SOILMATPOT', units='Pa', & + long='soil matric potential, weighted by root area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=4, ivar=ivar, initialize=initialize_variables, & + index = ih_rootwgt_soilmatpot_si) + + call this%set_history_var(vname='FATES_SOILMATPOT_SL', units='Pa', & + long='soil water matric potenial by soil layer', & + use_default='inactive', avgflag='A', vtype=site_ground_r8, & + hlms='CLM:ALM', 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', 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', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_soilvwcsat_sl) + + call this%set_history_var(vname='FATES_ROOTUPTAKE', units='kg m-2 s-1', & + long='root water uptake rate', use_default='active', avgflag='A', & + vtype=site_r8, hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_rootuptake_si) + + call this%set_history_var(vname='FATES_ROOTUPTAKE_SL', & + units='kg m-2 s-1', & + long='root water uptake rate by soil layer', & + use_default='inactive', avgflag='A', vtype=site_ground_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_rootuptake_sl) + + call this%set_history_var(vname='FATES_ROOTUPTAKE0_SZPF', & + units='kg m-2 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', 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', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake10_scpf ) + call this%set_history_var(vname='FATES_ROOTUPTAKE10_SZPF', & + units='kg m-2 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', 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', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake50_scpf ) + call this%set_history_var(vname='FATES_ROOTUPTAKE50_SZPF', & + units='kg m-2 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', 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', & - 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', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_si ) - - call this%set_history_var(vname='H2OVEG_DEAD', units = 'kg/m2', & - long='cumulative plant_stored_h2o in dead biomass due to mortality', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_dead_si ) - - call this%set_history_var(vname='H2OVEG_RECRUIT', units = 'kg/m2', & - long='amount of water in new recruits', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_recruit_si ) - - call this%set_history_var(vname='H2OVEG_GROWTURN_ERR', units = 'kg/m2', & - long='cumulative net borrowed (+) or lost (-) from plant_stored_h2o due to combined growth & turnover', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_growturn_err_si ) - - call this%set_history_var(vname='H2OVEG_HYDRO_ERR', units = 'kg/m2', & - long='cumulative net borrowed (+) from plant_stored_h2o due to plant hydrodynamics', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_hydro_err_si ) + call this%set_history_var(vname='FATES_ROOTUPTAKE100_SZPF', & + units='kg m-2 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', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_rootuptake100_scpf) + + call this%set_history_var(vname='FATES_VEGH2O', units = 'kg m-2', & + long='water stored inside vegetation tissues (leaf, stem, roots)', & + use_default='inactive', avgflag='A', vtype=site_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_h2oveg_si) + + call this%set_history_var(vname='FATES_VEGH2O_DEAD', units = 'kg m-2', & + long='cumulative water stored in dead biomass due to mortality', & + use_default='inactive', avgflag='A', vtype=site_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_h2oveg_dead_si) + + call this%set_history_var(vname='FATES_VEGH2O_RECRUIT', & + units = 'kg m-2', long='amount of water in new recruits', & + use_default='inactive', avgflag='A', vtype=site_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_h2oveg_recruit_si) + + call this%set_history_var(vname='FATES_VEGH2O_GROWTURN_ERR', & + units = 'kg m-2', & + long='cumulative net borrowed (+) or lost (-) from water storage due to combined growth & turnover', & + use_default='inactive', avgflag='A', vtype=site_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_h2oveg_growturn_err_si) + + call this%set_history_var(vname='FATES_VEGH2O_HYDRO_ERR', & + units = 'kg m-2', & + long='cumulative net borrowed (+) from plant_stored_h2o due to plant hydrodynamics', & + use_default='inactive', avgflag='A', vtype=site_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_h2oveg_hydro_err_si) end if hydro_active_if ! Must be last thing before return From 84b98e25b0b5b1954606378441fcd35b2c169676 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Sun, 10 Oct 2021 10:26:12 -0600 Subject: [PATCH 421/578] fix mortality units --- main/FatesHistoryInterfaceMod.F90 | 38 +++++++++++++++---------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 27c8d14ccb..865d754779 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2592,7 +2592,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%frmort + & ccohort%smort + ccohort%asmort) * ccohort%n + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * sec_per_day * days_per_year + ccohort%n * sec_per_day * days_per_year / m2_per_ha hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + ccohort%n / m2_per_ha hio_nplant_canopy_si_scls(io_si,scls) = hio_nplant_canopy_si_scls(io_si,scls) + ccohort%n / m2_per_ha @@ -2625,9 +2625,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * & - total_m * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + & + total_m * ccohort%n * days_per_sec * years_per_day * ha_per_m2 + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_m * & - ccohort%n * g_per_kg * ha_per_m2 + ccohort%n * ha_per_m2 hio_carbon_balance_canopy_si_scls(io_si,scls) = hio_carbon_balance_canopy_si_scls(io_si,scls) + & @@ -2719,9 +2719,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * & - total_m * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + & + total_m * ccohort%n * days_per_sec * years_per_day * ha_per_m2 + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_m * & - ccohort%n * g_per_kg * ha_per_m2 + ccohort%n * ha_per_m2 hio_carbon_balance_understory_si_scls(io_si,scls) = hio_carbon_balance_understory_si_scls(io_si,scls) + & ccohort%npp_acc_hold * ccohort%n / m2_per_ha @@ -2900,16 +2900,16 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! ! add termination mortality to canopy and understory mortality hio_mortality_canopy_si_scls(io_si,i_scls) = hio_mortality_canopy_si_scls(io_si,i_scls) + & - sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year + sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year / m2_per_ha hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & sites(s)%term_nindivs_ustory(i_scls,i_pft) * days_per_year / m2_per_ha hio_mortality_canopy_si_scpf(io_si,i_scpf) = hio_mortality_canopy_si_scpf(io_si,i_scpf) + & - sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year + sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year / m2_per_ha hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & - sites(s)%term_nindivs_ustory(i_scls,i_pft) * days_per_year + sites(s)%term_nindivs_ustory(i_scls,i_pft) * days_per_year / m2_per_ha ! ! imort on its own @@ -2920,13 +2920,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! cohorts that may have been promoted as part of the patch creation, and use the pre-calculated site-level ! values to avoid biasing the results by the dramatically-reduced number densities in cohorts that are subject to imort hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & - sites(s)%imort_rate(i_scls, i_pft) + sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha ! iscag = i_scls ! since imort is by definition something that only happens in newly disturbed patches, treat as such hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & - sites(s)%imort_rate(i_scls, i_pft) + sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha ! fire mortality from the site-level diagnostic rates hio_m5_si_scpf(io_si,i_scpf) = (sites(s)%fmort_rate_canopy(i_scls, i_pft) + & @@ -2940,14 +2940,14 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! ! fire components of overall canopy and understory mortality hio_mortality_canopy_si_scpf(io_si,i_scpf) = hio_mortality_canopy_si_scpf(io_si,i_scpf) + & - sites(s)%fmort_rate_canopy(i_scls, i_pft) + sites(s)%fmort_rate_canopy(i_scls, i_pft) / m2_per_ha hio_mortality_canopy_si_scls(io_si,i_scls) = hio_mortality_canopy_si_scls(io_si,i_scls) + & - sites(s)%fmort_rate_canopy(i_scls, i_pft) + sites(s)%fmort_rate_canopy(i_scls, i_pft) / m2_per_ha ! the fire mortality rates for each layer are total dead, since the usable ! output will then normalize by the counts, we are allowed to sum over layers hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & - sites(s)%fmort_rate_ustory(i_scls, i_pft) + sites(s)%fmort_rate_ustory(i_scls, i_pft) / m2_per_ha hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & sites(s)%fmort_rate_ustory(i_scls, i_pft) / m2_per_ha @@ -2955,18 +2955,18 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! ! carbon flux associated with mortality of trees dying by fire hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & - sites(s)%fmort_carbonflux_canopy + sites(s)%fmort_carbonflux_canopy / g_per_kg hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & - sites(s)%fmort_carbonflux_ustory + sites(s)%fmort_carbonflux_ustory / g_per_kg ! ! for scag variables, also treat as happening in the newly-disurbed patch hio_mortality_canopy_si_scag(io_si,iscag) = hio_mortality_canopy_si_scag(io_si,iscag) + & - sites(s)%fmort_rate_canopy(i_scls, i_pft) + sites(s)%fmort_rate_canopy(i_scls, i_pft) / m2_per_ha hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & - sites(s)%fmort_rate_ustory(i_scls, i_pft) + sites(s)%fmort_rate_ustory(i_scls, i_pft) / m2_per_ha ! while in this loop, pass the fusion-induced growth rate flux to history hio_growthflux_fusion_si_scpf(io_si,i_scpf) = hio_growthflux_fusion_si_scpf(io_si,i_scpf) + & @@ -2982,7 +2982,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! treat carbon flux from imort the same way hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & - sites(s)%imort_carbonflux + sites(s)%imort_carbonflux / g_per_kg ! sites(s)%term_nindivs_canopy(:,:) = 0._r8 sites(s)%term_nindivs_ustory(:,:) = 0._r8 @@ -3017,7 +3017,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m7_si_scpf(io_si,i_scpf) + & hio_m8_si_scpf(io_si,i_scpf) + & hio_m9_si_scpf(io_si,i_scpf) + & - hio_m10_si_scpf(io_si,i_scpf)) / m2_per_ha + hio_m10_si_scpf(io_si,i_scpf)) end do end do From 59d61e4859d866a7d00b827b1d983bc52b079e8d Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Sun, 10 Oct 2021 11:14:17 -0600 Subject: [PATCH 422/578] fix sapflow calculation --- main/FatesHistoryInterfaceMod.F90 | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 865d754779..51a491c4ab 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2047,7 +2047,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_err_fates_si(io_si,el) = sites(s)%mass_balance(el)%err_fates / sec_per_day - ! Total element lost to atmosphere from burning (kg/site/day -> g/m2/s) + ! Total element lost to atmosphere from burning (kg/site/day -> kg/m2/s) hio_burn_flux_elem(io_si,el) = & sites(s)%mass_balance(el)%burn_flux_to_atm * & ha_per_m2 * days_per_sec @@ -4019,7 +4019,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) hio_rootuptake_sl(io_si,:) = 0._r8 hio_rootuptake_sl(io_si,jr1:jr2) = site_hydr%rootuptake_sl(1:nlevrhiz) / m2_per_ha - hio_rootuptake_si(io_si) = sum(site_hydr%sapflow_scpf) / m2_per_ha + hio_sapflow_si(io_si) = sum(site_hydr%sapflow_scpf) / m2_per_ha ! Normalization counters nplant_scpf(:) = 0._r8 @@ -4498,8 +4498,8 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FATES_SECONDARY_FOREST_FRACTION', & units='m2 m-2', long='secondary forest fraction', & use_default='inactive', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - flushval=hlm_hio_ignore_val, upfreq=1, ivar=ivar, & - initialize=initialize_variables, index=ih_fraction_secondary_forest_si) + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_fraction_secondary_forest_si) call this%set_history_var(vname='FATES_WOOD_PRODUCT', units='kg m-2', & long='total wood product from logging in kg carbon per m2 land area', & From 20224fe84dc0c1332775d7eac1a41c7cc5451883 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 10 Oct 2021 21:25:37 -0400 Subject: [PATCH 423/578] Return step error cap to JDs previous setting, remove unused local variables --- biogeophys/FatesPlantHydraulicsMod.F90 | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 59b5ad630e..428f5f7d7a 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -232,7 +232,7 @@ module FatesPlantHydraulicsMod ! 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 ! original is 1.e-7_r8, Junyan changed to 2.e-7_r8 + real(r8), parameter :: max_wb_step_err = 2.e-7_r8 ! original is 1.e-7_r8, Junyan changed to 2.e-7_r8 ! ! !PUBLIC MEMBER FUNCTIONS: @@ -849,13 +849,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) real(r8) :: norm ! total root fraction used <1 integer :: nlevrhiz ! number of rhizosphere levels real(r8) :: dbh ! the dbh of current cohort [cm] - real(r8) :: dbh_0 ! the dbh of the sappling at recuitment [cm] - real(r8) :: dbh_max ! the dbh upon which the plant reaches maximum rooting depth [cm] - real(r8) :: dbh_rev ! the dbh represented as a linear fraction between dbh_0 and dbh_max real(r8) :: z_fr ! rooting depth of a cohort [cm] - real(r8) :: z_fr_0 ! the rooting depth of of the sappling, corresponding to dbh_0 [cm] - real(r8) :: z_fr_max ! the maximum rooting depth of a PFT [cm] - real(r8) :: frk ! the exponent parameter of the cohort rooting depth function, a PFT based parameter ! 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 From 59c0997bf6660be449bad964a3e4d27853da2868 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Mon, 11 Oct 2021 09:07:41 -0600 Subject: [PATCH 424/578] update to 0.0 flushval for testing --- main/FatesHistoryInterfaceMod.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 8434f35aaf..3aee3533c7 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1513,7 +1513,7 @@ subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype real(r8), :: flushval logical :: write_var - flushval = hlm_hio_ignore_val !for now do this (ACF 09/27/21) + flushval = 0.0_r8 !for now do this (ACF 09/27/21) ! we need to flush this to 0.0 in FATES write_var = check_hlm_list(trim(hlms), trim(hlm_name)) @@ -3795,7 +3795,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! PFT-mean radiation profiles do ican = 1, cpatch%ncl_p do ileaf = 1, maxval(cpatch%nrad(ican,:)) - + ! calculate where we are on multiplexed dimensions cnlf_indx = ileaf + (ican-1) * nlevleaf ! @@ -6144,9 +6144,9 @@ subroutine define_history_vars(this, initialize_variables) upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_livestem_mr_si) - call this%set_history_var(vname='FATES_AUTO_RESP_MAINT_CANOPY_SZ', & + call this%set_history_var(vname='FATES_AUTO_RESP_DARK_CANOPY_SZ', & units = 'kg m-2 s-1', & - long='maintenance autotrophic respiration for canopy plants in kg carbon per m2 per second by size', & + long='dark respiration for canopy plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, index = ih_rdark_canopy_si_scls) @@ -6277,9 +6277,9 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_stor_understory_si_scls) - call this%set_history_var(vname='FATES_AUTO_RESP_MAINT_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_AUTO_RESP_DARK_UNDERSTORY_SZ', & units = 'kg m-2 s-1', & - long='maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & + long='dark respiration for understory plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, index = ih_rdark_understory_si_scls) @@ -6668,7 +6668,7 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_iterh1_scpf ) - call this%set_history_var(vname='FATES_ITERH2_SCPF', units='count/indiv/step', & + call this%set_history_var(vname='FATES_ITERH2_SZPF', units='count/indiv/step', & long='water balance error iteration diagnostic 2', & use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & From 3322223f693a93f20a7e00f1e6cdb34381bf0ef0 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Mon, 11 Oct 2021 10:01:53 -0600 Subject: [PATCH 425/578] variable name updates --- main/FatesHistoryInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 3aee3533c7..c613227ce5 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1514,7 +1514,7 @@ subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype logical :: write_var flushval = 0.0_r8 !for now do this (ACF 09/27/21) - ! we need to flush this to 0.0 in FATES + ! we need to flush this to 0.0 in FATESs write_var = check_hlm_list(trim(hlms), trim(hlm_name)) if( write_var ) then From 57deae1e234774c66f2eeff49549acebdc8198f7 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 11 Oct 2021 12:55:10 -0400 Subject: [PATCH 426/578] prototype updated flushing --- main/FatesHistoryInterfaceMod.F90 | 71 ++++++++++++++++++++++++++++--- 1 file changed, 66 insertions(+), 5 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 3aee3533c7..a06d18022d 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -729,6 +729,7 @@ module FatesHistoryInterfaceMod procedure, private :: set_levelage_index procedure, public :: flush_hvars + procedure, public :: zero_site_hvars end type fates_history_interface_type @@ -1461,6 +1462,59 @@ end function levagefuel_index ! ====================================================================================== + + subroutine zero_site_hvars(this,nc,sites,upfreq_in) + + + ! This routine zero's a history diagnostic variable + ! but only zero's on fates sites + ! This should be called prior to filling the variable + ! and after they have been flushed to the ignore value + + class(fates_history_interface_type) :: this + integer,intent(in) :: nc + integer,intent(in) :: upfreq_in + type(ed_site_type),intent(in) :: sites(:) + + integer :: ivar + integer :: nsites + integer :: s ! fates site index (1:nsites) + integer :: ndims ! number of dimensions + + nsites = ubound(sites,1) + + do ivar=1,ubound(this%hvars,1) + if (this%hvars(ivar)%upfreq == upfreq_in) then ! Only flush variables with update on dynamics step + call this%hvars(ivar)%flush(nc, this%dim_bounds, this%dim_kinds) + + ndims = this%dim_kinds(this%hvars(ivar)%dim_kinds_index)%ndims + + if(trim(this%dim_kinds(this%hvars(ivar)%dim_kinds_index)%name) == site_int)then + write(fates_log(),*)'add in zeroing provision for SI_INT' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(ndims==1) then + do s = 1,nsites + this%hvars(ivar)%r81d(sites(s)%h_gid) = 0._r8 + end do + elseif(ndims==2) then + do s = 1,nsites + this%hvars(ivar)%r82d(sites(s)%h_gid,:) = 0._r8 + end do + elseif(ndims==3) then + do s = 1,nsites + this%hvars(ivar)%r83d(sites(s)%h_gid,:,:) = 0._r8 + end do + end if + end if + end do + + return + end subroutine zero_site_hvars + + + subroutine flush_hvars(this,nc,upfreq_in) class(fates_history_interface_type) :: this @@ -1510,11 +1564,15 @@ subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype ! locals integer :: ub1, lb1, ub2, lb2 ! Bounds for allocating the var integer :: ityp - real(r8), :: flushval + real(r8) :: flushval logical :: write_var - flushval = 0.0_r8 !for now do this (ACF 09/27/21) - ! we need to flush this to 0.0 in FATES + + ! Flushing to the ignore val coerces all FATES diagnostics to be + ! relevant only on FATES sites. This way we do not average zero's + ! at locations not on FATES columns + + flushval = hlm_hio_ignore_val !for now do this (ACF 09/27/21) write_var = check_hlm_list(trim(hlms), trim(hlm_name)) if( write_var ) then @@ -3151,6 +3209,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_reprop_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_pefflux_scpf)%r82d(io_si,:) = & sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) / & m2_per_ha / sec_per day @@ -3535,7 +3594,8 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=2) - + call this%zero_site_hvars(nc,sites,upfreq_in=2) + per_dt_tstep = 1.0_r8/dt_tstep do s = 1,nsites @@ -3959,7 +4019,8 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=4) - + call this%zero_site_hvars(nc,sites,upfreq_in=4) + if(print_iterations) then do iscpf = 1,iterh2_nhist iterh2_histx(iscpf) = iterh2_dx*real(iscpf-1,r8) From 994e48eaa31145162e246b68c3893158300e7074 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Mon, 11 Oct 2021 11:23:05 -0600 Subject: [PATCH 427/578] fix typos --- main/FatesHistoryInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index c613227ce5..1d91bbb3b7 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1510,7 +1510,7 @@ subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype ! locals integer :: ub1, lb1, ub2, lb2 ! Bounds for allocating the var integer :: ityp - real(r8), :: flushval + real(r8) :: flushval logical :: write_var flushval = 0.0_r8 !for now do this (ACF 09/27/21) From 6d75fd43ac8beb08a1463e5355068632539da4dd Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 11 Oct 2021 14:10:07 -0400 Subject: [PATCH 428/578] Fixes and completions to zero flushing history --- main/EDMainMod.F90 | 4 ++++ main/FatesHistoryInterfaceMod.F90 | 11 +++++------ 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 7aa733989d..dabaa3380c 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -159,6 +159,10 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) call currentSite%flux_diags(el)%ZeroFluxDiags() end do + + call fates_hist%zero_site_hvars(sites,upfreq_in=1) + + ! Call a routine that simply identifies if logging should occur ! This is limited to a global event until more structured event handling is enabled call IsItLoggingTime(hlm_masterproc,currentSite) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index a06d18022d..790be210cc 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1463,7 +1463,7 @@ end function levagefuel_index ! ====================================================================================== - subroutine zero_site_hvars(this,nc,sites,upfreq_in) + subroutine zero_site_hvars(this,sites,upfreq_in) ! This routine zero's a history diagnostic variable @@ -1472,7 +1472,6 @@ subroutine zero_site_hvars(this,nc,sites,upfreq_in) ! and after they have been flushed to the ignore value class(fates_history_interface_type) :: this - integer,intent(in) :: nc integer,intent(in) :: upfreq_in type(ed_site_type),intent(in) :: sites(:) @@ -1485,7 +1484,6 @@ subroutine zero_site_hvars(this,nc,sites,upfreq_in) do ivar=1,ubound(this%hvars,1) if (this%hvars(ivar)%upfreq == upfreq_in) then ! Only flush variables with update on dynamics step - call this%hvars(ivar)%flush(nc, this%dim_bounds, this%dim_kinds) ndims = this%dim_kinds(this%hvars(ivar)%dim_kinds_index)%ndims @@ -2534,9 +2532,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%hmort*ccohort%n / m2_per_ha hio_m3_si_scpf(io_si,scpf) = hio_m3_si_scpf(io_si,scpf) + & ccohort%cmort*ccohort%n / m2_per_ha + hio_m7_si_scpf(io_si,scpf) = hio_m7_si_scpf(io_si,scpf) + & (ccohort%lmort_direct + ccohort%lmort_collateral + & ccohort%lmort_infra) * ccohort%n / m2_per_ha + hio_m8_si_scpf(io_si,scpf) = hio_m8_si_scpf(io_si,scpf) + & ccohort%frmort*ccohort%n / m2_per_ha hio_m9_si_scpf(io_si,scpf) = hio_m9_si_scpf(io_si,scpf) + & @@ -2646,7 +2646,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%frmort + & ccohort%smort + ccohort%asmort) * ccohort%n + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & @@ -3594,7 +3593,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=2) - call this%zero_site_hvars(nc,sites,upfreq_in=2) + call this%zero_site_hvars(sites,upfreq_in=2) per_dt_tstep = 1.0_r8/dt_tstep @@ -4019,7 +4018,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=4) - call this%zero_site_hvars(nc,sites,upfreq_in=4) + call this%zero_site_hvars(sites,upfreq_in=4) if(print_iterations) then do iscpf = 1,iterh2_nhist From 7c89d71d3a33a84ee70370ff72fb7b6ebb81828b Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Mon, 11 Oct 2021 12:37:37 -0600 Subject: [PATCH 429/578] fix mortality logging units --- main/FatesHistoryInterfaceMod.F90 | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 1d91bbb3b7..824c0b03af 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1514,7 +1514,6 @@ subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype logical :: write_var flushval = 0.0_r8 !for now do this (ACF 09/27/21) - ! we need to flush this to 0.0 in FATESs write_var = check_hlm_list(trim(hlms), trim(hlm_name)) if( write_var ) then @@ -2590,9 +2589,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%frmort + & - ccohort%smort + ccohort%asmort) * ccohort%n + & + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * sec_per_day * days_per_year / m2_per_ha + ccohort%n * days_per_year / m2_per_ha hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + ccohort%n / m2_per_ha hio_nplant_canopy_si_scls(io_si,scls) = hio_nplant_canopy_si_scls(io_si,scls) + ccohort%n / m2_per_ha @@ -2620,7 +2619,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * sec_per_day * days_per_year / m2_per_ha + ccohort%n * days_per_year / m2_per_ha hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & @@ -2683,9 +2682,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) 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 + & + ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * sec_per_day * days_per_year / m2_per_ha + ccohort%n * days_per_year / m2_per_ha hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + ccohort%n / m2_per_ha hio_nplant_understory_si_scls(io_si,scls) = hio_nplant_understory_si_scls(io_si,scls) + ccohort%n / m2_per_ha @@ -2714,7 +2713,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * sec_per_day * days_per_year / m2_per_ha + ccohort%n * days_per_year / m2_per_ha hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & @@ -5600,7 +5599,7 @@ subroutine define_history_vars(this, initialize_variables) initialize=initialize_variables, index = ih_m6_si_scpf) call this%set_history_var(vname='FATES_MORTALITY_LOGGING_SZPF', & - units = 'm-2 event-1', & + units = 'm-2 yr-1', & long='logging mortality by pft/size in number of plants per m2 per ', & use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', upfreq=1, & @@ -5950,7 +5949,7 @@ subroutine define_history_vars(this, initialize_variables) initialize=initialize_variables, index = ih_m6_si_scls) call this%set_history_var(vname='FATES_MORTALITY_LOGGING_SZ', & - units = 'm-2 event-1', & + units = 'm-2 yr-1', & long='logging mortality by size in number of plants per m2 per event', & use_default='active', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & @@ -6662,13 +6661,13 @@ subroutine define_history_vars(this, initialize_variables) upfreq=4, ivar=ivar, initialize=initialize_variables, & index = ih_sapflow_si) - call this%set_history_var(vname='FATES_ITERH1_SZPF', units='count/indiv/step', & + call this%set_history_var(vname='FATES_ITERH1_SZPF', units='count indiv-1 step-1', & long='water balance error iteration diagnostic 1', & use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_iterh1_scpf ) - call this%set_history_var(vname='FATES_ITERH2_SZPF', units='count/indiv/step', & + call this%set_history_var(vname='FATES_ITERH2_SZPF', units='count indiv-1 step-1', & long='water balance error iteration diagnostic 2', & use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & From 9ddac21897bd4a823fc99d980dbafad64e811491 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Mon, 11 Oct 2021 12:38:43 -0600 Subject: [PATCH 430/578] fix missing ampersand --- main/FatesHistoryInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 824c0b03af..d5e8e43aab 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -4011,7 +4011,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) hio_rootuptake_si(io_si) = sum(site_hydr%rootuptake_sl,dim=1) / m2_per_ha hio_rootuptake_sl(io_si,:) = 0._r8 - hio_rootuptake_sl(io_si,jr1:jr2) = site_hydr%rootuptake_sl(1:nlevrhiz) / + hio_rootuptake_sl(io_si,jr1:jr2) = site_hydr%rootuptake_sl(1:nlevrhiz) / & m2_per_ha hio_sapflow_si(io_si) = sum(site_hydr%sapflow_scpf) / m2_per_ha From db5a19364178db86cc191ef6be4096ba916b64c5 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Mon, 11 Oct 2021 12:55:55 -0600 Subject: [PATCH 431/578] typo fixes --- main/FatesHistoryInterfaceMod.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index d5e8e43aab..f9337366b2 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3152,7 +3152,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_reprop_scpf)%r82d(io_si,:) = 0._r8 this%hvars(ih_pefflux_scpf)%r82d(io_si,:) = & sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) / & - m2_per_ha / sec_per day + m2_per_ha / sec_per_day this%hvars(ih_pneed_scpf)%r82d(io_si,:) = & sites(s)%flux_diags(el)%nutrient_need_scpf(:) / & @@ -4623,7 +4623,7 @@ subroutine define_history_vars(this, initialize_variables) index = ih_litter_moisture_si_fuel) call this%set_history_var(vname='FATES_FUEL_AMOUNT_FC', units='kg m-2', & - long='spitfire fuel-class level fuel amount in kg carbon per m2 land area', + long='spitfire fuel-class level fuel amount in kg carbon per m2 land area', & use_default='active', avgflag='A', vtype=site_fuel_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_fuel_amount_si_fuel) @@ -5073,8 +5073,8 @@ subroutine define_history_vars(this, initialize_variables) units='kg m-2 s-1', & long='autotrophic respiration of canopy plants in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=2, ivar=ivar, initialize=initialize_variables, i & - ndex = ih_ar_canopy_si) + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_ar_canopy_si) call this%set_history_var(vname='FATES_GPP_UNDERSTORY', & units='kg m-2 s-1', & @@ -5354,7 +5354,7 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FATES_MORTALITY_UNDERSTORY_APSZ', & units = 'm-2 yr-1', & - long='mortality rate of understory plants in number of plants per m2 per year in each size x age class', + long='mortality rate of understory plants in number of plants per m2 per year in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_mortality_understory_si_scag) @@ -5399,7 +5399,7 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FATES_GPP_CANOPY_SZPF', & units='kg m-2 s-1', & - long='gross primary production of canopy plants by pft/size in kg carbon per m2 per second', + long='gross primary production of canopy plants by pft/size in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_gpp_canopy_si_scpf) @@ -5413,7 +5413,7 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FATES_GPP_UNDERSTORY_SZPF', & units='kg m-2 s-1', & - long='gross primary production of understory plants by pft/size in kg carbon per m2 per second', + long='gross primary production of understory plants by pft/size in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_gpp_understory_si_scpf) @@ -5472,7 +5472,7 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname = 'FATES_NPP_AGSTRUCT_SZPF', & units='kg m-2 s-1', & - long='NPP flux into above-ground structural (deadwood) by pft/size in kg carbon per m2 per second', + long='NPP flux into above-ground structural (deadwood) by pft/size in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_agdw_si_scpf) From 1fbcda6433e2eacf2ce7ab8d0e3337ca9ac62599 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Mon, 11 Oct 2021 13:01:18 -0600 Subject: [PATCH 432/578] add units constants --- main/FatesHistoryInterfaceMod.F90 | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index f9337366b2..d734c69fa3 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -60,6 +60,14 @@ module FatesHistoryInterfaceMod use FatesConstantsMod , only : sec_per_day use FatesConstantsMod , only : days_per_year use FatesConstantsMod , only : years_per_day + use FatesConstantsMod , only : m2_per_km2 + use FatesConstantsMod , only : s_per_day + use FatesConstantsMod , only : J_per_kJ + use FatesConstantsMod , only : m2_per_ha + use FatesConstantsMod , only : m_per_cm + use FatesConstantsMod , only : sec_per_min + use FatesConstantsMod , only : umol_per_mol + use FatesConstantsMod , only : pa_per_mpa use FatesLitterMod , only : litter_type use FatesConstantsMod , only : secondaryforest From e0dd230befd6edf6083c932644fef35672ef8458 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Mon, 11 Oct 2021 13:02:49 -0600 Subject: [PATCH 433/578] fix typo --- main/FatesHistoryInterfaceMod.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index d734c69fa3..069414daa6 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -61,7 +61,6 @@ module FatesHistoryInterfaceMod use FatesConstantsMod , only : days_per_year use FatesConstantsMod , only : years_per_day use FatesConstantsMod , only : m2_per_km2 - use FatesConstantsMod , only : s_per_day use FatesConstantsMod , only : J_per_kJ use FatesConstantsMod , only : m2_per_ha use FatesConstantsMod , only : m_per_cm @@ -2179,7 +2178,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) end do hio_area_burnt_si_age(io_si,cpatch%age_class) = hio_area_burnt_si_age(io_si,cpatch%age_class) + & - cpatch%frac_burnt * cpatch%area * AREA_INV / s_per_day + cpatch%frac_burnt * cpatch%area * AREA_INV / sec_per_day ! 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 From 88df2c46c253134c13399ae4b16d484d9f6fb940 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Mon, 11 Oct 2021 13:13:36 -0600 Subject: [PATCH 434/578] add units constants to EdMainMod --- main/EDMainMod.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 7aa733989d..d7f302375f 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -70,6 +70,8 @@ module EDMainMod use FatesConstantsMod , only : itrue,ifalse use FatesConstantsMod , only : primaryforest, secondaryforest use FatesConstantsMod , only : nearzero + use FatesConstantsMod , only : m2_per_ha + use FatesConstantsMod , only : sec_per_day use FatesPlantHydraulicsMod , only : do_growthrecruiteffects use FatesPlantHydraulicsMod , only : UpdateSizeDepPlantHydProps use FatesPlantHydraulicsMod , only : UpdateSizeDepPlantHydStates From d78c9eb01b4db1633a8d3e0124affd2a14208a06 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Mon, 11 Oct 2021 15:32:06 -0600 Subject: [PATCH 435/578] fix names that were too long --- main/FatesHistoryInterfaceMod.F90 | 132 +++++++++++++++--------------- 1 file changed, 66 insertions(+), 66 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 069414daa6..47cc116642 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -4515,14 +4515,14 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index=ih_biomass_secondary_forest_si) - call this%set_history_var(vname='FATES_SECONDARY_AREA_ANTHRO_DIST_AP', & + call this%set_history_var(vname='FATES_SECONDAREA_ANTHRODIST_AP', & units='m2 m-2', & long='secondary forest patch area age distribution since anthropgenic disturbance', & use_default='inactive', avgflag='A', vtype=site_age_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index=ih_agesince_anthrodist_si_age) - call this%set_history_var(vname='FATES_SECONDARY_AREA_DIST_AP', & + call this%set_history_var(vname='FATES_SECONDAREA_DIST_AP', & units='m2 m-2', & long='secondary forest patch area age distribution since any kind of disturbance', & use_default='inactive', avgflag='A', vtype=site_age_r8, & @@ -4786,7 +4786,7 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_storen_si) - call this%set_history_var(vname='FATES_STOREN_TFRAC', units='1', & + call this%set_history_var(vname='FATES_STOREN_TF', units='1', & long='storage N fraction of target', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_storentfrac_si) @@ -4852,7 +4852,7 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_storep_si) - call this%set_history_var(vname='FATES_STOREP_TFRAC', units='1', & + call this%set_history_var(vname='FATES_STOREP_TF', units='1', & long='storage P fraction of target', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, & ivar=ivar, initialize=initialize_variables, & @@ -4938,7 +4938,7 @@ subroutine define_history_vars(this, initialize_variables) ! disturbance rates - call this%set_history_var(vname='FATES_PRIMARYLAND_PATCHFUSION_ERROR', & + call this%set_history_var(vname='FATES_PRIMARY_PATCHFUSION_ERR', & units='m2 m-2 yr-1', & long='error in total primary lands associated with patch fusion', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & @@ -5024,7 +5024,7 @@ subroutine define_history_vars(this, initialize_variables) use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_gpp_si) - call this%set_history_var(vname='FATES_AUTO_RESP', units='kg m-2 s-1', & + call this%set_history_var(vname='FATES_AUTORESP', units='kg m-2 s-1', & long='autotrophic respiration in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_aresp_si) @@ -5076,7 +5076,7 @@ subroutine define_history_vars(this, initialize_variables) upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_gpp_canopy_si) - call this%set_history_var(vname='FATES_AUTO_RESP_CANOPY', & + call this%set_history_var(vname='FATES_AUTORESP_CANOPY', & units='kg m-2 s-1', & long='autotrophic respiration of canopy plants in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & @@ -5090,8 +5090,8 @@ subroutine define_history_vars(this, initialize_variables) upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_gpp_understory_si) - call this%set_history_var(vname='FATES_AUTO_RESP_UNDERSTORY', & - units='kg m-2 s-1', & + call this%set_history_var(vname='FATES_AUTORESP_UNDERSTORY', & + units='kg m-2 s-1', & long='autotrophic respiration of understory plants in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, & @@ -5303,14 +5303,14 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_promotion_carbonflux_si) - call this%set_history_var(vname='FATES_MORTALITY_CARBONFLUX_CANOPY', & + call this%set_history_var(vname='FATES_MORTALITY_CFLUX_CANOPY', & units = 'kg m-2 s-1', & long='flux of biomass carbon from live to dead pools from mortality of canopy plants in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_canopy_mortality_carbonflux_si) - call this%set_history_var(vname='FATES_MORTALITY_CARBONFLUX_UNDERSTORY', & + call this%set_history_var(vname='FATES_MORTALITY_CFLUX_UNDERSTORY', & units = 'kg m-2 s-1', & long='flux of biomass carbon from live to dead pools from mortality of understory plants in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & @@ -5411,7 +5411,7 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_gpp_canopy_si_scpf) - call this%set_history_var(vname='FATES_AUTO_RESP_CANOPY_SZPF', & + call this%set_history_var(vname='FATES_AUTORESP_CANOPY_SZPF', & units='kg m-2 s-1', & long='autotrophic respiration of canopy plants by pft/size in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & @@ -5425,7 +5425,7 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_gpp_understory_si_scpf) - call this%set_history_var(vname='FATES_AUTO_RESP_UNDERSTORY_SZPF', & + call this%set_history_var(vname='FATES_AUTORESP_UNDERSTORY_SZPF', & units='kg m-2 s-1', & long='autotrophic respiration of understory plants by pft/size in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & @@ -5626,14 +5626,14 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_m9_si_scpf) - call this%set_history_var(vname='FATES_MORTALITY_AGESCENESCENCE_SZPF', & + call this%set_history_var(vname='FATES_MORTALITY_AGESCEN_SZPF', & units = 'm-2 yr-1', & long='age senescence mortality by pft/size in number of plants per m2 per year', & use_default='inactive', avgflag='A', vtype =site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_m10_si_scpf) - call this%set_history_var(vname='FATES_MORTALITY_AGESCENESCENCE_ACPF', & + call this%set_history_var(vname='FATES_MORTALITY_AGESCEN_ACPF', & units='m-2 yr-1', & long='age senescence mortality by pft/cohort age in number of plants per m2 per year', & use_default='inactive', avgflag='A', vtype =site_coage_pft_r8, & @@ -5744,49 +5744,49 @@ subroutine define_history_vars(this, initialize_variables) ! Size structured diagnostics that require rapid updates (upfreq=2) - call this%set_history_var(vname='FATES_AUTO_RESP_SZPF', & + call this%set_history_var(vname='FATES_AUTORESP_SZPF', & units = 'kg m-2 s-1', & long='total autotrophic respiration in kg carbon per m2 per second by pft/size', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, index = ih_ar_si_scpf) - call this%set_history_var(vname='FATES_AUTO_RESP_GROW_SZPF', & + call this%set_history_var(vname='FATES_GROWAR_SZPF', & units = 'kg m-2 s-1', & long='growth autotrophic respiration in kg carbon per m2 per second by pft/size', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, index = ih_ar_grow_si_scpf) - call this%set_history_var(vname='FATES_AUTO_RESP_MAINT_SZPF', & + call this%set_history_var(vname='FATES_MAINTAR_SZPF', & units = 'kg m-2 s-1', & long='maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, index = ih_ar_maint_si_scpf) - call this%set_history_var(vname='FATES_AUTO_RESP_DARKMAINT_SZPF', & + call this%set_history_var(vname='FATES_RDARK_SZPF', & units = 'kg m-2 s-1', & long='dark portion of maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, index = ih_ar_darkm_si_scpf) - call this%set_history_var(vname='FATES_AUTO_RESP_AGSAPMAINT_SZPF', & + call this%set_history_var(vname='FATES_AGSAPMAINTAR_SZPF', & units = 'kg m-2 s-1', & long='above-ground sapwood maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, index = ih_ar_agsapm_si_scpf) - call this%set_history_var(vname='FATES_AUTO_RESP_BGSAPMAINT_SZPF', & + call this%set_history_var(vname='FATES_BGSAPMAINTAR_SZPF', & units = 'kg m-2 s-1', & long='below-ground sapwood maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, index = ih_ar_crootm_si_scpf) - call this%set_history_var(vname='FATES_AUTO_RESP_FROOTMAINT_SZPF', & + call this%set_history_var(vname='FATES_FROOTMAINTAR_SZPF', & units = 'kg m-2 s-1', & long='fine root maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & @@ -5807,7 +5807,7 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_ddbh_understory_si_scls) - call this%set_history_var(vname='FATES_YESTERDAYCANLEV_CANOPY_SZ', & + call this%set_history_var(vname='FATES_YESTCANLEV_CANOPY_SZ', & units = 'm-2', & long='yesterdays canopy level for canopy plants by size class in number of plants per m2', & use_default='inactive', avgflag='A', vtype=site_size_r8, & @@ -5815,7 +5815,7 @@ subroutine define_history_vars(this, initialize_variables) initialize=initialize_variables, & index = ih_yesterdaycanopylevel_canopy_si_scls) - call this%set_history_var(vname='FATES_YESTERDAYCANLEV_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_YESTCANLEV_UNDERSTORY_SZ', & units = 'm-2', & long='yesterdays canopy level for understory plants by size class in number of plants per m2', & use_default='inactive', avgflag='A', vtype=site_size_r8, & @@ -5976,14 +5976,14 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_m9_si_scls) - call this%set_history_var(vname='FATES_MORTALITY_AGESCENESCENCE_SZ', & + call this%set_history_var(vname='FATES_MORTALITY_AGESCEN_SZ', & units = 'm-2 yr-1', & long='age senescence mortality by size in number of plants per m2 per year', & use_default='active', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_m10_si_scls) - call this%set_history_var(vname='FATES_MORTALITY_AGESCENESCENCE_AC', & + call this%set_history_var(vname='FATES_MORTALITY_AGESCEN_AC', & units = 'm-2 yr-1', & long='age senescence mortality by cohort age in number of plants per m2 per year', & use_default='active', avgflag='A', vtype=site_coage_r8, & @@ -6038,37 +6038,37 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_crown_area_understory_si_scls) - call this%set_history_var(vname='FATES_LEAFCTURNOVER_CANOPY_SZ', & + call this%set_history_var(vname='FATES_LEAFCTURN_CANOPY_SZ', & units = 'kg m-2 s-1', & - long='leaf turnover for canopy plants by size class in kg carbon per m2 per second', & + long='leaf turnover (non-mortal) for canopy plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_leaf_md_canopy_si_scls) - call this%set_history_var(vname='FATES_FROOTCTURNOVER_CANOPY_SZ', & + call this%set_history_var(vname='FATES_FROOTCTURN_CANOPY_SZ', & units = 'kg m-2 s-1', & - long='fine root turnover for canopy plants by size class in kg carbon per m2 per second', & + long='fine root turnover (non-mortal) for canopy plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_root_md_canopy_si_scls) - call this%set_history_var(vname='FATES_STORECTURNOVER_CANOPY_SZ', & + call this%set_history_var(vname='FATES_STORECTURN_CANOPY_SZ', & units = 'kg m-2 s-1', & - long='storage turnover for canopy plants by size class in kg carbon per m2 per second', & + long='storage turnover (non-mortal) for canopy plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_bstore_md_canopy_si_scls) - call this%set_history_var(vname='FATES_STRUCTCTURNOVER_CANOPY_SZ', & + call this%set_history_var(vname='FATES_STRUCTCTURN_CANOPY_SZ', & units = 'kg m-2 s-1', & - long='structural C turnover for canopy plants by size class in kg carbon per m2 per second', & + long='structural C turnover (non-mortal) for canopy plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_bdead_md_canopy_si_scls) - call this%set_history_var(vname='FATES_SAPWOODCTURNOVER_CANOPY_SZ', & + call this%set_history_var(vname='FATES_SAPWOODCTURN_CANOPY_SZ', & units = 'kg m-2 s-1', & - long='sapwood turnover for canopy plants by size class in kg carbon per m2 per second', & + long='sapwood turnover (non-mortal) for canopy plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_bsw_md_canopy_si_scls) @@ -6122,42 +6122,42 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_stor_canopy_si_scls) - call this%set_history_var(vname='FATES_AUTO_RESP_LEAFMAINT', & + call this%set_history_var(vname='FATES_LEAFMAINTAR', & units = 'kg m-2 s-1', & long='leaf maintenance autotrophic respiration in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_leaf_mr_si) - call this%set_history_var(vname='FATES_AUTO_RESP_FROOTMAINT', & + call this%set_history_var(vname='FATES_FROOTMAINTAR', & units = 'kg m-2 s-1', & long='fine root maintenance autotrophic respiration in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_froot_mr_si) - call this%set_history_var(vname='FATES_AUTO_RESP_CROOTMAINT', & + call this%set_history_var(vname='FATES_CROOTMAINTAR', & units = 'kg m-2 s-1', & long='live coarse root maintenance autotrophic respiration in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_livecroot_mr_si) - call this%set_history_var(vname='FATES_AUTO_RESP_LIVESTEMMAINT', & + call this%set_history_var(vname='FATES_LSTEMMAINTAR', & units = 'kg m-2 s-1', & long='live stem maintenance autotrophic respiration in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_livestem_mr_si) - call this%set_history_var(vname='FATES_AUTO_RESP_DARK_CANOPY_SZ', & + call this%set_history_var(vname='FATES_RDARK_CANOPY_SZ', & units = 'kg m-2 s-1', & long='dark respiration for canopy plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, index = ih_rdark_canopy_si_scls) - call this%set_history_var(vname='FATES_AUTO_RESP_LIVESTEMMAINT_CANOPY_SZ', & + call this%set_history_var(vname='FATES_LSTEMMAINTAR_CANOPY_SZ', & units = 'kg m-2 s-1', & long='live stem maintenance autotrophic respiration for canopy plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & @@ -6165,7 +6165,7 @@ subroutine define_history_vars(this, initialize_variables) initialize=initialize_variables, & index = ih_livestem_mr_canopy_si_scls) - call this%set_history_var(vname='FATES_AUTO_RESP_CROOTMAINT_CANOPY_SZ', & + call this%set_history_var(vname='FATES_CROOTMAINTAR_CANOPY_SZ', & units = 'kg m-2 s-1', & long='live coarse root maintenance autotrophic respiration for canopy plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & @@ -6173,62 +6173,62 @@ subroutine define_history_vars(this, initialize_variables) initialize=initialize_variables, & index = ih_livecroot_mr_canopy_si_scls) - call this%set_history_var(vname='FATES_AUTO_RESP_FROOTMAINT_CANOPY_SZ', & + call this%set_history_var(vname='FATES_FROOTMAINTAR_CANOPY_SZ', & units = 'kg m-2 s-1', & long='live coarse root maintenance autotrophic respiration for canopy plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, index = ih_froot_mr_canopy_si_scls) - call this%set_history_var(vname='FATES_AUTO_RESP_GROW_CANOPY_SZ', & + call this%set_history_var(vname='FATES_GROWAR_CANOPY_SZ', & units = 'kg m-2 s-1', & long='growth autotrophic respiration of canopy plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, index = ih_resp_g_canopy_si_scls) - call this%set_history_var(vname='FATES_AUTO_RESP_MAINT_CANOPY_SZ', & + call this%set_history_var(vname='FATES_MAINTAR_CANOPY_SZ', & units = 'kg m-2 s-1', & long='maintenance autotrophic respiration of canopy plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, index = ih_resp_m_canopy_si_scls) - call this%set_history_var(vname='FATES_LEAFCTURNOVER_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_LEAFCTURN_UNDERSTORY_SZ', & units = 'kg m-2 s-1', & - long='leaf turnover for understory plants by size class in kg carbon per m2 per second', & + long='leaf turnover (non-mortal) for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & index = ih_leaf_md_understory_si_scls) - call this%set_history_var(vname='FATES_FROOTCTURNOVER_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_FROOTCTURN_UNDERSTORY_SZ', & units = 'kg m-2 s-1', & - long='fine root turnover for understory plants by size class in kg carbon per m2 per second', & + long='fine root turnover (non-mortal) for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & index = ih_root_md_understory_si_scls) - call this%set_history_var(vname='FATES_STORECTURNOVER_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_STORECTUR_UNDERSTORY_SZ', & units = 'kg m-2 s-1', & - long='storage C turnover for understory plants by size class in kg carbon per m2 per second', & + long='storage C turnover (non-mortal) for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & index = ih_bstore_md_understory_si_scls) - call this%set_history_var(vname='FATES_STRUCTCTURNOVER_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_STRUCTCTURN_UNDERSTORY_SZ', & units = 'kg m-2 s-1', & - long='structural C turnover for understory plants by size class in kg carbon per m2 per second', & + long='structural C turnover (non-mortal) for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & index = ih_bdead_md_understory_si_scls) - call this%set_history_var(vname='FATES_SAPWOODCTURNOVER_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_SAPWOODCTURN_UNDERSTORY_SZ', & units = 'kg m-2 s-1', & - long='sapwood C turnover for understory plants by size class in kg carbon per m2 per second', & + long='sapwood C turnover (non-mortal) for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_bsw_md_understory_si_scls) @@ -6283,14 +6283,14 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_stor_understory_si_scls) - call this%set_history_var(vname='FATES_AUTO_RESP_DARK_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_RDARK_UNDERSTORY_SZ', & units = 'kg m-2 s-1', & long='dark respiration for understory plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, index = ih_rdark_understory_si_scls) - call this%set_history_var(vname='FATES_AUTO_RESP_LIVESTEMMAINT_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_LSTEMMAINTAR_UNDERSTORY_SZ', & units = 'kg m-2 s-1', & long='live stem maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & @@ -6298,7 +6298,7 @@ subroutine define_history_vars(this, initialize_variables) initialize=initialize_variables, & index = ih_livestem_mr_understory_si_scls) - call this%set_history_var(vname='FATES_AUTO_RESP_CROOTMAINT_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_CROOTMAINTAR_UNDERSTORY_SZ', & units = 'kg m-2 s-1', & long='live coarse root maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & @@ -6306,7 +6306,7 @@ subroutine define_history_vars(this, initialize_variables) initialize=initialize_variables, & index = ih_livecroot_mr_understory_si_scls) - call this%set_history_var(vname='FATES_AUTO_RESP_FROOTMAINT_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_FROOTMAINTAR_UNDERSTORY_SZ', & units = 'kg m-2 s-1', & long='fine root maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & @@ -6314,14 +6314,14 @@ subroutine define_history_vars(this, initialize_variables) initialize=initialize_variables, & index = ih_froot_mr_understory_si_scls) - call this%set_history_var(vname='FATES_AUTO_RESP_GROW_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_GROWAR_UNDERSTORY_SZ', & units = 'kg m-2 s-1', & long='growth autotrophic respiration of understory plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, index = ih_resp_g_understory_si_scls) - call this%set_history_var(vname='FATES_AUTO_RESP_MAINT_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_MAINTAR_UNDERSTORY_SZ', & units = 'kg m-2 s-1', & long='maintenance autotrophic respiration of understory plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & @@ -6476,14 +6476,14 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_storen_scpf) - call this%set_history_var(vname='FATES_STOREN_TFRAC_CANOPY_SZPF', & + call this%set_history_var(vname='FATES_STOREN_TF_CANOPY_SZPF', & units='1', & long='storage nitrogen fraction (0-1) of target, in canopy, by size-class x pft', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_storentfrac_canopy_scpf) - call this%set_history_var(vname='FATES_STOREN_TFRAC_UNDERSTORY_SZPF', & + call this%set_history_var(vname='FATES_STOREN_TF_UNDERSTORY_SZPF', & units='1', & long='storage nitrogen fraction (0-1) of target, in understory, by size-class x pft', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & @@ -6558,14 +6558,14 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_storep_scpf) - call this%set_history_var(vname='FATES_STOREP_TFRAC_CANOPY_SZPF', & + call this%set_history_var(vname='FATES_STOREP_TF_CANOPY_SZPF', & units='1', & long='storage phosphorus fraction (0-1) of target, in canopy, by size-class x pft', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_storeptfrac_canopy_scpf) - call this%set_history_var(vname='FATES_STOREP_TFRAC_UNDERSTORY_SZPF', & + call this%set_history_var(vname='FATES_STOREP_TF_UNDERSTORY_SZPF', & units='1', & long='storage phosphorus fraction (0-1) of target, in understory, by size-class x pft', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & From 9dfd07f90b9792aed6ce213a5960a0d9dc464d2b Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Tue, 12 Oct 2021 08:24:52 -0600 Subject: [PATCH 436/578] change NPP fluxes to allocation in varnames --- main/FatesHistoryInterfaceMod.F90 | 260 +++++++++++++++--------------- 1 file changed, 130 insertions(+), 130 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 47cc116642..37a4a62bcd 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -4319,7 +4319,7 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index=ih_site_dstatus_si) - call this%set_history_var(vname='FATES_GDD', units='degC', & + call this%set_history_var(vname='FATES_GDD', units='degree_Celsius', & long='site-level growing degree days', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index=ih_gdd_si) @@ -4930,11 +4930,11 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_canopy_biomass_si) - call this%set_history_var(vname='FATES_UNDERSTORY_VEGC', units='kg m-2', & + call this%set_history_var(vname='FATES_USTORY_VEGC', units='kg m-2', & long='biomass of understory plants in kg carbon per m2 land area', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_understory_biomass_si) + index = ih_USTORY_biomass_si) ! disturbance rates @@ -5088,14 +5088,14 @@ subroutine define_history_vars(this, initialize_variables) long='gross primary production of understory plants in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_gpp_understory_si) + index = ih_gpp_USTORY_si) call this%set_history_var(vname='FATES_AUTORESP_UNDERSTORY', & units='kg m-2 s-1', & long='autotrophic respiration of understory plants in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_ar_understory_si) + index = ih_ar_USTORY_si) ! fast radiative fluxes resolved through the canopy @@ -5315,7 +5315,7 @@ subroutine define_history_vars(this, initialize_variables) long='flux of biomass carbon from live to dead pools from mortality of understory plants in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_understory_mortality_carbonflux_si) + index = ih_USTORY_mortality_carbonflux_si) ! size class by age dimensioned variables @@ -5331,12 +5331,12 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_nplant_canopy_si_scag) - call this%set_history_var(vname='FATES_NPLANT_UNDERSTORY_APSZ', & + call this%set_history_var(vname='FATES_NPLANT_USTORY_APSZ', & units = 'm-2', & long='number of plants per m2 in understory in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_nplant_understory_si_scag) + initialize=initialize_variables, index = ih_nplant_USTORY_si_scag) call this%set_history_var(vname='FATES_DDBH_CANOPY_APSZ', & units = 'm m-2 yr-1', & @@ -5345,12 +5345,12 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_ddbh_canopy_si_scag) - call this%set_history_var(vname='FATES_DDBH_UNDERSTORY_APSZ', & + call this%set_history_var(vname='FATES_DDBH_USTORY_APSZ', & units = 'm m-2 yr-1', & long='growth rate of understory plants in meters DBH per m2 per year in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_ddbh_understory_si_scag) + initialize=initialize_variables, index = ih_ddbh_USTORY_si_scag) call this%set_history_var(vname='FATES_MORTALITY_CANOPY_APSZ', & units = 'm-2 yr-1', & @@ -5359,12 +5359,12 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_mortality_canopy_si_scag) - call this%set_history_var(vname='FATES_MORTALITY_UNDERSTORY_APSZ', & + call this%set_history_var(vname='FATES_MORTALITY_USTORY_APSZ', & units = 'm-2 yr-1', & long='mortality rate of understory plants in number of plants per m2 per year in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_mortality_understory_si_scag) + initialize=initialize_variables, index = ih_mortality_USTORY_si_scag) ! size x age x pft dimensioned @@ -5418,19 +5418,19 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_ar_canopy_si_scpf) - call this%set_history_var(vname='FATES_GPP_UNDERSTORY_SZPF', & + call this%set_history_var(vname='FATES_GPP_USTORY_SZPF', & units='kg m-2 s-1', & long='gross primary production of understory plants by pft/size in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_gpp_understory_si_scpf) + initialize=initialize_variables, index = ih_gpp_USTORY_si_scpf) - call this%set_history_var(vname='FATES_AUTORESP_UNDERSTORY_SZPF', & + call this%set_history_var(vname='FATES_AUTORESP_USTORY_SZPF', & units='kg m-2 s-1', & long='autotrophic respiration of understory plants by pft/size in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_ar_understory_si_scpf) + initialize=initialize_variables, index = ih_ar_USTORY_si_scpf) call this%set_history_var(vname='FATES_NPP_SZPF', units='kg m-2 s-1', & long='total net primary production by pft/size in kg carbon per m2 per second', & @@ -5438,55 +5438,55 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_npp_totl_si_scpf) - call this%set_history_var(vname='FATES_NPP_LEAF_SZPF', units='kg m-2 s-1', & - long='NPP flux into leaves by pft/size in kg carbon per m2 per second', & + call this%set_history_var(vname='FATES_LEAF_ALLOC_SZPF', units='kg m-2 s-1', & + long='allocation to leaves by pft/size in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_npp_leaf_si_scpf) - call this%set_history_var(vname='FATES_NPP_SEED_SZPF', units='kg m-2 s-1', & - long='NPP flux into seeds by pft/size in kg carbon per m2 per second', & + call this%set_history_var(vname='FATES_SEED_ALLOC_SZPF', units='kg m-2 s-1', & + long='allocation to seeds by pft/size in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_npp_seed_si_scpf) - call this%set_history_var(vname='FATES_NPP_FROOT_SZPF', & + call this%set_history_var(vname='FATES_FROOT_ALLOC_SZPF', & units='kg m-2 s-1', & - long='NPP flux into fine roots by pft/size in kg carbon per m2 per second', & + long='allocation to fine roots by pft/size in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_npp_fnrt_si_scpf) - call this%set_history_var(vname='FATES_NPP_BGSAPWOOD_SZPF', & + call this%set_history_var(vname='FATES_BGSAPWOOD_ALLOC_SZPF', & units='kg m-2 s-1', & - long='NPP flux into below-ground sapwood by pft/size in kg carbon per m2 per second', & + long='allocation to below-ground sapwood by pft/size in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_bgsw_si_scpf) - call this%set_history_var(vname='FATES_NPP_BGSTRUCT_SZPF', units='kg m-2 s-1', & - long='NPP flux into below-ground structural (deadwood) by pft/size in kg carbon per m2 per second', & + call this%set_history_var(vname='FATES_BGSTRUCT_ALLOC_SZPF', units='kg m-2 s-1', & + long='allocation to below-ground structural (deadwood) by pft/size in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_bgdw_si_scpf) - call this%set_history_var(vname='FATES_NPP_AGSAPWOOD_SZPF', & + call this%set_history_var(vname='FATES_AGSAPWOOD_ALLOC_SZPF', & units='kg m-2 s-1', & - long='NPP flux into above-ground sapwood by pft/size in kg carbon per m2 per second', & + long='allocation to above-ground sapwood by pft/size in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_agsw_si_scpf) - call this%set_history_var(vname = 'FATES_NPP_AGSTRUCT_SZPF', & + call this%set_history_var(vname = 'FATES_AGSTRUCT_ALLOC_SZPF', & units='kg m-2 s-1', & - long='NPP flux into above-ground structural (deadwood) by pft/size in kg carbon per m2 per second', & + long='allocation to above-ground structural (deadwood) by pft/size in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_agdw_si_scpf) - call this%set_history_var(vname = 'FATES_NPP_STORE_SZPF', & + call this%set_history_var(vname = 'FATES_STORE_ALLOC_SZPF', & units='kg m-2 s-1', & - long='NPP flux into storage C by pft/size in kg carbon per m2 per second', & + long='allocation to storage C by pft/size in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_stor_si_scpf) @@ -5518,12 +5518,12 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_ddbh_canopy_si_scpf) - call this%set_history_var(vname='FATES_DDBH_UNDERSTORY_SZPF', & + call this%set_history_var(vname='FATES_DDBH_USTORY_SZPF', & units = 'm m-2 yr-1', & long='diameter growth increment by pft/size', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_ddbh_understory_si_scpf) + initialize=initialize_variables, index = ih_ddbh_USTORY_si_scpf) call this%set_history_var(vname='FATES_BASALAREA_SZPF', units = 'm2 m-2', & long='basal area by pft/size', use_default='inactive', & @@ -5673,34 +5673,34 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_nplant_canopy_si_scpf) - call this%set_history_var(vname='FATES_MORTALITY_UNDERSTORY_SZPF', & + call this%set_history_var(vname='FATES_MORTALITY_USTORY_SZPF', & units = 'm-2 yr-1', & long='total mortality of understory plants by pft/size in number of plants per m2 per year', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_mortality_understory_si_scpf) + index = ih_mortality_USTORY_si_scpf) - call this%set_history_var(vname='FATES_STOREC_UNDERSTORY_SZPF', & + call this%set_history_var(vname='FATES_STOREC_USTORY_SZPF', & units = 'kg m-2', & long='biomass in storage pools of understory plants by pft/size in kg carbon per m2', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_bstor_understory_si_scpf) + initialize=initialize_variables, index = ih_bstor_USTORY_si_scpf) - call this%set_history_var(vname='FATES_LEAFC_UNDERSTORY_SZPF', & + call this%set_history_var(vname='FATES_LEAFC_USTORY_SZPF', & units = 'kg m-2', & long='biomass in leaves of understory plants by pft/size in kg carbon per m2', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_bleaf_understory_si_scpf) + initialize=initialize_variables, index = ih_bleaf_USTORY_si_scpf) - call this%set_history_var(vname='FATES_NPLANT_UNDERSTORY_SZPF', & + call this%set_history_var(vname='FATES_NPLANT_USTORY_SZPF', & units = 'm-2', & long='density of understory plants by pft/size in number of plants per m2', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_nplant_understory_si_scpf) + initialize=initialize_variables, index = ih_nplant_USTORY_si_scpf) call this%set_history_var(vname='FATES_CWD_ABOVEGROUND_DC', units='kg m-2', & long='debris class-level aboveground coarse woody debris stocks in kg carbon per m2', & @@ -5801,11 +5801,11 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_ddbh_canopy_si_scls) - call this%set_history_var(vname='FATES_DDBH_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_DDBH_USTORY_SZ', & units = 'm m-2 yr-1', long='diameter growth increment by size of understory plants', & use_default='active', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_ddbh_understory_si_scls) + initialize=initialize_variables, index = ih_ddbh_USTORY_si_scls) call this%set_history_var(vname='FATES_YESTCANLEV_CANOPY_SZ', & units = 'm-2', & @@ -5815,13 +5815,13 @@ subroutine define_history_vars(this, initialize_variables) initialize=initialize_variables, & index = ih_yesterdaycanopylevel_canopy_si_scls) - call this%set_history_var(vname='FATES_YESTCANLEV_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_YESTCANLEV_USTORY_SZ', & units = 'm-2', & long='yesterdays canopy level for understory plants by size class in number of plants per m2', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_yesterdaycanopylevel_understory_si_scls) + index = ih_yesterdaycanopylevel_USTORY_si_scls) call this%set_history_var(vname='FATES_BASALAREA_SZ', units = 'm2 m-2', & long='basal area by size class', use_default='active', & @@ -5881,26 +5881,26 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_mortality_canopy_si_scls) - call this%set_history_var(vname='FATES_NPLANT_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_NPLANT_USTORY_SZ', & units = 'm-2', & long='number of understory plants per m2 by size class', & use_default='active', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_nplant_understory_si_scls) + initialize=initialize_variables, index = ih_nplant_USTORY_si_scls) - call this%set_history_var(vname='FATES_LAI_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_LAI_USTORY_SZ', & units = 'm2 m-2', & long='leaf area index (LAI) of understory plants by size class', & use_default='active', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_lai_understory_si_scls) + initialize=initialize_variables, index = ih_lai_USTORY_si_scls) - call this%set_history_var(vname='FATES_SAI_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_SAI_USTORY_SZ', & units = 'm2 m-2', & long='stem area index (SAI) of understory plants by size class', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_sai_understory_si_scls) + initialize=initialize_variables, index = ih_sai_USTORY_si_scls) call this%set_history_var(vname='FATES_NPLANT_SZ', units = 'm-2', & long='number of plants per m2 by size class', use_default='active', & @@ -5997,20 +5997,20 @@ subroutine define_history_vars(this, initialize_variables) initialize=initialize_variables, & index = ih_carbon_balance_canopy_si_scls) - call this%set_history_var(vname='FATES_NPP_UNDERSTORY_SZ', units = 'kg m-2 s-1', & + call this%set_history_var(vname='FATES_NPP_USTORY_SZ', units = 'kg m-2 s-1', & long='NPP of understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_carbon_balance_understory_si_scls) + index = ih_carbon_balance_USTORY_si_scls) - call this%set_history_var(vname='FATES_MORTALITY_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_MORTALITY_USTORY_SZ', & units = 'm-2 yr-1', & long='total mortality of understory trees by size class in individuals per m2 per year', & use_default='active', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_mortality_understory_si_scls) + index = ih_mortality_USTORY_si_scls) call this%set_history_var(vname='FATES_TRIMMING_CANOPY_SZ', units = 'm-2', & long='trimming term of canopy plants weighted by plant density, by size class', & @@ -6018,13 +6018,13 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_trimming_canopy_si_scls) - call this%set_history_var(vname='FATES_TRIMMING_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_TRIMMING_USTORY_SZ', & units = 'm-2', & long='trimming term of understory plants weighted by plant density, by size class', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_trimming_understory_si_scls) + index = ih_trimming_USTORY_si_scls) call this%set_history_var(vname='FATES_CROWNAREA_CANOPY_SZ', units = 'm2 m-2', & long='total crown area of canopy plants by size class', & @@ -6032,11 +6032,11 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_crown_area_canopy_si_scls) - call this%set_history_var(vname='FATES_CROWNAREA_UNDERSTORY_SZ', units = 'm2 m-2', & + call this%set_history_var(vname='FATES_CROWNAREA_USTORY_SZ', units = 'm2 m-2', & long='total crown area of understory plants by size class', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_crown_area_understory_si_scls) + initialize=initialize_variables, index = ih_crown_area_USTORY_si_scls) call this%set_history_var(vname='FATES_LEAFCTURN_CANOPY_SZ', & units = 'kg m-2 s-1', & @@ -6080,44 +6080,44 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_seed_prod_canopy_si_scls) - call this%set_history_var(vname='FATES_NPP_LEAF_CANOPY_SZ', & + call this%set_history_var(vname='FATES_LEAF_ALLOC_CANOPY_SZ', & units = 'kg m-2 s-1', & - long='NPP flux into leaves for canopy plants by size class in kg carbon per m2 per second', & + long='allocation to leaves for canopy plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_leaf_canopy_si_scls) - call this%set_history_var(vname='FATES_NPP_FROOT_CANOPY_SZ', & + call this%set_history_var(vname='FATES_FROOT_ALLOC_CANOPY_SZ', & units = 'kg m-2 s-1', & - long='NPP flux into fine root C for canopy plants by size class in kg carbon per m2 per second', & + long='allocation to fine root C for canopy plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_fnrt_canopy_si_scls) - call this%set_history_var(vname='FATES_NPP_SAPWOOD_CANOPY_SZ', & + call this%set_history_var(vname='FATES_SAPWOOD_ALLOC_CANOPY_SZ', & units = 'kg m-2 s-1', & - long='NPP flux into sapwood C for canopy plants by size class in kg carbon per m2 per second', & + long='allocation to sapwood C for canopy plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_sapw_canopy_si_scls) - call this%set_history_var(vname='FATES_NPP_STRUCT_CANOPY_SZ', & + call this%set_history_var(vname='FATES_STRUCT_ALLOC_CANOPY_SZ', & units = 'kg m-2 s-1', & - long='NPP flux into structural C for canopy plants by size class in kg carbon per m2 per second', & + long='allocation to structural C for canopy plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_dead_canopy_si_scls) - call this%set_history_var(vname='FATES_NPP_SEED_CANOPY_SZ', & + call this%set_history_var(vname='FATES_SEED_ALLOC_CANOPY_SZ', & units = 'kg m-2 s-1', & - long='NPP flux into reproductive C for canopy plants by size class in kg carbon per m2 per second', & + long='allocation to reproductive C for canopy plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_seed_canopy_si_scls) - call this%set_history_var(vname='FATES_NPP_STORE_CANOPY_SZ', & + call this%set_history_var(vname='FATES_STORE_ALLOC_CANOPY_SZ', & units = 'kg m-2 s-1', & - long='NPP flux into storage C for canopy plants by size class in kg carbon per m2 per second', & + long='allocation to storage C for canopy plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_stor_canopy_si_scls) @@ -6194,140 +6194,140 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, index = ih_resp_m_canopy_si_scls) - call this%set_history_var(vname='FATES_LEAFCTURN_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_LEAFCTURN_USTORY_SZ', & units = 'kg m-2 s-1', & long='leaf turnover (non-mortal) for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_leaf_md_understory_si_scls) + index = ih_leaf_md_USTORY_si_scls) - call this%set_history_var(vname='FATES_FROOTCTURN_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_FROOTCTURN_USTORY_SZ', & units = 'kg m-2 s-1', & long='fine root turnover (non-mortal) for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_root_md_understory_si_scls) + index = ih_root_md_USTORY_si_scls) - call this%set_history_var(vname='FATES_STORECTUR_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_STORECTUR_USTORY_SZ', & units = 'kg m-2 s-1', & long='storage C turnover (non-mortal) for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_bstore_md_understory_si_scls) + index = ih_bstore_md_USTORY_si_scls) - call this%set_history_var(vname='FATES_STRUCTCTURN_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_STRUCTCTURN_USTORY_SZ', & units = 'kg m-2 s-1', & long='structural C turnover (non-mortal) for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_bdead_md_understory_si_scls) + index = ih_bdead_md_USTORY_si_scls) - call this%set_history_var(vname='FATES_SAPWOODCTURN_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_SAPWOODCTURN_USTORY_SZ', & units = 'kg m-2 s-1', & long='sapwood C turnover (non-mortal) for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_bsw_md_understory_si_scls) + initialize=initialize_variables, index = ih_bsw_md_USTORY_si_scls) - call this%set_history_var(vname='FATES_SEED_PROD_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_SEED_PROD_USTORY_SZ', & units = 'kg m-2 s-1', & long='seed production of understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_seed_prod_understory_si_scls) + index = ih_seed_prod_USTORY_si_scls) - call this%set_history_var(vname='FATES_NPP_LEAF_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_LEAF_ALLOC_USTORY_SZ', & units = 'kg m-2 s-1', & - long='NPP flux into leaves for understory plants by size class in kg carbon per m2 per second', & + long='allocation to leaves for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_npp_leaf_understory_si_scls) + index = ih_npp_leaf_USTORY_si_scls) - call this%set_history_var(vname='FATES_NPP_FROOT_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_FROOT_ALLOC_USTORY_SZ', & units = 'kg m-2 s-1', & - long='NPP flux into fine roots for understory plants by size class in kg carbon per m2 per second', & + long='allocation to fine roots for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_npp_fnrt_understory_si_scls) + index = ih_npp_fnrt_USTORY_si_scls) - call this%set_history_var(vname='FATES_NPP_SAPWOOD_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_SAPWOOD_ALLOC_USTORY_SZ', & units = 'kg m-2 s-1', & - long='NPP flux into sapwood C for understory plants by size class in kg carbon per m2 per second', & + long='allocation to sapwood C for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_npp_sapw_understory_si_scls) + index = ih_npp_sapw_USTORY_si_scls) - call this%set_history_var(vname='FATES_NPP_STRUCT_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_STRUCT_ALLOC_USTORY_SZ', & units = 'kg m-2 s-1', & - long='NPP flux into structural C for understory plants by size class in kg carbon per m2 per second', & + long='allocation to structural C for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_npp_dead_understory_si_scls) + index = ih_npp_dead_USTORY_si_scls) - call this%set_history_var(vname='FATES_NPP_SEED_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_SEED_ALLOC_USTORY_SZ', & units = 'kg m-2 s-1', & - long='NPP flux into reproductive C for understory plants by size class in kg carbon per m2 per second', & + long='allocation to reproductive C for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_npp_seed_understory_si_scls) + index = ih_npp_seed_USTORY_si_scls) - call this%set_history_var(vname='FATES_NPP_STORE_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_STORE_ALLOC_USTORY_SZ', & units = 'kg m-2 s-1', & - long='NPP flux into storage C for understory plants by size class in kg carbon per m2 per second', & + long='allocation to storage C for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_npp_stor_understory_si_scls) + index = ih_npp_stor_USTORY_si_scls) - call this%set_history_var(vname='FATES_RDARK_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_RDARK_USTORY_SZ', & units = 'kg m-2 s-1', & long='dark respiration for understory plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & - initialize=initialize_variables, index = ih_rdark_understory_si_scls) + initialize=initialize_variables, index = ih_rdark_USTORY_si_scls) - call this%set_history_var(vname='FATES_LSTEMMAINTAR_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_LSTEMMAINTAR_USTORY_SZ', & units = 'kg m-2 s-1', & long='live stem maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, & - index = ih_livestem_mr_understory_si_scls) + index = ih_livestem_mr_USTORY_si_scls) - call this%set_history_var(vname='FATES_CROOTMAINTAR_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_CROOTMAINTAR_USTORY_SZ', & units = 'kg m-2 s-1', & long='live coarse root maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, & - index = ih_livecroot_mr_understory_si_scls) + index = ih_livecroot_mr_USTORY_si_scls) - call this%set_history_var(vname='FATES_FROOTMAINTAR_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_FROOTMAINTAR_USTORY_SZ', & units = 'kg m-2 s-1', & long='fine root maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, & - index = ih_froot_mr_understory_si_scls) + index = ih_froot_mr_USTORY_si_scls) - call this%set_history_var(vname='FATES_GROWAR_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_GROWAR_USTORY_SZ', & units = 'kg m-2 s-1', & long='growth autotrophic respiration of understory plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & - initialize=initialize_variables, index = ih_resp_g_understory_si_scls) + initialize=initialize_variables, index = ih_resp_g_USTORY_si_scls) - call this%set_history_var(vname='FATES_MAINTAR_UNDERSTORY_SZ', & + call this%set_history_var(vname='FATES_MAINTAR_USTORY_SZ', & units = 'kg m-2 s-1', & long='maintenance autotrophic respiration of understory plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_resp_m_understory_si_scls) + index = ih_resp_m_USTORY_si_scls) ! CARBON BALANCE VARIABLES THAT DEPEND ON HLM BGC INPUTS @@ -6483,13 +6483,13 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_storentfrac_canopy_scpf) - call this%set_history_var(vname='FATES_STOREN_TF_UNDERSTORY_SZPF', & + call this%set_history_var(vname='FATES_STOREN_TF_USTORY_SZPF', & units='1', & long='storage nitrogen fraction (0-1) of target, in understory, by size-class x pft', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_storentfrac_understory_scpf) + index = ih_storentfrac_USTORY_scpf) call this%set_history_var(vname='FATES_REPRON_SZPF', units='kg m-2', & long='reproductive nitrogen mass (on plant) by size-class x pft in kg N per m2', & @@ -6565,13 +6565,13 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_storeptfrac_canopy_scpf) - call this%set_history_var(vname='FATES_STOREP_TF_UNDERSTORY_SZPF', & + call this%set_history_var(vname='FATES_STOREP_TF_USTORY_SZPF', & units='1', & long='storage phosphorus fraction (0-1) of target, in understory, by size-class x pft', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_storeptfrac_understory_scpf) + index = ih_storeptfrac_USTORY_scpf) call this%set_history_var(vname='FATES_REPROP_SZPF', units='kg m-2', & long='reproductive phosphorus mass (on plant) by size-class x pft in kg P per m2', & @@ -6603,38 +6603,38 @@ subroutine define_history_vars(this, initialize_variables) ! organ-partitioned NPP / allocation fluxes - call this%set_history_var(vname='FATES_NPP_LEAF', units='kg m-2 s-1', & - long='NPP flux into leaves in kg carbon per m2 per second', & + call this%set_history_var(vname='FATES_LEAF_ALLOC', units='kg m-2 s-1', & + long='allocation to leaves in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_leaf_si) - call this%set_history_var(vname='FATES_NPP_SEED', units='kg m-2 s-1', & - long='NPP flux into seeds in kg carbon per m2 per second', & + call this%set_history_var(vname='FATES_SEED_ALLOC', units='kg m-2 s-1', & + long='allocation to seeds in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_seed_si) - call this%set_history_var(vname='FATES_NPP_STEM', units='kg m-2 s-1', & - long='NPP flux into stem in kg carbon per m2 per second', & + call this%set_history_var(vname='FATES_STEM_ALLOC', units='kg m-2 s-1', & + long='allocation to stem in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_stem_si) - call this%set_history_var(vname='FATES_NPP_FROOT', units='kg m-2 s-1', & - long='NPP flux into fine roots in kg carbon per m2 per second', & + call this%set_history_var(vname='FATES_FROOT_ALLOC', units='kg m-2 s-1', & + long='allocation to fine roots in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_froot_si) - call this%set_history_var(vname='FATES_NPP_CROOT', units='kg m-2 s-1', & - long='NPP flux into coarse roots in kg carbon per m2 per second', & + call this%set_history_var(vname='FATES_CROOT_ALLOC', units='kg m-2 s-1', & + long='allocation to coarse roots in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_croot_si) - call this%set_history_var(vname='FATES_NPP_STORE', units='kg m-2 s-1', & - long='NPP flux into storage tissues in kg carbon per m2 per second', & + call this%set_history_var(vname='FATES_STORE_ALLOC', units='kg m-2 s-1', & + long='allocation to storage tissues in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_npp_stor_si) From 1e32d0247e23a4d5481abdd9f52e43d61112a74b Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Tue, 12 Oct 2021 09:19:26 -0600 Subject: [PATCH 437/578] ustory typo fix --- main/FatesHistoryInterfaceMod.F90 | 92 +++++++++++++++---------------- 1 file changed, 46 insertions(+), 46 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 37a4a62bcd..6639ef2e87 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -4934,7 +4934,7 @@ subroutine define_history_vars(this, initialize_variables) long='biomass of understory plants in kg carbon per m2 land area', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_USTORY_biomass_si) + index = ih_understory_biomass_si) ! disturbance rates @@ -5088,14 +5088,14 @@ subroutine define_history_vars(this, initialize_variables) long='gross primary production of understory plants in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_gpp_USTORY_si) + index = ih_gpp_understory_si) call this%set_history_var(vname='FATES_AUTORESP_UNDERSTORY', & units='kg m-2 s-1', & long='autotrophic respiration of understory plants in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_ar_USTORY_si) + index = ih_ar_understory_si) ! fast radiative fluxes resolved through the canopy @@ -5315,7 +5315,7 @@ subroutine define_history_vars(this, initialize_variables) long='flux of biomass carbon from live to dead pools from mortality of understory plants in kg carbon per m2 per second', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_USTORY_mortality_carbonflux_si) + index = ih_understory_mortality_carbonflux_si) ! size class by age dimensioned variables @@ -5331,12 +5331,12 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_nplant_canopy_si_scag) - call this%set_history_var(vname='FATES_NPLANT_USTORY_APSZ', & + call this%set_history_var(vname='FATES_NPLANT_USTORY_APSZ', & units = 'm-2', & long='number of plants per m2 in understory in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_nplant_USTORY_si_scag) + initialize=initialize_variables, index = ih_nplant_understory_si_scag) call this%set_history_var(vname='FATES_DDBH_CANOPY_APSZ', & units = 'm m-2 yr-1', & @@ -5345,12 +5345,12 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_ddbh_canopy_si_scag) - call this%set_history_var(vname='FATES_DDBH_USTORY_APSZ', & + call this%set_history_var(vname='FATES_DDBH_USTORY_APSZ', & units = 'm m-2 yr-1', & long='growth rate of understory plants in meters DBH per m2 per year in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_ddbh_USTORY_si_scag) + initialize=initialize_variables, index = ih_ddbh_understory_si_scag) call this%set_history_var(vname='FATES_MORTALITY_CANOPY_APSZ', & units = 'm-2 yr-1', & @@ -5359,12 +5359,12 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_mortality_canopy_si_scag) - call this%set_history_var(vname='FATES_MORTALITY_USTORY_APSZ', & + call this%set_history_var(vname='FATES_MORTALITY_USTORY_APSZ', & units = 'm-2 yr-1', & long='mortality rate of understory plants in number of plants per m2 per year in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_mortality_USTORY_si_scag) + initialize=initialize_variables, index = ih_mortality_understory_si_scag) ! size x age x pft dimensioned @@ -5423,14 +5423,14 @@ subroutine define_history_vars(this, initialize_variables) long='gross primary production of understory plants by pft/size in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_gpp_USTORY_si_scpf) + initialize=initialize_variables, index = ih_gpp_understory_si_scpf) call this%set_history_var(vname='FATES_AUTORESP_USTORY_SZPF', & units='kg m-2 s-1', & long='autotrophic respiration of understory plants by pft/size in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_ar_USTORY_si_scpf) + initialize=initialize_variables, index = ih_ar_understory_si_scpf) call this%set_history_var(vname='FATES_NPP_SZPF', units='kg m-2 s-1', & long='total net primary production by pft/size in kg carbon per m2 per second', & @@ -5523,7 +5523,7 @@ subroutine define_history_vars(this, initialize_variables) long='diameter growth increment by pft/size', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_ddbh_USTORY_si_scpf) + initialize=initialize_variables, index = ih_ddbh_understory_si_scpf) call this%set_history_var(vname='FATES_BASALAREA_SZPF', units = 'm2 m-2', & long='basal area by pft/size', use_default='inactive', & @@ -5679,28 +5679,28 @@ subroutine define_history_vars(this, initialize_variables) use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_mortality_USTORY_si_scpf) + index = ih_mortality_understory_si_scpf) call this%set_history_var(vname='FATES_STOREC_USTORY_SZPF', & units = 'kg m-2', & long='biomass in storage pools of understory plants by pft/size in kg carbon per m2', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_bstor_USTORY_si_scpf) + initialize=initialize_variables, index = ih_bstor_understory_si_scpf) call this%set_history_var(vname='FATES_LEAFC_USTORY_SZPF', & units = 'kg m-2', & long='biomass in leaves of understory plants by pft/size in kg carbon per m2', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_bleaf_USTORY_si_scpf) + initialize=initialize_variables, index = ih_bleaf_understory_si_scpf) call this%set_history_var(vname='FATES_NPLANT_USTORY_SZPF', & units = 'm-2', & long='density of understory plants by pft/size in number of plants per m2', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_nplant_USTORY_si_scpf) + initialize=initialize_variables, index = ih_nplant_understory_si_scpf) call this%set_history_var(vname='FATES_CWD_ABOVEGROUND_DC', units='kg m-2', & long='debris class-level aboveground coarse woody debris stocks in kg carbon per m2', & @@ -5805,7 +5805,7 @@ subroutine define_history_vars(this, initialize_variables) units = 'm m-2 yr-1', long='diameter growth increment by size of understory plants', & use_default='active', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_ddbh_USTORY_si_scls) + initialize=initialize_variables, index = ih_ddbh_understory_si_scls) call this%set_history_var(vname='FATES_YESTCANLEV_CANOPY_SZ', & units = 'm-2', & @@ -5821,7 +5821,7 @@ subroutine define_history_vars(this, initialize_variables) use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_yesterdaycanopylevel_USTORY_si_scls) + index = ih_yesterdaycanopylevel_understory_si_scls) call this%set_history_var(vname='FATES_BASALAREA_SZ', units = 'm2 m-2', & long='basal area by size class', use_default='active', & @@ -5886,21 +5886,21 @@ subroutine define_history_vars(this, initialize_variables) long='number of understory plants per m2 by size class', & use_default='active', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_nplant_USTORY_si_scls) + initialize=initialize_variables, index = ih_nplant_understory_si_scls) call this%set_history_var(vname='FATES_LAI_USTORY_SZ', & units = 'm2 m-2', & long='leaf area index (LAI) of understory plants by size class', & use_default='active', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_lai_USTORY_si_scls) + initialize=initialize_variables, index = ih_lai_understory_si_scls) call this%set_history_var(vname='FATES_SAI_USTORY_SZ', & units = 'm2 m-2', & long='stem area index (SAI) of understory plants by size class', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_sai_USTORY_si_scls) + initialize=initialize_variables, index = ih_sai_understory_si_scls) call this%set_history_var(vname='FATES_NPLANT_SZ', units = 'm-2', & long='number of plants per m2 by size class', use_default='active', & @@ -6002,7 +6002,7 @@ subroutine define_history_vars(this, initialize_variables) use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_carbon_balance_USTORY_si_scls) + index = ih_carbon_balance_understory_si_scls) call this%set_history_var(vname='FATES_MORTALITY_USTORY_SZ', & units = 'm-2 yr-1', & @@ -6010,7 +6010,7 @@ subroutine define_history_vars(this, initialize_variables) use_default='active', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_mortality_USTORY_si_scls) + index = ih_mortality_understory_si_scls) call this%set_history_var(vname='FATES_TRIMMING_CANOPY_SZ', units = 'm-2', & long='trimming term of canopy plants weighted by plant density, by size class', & @@ -6024,7 +6024,7 @@ subroutine define_history_vars(this, initialize_variables) use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_trimming_USTORY_si_scls) + index = ih_trimming_understory_si_scls) call this%set_history_var(vname='FATES_CROWNAREA_CANOPY_SZ', units = 'm2 m-2', & long='total crown area of canopy plants by size class', & @@ -6036,7 +6036,7 @@ subroutine define_history_vars(this, initialize_variables) long='total crown area of understory plants by size class', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_crown_area_USTORY_si_scls) + initialize=initialize_variables, index = ih_crown_area_understory_si_scls) call this%set_history_var(vname='FATES_LEAFCTURN_CANOPY_SZ', & units = 'kg m-2 s-1', & @@ -6200,7 +6200,7 @@ subroutine define_history_vars(this, initialize_variables) use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_leaf_md_USTORY_si_scls) + index = ih_leaf_md_understory_si_scls) call this%set_history_var(vname='FATES_FROOTCTURN_USTORY_SZ', & units = 'kg m-2 s-1', & @@ -6208,7 +6208,7 @@ subroutine define_history_vars(this, initialize_variables) use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_root_md_USTORY_si_scls) + index = ih_root_md_understory_si_scls) call this%set_history_var(vname='FATES_STORECTUR_USTORY_SZ', & units = 'kg m-2 s-1', & @@ -6216,7 +6216,7 @@ subroutine define_history_vars(this, initialize_variables) use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_bstore_md_USTORY_si_scls) + index = ih_bstore_md_understory_si_scls) call this%set_history_var(vname='FATES_STRUCTCTURN_USTORY_SZ', & units = 'kg m-2 s-1', & @@ -6224,14 +6224,14 @@ subroutine define_history_vars(this, initialize_variables) use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_bdead_md_USTORY_si_scls) + index = ih_bdead_md_understory_si_scls) call this%set_history_var(vname='FATES_SAPWOODCTURN_USTORY_SZ', & units = 'kg m-2 s-1', & long='sapwood C turnover (non-mortal) for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & - initialize=initialize_variables, index = ih_bsw_md_USTORY_si_scls) + initialize=initialize_variables, index = ih_bsw_md_understory_si_scls) call this%set_history_var(vname='FATES_SEED_PROD_USTORY_SZ', & units = 'kg m-2 s-1', & @@ -6239,56 +6239,56 @@ subroutine define_history_vars(this, initialize_variables) use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_seed_prod_USTORY_si_scls) + index = ih_seed_prod_understory_si_scls) call this%set_history_var(vname='FATES_LEAF_ALLOC_USTORY_SZ', & units = 'kg m-2 s-1', & long='allocation to leaves for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_npp_leaf_USTORY_si_scls) + index = ih_npp_leaf_understory_si_scls) call this%set_history_var(vname='FATES_FROOT_ALLOC_USTORY_SZ', & units = 'kg m-2 s-1', & long='allocation to fine roots for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_npp_fnrt_USTORY_si_scls) + index = ih_npp_fnrt_understory_si_scls) call this%set_history_var(vname='FATES_SAPWOOD_ALLOC_USTORY_SZ', & units = 'kg m-2 s-1', & long='allocation to sapwood C for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_npp_sapw_USTORY_si_scls) + index = ih_npp_sapw_understory_si_scls) call this%set_history_var(vname='FATES_STRUCT_ALLOC_USTORY_SZ', & units = 'kg m-2 s-1', & long='allocation to structural C for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_npp_dead_USTORY_si_scls) + index = ih_npp_dead_understory_si_scls) call this%set_history_var(vname='FATES_SEED_ALLOC_USTORY_SZ', & units = 'kg m-2 s-1', & long='allocation to reproductive C for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_npp_seed_USTORY_si_scls) + index = ih_npp_seed_understory_si_scls) call this%set_history_var(vname='FATES_STORE_ALLOC_USTORY_SZ', & units = 'kg m-2 s-1', & long='allocation to storage C for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_npp_stor_USTORY_si_scls) + index = ih_npp_stor_understory_si_scls) call this%set_history_var(vname='FATES_RDARK_USTORY_SZ', & units = 'kg m-2 s-1', & long='dark respiration for understory plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & - initialize=initialize_variables, index = ih_rdark_USTORY_si_scls) + initialize=initialize_variables, index = ih_rdark_understory_si_scls) call this%set_history_var(vname='FATES_LSTEMMAINTAR_USTORY_SZ', & units = 'kg m-2 s-1', & @@ -6296,7 +6296,7 @@ subroutine define_history_vars(this, initialize_variables) use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, & - index = ih_livestem_mr_USTORY_si_scls) + index = ih_livestem_mr_understory_si_scls) call this%set_history_var(vname='FATES_CROOTMAINTAR_USTORY_SZ', & units = 'kg m-2 s-1', & @@ -6304,7 +6304,7 @@ subroutine define_history_vars(this, initialize_variables) use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, & - index = ih_livecroot_mr_USTORY_si_scls) + index = ih_livecroot_mr_understory_si_scls) call this%set_history_var(vname='FATES_FROOTMAINTAR_USTORY_SZ', & units = 'kg m-2 s-1', & @@ -6312,14 +6312,14 @@ subroutine define_history_vars(this, initialize_variables) use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & initialize=initialize_variables, & - index = ih_froot_mr_USTORY_si_scls) + index = ih_froot_mr_understory_si_scls) call this%set_history_var(vname='FATES_GROWAR_USTORY_SZ', & units = 'kg m-2 s-1', & long='growth autotrophic respiration of understory plants in kg carbon per m2 per second by size', & use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, & - initialize=initialize_variables, index = ih_resp_g_USTORY_si_scls) + initialize=initialize_variables, index = ih_resp_g_understory_si_scls) call this%set_history_var(vname='FATES_MAINTAR_USTORY_SZ', & units = 'kg m-2 s-1', & @@ -6327,7 +6327,7 @@ subroutine define_history_vars(this, initialize_variables) use_default='inactive', avgflag='A', vtype=site_size_r8, & hlms='CLM:ALM', & upfreq=2, ivar=ivar, initialize=initialize_variables, & - index = ih_resp_m_USTORY_si_scls) + index = ih_resp_m_understory_si_scls) ! CARBON BALANCE VARIABLES THAT DEPEND ON HLM BGC INPUTS @@ -6489,7 +6489,7 @@ subroutine define_history_vars(this, initialize_variables) use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_storentfrac_USTORY_scpf) + index = ih_storentfrac_understory_scpf) call this%set_history_var(vname='FATES_REPRON_SZPF', units='kg m-2', & long='reproductive nitrogen mass (on plant) by size-class x pft in kg N per m2', & @@ -6571,7 +6571,7 @@ subroutine define_history_vars(this, initialize_variables) use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, & - index = ih_storeptfrac_USTORY_scpf) + index = ih_storeptfrac_understory_scpf) call this%set_history_var(vname='FATES_REPROP_SZPF', units='kg m-2', & long='reproductive phosphorus mass (on plant) by size-class x pft in kg P per m2', & From dc184e6140eea2ee88c148c4735bbeccaaffdc79 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Tue, 12 Oct 2021 10:00:05 -0600 Subject: [PATCH 438/578] fix typo in variable name --- main/FatesHistoryInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 6639ef2e87..08b9d166dd 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -6210,7 +6210,7 @@ subroutine define_history_vars(this, initialize_variables) initialize=initialize_variables, & index = ih_root_md_understory_si_scls) - call this%set_history_var(vname='FATES_STORECTUR_USTORY_SZ', & + call this%set_history_var(vname='FATES_STORECTURN_USTORY_SZ', & units = 'kg m-2 s-1', & long='storage C turnover (non-mortal) for understory plants by size class in kg carbon per m2 per second', & use_default='inactive', avgflag='A', vtype=site_size_r8, & From cf1b34c67dd03b93aabf2a8e2e5c59c174d017b4 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Thu, 14 Oct 2021 10:03:03 -0600 Subject: [PATCH 439/578] fix mistakes in unit conversion --- main/FatesHistoryInterfaceMod.F90 | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 08b9d166dd..3104687fab 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2289,7 +2289,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%n * AREA_INV) * leaf_m hio_storebiomass_si_pft(io_si,ft) = hio_storebiomass_si_pft(io_si,ft) + & - (ccohort%n * AREA_INV) * store_m * g_per_kg + (ccohort%n * AREA_INV) * store_m hio_nindivs_si_pft(io_si,ft) = hio_nindivs_si_pft(io_si,ft) + & ccohort%n * AREA_INV @@ -2472,7 +2472,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! growth increment hio_ddbh_si_scpf(io_si,scpf) = hio_ddbh_si_scpf(io_si,scpf) + & - ccohort%ddbhdt*ccohort%n / m2_per_ha + ccohort%ddbhdt*ccohort%n / m2_per_ha * m_per_cm end if @@ -2618,7 +2618,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_ddbh_canopy_si_scpf(io_si,scpf) = hio_ddbh_canopy_si_scpf(io_si,scpf) + & ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha hio_ddbh_canopy_si_scls(io_si,scls) = hio_ddbh_canopy_si_scls(io_si,scls) + & - ccohort%ddbhdt*ccohort%n + ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha ! sum of all mortality hio_mortality_canopy_si_scls(io_si,scls) = hio_mortality_canopy_si_scls(io_si,scls) + & @@ -2712,7 +2712,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_ddbh_understory_si_scpf(io_si,scpf) = hio_ddbh_understory_si_scpf(io_si,scpf) + & ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha hio_ddbh_understory_si_scls(io_si,scls) = hio_ddbh_understory_si_scls(io_si,scls) + & - ccohort%ddbhdt*ccohort%n + ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha ! sum of all mortality hio_mortality_understory_si_scls(io_si,scls) = hio_mortality_understory_si_scls(io_si,scls) + & @@ -2730,7 +2730,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%n * ha_per_m2 hio_carbon_balance_understory_si_scls(io_si,scls) = hio_carbon_balance_understory_si_scls(io_si,scls) + & - ccohort%npp_acc_hold * ccohort%n / m2_per_ha + ccohort%npp_acc_hold * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_leaf_md_understory_si_scls(io_si,scls) = hio_leaf_md_understory_si_scls(io_si,scls) + & leaf_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day @@ -2760,7 +2760,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) = & hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) + & - ccohort%canopy_layer_yesterday * ccohort%n + ccohort%canopy_layer_yesterday * ccohort%n / m2_per_ha endif ! ! @@ -2772,7 +2772,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) do i_scls = ccohort%size_class_lasttimestep + 1, scls i_scpf = (ccohort%pft-1)*nlevsclass+i_scls hio_growthflux_si_scpf(io_si,i_scpf) = hio_growthflux_si_scpf(io_si,i_scpf) + & - ccohort%n * days_per_year + ccohort%n / m2_per_ha end do end if ccohort%size_class_lasttimestep = scls @@ -2784,7 +2784,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! ! if cohort is new, track its growth flux into the first size bin i_scpf = (ccohort%pft-1)*nlevsclass+1 - hio_growthflux_si_scpf(io_si,i_scpf) = hio_growthflux_si_scpf(io_si,i_scpf) + ccohort%n * days_per_year + hio_growthflux_si_scpf(io_si,i_scpf) = hio_growthflux_si_scpf(io_si,i_scpf) + ccohort%n / m2_per_ha ccohort%size_class_lasttimestep = 1 end if @@ -3085,10 +3085,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! Sum up all input litter fluxes (above below, fines, cwd) [kg/ha/day] hio_litter_in_elem(io_si, el) = & - sum(flux_diags%cwd_ag_input(:)) + & + (sum(flux_diags%cwd_ag_input(:)) + & sum(flux_diags%cwd_bg_input(:)) + & sum(flux_diags%leaf_litter_input(:)) + & - sum(flux_diags%root_litter_input(:)) / m2_per_ha / sec_per_day + sum(flux_diags%root_litter_input(:))) / m2_per_ha / sec_per_day hio_cwd_ag_elem(io_si,el) = 0._r8 hio_cwd_bg_elem(io_si,el) = 0._r8 @@ -3201,7 +3201,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) sum(litt%seed_germ(:)) * cpatch%area / m2_per_ha / sec_per_day hio_seed_decay_elem(io_si,el) = hio_seed_decay_elem(io_si,el) + & - sum(litt%seed_decay(:) + litt%seed_germ_decay(:) ) * cpatch%area + sum(litt%seed_decay(:) + litt%seed_germ_decay(:) ) * & + cpatch%area / m2_per_ha / sec_per_day hio_seeds_in_local_elem(io_si,el) = hio_seeds_in_local_elem(io_si,el) + & sum(litt%seed_in_local(:)) * cpatch%area / m2_per_ha / sec_per_day @@ -4733,7 +4734,7 @@ subroutine define_history_vars(this, initialize_variables) long='seed mass decay (germinated and un-germinated) in kg element per m2 per second', & use_default='active', avgflag='A', vtype=site_elem_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & - index = ih_seed_decay_elem ) + index = ih_seed_decay_elem) ! SITE LEVEL CARBON STATE VARIABLES From f03f83a29e9b043425f72eb57b94ef2a5188590b Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Fri, 15 Oct 2021 09:39:02 -0600 Subject: [PATCH 440/578] fix unit conversion mistakes - c13 disc and growthflux --- main/FatesHistoryInterfaceMod.F90 | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 3104687fab..a68c6d80e1 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2419,7 +2419,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) capf => ccohort%coage_by_pft_class) - gpp_cached = hio_gpp_si_scpf(io_si,scpf) + gpp_cached = (hio_gpp_si_scpf(io_si,scpf)) * & + days_per_year * sec_per_day hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + & n_perm2*ccohort%gpp_acc_hold / & @@ -2772,7 +2773,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) do i_scls = ccohort%size_class_lasttimestep + 1, scls i_scpf = (ccohort%pft-1)*nlevsclass+i_scls hio_growthflux_si_scpf(io_si,i_scpf) = hio_growthflux_si_scpf(io_si,i_scpf) + & - ccohort%n / m2_per_ha + ccohort%n * days_per_year / m2_per_ha end do end if ccohort%size_class_lasttimestep = scls @@ -2784,7 +2785,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! ! if cohort is new, track its growth flux into the first size bin i_scpf = (ccohort%pft-1)*nlevsclass+1 - hio_growthflux_si_scpf(io_si,i_scpf) = hio_growthflux_si_scpf(io_si,i_scpf) + ccohort%n / m2_per_ha + hio_growthflux_si_scpf(io_si,i_scpf) = & + hio_growthflux_si_scpf(io_si,i_scpf) + ccohort%n * & + days_per_year / m2_per_ha ccohort%size_class_lasttimestep = 1 end if From 4ec0c61ed928a5fd25051fdad1bd2d2f02f5b754 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Mon, 18 Oct 2021 09:14:38 -0600 Subject: [PATCH 441/578] add site_int definition --- main/FatesHistoryInterfaceMod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index e7722817e2..60e62d3003 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -31,6 +31,7 @@ module FatesHistoryInterfaceMod use EDTypesMod , only : dtype_ilog use FatesIODimensionsMod , only : fates_io_dimension_type use FatesIOVariableKindMod , only : fates_io_variable_kind_type + use FatesIOVariableKindMod , only : site_int use FatesHistoryVariableType , only : fates_history_variable_type use FatesInterfaceTypesMod , only : hlm_hio_ignore_val use FatesInterfaceTypesMod , only : hlm_use_planthydro From a7327e4953e8941b32bf8a4ca7e05062777e80ff Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Mon, 18 Oct 2021 10:18:07 -0600 Subject: [PATCH 442/578] change zero_site_hvars to only take in currentSite --- main/EDMainMod.F90 | 6 +++--- main/FatesHistoryInterfaceMod.F90 | 30 +++++++++--------------------- 2 files changed, 12 insertions(+), 24 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 0f68bfc4fa..aa18dd2f5b 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -161,10 +161,10 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) call currentSite%flux_diags(el)%ZeroFluxDiags() end do - - call fates_hist%zero_site_hvars(sites,upfreq_in=1) - + call fates_hist%zero_site_hvars(currentSite,upfreq_in=1) + + ! Call a routine that simply identifies if logging should occur ! This is limited to a global event until more structured event handling is enabled call IsItLoggingTime(hlm_masterproc,currentSite) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 60e62d3003..d0400682c6 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1470,26 +1470,20 @@ end function levagefuel_index ! ====================================================================================== - - subroutine zero_site_hvars(this,sites,upfreq_in) - + subroutine zero_site_hvars(this, currentSite, upfreq_in) ! This routine zero's a history diagnostic variable ! but only zero's on fates sites ! This should be called prior to filling the variable ! and after they have been flushed to the ignore value - class(fates_history_interface_type) :: this - integer,intent(in) :: upfreq_in - type(ed_site_type),intent(in) :: sites(:) + class(fates_history_interface_type) :: this ! hvars_interface instance + integer, intent(in) :: upfreq_in ! + type(ed_site_type), intent(in), target :: currentSite ! site instance - integer :: ivar - integer :: nsites - integer :: s ! fates site index (1:nsites) + integer :: ivar ! history variable index integer :: ndims ! number of dimensions - nsites = ubound(sites,1) - do ivar=1,ubound(this%hvars,1) if (this%hvars(ivar)%upfreq == upfreq_in) then ! Only flush variables with update on dynamics step @@ -1501,17 +1495,11 @@ subroutine zero_site_hvars(this,sites,upfreq_in) end if if(ndims==1) then - do s = 1,nsites - this%hvars(ivar)%r81d(sites(s)%h_gid) = 0._r8 - end do + this%hvars(ivar)%r81d(currentSite%h_gid) = 0._r8 elseif(ndims==2) then - do s = 1,nsites - this%hvars(ivar)%r82d(sites(s)%h_gid,:) = 0._r8 - end do + this%hvars(ivar)%r82d(currentSite%h_gid,:) = 0._r8 elseif(ndims==3) then - do s = 1,nsites - this%hvars(ivar)%r83d(sites(s)%h_gid,:,:) = 0._r8 - end do + this%hvars(ivar)%r83d(currentSite%h_gid,:,:) = 0._r8 end if end if end do @@ -1519,7 +1507,7 @@ subroutine zero_site_hvars(this,sites,upfreq_in) return end subroutine zero_site_hvars - + ! ====================================================================================== subroutine flush_hvars(this,nc,upfreq_in) From 230c8023cabf3bd55af6ca4173b040384c48ca58 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Mon, 18 Oct 2021 10:23:07 -0600 Subject: [PATCH 443/578] move zero_site_hvars into site loops --- main/FatesHistoryInterfaceMod.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index d0400682c6..2a1b285c9d 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3593,12 +3593,13 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=2) - call this%zero_site_hvars(sites,upfreq_in=2) per_dt_tstep = 1.0_r8/dt_tstep do s = 1,nsites + call this%zero_site_hvars(sites(s), upfreq_in=2) + io_si = sites(s)%h_gid hio_nep_si(io_si) = -bc_in(s)%tot_het_resp / g_per_kg ! (kgC/m2/s) @@ -4018,7 +4019,6 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=4) - call this%zero_site_hvars(sites,upfreq_in=4) if(print_iterations) then do iscpf = 1,iterh2_nhist @@ -4027,6 +4027,8 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) end if do s = 1,nsites + call this%zero_site_hvars(sites(s),upfreq_in=4) + site_hydr => sites(s)%si_hydr nlevrhiz = site_hydr%nlevrhiz jr1 = site_hydr%i_rhiz_t From 75e37c6e18614709ddcffc619674678f5141e062 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 18 Oct 2021 13:15:37 -0400 Subject: [PATCH 444/578] First pass at adding warning functions --- biogeochem/EDPatchDynamicsMod.F90 | 16 +++--- main/FatesGlobals.F90 | 85 ++++++++++++++++++++++++++++++- 2 files changed, 92 insertions(+), 9 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index fda538e36e..b877028e2a 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -3,7 +3,8 @@ module EDPatchDynamicsMod ! ============================================================================ ! Controls formation, creation, fusing and termination of patch level processes. ! ============================================================================ - use FatesGlobals , only : fates_log + use FatesGlobals , only : fates_log + use FatesGlobals , only : FatesWarn,N2S,A2S use FatesInterfaceTypesMod , only : hlm_freq_day use EDPftvarcon , only : EDPftvarcon_inst use EDPftvarcon , only : GetDecompyFrac @@ -132,7 +133,8 @@ module EDPatchDynamicsMod real(r8), parameter :: treefall_localization = 0.0_r8 real(r8), parameter :: burn_localization = 0.0_r8 - + character(len=512) :: msg ! Message string for warnings and logging + ! 10/30/09: Created by Rosie Fisher ! ============================================================================ @@ -333,15 +335,15 @@ subroutine disturbance_rates( site_in, bc_in) end do ! Fires can't burn the whole patch, as this causes /0 errors. - if (debug) then - if (currentPatch%disturbance_rates(dtype_ifire) > 0.98_r8)then - write(fates_log(),*) 'very high fire areas', & - currentPatch%disturbance_rates(dtype_ifire),currentPatch%frac_burnt - endif + !if (currentPatch%disturbance_rates(dtype_ifire) > 0.98_r8)then + if(.true.)then + msg = 'very high fire areas'//trim(A2S(currentPatch%disturbance_rates(:)))//trim(N2S(currentPatch%frac_burnt)) + call FatesWarn(msg,index=2) endif + ! ------------------------------------------------------------------------------------------ ! Determine which disturbance is dominant, and force mortality diagnostics in the upper ! canopy to be zero for the non-dominant mode. Note: upper-canopy tree-fall mortality is diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 index d37ffe3b2a..48f8ffcdcb 100644 --- a/main/FatesGlobals.F90 +++ b/main/FatesGlobals.F90 @@ -17,7 +17,32 @@ module FatesGlobals public :: fates_log public :: fates_global_verbose public :: fates_endrun - + public :: FatesWarn + public :: A2S + public :: N2S + + ! ------------------------------------------------------------------------------------- + ! Warning handling + ! The objective here is to stop writing the same warning over and over again. After + ! we've seen the same machine print out the same warning over and over again, we get + ! the point and don't have to continue seeing the message. + ! We also allow warnings to have their own unique or group identifier, which will + ! make is to you only turn off warnings that are particularly chatty, and continue + ! to allow warnings elsewhere that have not tripped as often. + ! ------------------------------------------------------------------------------------- + + integer, parameter :: max_ids = 200 ! Maximum number of unique warning ids + ! expand as necessary + integer :: warn_counts(0:max_ids) = 0 ! Total number of times each id has warned + integer, parameter :: max_warnings = 100 ! The maximum number of warnings before we + ! stop writing the warning + logical :: warn_active(0:max_ids) = .true. ! The current status of the warning. + logical, parameter :: warning_override = .false. ! If you really don't want any warnings + ! you can set this to true to avoid + ! printing any of these warnings to the log + ! It should also bypass the logicals bound inside + ! at the compiler level (?) and be faster + contains @@ -67,6 +92,62 @@ subroutine fates_endrun(msg) end subroutine fates_endrun ! ===================================================================================== - + subroutine FatesWarn(msg,index) + + character(len=*), intent(in) :: msg ! string to be printed + integer,optional,intent(in) :: index ! warning index + + integer :: ind + + if(warning_override) return ! Exit early if we are turning off warnings + + if(present(index))then + ind = index + else + ind = 0 + end if + + ! Don't check if the index is within bounds, this routine could already + ! be too expensive if this is in cohort loops + warn_counts(ind) = warn_counts(ind) + 1 + + if(warn_active(ind))then + write(fates_log(),*) 'FWARN: ',ind,'m: ',msg + if(warn_counts(ind)> max_warnings) then + warn_active(ind) = .false. + write(fates_log(),*) 'FWARN: ',ind,'has saturated messaging, no longer reporting' + end if + end if + return + end subroutine FatesWarn + + ! ===================================================================================== + + function N2S(real_in) result(str) + + real(r8) :: real_in + character(len=16) :: str + + !write(str,*) real_in + write(str,'(a,E12.6)') ', ',real_in + + end function N2S + + ! ===================================================================================== + + function A2S(reals_in) result(str) + + real(r8) :: reals_in(:) + character(len=512) :: str + character(len=16) :: str_frag + integer :: i, nreal + + str = ', ' + do i = 1,ubound(reals_in,1) + str = trim(str)//', '//N2S(reals_in(i)) + end do + + end function A2S + end module FatesGlobals From e760438f82bc02422165a167a048e9c75906dffb Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 21 Oct 2021 02:55:51 -0600 Subject: [PATCH 445/578] updates to fabs and fabs_leaf --- biogeophys/EDSurfaceAlbedoMod.F90 | 11 +- tools/FatesPFTIndexSwapper_rf.py | 274 ++++++++++++++++++++++++++++++ 2 files changed, 282 insertions(+), 3 deletions(-) create mode 100755 tools/FatesPFTIndexSwapper_rf.py diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 1655c59819..7c1cb08a4a 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -328,9 +328,6 @@ subroutine PatchNormanRadiation (currentPatch, & endif !frac_lai = 1.0_r8 ! make the same as previous codebase, in theory. frac_sai = 1.0_r8 - frac_lai - f_abs(L,ft,iv,ib) = 1.0_r8 - (frac_lai*(rhol(ft,ib) + taul(ft,ib))+& - frac_sai*(rhos(ft,ib) + taus(ft,ib))) - f_abs_leaf(L,ft,iv,ib) = frac_lai*(1.0_r8 - rhol(ft,ib) - taul(ft,ib))/f_abs(L,ft,iv,ib) rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) tau_layer(L,ft,iv,ib)=frac_lai*taul(ft,ib)+frac_sai*taus(ft,ib) @@ -340,6 +337,14 @@ subroutine PatchNormanRadiation (currentPatch, & + rho_snow(ib) * currentPatch%fcansno tau_layer(L,ft,iv,ib)=tau_layer(L,ft,iv,ib)*(1.0_r8- currentPatch%fcansno) & + tau_snow(ib) * currentPatch%fcansno + + ! fraction of incoming light absorbed by leaves or stems. + f_abs(L,ft,iv,ib) = 1.0_r8 - tau_layer(L,ft,iv,ib) - rho_layer(L,ft,iv,ib) + + ! the fraction of the vegetation absorbed light which is absorbed by leaves + f_abs_leaf(L,ft,iv,ib) = (1.0_r8- currentPatch%fcansno) * frac_lai* & + (1.0_r8 - rhol(ft,ib) - taul(ft,ib))/f_abs(L,ft,iv,ib) + end do !ib endif end do !iv diff --git a/tools/FatesPFTIndexSwapper_rf.py b/tools/FatesPFTIndexSwapper_rf.py new file mode 100755 index 0000000000..7e39056fa8 --- /dev/null +++ b/tools/FatesPFTIndexSwapper_rf.py @@ -0,0 +1,274 @@ +#!/usr/bin/env python + +# ======================================================================================= +# +# This python script will open an input FATES parameter file, and given a list of PFT +# indices supplied by the user, will create a new parameter file with PFTs entries cloned +# from the original file as-per the list of indices supplied by the user. +# +# First Added, Ryan Knox: Thu Jan 11 13:36:14 PST 2018 +# ======================================================================================= + +import numpy as np +from numpy import * +import sys +import getopt +import code # For development: code.interact(local=locals()) +from datetime import datetime +from scipy.io import netcdf +#import matplotlib.pyplot as plt + + +# ======================================================================================= +# Parameters +# ======================================================================================= + +pft_dim_name = 'fates_pft' +prt_dim_name = 'fates_prt_organs' +hydro_dim_name = 'fates_hydr_organs' +litt_dim_name = 'fates_litterclass' +string_dim_name = 'fates_string_length' + +class timetype: + + # This is time, like the thing that always goes forward and cant be seen + # or touched, insert creative riddle here + + def __init__(self,ntimes): + + self.year = -9*np.ones((ntimes)) + self.month = -9*np.ones((ntimes)) + # This is a floating point decimal day + self.day = -9.0*np.ones((ntimes)) + + # This is a decimal datenumber + self.datenum = -9.0*np.ones((ntimes)) + + +def usage(): + print('') + print('=======================================================================') + print('') + print(' python FatesPFTIndexSwapper.py -h --pft-indices= ') + print(' --fin= ') + print(' --fout=') + print('') + print('') + print(' -h --help ') + print(' print this help message') + print('') + print('') + print(' --pft-indices=') + print(' This is a comma delimited list of integer positions of the PFTs') + print(' to be copied into the new file. Note that first pft position') + print(' is treated as 1 (not C or python like), and any order or multiples') + print(' of indices can be chosen') + print('') + print('') + print(' --fin=') + print(' This is the full path to the netcdf file you are basing off of') + print('') + print('') + print(' --fout=') + print(' This is the full path to the netcdf file you are writing to.') + print('') + print('') + print('=======================================================================') + + +def interp_args(argv): + + argv.pop(0) # The script itself is the first argument, forget it + + # Name of the conversion file + + input_fname = "none" + output_fname = "none" + donor_pft_indices = -9 + donot_pft_indices_str = '' + try: + opts, args = getopt.getopt(argv, 'h',["fin=","fout=","pft-indices="]) + except getopt.GetoptError as err: + print('Argument error, see usage') + usage() + sys.exit(2) + + for o, a in opts: + if o in ("-h", "--help"): + usage() + sys.exit(0) + elif o in ("--fin"): + input_fname = a + elif o in ("--fout"): + output_fname = a + elif o in ("--pft-indices"): + donor_pft_indices_str = a.strip() + else: + assert False, "unhandled option" + + + if (input_fname == "none"): + print("You must specify an input file:\n\n") + usage() + sys.exit(2) + + if (output_fname == "none"): + print("You must specify an output file:\n\n") + usage() + sys.exit(2) + + if (donor_pft_indices_str == ''): + print("You must specify at least one donor pft index!\n\n") + usage() + sys.exit(2) + else: + donor_pft_indices = [] + for strpft in donor_pft_indices_str.split(','): + donor_pft_indices.append(int(strpft)) + + + return (input_fname,output_fname,donor_pft_indices) + + +# ======================================================================================== +# ======================================================================================== +# Main +# ======================================================================================== +# ======================================================================================== + +def main(argv): + + # Interpret the arguments to the script + [input_fname,output_fname,donor_pft_indices] = interp_args(argv) + + num_pft_out = len(donor_pft_indices) + + # Open the netcdf files + fp_out = netcdf.netcdf_file(output_fname, 'w') + + fp_in = netcdf.netcdf_file(input_fname, 'r') + + for key, value in sorted(fp_in.dimensions.items()): + if(key==pft_dim_name): + fp_out.createDimension(key,int(num_pft_out)) + print('Creating Dimension: {}={}'.format(key,num_pft_out)) + else: + fp_out.createDimension(key,int(value)) + print('Creating Dimension: {}={}'.format(key,value)) + + for key, value in sorted(fp_in.variables.items()): + print('Creating Variable: ',key) + # code.interact(local=locals()) + + + in_var = fp_in.variables.get(key) + + + # Idenfity if this variable has pft dimension + pft_dim_found = -1 + prt_dim_found = -1 + hydro_dim_found = -1 + litt_dim_found = -1 + string_dim_found = -1 + pft_dim_len = len(fp_in.variables.get(key).dimensions) + + for idim, name in enumerate(fp_in.variables.get(key).dimensions): + + # Manipulate data + if(name==pft_dim_name): + pft_dim_found = idim + if(name==prt_dim_name): + prt_dim_found = idim + if(name==litt_dim_name): + litt_dim_found = idim + if(name==hydro_dim_name): + hydro_dim_found = idim + if(name==string_dim_name): + string_dim_found = idim + + # Copy over the input data + # Tedious, but I have to permute through all combinations of dimension position + if( pft_dim_len == 0 ): + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + out_var.assignValue(float(fp_in.variables.get(key).data)) + elif( (pft_dim_found==-1) & (prt_dim_found==-1) & (litt_dim_found==-1) & (hydro_dim_found==-1) ): + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + elif( (pft_dim_found==0) & (pft_dim_len==1) ): # 1D fates_pft + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + tmp_out = np.zeros([num_pft_out]) + for id,ipft in enumerate(donor_pft_indices): + tmp_out[id] = fp_in.variables.get(key).data[ipft-1] + out_var[:] = tmp_out + + # 2D hydro_organ - fates_pft + # or.. prt_organ - fates_pft + elif( (pft_dim_found==1) & (pft_dim_len==2) ): + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + dim2_len = fp_in.dimensions.get(fp_in.variables.get(key).dimensions[0]) + tmp_out = np.zeros([dim2_len,num_pft_out]) + for id,ipft in enumerate(donor_pft_indices): + for idim in range(0,dim2_len): + tmp_out[idim,id] = fp_in.variables.get(key).data[idim,ipft-1] + out_var[:] = tmp_out + + elif( (pft_dim_found==0) & (pft_dim_len==2) ): # fates_pft - string_length + out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) + dim2_len = fp_in.dimensions.get(fp_in.variables.get(key).dimensions[1]) + out_var[:] = np.empty([num_pft_out,dim2_len], dtype="S{}".format(dim2_len)) + for id,ipft in enumerate(donor_pft_indices): + out_var[id] = fp_in.variables.get(key).data[ipft-1] + + elif( (prt_dim_found==0) & (pft_dim_len==2) ): + out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + + elif( (hydro_dim_found==0) & (string_dim_found>=0) ): + out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + + elif( (litt_dim_found==0) & (string_dim_found>=0) ): + out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + + elif( prt_dim_found==0 ): # fates_prt_organs - indices + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + + elif( litt_dim_found==0 ): + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + elif( hydro_dim_found==0): + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + else: + print('This variable has a dimensioning that we have not considered yet.') + print('Please add this condition to the logic above this statement.') + print('Aborting') + for idim, name in enumerate(fp_in.variables.get(key).dimensions): + print("idim: {}, name: {}".format(idim,name)) + exit(2) + + out_var.units = in_var.units + out_var.long_name = in_var.long_name + + fp_out.history = "This file was made from FatesPFTIndexSwapper.py \n Input File = {} \n Indices = {}"\ + .format(input_fname,donor_pft_indices) + + #var_out.mode = var.mode + #fp.flush() + + fp_in.close() + fp_out.close() + + print('Cloneing complete!') + exit(0) + + + + +# ======================================================================================= +# This is the actual call to main + +if __name__ == "__main__": + main(sys.argv) From 6023f7218823e223a6b4b4f8f7cd698f8808bfe2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 22 Oct 2021 13:29:41 -0400 Subject: [PATCH 446/578] Commented out cohort-level vegetation temp averages, as they are redundant with patch-level given how the HLMs handle temperature physics --- biogeochem/EDCanopyStructureMod.F90 | 14 ++++--- biogeochem/EDCohortDynamicsMod.F90 | 15 +++++--- biogeochem/EDPatchDynamicsMod.F90 | 6 ++- main/EDInitMod.F90 | 11 +++--- main/EDPftvarcon.F90 | 27 +++++++------ main/EDTypesMod.F90 | 6 ++- main/FatesInterfaceMod.F90 | 59 +++++++++++++++-------------- main/FatesInventoryInitMod.F90 | 5 ++- main/FatesRestartInterfaceMod.F90 | 28 +++++++++----- 9 files changed, 99 insertions(+), 72 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index c48d702000..5f8261ae26 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -669,10 +669,11 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) call InitHydrCohort(currentSite,copyc) endif + ! (keep as an example) ! Initialize running means - allocate(copyc%tveg_lpa) - call copyc%tveg_lpa%InitRMean(ema_lpa, & - init_value=currentPatch%tveg_lpa%GetMean()) + !allocate(copyc%tveg_lpa) + !call copyc%tveg_lpa%InitRMean(ema_lpa, & + ! init_value=currentPatch%tveg_lpa%GetMean()) call copy_cohort(currentCohort, copyc) @@ -1127,10 +1128,11 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) call InitHydrCohort(CurrentSite,copyc) endif + ! (keep as an example) ! Initialize running means - allocate(copyc%tveg_lpa) - call copyc%tveg_lpa%InitRMean(ema_lpa,& - init_value=currentPatch%tveg_lpa%GetMean()) + !allocate(copyc%tveg_lpa) + !call copyc%tveg_lpa%InitRMean(ema_lpa,& + ! init_value=currentPatch%tveg_lpa%GetMean()) call copy_cohort(currentCohort, copyc) !makes an identical copy... diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 4d9258b276..893c0e66db 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -310,8 +310,10 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & ! Allocate running mean functions - allocate(new_cohort%tveg_lpa) - call new_cohort%tveg_lpa%InitRMean(ema_lpa,init_value=patchptr%tveg_lpa%GetMean()) + + ! (Keeping as an example) + !! allocate(new_cohort%tveg_lpa) + !! call new_cohort%tveg_lpa%InitRMean(ema_lpa,init_value=patchptr%tveg_lpa%GetMean()) ! Recuits do not have mortality rates, nor have they moved any @@ -1004,8 +1006,9 @@ subroutine DeallocateCohort(currentCohort) type(ed_cohort_type),intent(inout) :: currentCohort + ! (Keeping as an example) ! Remove the running mean structure - deallocate(currentCohort%tveg_lpa) + ! deallocate(currentCohort%tveg_lpa) ! At this point, nothing should be pointing to current Cohort if (hlm_use_planthydro.eq.itrue) call DeallocateHydrCohort(currentCohort) @@ -1170,9 +1173,10 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) end do end if + ! (Keeping as an example) ! Running mean fuses based on number density fraction just ! like other variables - call currentCohort%tveg_lpa%FuseRMean(nextc%tveg_lpa,currentCohort%n/newn) + !!call currentCohort%tveg_lpa%FuseRMean(nextc%tveg_lpa,currentCohort%n/newn) ! new cohort age is weighted mean of two cohorts currentCohort%coage = & @@ -1816,8 +1820,9 @@ subroutine copy_cohort( currentCohort,copyc ) n%tpu25top = o%tpu25top n%kp25top = o%kp25top + ! (Keeping as an example) ! Copy over running means - call n%tveg_lpa%CopyFromDonor(o%tveg_lpa) + ! call n%tveg_lpa%CopyFromDonor(o%tveg_lpa) ! CARBON FLUXES n%gpp_acc_hold = o%gpp_acc_hold diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index fe53d69f0b..54dd928bd8 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -703,9 +703,11 @@ subroutine spawn_patches( currentSite, bc_in) nc%prt => null() call InitPRTObject(nc%prt) call InitPRTBoundaryConditions(nc) + + ! (Keeping as an example) ! Allocate running mean functions - allocate(nc%tveg_lpa) - call nc%tveg_lpa%InitRMean(ema_lpa,init_value=new_patch%tveg_lpa%GetMean()) + !allocate(nc%tveg_lpa) + !call nc%tveg_lpa%InitRMean(ema_lpa,init_value=new_patch%tveg_lpa%GetMean()) call zero_cohort(nc) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 87fc570a72..6e35c38fe2 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -896,12 +896,13 @@ subroutine init_cohorts( site_in, patch_in, bc_in) endif !use_this_pft enddo !numpft + ! (Keeping as an example) ! Pass patch level temperature to the new cohorts (this is a nominal 15C right now) - temp_cohort => patch_in%tallest - do while(associated(temp_cohort)) - call temp_cohort%tveg_lpa%UpdateRmean(patch_in%tveg_lpa%GetMean()) - temp_cohort => temp_cohort%shorter - end do + !temp_cohort => patch_in%tallest + !do while(associated(temp_cohort)) + !call temp_cohort%tveg_lpa%UpdateRmean(patch_in%tveg_lpa%GetMean()) + !temp_cohort => temp_cohort%shorter + !end do call fuse_cohorts(site_in, patch_in,bc_in) call sort_cohorts(patch_in) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 89c0cf2ea5..46366d7275 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -1475,7 +1475,7 @@ subroutine FatesCheckParams(is_master) use FatesConstantsMod , only : fates_check_param_set use FatesConstantsMod , only : itrue, ifalse use EDParamsMod , only : logging_mechanical_frac, logging_collateral_frac, logging_direct_frac - use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog + use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog,hlm_use_sp ! Argument logical, intent(in) :: is_master ! Only log if this is the master proc @@ -1740,17 +1740,20 @@ subroutine FatesCheckParams(is_master) ! check that the host-fates PFT map adds to one along HLM dimension so that all the HLM area ! goes to a FATES PFT. Each FATES PFT can get < or > 1 of an HLM PFT. - do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) - sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft)) - if(abs(sumarea-1.0_r8).gt.nearzero)then - write(fates_log(),*) 'The distribution of this host land model PFT :',hlm_pft - write(fates_log(),*) 'into FATES PFTs, does not add up to 1.0.' - write(fates_log(),*) 'Error is:',sumarea-1.0_r8 - write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft) - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end do !hlm_pft + if((hlm_use_fixed_biogeog.eq.itrue) .or. (hlm_use_sp.eq.itrue)) then + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft)) + if(abs(sumarea-1.0_r8).gt.nearzero)then + write(fates_log(),*) 'The distribution of this host land model PFT :',hlm_pft + write(fates_log(),*) 'into FATES PFTs, does not add up to 1.0.' + write(fates_log(),*) 'Error is:',sumarea-1.0_r8 + write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft) + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do !hlm_pft + end if + end do !ipft diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 7ddc717986..bcbbd2a180 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -389,8 +389,10 @@ module EDTypesMod ! Running means - class(rmean_type), pointer :: tveg_lpa ! exponential moving average of leaf temperature at the - ! leaf photosynthetic acclimation time-scale [K] + + ! (keeping this in-code as an example) + !class(rmean_type), pointer :: tveg_lpa ! exponential moving average of leaf temperature at the + ! leaf photosynthetic acclimation time-scale [K] end type ed_cohort_type diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index b606cbdb9e..b288781c4d 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -147,6 +147,7 @@ module FatesInterfaceMod public :: zero_bcs public :: set_bcs public :: UpdateFatesRMeansTStep + public :: InitTimeAveragingGlobals contains @@ -730,7 +731,7 @@ subroutine SetFatesGlobalElements(use_fates) if (use_fates) then - ! first read the non-PFT parameters + ! Self explanatory, read the fates parameter file call FatesReadParameters() ! Identify the number of PFTs by evaluating a pft array @@ -873,15 +874,7 @@ subroutine SetFatesGlobalElements(use_fates) ! These will not be used if use_ed or use_fates is false call fates_history_maps() - - ! Instantiate the time-averaging method globals - allocate(ema_24hr) - call ema_24hr%define(sec_per_day, hlm_stepsize, moving_ema_window) - allocate(fixed_24hr) - call fixed_24hr%define(sec_per_day, hlm_stepsize, fixed_window) - allocate(ema_lpa) - call ema_lpa%define(photo_temp_acclim_timescale*sec_per_day, & - hlm_stepsize,moving_ema_window) + else ! If we are not using FATES, the cohort dimension is still @@ -898,6 +891,27 @@ subroutine SetFatesGlobalElements(use_fates) end subroutine SetFatesGlobalElements + ! ====================================================================== + + subroutine InitTimeAveragingGlobals() + + ! Instantiate the time-averaging method globals + ! NOTE: It may be possible in the future that the HLM model timesteps + ! are dynamic in time or space, in that case, these would no longer + ! be global constants. + + allocate(ema_24hr) + call ema_24hr%define(sec_per_day, hlm_stepsize, moving_ema_window) + allocate(fixed_24hr) + call fixed_24hr%define(sec_per_day, hlm_stepsize, fixed_window) + allocate(ema_lpa) + call ema_lpa%define(photo_temp_acclim_timescale*sec_per_day, & + hlm_stepsize,moving_ema_window) + + return + end subroutine InitTimeAveragingGlobals + + ! ====================================================================== subroutine InitPARTEHGlobals() @@ -1241,7 +1255,6 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_numlevgrnd = unset_int hlm_name = 'unset' hlm_hio_ignore_val = unset_double - hlm_stepsize = unset_double hlm_masterproc = unset_int hlm_ipedof = unset_int hlm_nu_com = 'unset' @@ -1451,14 +1464,6 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if( abs(hlm_stepsize-unset_double) cpatch%tallest - do while (associated(ccohort)) - call ccohort%tveg_lpa%UpdateRMean(bc_in(s)%t_veg_pa(ifp)) - ccohort => ccohort%shorter - end do + ! (Keeping as an example) + !ccohort => cpatch%tallest + !do while (associated(ccohort)) + ! call ccohort%tveg_lpa%UpdateRMean(bc_in(s)%t_veg_pa(ifp)) + ! ccohort => ccohort%shorter + !end do cpatch => cpatch%younger enddo diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 3bf021d004..507f01dbee 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -1071,9 +1071,10 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & prt_obj => null() call InitPRTObject(prt_obj) + ! (Keeping as an example) ! Allocate running mean functions - allocate(temp_cohort%tveg_lpa) - call temp_cohort%tveg_lpa%InitRMean(ema_lpa,init_value=cpatch%tveg_lpa%GetMean()) + !allocate(temp_cohort%tveg_lpa) + !call temp_cohort%tveg_lpa%InitRMean(ema_lpa,init_value=cpatch%tveg_lpa%GetMean()) do el = 1,num_elements diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 6436802bea..c641f5096f 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -147,7 +147,9 @@ module FatesRestartInterfaceMod ! Running Means integer :: ir_tveg24_pa integer :: ir_tveglpa_pa - integer :: ir_tveglpa_co + + ! (Keeping as an example) + !!integer :: ir_tveglpa_co integer :: ir_ddbhdt_co integer :: ir_resp_tstep_co @@ -591,6 +593,10 @@ subroutine define_restart_vars(this, initialize_variables) ivar=0 + print*,"ABOUT TO DEFINE RESTARTS" + stop + + ! ----------------------------------------------------------------------------------- ! Site level variables ! ----------------------------------------------------------------------------------- @@ -1266,10 +1272,11 @@ subroutine define_restart_vars(this, initialize_variables) call this%DefineRMeanRestartVar(vname='fates_tveglpapatch',vtype=cohort_r8, & long_name='running average (EMA) of patch veg temp for photo acclim', & units='K', initialize=initialize_variables,ivar=ivar, index = ir_tveglpa_pa) - - call this%DefineRMeanRestartVar(vname='fates_tveglpacohort',vtype=cohort_r8, & - long_name='running average (EMA) of cohort veg temp for photo acclim', & - units='K', initialize=initialize_variables,ivar=ivar, index = ir_tveglpa_co) + + ! (Keeping as an example) + !call this%DefineRMeanRestartVar(vname='fates_tveglpacohort',vtype=cohort_r8, & + ! long_name='running average (EMA) of cohort veg temp for photo acclim', & + ! units='K', initialize=initialize_variables,ivar=ivar, index = ir_tveglpa_co) ! Register all of the PRT states and fluxes @@ -2050,7 +2057,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) cohortsperpatch endif - call this%SetRMeanRestartVar(ccohort%tveg_lpa, ir_tveglpa_co, io_idx_co) + ! (Keeping as an example) + ! call this%SetRMeanRestartVar(ccohort%tveg_lpa, ir_tveglpa_co, io_idx_co) io_idx_co = io_idx_co + 1 @@ -2431,9 +2439,10 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in, bc_out) call InitHydrCohort(sites(s),new_cohort) end if + ! (Keeping as an example) ! Allocate running mean functions - allocate(new_cohort%tveg_lpa) - call new_cohort%tveg_lpa%InitRMean(ema_lpa) + !allocate(new_cohort%tveg_lpa) + !call new_cohort%tveg_lpa%InitRMean(ema_lpa) ! Update the previous @@ -2851,7 +2860,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) end if - call this%GetRMeanRestartVar(ccohort%tveg_lpa, ir_tveglpa_co, io_idx_co) + ! (Keeping as an example) + !call this%GetRMeanRestartVar(ccohort%tveg_lpa, ir_tveglpa_co, io_idx_co) if (hlm_use_sp .eq. itrue) then ccohort%c_area = this%rvars(ir_c_area_co)%r81d(io_idx_co) From 657b135bae79f264df88d1f7e5e6e988eec18984 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 22 Oct 2021 15:18:00 -0600 Subject: [PATCH 447/578] Removing debug print --- main/FatesRestartInterfaceMod.F90 | 4 ---- 1 file changed, 4 deletions(-) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index c641f5096f..f51a231ba3 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -593,10 +593,6 @@ subroutine define_restart_vars(this, initialize_variables) ivar=0 - print*,"ABOUT TO DEFINE RESTARTS" - stop - - ! ----------------------------------------------------------------------------------- ! Site level variables ! ----------------------------------------------------------------------------------- From abc07905819a9068b819d68c5422615c6b09998a Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 22 Oct 2021 17:31:30 -0600 Subject: [PATCH 448/578] fixed some stuff: variable descriptions, removed one unused variable, do a check only when needed --- biogeochem/FatesAllometryMod.F90 | 15 +++++++-------- main/EDPftvarcon.F90 | 32 +++++++++++++++++--------------- main/EDTypesMod.F90 | 2 -- 3 files changed, 24 insertions(+), 25 deletions(-) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index e47934715d..9f78f2ea67 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -1330,16 +1330,15 @@ subroutine d2blmax_2pwr(d,p1,p2,c2b,blmax,dblmaxdd) ! ====================================================================== ! This is a power function for leaf biomass from plant diameter. - ! - ! log(bl) = a2 + b2*log(h) - ! bl = exp(a2) * h**b2 ! ====================================================================== + ! p1 and p2 represent the parameters that govern total beaf dry biomass, + ! and the output argument blmax is the leaf carbon only real(r8),intent(in) :: d ! plant diameter [cm] real(r8),intent(in) :: p1 ! parameter 1 (slope) real(r8),intent(in) :: p2 ! parameter 2 (curvature, exponent) - real(r8),intent(in) :: c2b ! carbon to biomass multiplier + real(r8),intent(in) :: c2b ! carbon to biomass multiplier (~2) real(r8),intent(out) :: blmax ! plant leaf biomass [kgC] real(r8),intent(out),optional :: dblmaxdd ! change leaf bio per diameter [kgC/cm] @@ -1674,7 +1673,7 @@ subroutine dh2bagw_chave2014(d,h,dhdd,p1,p2,wood_density,c2b,bagw,dbagwdd) real(r8),intent(in) :: p2 ! allometry parameter 2 real(r8),intent(in) :: wood_density real(r8),intent(in) :: c2b - real(r8),intent(out) :: bagw ! plant height [m] + real(r8),intent(out) :: bagw ! plant aboveground biomass [kgC] real(r8),intent(out),optional :: dbagwdd ! change in agb per diameter [kgC/cm] real(r8) :: dbagwdd1,dbagwdd2,dbagwdd3 @@ -1730,10 +1729,10 @@ subroutine d2bagw_2pwr(d,p1,p2,c2b,bagw,dbagwdd) real(r8),intent(in) :: d ! plant diameter [cm] - real(r8),intent(in) :: p1 ! allometry parameter 1 - real(r8),intent(in) :: p2 ! allometry parameter 2 + real(r8),intent(in) :: p1 ! allometry parameter 1 + real(r8),intent(in) :: p2 ! allometry parameter 2 real(r8),intent(in) :: c2b ! carbon to biomass multiplier ~2 - real(r8),intent(out) :: bagw ! plant height [m] + real(r8),intent(out) :: bagw ! plant aboveground biomass [kg C] real(r8),intent(out),optional :: dbagwdd ! change in agb per diameter [kgC/cm] bagw = (p1 * d**p2)/c2b diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index c89e63df98..0b16af43e8 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -1749,21 +1749,23 @@ subroutine FatesCheckParams(is_master) end if - ! check that the host-fates PFT map adds to one along HLM dimension so that all the HLM area - ! goes to a FATES PFT. Each FATES PFT can get < or > 1 of an HLM PFT. - do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) - sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft)) - if(abs(sumarea-1.0_r8).gt.nearzero)then - write(fates_log(),*) 'The distribution of this host land model PFT :',hlm_pft - write(fates_log(),*) 'into FATES PFTs, does not add up to 1.0.' - write(fates_log(),*) 'Error is:',sumarea-1.0_r8 - write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft) - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end do !hlm_pft - end do !ipft - + if( hlm_use_fixed_biogeog .eq. itrue ) then + ! check that the host-fates PFT map adds to one along HLM dimension so that all the HLM area + ! goes to a FATES PFT. Each FATES PFT can get < or > 1 of an HLM PFT. + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft)) + if(abs(sumarea-1.0_r8).gt.nearzero)then + write(fates_log(),*) 'The distribution of this host land model PFT :',hlm_pft + write(fates_log(),*) 'into FATES PFTs, does not add up to 1.0.' + write(fates_log(),*) 'Error is:',sumarea-1.0_r8 + write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft) + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do !hlm_pft + end if + + end do !ipft !! ! Checks for HYDRO !! if( hlm_use_planthydro == itrue ) then diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index b7d3eedb96..ac3a34f635 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -529,8 +529,6 @@ module EDTypesMod real(r8),allocatable :: fragmentation_scaler(:) ! Scale rate of litter fragmentation based on soil layer. 0 to 1. - real(r8) :: repro(maxpft) ! allocation to reproduction per PFT : KgC/m2 - !FUEL CHARECTERISTICS real(r8) :: sum_fuel ! total ground fuel related to ros (omits 1000hr fuels): KgC/m2 real(r8) :: fuel_frac(nfsc) ! fraction of each litter class in the ros_fuel:-. From 726ec6bcfb295a3a6d81824b1292b321fc8161ce Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 26 Oct 2021 15:06:46 -0400 Subject: [PATCH 449/578] Some refactoring of the leaf humidity effects on stomatal conductance --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 250 +++++++++++++++++---- main/FatesConstantsMod.F90 | 9 + 2 files changed, 213 insertions(+), 46 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 4ff827443b..b5021be9e0 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -25,6 +25,10 @@ module FATESPlantRespPhotosynthMod use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : itrue use FatesConstantsMod, only : nearzero + use FatesConstantsMod, only : molar_mass_ratio_vapdry + use FatesConstantsMod, only : molar_mass_water + use FatesConstantsMod, only : rgas_J_K_mol + use FatesConstantsMod, only : fates_unset_r8 use FatesInterfaceTypesMod, only : hlm_use_planthydro use FatesInterfaceTypesMod, only : hlm_parteh_mode use FatesInterfaceTypesMod, only : numpft @@ -47,7 +51,8 @@ module FATESPlantRespPhotosynthMod use PRTGenericMod, only : struct_organ use EDParamsMod, only : ED_val_base_mr_20, stomatal_model use PRTParametersMod, only : prt_params - + use EDPftvarcon , only : EDPftvarcon_inst + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -72,6 +77,25 @@ module FATESPlantRespPhotosynthMod ! Ratio of H2O/CO2 gass diffusion in the leaf boundary layer (approximate) real(r8),parameter :: h2o_co2_bl_diffuse_ratio = 1.4_r8 + ! Constants used to define C3 versus C4 photosynth pathways + integer, parameter :: c3_path_index = 1 + integer, parameter :: c4_path_index = 0 + + + ! Constants used to define conductance models + integer, parameter :: medlyn_model = 2 + integer, parameter :: ballberry_model = 1 + + ! Alternatively, Gross Assimilation can be used to estimate + ! leaf co2 partial pressure and therefore conductance. The default + !is to use anet + logical, parameter :: use_agross = .false. + + + + + + contains !-------------------------------------------------------------------------------------- @@ -88,8 +112,6 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! !USES: - use EDPftvarcon , only : EDPftvarcon_inst - use FatesSynchronizedParamsMod , only : FatesSynchronizedParamsInst use EDTypesMod , only : ed_patch_type use EDTypesMod , only : ed_cohort_type @@ -213,7 +235,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! above the leaf layer of interest real(r8) :: lai_current ! the LAI in the current leaf layer real(r8) :: cumulative_lai ! the cumulative LAI, top down, to the leaf layer of interest - + real(r8) :: leaf_psi ! leaf xylem matric potential [MPa] (only meaningful/used w/ hydro) real(r8), allocatable :: rootfr_ft(:,:) ! Root fractions per depth and PFT ! ----------------------------------------------------------------------------------- @@ -413,6 +435,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) lai_current = min(leaf_inc, currentCohort%treelai - lai_layers_above) cumulative_lai = lai_canopy_above + lai_layers_above + 0.5*lai_current + leaf_psi = currentCohort%co_hydr%psi_ag(1) + else stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentPatch%btran_ft(ft) ) @@ -426,6 +450,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) sum(currentPatch%tlai_profile(cl,ft,1:iv-1)) + & 0.5*currentPatch%tlai_profile(cl,ft,iv) + leaf_psi = fates_unset_r8 end if @@ -534,6 +559,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) mm_ko2, & ! in co2_cpoint, & ! in lmr_z(iv,ft,cl), & ! in + leaf_psi, & ! in + bc_in(s)%rb_pa(ifp), & ! in currentPatch%psn_z(cl,ft,iv), & ! out rs_z(iv,ft,cl), & ! out anet_av_z(iv,ft,cl), & ! out @@ -849,11 +876,14 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in mm_ko2, & ! in co2_cpoint, & ! in lmr, & ! in + leaf_psi, & ! in + rb, & ! in psn_out, & ! out rstoma_out, & ! out anet_av_out, & ! out c13disc_z) ! out + ! ------------------------------------------------------------------------------------ ! This subroutine calculates photosynthesis and stomatal conductance within each leaf ! sublayer. @@ -863,8 +893,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! Other arguments or variables may be indicative of scales broader than the LSL. ! ------------------------------------------------------------------------------------ - use EDPftvarcon , only : EDPftvarcon_inst - use EDParamsMod , only : theta_cj_c3, theta_cj_c4 + use EDParamsMod , only : theta_cj_c3, theta_cj_c4 ! Arguments @@ -904,13 +933,18 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in real(r8), intent(in) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) real(r8), intent(in) :: co2_cpoint ! CO2 compensation point (Pa) real(r8), intent(in) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) - + real(r8), intent(in) :: leaf_psi ! Leaf water potential [MPa] + real(r8), intent(in) :: rb ! Boundary Layer resistance of leaf [s/m] + real(r8), intent(out) :: psn_out ! carbon assimilated in this leaf layer umolC/m2/s real(r8), intent(out) :: rstoma_out ! stomatal resistance (1/gs_lsl) (s/m) real(r8), intent(out) :: anet_av_out ! net leaf photosynthesis (umol CO2/m**2/s) ! averaged over sun and shade leaves. real(r8), intent(out) :: c13disc_z ! carbon 13 in newly assimilated carbon + + + ! Locals ! ------------------------------------------------------------------------ integer :: c3c4_path_index ! Index for which photosynthetic pathway @@ -919,6 +953,8 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in real(r8) :: gstoma ! Stomatal Conductance of this leaf layer (m/s) real(r8) :: agross ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) real(r8) :: anet ! net leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: a_gs ! The assimilation (a) for calculating conductance (gs) + ! is either = to anet or agross real(r8) :: je ! electron transport rate (umol electrons/m**2/s) real(r8) :: qabs ! PAR absorbed by PS II (umol photons/m**2/s) real(r8) :: aquad,bquad,cquad ! terms for quadratic equations @@ -969,10 +1005,10 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in medlyn_slope=> EDPftvarcon_inst%medlyn_slope , & ! Slope for Medlyn stomatal conductance model method, the unit is KPa^0.5 stomatal_intercept=> EDPftvarcon_inst%stomatal_intercept ) !Unstressed minimum stomatal conductance, the unit is umol/m**2/s - ! photosynthetic pathway: 0. = c4, 1. = c3 + ! photosynthetic pathway: 0. = c4, 1. = c3 c3c4_path_index = nint(EDPftvarcon_inst%c3psn(ft)) - if (c3c4_path_index == 1) then + if (c3c4_path_index == c3_path_index) then init_co2_inter_c = init_a2l_co2_c3 * can_co2_ppress else init_co2_inter_c = init_a2l_co2_c4 * can_co2_ppress @@ -981,8 +1017,8 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! Part III: Photosynthesis and Conductance ! ---------------------------------------------------------------------------------- - if ( parsun_lsl <= 0._r8 ) then ! night time - + if_daytime: if ( parsun_lsl <= 0._r8 ) then ! night time + anet_av_out = -lmr psn_out = 0._r8 @@ -995,8 +1031,9 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in else ! day time (a little bit more complicated ...) - !is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) - if ( laisun_lsl + laisha_lsl > 0._r8 ) then + ! Is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) + + if_leafarea: if ( laisun_lsl + laisha_lsl > 0._r8 ) then !Loop aroun shaded and unshaded leaves psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. @@ -1039,7 +1076,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in niter = 0 loop_continue = .true. - do while(loop_continue) + iter_loop: do while(loop_continue) ! Increment iteration counter. Stop if too many iterations niter = niter + 1 @@ -1047,7 +1084,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in co2_inter_c_old = co2_inter_c ! Photosynthesis limitation rate calculations - if (c3c4_path_index == 1)then + if (c3c4_path_index == c3_path_index)then ! C3: Rubisco-limited photosynthesis ac = vcmax * max(co2_inter_c-co2_cpoint, 0._r8) / & @@ -1087,33 +1124,44 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in ! C4: PEP carboxylase-limited (CO2-limited) ap = co2_rcurve_islope * max(co2_inter_c, 0._r8) / can_press - ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap + ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap - aquad = theta_cj_c4 - bquad = -(ac + aj) - cquad = ac * aj - call quadratic_f (aquad, bquad, cquad, r1, r2) - ai = min(r1,r2) - - aquad = theta_ip - bquad = -(ai + ap) - cquad = ai * ap - call quadratic_f (aquad, bquad, cquad, r1, r2) - agross = min(r1,r2) + aquad = theta_cj_c4 + bquad = -(ac + aj) + cquad = ac * aj + call quadratic_f (aquad, bquad, cquad, r1, r2) + ai = min(r1,r2) - end if + aquad = theta_ip + bquad = -(ai + ap) + cquad = ai * ap + call quadratic_f (aquad, bquad, cquad, r1, r2) + agross = min(r1,r2) - ! Net carbon assimilation. Exit iteration if an < 0 + end if + + ! Calculate anet, only exit iteration with negative anet when + ! using anet in calculating gs this is version B anet = agross - lmr - if (anet < 0._r8) then - loop_continue = .false. + + if (use_agross) then + if ( stomatal_model == medlyn_model ) then + write (fates_log(),*) 'Gross Assimilation conductance is incompatible with the Medlyn model' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + a_gs = agross + else + if (anet < 0._r8) then + loop_continue = .false. + end if + a_gs = anet end if - ! Quadratic gs_mol calculation with an known. Valid for an >= 0. ! With an <= 0, then gs_mol = stomatal_intercept_btran - leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press + leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * a_gs * can_press leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) - if ( stomatal_model == 2 ) then + + if ( stomatal_model == medlyn_model ) then !stomatal conductance calculated from Medlyn et al. (2011), the numerical & !implementation was adapted from the equations in CLM5.0 vpd = max((veg_esat - ceair), 50._r8) * 0.001_r8 !addapted from CLM5. Put some constraint on VPD @@ -1129,15 +1177,16 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in call quadratic_f (aquad, bquad, cquad, r1, r2) gs_mol = max(r1,r2) - else if ( stomatal_model == 1 ) then !stomatal conductance calculated from Ball et al. (1987) + else if ( stomatal_model == ballberry_model ) then !stomatal conductance calculated from Ball et al. (1987) aquad = leaf_co2_ppress - bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * anet * can_press + bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * a_gs * can_press cquad = -gb_mol*(leaf_co2_ppress*stomatal_intercept_btran + & bb_slope(ft)*anet*can_press * ceair/ veg_esat ) call quadratic_f (aquad, bquad, cquad, r1, r2) gs_mol = max(r1,r2) end if + ! Derive new estimate for co2_inter_c co2_inter_c = can_co2_ppress - anet * can_press * & (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) @@ -1151,16 +1200,16 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in .or. niter == 5) then loop_continue = .false. end if - end do !iteration loop + end do iter_loop - ! End of co2_inter_c iteration. Check for an < 0, in which case - ! gs_mol =stomatal_intercept_btran + ! End of co2_inter_c iteration. Check for an < 0, in which case gs_mol = bbb + ! And Final estimates for leaf_co2_ppress and co2_inter_c + ! (needed for early exit of co2_inter_c iteration when an < 0) if (anet < 0._r8) then gs_mol = stomatal_intercept_btran end if ! Final estimates for leaf_co2_ppress and co2_inter_c - ! (needed for early exit of co2_inter_c iteration when an < 0) leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) co2_inter_c = can_co2_ppress - anet * can_press * & @@ -1216,9 +1265,23 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in enddo !sunsha loop - ! This is the stomatal resistance of the leaf layer - rstoma_out = 1._r8/gstoma + ! Stomatal resistance of the leaf-layer + + + + if (.not. (hlm_use_planthydro.eq.itrue .and. EDPftvarcon_inst%hydr_k_lwp(ft)>nearzero) ) then + + rstoma_out = 1._r8/gstoma + else + + rstoma_out = LeafHumidityStomaResis(leaf_psi, veg_tempk, ceair, can_press, veg_esat, & + rb, gstoma, ft) + + + end if + + else ! No leaf area. This layer is present only because of stems. @@ -1232,16 +1295,111 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in rstoma_out = min(rsmax0,cf/(stem_cuticle_loss_frac*stomatal_intercept(ft))) c13disc_z = 0.0_r8 - end if !is there leaf area? + end if if_leafarea !is there leaf area? - end if ! night or day + end if if_daytime ! night or day end associate return end subroutine LeafLayerPhotosynthesis +! ======================================================================================= + +function LeafHumidityStomaResis(leaf_psi, veg_tempk, ceair, can_press, veg_esat, & + rb, gstoma, ft) result(rstoma_out) + + ! ------------------------------------------------------------------------------------- + ! This calculates inner leaf humidity as a function of mesophyll water potential + ! Adopted from Vesala et al., 2017 https://www.frontiersin.org/articles/10.3389/fpls.2017.00054/full + ! + ! Equation 1 in Vesala et al: + ! lwp_star = wi/w0 = exp( k_lwp*leaf_psi*molar_mass_water/(rgas_J_k_mol * veg_tempk) ) + ! + ! Terms: + ! leaf_psi: leaf water potential [MPa] + ! k_lwp: inner leaf humidity scaling coefficient [-] + ! rgas_J_K_mol: universal gas constant, [J/K/mol], 8.3144598 + ! molar_mass_water, molar mass of water, [g/mol]: 18.0 + ! + ! Unit conversions: + ! 1 Pa = 1 N/m2 = 1 J/m3 + ! density of liquid water [kg/m3] = 1000 + ! + ! units of equation 1: exp( [MPa]*[g/mol]/( [J/K/mol] * [K] ) ) + ! [MJ/m3]*[g/mol]*[m3/kg]*[kg/g]*[J/MJ] / ([J/mol]) + ! dimensionless: [J/g]*[g/mol]/([J/mol]) + ! + ! Note: unit conversions drop out b/c [m3/kg]*[kg/g]*[J/MJ] = 1e-3*1.e-3*1e6 = 1.0 + ! + ! Junyan Ding 2021 + ! ------------------------------------------------------------------------------------- + + ! Arguments + real(r8) :: leaf_psi ! Leaf water potential [MPa] + real(r8) :: veg_tempk ! Leaf temperature [K] + real(r8) :: ceair ! vapor pressure of air, constrained [Pa] + real(r8) :: can_press ! Atmospheric pressure of canopy [Pa] + real(r8) :: veg_esat ! Saturated vapor pressure at veg surf [Pa] + real(r8) :: rb ! Leaf Boundary layer resistance [s/m] + real(r8) :: gstoma ! Stomatal Conductance of this leaf layer [m/s] + integer :: ft ! Plant Functional Type + real(r8) :: rstoma_out ! Total Stomatal resistance (stoma and BL) [s/m] + + ! Locals + real(r8) :: k_lwp ! Scaling coefficient for the ratio of leaf xylem + ! water potential to mesophyll water potential + real(r8) :: qs ! Specific humidity [g/kg] + real(r8) :: qsat ! Saturation specific humidity [g/kg] + real(r8) :: qsat_adj ! Adjusted saturation specific humidity [g/kg] + real(r8) :: lwp_star ! leaf water potential scaling coefficient + ! for inner leaf humidity, 0 means total dehydroted + ! leaf, 1 means total saturated leaf + + ! Note: to disable this control, set k_lwp to zero, LWP_star will be 1, see code (line 1308) below + k_lwp = EDPftvarcon_inst%hydr_k_lwp(ft) + if (leaf_psi<0._r8) then + lwp_star = exp(k_lwp*leaf_psi*molar_mass_water/(rgas_J_K_mol *veg_tempk)) + else + lwp_star = 1._r8 + end if + + ! compute specific humidity from vapor pressure + ! q = 0.622*e/(can_press - 0.378*e) + ! source https://cran.r-project.org/web/packages/humidity/vignettes/humidity-measures.html + ! now adjust inner leaf humidity by LWP_star + + qs = molar_mass_ratio_vapdry * ceair / (can_press - (1._r8-molar_mass_ratio_vapdry) * ceair) + qsat = molar_mass_ratio_vapdry * veg_esat / (can_press - (1._r8-molar_mass_ratio_vapdry) * veg_esat) + qsat_adj = qsat*lwp_star + + ! Adjusting gs (compute a virtual gs) that will be passed to host model + + if ( qsat_adj < qs ) then + + ! if inner leaf vapor pressure is less then or equal to that at leaf surface + ! then set stomata resistance to be very large to stop the transpiration or back flow of vapor + rstoma_out = rsmax0*100._r8 + + else + + rstoma_out = (qsat-qs)*( 1/gstoma + rb)/(qsat_adj - qs)-rb + + end if + + if (rstoma_out < nearzero ) then + write (fates_log(),*) 'qsat:', qsat, 'qs:', qs + write (fates_log(),*) 'LWP :', leaf_psi + write (fates_log(),*) 'ceair:', ceair, 'veg_esat:', veg_esat + write (fates_log(),*) 'rstoma_out:', rstoma_out, 'rb:', rb + write (fates_log(),*) 'LWP_star', lwp_star + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + +end function LeafHumidityStomaResis + + ! ===================================================================================== subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv @@ -1282,7 +1440,7 @@ subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv real(r8), intent(in) :: rb ! leaf boundary layer resistance (s/m) real(r8), intent(in) :: maintresp_reduction_factor ! factor by which to reduce maintenance respiration real(r8), intent(out) :: g_sb_laweight ! Combined conductance (stomatal + boundary layer) for the cohort - ! weighted by leaf area [m/s]*[m2] + ! weighted by leaf area [m/s]*[m2] real(r8), intent(out) :: gpp ! GPP (kgC/indiv/s) real(r8), intent(out) :: rdark ! Dark Leaf Respiration (kgC/indiv/s) real(r8), intent(out) :: cohort_eleaf_area ! Effective leaf area of the cohort [m2] @@ -1760,7 +1918,7 @@ subroutine LeafLayerMaintenanceRespiration(lmr25top_ft, & lmr) use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - use EDPftvarcon , only : EDPftvarcon_inst + ! Arguments real(r8), intent(in) :: lmr25top_ft ! canopy top leaf maint resp rate at 25C diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 7e19856aa2..64b211fd23 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -183,6 +183,9 @@ module FatesConstantsMod ! universal gas constant [J/K/kmol] real(fates_r8), parameter, public :: rgas_J_K_kmol = 8314.4598_fates_r8 + ! universal gas constant [J/k/mol] + real(fates_r8), parameter, public :: rgas_J_K_mol = 8.3144598_fates_r8 + ! freezing point of water at 1 atm (K) real(fates_r8), parameter, public :: t_water_freeze_k_1atm = 273.15_fates_r8 @@ -192,6 +195,12 @@ module FatesConstantsMod ! Density of fresh liquid water (kg/m3) real(fates_r8), parameter, public :: dens_fresh_liquid_water = 1.0E3_fates_r8 + ! Molar mass of water (g/mol) + real(fates_r8), parameter, public :: molar_mass_water = 18.0_fates_r8 + + ! Approximate molar mass of water vapor to dry air (-) + real(fates_r8), parameter, public :: molar_mass_ratio_vapdry= 0.622_fates_r8 + ! Gravity constant on earth [m/s] real(fates_r8), parameter, public :: grav_earth = 9.8_fates_r8 From 4fb64d5165e53e4ad384020353ca9f8eb800d969 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Tue, 26 Oct 2021 15:23:23 -0600 Subject: [PATCH 450/578] update hio_nplant_si_scpf check against nplant_scpf for units --- main/FatesHistoryInterfaceMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 2a1b285c9d..b29ad9c7e0 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -4216,7 +4216,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) if(hlm_use_ed_st3.eq.ifalse) then do iscpf=1,nlevsclass*numpft - if( abs(hio_nplant_si_scpf(io_si, iscpf)-nplant_scpf(iscpf)) > 1.0E-8_r8 ) then + if( abs(hio_nplant_si_scpf(io_si, iscpf)-(nplant_scpf(iscpf)/m2_per_ha)) > 1.0E-8_r8 ) then write(fates_log(),*) 'numpft:',numpft write(fates_log(),*) 'nlevsclass:',nlevsclass write(fates_log(),*) 'scpf:',iscpf @@ -5227,7 +5227,7 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_laisha_top_si_can) - call this%set_history_var(vname='FATES_FABD_SUN_CLLLPF', units='1', & + call this%set_history_var(vname='ih_fabd_sun_si_cnlfpft', units='1', & long='sun fraction of direct light absorbed by each canopy, leaf, and PFT', & use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & From c45f5d16ec3b01ce210e2cf8fca29db0e268bad9 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Wed, 27 Oct 2021 08:09:05 -0600 Subject: [PATCH 451/578] fix variable name typo --- main/FatesHistoryInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index b29ad9c7e0..8746269915 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -5227,7 +5227,7 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & index = ih_laisha_top_si_can) - call this%set_history_var(vname='ih_fabd_sun_si_cnlfpft', units='1', & + call this%set_history_var(vname='FATES_FABD_SUN_CLLLPF', units='1', & long='sun fraction of direct light absorbed by each canopy, leaf, and PFT', & use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & From ad4931aeb07923225de5acdc6e0757d65889f2cd Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Wed, 27 Oct 2021 08:19:06 -0600 Subject: [PATCH 452/578] update hio_nplant_scpf check --- main/FatesHistoryInterfaceMod.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 8746269915..7118e3e0ad 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -4216,7 +4216,8 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) if(hlm_use_ed_st3.eq.ifalse) then do iscpf=1,nlevsclass*numpft - if( abs(hio_nplant_si_scpf(io_si, iscpf)-(nplant_scpf(iscpf)/m2_per_ha)) > 1.0E-8_r8 ) then + if ((abs(hio_nplant_si_scpf(io_si, iscpf)-(nplant_scpf(iscpf)/m2_per_ha)) > 1.0E-8_r8) .and. & + (hio_nplant_si_scpf(io_si, iscpf) .ne. hlm_hio_ignore_val)) then write(fates_log(),*) 'numpft:',numpft write(fates_log(),*) 'nlevsclass:',nlevsclass write(fates_log(),*) 'scpf:',iscpf From 2affab7f910137e37d661cdeff817bc43128803e Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Wed, 27 Oct 2021 10:03:58 -0600 Subject: [PATCH 453/578] testing logging mortality --- main/FatesHistoryInterfaceMod.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 7118e3e0ad..bf87d21da2 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2646,7 +2646,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%frmort + & ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * days_per_year / m2_per_ha + ccohort%n * sec_per_day * days_per_year / m2_per_ha hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + ccohort%n / m2_per_ha hio_nplant_canopy_si_scls(io_si,scls) = hio_nplant_canopy_si_scls(io_si,scls) + ccohort%n / m2_per_ha @@ -2674,7 +2674,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * days_per_year / m2_per_ha + ccohort%n * sec_per_day * days_per_year / m2_per_ha hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & @@ -2739,7 +2739,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * days_per_year / m2_per_ha + ccohort%n * sec_per_day * days_per_year / m2_per_ha hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + ccohort%n / m2_per_ha hio_nplant_understory_si_scls(io_si,scls) = hio_nplant_understory_si_scls(io_si,scls) + ccohort%n / m2_per_ha @@ -2768,7 +2768,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * days_per_year / m2_per_ha + ccohort%n * sec_per_day * days_per_year / m2_per_ha hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & @@ -3403,13 +3403,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) if( hio_nplant_canopy_si_scpf(io_si,i_scpf)>nearzero ) then this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) / & - hio_nplant_canopy_si_scpf(io_si,i_scpf) + (hio_nplant_canopy_si_scpf(io_si,i_scpf)*m2_per_ha) end if if( hio_nplant_understory_si_scpf(io_si,i_scpf)>nearzero ) then this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) / & - hio_nplant_understory_si_scpf(io_si,i_scpf) + (hio_nplant_understory_si_scpf(io_si,i_scpf)*m2_per_ha) end if end do From 14828199548e28f85fb80bb29fc09f1bf94f7072 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 27 Oct 2021 12:53:12 -0400 Subject: [PATCH 454/578] Cleaning up call to leaf humidity calculations --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 16 ++++------------ 1 file changed, 4 insertions(+), 12 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index b5021be9e0..f1f1fc86e9 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -1266,20 +1266,12 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in enddo !sunsha loop ! Stomatal resistance of the leaf-layer - - - - if (.not. (hlm_use_planthydro.eq.itrue .and. EDPftvarcon_inst%hydr_k_lwp(ft)>nearzero) ) then - - rstoma_out = 1._r8/gstoma - - else - + if ( (hlm_use_planthydro.eq.itrue .and. EDPftvarcon_inst%hydr_k_lwp(ft)>nearzero) ) then rstoma_out = LeafHumidityStomaResis(leaf_psi, veg_tempk, ceair, can_press, veg_esat, & rb, gstoma, ft) - - - end if + else + rstoma_out = 1._r8/gstoma + end if else From c2a207cc26fd9a533b624caf99eb40ce1f825f4e Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Wed, 27 Oct 2021 18:31:01 -0600 Subject: [PATCH 455/578] add flushval call to history_dyn subroutine --- main/FatesHistoryInterfaceMod.F90 | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index bf87d21da2..ec770397fd 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2069,8 +2069,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_err_fates_si => this%hvars(ih_err_fates_si)%r82d ) - - + ! Flush the relevant history variables + call this%flush_hvars(nc,upfreq_in=1) ! If we don't have dynamics turned on, we just abort these diagnostics if (hlm_use_ed_st3.eq.itrue) return @@ -2083,6 +2083,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) do s = 1,nsites + call this%zero_site_hvars(sites(s), upfreq_in=1) + io_si = sites(s)%h_gid ! Total carbon model error [kgC/day -> kgC/s] @@ -2672,7 +2674,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_mortality_canopy_si_scls(io_si,scls) = hio_mortality_canopy_si_scls(io_si,scls) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + & + ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & ccohort%n * sec_per_day * days_per_year / m2_per_ha @@ -3426,13 +3428,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) if( hio_nplant_canopy_si_scpf(io_si,i_scpf)>nearzero ) then this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) /& - hio_nplant_canopy_si_scpf(io_si,i_scpf) + (hio_nplant_canopy_si_scpf(io_si,i_scpf)*m2_per_ha) end if if( hio_nplant_understory_si_scpf(io_si,i_scpf)>nearzero ) then this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) = & this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) /& - hio_nplant_understory_si_scpf(io_si,i_scpf) + (hio_nplant_understory_si_scpf(io_si,i_scpf)*m2_per_ha) end if end do From f4558b8b8419d7f9b021686c79c9d3107d417d40 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Thu, 28 Oct 2021 09:52:39 -0600 Subject: [PATCH 456/578] correct mortality --- main/FatesHistoryInterfaceMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index ec770397fd..0d03432632 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2768,7 +2768,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_mortality_understory_si_scls(io_si,scls) = hio_mortality_understory_si_scls(io_si,scls) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + & + ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & ccohort%n * sec_per_day * days_per_year / m2_per_ha From cb0207e970e0b8606a2f9902e663fc63063b7ef4 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Fri, 29 Oct 2021 08:43:37 -0600 Subject: [PATCH 457/578] get rid of flushing inside update_history_dyn --- main/FatesHistoryInterfaceMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 0d03432632..0a77cb56c5 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2070,7 +2070,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! Flush the relevant history variables - call this%flush_hvars(nc,upfreq_in=1) + !call this%flush_hvars(nc,upfreq_in=1) ! If we don't have dynamics turned on, we just abort these diagnostics if (hlm_use_ed_st3.eq.itrue) return @@ -2083,7 +2083,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) do s = 1,nsites - call this%zero_site_hvars(sites(s), upfreq_in=1) + !call this%zero_site_hvars(sites(s), upfreq_in=1) io_si = sites(s)%h_gid From 56d173386d47be7a53628fee676b307ace3e4959 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Fri, 29 Oct 2021 21:25:50 -0600 Subject: [PATCH 458/578] test for mortality --- main/FatesHistoryInterfaceMod.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 0a77cb56c5..e1561b9e62 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1520,7 +1520,6 @@ subroutine flush_hvars(this,nc,upfreq_in) do ivar=1,ubound(this%hvars,1) if (this%hvars(ivar)%upfreq == upfreq_in) then ! Only flush variables with update on dynamics step call this%hvars(ivar)%flush(nc, this%dim_bounds, this%dim_kinds) - end if end do @@ -2085,7 +2084,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) !call this%zero_site_hvars(sites(s), upfreq_in=1) + io_si = sites(s)%h_gid + ! Doing a check here + hio_mortality_si_pft(io_si,:) = 0.0 ! Total carbon model error [kgC/day -> kgC/s] hio_cbal_err_fates_si(io_si) = & From b9ff1587eabed2fef52e99b4ccf22c674eac1c33 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Fri, 29 Oct 2021 22:17:20 -0600 Subject: [PATCH 459/578] second mortality fix --- main/FatesHistoryInterfaceMod.F90 | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index e1561b9e62..062ca41356 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2067,10 +2067,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_cbal_err_fates_si => this%hvars(ih_cbal_err_fates_si)%r81d, & hio_err_fates_si => this%hvars(ih_err_fates_si)%r82d ) - - ! Flush the relevant history variables - !call this%flush_hvars(nc,upfreq_in=1) - ! If we don't have dynamics turned on, we just abort these diagnostics if (hlm_use_ed_st3.eq.itrue) return @@ -2082,12 +2078,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) do s = 1,nsites - !call this%zero_site_hvars(sites(s), upfreq_in=1) - - io_si = sites(s)%h_gid - ! Doing a check here - hio_mortality_si_pft(io_si,:) = 0.0 ! Total carbon model error [kgC/day -> kgC/s] hio_cbal_err_fates_si(io_si) = & @@ -3062,6 +3053,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) end do sites(s)%recruitment_rate(:) = 0._r8 + hio_mortality_si_pft(io_si,:) = 0.0_r8 ! summarize all of the mortality fluxes by PFT do i_pft = 1, numpft do i_scls = 1,nlevsclass From 83f6abc4b14f5f577ff580b0065e9f7b579d97a4 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Mon, 1 Nov 2021 14:57:29 -0600 Subject: [PATCH 460/578] whitespace updates --- main/FatesHistoryInterfaceMod.F90 | 2596 +++++++++++++++-------------- 1 file changed, 1302 insertions(+), 1294 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 062ca41356..f1cec7c51b 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1565,7 +1565,7 @@ subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype ! relevant only on FATES sites. This way we do not average zero's ! at locations not on FATES columns - flushval = hlm_hio_ignore_val !for now do this (ACF 09/27/21) + flushval = hlm_hio_ignore_val write_var = check_hlm_list(trim(hlms), trim(hlm_name)) if( write_var ) then @@ -2067,1414 +2067,1422 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_cbal_err_fates_si => this%hvars(ih_cbal_err_fates_si)%r81d, & hio_err_fates_si => this%hvars(ih_err_fates_si)%r82d ) - ! If we don't have dynamics turned on, we just abort these diagnostics - if (hlm_use_ed_st3.eq.itrue) return + ! If we don't have dynamics turned on, we just abort these diagnostics + if (hlm_use_ed_st3.eq.itrue) return - model_day_int = nint(hlm_model_day) + model_day_int = nint(hlm_model_day) - ! --------------------------------------------------------------------------------- - ! Loop through the FATES scale hierarchy and fill the history IO arrays - ! --------------------------------------------------------------------------------- + ! --------------------------------------------------------------------------------- + ! Loop through the FATES scale hierarchy and fill the history IO arrays + ! --------------------------------------------------------------------------------- - do s = 1,nsites - - io_si = sites(s)%h_gid - - ! Total carbon model error [kgC/day -> kgC/s] - hio_cbal_err_fates_si(io_si) = & - sites(s)%mass_balance(element_pos(carbon12_element))%err_fates / sec_per_day - - ! Total carbon lost to atmosphere from burning (kgC/site/day -> kgC/m2/s) - hio_fire_c_to_atm_si(io_si) = & - sites(s)%mass_balance(element_pos(carbon12_element))%burn_flux_to_atm * & - ha_per_m2 * days_per_sec - - ! Total model error [kg/day -> kg/s] (all elements) - do el = 1, num_elements - - hio_err_fates_si(io_si,el) = sites(s)%mass_balance(el)%err_fates / sec_per_day - - ! Total element lost to atmosphere from burning (kg/site/day -> kg/m2/s) - hio_burn_flux_elem(io_si,el) = & - sites(s)%mass_balance(el)%burn_flux_to_atm * & - ha_per_m2 * days_per_sec - - end do + siteloop: do s = 1,nsites - hio_canopy_spread_si(io_si) = sites(s)%spread + io_si = sites(s)%h_gid - ! Update the site statuses (stati?) - hio_site_cstatus_si(io_si) = real(sites(s)%cstatus,r8) - hio_site_dstatus_si(io_si) = real(sites(s)%dstatus,r8) + ! Total carbon model error [kgC/day -> kgC/s] + hio_cbal_err_fates_si(io_si) = & + sites(s)%mass_balance(element_pos(carbon12_element))%err_fates / sec_per_day - !count number of days for leaves off - hio_site_nchilldays_si(io_si) = real(sites(s)%nchilldays,r8) - hio_site_ncolddays_si(io_si) = real(sites(s)%ncolddays,r8) + ! Total carbon lost to atmosphere from burning (kgC/site/day -> kgC/m2/s) + hio_fire_c_to_atm_si(io_si) = & + sites(s)%mass_balance(element_pos(carbon12_element))%burn_flux_to_atm * & + ha_per_m2 * days_per_sec + do el = 1, num_elements - hio_gdd_si(io_si) = sites(s)%grow_deg_days - hio_cleafoff_si(io_si) = real(model_day_int - sites(s)%cleafoffdate,r8) - hio_cleafon_si(io_si) = real(model_day_int - sites(s)%cleafondate,r8) - hio_dleafoff_si(io_si) = real(model_day_int - sites(s)%dleafoffdate,r8) - hio_dleafon_si(io_si) = real(model_day_int - sites(s)%dleafondate,r8) - - if(model_day_int>numWaterMem)then - hio_meanliqvol_si(io_si) = & - sum(sites(s)%water_memory(1:numWaterMem))/real(numWaterMem,r8) - end if - - ! track total wood product accumulation at the site level - hio_woodproduct_si(io_si) = sites(s)%resources_management%trunk_product_site & - * AREA_INV - - ! site-level fire variables - hio_nesterov_fire_danger_si(io_si) = sites(s)%acc_NI - hio_fire_nignitions_si(io_si) = sites(s)%NF_successful / m2_per_km2 / sec_per_day - hio_fire_fdi_si(io_si) = sites(s)%FDI - - ! If hydraulics are turned on, track the error terms - ! associated with dynamics - - if(hlm_use_planthydro.eq.itrue)then - this%hvars(ih_h2oveg_dead_si)%r81d(io_si) = sites(s)%si_hydr%h2oveg_dead - this%hvars(ih_h2oveg_recruit_si)%r81d(io_si) = sites(s)%si_hydr%h2oveg_recruit - this%hvars(ih_h2oveg_growturn_err_si)%r81d(io_si) = sites(s)%si_hydr%h2oveg_growturn_err - end if - - ! error in primary lands from patch fusion - hio_primaryland_fusion_error_si(io_si) = sites(s)%primary_land_patchfusion_error * days_per_year - - ! output site-level disturbance rates - hio_disturbance_rate_p2p_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_primary(1:N_DIST_TYPES)) * days_per_year - hio_disturbance_rate_p2s_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_secondary(1:N_DIST_TYPES)) * days_per_year - hio_disturbance_rate_s2s_si(io_si) = sum(sites(s)%disturbance_rates_secondary_to_secondary(1:N_DIST_TYPES)) * days_per_year + ! Total model error [kg/day -> kg/s] (all elements) + hio_err_fates_si(io_si,el) = sites(s)%mass_balance(el)%err_fates / sec_per_day - hio_fire_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ifire) + & - sites(s)%disturbance_rates_primary_to_secondary(dtype_ifire) + & - sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifire)) * & - days_per_year + ! Total element lost to atmosphere from burning (kg/site/day -> kg/m2/s) + hio_burn_flux_elem(io_si,el) = & + sites(s)%mass_balance(el)%burn_flux_to_atm * ha_per_m2 * & + days_per_sec - hio_logging_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ilog) + & - sites(s)%disturbance_rates_primary_to_secondary(dtype_ilog) + & - sites(s)%disturbance_rates_secondary_to_secondary(dtype_ilog)) * & - days_per_year + end do - hio_fall_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ifall) + & - sites(s)%disturbance_rates_primary_to_secondary(dtype_ifall) + & - sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifall)) * & - days_per_year + ! Canopy spread index (0-1) + hio_canopy_spread_si(io_si) = sites(s)%spread - hio_potential_disturbance_rate_si(io_si) = sum(sites(s)%potential_disturbance_rates(1:N_DIST_TYPES)) * days_per_year + ! Site statuses (stati?) for cold deciduous and drought + ! deciduous + hio_site_cstatus_si(io_si) = real(sites(s)%cstatus,r8) + hio_site_dstatus_si(io_si) = real(sites(s)%dstatus,r8) - hio_harvest_carbonflux_si(io_si) = sites(s)%harvest_carbon_flux + ! Number of chill days and cold days + hio_site_nchilldays_si(io_si) = real(sites(s)%nchilldays,r8) + hio_site_ncolddays_si(io_si) = real(sites(s)%ncolddays,r8) - ipa = 0 - cpatch => sites(s)%oldest_patch - do while(associated(cpatch)) + ! Growing degree-days + hio_gdd_si(io_si) = sites(s)%grow_deg_days - ! Increment the number of patches per site - hio_npatches_si(io_si) = hio_npatches_si(io_si) + 1._r8 + ! Model days elapsed since leaf on/off for cold- and drought-deciduous + hio_cleafoff_si(io_si) = real(model_day_int - sites(s)%cleafoffdate,r8) + hio_cleafon_si(io_si) = real(model_day_int - sites(s)%cleafondate,r8) + hio_dleafoff_si(io_si) = real(model_day_int - sites(s)%dleafoffdate,r8) + hio_dleafon_si(io_si) = real(model_day_int - sites(s)%dleafondate,r8) - cpatch%age_class = get_age_class_index(cpatch%age) + ! Mean liquid water content (m3/m3) used for drought phenology + if(model_day_int>numWaterMem)then + hio_meanliqvol_si(io_si) = & + sum(sites(s)%water_memory(1:numWaterMem))/real(numWaterMem,r8) + end if - ! Increment the fractional area in each age class bin - hio_area_si_age(io_si,cpatch%age_class) = hio_area_si_age(io_si,cpatch%age_class) & - + cpatch%area * AREA_INV + ! track total wood product accumulation at the site level + hio_woodproduct_si(io_si) = sites(s)%resources_management%trunk_product_site & + * AREA_INV - ! Increment some patch-age-resolved diagnostics - hio_lai_si_age(io_si,cpatch%age_class) = hio_lai_si_age(io_si,cpatch%age_class) & - + sum(cpatch%tlai_profile(:,:,:)) * cpatch%area + ! site-level fire variables: - hio_ncl_si_age(io_si,cpatch%age_class) = hio_ncl_si_age(io_si,cpatch%age_class) & - + cpatch%ncl_p * cpatch%area - hio_npatches_si_age(io_si,cpatch%age_class) = hio_npatches_si_age(io_si,cpatch%age_class) + 1._r8 - if ( ED_val_comp_excln .lt. 0._r8 ) then ! only valid when "strict ppa" enabled - hio_zstar_si_age(io_si,cpatch%age_class) = hio_zstar_si_age(io_si,cpatch%age_class) & - + cpatch%zstar * cpatch%area * AREA_INV - endif + ! Nesterov index (unitless) + hio_nesterov_fire_danger_si(io_si) = sites(s)%acc_NI - ! some diagnostics on secondary forest area and its age distribution - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then - hio_fraction_secondary_forest_si(io_si) = hio_fraction_secondary_forest_si(io_si) + & - cpatch%area * AREA_INV + ! number of ignitions [#/km2/day -> #/m2/s] + hio_fire_nignitions_si(io_si) = sites(s)%NF_successful / m2_per_km2 / & + sec_per_day - ageclass_since_anthrodist = get_age_class_index(cpatch%age_since_anthro_disturbance) + ! Fire danger index (FDI) (0-1) + hio_fire_fdi_si(io_si) = sites(s)%FDI - hio_agesince_anthrodist_si_age(io_si,ageclass_since_anthrodist) = & - hio_agesince_anthrodist_si_age(io_si,ageclass_since_anthrodist) & - + cpatch%area * AREA_INV + ! If hydraulics are turned on, track the error terms associated with + ! dynamics [kg/m2] + if(hlm_use_planthydro.eq.itrue)then + this%hvars(ih_h2oveg_dead_si)%r81d(io_si) = sites(s)%si_hydr%h2oveg_dead + this%hvars(ih_h2oveg_recruit_si)%r81d(io_si) = sites(s)%si_hydr%h2oveg_recruit + this%hvars(ih_h2oveg_growturn_err_si)%r81d(io_si) = sites(s)%si_hydr%h2oveg_growturn_err + end if - hio_secondaryforest_area_si_age(io_si,cpatch%age_class) = & - hio_secondaryforest_area_si_age(io_si,cpatch%age_class) & - + cpatch%area * AREA_INV - endif + ! error in primary lands from patch fusion [m2 m-2 day-1] -> [m2 m-2 yr-1] + hio_primaryland_fusion_error_si(io_si) = sites(s)%primary_land_patchfusion_error * days_per_year + + ! output site-level disturbance rates [m2 m-2 day-1] -> [m2 m-2 yr-1] + hio_disturbance_rate_p2p_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_primary(1:N_DIST_TYPES)) * days_per_year + hio_disturbance_rate_p2s_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_secondary(1:N_DIST_TYPES)) * days_per_year + hio_disturbance_rate_s2s_si(io_si) = sum(sites(s)%disturbance_rates_secondary_to_secondary(1:N_DIST_TYPES)) * days_per_year + + hio_fire_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ifire) + & + sites(s)%disturbance_rates_primary_to_secondary(dtype_ifire) + & + sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifire)) * & + days_per_year + + hio_logging_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ilog) + & + sites(s)%disturbance_rates_primary_to_secondary(dtype_ilog) + & + sites(s)%disturbance_rates_secondary_to_secondary(dtype_ilog)) * & + days_per_year + + hio_fall_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ifall) + & + sites(s)%disturbance_rates_primary_to_secondary(dtype_ifall) + & + sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifall)) * & + days_per_year + + hio_potential_disturbance_rate_si(io_si) = sum(sites(s)%potential_disturbance_rates(1:N_DIST_TYPES)) * days_per_year + + ! harvest carbon flux in [kgC/m2/d] -> [kgC/m2/yr] + hio_harvest_carbonflux_si(io_si) = sites(s)%harvest_carbon_flux * & + days_per_year + + ! Loop through patches to sum up diagonistics + ipa = 0 + cpatch => sites(s)%oldest_patch + patchloop: do while(associated(cpatch)) + + ! Increment the number of patches per site + hio_npatches_si(io_si) = hio_npatches_si(io_si) + 1._r8 + + cpatch%age_class = get_age_class_index(cpatch%age) + + ! Increment the fractional area in each age class bin + hio_area_si_age(io_si,cpatch%age_class) = hio_area_si_age(io_si,cpatch%age_class) & + + cpatch%area * AREA_INV + + ! Increment some patch-age-resolved diagnostics + + hio_lai_si_age(io_si,cpatch%age_class) = hio_lai_si_age(io_si,cpatch%age_class) & + + sum(cpatch%tlai_profile(:,:,:)) * cpatch%area + hio_ncl_si_age(io_si,cpatch%age_class) = hio_ncl_si_age(io_si,cpatch%age_class) & + + cpatch%ncl_p * cpatch%area + hio_npatches_si_age(io_si,cpatch%age_class) = hio_npatches_si_age(io_si,cpatch%age_class) + 1._r8 + + if ( ED_val_comp_excln .lt. 0._r8 ) then ! only valid when "strict ppa" enabled + hio_zstar_si_age(io_si,cpatch%age_class) = hio_zstar_si_age(io_si,cpatch%age_class) & + + cpatch%zstar * cpatch%area * AREA_INV + endif + + ! some diagnostics on secondary forest area and its age distribution + if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + hio_fraction_secondary_forest_si(io_si) = hio_fraction_secondary_forest_si(io_si) + & + cpatch%area * AREA_INV + + ageclass_since_anthrodist = get_age_class_index(cpatch%age_since_anthro_disturbance) + + hio_agesince_anthrodist_si_age(io_si,ageclass_since_anthrodist) = & + hio_agesince_anthrodist_si_age(io_si,ageclass_since_anthrodist) & + + cpatch%area * AREA_INV + + hio_secondaryforest_area_si_age(io_si,cpatch%age_class) = & + hio_secondaryforest_area_si_age(io_si,cpatch%age_class) & + + 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 class - 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 - !!! 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 + ! fractional area burnt [frac/day] -> [frac/sec] + 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 / sec_per_day + + ! 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 + + ! Fire intensity weighted by burned fraction [kJ/m/s] -> [J/m/s] + 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 * J_per_kJ + + ! Fuel sum [kg/m2] + 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 + + ! Canopy trimming - degree to which canopy expansion is limited by leaf economics (0-1) + if(associated(cpatch%tallest))then + hio_trimming_si(io_si) = hio_trimming_si(io_si) + cpatch%tallest%canopy_trim * cpatch%area * AREA_INV + endif + + ! area occupied by plants and trees [m2/m2] + 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 + + ! loop through cohorts on patch + ccohort => cpatch%shortest + cohortloop: do while(associated(ccohort)) + + ft = ccohort%pft + + ! get indices for size class x pft and cohort age x pft + ! size class is the fastest changing dimension + call sizetype_class_index(ccohort%dbh, ccohort%pft, & + ccohort%size_class, ccohort%size_by_pft_class) + ! cohort age is the fastest changing dimension + call coagetype_class_index(ccohort%coage, ccohort%pft, & + ccohort%coage_class, ccohort%coage_by_pft_class) + + ! Increment the number of cohorts per site + hio_ncohorts_si(io_si) = hio_ncohorts_si(io_si) + 1._r8 + + 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 + + ! calculate leaf height distribution, assuming leaf area is evenly distributed thru crown depth + height_bin_max = get_height_index(ccohort%hite) + height_bin_min = get_height_index(ccohort%hite * (1._r8 - EDPftvarcon_inst%crown(ft))) + do i_heightbin = height_bin_min, height_bin_max + binbottom = ED_val_history_height_bin_edges(i_heightbin) + if (i_heightbin .eq. nlevheight) then + bintop = reallytalltrees + else + bintop = ED_val_history_height_bin_edges(i_heightbin+1) + endif + ! what fraction of a cohort's crown is in this height bin? + frac_canopy_in_bin = (min(bintop,ccohort%hite) - & + max(binbottom,ccohort%hite * (1._r8 - EDPftvarcon_inst%crown(ft)))) / & + (ccohort%hite * EDPftvarcon_inst%crown(ft)) + + hio_leaf_height_dist_si_height(io_si,i_heightbin) = & + hio_leaf_height_dist_si_height(io_si,i_heightbin) + & + ccohort%c_area * AREA_INV * ccohort%treelai * frac_canopy_in_bin + + ! if ( ( ccohort%c_area * AREA_INV * ccohort%treelai * frac_canopy_in_bin) .lt. 0._r8) then + ! write(fates_log(),*) ' negative hio_leaf_height_dist_si_height:' + ! write(fates_log(),*) ' c_area, treelai, frac_canopy_in_bin:', ccohort%c_area, ccohort%treelai, frac_canopy_in_bin + ! endif 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 / sec_per_day - - ! 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 * J_per_kJ - - 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 + if (ccohort%canopy_layer .eq. 1) then + ! calculate the area of canopy that is within each height bin + hio_canopy_height_dist_si_height(io_si,height_bin_max) = & + hio_canopy_height_dist_si_height(io_si,height_bin_max) + ccohort%c_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)) - - ft = ccohort%pft - - call sizetype_class_index(ccohort%dbh, ccohort%pft, ccohort%size_class, ccohort%size_by_pft_class) - call coagetype_class_index(ccohort%coage, ccohort%pft, & - ccohort%coage_class, ccohort%coage_by_pft_class) - - ! Increment the number of cohorts per site - hio_ncohorts_si(io_si) = hio_ncohorts_si(io_si) + 1._r8 - - 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 - - ! calculate leaf height distribution, assuming leaf area is evenly distributed thru crown depth - height_bin_max = get_height_index(ccohort%hite) - height_bin_min = get_height_index(ccohort%hite * (1._r8 - EDPftvarcon_inst%crown(ft))) - do i_heightbin = height_bin_min, height_bin_max - binbottom = ED_val_history_height_bin_edges(i_heightbin) - if (i_heightbin .eq. nlevheight) then - bintop = reallytalltrees - else - bintop = ED_val_history_height_bin_edges(i_heightbin+1) + ! Update biomass components + ! Mass pools [kg] + elloop: do el = 1, num_elements + + sapw_m = ccohort%prt%GetState(sapw_organ, element_list(el)) + struct_m = ccohort%prt%GetState(struct_organ, element_list(el)) + leaf_m = ccohort%prt%GetState(leaf_organ, element_list(el)) + fnrt_m = ccohort%prt%GetState(fnrt_organ, element_list(el)) + store_m = ccohort%prt%GetState(store_organ, element_list(el)) + repro_m = ccohort%prt%GetState(repro_organ, element_list(el)) + + alive_m = leaf_m + fnrt_m + sapw_m + total_m = alive_m + store_m + struct_m + + ! Plant multi-element states and fluxes + ! Zero states, and set the fluxes + if( element_list(el).eq.carbon12_element )then + + ! mass in different tissues [kg/ha] -> [kg/m2] + this%hvars(ih_storec_si)%r81d(io_si) = & + this%hvars(ih_storec_si)%r81d(io_si) + ccohort%n * & + store_m / m2_per_ha + this%hvars(ih_leafc_si)%r81d(io_si) = & + this%hvars(ih_leafc_si)%r81d(io_si) + ccohort%n * & + leaf_m / m2_per_ha + this%hvars(ih_fnrtc_si)%r81d(io_si) = & + this%hvars(ih_fnrtc_si)%r81d(io_si) + ccohort%n * & + fnrt_m / m2_per_ha + this%hvars(ih_reproc_si)%r81d(io_si) = & + this%hvars(ih_reproc_si)%r81d(io_si)+ ccohort%n * & + repro_m / m2_per_ha + this%hvars(ih_sapwc_si)%r81d(io_si) = & + this%hvars(ih_sapwc_si)%r81d(io_si) + ccohort%n * & + sapw_m / m2_per_ha + this%hvars(ih_totvegc_si)%r81d(io_si) = & + this%hvars(ih_totvegc_si)%r81d(io_si)+ ccohort%n * & + total_m / m2_per_ha + + hio_bdead_si(io_si) = hio_bdead_si(io_si) + n_perm2 * struct_m + hio_balive_si(io_si) = hio_balive_si(io_si) + n_perm2 * alive_m + + hio_agb_si(io_si) = hio_agb_si(io_si) + n_perm2 * & + ( leaf_m + (sapw_m + struct_m + store_m) * prt_params%allom_agb_frac(ccohort%pft) ) + + + ! Update PFT partitioned biomass components + hio_leafbiomass_si_pft(io_si,ft) = hio_leafbiomass_si_pft(io_si,ft) + & + (ccohort%n * AREA_INV) * leaf_m + + hio_storebiomass_si_pft(io_si,ft) = hio_storebiomass_si_pft(io_si,ft) + & + (ccohort%n * AREA_INV) * store_m + + hio_nindivs_si_pft(io_si,ft) = hio_nindivs_si_pft(io_si,ft) + & + ccohort%n * AREA_INV + + hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & + (ccohort%n * AREA_INV) * total_m + + ! update total biomass per age bin + hio_biomass_si_age(io_si,cpatch%age_class) = hio_biomass_si_age(io_si,cpatch%age_class) & + + total_m * ccohort%n * AREA_INV + + ! track the total biomass on all secondary lands + if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + hio_biomass_secondary_forest_si(io_si) = hio_biomass_secondary_forest_si(io_si) + & + total_m * ccohort%n * AREA_INV endif - ! what fraction of a cohort's crown is in this height bin? - frac_canopy_in_bin = (min(bintop,ccohort%hite) - & - max(binbottom,ccohort%hite * (1._r8 - EDPftvarcon_inst%crown(ft)))) / & - (ccohort%hite * EDPftvarcon_inst%crown(ft)) - ! - hio_leaf_height_dist_si_height(io_si,i_heightbin) = & - hio_leaf_height_dist_si_height(io_si,i_heightbin) + & - ccohort%c_area * AREA_INV * ccohort%treelai * frac_canopy_in_bin - - ! if ( ( ccohort%c_area * AREA_INV * ccohort%treelai * frac_canopy_in_bin) .lt. 0._r8) then - ! write(fates_log(),*) ' negative hio_leaf_height_dist_si_height:' - ! write(fates_log(),*) ' c_area, treelai, frac_canopy_in_bin:', ccohort%c_area, ccohort%treelai, frac_canopy_in_bin - ! endif - end do - if (ccohort%canopy_layer .eq. 1) then - ! calculate the area of canopy that is within each height bin - hio_canopy_height_dist_si_height(io_si,height_bin_max) = & - hio_canopy_height_dist_si_height(io_si,height_bin_max) + ccohort%c_area * AREA_INV - endif - - ! Update biomass components - ! Mass pools [kgC] - do el = 1, num_elements - - sapw_m = ccohort%prt%GetState(sapw_organ, element_list(el)) - struct_m = ccohort%prt%GetState(struct_organ, element_list(el)) - leaf_m = ccohort%prt%GetState(leaf_organ, element_list(el)) - fnrt_m = ccohort%prt%GetState(fnrt_organ, element_list(el)) - store_m = ccohort%prt%GetState(store_organ, element_list(el)) - repro_m = ccohort%prt%GetState(repro_organ, element_list(el)) - - - alive_m = leaf_m + fnrt_m + sapw_m - total_m = alive_m + store_m + struct_m - - ! Plant multi-element states and fluxes - ! Zero states, and set the fluxes - if( element_list(el).eq.carbon12_element )then - - this%hvars(ih_storec_si)%r81d(io_si) = & - this%hvars(ih_storec_si)%r81d(io_si) + ccohort%n * store_m / m2_per_ha - this%hvars(ih_leafc_si)%r81d(io_si) = & - this%hvars(ih_leafc_si)%r81d(io_si) + ccohort%n * leaf_m / m2_per_ha - this%hvars(ih_fnrtc_si)%r81d(io_si) = & - this%hvars(ih_fnrtc_si)%r81d(io_si) + ccohort%n * fnrt_m / m2_per_ha - this%hvars(ih_reproc_si)%r81d(io_si) = & - this%hvars(ih_reproc_si)%r81d(io_si)+ ccohort%n * repro_m / m2_per_ha - this%hvars(ih_sapwc_si)%r81d(io_si) = & - this%hvars(ih_sapwc_si)%r81d(io_si)+ ccohort%n * sapw_m / m2_per_ha - this%hvars(ih_totvegc_si)%r81d(io_si) = & - this%hvars(ih_totvegc_si)%r81d(io_si)+ ccohort%n * total_m / m2_per_ha - - hio_bdead_si(io_si) = hio_bdead_si(io_si) + n_perm2 * struct_m - hio_balive_si(io_si) = hio_balive_si(io_si) + n_perm2 * alive_m - - hio_agb_si(io_si) = hio_agb_si(io_si) + n_perm2 * & - ( leaf_m + (sapw_m + struct_m + store_m) * prt_params%allom_agb_frac(ccohort%pft) ) - - - ! Update PFT partitioned biomass components - hio_leafbiomass_si_pft(io_si,ft) = hio_leafbiomass_si_pft(io_si,ft) + & - (ccohort%n * AREA_INV) * leaf_m - - hio_storebiomass_si_pft(io_si,ft) = hio_storebiomass_si_pft(io_si,ft) + & - (ccohort%n * AREA_INV) * store_m - - hio_nindivs_si_pft(io_si,ft) = hio_nindivs_si_pft(io_si,ft) + & - ccohort%n * AREA_INV - - hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & - (ccohort%n * AREA_INV) * total_m - - ! update total biomass per age bin - hio_biomass_si_age(io_si,cpatch%age_class) = hio_biomass_si_age(io_si,cpatch%age_class) & - + total_m * ccohort%n * AREA_INV - - ! track the total biomass on all secondary lands - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then - hio_biomass_secondary_forest_si(io_si) = hio_biomass_secondary_forest_si(io_si) + & - total_m * ccohort%n * AREA_INV - endif - - elseif(element_list(el).eq.nitrogen_element)then - - store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) - - this%hvars(ih_storen_si)%r81d(io_si) = & - this%hvars(ih_storen_si)%r81d(io_si) + ccohort%n * store_m / m2_per_ha - this%hvars(ih_storentfrac_si)%r81d(io_si) = & - this%hvars(ih_storentfrac_si)%r81d(io_si) + ccohort%n * store_max / m2_per_ha - this%hvars(ih_leafn_si)%r81d(io_si) = & - this%hvars(ih_leafn_si)%r81d(io_si) + ccohort%n * leaf_m / m2_per_ha - this%hvars(ih_fnrtn_si)%r81d(io_si) = & - this%hvars(ih_fnrtn_si)%r81d(io_si) + ccohort%n * fnrt_m / m2_per_ha - this%hvars(ih_repron_si)%r81d(io_si) = & - this%hvars(ih_repron_si)%r81d(io_si) + ccohort%n * repro_m / m2_per_ha - this%hvars(ih_sapwn_si)%r81d(io_si) = & - this%hvars(ih_sapwn_si)%r81d(io_si) + ccohort%n * sapw_m / m2_per_ha - this%hvars(ih_totvegn_si)%r81d(io_si) = & - this%hvars(ih_totvegn_si)%r81d(io_si) + ccohort%n * total_m / m2_per_ha - - - elseif(element_list(el).eq.phosphorus_element) then - - store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) - - this%hvars(ih_storep_si)%r81d(io_si) = & - this%hvars(ih_storep_si)%r81d(io_si) + ccohort%n * store_m / m2_per_ha - this%hvars(ih_storeptfrac_si)%r81d(io_si) = & - this%hvars(ih_storeptfrac_si)%r81d(io_si) + ccohort%n * store_max / m2_per_ha - this%hvars(ih_leafp_si)%r81d(io_si) = & - this%hvars(ih_leafp_si)%r81d(io_si) + ccohort%n * leaf_m / m2_per_ha - this%hvars(ih_fnrtp_si)%r81d(io_si) = & - this%hvars(ih_fnrtp_si)%r81d(io_si) + ccohort%n * fnrt_m / m2_per_ha - this%hvars(ih_reprop_si)%r81d(io_si) = & - this%hvars(ih_reprop_si)%r81d(io_si) + ccohort%n * repro_m / m2_per_ha - this%hvars(ih_sapwp_si)%r81d(io_si) = & - this%hvars(ih_sapwp_si)%r81d(io_si) + ccohort%n * sapw_m / m2_per_ha - this%hvars(ih_totvegp_si)%r81d(io_si) = & - this%hvars(ih_totvegp_si)%r81d(io_si)+ ccohort%n * total_m / m2_per_ha + elseif(element_list(el).eq.nitrogen_element)then + + store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) + + this%hvars(ih_storen_si)%r81d(io_si) = & + this%hvars(ih_storen_si)%r81d(io_si) + ccohort%n * & + store_m / m2_per_ha + this%hvars(ih_storentfrac_si)%r81d(io_si) = & + this%hvars(ih_storentfrac_si)%r81d(io_si) + ccohort%n * & + store_max / m2_per_ha + this%hvars(ih_leafn_si)%r81d(io_si) = & + this%hvars(ih_leafn_si)%r81d(io_si) + ccohort%n * & + leaf_m / m2_per_ha + this%hvars(ih_fnrtn_si)%r81d(io_si) = & + this%hvars(ih_fnrtn_si)%r81d(io_si) + ccohort%n * & + fnrt_m / m2_per_ha + this%hvars(ih_repron_si)%r81d(io_si) = & + this%hvars(ih_repron_si)%r81d(io_si) + ccohort%n * & + repro_m / m2_per_ha + this%hvars(ih_sapwn_si)%r81d(io_si) = & + this%hvars(ih_sapwn_si)%r81d(io_si) + ccohort%n * & + sapw_m / m2_per_ha + this%hvars(ih_totvegn_si)%r81d(io_si) = & + this%hvars(ih_totvegn_si)%r81d(io_si) + ccohort%n * & + total_m / m2_per_ha + + elseif(element_list(el).eq.phosphorus_element) then + + store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) + + this%hvars(ih_storep_si)%r81d(io_si) = & + this%hvars(ih_storep_si)%r81d(io_si) + ccohort%n * & + store_m / m2_per_ha + this%hvars(ih_storeptfrac_si)%r81d(io_si) = & + this%hvars(ih_storeptfrac_si)%r81d(io_si) + ccohort%n * & + store_max / m2_per_ha + this%hvars(ih_leafp_si)%r81d(io_si) = & + this%hvars(ih_leafp_si)%r81d(io_si) + ccohort%n * & + leaf_m / m2_per_ha + this%hvars(ih_fnrtp_si)%r81d(io_si) = & + this%hvars(ih_fnrtp_si)%r81d(io_si) + ccohort%n * & + fnrt_m / m2_per_ha + this%hvars(ih_reprop_si)%r81d(io_si) = & + this%hvars(ih_reprop_si)%r81d(io_si) + ccohort%n * & + repro_m / m2_per_ha + this%hvars(ih_sapwp_si)%r81d(io_si) = & + this%hvars(ih_sapwp_si)%r81d(io_si) + ccohort%n * & + sapw_m / m2_per_ha + this%hvars(ih_totvegp_si)%r81d(io_si) = & + this%hvars(ih_totvegp_si)%r81d(io_si)+ ccohort%n * & + total_m / m2_per_ha - end if + end if - end do + end do elloop + ! Update PFT crown area + hio_crownarea_si_pft(io_si, ft) = hio_crownarea_si_pft(io_si, ft) + & + ccohort%c_area * AREA_INV + if (ccohort%canopy_layer .eq. 1) then + ! Update PFT canopy crown area + hio_canopycrownarea_si_pft(io_si, ft) = hio_canopycrownarea_si_pft(io_si, ft) + & + ccohort%c_area * AREA_INV + end if - ! Update PFT crown area - hio_crownarea_si_pft(io_si, ft) = hio_crownarea_si_pft(io_si, ft) + & - ccohort%c_area * AREA_INV + ! update pft-resolved NPP and GPP fluxes + hio_gpp_si_pft(io_si, ft) = hio_gpp_si_pft(io_si, ft) + & + ccohort%gpp_acc_hold * n_perm2 / days_per_year / sec_per_day + + hio_npp_si_pft(io_si, ft) = hio_npp_si_pft(io_si, ft) + & + ccohort%npp_acc_hold * n_perm2 / days_per_year / sec_per_day + + ! Site by Size-Class x PFT (SCPF) + ! ------------------------------------------------------------------------ + + dbh = ccohort%dbh !-0.5*(1./365.25)*ccohort%ddbhdt + + ! Flux Variables (cohorts must had experienced a day before any of these values + ! have any meaning, otherwise they are just inialization values + notnew: if( .not.(ccohort%isnew) ) then + + ! Turnover pools [kgC/day] * [day/yr] = [kgC/yr] + sapw_m_turnover = ccohort%prt%GetTurnover(sapw_organ, carbon12_element) * days_per_year + store_m_turnover = ccohort%prt%GetTurnover(store_organ, carbon12_element) * days_per_year + leaf_m_turnover = ccohort%prt%GetTurnover(leaf_organ, carbon12_element) * days_per_year + fnrt_m_turnover = ccohort%prt%GetTurnover(fnrt_organ, carbon12_element) * days_per_year + struct_m_turnover = ccohort%prt%GetTurnover(struct_organ, carbon12_element) * days_per_year + + ! Net change from allocation and transport [kgC/day] * [day/yr] = [kgC/yr] + sapw_m_net_alloc = ccohort%prt%GetNetAlloc(sapw_organ, carbon12_element) * days_per_year + store_m_net_alloc = ccohort%prt%GetNetAlloc(store_organ, carbon12_element) * days_per_year + leaf_m_net_alloc = ccohort%prt%GetNetAlloc(leaf_organ, carbon12_element) * days_per_year + fnrt_m_net_alloc = ccohort%prt%GetNetAlloc(fnrt_organ, carbon12_element) * days_per_year + struct_m_net_alloc = ccohort%prt%GetNetAlloc(struct_organ, carbon12_element) * days_per_year + repro_m_net_alloc = ccohort%prt%GetNetAlloc(repro_organ, carbon12_element) * days_per_year + + ! ecosystem-level, organ-partitioned NPP/allocation fluxes + ! [kgC/yr] -> [kgC/sec] + hio_npp_leaf_si(io_si) = hio_npp_leaf_si(io_si) + & + leaf_m_net_alloc * n_perm2 / days_per_year / sec_per_day + hio_npp_seed_si(io_si) = hio_npp_seed_si(io_si) + & + repro_m_net_alloc * n_perm2 / days_per_year / sec_per_day + hio_npp_stem_si(io_si) = hio_npp_stem_si(io_si) + & + (sapw_m_net_alloc + struct_m_net_alloc) * n_perm2 * & + (prt_params%allom_agb_frac(ccohort%pft)) / & + days_per_year / sec_per_day + hio_npp_froot_si(io_si) = hio_npp_froot_si(io_si) + & + fnrt_m_net_alloc * n_perm2 / days_per_year / sec_per_day + hio_npp_croot_si(io_si) = hio_npp_croot_si(io_si) + & + (sapw_m_net_alloc + struct_m_net_alloc) * n_perm2 * & + (1._r8-prt_params%allom_agb_frac(ccohort%pft)) / & + days_per_year / sec_per_day + hio_npp_stor_si(io_si) = hio_npp_stor_si(io_si) + & + store_m_net_alloc * n_perm2 / days_per_year / sec_per_day + + associate( scpf => ccohort%size_by_pft_class, & + scls => ccohort%size_class, & + cacls => ccohort%coage_class, & + capf => ccohort%coage_by_pft_class) + + gpp_cached = (hio_gpp_si_scpf(io_si,scpf)) * & + days_per_year * sec_per_day + + ! [kgC/m2/s] + hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + & + n_perm2*ccohort%gpp_acc_hold / days_per_year / sec_per_day + hio_npp_totl_si_scpf(io_si,scpf) = hio_npp_totl_si_scpf(io_si,scpf) + & + ccohort%npp_acc_hold * n_perm2 / days_per_year / sec_per_day + + hio_npp_leaf_si_scpf(io_si,scpf) = hio_npp_leaf_si_scpf(io_si,scpf) + & + leaf_m_net_alloc*n_perm2 / days_per_year / sec_per_day + hio_npp_fnrt_si_scpf(io_si,scpf) = hio_npp_fnrt_si_scpf(io_si,scpf) + & + fnrt_m_net_alloc*n_perm2 / days_per_year / sec_per_day + hio_npp_bgsw_si_scpf(io_si,scpf) = hio_npp_bgsw_si_scpf(io_si,scpf) + & + sapw_m_net_alloc*n_perm2*(1._r8-prt_params%allom_agb_frac(ccohort%pft)) / & + days_per_year / sec_per_day + hio_npp_agsw_si_scpf(io_si,scpf) = hio_npp_agsw_si_scpf(io_si,scpf) + & + sapw_m_net_alloc*n_perm2*prt_params%allom_agb_frac(ccohort%pft) / & + days_per_year / sec_per_day + hio_npp_bgdw_si_scpf(io_si,scpf) = hio_npp_bgdw_si_scpf(io_si,scpf) + & + struct_m_net_alloc*n_perm2*(1._r8-prt_params%allom_agb_frac(ccohort%pft)) / & + days_per_year / sec_per_day + hio_npp_agdw_si_scpf(io_si,scpf) = hio_npp_agdw_si_scpf(io_si,scpf) + & + struct_m_net_alloc*n_perm2*prt_params%allom_agb_frac(ccohort%pft) / & + days_per_year / sec_per_day + hio_npp_seed_si_scpf(io_si,scpf) = hio_npp_seed_si_scpf(io_si,scpf) + & + repro_m_net_alloc*n_perm2 / days_per_year / sec_per_day + hio_npp_stor_si_scpf(io_si,scpf) = hio_npp_stor_si_scpf(io_si,scpf) + & + store_m_net_alloc*n_perm2 / days_per_year / sec_per_day + + ! Woody State Variables (basal area growth increment) + if ( int(prt_params%woody(ft)) == itrue) then + + ! basal area [m2/m2] + hio_ba_si_scpf(io_si,scpf) = hio_ba_si_scpf(io_si,scpf) + & + 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*ccohort%n / m2_per_ha + + ! also by size class only + hio_ba_si_scls(io_si,scls) = hio_ba_si_scls(io_si,scls) + & + 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)* & + ccohort%n / m2_per_ha + + ! growth increment + hio_ddbh_si_scpf(io_si,scpf) = hio_ddbh_si_scpf(io_si,scpf) + & + ccohort%ddbhdt*ccohort%n / m2_per_ha * m_per_cm - if (ccohort%canopy_layer .eq. 1) then - ! Update PFT canopy crown area - hio_canopycrownarea_si_pft(io_si, ft) = hio_canopycrownarea_si_pft(io_si, ft) + & - ccohort%c_area * AREA_INV end if - ! update pft-resolved NPP and GPP fluxes - hio_gpp_si_pft(io_si, ft) = hio_gpp_si_pft(io_si, ft) + & - ccohort%gpp_acc_hold * n_perm2 / days_per_year / sec_per_day - - hio_npp_si_pft(io_si, ft) = hio_npp_si_pft(io_si, ft) + & - ccohort%npp_acc_hold * n_perm2 / days_per_year / sec_per_day - - - ! Site by Size-Class x PFT (SCPF) - ! ------------------------------------------------------------------------ - - dbh = ccohort%dbh !-0.5*(1./365.25)*ccohort%ddbhdt - - ! Flux Variables (cohorts must had experienced a day before any of these values - ! have any meaning, otherwise they are just inialization values - if( .not.(ccohort%isnew) ) then - - ! Turnover pools [kgC/day] * [day/yr] = [kgC/yr] - sapw_m_turnover = ccohort%prt%GetTurnover(sapw_organ, carbon12_element) * days_per_year - store_m_turnover = ccohort%prt%GetTurnover(store_organ, carbon12_element) * days_per_year - leaf_m_turnover = ccohort%prt%GetTurnover(leaf_organ, carbon12_element) * days_per_year - fnrt_m_turnover = ccohort%prt%GetTurnover(fnrt_organ, carbon12_element) * days_per_year - struct_m_turnover = ccohort%prt%GetTurnover(struct_organ, carbon12_element) * days_per_year - - ! Net change from allocation and transport [kgC/day] * [day/yr] = [kgC/yr] - sapw_m_net_alloc = ccohort%prt%GetNetAlloc(sapw_organ, carbon12_element) * days_per_year - store_m_net_alloc = ccohort%prt%GetNetAlloc(store_organ, carbon12_element) * days_per_year - leaf_m_net_alloc = ccohort%prt%GetNetAlloc(leaf_organ, carbon12_element) * days_per_year - fnrt_m_net_alloc = ccohort%prt%GetNetAlloc(fnrt_organ, carbon12_element) * days_per_year - struct_m_net_alloc = ccohort%prt%GetNetAlloc(struct_organ, carbon12_element) * days_per_year - repro_m_net_alloc = ccohort%prt%GetNetAlloc(repro_organ, carbon12_element) * days_per_year - - ! ecosystem-level, organ-partitioned NPP/allocation fluxes - hio_npp_leaf_si(io_si) = hio_npp_leaf_si(io_si) + & - leaf_m_net_alloc * n_perm2 / days_per_year / sec_per_day - hio_npp_seed_si(io_si) = hio_npp_seed_si(io_si) + & - repro_m_net_alloc * n_perm2 / days_per_year / sec_per_day - hio_npp_stem_si(io_si) = hio_npp_stem_si(io_si) + & - (sapw_m_net_alloc + struct_m_net_alloc) * n_perm2 * & - (prt_params%allom_agb_frac(ccohort%pft)) / & - days_per_year / sec_per_day - hio_npp_froot_si(io_si) = hio_npp_froot_si(io_si) + & - fnrt_m_net_alloc * n_perm2 / days_per_year / sec_per_day - hio_npp_croot_si(io_si) = hio_npp_croot_si(io_si) + & - (sapw_m_net_alloc + struct_m_net_alloc) * n_perm2 * & - (1._r8-prt_params%allom_agb_frac(ccohort%pft)) / & - days_per_year / sec_per_day - hio_npp_stor_si(io_si) = hio_npp_stor_si(io_si) + & - store_m_net_alloc * n_perm2 / days_per_year / sec_per_day - - associate( scpf => ccohort%size_by_pft_class, & - - scls => ccohort%size_class, & - cacls => ccohort%coage_class, & - capf => ccohort%coage_by_pft_class) - - - gpp_cached = (hio_gpp_si_scpf(io_si,scpf)) * & - days_per_year * sec_per_day - - hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + & - n_perm2*ccohort%gpp_acc_hold / & - days_per_year / sec_per_day ! [kgC/m2/s] - hio_npp_totl_si_scpf(io_si,scpf) = hio_npp_totl_si_scpf(io_si,scpf) + & - ccohort%npp_acc_hold * n_perm2 / & - days_per_year / sec_per_day - - - hio_npp_leaf_si_scpf(io_si,scpf) = hio_npp_leaf_si_scpf(io_si,scpf) + & - leaf_m_net_alloc*n_perm2 / & - days_per_year / sec_per_day - hio_npp_fnrt_si_scpf(io_si,scpf) = hio_npp_fnrt_si_scpf(io_si,scpf) + & - fnrt_m_net_alloc*n_perm2 / & - days_per_year / sec_per_day - hio_npp_bgsw_si_scpf(io_si,scpf) = hio_npp_bgsw_si_scpf(io_si,scpf) + & - sapw_m_net_alloc*n_perm2* & - (1._r8-prt_params%allom_agb_frac(ccohort%pft)) / & - days_per_year / sec_per_day - hio_npp_agsw_si_scpf(io_si,scpf) = hio_npp_agsw_si_scpf(io_si,scpf) + & - sapw_m_net_alloc*n_perm2* & - prt_params%allom_agb_frac(ccohort%pft) / & - days_per_year / sec_per_day - hio_npp_bgdw_si_scpf(io_si,scpf) = hio_npp_bgdw_si_scpf(io_si,scpf) + & - struct_m_net_alloc*n_perm2* & - (1._r8-prt_params%allom_agb_frac(ccohort%pft)) / & - days_per_year / sec_per_day - hio_npp_agdw_si_scpf(io_si,scpf) = hio_npp_agdw_si_scpf(io_si,scpf) + & - struct_m_net_alloc*n_perm2* & - prt_params%allom_agb_frac(ccohort%pft) / & - days_per_year / sec_per_day - hio_npp_seed_si_scpf(io_si,scpf) = hio_npp_seed_si_scpf(io_si,scpf) + & - repro_m_net_alloc*n_perm2 / & - days_per_year / sec_per_day - hio_npp_stor_si_scpf(io_si,scpf) = hio_npp_stor_si_scpf(io_si,scpf) + & - store_m_net_alloc*n_perm2 / & - days_per_year / sec_per_day - - ! Woody State Variables (basal area growth increment) - if ( int(prt_params%woody(ft)) == itrue) then - - ! basal area [m2/m2] - hio_ba_si_scpf(io_si,scpf) = hio_ba_si_scpf(io_si,scpf) + & - 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*ccohort%n / m2_per_ha - - ! also by size class only - hio_ba_si_scls(io_si,scls) = hio_ba_si_scls(io_si,scls) + & - 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)* & - ccohort%n / m2_per_ha - - ! growth increment - hio_ddbh_si_scpf(io_si,scpf) = hio_ddbh_si_scpf(io_si,scpf) + & - ccohort%ddbhdt*ccohort%n / m2_per_ha * m_per_cm + ! mortality sums [#/m2] + hio_m1_si_scpf(io_si,scpf) = hio_m1_si_scpf(io_si,scpf) + & + ccohort%bmort*ccohort%n / m2_per_ha + hio_m2_si_scpf(io_si,scpf) = hio_m2_si_scpf(io_si,scpf) + & + ccohort%hmort*ccohort%n / m2_per_ha + hio_m3_si_scpf(io_si,scpf) = hio_m3_si_scpf(io_si,scpf) + & + ccohort%cmort*ccohort%n / m2_per_ha + + hio_m7_si_scpf(io_si,scpf) = hio_m7_si_scpf(io_si,scpf) + & + (ccohort%lmort_direct + ccohort%lmort_collateral + & + ccohort%lmort_infra) * ccohort%n / m2_per_ha + + hio_m8_si_scpf(io_si,scpf) = hio_m8_si_scpf(io_si,scpf) + & + ccohort%frmort*ccohort%n / m2_per_ha + hio_m9_si_scpf(io_si,scpf) = hio_m9_si_scpf(io_si,scpf) + & + ccohort%smort*ccohort%n / m2_per_ha + + if (hlm_use_cohort_age_tracking .eq.itrue) then + hio_m10_si_scpf(io_si,scpf) = hio_m10_si_scpf(io_si,scpf) + & + ccohort%asmort*ccohort%n / m2_per_ha + hio_m10_si_capf(io_si,capf) = hio_m10_si_capf(io_si,capf) + & + ccohort%asmort*ccohort%n / m2_per_ha + hio_m10_si_scls(io_si,scls) = hio_m10_si_scls(io_si,scls) + & + ccohort%asmort*ccohort%n / m2_per_ha + hio_m10_si_cacls(io_si,cacls) = hio_m10_si_cacls(io_si,cacls)+ & + ccohort%asmort*ccohort%n / m2_per_ha + end if - end if + hio_m1_si_scls(io_si,scls) = hio_m1_si_scls(io_si,scls) + ccohort%bmort*ccohort%n / m2_per_ha + hio_m2_si_scls(io_si,scls) = hio_m2_si_scls(io_si,scls) + ccohort%hmort*ccohort%n / m2_per_ha + hio_m3_si_scls(io_si,scls) = hio_m3_si_scls(io_si,scls) + ccohort%cmort*ccohort%n / m2_per_ha + hio_m7_si_scls(io_si,scls) = hio_m7_si_scls(io_si,scls) + & + (ccohort%lmort_direct+ccohort%lmort_collateral+ccohort%lmort_infra) * ccohort%n / m2_per_ha + hio_m8_si_scls(io_si,scls) = hio_m8_si_scls(io_si,scls) + & + ccohort%frmort*ccohort%n / m2_per_ha + hio_m9_si_scls(io_si,scls) = hio_m9_si_scls(io_si,scls) + ccohort%smort*ccohort%n / m2_per_ha + + !C13 discrimination + if(gpp_cached + ccohort%gpp_acc_hold > 0.0_r8)then + hio_c13disc_si_scpf(io_si,scpf) = ((hio_c13disc_si_scpf(io_si,scpf) * gpp_cached) + & + (ccohort%c13disc_acc * ccohort%gpp_acc_hold)) / (gpp_cached + ccohort%gpp_acc_hold) + else + hio_c13disc_si_scpf(io_si,scpf) = 0.0_r8 + endif - hio_m1_si_scpf(io_si,scpf) = hio_m1_si_scpf(io_si,scpf) + & - ccohort%bmort*ccohort%n / m2_per_ha - hio_m2_si_scpf(io_si,scpf) = hio_m2_si_scpf(io_si,scpf) + & - ccohort%hmort*ccohort%n / m2_per_ha - hio_m3_si_scpf(io_si,scpf) = hio_m3_si_scpf(io_si,scpf) + & - ccohort%cmort*ccohort%n / m2_per_ha - - hio_m7_si_scpf(io_si,scpf) = hio_m7_si_scpf(io_si,scpf) + & - (ccohort%lmort_direct + ccohort%lmort_collateral + & - ccohort%lmort_infra) * ccohort%n / m2_per_ha - - hio_m8_si_scpf(io_si,scpf) = hio_m8_si_scpf(io_si,scpf) + & - ccohort%frmort*ccohort%n / m2_per_ha - hio_m9_si_scpf(io_si,scpf) = hio_m9_si_scpf(io_si,scpf) + & - ccohort%smort*ccohort%n / m2_per_ha - - if (hlm_use_cohort_age_tracking .eq.itrue) then - hio_m10_si_scpf(io_si,scpf) = hio_m10_si_scpf(io_si,scpf) + ccohort%asmort*ccohort%n / m2_per_ha - hio_m10_si_capf(io_si,capf) = hio_m10_si_capf(io_si,capf) + ccohort%asmort*ccohort%n / m2_per_ha - hio_m10_si_scls(io_si,scls) = hio_m10_si_scls(io_si,scls) + ccohort%asmort*ccohort%n / m2_per_ha - hio_m10_si_cacls(io_si,cacls) = hio_m10_si_cacls(io_si,cacls)+ & - ccohort%asmort*ccohort%n / m2_per_ha - end if - - hio_m1_si_scls(io_si,scls) = hio_m1_si_scls(io_si,scls) + ccohort%bmort*ccohort%n / m2_per_ha - hio_m2_si_scls(io_si,scls) = hio_m2_si_scls(io_si,scls) + ccohort%hmort*ccohort%n / m2_per_ha - hio_m3_si_scls(io_si,scls) = hio_m3_si_scls(io_si,scls) + ccohort%cmort*ccohort%n / m2_per_ha - hio_m7_si_scls(io_si,scls) = hio_m7_si_scls(io_si,scls) + & - (ccohort%lmort_direct+ccohort%lmort_collateral+ccohort%lmort_infra) * ccohort%n / m2_per_ha - hio_m8_si_scls(io_si,scls) = hio_m8_si_scls(io_si,scls) + & - ccohort%frmort*ccohort%n / m2_per_ha - hio_m9_si_scls(io_si,scls) = hio_m9_si_scls(io_si,scls) + ccohort%smort*ccohort%n / m2_per_ha - - - - !C13 discrimination - if(gpp_cached + ccohort%gpp_acc_hold > 0.0_r8)then - hio_c13disc_si_scpf(io_si,scpf) = ((hio_c13disc_si_scpf(io_si,scpf) * gpp_cached) + & - (ccohort%c13disc_acc * ccohort%gpp_acc_hold)) / (gpp_cached + ccohort%gpp_acc_hold) - else - hio_c13disc_si_scpf(io_si,scpf) = 0.0_r8 - endif - - ! number density [/ha] - hio_nplant_si_scpf(io_si,scpf) = hio_nplant_si_scpf(io_si,scpf) + ccohort%n / m2_per_ha - - ! number density along the cohort age dimension - if (hlm_use_cohort_age_tracking .eq.itrue) then - hio_nplant_si_capf(io_si,capf) = hio_nplant_si_capf(io_si,capf) + ccohort%n / m2_per_ha - hio_nplant_si_cacls(io_si,cacls) = hio_nplant_si_cacls(io_si,cacls)+ccohort%n / m2_per_ha - end if - - - ! Carbon only metrics - sapw_m = ccohort%prt%GetState(sapw_organ, carbon12_element) - struct_m = ccohort%prt%GetState(struct_organ, carbon12_element) - leaf_m = ccohort%prt%GetState(leaf_organ, carbon12_element) - fnrt_m = ccohort%prt%GetState(fnrt_organ, carbon12_element) - store_m = ccohort%prt%GetState(store_organ, carbon12_element) - repro_m = ccohort%prt%GetState(repro_organ, carbon12_element) - alive_m = leaf_m + fnrt_m + sapw_m - total_m = alive_m + store_m + struct_m - - - ! number density by size and biomass - hio_agb_si_scls(io_si,scls) = hio_agb_si_scls(io_si,scls) + & - total_m * ccohort%n * prt_params%allom_agb_frac(ccohort%pft) * AREA_INV - - hio_agb_si_scpf(io_si,scpf) = hio_agb_si_scpf(io_si,scpf) + & - total_m * ccohort%n * prt_params%allom_agb_frac(ccohort%pft) * AREA_INV - - - hio_biomass_si_scls(io_si,scls) = hio_biomass_si_scls(io_si,scls) + & - total_m * ccohort%n * AREA_INV - - ! update size-class x patch-age related quantities - - iscag = get_sizeage_class_index(ccohort%dbh,cpatch%age) - - hio_nplant_si_scag(io_si,iscag) = hio_nplant_si_scag(io_si,iscag) + ccohort%n / m2_per_ha - - hio_nplant_si_scls(io_si,scls) = hio_nplant_si_scls(io_si,scls) + ccohort%n / m2_per_ha - - - ! update size, age, and PFT - indexed quantities - - iscagpft = get_sizeagepft_class_index(ccohort%dbh,cpatch%age,ccohort%pft) - - hio_nplant_si_scagpft(io_si,iscagpft) = hio_nplant_si_scagpft(io_si,iscagpft) + ccohort%n / m2_per_ha - - ! update age and PFT - indexed quantities - - iagepft = get_agepft_class_index(cpatch%age,ccohort%pft) - - hio_npp_si_agepft(io_si,iagepft) = hio_npp_si_agepft(io_si,iagepft) + & - ccohort%n * ccohort%npp_acc_hold * AREA_INV / days_per_year / sec_per_day - - hio_biomass_si_agepft(io_si,iagepft) = hio_biomass_si_agepft(io_si,iagepft) + & - total_m * ccohort%n * AREA_INV - - ! update SCPF/SCLS- and canopy/subcanopy- partitioned quantities - if (ccohort%canopy_layer .eq. 1) then - hio_nplant_canopy_si_scag(io_si,iscag) = hio_nplant_canopy_si_scag(io_si,iscag) + ccohort%n / m2_per_ha - hio_mortality_canopy_si_scag(io_si,iscag) = hio_mortality_canopy_si_scag(io_si,iscag) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha - hio_ddbh_canopy_si_scag(io_si,iscag) = hio_ddbh_canopy_si_scag(io_si,iscag) + & - ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha - hio_bstor_canopy_si_scpf(io_si,scpf) = hio_bstor_canopy_si_scpf(io_si,scpf) + & - store_m * ccohort%n / m2_per_ha - hio_bleaf_canopy_si_scpf(io_si,scpf) = hio_bleaf_canopy_si_scpf(io_si,scpf) + & - leaf_m * ccohort%n / m2_per_ha - - hio_canopy_biomass_si(io_si) = hio_canopy_biomass_si(io_si) + n_perm2 * total_m - - !hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & - ! (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ! ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n - - hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%frmort + & - ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & - (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * sec_per_day * days_per_year / m2_per_ha - - hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + ccohort%n / m2_per_ha - hio_nplant_canopy_si_scls(io_si,scls) = hio_nplant_canopy_si_scls(io_si,scls) + ccohort%n / m2_per_ha - hio_lai_canopy_si_scls(io_si,scls) = hio_lai_canopy_si_scls(io_si,scls) + & - ccohort%treelai*ccohort%c_area * AREA_INV - hio_sai_canopy_si_scls(io_si,scls) = hio_sai_canopy_si_scls(io_si,scls) + & - ccohort%treesai*ccohort%c_area * AREA_INV - hio_trimming_canopy_si_scls(io_si,scls) = hio_trimming_canopy_si_scls(io_si,scls) + & - ccohort%n * ccohort%canopy_trim / m2_per_ha - hio_crown_area_canopy_si_scls(io_si,scls) = hio_crown_area_canopy_si_scls(io_si,scls) + & - ccohort%c_area / m2_per_ha - hio_gpp_canopy_si_scpf(io_si,scpf) = hio_gpp_canopy_si_scpf(io_si,scpf) + & - n_perm2*ccohort%gpp_acc_hold / days_per_year / sec_per_day - hio_ar_canopy_si_scpf(io_si,scpf) = hio_ar_canopy_si_scpf(io_si,scpf) + & - n_perm2*ccohort%resp_acc_hold / days_per_year / sec_per_day - ! growth increment - hio_ddbh_canopy_si_scpf(io_si,scpf) = hio_ddbh_canopy_si_scpf(io_si,scpf) + & - ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha - hio_ddbh_canopy_si_scls(io_si,scls) = hio_ddbh_canopy_si_scls(io_si,scls) + & - ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha - - ! sum of all mortality - hio_mortality_canopy_si_scls(io_si,scls) = hio_mortality_canopy_si_scls(io_si,scls) + & - - (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & - (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * sec_per_day * days_per_year / m2_per_ha - - hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * & - total_m * ccohort%n * days_per_sec * years_per_day * ha_per_m2 + & - (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_m * & - ccohort%n * ha_per_m2 - - - hio_carbon_balance_canopy_si_scls(io_si,scls) = hio_carbon_balance_canopy_si_scls(io_si,scls) + & - ccohort%n * ccohort%npp_acc_hold / m2_per_ha / days_per_year / sec_per_day - - - hio_leaf_md_canopy_si_scls(io_si,scls) = hio_leaf_md_canopy_si_scls(io_si,scls) + & - leaf_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_root_md_canopy_si_scls(io_si,scls) = hio_root_md_canopy_si_scls(io_si,scls) + & - fnrt_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_bsw_md_canopy_si_scls(io_si,scls) = hio_bsw_md_canopy_si_scls(io_si,scls) + & - sapw_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_bstore_md_canopy_si_scls(io_si,scls) = hio_bstore_md_canopy_si_scls(io_si,scls) + & - store_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_bdead_md_canopy_si_scls(io_si,scls) = hio_bdead_md_canopy_si_scls(io_si,scls) + & - struct_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_seed_prod_canopy_si_scls(io_si,scls) = hio_seed_prod_canopy_si_scls(io_si,scls) + & - ccohort%seed_prod * ccohort%n / m2_per_ha / days_per_year / sec_per_day - - hio_npp_leaf_canopy_si_scls(io_si,scls) = hio_npp_leaf_canopy_si_scls(io_si,scls) + & - leaf_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_npp_fnrt_canopy_si_scls(io_si,scls) = hio_npp_fnrt_canopy_si_scls(io_si,scls) + & - fnrt_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_npp_sapw_canopy_si_scls(io_si,scls) = hio_npp_sapw_canopy_si_scls(io_si,scls) + & - sapw_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_npp_dead_canopy_si_scls(io_si,scls) = hio_npp_dead_canopy_si_scls(io_si,scls) + & - struct_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_npp_seed_canopy_si_scls(io_si,scls) = hio_npp_seed_canopy_si_scls(io_si,scls) + & - repro_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_npp_stor_canopy_si_scls(io_si,scls) = hio_npp_stor_canopy_si_scls(io_si,scls) + & - store_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day - - hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) = & - hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) + & - ccohort%canopy_layer_yesterday * ccohort%n / m2_per_ha - else - hio_nplant_understory_si_scag(io_si,iscag) = hio_nplant_understory_si_scag(io_si,iscag) + ccohort%n / m2_per_ha - hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha - hio_ddbh_understory_si_scag(io_si,iscag) = hio_ddbh_understory_si_scag(io_si,iscag) + & - ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha - hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & - store_m * ccohort%n / m2_per_ha - hio_bleaf_understory_si_scpf(io_si,scpf) = hio_bleaf_understory_si_scpf(io_si,scpf) + & - leaf_m * ccohort%n / m2_per_ha - hio_understory_biomass_si(io_si) = hio_understory_biomass_si(io_si) + & - n_perm2 * total_m - - !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 - - 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 / m2_per_ha + & - (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * sec_per_day * days_per_year / m2_per_ha - - hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + ccohort%n / m2_per_ha - hio_nplant_understory_si_scls(io_si,scls) = hio_nplant_understory_si_scls(io_si,scls) + ccohort%n / m2_per_ha - hio_lai_understory_si_scls(io_si,scls) = hio_lai_understory_si_scls(io_si,scls) + & - ccohort%treelai*ccohort%c_area * AREA_INV - hio_sai_understory_si_scls(io_si,scls) = hio_sai_understory_si_scls(io_si,scls) + & - ccohort%treelai*ccohort%c_area * AREA_INV - hio_trimming_understory_si_scls(io_si,scls) = hio_trimming_understory_si_scls(io_si,scls) + & - ccohort%n * ccohort%canopy_trim / m2_per_ha - hio_crown_area_understory_si_scls(io_si,scls) = hio_crown_area_understory_si_scls(io_si,scls) + & - ccohort%c_area / m2_per_ha - hio_gpp_understory_si_scpf(io_si,scpf) = hio_gpp_understory_si_scpf(io_si,scpf) + & - n_perm2*ccohort%gpp_acc_hold / days_per_year / sec_per_day - hio_ar_understory_si_scpf(io_si,scpf) = hio_ar_understory_si_scpf(io_si,scpf) + & - n_perm2*ccohort%resp_acc_hold / days_per_year / sec_per_day - - ! growth increment - hio_ddbh_understory_si_scpf(io_si,scpf) = hio_ddbh_understory_si_scpf(io_si,scpf) + & - ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha - hio_ddbh_understory_si_scls(io_si,scls) = hio_ddbh_understory_si_scls(io_si,scls) + & - ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha - - ! sum of all mortality - hio_mortality_understory_si_scls(io_si,scls) = hio_mortality_understory_si_scls(io_si,scls) + & - - (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & - (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * sec_per_day * days_per_year / m2_per_ha - - hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * & - total_m * ccohort%n * days_per_sec * years_per_day * ha_per_m2 + & - (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_m * & - ccohort%n * ha_per_m2 - - hio_carbon_balance_understory_si_scls(io_si,scls) = hio_carbon_balance_understory_si_scls(io_si,scls) + & - ccohort%npp_acc_hold * ccohort%n / m2_per_ha / days_per_year / sec_per_day - - hio_leaf_md_understory_si_scls(io_si,scls) = hio_leaf_md_understory_si_scls(io_si,scls) + & - leaf_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_root_md_understory_si_scls(io_si,scls) = hio_root_md_understory_si_scls(io_si,scls) + & - fnrt_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_bsw_md_understory_si_scls(io_si,scls) = hio_bsw_md_understory_si_scls(io_si,scls) + & - sapw_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_bstore_md_understory_si_scls(io_si,scls) = hio_bstore_md_understory_si_scls(io_si,scls) + & - store_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_bdead_md_understory_si_scls(io_si,scls) = hio_bdead_md_understory_si_scls(io_si,scls) + & - struct_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_seed_prod_understory_si_scls(io_si,scls) = hio_seed_prod_understory_si_scls(io_si,scls) + & - ccohort%seed_prod * ccohort%n / m2_per_ha / days_per_year / sec_per_day - - hio_npp_leaf_understory_si_scls(io_si,scls) = hio_npp_leaf_understory_si_scls(io_si,scls) + & - leaf_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_npp_fnrt_understory_si_scls(io_si,scls) = hio_npp_fnrt_understory_si_scls(io_si,scls) + & - fnrt_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_npp_sapw_understory_si_scls(io_si,scls) = hio_npp_sapw_understory_si_scls(io_si,scls) + & - sapw_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_npp_dead_understory_si_scls(io_si,scls) = hio_npp_dead_understory_si_scls(io_si,scls) + & - struct_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_npp_seed_understory_si_scls(io_si,scls) = hio_npp_seed_understory_si_scls(io_si,scls) + & - repro_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day - hio_npp_stor_understory_si_scls(io_si,scls) = hio_npp_stor_understory_si_scls(io_si,scls) + & - store_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day - - hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) = & - hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) + & - ccohort%canopy_layer_yesterday * ccohort%n / m2_per_ha - endif - ! - ! - ccohort%canopy_layer_yesterday = real(ccohort%canopy_layer, r8) - ! - ! growth flux of individuals into a given bin - ! track the actual growth here, the virtual growth from fusion lower down - if ( (scls - ccohort%size_class_lasttimestep ) .gt. 0) then - do i_scls = ccohort%size_class_lasttimestep + 1, scls - i_scpf = (ccohort%pft-1)*nlevsclass+i_scls - hio_growthflux_si_scpf(io_si,i_scpf) = hio_growthflux_si_scpf(io_si,i_scpf) + & - ccohort%n * days_per_year / m2_per_ha - end do - end if - ccohort%size_class_lasttimestep = scls - - - ! - end associate - else ! i.e. cohort%isnew - ! - ! if cohort is new, track its growth flux into the first size bin - i_scpf = (ccohort%pft-1)*nlevsclass+1 - hio_growthflux_si_scpf(io_si,i_scpf) = & - hio_growthflux_si_scpf(io_si,i_scpf) + ccohort%n * & - days_per_year / m2_per_ha - ccohort%size_class_lasttimestep = 1 + ! number density [/m2] + hio_nplant_si_scpf(io_si,scpf) = hio_nplant_si_scpf(io_si,scpf) + ccohort%n / m2_per_ha + ! number density along the cohort age dimension + if (hlm_use_cohort_age_tracking .eq.itrue) then + hio_nplant_si_capf(io_si,capf) = hio_nplant_si_capf(io_si,capf) + ccohort%n / m2_per_ha + hio_nplant_si_cacls(io_si,cacls) = hio_nplant_si_cacls(io_si,cacls)+ccohort%n / m2_per_ha end if - ! resolve some canopy area profiles, both total and of occupied leaves - ican = ccohort%canopy_layer + ! Carbon only metrics + sapw_m = ccohort%prt%GetState(sapw_organ, carbon12_element) + struct_m = ccohort%prt%GetState(struct_organ, carbon12_element) + leaf_m = ccohort%prt%GetState(leaf_organ, carbon12_element) + fnrt_m = ccohort%prt%GetState(fnrt_organ, carbon12_element) + store_m = ccohort%prt%GetState(store_organ, carbon12_element) + repro_m = ccohort%prt%GetState(repro_organ, carbon12_element) + alive_m = leaf_m + fnrt_m + sapw_m + total_m = alive_m + store_m + struct_m + + + ! number density by size and biomass + hio_agb_si_scls(io_si,scls) = hio_agb_si_scls(io_si,scls) + & + total_m * ccohort%n * prt_params%allom_agb_frac(ccohort%pft) * AREA_INV + + hio_agb_si_scpf(io_si,scpf) = hio_agb_si_scpf(io_si,scpf) + & + total_m * ccohort%n * prt_params%allom_agb_frac(ccohort%pft) * AREA_INV + + hio_biomass_si_scls(io_si,scls) = hio_biomass_si_scls(io_si,scls) + & + total_m * ccohort%n * AREA_INV + + ! update size-class x patch-age related quantities + + iscag = get_sizeage_class_index(ccohort%dbh,cpatch%age) + + hio_nplant_si_scag(io_si,iscag) = hio_nplant_si_scag(io_si,iscag) + ccohort%n / m2_per_ha + + hio_nplant_si_scls(io_si,scls) = hio_nplant_si_scls(io_si,scls) + ccohort%n / m2_per_ha + + + ! update size, age, and PFT - indexed quantities + iscagpft = get_sizeagepft_class_index(ccohort%dbh,cpatch%age,ccohort%pft) + + hio_nplant_si_scagpft(io_si,iscagpft) = hio_nplant_si_scagpft(io_si,iscagpft) + ccohort%n / m2_per_ha + + ! update age and PFT - indexed quantities + iagepft = get_agepft_class_index(cpatch%age,ccohort%pft) + + hio_npp_si_agepft(io_si,iagepft) = hio_npp_si_agepft(io_si,iagepft) + & + ccohort%n * ccohort%npp_acc_hold * AREA_INV / days_per_year / sec_per_day + + hio_biomass_si_agepft(io_si,iagepft) = hio_biomass_si_agepft(io_si,iagepft) + & + total_m * ccohort%n * AREA_INV + + ! update SCPF/SCLS- and canopy/subcanopy- partitioned quantities + canlayer: if (ccohort%canopy_layer .eq. 1) then + hio_nplant_canopy_si_scag(io_si,iscag) = hio_nplant_canopy_si_scag(io_si,iscag) + ccohort%n / m2_per_ha + hio_mortality_canopy_si_scag(io_si,iscag) = hio_mortality_canopy_si_scag(io_si,iscag) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + hio_ddbh_canopy_si_scag(io_si,iscag) = hio_ddbh_canopy_si_scag(io_si,iscag) + & + ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha + hio_bstor_canopy_si_scpf(io_si,scpf) = hio_bstor_canopy_si_scpf(io_si,scpf) + & + store_m * ccohort%n / m2_per_ha + hio_bleaf_canopy_si_scpf(io_si,scpf) = hio_bleaf_canopy_si_scpf(io_si,scpf) + & + leaf_m * ccohort%n / m2_per_ha + + hio_canopy_biomass_si(io_si) = hio_canopy_biomass_si(io_si) + n_perm2 * total_m + + !hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & + ! (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + ! ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + + hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%frmort + & + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & + ccohort%n * sec_per_day * days_per_year / m2_per_ha + + hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + ccohort%n / m2_per_ha + hio_nplant_canopy_si_scls(io_si,scls) = hio_nplant_canopy_si_scls(io_si,scls) + ccohort%n / m2_per_ha + hio_lai_canopy_si_scls(io_si,scls) = hio_lai_canopy_si_scls(io_si,scls) + & + ccohort%treelai*ccohort%c_area * AREA_INV + hio_sai_canopy_si_scls(io_si,scls) = hio_sai_canopy_si_scls(io_si,scls) + & + ccohort%treesai*ccohort%c_area * AREA_INV + hio_trimming_canopy_si_scls(io_si,scls) = hio_trimming_canopy_si_scls(io_si,scls) + & + ccohort%n * ccohort%canopy_trim / m2_per_ha + hio_crown_area_canopy_si_scls(io_si,scls) = hio_crown_area_canopy_si_scls(io_si,scls) + & + ccohort%c_area / m2_per_ha + hio_gpp_canopy_si_scpf(io_si,scpf) = hio_gpp_canopy_si_scpf(io_si,scpf) + & + n_perm2*ccohort%gpp_acc_hold / days_per_year / sec_per_day + hio_ar_canopy_si_scpf(io_si,scpf) = hio_ar_canopy_si_scpf(io_si,scpf) + & + n_perm2*ccohort%resp_acc_hold / days_per_year / sec_per_day + ! growth increment + hio_ddbh_canopy_si_scpf(io_si,scpf) = hio_ddbh_canopy_si_scpf(io_si,scpf) + & + ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha + hio_ddbh_canopy_si_scls(io_si,scls) = hio_ddbh_canopy_si_scls(io_si,scls) + & + ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha + + ! sum of all mortality + hio_mortality_canopy_si_scls(io_si,scls) = hio_mortality_canopy_si_scls(io_si,scls) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & + ccohort%n * sec_per_day * days_per_year / m2_per_ha + + hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + ccohort%frmort + ccohort%smort + ccohort%asmort) * & + total_m * ccohort%n * days_per_sec * years_per_day * ha_per_m2 + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_m * & + ccohort%n * ha_per_m2 + + + hio_carbon_balance_canopy_si_scls(io_si,scls) = hio_carbon_balance_canopy_si_scls(io_si,scls) + & + ccohort%n * ccohort%npp_acc_hold / m2_per_ha / days_per_year / sec_per_day + + hio_leaf_md_canopy_si_scls(io_si,scls) = hio_leaf_md_canopy_si_scls(io_si,scls) + & + leaf_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_root_md_canopy_si_scls(io_si,scls) = hio_root_md_canopy_si_scls(io_si,scls) + & + fnrt_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_bsw_md_canopy_si_scls(io_si,scls) = hio_bsw_md_canopy_si_scls(io_si,scls) + & + sapw_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_bstore_md_canopy_si_scls(io_si,scls) = hio_bstore_md_canopy_si_scls(io_si,scls) + & + store_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_bdead_md_canopy_si_scls(io_si,scls) = hio_bdead_md_canopy_si_scls(io_si,scls) + & + struct_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_seed_prod_canopy_si_scls(io_si,scls) = hio_seed_prod_canopy_si_scls(io_si,scls) + & + ccohort%seed_prod * ccohort%n / m2_per_ha / days_per_year / sec_per_day + + hio_npp_leaf_canopy_si_scls(io_si,scls) = hio_npp_leaf_canopy_si_scls(io_si,scls) + & + leaf_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_fnrt_canopy_si_scls(io_si,scls) = hio_npp_fnrt_canopy_si_scls(io_si,scls) + & + fnrt_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_sapw_canopy_si_scls(io_si,scls) = hio_npp_sapw_canopy_si_scls(io_si,scls) + & + sapw_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_dead_canopy_si_scls(io_si,scls) = hio_npp_dead_canopy_si_scls(io_si,scls) + & + struct_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_seed_canopy_si_scls(io_si,scls) = hio_npp_seed_canopy_si_scls(io_si,scls) + & + repro_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_stor_canopy_si_scls(io_si,scls) = hio_npp_stor_canopy_si_scls(io_si,scls) + & + store_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + + hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) = & + hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) + & + ccohort%canopy_layer_yesterday * ccohort%n / m2_per_ha + else canlayer + hio_nplant_understory_si_scag(io_si,iscag) = hio_nplant_understory_si_scag(io_si,iscag) + ccohort%n / m2_per_ha + hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + hio_ddbh_understory_si_scag(io_si,iscag) = hio_ddbh_understory_si_scag(io_si,iscag) + & + ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha + hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & + store_m * ccohort%n / m2_per_ha + hio_bleaf_understory_si_scpf(io_si,scpf) = hio_bleaf_understory_si_scpf(io_si,scpf) + & + leaf_m * ccohort%n / m2_per_ha + hio_understory_biomass_si(io_si) = hio_understory_biomass_si(io_si) + & + n_perm2 * total_m + + !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 + + 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 / m2_per_ha + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & + ccohort%n * sec_per_day * days_per_year / m2_per_ha + + hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + ccohort%n / m2_per_ha + hio_nplant_understory_si_scls(io_si,scls) = hio_nplant_understory_si_scls(io_si,scls) + ccohort%n / m2_per_ha + hio_lai_understory_si_scls(io_si,scls) = hio_lai_understory_si_scls(io_si,scls) + & + ccohort%treelai*ccohort%c_area * AREA_INV + hio_sai_understory_si_scls(io_si,scls) = hio_sai_understory_si_scls(io_si,scls) + & + ccohort%treelai*ccohort%c_area * AREA_INV + hio_trimming_understory_si_scls(io_si,scls) = hio_trimming_understory_si_scls(io_si,scls) + & + ccohort%n * ccohort%canopy_trim / m2_per_ha + hio_crown_area_understory_si_scls(io_si,scls) = hio_crown_area_understory_si_scls(io_si,scls) + & + ccohort%c_area / m2_per_ha + hio_gpp_understory_si_scpf(io_si,scpf) = hio_gpp_understory_si_scpf(io_si,scpf) + & + n_perm2*ccohort%gpp_acc_hold / days_per_year / sec_per_day + hio_ar_understory_si_scpf(io_si,scpf) = hio_ar_understory_si_scpf(io_si,scpf) + & + n_perm2*ccohort%resp_acc_hold / days_per_year / sec_per_day + + ! growth increment + hio_ddbh_understory_si_scpf(io_si,scpf) = hio_ddbh_understory_si_scpf(io_si,scpf) + & + ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha + hio_ddbh_understory_si_scls(io_si,scls) = hio_ddbh_understory_si_scls(io_si,scls) + & + ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha + + ! sum of all mortality + hio_mortality_understory_si_scls(io_si,scls) = hio_mortality_understory_si_scls(io_si,scls) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & + ccohort%n * sec_per_day * days_per_year / m2_per_ha + + hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + ccohort%frmort + ccohort%smort + ccohort%asmort) * & + total_m * ccohort%n * days_per_sec * years_per_day * ha_per_m2 + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_m * & + ccohort%n * ha_per_m2 + + hio_carbon_balance_understory_si_scls(io_si,scls) = hio_carbon_balance_understory_si_scls(io_si,scls) + & + ccohort%npp_acc_hold * ccohort%n / m2_per_ha / days_per_year / sec_per_day + + hio_leaf_md_understory_si_scls(io_si,scls) = hio_leaf_md_understory_si_scls(io_si,scls) + & + leaf_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_root_md_understory_si_scls(io_si,scls) = hio_root_md_understory_si_scls(io_si,scls) + & + fnrt_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_bsw_md_understory_si_scls(io_si,scls) = hio_bsw_md_understory_si_scls(io_si,scls) + & + sapw_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_bstore_md_understory_si_scls(io_si,scls) = hio_bstore_md_understory_si_scls(io_si,scls) + & + store_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_bdead_md_understory_si_scls(io_si,scls) = hio_bdead_md_understory_si_scls(io_si,scls) + & + struct_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_seed_prod_understory_si_scls(io_si,scls) = hio_seed_prod_understory_si_scls(io_si,scls) + & + ccohort%seed_prod * ccohort%n / m2_per_ha / days_per_year / sec_per_day + + hio_npp_leaf_understory_si_scls(io_si,scls) = hio_npp_leaf_understory_si_scls(io_si,scls) + & + leaf_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_fnrt_understory_si_scls(io_si,scls) = hio_npp_fnrt_understory_si_scls(io_si,scls) + & + fnrt_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_sapw_understory_si_scls(io_si,scls) = hio_npp_sapw_understory_si_scls(io_si,scls) + & + sapw_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_dead_understory_si_scls(io_si,scls) = hio_npp_dead_understory_si_scls(io_si,scls) + & + struct_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_seed_understory_si_scls(io_si,scls) = hio_npp_seed_understory_si_scls(io_si,scls) + & + repro_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_stor_understory_si_scls(io_si,scls) = hio_npp_stor_understory_si_scls(io_si,scls) + & + store_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + + hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) = & + hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) + & + ccohort%canopy_layer_yesterday * ccohort%n / m2_per_ha + endif canlayer ! - hio_crownarea_si_can(io_si, ican) = hio_crownarea_si_can(io_si, ican) + ccohort%c_area / AREA ! - do ileaf=1,ccohort%nv - cnlf_indx = ileaf + (ican-1) * nlevleaf - hio_crownarea_si_cnlf(io_si, cnlf_indx) = hio_crownarea_si_cnlf(io_si, cnlf_indx) + & - ccohort%c_area / AREA - end do - - ccohort => ccohort%taller - enddo ! cohort loop - - ! 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 - - ! Update Fire Variables - hio_spitfire_ros_si(io_si) = hio_spitfire_ros_si(io_si) + cpatch%ROS_front * cpatch%area * AREA_INV / sec_per_min - hio_effect_wspeed_si(io_si) = hio_effect_wspeed_si(io_si) + cpatch%effect_wspeed * cpatch%area * AREA_INV / sec_per_min - hio_tfc_ros_si(io_si) = hio_tfc_ros_si(io_si) + cpatch%TFC_ROS * cpatch%area * AREA_INV - hio_fire_intensity_si(io_si) = hio_fire_intensity_si(io_si) + cpatch%FI * cpatch%area * AREA_INV * J_per_kJ - hio_fire_area_si(io_si) = hio_fire_area_si(io_si) + cpatch%frac_burnt * cpatch%area * AREA_INV / sec_per_day - 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 / m_per_cm - 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 * cpatch%area * AREA_INV - - do ilyr = 1,sites(s)%nlevsoil - hio_fragmentation_scaler_sl(io_si,ilyr) = hio_fragmentation_scaler_sl(io_si,ilyr) + cpatch%fragmentation_scaler(ilyr) * cpatch%area * AREA_INV - end do - - do i_fuel = 1,nfsc - - i_agefuel = get_agefuel_class_index(cpatch%age,i_fuel) - hio_fuel_amount_age_fuel(io_si,i_agefuel) = hio_fuel_amount_age_fuel(io_si,i_agefuel) + & - cpatch%fuel_frac(i_fuel) * cpatch%sum_fuel * cpatch%area * AREA_INV - - 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_fuel_amount_si_fuel(io_si, i_fuel) = hio_fuel_amount_si_fuel(io_si, i_fuel) + & - cpatch%fuel_frac(i_fuel) * cpatch%sum_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 * J_per_kJ - - ! Update Litter Flux Variables - - litt_c => cpatch%litter(element_pos(carbon12_element)) - flux_diags_c => sites(s)%flux_diags(element_pos(carbon12_element)) - - do i_cwd = 1, ncwd - - hio_cwd_ag_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_si_cwdsc(io_si, i_cwd) + & - litt_c%ag_cwd(i_cwd)*cpatch%area * AREA_INV - hio_cwd_bg_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_si_cwdsc(io_si, i_cwd) + & - sum(litt_c%bg_cwd(i_cwd,:)) * cpatch%area * AREA_INV - - hio_cwd_ag_out_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_out_si_cwdsc(io_si, i_cwd) + & - litt_c%ag_cwd_frag(i_cwd)*cpatch%area * AREA_INV / & - days_per_year / sec_per_day - - hio_cwd_bg_out_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_out_si_cwdsc(io_si, i_cwd) + & - sum(litt_c%bg_cwd_frag(i_cwd,:)) * cpatch%area * AREA_INV / & - days_per_year / sec_per_day + ccohort%canopy_layer_yesterday = real(ccohort%canopy_layer, r8) + ! + ! growth flux of individuals into a given bin + ! track the actual growth here, the virtual growth from fusion lower down + if ( (scls - ccohort%size_class_lasttimestep ) .gt. 0) then + do i_scls = ccohort%size_class_lasttimestep + 1, scls + i_scpf = (ccohort%pft-1)*nlevsclass+i_scls + hio_growthflux_si_scpf(io_si,i_scpf) = hio_growthflux_si_scpf(io_si,i_scpf) + & + ccohort%n * days_per_year / m2_per_ha + end do + end if + ccohort%size_class_lasttimestep = scls + end associate + else notnew ! i.e. cohort%isnew + ! + ! if cohort is new, track its growth flux into the first size bin + i_scpf = (ccohort%pft-1)*nlevsclass+1 + hio_growthflux_si_scpf(io_si,i_scpf) = & + hio_growthflux_si_scpf(io_si,i_scpf) + ccohort%n * & + days_per_year / m2_per_ha + ccohort%size_class_lasttimestep = 1 + + end if notnew + + ! resolve some canopy area profiles, both total and of occupied leaves + ican = ccohort%canopy_layer + ! + hio_crownarea_si_can(io_si, ican) = hio_crownarea_si_can(io_si, ican) + ccohort%c_area / AREA + ! + do ileaf=1,ccohort%nv + cnlf_indx = ileaf + (ican-1) * nlevleaf + hio_crownarea_si_cnlf(io_si, cnlf_indx) = hio_crownarea_si_cnlf(io_si, cnlf_indx) + & + ccohort%c_area / AREA end do - ipa = ipa + 1 - cpatch => cpatch%younger - end do !patch loop - - ! divide so-far-just-summed but to-be-averaged patch-age-class variables by patch-age-class area to get mean values - do ipa2 = 1, nlevage - if (hio_area_si_age(io_si, ipa2) .gt. tiny) then - hio_lai_si_age(io_si, ipa2) = hio_lai_si_age(io_si, ipa2) / (hio_area_si_age(io_si, ipa2)*AREA) - hio_ncl_si_age(io_si, ipa2) = hio_ncl_si_age(io_si, ipa2) / (hio_area_si_age(io_si, ipa2)*AREA) - do i_pft = 1, numpft - iagepft = ipa2 + (i_pft-1) * nlevage - hio_scorch_height_si_agepft(io_si, iagepft) = & - hio_scorch_height_si_agepft(io_si, iagepft) / (hio_area_si_age(io_si, ipa2)*AREA) - enddo - else - hio_lai_si_age(io_si, ipa2) = 0._r8 - hio_ncl_si_age(io_si, ipa2) = 0._r8 - endif - + ccohort => ccohort%taller + enddo cohortloop ! cohort loop + + ! 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 + + ! Update Fire Variables + hio_spitfire_ros_si(io_si) = hio_spitfire_ros_si(io_si) + cpatch%ROS_front * cpatch%area * AREA_INV / sec_per_min + hio_effect_wspeed_si(io_si) = hio_effect_wspeed_si(io_si) + cpatch%effect_wspeed * cpatch%area * AREA_INV / sec_per_min + hio_tfc_ros_si(io_si) = hio_tfc_ros_si(io_si) + cpatch%TFC_ROS * cpatch%area * AREA_INV + hio_fire_intensity_si(io_si) = hio_fire_intensity_si(io_si) + cpatch%FI * cpatch%area * AREA_INV * J_per_kJ + hio_fire_area_si(io_si) = hio_fire_area_si(io_si) + cpatch%frac_burnt * cpatch%area * AREA_INV / sec_per_day + 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 / m_per_cm + 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 * cpatch%area * AREA_INV + + do ilyr = 1,sites(s)%nlevsoil + hio_fragmentation_scaler_sl(io_si,ilyr) = hio_fragmentation_scaler_sl(io_si,ilyr) + cpatch%fragmentation_scaler(ilyr) * cpatch%area * AREA_INV end do - ! pass the cohort termination mortality as a flux to the history, and then reset the termination mortality buffer - ! note there are various ways of reporting the total mortality, so pass to these as well - do i_pft = 1, numpft - do i_scls = 1,nlevsclass - i_scpf = (i_pft-1)*nlevsclass + i_scls - ! - ! termination mortality. sum of canopy and understory indices - hio_m6_si_scpf(io_si,i_scpf) = (sites(s)%term_nindivs_canopy(i_scls,i_pft) + & - sites(s)%term_nindivs_ustory(i_scls,i_pft)) * & - days_per_year / m2_per_ha - - hio_m6_si_scls(io_si,i_scls) = hio_m6_si_scls(io_si,i_scls) + & - (sites(s)%term_nindivs_canopy(i_scls,i_pft) + & - sites(s)%term_nindivs_ustory(i_scls,i_pft)) * & - days_per_year / m2_per_ha + do i_fuel = 1,nfsc + i_agefuel = get_agefuel_class_index(cpatch%age,i_fuel) + hio_fuel_amount_age_fuel(io_si,i_agefuel) = hio_fuel_amount_age_fuel(io_si,i_agefuel) + & + cpatch%fuel_frac(i_fuel) * cpatch%sum_fuel * cpatch%area * AREA_INV - ! - ! add termination mortality to canopy and understory mortality - hio_mortality_canopy_si_scls(io_si,i_scls) = hio_mortality_canopy_si_scls(io_si,i_scls) + & - sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year / m2_per_ha - - hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & - sites(s)%term_nindivs_ustory(i_scls,i_pft) * days_per_year / m2_per_ha - - hio_mortality_canopy_si_scpf(io_si,i_scpf) = hio_mortality_canopy_si_scpf(io_si,i_scpf) + & - sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year / m2_per_ha + 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_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & - sites(s)%term_nindivs_ustory(i_scls,i_pft) * days_per_year / m2_per_ha + hio_fuel_amount_si_fuel(io_si, i_fuel) = hio_fuel_amount_si_fuel(io_si, i_fuel) + & + cpatch%fuel_frac(i_fuel) * cpatch%sum_fuel * cpatch%area * AREA_INV - ! - ! imort on its own - hio_m4_si_scpf(io_si,i_scpf) = sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha - hio_m4_si_scls(io_si,i_scls) = hio_m4_si_scls(io_si,i_scls) + sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha - ! - ! add imort to other mortality terms. consider imort as understory mortality even if it happens in - ! cohorts that may have been promoted as part of the patch creation, and use the pre-calculated site-level - ! values to avoid biasing the results by the dramatically-reduced number densities in cohorts that are subject to imort - hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & - sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha - hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & - sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha - ! - iscag = i_scls ! since imort is by definition something that only happens in newly disturbed patches, treat as such - hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & - sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha - - ! fire mortality from the site-level diagnostic rates - hio_m5_si_scpf(io_si,i_scpf) = (sites(s)%fmort_rate_canopy(i_scls, i_pft) + & - sites(s)%fmort_rate_ustory(i_scls, i_pft)) / m2_per_ha - hio_m5_si_scls(io_si,i_scls) = hio_m5_si_scls(io_si,i_scls) + & - (sites(s)%fmort_rate_canopy(i_scls, i_pft) + & - sites(s)%fmort_rate_ustory(i_scls, i_pft)) / m2_per_ha - ! - hio_crownfiremort_si_scpf(io_si,i_scpf) = sites(s)%fmort_rate_crown(i_scls, i_pft) / m2_per_ha - hio_cambialfiremort_si_scpf(io_si,i_scpf) = sites(s)%fmort_rate_cambial(i_scls, i_pft) / m2_per_ha - ! - ! fire components of overall canopy and understory mortality - hio_mortality_canopy_si_scpf(io_si,i_scpf) = hio_mortality_canopy_si_scpf(io_si,i_scpf) + & - sites(s)%fmort_rate_canopy(i_scls, i_pft) / m2_per_ha - hio_mortality_canopy_si_scls(io_si,i_scls) = hio_mortality_canopy_si_scls(io_si,i_scls) + & - sites(s)%fmort_rate_canopy(i_scls, i_pft) / m2_per_ha + 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 - ! the fire mortality rates for each layer are total dead, since the usable - ! output will then normalize by the counts, we are allowed to sum over layers - hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & - sites(s)%fmort_rate_ustory(i_scls, i_pft) / m2_per_ha - hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & - sites(s)%fmort_rate_ustory(i_scls, i_pft) / m2_per_ha + 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 * J_per_kJ - ! - ! carbon flux associated with mortality of trees dying by fire - hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & - sites(s)%fmort_carbonflux_canopy / g_per_kg + ! Update Litter Flux Variables - hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & - sites(s)%fmort_carbonflux_ustory / g_per_kg + litt_c => cpatch%litter(element_pos(carbon12_element)) + flux_diags_c => sites(s)%flux_diags(element_pos(carbon12_element)) - ! - ! for scag variables, also treat as happening in the newly-disurbed patch + do i_cwd = 1, ncwd - hio_mortality_canopy_si_scag(io_si,iscag) = hio_mortality_canopy_si_scag(io_si,iscag) + & - sites(s)%fmort_rate_canopy(i_scls, i_pft) / m2_per_ha - hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & - sites(s)%fmort_rate_ustory(i_scls, i_pft) / m2_per_ha + hio_cwd_ag_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_si_cwdsc(io_si, i_cwd) + & + litt_c%ag_cwd(i_cwd)*cpatch%area * AREA_INV + hio_cwd_bg_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_si_cwdsc(io_si, i_cwd) + & + sum(litt_c%bg_cwd(i_cwd,:)) * cpatch%area * AREA_INV - ! while in this loop, pass the fusion-induced growth rate flux to history - hio_growthflux_fusion_si_scpf(io_si,i_scpf) = hio_growthflux_fusion_si_scpf(io_si,i_scpf) + & - sites(s)%growthflux_fusion(i_scls, i_pft) * days_per_year / m2_per_ha + hio_cwd_ag_out_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_out_si_cwdsc(io_si, i_cwd) + & + litt_c%ag_cwd_frag(i_cwd)*cpatch%area * AREA_INV / & + days_per_year / sec_per_day + hio_cwd_bg_out_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_out_si_cwdsc(io_si, i_cwd) + & + sum(litt_c%bg_cwd_frag(i_cwd,:)) * cpatch%area * AREA_INV / & + days_per_year / sec_per_day + end do + ipa = ipa + 1 + cpatch => cpatch%younger + end do patchloop !patch loop + ! divide so-far-just-summed but to-be-averaged patch-age-class variables by patch-age-class area to get mean values + do ipa2 = 1, nlevage + if (hio_area_si_age(io_si, ipa2) .gt. tiny) then + hio_lai_si_age(io_si, ipa2) = hio_lai_si_age(io_si, ipa2) / (hio_area_si_age(io_si, ipa2)*AREA) + hio_ncl_si_age(io_si, ipa2) = hio_ncl_si_age(io_si, ipa2) / (hio_area_si_age(io_si, ipa2)*AREA) + do i_pft = 1, numpft + iagepft = ipa2 + (i_pft-1) * nlevage + hio_scorch_height_si_agepft(io_si, iagepft) = & + hio_scorch_height_si_agepft(io_si, iagepft) / (hio_area_si_age(io_si, ipa2)*AREA) + enddo + else + hio_lai_si_age(io_si, ipa2) = 0._r8 + hio_ncl_si_age(io_si, ipa2) = 0._r8 + endif + end do + + ! pass the cohort termination mortality as a flux to the history, and then reset the termination mortality buffer + ! note there are various ways of reporting the total mortality, so pass to these as well + do i_pft = 1, numpft + do i_scls = 1,nlevsclass + i_scpf = (i_pft-1)*nlevsclass + i_scls + ! + ! termination mortality. sum of canopy and understory indices + hio_m6_si_scpf(io_si,i_scpf) = (sites(s)%term_nindivs_canopy(i_scls,i_pft) + & + sites(s)%term_nindivs_ustory(i_scls,i_pft)) * & + days_per_year / m2_per_ha + + hio_m6_si_scls(io_si,i_scls) = hio_m6_si_scls(io_si,i_scls) + & + (sites(s)%term_nindivs_canopy(i_scls,i_pft) + & + sites(s)%term_nindivs_ustory(i_scls,i_pft)) * & + days_per_year / m2_per_ha + ! + ! add termination mortality to canopy and understory mortality + hio_mortality_canopy_si_scls(io_si,i_scls) = hio_mortality_canopy_si_scls(io_si,i_scls) + & + sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year / m2_per_ha + + hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & + sites(s)%term_nindivs_ustory(i_scls,i_pft) * days_per_year / m2_per_ha + + hio_mortality_canopy_si_scpf(io_si,i_scpf) = hio_mortality_canopy_si_scpf(io_si,i_scpf) + & + sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year / m2_per_ha + + hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & + sites(s)%term_nindivs_ustory(i_scls,i_pft) * days_per_year / m2_per_ha + + ! + ! imort on its own + hio_m4_si_scpf(io_si,i_scpf) = sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha + hio_m4_si_scls(io_si,i_scls) = hio_m4_si_scls(io_si,i_scls) + sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha + ! + ! add imort to other mortality terms. consider imort as understory mortality even if it happens in + ! cohorts that may have been promoted as part of the patch creation, and use the pre-calculated site-level + ! values to avoid biasing the results by the dramatically-reduced number densities in cohorts that are subject to imort + hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & + sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha + hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & + sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha + ! + iscag = i_scls ! since imort is by definition something that only happens in newly disturbed patches, treat as such + hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & + sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha + + ! fire mortality from the site-level diagnostic rates + hio_m5_si_scpf(io_si,i_scpf) = (sites(s)%fmort_rate_canopy(i_scls, i_pft) + & + sites(s)%fmort_rate_ustory(i_scls, i_pft)) / m2_per_ha + hio_m5_si_scls(io_si,i_scls) = hio_m5_si_scls(io_si,i_scls) + & + (sites(s)%fmort_rate_canopy(i_scls, i_pft) + & + sites(s)%fmort_rate_ustory(i_scls, i_pft)) / m2_per_ha + ! + hio_crownfiremort_si_scpf(io_si,i_scpf) = sites(s)%fmort_rate_crown(i_scls, i_pft) / m2_per_ha + hio_cambialfiremort_si_scpf(io_si,i_scpf) = sites(s)%fmort_rate_cambial(i_scls, i_pft) / m2_per_ha + ! + ! fire components of overall canopy and understory mortality + hio_mortality_canopy_si_scpf(io_si,i_scpf) = hio_mortality_canopy_si_scpf(io_si,i_scpf) + & + sites(s)%fmort_rate_canopy(i_scls, i_pft) / m2_per_ha + hio_mortality_canopy_si_scls(io_si,i_scls) = hio_mortality_canopy_si_scls(io_si,i_scls) + & + sites(s)%fmort_rate_canopy(i_scls, i_pft) / m2_per_ha + + ! the fire mortality rates for each layer are total dead, since the usable + ! output will then normalize by the counts, we are allowed to sum over layers + hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & + sites(s)%fmort_rate_ustory(i_scls, i_pft) / m2_per_ha + + hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & + sites(s)%fmort_rate_ustory(i_scls, i_pft) / m2_per_ha + + ! + ! carbon flux associated with mortality of trees dying by fire + hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & + sites(s)%fmort_carbonflux_canopy / g_per_kg + + hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & + sites(s)%fmort_carbonflux_ustory / g_per_kg + + ! + ! for scag variables, also treat as happening in the newly-disurbed patch + + hio_mortality_canopy_si_scag(io_si,iscag) = hio_mortality_canopy_si_scag(io_si,iscag) + & + sites(s)%fmort_rate_canopy(i_scls, i_pft) / m2_per_ha + hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & + sites(s)%fmort_rate_ustory(i_scls, i_pft) / m2_per_ha + + ! while in this loop, pass the fusion-induced growth rate flux to history + hio_growthflux_fusion_si_scpf(io_si,i_scpf) = hio_growthflux_fusion_si_scpf(io_si,i_scpf) + & + sites(s)%growthflux_fusion(i_scls, i_pft) * days_per_year / m2_per_ha - end do - end do - ! - - ! treat carbon flux from imort the same way - hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & - sites(s)%imort_carbonflux / g_per_kg - ! - sites(s)%term_nindivs_canopy(:,:) = 0._r8 - sites(s)%term_nindivs_ustory(:,:) = 0._r8 - sites(s)%imort_carbonflux = 0._r8 - sites(s)%imort_rate(:,:) = 0._r8 - sites(s)%fmort_rate_canopy(:,:) = 0._r8 - sites(s)%fmort_rate_ustory(:,:) = 0._r8 - sites(s)%fmort_carbonflux_canopy = 0._r8 - sites(s)%fmort_carbonflux_ustory = 0._r8 - sites(s)%fmort_rate_cambial(:,:) = 0._r8 - sites(s)%fmort_rate_crown(:,:) = 0._r8 - sites(s)%growthflux_fusion(:,:) = 0._r8 - - ! pass the recruitment rate as a flux to the history, and then reset the recruitment buffer - do i_pft = 1, numpft - hio_recruitment_si_pft(io_si,i_pft) = sites(s)%recruitment_rate(i_pft) * days_per_year / m2_per_ha end do - sites(s)%recruitment_rate(:) = 0._r8 - - hio_mortality_si_pft(io_si,:) = 0.0_r8 - ! summarize all of the mortality fluxes by PFT - do i_pft = 1, numpft - do i_scls = 1,nlevsclass - i_scpf = (i_pft-1)*nlevsclass + i_scls - - hio_mortality_si_pft(io_si,i_pft) = (hio_mortality_si_pft(io_si,i_pft) + & - hio_m1_si_scpf(io_si,i_scpf) + & - hio_m2_si_scpf(io_si,i_scpf) + & - hio_m3_si_scpf(io_si,i_scpf) + & - hio_m4_si_scpf(io_si,i_scpf) + & - hio_m5_si_scpf(io_si,i_scpf) + & - hio_m6_si_scpf(io_si,i_scpf) + & - hio_m7_si_scpf(io_si,i_scpf) + & - hio_m8_si_scpf(io_si,i_scpf) + & - hio_m9_si_scpf(io_si,i_scpf) + & - hio_m10_si_scpf(io_si,i_scpf)) + end do + + ! treat carbon flux from imort the same way + hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & + sites(s)%imort_carbonflux / g_per_kg + ! + sites(s)%term_nindivs_canopy(:,:) = 0._r8 + sites(s)%term_nindivs_ustory(:,:) = 0._r8 + sites(s)%imort_carbonflux = 0._r8 + sites(s)%imort_rate(:,:) = 0._r8 + sites(s)%fmort_rate_canopy(:,:) = 0._r8 + sites(s)%fmort_rate_ustory(:,:) = 0._r8 + sites(s)%fmort_carbonflux_canopy = 0._r8 + sites(s)%fmort_carbonflux_ustory = 0._r8 + sites(s)%fmort_rate_cambial(:,:) = 0._r8 + sites(s)%fmort_rate_crown(:,:) = 0._r8 + sites(s)%growthflux_fusion(:,:) = 0._r8 + + ! pass the recruitment rate as a flux to the history, and then reset the recruitment buffer + do i_pft = 1, numpft + hio_recruitment_si_pft(io_si,i_pft) = sites(s)%recruitment_rate(i_pft) * days_per_year / m2_per_ha + end do + sites(s)%recruitment_rate(:) = 0._r8 + + ! summarize all of the mortality fluxes by PFT + do i_pft = 1, numpft + do i_scls = 1,nlevsclass + i_scpf = (i_pft-1)*nlevsclass + i_scls + + hio_mortality_si_pft(io_si,i_pft) = hio_mortality_si_pft(io_si,i_pft) + & + hio_m1_si_scpf(io_si,i_scpf) + & + hio_m2_si_scpf(io_si,i_scpf) + & + hio_m3_si_scpf(io_si,i_scpf) + & + hio_m4_si_scpf(io_si,i_scpf) + & + hio_m5_si_scpf(io_si,i_scpf) + & + hio_m6_si_scpf(io_si,i_scpf) + & + hio_m7_si_scpf(io_si,i_scpf) + & + hio_m8_si_scpf(io_si,i_scpf) + & + hio_m9_si_scpf(io_si,i_scpf) + & + hio_m10_si_scpf(io_si,i_scpf) - end do end do + end do + + ! ------------------------------------------------------------------------------ + ! Some carbon only litter diagnostics (legacy) + ! ------------------------------------------------------------------------------ + + flux_diags => sites(s)%flux_diags(element_pos(carbon12_element)) + + hio_litter_in_si(io_si) = (sum(flux_diags%cwd_ag_input(:)) + & + sum(flux_diags%cwd_bg_input(:)) + & + sum(flux_diags%leaf_litter_input(:)) + & + sum(flux_diags%root_litter_input(:))) * & + AREA_INV * days_per_sec + + hio_litter_out_si(io_si) = 0._r8 + hio_seed_bank_si(io_si) = 0._r8 + hio_seeds_in_si(io_si) = 0._r8 + + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + + litt => cpatch%litter(element_pos(carbon12_element)) + + area_frac = cpatch%area * AREA_INV + + ! Sum up all output fluxes (fragmentation) kgC/m2/day -> gC/m2/s + hio_litter_out_si(io_si) = hio_litter_out_si(io_si) + & + (sum(litt%leaf_fines_frag(:)) + & + sum(litt%root_fines_frag(:,:)) + & + sum(litt%ag_cwd_frag(:)) + & + sum(litt%bg_cwd_frag(:,:))) * & + area_frac * days_per_sec + + ! Sum up total seed bank (germinated and ungerminated) + hio_seed_bank_si(io_si) = hio_seed_bank_si(io_si) + & + (sum(litt%seed(:))+sum(litt%seed_germ(:))) * & + area_frac * days_per_sec + + ! Sum up the input flux into the seed bank (local and external) + hio_seeds_in_si(io_si) = hio_seeds_in_si(io_si) + & + (sum(litt%seed_in_local(:)) + sum(litt%seed_in_extern(:))) * & + area_frac * days_per_sec + + cpatch => cpatch%younger + end do + + ! ------------------------------------------------------------------------------ + ! Diagnostics discretized by element type + ! ------------------------------------------------------------------------------ + + hio_cwd_elcwd(io_si,:) = 0._r8 + + do el = 1, num_elements + + flux_diags => sites(s)%flux_diags(el) + + ! Sum up all input litter fluxes (above below, fines, cwd) [kg/ha/day] + hio_litter_in_elem(io_si, el) = (sum(flux_diags%cwd_ag_input(:)) + & + sum(flux_diags%cwd_bg_input(:)) + sum(flux_diags%leaf_litter_input(:)) + & + sum(flux_diags%root_litter_input(:))) / m2_per_ha / sec_per_day + + hio_cwd_ag_elem(io_si,el) = 0._r8 + hio_cwd_bg_elem(io_si,el) = 0._r8 + hio_fines_ag_elem(io_si,el) = 0._r8 + hio_fines_bg_elem(io_si,el) = 0._r8 + + hio_seed_bank_elem(io_si,el) = 0._r8 + hio_seed_germ_elem(io_si,el) = 0._r8 + hio_seed_decay_elem(io_si,el) = 0._r8 + hio_seeds_in_local_elem(io_si,el) = 0._r8 + hio_seed_in_extern_elem(io_si,el) = 0._r8 + hio_litter_out_elem(io_si,el) = 0._r8 + + ! Plant multi-element states and fluxes + ! Zero states, and set the fluxes + if(element_list(el).eq.carbon12_element)then + this%hvars(ih_totvegc_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_leafc_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_fnrtc_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_sapwc_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storec_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_reproc_scpf)%r82d(io_si,:) = 0._r8 + + this%hvars(ih_cefflux_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) / & + m2_per_ha / sec_per_day + + this%hvars(ih_cefflux_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) / & + m2_per_ha / sec_per_day + + elseif(element_list(el).eq.nitrogen_element)then + + this%hvars(ih_totvegn_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_leafn_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_fnrtn_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_sapwn_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storen_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_repron_scpf)%r82d(io_si,:) = 0._r8 + + this%hvars(ih_nefflux_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) / & + m2_per_ha / sec_per_day + + this%hvars(ih_nneed_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_need_scpf(:) / & + m2_per_ha / sec_per_day + + this%hvars(ih_nneed_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_need_scpf(:),dim=1) / & + m2_per_ha / sec_per_day + + this%hvars(ih_nefflux_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) / & + m2_per_ha / sec_per_day + + + elseif(element_list(el).eq.phosphorus_element)then + this%hvars(ih_totvegp_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_leafp_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_fnrtp_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_sapwp_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storep_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_reprop_scpf)%r82d(io_si,:) = 0._r8 + + this%hvars(ih_pefflux_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) / & + m2_per_ha / sec_per_day + + this%hvars(ih_pneed_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_need_scpf(:) / & + m2_per_ha / sec_per_day + + this%hvars(ih_pneed_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_need_scpf(:),dim=1) / & + m2_per_ha / sec_per_day + + this%hvars(ih_pefflux_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) / & + m2_per_ha / sec_per_day - ! ------------------------------------------------------------------------------ - ! Some carbon only litter diagnostics (legacy) - ! ------------------------------------------------------------------------------ - - flux_diags => sites(s)%flux_diags(element_pos(carbon12_element)) - - hio_litter_in_si(io_si) = (sum(flux_diags%cwd_ag_input(:)) + & - sum(flux_diags%cwd_bg_input(:)) + & - sum(flux_diags%leaf_litter_input(:)) + & - sum(flux_diags%root_litter_input(:))) * & - AREA_INV * days_per_sec - - hio_litter_out_si(io_si) = 0._r8 - hio_seed_bank_si(io_si) = 0._r8 - hio_seeds_in_si(io_si) = 0._r8 + end if cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - litt => cpatch%litter(element_pos(carbon12_element)) + litt => cpatch%litter(el) area_frac = cpatch%area * AREA_INV - ! Sum up all output fluxes (fragmentation) kgC/m2/day -> gC/m2/s - hio_litter_out_si(io_si) = hio_litter_out_si(io_si) + & - (sum(litt%leaf_fines_frag(:)) + & - sum(litt%root_fines_frag(:,:)) + & - sum(litt%ag_cwd_frag(:)) + & - sum(litt%bg_cwd_frag(:,:))) * & - area_frac * days_per_sec - - ! Sum up total seed bank (germinated and ungerminated) - hio_seed_bank_si(io_si) = hio_seed_bank_si(io_si) + & - (sum(litt%seed(:))+sum(litt%seed_germ(:))) * & - area_frac * days_per_sec + ! Sum up all output fluxes (fragmentation) + hio_litter_out_elem(io_si,el) = hio_litter_out_elem(io_si,el) + & + (sum(litt%leaf_fines_frag(:)) + & + sum(litt%root_fines_frag(:,:)) + & + sum(litt%ag_cwd_frag(:)) + & + sum(litt%bg_cwd_frag(:,:)) + & + sum(litt%seed_decay(:)) + & + sum(litt%seed_germ_decay(:))) * cpatch%area / m2_per_ha / sec_per_day - ! Sum up the input flux into the seed bank (local and external) - hio_seeds_in_si(io_si) = hio_seeds_in_si(io_si) + & - (sum(litt%seed_in_local(:)) + sum(litt%seed_in_extern(:))) * & - area_frac * days_per_sec - - cpatch => cpatch%younger - end do + hio_seed_bank_elem(io_si,el) = hio_seed_bank_elem(io_si,el) + & + sum(litt%seed(:)) * cpatch%area / m2_per_ha + hio_seed_germ_elem(io_si,el) = hio_seed_germ_elem(io_si,el) + & + sum(litt%seed_germ(:)) * cpatch%area / m2_per_ha / sec_per_day - ! ------------------------------------------------------------------------------ - ! Diagnostics discretized by element type - ! ------------------------------------------------------------------------------ - - hio_cwd_elcwd(io_si,:) = 0._r8 - - do el = 1, num_elements - - flux_diags => sites(s)%flux_diags(el) - - ! Sum up all input litter fluxes (above below, fines, cwd) [kg/ha/day] - hio_litter_in_elem(io_si, el) = & - (sum(flux_diags%cwd_ag_input(:)) + & - sum(flux_diags%cwd_bg_input(:)) + & - sum(flux_diags%leaf_litter_input(:)) + & - sum(flux_diags%root_litter_input(:))) / m2_per_ha / sec_per_day - - hio_cwd_ag_elem(io_si,el) = 0._r8 - hio_cwd_bg_elem(io_si,el) = 0._r8 - hio_fines_ag_elem(io_si,el) = 0._r8 - hio_fines_bg_elem(io_si,el) = 0._r8 - - hio_seed_bank_elem(io_si,el) = 0._r8 - hio_seed_germ_elem(io_si,el) = 0._r8 - hio_seed_decay_elem(io_si,el) = 0._r8 - hio_seeds_in_local_elem(io_si,el) = 0._r8 - hio_seed_in_extern_elem(io_si,el) = 0._r8 - hio_litter_out_elem(io_si,el) = 0._r8 - - ! Plant multi-element states and fluxes - ! Zero states, and set the fluxes - if(element_list(el).eq.carbon12_element)then - this%hvars(ih_totvegc_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_leafc_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_fnrtc_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_sapwc_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_storec_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_reproc_scpf)%r82d(io_si,:) = 0._r8 - - this%hvars(ih_cefflux_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) / & - m2_per_ha / sec_per_day - - this%hvars(ih_cefflux_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) / & - m2_per_ha / sec_per_day - - elseif(element_list(el).eq.nitrogen_element)then - - this%hvars(ih_totvegn_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_leafn_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_fnrtn_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_sapwn_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_storen_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_repron_scpf)%r82d(io_si,:) = 0._r8 - - this%hvars(ih_nefflux_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) / & - m2_per_ha / sec_per_day - - this%hvars(ih_nneed_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_need_scpf(:) / & - m2_per_ha / sec_per_day - - this%hvars(ih_nneed_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_need_scpf(:),dim=1) / & - m2_per_ha / sec_per_day - - this%hvars(ih_nefflux_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) / & - m2_per_ha / sec_per_day - - - elseif(element_list(el).eq.phosphorus_element)then - this%hvars(ih_totvegp_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_leafp_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_fnrtp_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_sapwp_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_storep_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_reprop_scpf)%r82d(io_si,:) = 0._r8 - - this%hvars(ih_pefflux_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) / & - m2_per_ha / sec_per_day - - this%hvars(ih_pneed_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_need_scpf(:) / & - m2_per_ha / sec_per_day - - this%hvars(ih_pneed_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_need_scpf(:),dim=1) / & - m2_per_ha / sec_per_day - - this%hvars(ih_pefflux_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) / & - m2_per_ha / sec_per_day - - end if + hio_seed_decay_elem(io_si,el) = hio_seed_decay_elem(io_si,el) + & + sum(litt%seed_decay(:) + litt%seed_germ_decay(:) ) * & + cpatch%area / m2_per_ha / sec_per_day + hio_seeds_in_local_elem(io_si,el) = hio_seeds_in_local_elem(io_si,el) + & + sum(litt%seed_in_local(:)) * cpatch%area / m2_per_ha / sec_per_day - cpatch => sites(s)%oldest_patch - do while(associated(cpatch)) + hio_seed_in_extern_elem(io_si,el) = hio_seed_in_extern_elem(io_si,el) + & + sum(litt%seed_in_extern(:)) * cpatch%area / m2_per_ha / sec_per_day - litt => cpatch%litter(el) + ! Litter State Variables + hio_cwd_ag_elem(io_si,el) = hio_cwd_ag_elem(io_si,el) + & + sum(litt%ag_cwd(:)) * cpatch%area / m2_per_ha - area_frac = cpatch%area * AREA_INV + hio_cwd_bg_elem(io_si,el) = hio_cwd_bg_elem(io_si,el) + & + sum(litt%bg_cwd(:,:)) * cpatch%area / m2_per_ha + hio_fines_ag_elem(io_si,el) = hio_fines_ag_elem(io_si,el) + & + sum(litt%leaf_fines(:)) * cpatch%area / m2_per_ha + hio_fines_bg_elem(io_si,el) = hio_fines_bg_elem(io_si,el) + & + sum(litt%root_fines(:,:)) * cpatch%area / m2_per_ha - ! Sum up all output fluxes (fragmentation) - hio_litter_out_elem(io_si,el) = hio_litter_out_elem(io_si,el) + & - (sum(litt%leaf_fines_frag(:)) + & - sum(litt%root_fines_frag(:,:)) + & - sum(litt%ag_cwd_frag(:)) + & - sum(litt%bg_cwd_frag(:,:)) + & - sum(litt%seed_decay(:)) + & - sum(litt%seed_germ_decay(:))) * cpatch%area / m2_per_ha / sec_per_day + do cwd=1,ncwd + elcwd = (el-1)*ncwd+cwd + hio_cwd_elcwd(io_si,elcwd) = hio_cwd_elcwd(io_si,elcwd) + & + (litt%ag_cwd(cwd) + sum(litt%bg_cwd(cwd,:))) * & + cpatch%area / m2_per_ha - hio_seed_bank_elem(io_si,el) = hio_seed_bank_elem(io_si,el) + & - sum(litt%seed(:)) * cpatch%area / m2_per_ha + end do - hio_seed_germ_elem(io_si,el) = hio_seed_germ_elem(io_si,el) + & - sum(litt%seed_germ(:)) * cpatch%area / m2_per_ha / sec_per_day + ! Load Mass States + ccohort => cpatch%tallest + do while(associated(ccohort)) - hio_seed_decay_elem(io_si,el) = hio_seed_decay_elem(io_si,el) + & - sum(litt%seed_decay(:) + litt%seed_germ_decay(:) ) * & - cpatch%area / m2_per_ha / sec_per_day + sapw_m = ccohort%prt%GetState(sapw_organ, element_list(el)) + struct_m = ccohort%prt%GetState(struct_organ, element_list(el)) + leaf_m = ccohort%prt%GetState(leaf_organ, element_list(el)) + fnrt_m = ccohort%prt%GetState(fnrt_organ, element_list(el)) + store_m = ccohort%prt%GetState(store_organ, element_list(el)) + repro_m = ccohort%prt%GetState(repro_organ, element_list(el)) + total_m = sapw_m+struct_m+leaf_m+fnrt_m+store_m+repro_m + + + i_scpf = ccohort%size_by_pft_class + + if(element_list(el).eq.carbon12_element)then + this%hvars(ih_totvegc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_totvegc_scpf)%r82d(io_si,i_scpf) + & + total_m * ccohort%n / m2_per_ha + this%hvars(ih_leafc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_leafc_scpf)%r82d(io_si,i_scpf) + & + leaf_m * ccohort%n / m2_per_ha + this%hvars(ih_fnrtc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_fnrtc_scpf)%r82d(io_si,i_scpf) + & + fnrt_m * ccohort%n / m2_per_ha + this%hvars(ih_sapwc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_sapwc_scpf)%r82d(io_si,i_scpf) + & + sapw_m * ccohort%n / m2_per_ha + this%hvars(ih_storec_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storec_scpf)%r82d(io_si,i_scpf) + & + store_m * ccohort%n / m2_per_ha + this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) + & + repro_m * ccohort%n / m2_per_ha + elseif(element_list(el).eq.nitrogen_element)then + + store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) + + this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) + & + total_m * ccohort%n / m2_per_ha + this%hvars(ih_leafn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_leafn_scpf)%r82d(io_si,i_scpf) + & + leaf_m * ccohort%n / m2_per_ha + this%hvars(ih_fnrtn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_fnrtn_scpf)%r82d(io_si,i_scpf) + & + fnrt_m * ccohort%n / m2_per_ha + this%hvars(ih_sapwn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_sapwn_scpf)%r82d(io_si,i_scpf) + & + sapw_m * ccohort%n / m2_per_ha + this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) + & + store_m * ccohort%n / m2_per_ha + this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) + & + repro_m * ccohort%n / m2_per_ha - hio_seeds_in_local_elem(io_si,el) = hio_seeds_in_local_elem(io_si,el) + & - sum(litt%seed_in_local(:)) * cpatch%area / m2_per_ha / sec_per_day + if (ccohort%canopy_layer .eq. 1) then + this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n + else + this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n + end if - hio_seed_in_extern_elem(io_si,el) = hio_seed_in_extern_elem(io_si,el) + & - sum(litt%seed_in_extern(:)) * cpatch%area / m2_per_ha / sec_per_day + elseif(element_list(el).eq.phosphorus_element)then + + store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) + + this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) + & + total_m * ccohort%n / m2_per_ha + this%hvars(ih_leafp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_leafp_scpf)%r82d(io_si,i_scpf) + & + leaf_m * ccohort%n / m2_per_ha + this%hvars(ih_fnrtp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_fnrtp_scpf)%r82d(io_si,i_scpf) + & + fnrt_m * ccohort%n / m2_per_ha + this%hvars(ih_sapwp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_sapwp_scpf)%r82d(io_si,i_scpf) + & + sapw_m * ccohort%n / m2_per_ha + this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) + & + store_m * ccohort%n / m2_per_ha + this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) + & + repro_m * ccohort%n / m2_per_ha - ! Litter State Variables - hio_cwd_ag_elem(io_si,el) = hio_cwd_ag_elem(io_si,el) + & - sum(litt%ag_cwd(:)) * cpatch%area / m2_per_ha + if (ccohort%canopy_layer .eq. 1) then + this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n + else + this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n + end if - hio_cwd_bg_elem(io_si,el) = hio_cwd_bg_elem(io_si,el) + & - sum(litt%bg_cwd(:,:)) * cpatch%area / m2_per_ha + end if - hio_fines_ag_elem(io_si,el) = hio_fines_ag_elem(io_si,el) + & - sum(litt%leaf_fines(:)) * cpatch%area / m2_per_ha + ccohort => ccohort%shorter + end do ! end cohort loop - hio_fines_bg_elem(io_si,el) = hio_fines_bg_elem(io_si,el) + & - sum(litt%root_fines(:,:)) * cpatch%area / m2_per_ha + cpatch => cpatch%younger + end do ! end patch loop - do cwd=1,ncwd - elcwd = (el-1)*ncwd+cwd - hio_cwd_elcwd(io_si,elcwd) = hio_cwd_elcwd(io_si,elcwd) + & - (litt%ag_cwd(cwd) + sum(litt%bg_cwd(cwd,:))) * & - cpatch%area / m2_per_ha + end do ! end element loop - end do + ! Normalize nutrient storage fractions - ! Load Mass States - ccohort => cpatch%tallest - do while(associated(ccohort)) - - sapw_m = ccohort%prt%GetState(sapw_organ, element_list(el)) - struct_m = ccohort%prt%GetState(struct_organ, element_list(el)) - leaf_m = ccohort%prt%GetState(leaf_organ, element_list(el)) - fnrt_m = ccohort%prt%GetState(fnrt_organ, element_list(el)) - store_m = ccohort%prt%GetState(store_organ, element_list(el)) - repro_m = ccohort%prt%GetState(repro_organ, element_list(el)) - total_m = sapw_m+struct_m+leaf_m+fnrt_m+store_m+repro_m - - - i_scpf = ccohort%size_by_pft_class - - if(element_list(el).eq.carbon12_element)then - this%hvars(ih_totvegc_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_totvegc_scpf)%r82d(io_si,i_scpf) + & - total_m * ccohort%n / m2_per_ha - this%hvars(ih_leafc_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_leafc_scpf)%r82d(io_si,i_scpf) + & - leaf_m * ccohort%n / m2_per_ha - this%hvars(ih_fnrtc_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_fnrtc_scpf)%r82d(io_si,i_scpf) + & - fnrt_m * ccohort%n / m2_per_ha - this%hvars(ih_sapwc_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_sapwc_scpf)%r82d(io_si,i_scpf) + & - sapw_m * ccohort%n / m2_per_ha - this%hvars(ih_storec_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storec_scpf)%r82d(io_si,i_scpf) + & - store_m * ccohort%n / m2_per_ha - this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) + & - repro_m * ccohort%n / m2_per_ha - elseif(element_list(el).eq.nitrogen_element)then - - store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) - - this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) + & - total_m * ccohort%n / m2_per_ha - this%hvars(ih_leafn_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_leafn_scpf)%r82d(io_si,i_scpf) + & - leaf_m * ccohort%n / m2_per_ha - this%hvars(ih_fnrtn_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_fnrtn_scpf)%r82d(io_si,i_scpf) + & - fnrt_m * ccohort%n / m2_per_ha - this%hvars(ih_sapwn_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_sapwn_scpf)%r82d(io_si,i_scpf) + & - sapw_m * ccohort%n / m2_per_ha - this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) + & - store_m * ccohort%n / m2_per_ha - this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) + & - repro_m * ccohort%n / m2_per_ha - - if (ccohort%canopy_layer .eq. 1) then - this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n - else - this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n - end if - - elseif(element_list(el).eq.phosphorus_element)then - - store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) - - this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) + & - total_m * ccohort%n / m2_per_ha - this%hvars(ih_leafp_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_leafp_scpf)%r82d(io_si,i_scpf) + & - leaf_m * ccohort%n / m2_per_ha - this%hvars(ih_fnrtp_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_fnrtp_scpf)%r82d(io_si,i_scpf) + & - fnrt_m * ccohort%n / m2_per_ha - this%hvars(ih_sapwp_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_sapwp_scpf)%r82d(io_si,i_scpf) + & - sapw_m * ccohort%n / m2_per_ha - this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) + & - store_m * ccohort%n / m2_per_ha - this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) + & - repro_m * ccohort%n / m2_per_ha - - if (ccohort%canopy_layer .eq. 1) then - this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n - else - this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n - end if + do el = 1, num_elements + if(element_list(el).eq.nitrogen_element)then + if( this%hvars(ih_storentfrac_si)%r81d(io_si)>nearzero ) then + this%hvars(ih_storentfrac_si)%r81d(io_si) = this%hvars(ih_storen_si)%r81d(io_si) / & + this%hvars(ih_storentfrac_si)%r81d(io_si) + end if + do i_pft = 1, numpft + do i_scls = 1,nlevsclass + i_scpf = (i_pft-1)*nlevsclass + i_scls + + if( hio_nplant_canopy_si_scpf(io_si,i_scpf)>nearzero ) then + this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) / & + (hio_nplant_canopy_si_scpf(io_si,i_scpf)*m2_per_ha) + end if + if( hio_nplant_understory_si_scpf(io_si,i_scpf)>nearzero ) then + this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) / & + (hio_nplant_understory_si_scpf(io_si,i_scpf)*m2_per_ha) end if - ccohort => ccohort%shorter end do - - cpatch => cpatch%younger end do + elseif(element_list(el).eq.phosphorus_element)then + if( this%hvars(ih_storeptfrac_si)%r81d(io_si)>nearzero ) then + this%hvars(ih_storeptfrac_si)%r81d(io_si) = this%hvars(ih_storep_si)%r81d(io_si) / & + this%hvars(ih_storeptfrac_si)%r81d(io_si) + end if + do i_pft = 1, numpft + do i_scls = 1,nlevsclass + i_scpf = (i_pft-1)*nlevsclass + i_scls - end do - - ! Normalize nutrient storage fractions - - do el = 1, num_elements - if(element_list(el).eq.nitrogen_element)then - if( this%hvars(ih_storentfrac_si)%r81d(io_si)>nearzero ) then - this%hvars(ih_storentfrac_si)%r81d(io_si) = this%hvars(ih_storen_si)%r81d(io_si) / & - this%hvars(ih_storentfrac_si)%r81d(io_si) - end if - do i_pft = 1, numpft - do i_scls = 1,nlevsclass - i_scpf = (i_pft-1)*nlevsclass + i_scls - - if( hio_nplant_canopy_si_scpf(io_si,i_scpf)>nearzero ) then - this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) / & - (hio_nplant_canopy_si_scpf(io_si,i_scpf)*m2_per_ha) - end if - - if( hio_nplant_understory_si_scpf(io_si,i_scpf)>nearzero ) then - this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) / & - (hio_nplant_understory_si_scpf(io_si,i_scpf)*m2_per_ha) - end if + if( hio_nplant_canopy_si_scpf(io_si,i_scpf)>nearzero ) then + this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) /& + (hio_nplant_canopy_si_scpf(io_si,i_scpf)*m2_per_ha) - end do - end do - elseif(element_list(el).eq.phosphorus_element)then - if( this%hvars(ih_storeptfrac_si)%r81d(io_si)>nearzero ) then - this%hvars(ih_storeptfrac_si)%r81d(io_si) = this%hvars(ih_storep_si)%r81d(io_si) / & - this%hvars(ih_storeptfrac_si)%r81d(io_si) - end if - do i_pft = 1, numpft - do i_scls = 1,nlevsclass - i_scpf = (i_pft-1)*nlevsclass + i_scls - - if( hio_nplant_canopy_si_scpf(io_si,i_scpf)>nearzero ) then - this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) /& - (hio_nplant_canopy_si_scpf(io_si,i_scpf)*m2_per_ha) - - end if - if( hio_nplant_understory_si_scpf(io_si,i_scpf)>nearzero ) then - this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) /& - (hio_nplant_understory_si_scpf(io_si,i_scpf)*m2_per_ha) - end if + end if + if( hio_nplant_understory_si_scpf(io_si,i_scpf)>nearzero ) then + this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) /& + (hio_nplant_understory_si_scpf(io_si,i_scpf)*m2_per_ha) + end if - end do end do - end if - end do + end do + end if + end do - ! pass demotion rates and associated carbon fluxes to history - do i_scls = 1,nlevsclass - hio_demotion_rate_si_scls(io_si,i_scls) = sites(s)%demotion_rate(i_scls) * days_per_year / m2_per_ha - hio_promotion_rate_si_scls(io_si,i_scls) = sites(s)%promotion_rate(i_scls) * days_per_year / m2_per_ha - end do - ! - ! convert kg C / ha / day to kgc / m2 / sec - hio_demotion_carbonflux_si(io_si) = sites(s)%demotion_carbonflux * ha_per_m2 * days_per_sec - hio_promotion_carbonflux_si(io_si) = sites(s)%promotion_carbonflux * ha_per_m2 * days_per_sec - ! - ! mortality-associated carbon fluxes + ! pass demotion rates and associated carbon fluxes to history + do i_scls = 1,nlevsclass + hio_demotion_rate_si_scls(io_si,i_scls) = sites(s)%demotion_rate(i_scls) * days_per_year / m2_per_ha + hio_promotion_rate_si_scls(io_si,i_scls) = sites(s)%promotion_rate(i_scls) * days_per_year / m2_per_ha + end do + ! + ! convert kg C / ha / day to kgc / m2 / sec + hio_demotion_carbonflux_si(io_si) = sites(s)%demotion_carbonflux * ha_per_m2 * days_per_sec + hio_promotion_carbonflux_si(io_si) = sites(s)%promotion_carbonflux * ha_per_m2 * days_per_sec + ! + ! mortality-associated carbon fluxes - hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & - sites(s)%term_carbonflux_canopy * days_per_sec * ha_per_m2 + hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & + sites(s)%term_carbonflux_canopy * days_per_sec * ha_per_m2 - hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & - sites(s)%term_carbonflux_ustory * days_per_sec * ha_per_m2 + hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & + sites(s)%term_carbonflux_ustory * days_per_sec * ha_per_m2 - ! and zero the site-level termination carbon flux variable - sites(s)%term_carbonflux_canopy = 0._r8 - sites(s)%term_carbonflux_ustory = 0._r8 - ! + ! and zero the site-level termination carbon flux variable + sites(s)%term_carbonflux_canopy = 0._r8 + sites(s)%term_carbonflux_ustory = 0._r8 + ! - ! add the site-level disturbance-associated cwd and litter input fluxes to thir respective flux fields + ! add the site-level disturbance-associated cwd and litter input fluxes to thir respective flux fields - do i_cwd = 1, ncwd - hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) + & - flux_diags_c%cwd_ag_input(i_cwd) / days_per_year / sec_per_day + do i_cwd = 1, ncwd + hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) + & + flux_diags_c%cwd_ag_input(i_cwd) / days_per_year / sec_per_day - hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) + & - flux_diags_c%cwd_bg_input(i_cwd) / days_per_year / sec_per_day + hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) + & + flux_diags_c%cwd_bg_input(i_cwd) / days_per_year / sec_per_day - end do + end do - enddo ! site loop + enddo siteloop ! site loop - end associate + end associate - return + return end subroutine update_history_dyn subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) @@ -4349,12 +4357,12 @@ subroutine define_history_vars(this, initialize_variables) index=ih_trimming_si) call this%set_history_var(vname='FATES_AREA_PLANTS', units='m2 m-2', & - long='area occupied by all plants', use_default='active', & + long='area occupied by all plants per m2 land area', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index=ih_area_plant_si) call this%set_history_var(vname='FATES_AREA_TREES', units='m2 m-2', & - long='area occupied by woody plants', use_default='active', & + long='area occupied by woody plants per m2 land area', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & index=ih_area_trees_si) @@ -4416,7 +4424,7 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FATES_MEANLIQVOL_DROUGHTPHEN', & units='m3 m-3', & - long='site-level mean liquid water volume for drought phen', & + long='site-level mean liquid water volume for drought phenolgy', & use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & index=ih_meanliqvol_si) @@ -4702,7 +4710,7 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FATES_FIRE_INTENSITY_BURNFRAC_AP', & units='J m-1 s-1', & - long='product of fire intensity and burned area, resolved by patch age (so divide by FATES_BURNFRAC_AP to get burned-area-weighted-average intensity)', & + long='product of fire intensity and burned fraction, resolved by patch age (so divide by FATES_BURNFRAC_AP to get burned-area-weighted-average intensity)', & use_default='active', avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_fire_intensity_si_age) From 296207ad1926092eee5f73711c0c33b6a274022b Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Mon, 1 Nov 2021 15:03:03 -0600 Subject: [PATCH 461/578] set some mortality counters to zero --- main/FatesHistoryInterfaceMod.F90 | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index f1cec7c51b..e782f149a3 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2080,6 +2080,17 @@ subroutine update_history_dyn(this,nc,nsites,sites) io_si = sites(s)%h_gid + hio_m1_si_scpf(io_si, :) = 0.0_r8 + hio_m2_si_scpf(io_si, :) = 0.0_r8 + hio_m3_si_scpf(io_si, :) = 0.0_r8 + !hio_m4_si_scpf(io_si, :) = 0.0_r8 + !hio_m5_si_scpf(io_si, :) = 0.0_r8 + !hio_m6_si_scpf(io_si, :) = 0.0_r8 + hio_m7_si_scpf(io_si, :) = 0.0_r8 + hio_m8_si_scpf(io_si, :) = 0.0_r8 + hio_m9_si_scpf(io_si, :) = 0.0_r8 + hio_m10_si_scpf(io_si, :) = 0.0_r8 + ! Total carbon model error [kgC/day -> kgC/s] hio_cbal_err_fates_si(io_si) = & sites(s)%mass_balance(element_pos(carbon12_element))%err_fates / sec_per_day From 5c3653d0c70871e647257f679275929251514f73 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Mon, 1 Nov 2021 15:17:25 -0600 Subject: [PATCH 462/578] all mortality counters to zero --- main/FatesHistoryInterfaceMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index e782f149a3..b3adda4687 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2083,9 +2083,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m1_si_scpf(io_si, :) = 0.0_r8 hio_m2_si_scpf(io_si, :) = 0.0_r8 hio_m3_si_scpf(io_si, :) = 0.0_r8 - !hio_m4_si_scpf(io_si, :) = 0.0_r8 - !hio_m5_si_scpf(io_si, :) = 0.0_r8 - !hio_m6_si_scpf(io_si, :) = 0.0_r8 + hio_m4_si_scpf(io_si, :) = 0.0_r8 + hio_m5_si_scpf(io_si, :) = 0.0_r8 + hio_m6_si_scpf(io_si, :) = 0.0_r8 hio_m7_si_scpf(io_si, :) = 0.0_r8 hio_m8_si_scpf(io_si, :) = 0.0_r8 hio_m9_si_scpf(io_si, :) = 0.0_r8 From c9dfafcbe3d26940930051c7e65dd23fe89f6276 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 2 Nov 2021 11:50:53 -0400 Subject: [PATCH 463/578] Reverted to using rsmax0 instead of 100*rsmax0 during leaf humidity override --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index f1f1fc86e9..e7dfca938c 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -1349,7 +1349,7 @@ function LeafHumidityStomaResis(leaf_psi, veg_tempk, ceair, can_press, veg_esat, ! for inner leaf humidity, 0 means total dehydroted ! leaf, 1 means total saturated leaf - ! Note: to disable this control, set k_lwp to zero, LWP_star will be 1, see code (line 1308) below + ! Note: to disable this control, set k_lwp to zero, LWP_star will be 1 k_lwp = EDPftvarcon_inst%hydr_k_lwp(ft) if (leaf_psi<0._r8) then lwp_star = exp(k_lwp*leaf_psi*molar_mass_water/(rgas_J_K_mol *veg_tempk)) @@ -1358,7 +1358,7 @@ function LeafHumidityStomaResis(leaf_psi, veg_tempk, ceair, can_press, veg_esat, end if ! compute specific humidity from vapor pressure - ! q = 0.622*e/(can_press - 0.378*e) + ! q = molar_mass_ratio_vapdry*e/(can_press - (1-molar_mass_ratio_vapdry)*e) ! source https://cran.r-project.org/web/packages/humidity/vignettes/humidity-measures.html ! now adjust inner leaf humidity by LWP_star @@ -1372,7 +1372,7 @@ function LeafHumidityStomaResis(leaf_psi, veg_tempk, ceair, can_press, veg_esat, ! if inner leaf vapor pressure is less then or equal to that at leaf surface ! then set stomata resistance to be very large to stop the transpiration or back flow of vapor - rstoma_out = rsmax0*100._r8 + rstoma_out = rsmax0 else From 212330c77d279006c9fe7adff0214b6abdf40888 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 2 Nov 2021 11:50:08 -0600 Subject: [PATCH 464/578] fixing duplicative EDParamsMod entries --- main/EDParamsMod.F90 | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 34d82cf3e4..ec372c254f 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -93,8 +93,6 @@ module EDParamsMod ! 1 = Christofferson et al. 2016 (TFS), 2 = Van Genuchten 1980 integer, protected,allocatable,public :: hydr_htftype_node(:) - character(len=param_string_length),parameter,public :: ED_name_vai_top_bin_width = "fates_vai_top_bin_width" - character(len=param_string_length),parameter,public :: ED_name_vai_width_increase_factor = "fates_vai_width_increase_factor" character(len=param_string_length),parameter,public :: ED_name_photo_temp_acclim_timescale = "fates_photo_temp_acclim_timescale" character(len=param_string_length),parameter,public :: name_photo_tempsens_model = "fates_photo_tempsens_model" character(len=param_string_length),parameter,public :: name_maintresp_model = "fates_maintresp_model" @@ -289,12 +287,6 @@ subroutine FatesRegisterParams(fates_params) call FatesParamsInit() - call fates_params%RegisterParameter(name=ED_name_vai_top_bin_width, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) - - call fates_params%RegisterParameter(name=ED_name_vai_width_increase_factor, dimension_shape=dimension_shape_scalar, & - dimension_names=dim_names_scalar) - call fates_params%RegisterParameter(name=ED_name_photo_temp_acclim_timescale, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) @@ -475,12 +467,6 @@ subroutine FatesReceiveParams(fates_params) real(r8) :: tmpreal ! local real variable for changing type on read real(r8), allocatable :: hydr_htftype_real(:) - call fates_params%RetreiveParameter(name=ED_name_vai_top_bin_width, & - data=vai_top_bin_width) - - call fates_params%RetreiveParameter(name=ED_name_vai_width_increase_factor, & - data=vai_width_increase_factor) - call fates_params%RetreiveParameter(name=ED_name_photo_temp_acclim_timescale, & data=photo_temp_acclim_timescale) From 356dbd582c68a00e3d4f10256569e7b392e08c79 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 3 Nov 2021 14:07:18 -0600 Subject: [PATCH 465/578] scaling patch%rad_error by patch vegetated fraction --- biogeophys/EDSurfaceAlbedoMod.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 7c1cb08a4a..a48b4544b6 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -999,11 +999,13 @@ subroutine PatchNormanRadiation (currentPatch, & if (radtype == idirect)then error = (forc_dir(radtype) + forc_dif(radtype)) - & (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) - currentPatch%radiation_error = currentPatch%radiation_error + error + currentPatch%radiation_error = currentPatch%radiation_error + error & + * currentPatch%total_canopy_area / currentPatch%area else error = (forc_dir(radtype) + forc_dif(radtype)) - & (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) - currentPatch%radiation_error = currentPatch%radiation_error + error + currentPatch%radiation_error = currentPatch%radiation_error + error & + * currentPatch%total_canopy_area / currentPatch%area endif lai_reduction(:) = 0.0_r8 do L = 1, currentPatch%NCL_p From 56746e01712bec2c05dbbed034a579a676712e92 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 3 Nov 2021 15:33:17 -0600 Subject: [PATCH 466/578] adding further logic to ignore rad_error when veg-covered patch fraction is tiny --- biogeophys/EDSurfaceAlbedoMod.F90 | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index a48b4544b6..4921074380 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -999,14 +999,19 @@ subroutine PatchNormanRadiation (currentPatch, & if (radtype == idirect)then error = (forc_dir(radtype) + forc_dif(radtype)) - & (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) - currentPatch%radiation_error = currentPatch%radiation_error + error & - * currentPatch%total_canopy_area / currentPatch%area else error = (forc_dir(radtype) + forc_dif(radtype)) - & (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) + endif + + ! ignore the currentPatch%radiation_error if the veg-covered fraction of the patch is really small + if ( (currentPatch%total_canopy_area / currentPatch%area) .gt. tolerance ) then + ! normalize rad error by the veg-covered fraction of the patch because that is + ! the only part that this code applies to currentPatch%radiation_error = currentPatch%radiation_error + error & * currentPatch%total_canopy_area / currentPatch%area endif + lai_reduction(:) = 0.0_r8 do L = 1, currentPatch%NCL_p do ft =1,numpft From 0dfa7074368db9c87939669862df4ddf3772bea6 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 3 Nov 2021 16:13:27 -0600 Subject: [PATCH 467/578] removed FatesPFTIndexSwapper_rf.py --- tools/FatesPFTIndexSwapper_rf.py | 274 ------------------------------- 1 file changed, 274 deletions(-) delete mode 100755 tools/FatesPFTIndexSwapper_rf.py diff --git a/tools/FatesPFTIndexSwapper_rf.py b/tools/FatesPFTIndexSwapper_rf.py deleted file mode 100755 index 7e39056fa8..0000000000 --- a/tools/FatesPFTIndexSwapper_rf.py +++ /dev/null @@ -1,274 +0,0 @@ -#!/usr/bin/env python - -# ======================================================================================= -# -# This python script will open an input FATES parameter file, and given a list of PFT -# indices supplied by the user, will create a new parameter file with PFTs entries cloned -# from the original file as-per the list of indices supplied by the user. -# -# First Added, Ryan Knox: Thu Jan 11 13:36:14 PST 2018 -# ======================================================================================= - -import numpy as np -from numpy import * -import sys -import getopt -import code # For development: code.interact(local=locals()) -from datetime import datetime -from scipy.io import netcdf -#import matplotlib.pyplot as plt - - -# ======================================================================================= -# Parameters -# ======================================================================================= - -pft_dim_name = 'fates_pft' -prt_dim_name = 'fates_prt_organs' -hydro_dim_name = 'fates_hydr_organs' -litt_dim_name = 'fates_litterclass' -string_dim_name = 'fates_string_length' - -class timetype: - - # This is time, like the thing that always goes forward and cant be seen - # or touched, insert creative riddle here - - def __init__(self,ntimes): - - self.year = -9*np.ones((ntimes)) - self.month = -9*np.ones((ntimes)) - # This is a floating point decimal day - self.day = -9.0*np.ones((ntimes)) - - # This is a decimal datenumber - self.datenum = -9.0*np.ones((ntimes)) - - -def usage(): - print('') - print('=======================================================================') - print('') - print(' python FatesPFTIndexSwapper.py -h --pft-indices= ') - print(' --fin= ') - print(' --fout=') - print('') - print('') - print(' -h --help ') - print(' print this help message') - print('') - print('') - print(' --pft-indices=') - print(' This is a comma delimited list of integer positions of the PFTs') - print(' to be copied into the new file. Note that first pft position') - print(' is treated as 1 (not C or python like), and any order or multiples') - print(' of indices can be chosen') - print('') - print('') - print(' --fin=') - print(' This is the full path to the netcdf file you are basing off of') - print('') - print('') - print(' --fout=') - print(' This is the full path to the netcdf file you are writing to.') - print('') - print('') - print('=======================================================================') - - -def interp_args(argv): - - argv.pop(0) # The script itself is the first argument, forget it - - # Name of the conversion file - - input_fname = "none" - output_fname = "none" - donor_pft_indices = -9 - donot_pft_indices_str = '' - try: - opts, args = getopt.getopt(argv, 'h',["fin=","fout=","pft-indices="]) - except getopt.GetoptError as err: - print('Argument error, see usage') - usage() - sys.exit(2) - - for o, a in opts: - if o in ("-h", "--help"): - usage() - sys.exit(0) - elif o in ("--fin"): - input_fname = a - elif o in ("--fout"): - output_fname = a - elif o in ("--pft-indices"): - donor_pft_indices_str = a.strip() - else: - assert False, "unhandled option" - - - if (input_fname == "none"): - print("You must specify an input file:\n\n") - usage() - sys.exit(2) - - if (output_fname == "none"): - print("You must specify an output file:\n\n") - usage() - sys.exit(2) - - if (donor_pft_indices_str == ''): - print("You must specify at least one donor pft index!\n\n") - usage() - sys.exit(2) - else: - donor_pft_indices = [] - for strpft in donor_pft_indices_str.split(','): - donor_pft_indices.append(int(strpft)) - - - return (input_fname,output_fname,donor_pft_indices) - - -# ======================================================================================== -# ======================================================================================== -# Main -# ======================================================================================== -# ======================================================================================== - -def main(argv): - - # Interpret the arguments to the script - [input_fname,output_fname,donor_pft_indices] = interp_args(argv) - - num_pft_out = len(donor_pft_indices) - - # Open the netcdf files - fp_out = netcdf.netcdf_file(output_fname, 'w') - - fp_in = netcdf.netcdf_file(input_fname, 'r') - - for key, value in sorted(fp_in.dimensions.items()): - if(key==pft_dim_name): - fp_out.createDimension(key,int(num_pft_out)) - print('Creating Dimension: {}={}'.format(key,num_pft_out)) - else: - fp_out.createDimension(key,int(value)) - print('Creating Dimension: {}={}'.format(key,value)) - - for key, value in sorted(fp_in.variables.items()): - print('Creating Variable: ',key) - # code.interact(local=locals()) - - - in_var = fp_in.variables.get(key) - - - # Idenfity if this variable has pft dimension - pft_dim_found = -1 - prt_dim_found = -1 - hydro_dim_found = -1 - litt_dim_found = -1 - string_dim_found = -1 - pft_dim_len = len(fp_in.variables.get(key).dimensions) - - for idim, name in enumerate(fp_in.variables.get(key).dimensions): - - # Manipulate data - if(name==pft_dim_name): - pft_dim_found = idim - if(name==prt_dim_name): - prt_dim_found = idim - if(name==litt_dim_name): - litt_dim_found = idim - if(name==hydro_dim_name): - hydro_dim_found = idim - if(name==string_dim_name): - string_dim_found = idim - - # Copy over the input data - # Tedious, but I have to permute through all combinations of dimension position - if( pft_dim_len == 0 ): - out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) - out_var.assignValue(float(fp_in.variables.get(key).data)) - elif( (pft_dim_found==-1) & (prt_dim_found==-1) & (litt_dim_found==-1) & (hydro_dim_found==-1) ): - out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) - out_var[:] = in_var[:] - elif( (pft_dim_found==0) & (pft_dim_len==1) ): # 1D fates_pft - out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) - tmp_out = np.zeros([num_pft_out]) - for id,ipft in enumerate(donor_pft_indices): - tmp_out[id] = fp_in.variables.get(key).data[ipft-1] - out_var[:] = tmp_out - - # 2D hydro_organ - fates_pft - # or.. prt_organ - fates_pft - elif( (pft_dim_found==1) & (pft_dim_len==2) ): - out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) - dim2_len = fp_in.dimensions.get(fp_in.variables.get(key).dimensions[0]) - tmp_out = np.zeros([dim2_len,num_pft_out]) - for id,ipft in enumerate(donor_pft_indices): - for idim in range(0,dim2_len): - tmp_out[idim,id] = fp_in.variables.get(key).data[idim,ipft-1] - out_var[:] = tmp_out - - elif( (pft_dim_found==0) & (pft_dim_len==2) ): # fates_pft - string_length - out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) - dim2_len = fp_in.dimensions.get(fp_in.variables.get(key).dimensions[1]) - out_var[:] = np.empty([num_pft_out,dim2_len], dtype="S{}".format(dim2_len)) - for id,ipft in enumerate(donor_pft_indices): - out_var[id] = fp_in.variables.get(key).data[ipft-1] - - elif( (prt_dim_found==0) & (pft_dim_len==2) ): - out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) - out_var[:] = in_var[:] - - elif( (hydro_dim_found==0) & (string_dim_found>=0) ): - out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) - out_var[:] = in_var[:] - - elif( (litt_dim_found==0) & (string_dim_found>=0) ): - out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) - out_var[:] = in_var[:] - - elif( prt_dim_found==0 ): # fates_prt_organs - indices - out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) - out_var[:] = in_var[:] - - elif( litt_dim_found==0 ): - out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) - out_var[:] = in_var[:] - elif( hydro_dim_found==0): - out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) - out_var[:] = in_var[:] - else: - print('This variable has a dimensioning that we have not considered yet.') - print('Please add this condition to the logic above this statement.') - print('Aborting') - for idim, name in enumerate(fp_in.variables.get(key).dimensions): - print("idim: {}, name: {}".format(idim,name)) - exit(2) - - out_var.units = in_var.units - out_var.long_name = in_var.long_name - - fp_out.history = "This file was made from FatesPFTIndexSwapper.py \n Input File = {} \n Indices = {}"\ - .format(input_fname,donor_pft_indices) - - #var_out.mode = var.mode - #fp.flush() - - fp_in.close() - fp_out.close() - - print('Cloneing complete!') - exit(0) - - - - -# ======================================================================================= -# This is the actual call to main - -if __name__ == "__main__": - main(sys.argv) From fc4a3012fa28790fe0eb61dda5c491de973f57da Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 4 Nov 2021 15:30:59 -0600 Subject: [PATCH 468/578] zeroing out the rad error if no leaves are present --- biogeophys/EDSurfaceAlbedoMod.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 4921074380..4fe9af154f 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -141,6 +141,9 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) ! no radiation is absorbed bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 + + ! Zero out the radiation error to avoid + currentPatch%radiation_error = 0.0_r8 do ib = 1,hlm_numSWb bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) From 3e098e59f1bf47e8e57451a00df0fb8708465461 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 4 Nov 2021 16:46:16 -0700 Subject: [PATCH 469/578] adding comments to radiation_error calcs --- biogeophys/EDSurfaceAlbedoMod.F90 | 14 +++++++++----- main/EDTypesMod.F90 | 2 +- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 4fe9af154f..f88c20dede 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -141,9 +141,8 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) ! no radiation is absorbed bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 - - ! Zero out the radiation error to avoid currentPatch%radiation_error = 0.0_r8 + do ib = 1,hlm_numSWb bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) @@ -595,7 +594,10 @@ subroutine PatchNormanRadiation (currentPatch, & endif ! currentPatch%canopy_mask end do!ft end do!L + + ! Zero out the radiation error for the current patch before conducting the conservation check currentPatch%radiation_error = 0.0_r8 + do ib = 1,hlm_numSWb Dif_dn(:,:,:) = 0.00_r8 Dif_up(:,:,:) = 0.00_r8 @@ -1007,7 +1009,7 @@ subroutine PatchNormanRadiation (currentPatch, & (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) endif - ! ignore the currentPatch%radiation_error if the veg-covered fraction of the patch is really small + ! ignore the current patch radiation error if the veg-covered fraction of the patch is really small if ( (currentPatch%total_canopy_area / currentPatch%area) .gt. tolerance ) then ! normalize rad error by the veg-covered fraction of the patch because that is ! the only part that this code applies to @@ -1240,10 +1242,12 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) end do !iv end do !FT end do !CL - cpatch%radiation_error = cpatch%radiation_error * (bc_in(s)%solad_parb(ifp,ipar)+ & + + ! Convert normalized radiation error units from fraction of radiation to W/m2 + cpatch%radiation_error = cpatch%radiation_error * (bc_in(s)%solad_parb(ifp,ipar) + & bc_in(s)%solai_parb(ifp,ipar)) + ! output the actual PAR profiles through the canopy for diagnostic purposes - do CL = 1, cpatch%NCL_p do FT = 1,numpft do iv = 1, cpatch%nrad(CL,ft) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 724811c9b8..2f4178c74a 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -430,7 +430,7 @@ module EDTypesMod real(r8) :: elai_profile(nclmax,maxpft,nlevleaf) ! exposed leaf area in each canopy layer, pft, and leaf layer real(r8) :: tsai_profile(nclmax,maxpft,nlevleaf) ! total stem area in each canopy layer, pft, and leaf layer real(r8) :: esai_profile(nclmax,maxpft,nlevleaf) ! exposed stem area in each canopy layer, pft, and leaf layer - real(r8) :: radiation_error + real(r8) :: radiation_error ! radiation error (w/m2) real(r8) :: layer_height_profile(nclmax,maxpft,nlevleaf) real(r8) :: canopy_area_profile(nclmax,maxpft,nlevleaf) ! fraction of crown area per canopy area in each layer ! they will sum to 1.0 in the fully closed canopy layers From bf452b6110e59b062bf6b8a51c1ba2435dccff5d Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 5 Nov 2021 13:37:41 -0600 Subject: [PATCH 470/578] logic fixes to nocomp, fixed_biogeog, and their intersection --- biogeochem/EDPhysiologyMod.F90 | 7 +++++-- main/EDInitMod.F90 | 2 +- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 859f6e3534..e20b9896ca 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -16,6 +16,7 @@ module EDPhysiologyMod use FatesInterfaceTypesMod, only : hlm_use_planthydro use FatesInterfaceTypesMod, only : hlm_parteh_mode use FatesInterfaceTypesMod, only : hlm_use_fixed_biogeog + use FatesInterfaceTypesMod, only : hlm_use_nocomp use FatesInterfaceTypesMod, only : hlm_nitrogen_spec use FatesInterfaceTypesMod, only : hlm_phosphorus_spec use FatesConstantsMod, only : r8 => fates_r8 @@ -1853,8 +1854,10 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) do ft = 1,numpft - if(currentSite%use_this_pft(ft).eq.itrue)then - temp_cohort%canopy_trim = init_recruit_trim + if(currentSite%use_this_pft(ft).eq.itrue & + .and. ((hlm_use_nocomp .eq. ifalse) .or. (ft .eq. currentPatch%nocomp_pft_label)))then + + temp_cohort%canopy_trim = init_recruit_trim temp_cohort%pft = ft temp_cohort%hite = EDPftvarcon_inst%hgt_min(ft) temp_cohort%coage = 0.0_r8 diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index c3b503a729..c0a4e35c00 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -487,7 +487,7 @@ subroutine init_patches( nsites, sites, bc_in) start_patch = 1 ! start at the first vegetated patch if(hlm_use_nocomp.eq.itrue)then num_new_patches = numpft - if(hlm_use_sp.eq.itrue)then + if( (hlm_use_sp.eq.itrue) .or. (hlm_use_fixed_biogeog .eq.itrue) )then start_patch = 0 ! start at the bare ground patch endif ! allocate(newppft(numpft)) From b33a9eafc89dbba295be61c5fad4cf33cc0eb90a Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 5 Nov 2021 16:15:13 -0600 Subject: [PATCH 471/578] simplified logic in init --- main/EDInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index c0a4e35c00..33286077af 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -487,7 +487,7 @@ subroutine init_patches( nsites, sites, bc_in) start_patch = 1 ! start at the first vegetated patch if(hlm_use_nocomp.eq.itrue)then num_new_patches = numpft - if( (hlm_use_sp.eq.itrue) .or. (hlm_use_fixed_biogeog .eq.itrue) )then + if( hlm_use_fixed_biogeog .eq.itrue )then start_patch = 0 ! start at the bare ground patch endif ! allocate(newppft(numpft)) From 04aa2dba9f07125ca286b47ac7c5bc15cc9ab35c Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Wed, 10 Nov 2021 08:07:13 -0700 Subject: [PATCH 472/578] fix double counting of FATES_AREA_TREES --- main/FatesHistoryInterfaceMod.F90 | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 07957cb316..73d8e2d06b 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2449,8 +2449,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) end if end do elloop - hio_area_trees_si(io_si) = hio_area_trees_si(io_si) + min(cpatch%total_tree_area,cpatch%area) * AREA_INV - ! Update PFT crown area hio_crownarea_si_pft(io_si, ft) = hio_crownarea_si_pft(io_si, ft) + & ccohort%c_area * AREA_INV @@ -4471,13 +4469,13 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FATES_CROWNAREA_PF', units='m2 m-2', & long='total PFT-level crown area per m2 land area', & - use_default='inactive', avgflag='A', vtype=site_pft_r8, & + use_default='active', avgflag='A', vtype=site_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index=ih_crownarea_si_pft) call this%set_history_var(vname='FATES_CANOPYCROWNAREA_PF', & units='m2 m-2', long='total PFT-level canopy-layer crown area per m2 land area', & - use_default='inactive', avgflag='A', vtype=site_pft_r8, & + use_default='active', avgflag='A', vtype=site_pft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index=ih_canopycrownarea_si_pft) From 1d21c5be340200bbd0f78836d54ec4ffa53c8307 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 10 Nov 2021 13:03:18 -0700 Subject: [PATCH 473/578] adding site-level distubance rate tracking to initialization --- main/EDInitMod.F90 | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index c3b503a729..99d0208f84 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -198,6 +198,13 @@ subroutine zero_site( site_in ) site_in%water_memory(:) = nan site_in%vegtemp_memory(:) = nan ! record of last 10 days temperature for senescence model. + ! Disturbance rates tracking + site_in%primary_land_patchfusion_error = 0.0_r8 + site_in%harvest_carbon_flux = 0.0_r8 + site_in%potential_disturbance_rates(:) = 0.0_r8 + site_in%disturbance_rates_secondary_to_secondary(:) = 0.0_r8 + site_in%disturbance_rates_primary_to_secondary(:) = 0.0_r8 + site_in%disturbance_rates_primary_to_primary(:) = 0.0_r8 ! FIRE site_in%acc_ni = 0.0_r8 ! daily nesterov index accumulating over time. time unlimited theoretically. From 0a83cb8766e661a245532a111b139636b5a92c5c Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 10 Nov 2021 18:34:10 -0700 Subject: [PATCH 474/578] zeroing out the diagnostic radiation profiles during patch creation --- biogeochem/EDPatchDynamicsMod.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index c08e93565e..1ec3bf047e 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -2202,6 +2202,12 @@ subroutine zero_patch(cp_p) currentPatch%c_lblayer = 0.0_r8 currentPatch%fragmentation_scaler(:) = 0.0_r8 + ! diagnostic radiation profiles + currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 + currentPatch%solar_zenith_flag = .false. currentPatch%solar_zenith_angle = nan From ae5d0d37df6e16776a7d2bdf62c60b85b6305699 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Thu, 11 Nov 2021 11:08:31 -0700 Subject: [PATCH 475/578] removed setting mortality variables to 0.0 --- main/FatesHistoryInterfaceMod.F90 | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 73d8e2d06b..d42f918fbf 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2081,19 +2081,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) io_si = sites(s)%h_gid - ! We have to do this right now because we access them below - ! (outside of the cohort loop) - hio_m1_si_scpf(io_si, :) = 0.0_r8 - hio_m2_si_scpf(io_si, :) = 0.0_r8 - hio_m3_si_scpf(io_si, :) = 0.0_r8 - hio_m4_si_scpf(io_si, :) = 0.0_r8 - hio_m5_si_scpf(io_si, :) = 0.0_r8 - hio_m6_si_scpf(io_si, :) = 0.0_r8 - hio_m7_si_scpf(io_si, :) = 0.0_r8 - hio_m8_si_scpf(io_si, :) = 0.0_r8 - hio_m9_si_scpf(io_si, :) = 0.0_r8 - hio_m10_si_scpf(io_si, :) = 0.0_r8 - ! Total carbon model error [kgC/day -> kgC/s] hio_cbal_err_fates_si(io_si) = & sites(s)%mass_balance(element_pos(carbon12_element))%err_fates / sec_per_day From 113c1bbbf3b0056748e88b7637cf9c671186284c Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Fri, 12 Nov 2021 07:55:30 -0700 Subject: [PATCH 476/578] fix ag_ and bg_fines switch in associate statement --- main/FatesHistoryInterfaceMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index d42f918fbf..54c80cbced 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -1961,8 +1961,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_cwd_elcwd => this%hvars(ih_cwd_elcwd)%r82d, & hio_cwd_ag_elem => this%hvars(ih_cwd_ag_elem)%r82d, & hio_cwd_bg_elem => this%hvars(ih_cwd_bg_elem)%r82d, & - hio_fines_ag_elem => this%hvars(ih_fines_bg_elem)%r82d, & - hio_fines_bg_elem => this%hvars(ih_fines_ag_elem)%r82d, & + hio_fines_ag_elem => this%hvars(ih_fines_ag_elem)%r82d, & + hio_fines_bg_elem => this%hvars(ih_fines_bg_elem)%r82d, & hio_ba_si_scls => this%hvars(ih_ba_si_scls)%r82d, & hio_agb_si_scls => this%hvars(ih_agb_si_scls)%r82d, & hio_biomass_si_scls => this%hvars(ih_biomass_si_scls)%r82d, & From 8777a62a5e77304b0ec69f397b3e274fcac9acc6 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Mon, 15 Nov 2021 09:34:04 -0700 Subject: [PATCH 477/578] update for APSZ to SZAP switch --- main/FatesHistoryInterfaceMod.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 54c80cbced..8018e564f9 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -5381,47 +5381,47 @@ subroutine define_history_vars(this, initialize_variables) ! size class by age dimensioned variables - call this%set_history_var(vname='FATES_NPLANT_APSZ', units = 'm-2', & + call this%set_history_var(vname='FATES_NPLANT_SZAP', units = 'm-2', & long='number of plants per m2 in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_nplant_si_scag) - call this%set_history_var(vname='FATES_NPLANT_CANOPY_APSZ', units = 'm-2', & + call this%set_history_var(vname='FATES_NPLANT_CANOPY_SZAP', units = 'm-2', & long='number of plants per m2 in canopy in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_nplant_canopy_si_scag) - call this%set_history_var(vname='FATES_NPLANT_USTORY_APSZ', & + call this%set_history_var(vname='FATES_NPLANT_USTORY_SZAP', & units = 'm-2', & long='number of plants per m2 in understory in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_nplant_understory_si_scag) - call this%set_history_var(vname='FATES_DDBH_CANOPY_APSZ', & + call this%set_history_var(vname='FATES_DDBH_CANOPY_SZAP', & units = 'm m-2 yr-1', & long='growth rate of canopy plants in meters DBH per m2 per year in canopy in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_ddbh_canopy_si_scag) - call this%set_history_var(vname='FATES_DDBH_USTORY_APSZ', & + call this%set_history_var(vname='FATES_DDBH_USTORY_SZAP', & units = 'm m-2 yr-1', & long='growth rate of understory plants in meters DBH per m2 per year in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_ddbh_understory_si_scag) - call this%set_history_var(vname='FATES_MORTALITY_CANOPY_APSZ', & + call this%set_history_var(vname='FATES_MORTALITY_CANOPY_SZAP', & units = 'm-2 yr-1', & long='mortality rate of canopy plants in number of plants per m2 per year in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_mortality_canopy_si_scag) - call this%set_history_var(vname='FATES_MORTALITY_USTORY_APSZ', & + call this%set_history_var(vname='FATES_MORTALITY_USTORY_SZAP', & units = 'm-2 yr-1', & long='mortality rate of understory plants in number of plants per m2 per year in each size x age class', & use_default='inactive', avgflag='A', vtype=site_scag_r8, & @@ -5430,7 +5430,7 @@ subroutine define_history_vars(this, initialize_variables) ! size x age x pft dimensioned - call this%set_history_var(vname='FATES_NPLANT_APSZPF',units = 'm-2', & + call this%set_history_var(vname='FATES_NPLANT_SZAPPF',units = 'm-2', & long='number of plants per m2 in each size x age x pft class', & use_default='inactive', avgflag='A', vtype=site_scagpft_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, & From ebd60a022d6c999aa9e882cd24a6162684c2dca2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 16 Nov 2021 10:42:11 -0500 Subject: [PATCH 478/578] Resolving conflict in updates to VG related to parameter IO --- main/EDPftvarcon.F90 | 502 +++++++++++++---------- main/EDTypesMod.F90 | 51 +-- parameter_files/fates_params_default.cdl | 461 +++++++++++++-------- 3 files changed, 597 insertions(+), 417 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 6be57a6331..84e6159507 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -15,7 +15,6 @@ module EDPftvarcon use FatesGlobals, only : fates_log use FatesGlobals, only : endrun => fates_endrun use FatesLitterMod, only : ilabile,icellulose,ilignin - use PRTGenericMod, only : num_organ_types use PRTGenericMod, only : leaf_organ, fnrt_organ, store_organ use PRTGenericMod, only : sapw_organ, struct_organ, repro_organ use PRTGenericMod, only : prt_cnp_flex_allom_hyp,prt_carbon_allom_hyp @@ -26,11 +25,11 @@ module EDPftvarcon use FatesConstantsMod , only : prescribed_n_uptake use FatesConstantsMod , only : coupled_p_uptake use FatesConstantsMod , only : coupled_n_uptake - + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg - + ! ! !PUBLIC TYPES: implicit none @@ -40,25 +39,23 @@ module EDPftvarcon integer, parameter, public :: lower_bound_pft = 1 integer, parameter, public :: lower_bound_general = 1 - !ED specific variables. + !ED specific variables. type, public :: EDPftvarcon_type real(r8), allocatable :: freezetol(:) ! minimum temperature tolerance real(r8), allocatable :: hgt_min(:) ! sapling height m real(r8), allocatable :: dleaf(:) ! leaf characteristic dimension length (m) - real(r8), allocatable :: z0mr(:) ! ratio of roughness length of vegetation to height (-) - real(r8), allocatable :: displar(:) ! ratio of displacement height to canopy top height (-) - real(r8), allocatable :: crown(:) ! fraction of the height of the plant - ! that is occupied by crown. For fire model. + real(r8), allocatable :: z0mr(:) ! ratio of roughness length of vegetation to height (-) + real(r8), allocatable :: displar(:) ! ratio of displacement height to canopy top height real(r8), allocatable :: bark_scaler(:) ! scaler from dbh to bark thickness. For fire model. - real(r8), allocatable :: crown_kill(:) ! scaler on fire death. For fire model. - real(r8), allocatable :: initd(:) ! initial seedling density + real(r8), allocatable :: crown_kill(:) ! scaler on fire death. For fire model. + real(r8), allocatable :: initd(:) ! initial seedling density real(r8), allocatable :: seed_suppl(:) ! seeds that come from outside the gridbox. real(r8), allocatable :: bb_slope(:) ! ball berry slope parameter real(r8), allocatable :: medlyn_slope(:) ! Medlyn slope parameter KPa^0.5 real(r8), allocatable :: stomatal_intercept(:) ! intercept of stomatal conductance model - + real(r8), allocatable :: lf_flab(:) ! Leaf litter labile fraction [-] real(r8), allocatable :: lf_fcel(:) ! Leaf litter cellulose fraction [-] @@ -67,27 +64,27 @@ module EDPftvarcon real(r8), allocatable :: fr_fcel(:) ! Fine-root litter cellulose fraction [-] real(r8), allocatable :: fr_flig(:) ! Fine-root litter lignatn fraction [-] real(r8), allocatable :: xl(:) ! Leaf-stem orientation index - real(r8), allocatable :: clumping_index(:) ! factor describing how much self-occlusion - ! of leaf scattering elements + real(r8), allocatable :: clumping_index(:) ! factor describing how much self-occlusion + ! of leaf scattering elements ! decreases light interception - real(r8), allocatable :: c3psn(:) ! index defining the photosynthetic + real(r8), allocatable :: c3psn(:) ! index defining the photosynthetic ! pathway C4 = 0, C3 = 1 - - real(r8), allocatable :: smpso(:) ! Soil water potential at full stomatal opening + + real(r8), allocatable :: smpso(:) ! Soil water potential at full stomatal opening ! (non-HYDRO mode only) [mm] - real(r8), allocatable :: smpsc(:) ! Soil water potential at full stomatal closure + real(r8), allocatable :: smpsc(:) ! Soil water potential at full stomatal closure ! (non-HYDRO mode only) [mm] - real(r8), allocatable :: maintresp_reduction_curvature(:) ! curvature of MR reduction as f(carbon storage), + real(r8), allocatable :: maintresp_reduction_curvature(:) ! curvature of MR reduction as f(carbon storage), ! 1=linear, 0=very curved - real(r8), allocatable :: maintresp_reduction_intercept(:) ! intercept of MR reduction as f(carbon storage), + real(r8), allocatable :: maintresp_reduction_intercept(:) ! intercept of MR reduction as f(carbon storage), ! 0=no throttling, 1=max throttling real(r8), allocatable :: bmort(:) real(r8), allocatable :: mort_ip_size_senescence(:) ! inflection point of dbh dependent senescence real(r8), allocatable :: mort_r_size_senescence(:) ! rate of change in mortality with dbh - real(r8), allocatable :: mort_ip_age_senescence(:) ! inflection point of age dependent senescence - real(r8), allocatable :: mort_r_age_senescence(:) ! rate of change in mortality with age + real(r8), allocatable :: mort_ip_age_senescence(:) ! inflection point of age dependent senescence + real(r8), allocatable :: mort_r_age_senescence(:) ! rate of change in mortality with age real(r8), allocatable :: mort_scalar_coldstress(:) real(r8), allocatable :: mort_scalar_cstarvation(:) real(r8), allocatable :: mort_scalar_hydrfailure(:) @@ -95,17 +92,14 @@ module EDPftvarcon real(r8), allocatable :: hf_flc_threshold(:) real(r8), allocatable :: vcmaxha(:) real(r8), allocatable :: jmaxha(:) - real(r8), allocatable :: tpuha(:) real(r8), allocatable :: vcmaxhd(:) real(r8), allocatable :: jmaxhd(:) - real(r8), allocatable :: tpuhd(:) real(r8), allocatable :: vcmaxse(:) real(r8), allocatable :: jmaxse(:) - real(r8), allocatable :: tpuse(:) real(r8), allocatable :: germination_rate(:) ! Fraction of seed mass germinating per year (yr-1) - real(r8), allocatable :: seed_decay_rate(:) ! Fraction of seed mass (both germinated and + real(r8), allocatable :: seed_decay_rate(:) ! Fraction of seed mass (both germinated and ! ungerminated), decaying per year (yr-1) - + real(r8), allocatable :: trim_limit(:) ! Limit to reductions in leaf area w stress (m2/m2) real(r8), allocatable :: trim_inc(:) ! Incremental change in trimming function (m2/m2) real(r8), allocatable :: rhol(:, :) @@ -120,21 +114,21 @@ module EDPftvarcon ! Equation 16 Thonicke et al 2010 ! Non-PARTEH Allometry Parameters - ! -------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------- real(r8), allocatable :: allom_frbstor_repro(:) ! fraction of bstrore for reproduction after mortality ! Prescribed Physiology Mode Parameters - real(r8), allocatable :: prescribed_npp_canopy(:) ! this is only for the + real(r8), allocatable :: prescribed_npp_canopy(:) ! this is only for the ! prescribed_physiology_mode - real(r8), allocatable :: prescribed_npp_understory(:) ! this is only for the + real(r8), allocatable :: prescribed_npp_understory(:) ! this is only for the ! prescribed physiology mode - real(r8), allocatable :: prescribed_mortality_canopy(:) ! this is only for the + real(r8), allocatable :: prescribed_mortality_canopy(:) ! this is only for the ! prescribed_physiology_mode - real(r8), allocatable :: prescribed_mortality_understory(:) ! this is only for the + real(r8), allocatable :: prescribed_mortality_understory(:) ! this is only for the ! prescribed_physiology_mode - real(r8), allocatable :: prescribed_recruitment(:) ! this is only for the + real(r8), allocatable :: prescribed_recruitment(:) ! this is only for the ! prescribed_physiology_mode ! Nutrient Aquisition (ECA & RD) @@ -150,7 +144,7 @@ module EDPftvarcon ! Note*: units of [gC] is grams carbon of fine-root real(r8), allocatable :: eca_km_nh4(:) ! half-saturation constant for plant nh4 uptake [gN/m3] - real(r8), allocatable :: eca_vmax_nh4(:) ! maximum production rate for plant nh4 uptake [gN/gC/s] + real(r8), allocatable :: eca_vmax_nh4(:) ! maximum production rate for plant nh4 uptake [gN/gC/s] real(r8), allocatable :: eca_km_no3(:) ! half-saturation constant for plant no3 uptake [gN/m3] real(r8), allocatable :: eca_vmax_no3(:) ! maximum production rate for plant no3 uptake [gN/gC/s] real(r8), allocatable :: eca_km_p(:) ! half-saturation constant for plant p uptake [gP/m3] @@ -159,34 +153,39 @@ module EDPftvarcon real(r8), allocatable :: eca_vmax_ptase(:) ! maximum production rate for biochemical P prod [gP/gC/s] real(r8), allocatable :: eca_alpha_ptase(:) ! Fraction of min P generated from ptase activity ! that is immediately sent to the plant [/] - real(r8), allocatable :: eca_lambda_ptase(:) ! critical value for Ptase that incurs + real(r8), allocatable :: eca_lambda_ptase(:) ! critical value for Ptase that incurs ! biochemical production, fraction based how much ! more in need a plant is for P versus N [/] !real(r8), allocatable :: nfix1(:) ! nitrogen fixation parameter 1 !real(r8), allocatable :: nfix2(:) ! nitrogen fixation parameter 2 - + ! Turnover related things real(r8), allocatable :: phenflush_fraction(:) ! Maximum fraction of storage carbon used to flush leaves ! on bud-burst [kgC/kgC] - real(r8), allocatable :: phen_cold_size_threshold(:) ! stem/leaf drop occurs on DBH size of decidious non-woody - ! (coastal grass) plants larger than the threshold value - real(r8), allocatable :: phen_stem_drop_fraction(:) ! Fraction of stem dropped/senescened for decidious - ! non-woody (grass) plants + real(r8), allocatable :: phen_cold_size_threshold(:) ! stem/leaf drop occurs on DBH size of decidious non-woody + ! (coastal grass) plants larger than the threshold value + real(r8), allocatable :: phen_stem_drop_fraction(:) ! Fraction of stem dropped/senescened for decidious + ! non-woody (grass) plants ! Nutrient Aquisition parameters real(r8), allocatable :: prescribed_nuptake(:) ! If there is no soil BGC model active, - ! prescribe an uptake rate for nitrogen, this is the fraction of plant demand + ! prescribe an uptake rate for nitrogen, this is the fraction of plant demand real(r8), allocatable :: prescribed_puptake(:) ! If there is no soil BGC model active, ! prescribe an uptake rate for phosphorus ! This is the fraction of plant demand - + + + ! Unassociated pft dimensioned free parameter that + ! developers can use for testing arbitrary new hypothese + real(r8), allocatable :: dev_arbitrary_pft(:) + ! Parameters dimensioned by PFT and leaf age - real(r8), allocatable :: vcmax25top(:,:) ! maximum carboxylation rate of Rub. at 25C, - ! canopy top [umol CO2/m^2/s]. Dimensioned by + real(r8), allocatable :: vcmax25top(:,:) ! maximum carboxylation rate of Rub. at 25C, + ! canopy top [umol CO2/m^2/s]. Dimensioned by ! leaf age-class ! Plant Hydraulic Parameters ! --------------------------------------------------------------------------------------------- @@ -196,25 +195,34 @@ module EDPftvarcon real(r8), allocatable :: hydr_rs2(:) ! absorbing root radius (m) real(r8), allocatable :: hydr_srl(:) ! specific root length (m g-1) real(r8), allocatable :: hydr_rfrac_stem(:) ! fraction of total tree resistance from troot to canopy - real(r8), allocatable :: hydr_avuln_gs(:) ! shape parameter for stomatal control of water vapor exiting leaf + real(r8), allocatable :: hydr_avuln_gs(:) ! shape parameter for stomatal control of water vapor exiting leaf real(r8), allocatable :: hydr_p50_gs(:) ! water potential at 50% loss of stomatal conductance - - real(r8), allocatable :: hydr_alpha_vg(:) ! capilary length parameter in van Genuchten model - real(r8), allocatable :: hydr_m_vg(:) ! pore size distribution, m in van Genuchten 1980 model range (0,1) - real(r8), allocatable :: hydr_n_vg(:) ! pore size distribution, n in van Genuchten 1980 model range >2 real(r8), allocatable :: hydr_k_lwp(:) ! inner leaf humidity scaling coefficient ! PFT x Organ Dimension (organs are: 1=leaf, 2=stem, 3=transporting root, 4=absorbing root) - real(r8), allocatable :: hydr_avuln_node(:,:) ! xylem vulernability curve shape parameter + ! ---------------------------------------------------------------------------------- + + ! Van Genuchten PV PK curves (NOT IMPLEMENTED) + real(r8), allocatable :: hydr_vg_alpha_node(:,:) ! capilary length parameter in van Genuchten model + real(r8), allocatable :: hydr_vg_m_node(:,:) ! pore size distribution, m in van Genuchten 1980 model, range (0,1) + real(r8), allocatable :: hydr_vg_n_node(:,:) ! pore size distribution, n in van Genuchten 1980 model, range >2 + + ! TFS PV-PK curves + real(r8), allocatable :: hydr_avuln_node(:,:) ! xylem vulernability curve shape parameter real(r8), allocatable :: hydr_p50_node(:,:) ! xylem water potential at 50% conductivity loss (MPa) - real(r8), allocatable :: hydr_thetas_node(:,:) ! saturated water content (cm3/cm3) real(r8), allocatable :: hydr_epsil_node(:,:) ! bulk elastic modulus (MPa) real(r8), allocatable :: hydr_pitlp_node(:,:) ! turgor loss point (MPa) - real(r8), allocatable :: hydr_resid_node(:,:) ! residual fraction (fraction) real(r8), allocatable :: hydr_fcap_node(:,:) ! fraction of (1-resid_node) that is capillary in source real(r8), allocatable :: hydr_pinot_node(:,:) ! osmotic potential at full turgor real(r8), allocatable :: hydr_kmax_node(:,:) ! maximum xylem conductivity per unit conducting xylem area + ! Parameters for both VG and TFS PV-PK curves + real(r8), allocatable :: hydr_resid_node(:,:) ! residual fraction (fraction) + real(r8), allocatable :: hydr_thetas_node(:,:) ! saturated water content (cm3/cm3) + + ! Table that maps HLM pfts to FATES pfts for fixed biogeography mode + ! The values are area fractions (NOT IMPLEMENTED) + real(r8), allocatable :: hlm_pft_map(:,:) contains @@ -224,7 +232,7 @@ module EDPftvarcon procedure, private :: Register_PFT procedure, private :: Receive_PFT procedure, private :: Register_PFT_hydr_organs - procedure, private :: Receive_PFT_hydr_organs + procedure, private :: Receive_PFT_hydr_organs procedure, private :: Register_PFT_leafage procedure, private :: Receive_PFT_leafage procedure, private :: Register_PFT_numrad @@ -269,7 +277,7 @@ subroutine Register(this, fates_params) call this%Register_PFT_numrad(fates_params) call this%Register_PFT_hydr_organs(fates_params) call this%Register_PFT_leafage(fates_params) - + end subroutine Register !----------------------------------------------------------------------- @@ -294,6 +302,7 @@ subroutine Register_PFT(this, fates_params) use FatesParametersInterface, only : fates_parameters_type, param_string_length use FatesParametersInterface, only : dimension_name_pft, dimension_shape_1d + use FatesParametersInterface, only : dimension_name_hlm_pftno, dimension_shape_2d implicit none @@ -301,9 +310,11 @@ subroutine Register_PFT(this, fates_params) class(fates_parameters_type), intent(inout) :: fates_params character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_pft/) + character(len=param_string_length) :: pftmap_dim_names(2) integer, parameter :: dim_lower_bound(1) = (/ lower_bound_pft /) + character(len=param_string_length) :: name !X! name = '' @@ -318,10 +329,6 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_fire_crown_depth_frac' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_fire_bark_scaler' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -345,7 +352,7 @@ subroutine Register_PFT(this, fates_params) name = 'fates_leaf_stomatal_slope_medlyn' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_leaf_stomatal_intercept' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -398,7 +405,7 @@ subroutine Register_PFT(this, fates_params) name = 'fates_maintresp_reduction_curvature' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_maintresp_reduction_intercept' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -422,7 +429,7 @@ subroutine Register_PFT(this, fates_params) name = 'fates_prescribed_recruitment' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_fire_alpha_SH' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -446,31 +453,19 @@ subroutine Register_PFT(this, fates_params) name = 'fates_hydr_rfrac_stem' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_hydr_alpha_vg' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_hydr_m_vg' + name = 'fates_hydr_avuln_gs' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_hydr_n_vg' + name = 'fates_hydr_p50_gs' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'fates_hydr_k_lwp' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) + dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_hydr_avuln_gs' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_hydr_p50_gs' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_mort_bmort' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -506,11 +501,11 @@ subroutine Register_PFT(this, fates_params) name = 'fates_mort_hf_sm_threshold' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_mort_hf_flc_threshold' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_leaf_vcmaxha' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -519,10 +514,6 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_leaf_tpuha' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_leaf_vcmaxhd' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -531,10 +522,6 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_leaf_tpuhd' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_leaf_vcmaxse' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -543,10 +530,6 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_leaf_tpuse' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_seed_germination_rate' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -558,11 +541,11 @@ subroutine Register_PFT(this, fates_params) name = 'fates_trim_limit' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_trim_inc' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_leaf_diameter' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -578,11 +561,11 @@ subroutine Register_PFT(this, fates_params) name = 'fates_phenflush_fraction' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_phen_cold_size_threshold' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_phen_stem_drop_fraction' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -593,35 +576,35 @@ subroutine Register_PFT(this, fates_params) name = 'fates_eca_decompmicc' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_eca_km_nh4' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_eca_vmax_nh4' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_eca_km_no3' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_eca_vmax_no3' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_eca_km_p' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_eca_vmax_p' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_eca_km_ptase' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_eca_vmax_ptase' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -633,15 +616,27 @@ subroutine Register_PFT(this, fates_params) name = 'fates_eca_lambda_ptase' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_prescribed_nuptake' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'fates_prescribed_puptake' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dev_arbitrary_pft' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + ! adding the hlm_pft_map variable with two dimensions - FATES PFTno and HLM PFTno + pftmap_dim_names(1) = dimension_name_pft + pftmap_dim_names(2) = dimension_name_hlm_pftno + + name = 'fates_hlm_pft_map' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=pftmap_dim_names, lower_bounds=dim_lower_bound) + end subroutine Register_PFT !----------------------------------------------------------------------- @@ -668,10 +663,6 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%hgt_min) - name = 'fates_fire_crown_depth_frac' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%crown) - name = 'fates_fire_bark_scaler' call fates_params%RetreiveParameterAllocate(name=name, & data=this%bark_scaler) @@ -692,14 +683,14 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%bb_slope) - name = 'fates_leaf_stomatal_slope_medlyn' + name = 'fates_leaf_stomatal_slope_medlyn' call fates_params%RetreiveParameterAllocate(name=name, & data=this%medlyn_slope) name = 'fates_leaf_stomatal_intercept' call fates_params%RetreiveParameterAllocate(name=name, & data=this%stomatal_intercept) - + name = 'fates_lf_flab' call fates_params%RetreiveParameterAllocate(name=name, & data=this%lf_flab) @@ -778,7 +769,7 @@ subroutine Receive_PFT(this, fates_params) name = 'fates_allom_frbstor_repro' call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_frbstor_repro) + data=this%allom_frbstor_repro) name = 'fates_hydr_p_taper' call fates_params%RetreiveParameterAllocate(name=name, & @@ -787,35 +778,31 @@ subroutine Receive_PFT(this, fates_params) name = 'fates_hydr_rs2' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_rs2) - + name = 'fates_hydr_srl' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_srl) - + name = 'fates_hydr_rfrac_stem' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_rfrac_stem) - name = 'fates_hydr_alpha_vg' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%hydr_alpha_vg) - - name = 'fates_hydr_m_vg' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%hydr_m_vg) - - name = 'fates_hydr_n_vg' + name = 'fates_hydr_k_lwp' call fates_params%RetreiveParameterAllocate(name=name, & - data=this%hydr_n_vg) + data=this%hydr_k_lwp) name = 'fates_hydr_avuln_gs' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_avuln_gs) - + name = 'fates_hydr_p50_gs' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_p50_gs) + name = 'fates_hydr_k_lwp' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_k_lwp) + name = 'fates_mort_bmort' call fates_params%RetreiveParameterAllocate(name=name, & data=this%bmort) @@ -832,6 +819,7 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%mort_scalar_hydrfailure) + name = 'fates_mort_ip_size_senescence' call fates_params%RetreiveParameterAllocate(name=name, & data=this%mort_ip_size_senescence) @@ -847,7 +835,7 @@ subroutine Receive_PFT(this, fates_params) name = 'fates_mort_r_age_senescence' call fates_params%RetreiveParameterAllocate(name=name, & data=this%mort_r_age_senescence) - + name = 'fates_mort_scalar_coldstress' call fates_params%RetreiveParameterAllocate(name=name, & data=this%mort_scalar_coldstress) @@ -855,15 +843,16 @@ subroutine Receive_PFT(this, fates_params) name = 'fates_mort_scalar_cstarvation' call fates_params%RetreiveParameterAllocate(name=name, & data=this%mort_scalar_cstarvation) - + + name = 'fates_mort_hf_sm_threshold' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hf_sm_threshold) - + name = 'fates_mort_hf_flc_threshold' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hf_flc_threshold) - + name = 'fates_leaf_vcmaxha' call fates_params%RetreiveParameterAllocate(name=name, & data=this%vcmaxha) @@ -872,10 +861,6 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%jmaxha) - name = 'fates_leaf_tpuha' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%tpuha) - name = 'fates_leaf_vcmaxhd' call fates_params%RetreiveParameterAllocate(name=name, & data=this%vcmaxhd) @@ -884,10 +869,6 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%jmaxhd) - name = 'fates_leaf_tpuhd' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%tpuhd) - name = 'fates_leaf_vcmaxse' call fates_params%RetreiveParameterAllocate(name=name, & data=this%vcmaxse) @@ -896,10 +877,6 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%jmaxse) - name = 'fates_leaf_tpuse' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%tpuse) - name = 'fates_seed_germination_rate' call fates_params%RetreiveParameterAllocate(name=name, & data=this%germination_rate) @@ -931,11 +908,11 @@ subroutine Receive_PFT(this, fates_params) name = 'fates_phenflush_fraction' call fates_params%RetreiveParameterAllocate(name=name, & data=this%phenflush_fraction) - + name = 'fates_phen_cold_size_threshold' call fates_params%RetreiveParameterAllocate(name=name, & data=this%phen_cold_size_threshold) - + name = 'fates_phen_stem_drop_fraction' call fates_params%RetreiveParameterAllocate(name=name, & data=this%phen_stem_drop_fraction) @@ -947,7 +924,11 @@ subroutine Receive_PFT(this, fates_params) name = 'fates_prescribed_puptake' call fates_params%RetreiveParameterAllocate(name=name, & data=this%prescribed_puptake) - + + name = 'fates_dev_arbitrary_pft' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dev_arbitrary_pft) + name = 'fates_eca_decompmicc' call fates_params%RetreiveParameterAllocate(name=name, & data=this%decompmicc) @@ -955,11 +936,11 @@ subroutine Receive_PFT(this, fates_params) name = 'fates_eca_km_nh4' call fates_params%RetreiveParameterAllocate(name=name, & data=this%eca_km_nh4) - + name = 'fates_eca_vmax_nh4' call fates_params%RetreiveParameterAllocate(name=name, & data=this%eca_vmax_nh4) - + name = 'fates_eca_km_no3' call fates_params%RetreiveParameterAllocate(name=name, & data=this%eca_km_no3) @@ -992,6 +973,10 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%eca_lambda_ptase) + name = 'fates_hlm_pft_map' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hlm_pft_map) + end subroutine Receive_PFT !----------------------------------------------------------------------- @@ -1048,7 +1033,7 @@ subroutine Register_PFT_numrad(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names) - + end subroutine Register_PFT_numrad @@ -1102,7 +1087,7 @@ subroutine Receive_PFT_numrad(this, fates_params) ! received rhol data ! allocate(this%rhol(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) - + name = 'fates_rholvis' call fates_params%RetreiveParameter(name=name, & data=dummy_data) @@ -1117,7 +1102,7 @@ subroutine Receive_PFT_numrad(this, fates_params) ! received rhos data ! allocate(this%rhos(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) - + name = 'fates_rhosvis' call fates_params%RetreiveParameter(name=name, & data=dummy_data) @@ -1132,7 +1117,7 @@ subroutine Receive_PFT_numrad(this, fates_params) ! received taul data ! allocate(this%taul(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) - + name = 'fates_taulvis' call fates_params%RetreiveParameter(name=name, & data=dummy_data) @@ -1147,7 +1132,7 @@ subroutine Receive_PFT_numrad(this, fates_params) ! received taus data ! allocate(this%taus(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) - + name = 'fates_tausvis' call fates_params%RetreiveParameter(name=name, & data=dummy_data) @@ -1168,7 +1153,7 @@ subroutine Register_PFT_leafage(this, fates_params) use FatesParametersInterface, only : fates_parameters_type, param_string_length use FatesParametersInterface, only : max_dimensions, dimension_name_leaf_age use FatesParametersInterface, only : dimension_name_pft, dimension_shape_2d - + implicit none class(EDPftvarcon_type), intent(inout) :: this @@ -1184,25 +1169,28 @@ subroutine Register_PFT_leafage(this, fates_params) name = 'fates_leaf_vcmax25top' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + return end subroutine Register_PFT_leafage + + + ! ===================================================================================== subroutine Receive_PFT_leafage(this, fates_params) - + use FatesParametersInterface, only : fates_parameters_type use FatesParametersInterface, only : param_string_length - + implicit none - + class(EDPftvarcon_type), intent(inout) :: this class(fates_parameters_type), intent(inout) :: fates_params - + character(len=param_string_length) :: name - + name = 'fates_leaf_vcmax25top' call fates_params%RetreiveParameterAllocate(name=name, & data=this%vcmax25top) @@ -1232,10 +1220,22 @@ subroutine Register_PFT_hydr_organs(this, fates_params) dim_names(1) = dimension_name_pft dim_names(2) = dimension_name_hydr_organs + name = 'fates_hydr_vg_alpha_node' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hydr_vg_m_node' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hydr_vg_n_node' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_hydr_avuln_node' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_hydr_p50_node' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -1263,28 +1263,52 @@ subroutine Register_PFT_hydr_organs(this, fates_params) name = 'fates_hydr_pinot_node' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_hydr_kmax_node' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + + name = 'fates_hydr_vg_alpha_node' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hydr_vg_m_node' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hydr_vg_n_node' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) end subroutine Register_PFT_hydr_organs !----------------------------------------------------------------------- subroutine Receive_PFT_hydr_organs(this, fates_params) - + use FatesParametersInterface, only : fates_parameters_type use FatesParametersInterface, only : param_string_length - + implicit none - + class(EDPftvarcon_type), intent(inout) :: this class(fates_parameters_type), intent(inout) :: fates_params - + character(len=param_string_length) :: name - + + + name = 'fates_hydr_vg_alpha_node' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_vg_alpha_node) + + name = 'fates_hydr_vg_m_node' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_vg_m_node) + + name = 'fates_hydr_vg_n_node' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_vg_n_node) + name = 'fates_hydr_avuln_node' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_avuln_node) @@ -1296,19 +1320,19 @@ subroutine Receive_PFT_hydr_organs(this, fates_params) name = 'fates_hydr_thetas_node' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_thetas_node) - + name = 'fates_hydr_epsil_node' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_epsil_node) - + name = 'fates_hydr_pitlp_node' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_pitlp_node) - + name = 'fates_hydr_resid_node' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_resid_node) - + name = 'fates_hydr_fcap_node' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_fcap_node) @@ -1321,12 +1345,24 @@ subroutine Receive_PFT_hydr_organs(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_kmax_node) + name = 'fates_hydr_vg_alpha_node' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_vg_alpha_node) + + name = 'fates_hydr_vg_m_node' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_vg_m_node) + + name = 'fates_hydr_vg_n_node' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_vg_n_node) + end subroutine Receive_PFT_hydr_organs ! =============================================================================================== - + subroutine FatesReportPFTParams(is_master) - + ! Argument logical, intent(in) :: is_master ! Only log if this is the master proc @@ -1334,11 +1370,11 @@ subroutine FatesReportPFTParams(is_master) character(len=32),parameter :: fmt0 = '(a,100(F12.4,1X))' integer :: npft,ipft - + npft = size(EDPftvarcon_inst%initd,1) - + if(debug_report .and. is_master) then - + if(npft>100)then write(fates_log(),*) 'you are trying to report pft parameters during initialization' write(fates_log(),*) 'but you have so many that it is over-running the format spec' @@ -1352,13 +1388,12 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'dleaf = ',EDPftvarcon_inst%dleaf write(fates_log(),fmt0) 'z0mr = ',EDPftvarcon_inst%z0mr write(fates_log(),fmt0) 'displar = ',EDPftvarcon_inst%displar - write(fates_log(),fmt0) 'crown = ',EDPftvarcon_inst%crown write(fates_log(),fmt0) 'bark_scaler = ',EDPftvarcon_inst%bark_scaler write(fates_log(),fmt0) 'crown_kill = ',EDPftvarcon_inst%crown_kill write(fates_log(),fmt0) 'initd = ',EDPftvarcon_inst%initd write(fates_log(),fmt0) 'seed_suppl = ',EDPftvarcon_inst%seed_suppl write(fates_log(),fmt0) 'bb_slope = ',EDPftvarcon_inst%bb_slope - write(fates_log(),fmt0) 'medlyn_slope = ',EDPftvarcon_inst%medlyn_slope + write(fates_log(),fmt0) 'medlyn_slope = ',EDPftvarcon_inst%medlyn_slope write(fates_log(),fmt0) 'stomatal_intercept = ',EDPftvarcon_inst%stomatal_intercept write(fates_log(),fmt0) 'lf_flab = ',EDPftvarcon_inst%lf_flab write(fates_log(),fmt0) 'lf_fcel = ',EDPftvarcon_inst%lf_fcel @@ -1376,7 +1411,7 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'mort_ip_size_senescence = ', EDPftvarcon_inst%mort_ip_size_senescence write(fates_log(),fmt0) 'mort_r_size_senescence = ', EDPftvarcon_inst%mort_r_size_senescence write(fates_log(),fmt0) 'mort_ip_age_senescence = ', EDPftvarcon_inst%mort_ip_age_senescence - write(fates_log(),fmt0) 'mort_r_age_senescence = ', EDPftvarcon_inst%mort_r_age_senescence + write(fates_log(),fmt0) 'mort_r_age_senescence = ', EDPftvarcon_inst%mort_r_age_senescence write(fates_log(),fmt0) 'mort_scalar_coldstress = ',EDPftvarcon_inst%mort_scalar_coldstress write(fates_log(),fmt0) 'mort_scalar_cstarvation = ',EDPftvarcon_inst%mort_scalar_cstarvation write(fates_log(),fmt0) 'mort_scalar_hydrfailure = ',EDPftvarcon_inst%mort_scalar_hydrfailure @@ -1384,44 +1419,44 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'hf_flc_threshold = ',EDPftvarcon_inst%hf_flc_threshold write(fates_log(),fmt0) 'vcmaxha = ',EDPftvarcon_inst%vcmaxha write(fates_log(),fmt0) 'jmaxha = ',EDPftvarcon_inst%jmaxha - write(fates_log(),fmt0) 'tpuha = ',EDPftvarcon_inst%tpuha write(fates_log(),fmt0) 'vcmaxhd = ',EDPftvarcon_inst%vcmaxhd write(fates_log(),fmt0) 'jmaxhd = ',EDPftvarcon_inst%jmaxhd - write(fates_log(),fmt0) 'tpuhd = ',EDPftvarcon_inst%tpuhd write(fates_log(),fmt0) 'vcmaxse = ',EDPftvarcon_inst%vcmaxse write(fates_log(),fmt0) 'jmaxse = ',EDPftvarcon_inst%jmaxse - write(fates_log(),fmt0) 'tpuse = ',EDPftvarcon_inst%tpuse write(fates_log(),fmt0) 'germination_timescale = ',EDPftvarcon_inst%germination_rate write(fates_log(),fmt0) 'seed_decay_turnover = ',EDPftvarcon_inst%seed_decay_rate write(fates_log(),fmt0) 'trim_limit = ',EDPftvarcon_inst%trim_limit write(fates_log(),fmt0) 'trim_inc = ',EDPftvarcon_inst%trim_inc write(fates_log(),fmt0) 'rhol = ',EDPftvarcon_inst%rhol write(fates_log(),fmt0) 'rhos = ',EDPftvarcon_inst%rhos - write(fates_log(),fmt0) 'taul = ',EDPftvarcon_inst%taul + write(fates_log(),fmt0) 'taul = ',EDPftvarcon_inst%taul write(fates_log(),fmt0) 'taus = ',EDPftvarcon_inst%taus write(fates_log(),fmt0) 'phenflush_fraction',EDpftvarcon_inst%phenflush_fraction write(fates_log(),fmt0) 'phen_cold_size_threshold = ',EDPftvarcon_inst%phen_cold_size_threshold write(fates_log(),fmt0) 'phen_stem_drop_fraction',EDpftvarcon_inst%phen_stem_drop_fraction write(fates_log(),fmt0) 'fire_alpha_SH = ',EDPftvarcon_inst%fire_alpha_SH - write(fates_log(),fmt0) 'allom_frbstor_repro = ',EDPftvarcon_inst%allom_frbstor_repro + write(fates_log(),fmt0) 'allom_frbstor_repro = ',EDPftvarcon_inst%allom_frbstor_repro write(fates_log(),fmt0) 'hydr_p_taper = ',EDPftvarcon_inst%hydr_p_taper write(fates_log(),fmt0) 'hydr_rs2 = ',EDPftvarcon_inst%hydr_rs2 write(fates_log(),fmt0) 'hydr_srl = ',EDPftvarcon_inst%hydr_srl write(fates_log(),fmt0) 'hydr_rfrac_stem = ',EDPftvarcon_inst%hydr_rfrac_stem + write(fates_log(),fmt0) 'hydr_avuln_gs = ',EDPftvarcon_inst%hydr_avuln_gs write(fates_log(),fmt0) 'hydr_k_lwp = ',EDPftvarcon_inst%hydr_k_lwp - write(fates_log(),fmt0) 'hydr_alpha_vg = ',EDPftvarcon_inst%hydr_alpha_vg - write(fates_log(),fmt0) 'hydr_m_vg = ',EDPftvarcon_inst%hydr_m_vg - write(fates_log(),fmt0) 'hydr_n_vg = ',EDPftvarcon_inst%hydr_n_vg write(fates_log(),fmt0) 'hydr_p50_gs = ',EDPftvarcon_inst%hydr_p50_gs + write(fates_log(),fmt0) 'hydr_k_lwp = ',EDPftvarcon_inst%hydr_k_lwp write(fates_log(),fmt0) 'hydr_avuln_node = ',EDPftvarcon_inst%hydr_avuln_node write(fates_log(),fmt0) 'hydr_p50_node = ',EDPftvarcon_inst%hydr_p50_node - write(fates_log(),fmt0) 'hydr_thetas_node = ',EDPftvarcon_inst%hydr_thetas_node + write(fates_log(),fmt0) 'hydr_thetas_node = ',EDPftvarcon_inst%hydr_thetas_node write(fates_log(),fmt0) 'hydr_epsil_node = ',EDPftvarcon_inst%hydr_epsil_node write(fates_log(),fmt0) 'hydr_pitlp_node = ',EDPftvarcon_inst%hydr_pitlp_node write(fates_log(),fmt0) 'hydr_resid_node = ',EDPftvarcon_inst%hydr_resid_node write(fates_log(),fmt0) 'hydr_fcap_node = ',EDPftvarcon_inst%hydr_fcap_node write(fates_log(),fmt0) 'hydr_pinot_node = ',EDPftvarcon_inst%hydr_pinot_node write(fates_log(),fmt0) 'hydr_kmax_node = ',EDPftvarcon_inst%hydr_kmax_node + write(fates_log(),fmt0) 'hlm_pft_map = ', EDPftvarcon_inst%hlm_pft_map + write(fates_log(),fmt0) 'hydr_vg_alpha_node = ',EDPftvarcon_inst%hydr_vg_alpha_node + write(fates_log(),fmt0) 'hydr_vg_m_node = ',EDPftvarcon_inst%hydr_vg_m_node + write(fates_log(),fmt0) 'hydr_vg_n_node = ',EDPftvarcon_inst%hydr_vg_n_node write(fates_log(),*) '-------------------------------------------------' end if @@ -1436,7 +1471,7 @@ subroutine FatesCheckParams(is_master) ! ---------------------------------------------------------------------------------- ! ! This subroutine performs logical checks on user supplied parameters. It cross - ! compares various parameters and will fail if they don't make sense. + ! compares various parameters and will fail if they don't make sense. ! Examples: ! A tree can not be defined as both evergreen and deciduous. A woody plant ! cannot have a structural biomass allometry intercept of 0, and a non-woody @@ -1445,7 +1480,8 @@ subroutine FatesCheckParams(is_master) use FatesConstantsMod , only : fates_check_param_set use FatesConstantsMod , only : itrue, ifalse use EDParamsMod , only : logging_mechanical_frac, logging_collateral_frac, logging_direct_frac - + use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog + ! Argument logical, intent(in) :: is_master ! Only log if this is the master proc @@ -1456,6 +1492,10 @@ subroutine FatesCheckParams(is_master) integer :: nleafage ! size of the leaf age class array integer :: iage ! leaf age class index integer :: norgans ! size of the plant organ dimension + integer :: hlm_pft ! used in fixed biogeog mode + integer :: fates_pft ! used in fixed biogeog mode + + real(r8) :: sumarea ! area of PFTs in nocomp mode. npft = size(EDPftvarcon_inst%freezetol,1) @@ -1463,9 +1503,9 @@ subroutine FatesCheckParams(is_master) if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then - + ! Check to see if either RD/ECA/MIC is turned on - + if (.not.( (trim(hlm_nu_com).eq.'RD') .or. (trim(hlm_nu_com).eq.'ECA'))) then write(fates_log(),*) 'FATES PARTEH with allometric flexible CNP must have' write(fates_log(),*) 'a valid BGC model enabled: RD,ECA,MIC or SYN' @@ -1473,19 +1513,19 @@ subroutine FatesCheckParams(is_master) write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + ! If nitrogen is turned on, check to make sure there are valid ammonium ! parameters if(hlm_nitrogen_spec>0)then if (trim(hlm_nu_com).eq.'ECA') then - + if(any(EDpftvarcon_inst%eca_km_nh4(:)<0._r8) ) then write(fates_log(),*) 'ECA with nitrogen is turned on' write(fates_log(),*) 'bad ECA km value(s) for nh4: ',EDpftvarcon_inst%eca_km_nh4(:) write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + if(hlm_nitrogen_spec==2)then if(any(EDpftvarcon_inst%eca_km_no3(:)<0._r8)) then write(fates_log(),*) 'ECA with nit/denitr is turned on' @@ -1497,9 +1537,9 @@ subroutine FatesCheckParams(is_master) end if end if - + elseif (hlm_parteh_mode .ne. prt_carbon_allom_hyp) then - + write(fates_log(),*) 'FATES Plant Allocation and Reactive Transport has' write(fates_log(),*) 'only 2 modules supported, allometric carbon and CNP.' write(fates_log(),*) 'fates_parteh_mode must be set to 1 or 2 in the namelist' @@ -1509,7 +1549,7 @@ subroutine FatesCheckParams(is_master) ! If any PFTs are specified as either prescribed N or P uptake ! then they all must be ! - + if (any(EDPftvarcon_inst%prescribed_nuptake(:) < -nearzero ) .or. & any(EDPftvarcon_inst%prescribed_nuptake(:) > 10._r8 ) ) then write(fates_log(),*) 'Negative values for EDPftvarcon_inst%prescribed_nuptake(:)' @@ -1540,7 +1580,7 @@ subroutine FatesCheckParams(is_master) write(fates_log(),*) 'Exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) endif - + ! Same for phosphorus if (any(EDPftvarcon_inst%prescribed_puptake(:) < -nearzero ) .or. & any(EDPftvarcon_inst%prescribed_puptake(:) > 10._r8 )) then @@ -1564,14 +1604,14 @@ subroutine FatesCheckParams(is_master) else p_uptake_mode = coupled_p_uptake end if - - + + do ipft = 1,npft - - ! Check that parameter ranges for age-dependent mortality make sense - !----------------------------------------------------------------------------------- + + ! Check that parameter ranges for age-dependent mortality make sense + !----------------------------------------------------------------------------------- if ( ( EDPftvarcon_inst%mort_ip_age_senescence(ipft) < fates_check_param_set ) .and. & ( EDPftvarcon_inst%mort_r_age_senescence(ipft) > fates_check_param_set ) ) then @@ -1582,8 +1622,8 @@ subroutine FatesCheckParams(is_master) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - ! Check that parameter ranges for size-dependent mortality make sense - !----------------------------------------------------------------------------------- + ! Check that parameter ranges for size-dependent mortality make sense + !----------------------------------------------------------------------------------- if ( ( EDPftvarcon_inst%mort_ip_size_senescence(ipft) < fates_check_param_set ) .and. & ( EDPftvarcon_inst%mort_r_size_senescence(ipft) > fates_check_param_set ) ) then @@ -1594,8 +1634,8 @@ subroutine FatesCheckParams(is_master) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - ! Check that parameter ranges for size-dependent mortality make sense - !----------------------------------------------------------------------------------- + ! Check that parameter ranges for size-dependent mortality make sense + !----------------------------------------------------------------------------------- if ( ( EDPftvarcon_inst%mort_ip_size_senescence(ipft) < 0.0_r8 ) .or. & ( EDPftvarcon_inst%mort_r_size_senescence(ipft) < 0.0_r8 ) ) then @@ -1608,8 +1648,8 @@ subroutine FatesCheckParams(is_master) end if - ! Check that parameter ranges for size-dependent mortality make sense - !----------------------------------------------------------------------------------- + ! Check that parameter ranges for size-dependent mortality make sense + !----------------------------------------------------------------------------------- if ( ( EDPftvarcon_inst%mort_ip_size_senescence(ipft) < 0.0_r8 ) .or. & ( EDPftvarcon_inst%mort_r_size_senescence(ipft) < 0.0_r8 ) ) then @@ -1624,10 +1664,10 @@ subroutine FatesCheckParams(is_master) ! Check if the fraction of storage used for flushing deciduous trees ! is greater than zero, and less than or equal to 1. - if ( int(prt_params%evergreen(ipft)) .ne. 1 ) then + if ( int(prt_params%evergreen(ipft)) .ne. 1 ) then if ( ( EDPftvarcon_inst%phenflush_fraction(ipft) < nearzero ) .or. & ( EDPFtvarcon_inst%phenflush_fraction(ipft) > 1 ) ) then - + write(fates_log(),*) ' Deciduous plants must flush some storage carbon' write(fates_log(),*) ' on bud-burst. If phenflush_fraction is not greater than 0' write(fates_log(),*) ' it will not be able to put out any leaves. Plants need leaves.' @@ -1646,13 +1686,13 @@ subroutine FatesCheckParams(is_master) write(fates_log(),*) ' phen_stem_drop_fraction: ', EDPFtvarcon_inst%phen_stem_drop_fraction(ipft) write(fates_log(),*) ' Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + end if end if - + ! Check if freezing tolerance is within reasonable bounds ! ---------------------------------------------------------------------------------- - + if ( ( EDPftvarcon_inst%freezetol(ipft) > 60.0_r8 ) .or. & ( EDPFtvarcon_inst%freezetol(ipft) < -273.1_r8 ) ) then @@ -1668,11 +1708,11 @@ subroutine FatesCheckParams(is_master) end if - + ! Check if fraction of storage to reproduction is between 0-1 ! ---------------------------------------------------------------------------------- - + if ( ( EDPftvarcon_inst%allom_frbstor_repro(ipft) < 0.0_r8 ) .or. & ( EDPftvarcon_inst%allom_frbstor_repro(ipft) > 1.0_r8 ) ) then @@ -1685,11 +1725,11 @@ subroutine FatesCheckParams(is_master) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + ! Check if photosynthetic pathway is neither C3/C4 ! ---------------------------------------------------------------------------------- - + if ( ( EDPftvarcon_inst%c3psn(ipft) < 0.0_r8 ) .or. & ( EDPftvarcon_inst%c3psn(ipft) > 1.0_r8 ) ) then @@ -1703,13 +1743,29 @@ subroutine FatesCheckParams(is_master) end if - end do + if( hlm_use_fixed_biogeog .eq. itrue ) then + ! check that the host-fates PFT map adds to one along HLM dimension so that all the HLM area + ! goes to a FATES PFT. Each FATES PFT can get < or > 1 of an HLM PFT. + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft)) + if(abs(sumarea-1.0_r8).gt.nearzero)then + write(fates_log(),*) 'The distribution of this host land model PFT :',hlm_pft + write(fates_log(),*) 'into FATES PFTs, does not add up to 1.0.' + write(fates_log(),*) 'Error is:',sumarea-1.0_r8 + write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft) + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do !hlm_pft + end if + + end do !ipft !! ! 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 @@ -1734,7 +1790,7 @@ end subroutine FatesCheckParams ! ===================================================================================== function GetDecompyFrac(pft,organ_id,dcmpy) result(decompy_frac) - + ! This simple routine matches the correct decomposibility pool's ! material fraction with the pft parameter data. @@ -1742,8 +1798,8 @@ function GetDecompyFrac(pft,organ_id,dcmpy) result(decompy_frac) integer, intent(in) :: pft integer, intent(in) :: organ_id integer, intent(in) :: dcmpy - real(r8) :: decompy_frac - + real(r8) :: decompy_frac + ! Decomposability for leaves if(organ_id == leaf_organ)then select case(dcmpy) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 057b1340ca..ac3a34f635 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -18,6 +18,8 @@ module EDTypesMod use FatesLitterMod, only : ncwd use FatesConstantsMod, only : n_anthro_disturbance_categories use FatesConstantsMod, only : days_per_year + use FatesInterfaceTypesMod,only : bc_in_type + use FatesInterfaceTypesMod,only : bc_out_type implicit none private ! By default everything is private @@ -41,7 +43,8 @@ module EDTypesMod ! space and output arrays. - + real(r8), parameter, public :: init_recruit_trim = 0.8_r8 ! This is the initial trimming value that + ! new recruits start with ! ------------------------------------------------------------------------------------- ! Radiation parameters @@ -171,8 +174,7 @@ module EDTypesMod ! if the fusion area is less than min_patch_area_forced real(r8), parameter, public :: min_nppatch = min_npm2*min_patch_area ! minimum number of cohorts per patch (min_npm2*min_patch_area) - ! Junyan changed the min_n_safemath below , original is 1.0E-12_r8 - real(r8), parameter, public :: min_n_safemath = 1.0E-9_r8 ! in some cases, we want to immediately remove super small, + real(r8), parameter, public :: min_n_safemath = 1.0E-12_r8 ! in some cases, we want to immediately remove super small ! number densities of cohorts to prevent FPEs character*4 yearchar @@ -283,21 +285,19 @@ module EDTypesMod ! Nutrient Fluxes (if N, P, etc. are turned on) - real(r8) :: daily_n_uptake ! integrated daily uptake of mineralized N through competitive acquisition in soil [kg N / plant/ day] + real(r8) :: daily_nh4_uptake ! integrated daily uptake of mineralized ammonium through competitive acquisition in soil [kg N / plant/ day] + real(r8) :: daily_no3_uptake ! integrated daily uptake of mineralized nitrate through competitive acquisition in soil [kg N / plant/ day] real(r8) :: daily_p_uptake ! integrated daily uptake of mineralized P through competitive acquisition in soil [kg P / plant/ day] real(r8) :: daily_c_efflux ! daily mean efflux of excess carbon from roots into labile pool [kg C/plant/day] real(r8) :: daily_n_efflux ! daily mean efflux of excess nitrogen from roots into labile pool [kg N/plant/day] real(r8) :: daily_p_efflux ! daily mean efflux of excess phophorus from roots into labile pool [kg P/plant/day] - real(r8) :: daily_n_need1 ! Nitrogen needed to enable non-limited C growth (AllometricCNP hypothesis) - real(r8) :: daily_n_need2 ! Nitrogen needed to bring N concentrations up to optimal - real(r8) :: daily_p_need1 ! Phosphorus needed to enable non-limited C growth (AllometricCNP hypothesis) - real(r8) :: daily_p_need2 ! Phosphorus needed to bring P concentrations up to optimal + real(r8) :: daily_n_need ! Generic Nitrogen need of the plant, (hypothesis dependent) [kgN/plant/day] + real(r8) :: daily_p_need ! Generic Phosphorus need of the plant, (hypothesis dependent) [kgN/plant/day] + ! These two variables may use the previous "need" variables, by applying a smoothing function. - ! Or, its possible that the plant will use another method to calculate this, perhaps based - ! on storage. ! These variables are used in two scenarios. 1) They work with the prescribed uptake fraction ! in un-coupled mode, and 2) They are the plant's demand subbmitted to the Relative-Demand ! type soil BGC scheme. @@ -411,7 +411,7 @@ module EDTypesMod integer :: ncl_p ! Number of occupied canopy layers integer :: anthro_disturbance_label ! patch label for anthropogenic disturbance classification real(r8) :: age_since_anthro_disturbance ! average age for secondary forest since last anthropogenic disturbance - + integer :: nocomp_pft_label ! where nocomp is active, use this label for patch ID. ! LEAF ORGANIZATION real(r8) :: pft_agb_profile(maxpft,n_dbh_bins) ! binned above ground biomass, for patch fusion: KgC/m2 real(r8) :: canopy_layer_tlai(nclmax) ! total leaf area index of each canopy layer @@ -529,8 +529,6 @@ module EDTypesMod real(r8),allocatable :: fragmentation_scaler(:) ! Scale rate of litter fragmentation based on soil layer. 0 to 1. - real(r8) :: repro(maxpft) ! allocation to reproduction per PFT : KgC/m2 - !FUEL CHARECTERISTICS real(r8) :: sum_fuel ! total ground fuel related to ros (omits 1000hr fuels): KgC/m2 real(r8) :: fuel_frac(nfsc) ! fraction of each litter class in the ros_fuel:-. @@ -603,8 +601,7 @@ module EDTypesMod real(r8),allocatable :: nutrient_uptake_scpf(:) real(r8),allocatable :: nutrient_efflux_scpf(:) - real(r8),allocatable :: nutrient_needgrow_scpf(:) - real(r8),allocatable :: nutrient_needmax_scpf(:) + real(r8),allocatable :: nutrient_need_scpf(:) contains @@ -666,11 +663,6 @@ module EDTypesMod end type site_massbal_type - - - - - !************************************ !** Site type structure ** !************************************ @@ -685,6 +677,14 @@ module EDTypesMod type (ed_resources_management_type) :: resources_management ! resources_management at the site + ! If this simulation uses shared memory then the sites need to know what machine + ! index they are on. This index is (currently) only used to identify the sites + ! position in history output fields + !integer :: clump_id + + ! Global index of this site in the history output file + integer :: h_gid + ! INDICES real(r8) :: lat ! latitude: degrees @@ -694,6 +694,11 @@ module EDTypesMod real(r8), allocatable :: area_PFT(:) ! Area allocated to individual PFTs integer, allocatable :: use_this_pft(:) ! Is area_PFT > 0 ? (1=yes, 0=no) + ! SP mode target PFT level variables + real(r8), allocatable :: sp_tlai(:) ! target TLAI per FATES pft + real(r8), allocatable :: sp_tsai(:) ! target TSAI per FATES pft + real(r8), allocatable :: sp_htop(:) ! target HTOP per FATES pft + ! Mass Balance (allocation for each element) type(site_massbal_type), pointer :: mass_balance(:) @@ -704,6 +709,7 @@ module EDTypesMod ! PHENOLOGY real(r8) :: grow_deg_days ! Phenology growing degree days + real(r8) :: snow_depth ! site-level snow depth (used for ELAI/TLAI calcs) integer :: cstatus ! are leaves in this pixel on or off for cold decid ! 0 = this site has not experienced a cold period over at least @@ -744,7 +750,7 @@ module EDTypesMod real(r8), allocatable :: dz_soil(:) ! layer thickness (m) real(r8), allocatable :: z_soil(:) ! layer depth (m) real(r8), allocatable :: rootfrac_scr(:) ! This is just allocated scratch space to hold - ! root fractions. Since root fractions may be dependant + ! root fractions. Since root fractions may be dependent ! on cohort properties, and we do not want to store this infromation ! on each cohort, we do not keep root fractions in ! memory, and instead calculate them on demand. @@ -836,8 +842,7 @@ subroutine ZeroFluxDiags(this) this%root_litter_input(:) = 0._r8 this%nutrient_uptake_scpf(:) = 0._r8 this%nutrient_efflux_scpf(:) = 0._r8 - this%nutrient_needgrow_scpf(:) = 0._r8 - this%nutrient_needmax_scpf(:) = 0._r8 + this%nutrient_need_scpf(:) = 0._r8 return end subroutine ZeroFluxDiags diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 72e5e09156..931e0882fc 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -1,4 +1,4 @@ -netcdf fates_params_default { +netcdf fates_params_default.c210629_sorted { dimensions: fates_NCWD = 4 ; fates_history_age_bins = 7 ; @@ -9,8 +9,9 @@ dimensions: fates_leafage_class = 1 ; fates_litterclass = 6 ; fates_pft = 12 ; - fates_prt_organs = 6 ; + fates_prt_organs = 4 ; fates_string_length = 60 ; + fates_hlm_pftno = 14 ; variables: double fates_history_ageclass_bin_edges(fates_history_age_bins) ; fates_history_ageclass_bin_edges:units = "yr" ; @@ -24,12 +25,25 @@ variables: double fates_history_sizeclass_bin_edges(fates_history_size_bins) ; fates_history_sizeclass_bin_edges:units = "cm" ; fates_history_sizeclass_bin_edges:long_name = "Lower edges for DBH size class bins used in size-resolved cohort history output" ; + double fates_hydr_htftype_node(fates_hydr_organs) ; + fates_hydr_htftype_node:units = "unitless" ; + fates_hydr_htftype_node:long_name = "Switch that defines the hydraulic transfer functions for each organ." ; + fates_hydr_htftype_node:possible_values = "1: Christofferson et al. 2016 (TFS); 2: Van Genuchten 1980" ; + double fates_prt_organ_id(fates_prt_organs) ; + fates_prt_organ_id:units = "index, unitless" ; + fates_prt_organ_id:long_name = "This is the global index the organ in this file is associated with in PRTGenericMod.F90" ; char fates_pftname(fates_pft, fates_string_length) ; fates_pftname:units = "unitless - string" ; fates_pftname:long_name = "Description of plant type" ; + char fates_hydr_organname_node(fates_hydr_organs, fates_string_length) ; + fates_hydr_organname_node:units = "unitless - string" ; + fates_hydr_organname_node:long_name = "Name of plant hydraulics organs (DONT CHANGE, order matches media list in FatesHydraulicsMemMod.F90)" ; + char fates_litterclass_name(fates_litterclass, fates_string_length) ; + fates_litterclass_name:units = "unitless - string" ; + fates_litterclass_name:long_name = "Name of the litter classes, for variables associated with dimension fates_litterclass" ; char fates_prt_organ_name(fates_prt_organs, fates_string_length) ; fates_prt_organ_name:units = "unitless - string" ; - fates_prt_organ_name:long_name = "Plant organ name (order must match PRTGenericMod.F90)" ; + fates_prt_organ_name:long_name = "Name of plant organs (order must match PRTGenericMod.F90)" ; double fates_alloc_storage_cushion(fates_pft) ; fates_alloc_storage_cushion:units = "fraction" ; fates_alloc_storage_cushion:long_name = "maximum size of storage C pool, relative to maximum size of leaf C pool" ; @@ -121,12 +135,30 @@ variables: fates_allom_stmode:units = "index" ; fates_allom_stmode:long_name = "storage allometry function index." ; fates_allom_stmode:possible_values = "1: target storage proportional to trimmed maximum leaf biomass." ; + double fates_allom_zroot_k(fates_pft) ; + fates_allom_zroot_k:units = "unitless" ; + fates_allom_zroot_k:long_name = "scale coefficient of logistic rooting depth model" ; + double fates_allom_zroot_max_dbh(fates_pft) ; + fates_allom_zroot_max_dbh:units = "cm" ; + fates_allom_zroot_max_dbh:long_name = "dbh at which a plant reaches the maximum value for its maximum rooting depth" ; + double fates_allom_zroot_max_z(fates_pft) ; + fates_allom_zroot_max_z:units = "m" ; + fates_allom_zroot_max_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_max_dbh. note: max_z=min_z=large, sets rooting depth to soil depth" ; + double fates_allom_zroot_min_dbh(fates_pft) ; + fates_allom_zroot_min_dbh:units = "cm" ; + fates_allom_zroot_min_dbh:long_name = "dbh at which the maximum rooting depth for a recruit is defined" ; + double fates_allom_zroot_min_z(fates_pft) ; + fates_allom_zroot_min_z:units = "m" ; + fates_allom_zroot_min_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_min_dbh. note: max_z=min_z=large, sets rooting depth to soil depth" ; double fates_branch_turnover(fates_pft) ; fates_branch_turnover:units = "yr" ; fates_branch_turnover:long_name = "turnover time of branches" ; double fates_c2b(fates_pft) ; fates_c2b:units = "ratio" ; fates_c2b:long_name = "Carbon to biomass multiplier of bulk structural tissues" ; + double fates_dev_arbitrary_pft(fates_pft) ; + fates_dev_arbitrary_pft:units = "unknown" ; + fates_dev_arbitrary_pft:long_name = "Unassociated pft dimensioned free parameter that developers can use for testing arbitrary new hypotheses" ; double fates_displar(fates_pft) ; fates_displar:units = "unitless" ; fates_displar:long_name = "Ratio of displacement height to canopy top height" ; @@ -196,15 +228,6 @@ variables: double fates_grperc(fates_pft) ; fates_grperc:units = "unitless" ; fates_grperc:long_name = "Growth respiration factor" ; - double fates_hydr_alpha_vg(fates_pft) ; - fates_hydr_alpha_vg:units = "MPa-1" ; - fates_hydr_alpha_vg:long_name = "capalary length parameter in van Genuchten model" ; - double fates_hydr_m_vg(fates_pft) ; - fates_hydr_m_vg:units = "unitless" ; - fates_hydr_m_vg:long_name = "m in van Genuchten 1980 model, 2nd pore size distribution parameter" ; - double fates_hydr_n_vg(fates_pft) ; - fates_hydr_n_vg:units = "unitless" ; - fates_hydr_n_vg:long_name = "n in van Genuchten 1980 model, pore size distribution parameter" ; double fates_hydr_k_lwp(fates_pft) ; fates_hydr_k_lwp:units = "unitless" ; fates_hydr_k_lwp:long_name = "inner leaf humidity scale coefficient, between 1 to 10, set to 0 to disable this function" ; @@ -220,6 +243,10 @@ variables: double fates_hydr_fcap_node(fates_hydr_organs, fates_pft) ; fates_hydr_fcap_node:units = "unitless" ; fates_hydr_fcap_node:long_name = "fraction of non-residual water that is capillary in source" ; + double fates_hydr_k_lwp(fates_pft) ; + fates_hydr_k_lwp:units = "unitless" ; + fates_hydr_k_lwp:long_name = "inner leaf humidity scaling coefficient" ; + fates_hydr_k_lwp:possible_values = "0: turns off leaf humidity effects on conductance. 1-10 activates humidity effects" ; double fates_hydr_kmax_node(fates_hydr_organs, fates_pft) ; fates_hydr_kmax_node:units = "kg/MPa/m/s" ; fates_hydr_kmax_node:long_name = "maximum xylem conductivity per unit conducting xylem area" ; @@ -253,6 +280,15 @@ variables: double fates_hydr_thetas_node(fates_hydr_organs, fates_pft) ; fates_hydr_thetas_node:units = "cm3/cm3" ; fates_hydr_thetas_node:long_name = "saturated water content" ; + double fates_hydr_vg_alpha_node(fates_hydr_organs, fates_pft) ; + fates_hydr_vg_alpha_node:units = "MPa-1" ; + fates_hydr_vg_alpha_node:long_name = "(used if hydr_htftype_node = 2), capillary length parameter in van Genuchten model" ; + double fates_hydr_vg_m_node(fates_hydr_organs, fates_pft) ; + fates_hydr_vg_m_node:units = "unitless" ; + fates_hydr_vg_m_node:long_name = "(used if hydr_htftype_node = 2),m in van Genuchten 1980 model, 2nd pore size distribution parameter" ; + double fates_hydr_vg_n_node(fates_hydr_organs, fates_pft) ; + fates_hydr_vg_n_node:units = "unitless" ; + fates_hydr_vg_n_node:long_name = "(used if hydr_htftype_node = 2),n in van Genuchten 1980 model, pore size distribution parameter" ; double fates_leaf_c3psn(fates_pft) ; fates_leaf_c3psn:units = "flag" ; fates_leaf_c3psn:long_name = "Photosynthetic pathway (1=c3, 0=c4)" ; @@ -292,15 +328,6 @@ variables: double fates_leaf_stor_priority(fates_pft) ; fates_leaf_stor_priority:units = "unitless" ; fates_leaf_stor_priority:long_name = "factor governing priority of replacing storage with NPP" ; - double fates_leaf_tpuha(fates_pft) ; - fates_leaf_tpuha:units = "J/mol" ; - fates_leaf_tpuha:long_name = "activation energy for tpu" ; - double fates_leaf_tpuhd(fates_pft) ; - fates_leaf_tpuhd:units = "J/mol" ; - fates_leaf_tpuhd:long_name = "deactivation energy for tpu" ; - double fates_leaf_tpuse(fates_pft) ; - fates_leaf_tpuse:units = "J/mol/K" ; - fates_leaf_tpuse:long_name = "entropy term for tpu" ; double fates_leaf_vcmax25top(fates_leafage_class, fates_pft) ; fates_leaf_vcmax25top:units = "umol CO2/m^2/s" ; fates_leaf_vcmax25top:long_name = "maximum carboxylation rate of Rub. at 25C, canopy top" ; @@ -370,6 +397,9 @@ variables: double fates_nfix2(fates_pft) ; fates_nfix2:units = "NA" ; fates_nfix2:long_name = "place-holder for future n-fixation parameter (NOT IMPLEMENTED)" ; + double fates_nitr_store_ratio(fates_pft) ; + fates_nitr_store_ratio:units = "(gN/gN)" ; + fates_nitr_store_ratio:long_name = "ratio of storeable N, to functional N bound in cell structures of leaf,root,sap" ; double fates_phen_cold_size_threshold(fates_pft) ; fates_phen_cold_size_threshold:units = "cm" ; fates_phen_cold_size_threshold:long_name = "the dbh size above which will lead to phenology-related stem and leaf drop" ; @@ -388,6 +418,9 @@ variables: double fates_phenflush_fraction(fates_pft) ; fates_phenflush_fraction:units = "fraction" ; fates_phenflush_fraction:long_name = "Upon bud-burst, the maximum fraction of storage carbon used for flushing leaves" ; + double fates_phos_store_ratio(fates_pft) ; + fates_phos_store_ratio:units = "(gP/gP)" ; + fates_phos_store_ratio:long_name = "ratio of storeable P, to functional P bound in cell structures of leaf,root,sap" ; double fates_prescribed_mortality_canopy(fates_pft) ; fates_prescribed_mortality_canopy:units = "1/yr" ; fates_prescribed_mortality_canopy:long_name = "mortality rate of canopy trees for prescribed physiology mode" ; @@ -402,16 +435,16 @@ variables: fates_prescribed_npp_understory:long_name = "NPP per unit crown area of understory trees for prescribed physiology mode" ; double fates_prescribed_nuptake(fates_pft) ; fates_prescribed_nuptake:units = "fraction" ; - fates_prescribed_nuptake:long_name = "Nitrogen uptake flux as fraction of NPP demand. 0=fully coupled simulation" ; + fates_prescribed_nuptake:long_name = "Prescribed N uptake flux. 0=fully coupled simulation >0=prescribed (experimental)" ; double fates_prescribed_puptake(fates_pft) ; fates_prescribed_puptake:units = "fraction" ; - fates_prescribed_puptake:long_name = "Phosphorus uptake flux as fraction of NPP demand. 0=fully coupled simulation" ; + fates_prescribed_puptake:long_name = "Prescribed P uptake flux. 0=fully coupled simulation, >0=prescribed (experimental)" ; double fates_prescribed_recruitment(fates_pft) ; fates_prescribed_recruitment:units = "n/yr" ; fates_prescribed_recruitment:long_name = "recruitment rate for prescribed physiology mode" ; double fates_prt_alloc_priority(fates_prt_organs, fates_pft) ; fates_prt_alloc_priority:units = "index (0-fates_prt_organs)" ; - fates_prt_alloc_priority:long_name = "Priority order for allocation" ; + fates_prt_alloc_priority:long_name = "Priority order for allocation (C storage=2)" ; double fates_prt_nitr_stoich_p1(fates_prt_organs, fates_pft) ; fates_prt_nitr_stoich_p1:units = "(gN/gC)" ; fates_prt_nitr_stoich_p1:long_name = "nitrogen stoichiometry, parameter 1" ; @@ -512,6 +545,9 @@ variables: double fates_z0mr(fates_pft) ; fates_z0mr:units = "unitless" ; fates_z0mr:long_name = "Ratio of momentum roughness length to canopy top height" ; + double fates_hlm_pft_map(fates_hlm_pftno, fates_pft) ; + fates_hlm_pft_map:units = "area fraction" ; + fates_hlm_pft_map:long_name = "In fixed biogeog mode, fraction of HLM area associated with each FATES PFT" ; double fates_fire_FBD(fates_litterclass) ; fates_fire_FBD:units = "kg Biomass/m3" ; fates_fire_FBD:long_name = "fuel bulk density" ; @@ -563,6 +599,9 @@ variables: double fates_cwd_flig ; fates_cwd_flig:units = "unitless" ; fates_cwd_flig:long_name = "Lignin fraction of coarse woody debris" ; + double fates_dev_arbitrary ; + fates_dev_arbitrary:units = "unknown" ; + fates_dev_arbitrary:long_name = "Unassociated free parameter that developers can use for testing arbitrary new hypotheses" ; double fates_eca_plant_escalar ; fates_eca_plant_escalar:units = "" ; fates_eca_plant_escalar:long_name = "scaling factor for plant fine root biomass to calculate nutrient carrier enzyme abundance (ECA)" ; @@ -653,6 +692,9 @@ variables: double fates_logging_mechanical_frac ; fates_logging_mechanical_frac:units = "fraction" ; fates_logging_mechanical_frac:long_name = "Fraction of stems killed due infrastructure an other mechanical means" ; + double fates_maintresp_model ; + fates_maintresp_model:units = "unitless" ; + fates_maintresp_model:long_name = "switch for choosing between maintenance respiration models. 1=Ryan (1991) (NOT USED)" ; double fates_mort_disturb_frac ; fates_mort_disturb_frac:units = "fraction" ; fates_mort_disturb_frac:long_name = "fraction of canopy mortality that results in disturbance (i.e. transfer of area from new to old patch)" ; @@ -689,6 +731,12 @@ variables: double fates_phen_ncolddayslim ; fates_phen_ncolddayslim:units = "days" ; fates_phen_ncolddayslim:long_name = "day threshold exceedance for temperature leaf-drop" ; + double fates_photo_temp_acclim_timescale ; + fates_photo_temp_acclim_timescale:units = "days" ; + fates_photo_temp_acclim_timescale:long_name = "Length of the window for the exponential moving average (ema) of vegetation temperature used in photosynthesis temperature acclimation (NOT USED)" ; + double fates_photo_tempsens_model ; + fates_photo_tempsens_model:units = "unitless" ; + fates_photo_tempsens_model:long_name = "switch for choosing the model that defines the temperature sensitivity of photosynthetic parameters (vcmax, jmax). 1=non-acclimating (NOT USED)" ; double fates_q10_froz ; fates_q10_froz:units = "unitless" ; fates_q10_froz:long_name = "Q10 for frozen-soil respiration rates" ; @@ -698,6 +746,18 @@ variables: double fates_soil_salinity ; fates_soil_salinity:units = "ppt" ; fates_soil_salinity:long_name = "soil salinity used for model when not coupled to dynamic soil salinity" ; + double fates_theta_cj_c3 ; + fates_theta_cj_c3:units = "unitless" ; + fates_theta_cj_c3:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c3 plants" ; + double fates_theta_cj_c4 ; + fates_theta_cj_c4:units = "unitless" ; + fates_theta_cj_c4:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c4 plants" ; + double fates_vai_top_bin_width ; + fates_vai_top_bin_width:units = "m2/m2" ; + fates_vai_top_bin_width:long_name = "width in VAI units of uppermost leaf+stem layer scattering element in each canopy layer (NOT USED)" ; + double fates_vai_width_increase_factor ; + fates_vai_width_increase_factor:units = "unitless" ; + fates_vai_width_increase_factor:long_name = "factor by which each leaf+stem scattering element increases in VAI width (1 = uniform spacing) (NOT USED)" ; // global attributes: :history = "This parameter file is maintained in version control\nSee https://github.com/NGEET/fates/blob/master/parameter_files/fates_params_default.cdl \nFor changes, use git blame \n" ; @@ -709,9 +769,13 @@ data: fates_history_height_bin_edges = 0, 0.1, 0.3, 1, 3, 10 ; - fates_history_sizeclass_bin_edges = 0, 5, 10, 15, 20, 30, 40, 50, 60, 70, + fates_history_sizeclass_bin_edges = 0, 5, 10, 15, 20, 30, 40, 50, 60, 70, 80, 90, 100 ; + fates_hydr_htftype_node = 1, 1, 1, 1 ; + + fates_prt_organ_id = 1, 2, 3, 6 ; + fates_pftname = "broadleaf_evergreen_tropical_tree ", "needleleaf_evergreen_extratrop_tree ", @@ -726,30 +790,42 @@ data: "cool_c3_grass ", "c4_grass " ; + fates_hydr_organname_node = + "leaf ", + "stem ", + "transporting root ", + "absorbing root " ; + + fates_litterclass_name = + "twig ", + "small branch ", + "large branch ", + "trunk ", + "dead leaves ", + "live grass " ; + fates_prt_organ_name = "leaf ", "fine root ", "sapwood ", - "storage ", - "reproduction ", "structure " ; - fates_alloc_storage_cushion = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, + fates_alloc_storage_cushion = 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_allom_agb1 = 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, + fates_allom_agb1 = 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, 0.01, 0.01, 0.01 ; - fates_allom_agb2 = 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, + fates_allom_agb2 = 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572 ; - fates_allom_agb3 = 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, + fates_allom_agb3 = 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94 ; - fates_allom_agb4 = 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, + fates_allom_agb4 = 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931 ; - fates_allom_agb_frac = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, + fates_allom_agb_frac = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6 ; fates_allom_amode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; @@ -758,30 +834,30 @@ data: fates_allom_cmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_allom_d2bl1 = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, + fates_allom_d2bl1 = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07 ; - fates_allom_d2bl2 = 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, + fates_allom_d2bl2 = 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3 ; - fates_allom_d2bl3 = 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, + fates_allom_d2bl3 = 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55 ; - fates_allom_d2ca_coefficient_max = 0.6568464, 0.6568464, 0.6568464, - 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464, + fates_allom_d2ca_coefficient_max = 0.6568464, 0.6568464, 0.6568464, + 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464 ; - fates_allom_d2ca_coefficient_min = 0.3381119, 0.3381119, 0.3381119, - 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119, + fates_allom_d2ca_coefficient_min = 0.3381119, 0.3381119, 0.3381119, + 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119 ; - fates_allom_d2h1 = 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, + fates_allom_d2h1 = 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64 ; - fates_allom_d2h2 = 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, + fates_allom_d2h2 = 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37 ; - fates_allom_d2h3 = -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, + fates_allom_d2h3 = -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 ; fates_allom_dbh_maxheight = 90, 90, 90, 90, 90, 90, 3, 3, 2, 0.35, 0.35, 0.35 ; @@ -794,37 +870,52 @@ data: fates_allom_l2fr = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_allom_la_per_sa_int = 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, + fates_allom_la_per_sa_int = 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 ; fates_allom_la_per_sa_slp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_allom_lmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_allom_sai_scaler = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + fates_allom_sai_scaler = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 ; fates_allom_smode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; fates_allom_stmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + fates_allom_zroot_k = 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10 ; + + fates_allom_zroot_max_dbh = 100, 100, 100, 100, 100, 100, 2, 2, 2, 2, 2, 2 ; + + fates_allom_zroot_max_z = 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100 ; + + fates_allom_zroot_min_dbh = 1, 1, 1, 2.5, 2.5, 2.5, 0.1, 0.1, 0.1, 0.1, 0.1, + 0.1 ; + + fates_allom_zroot_min_z = 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100 ; + fates_branch_turnover = 150, 150, 150, 150, 150, 150, 150, 150, 150, 0, 0, 0 ; fates_c2b = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 ; - fates_displar = 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, + fates_dev_arbitrary_pft = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_displar = 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67 ; - fates_eca_alpha_ptase = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + fates_eca_alpha_ptase = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; - fates_eca_decompmicc = 280, 280, 280, 280, 280, 280, 280, 280, 280, 280, + fates_eca_decompmicc = 280, 280, 280, 280, 280, 280, 280, 280, 280, 280, 280, 280 ; - fates_eca_km_nh4 = 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, + fates_eca_km_nh4 = 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14 ; - fates_eca_km_no3 = 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, + fates_eca_km_no3 = 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27 ; fates_eca_km_p = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 ; @@ -833,28 +924,28 @@ data: fates_eca_lambda_ptase = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_eca_vmax_nh4 = 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, + fates_eca_vmax_nh4 = 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07 ; - fates_eca_vmax_no3 = 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, + fates_eca_vmax_no3 = 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08 ; - fates_eca_vmax_p = 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, + fates_eca_vmax_p = 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09 ; - fates_eca_vmax_ptase = 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, + fates_eca_vmax_ptase = 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09 ; - fates_fire_alpha_SH = 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, + fates_fire_alpha_SH = 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2 ; - fates_fire_bark_scaler = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, + fates_fire_bark_scaler = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07 ; - fates_fire_crown_depth_frac = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.95, 0.95, + fates_fire_crown_depth_frac = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.95, 0.95, 0.95, 1, 1, 1 ; - fates_fire_crown_kill = 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, + fates_fire_crown_kill = 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, 0.775 ; fates_fnrt_prof_a = 7, 7, 7, 7, 6, 6, 7, 7, 7, 11, 11, 11 ; @@ -865,26 +956,20 @@ data: fates_fr_fcel = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; - fates_fr_flab = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + fates_fr_flab = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25 ; - fates_fr_flig = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + fates_fr_flig = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25 ; - fates_grperc = 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, + fates_grperc = 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_avuln_gs = 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, + fates_hydr_avuln_gs = 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5 ; fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; - fates_hydr_alpha_vg = 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005, 0.005; - - fates_hydr_m_vg = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5; - - fates_hydr_n_vg = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2; - fates_hydr_avuln_node = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, @@ -903,40 +988,42 @@ data: 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + fates_hydr_kmax_node = -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999 ; - fates_hydr_p50_gs = -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, + fates_hydr_p50_gs = -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5 ; fates_hydr_p50_node = - -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, - -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, - -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, - -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25 ; - fates_hydr_p_taper = 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, + fates_hydr_p_taper = 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333 ; fates_hydr_pinot_node = - -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, + -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, - -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, + -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, - -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, + -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, - -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, + -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478 ; fates_hydr_pitlp_node = - -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, + -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, @@ -948,10 +1035,10 @@ data: 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, + 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 ; - fates_hydr_rs2 = 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, + fates_hydr_rs2 = 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001 ; fates_hydr_srl = 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25 ; @@ -962,89 +1049,103 @@ data: 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75 ; + fates_hydr_vg_alpha_node = + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005, + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005, + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005, + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005 ; + + fates_hydr_vg_m_node = + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; + + fates_hydr_vg_n_node = + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 ; + fates_leaf_c3psn = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0 ; - fates_leaf_clumping_index = 0.85, 0.85, 0.8, 0.85, 0.85, 0.9, 0.85, 0.9, + fates_leaf_clumping_index = 0.85, 0.85, 0.8, 0.85, 0.85, 0.9, 0.85, 0.9, 0.9, 0.75, 0.75, 0.75 ; - fates_leaf_diameter = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, + fates_leaf_diameter = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04 ; - fates_leaf_jmaxha = 43540, 43540, 43540, 43540, 43540, 43540, 43540, 43540, + fates_leaf_jmaxha = 43540, 43540, 43540, 43540, 43540, 43540, 43540, 43540, 43540, 43540, 43540, 43540 ; - fates_leaf_jmaxhd = 152040, 152040, 152040, 152040, 152040, 152040, 152040, + fates_leaf_jmaxhd = 152040, 152040, 152040, 152040, 152040, 152040, 152040, 152040, 152040, 152040, 152040, 152040 ; - fates_leaf_jmaxse = 495, 495, 495, 495, 495, 495, 495, 495, 495, 495, 495, + fates_leaf_jmaxse = 495, 495, 495, 495, 495, 495, 495, 495, 495, 495, 495, 495 ; fates_leaf_long = 1.5, 4, 1, 1.5, 1, 1, 1.5, 1, 1, 1, 1, 1 ; - fates_leaf_slamax = 0.0954, 0.0954, 0.0954, 0.0954, 0.0954, 0.0954, 0.012, + fates_leaf_slamax = 0.0954, 0.0954, 0.0954, 0.0954, 0.0954, 0.0954, 0.012, 0.03, 0.03, 0.03, 0.03, 0.03 ; - fates_leaf_slatop = 0.012, 0.01, 0.024, 0.012, 0.03, 0.03, 0.012, 0.03, + fates_leaf_slatop = 0.012, 0.01, 0.024, 0.012, 0.03, 0.03, 0.012, 0.03, 0.03, 0.03, 0.03, 0.03 ; - fates_leaf_stomatal_intercept = 10000, 10000, 10000, 10000, 10000, 10000, + fates_leaf_stomatal_intercept = 10000, 10000, 10000, 10000, 10000, 10000, 10000, 10000, 10000, 10000, 10000, 40000 ; fates_leaf_stomatal_slope_ballberry = 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8 ; - fates_leaf_stomatal_slope_medlyn = 4.1, 2.3, 2.3, 4.1, 4.4, 4.4, 4.7, 4.7, + fates_leaf_stomatal_slope_medlyn = 4.1, 2.3, 2.3, 4.1, 4.4, 4.4, 4.7, 4.7, 4.7, 2.2, 5.3, 1.6 ; - fates_leaf_stor_priority = 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, + fates_leaf_stor_priority = 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 ; - fates_leaf_tpuha = 53100, 53100, 53100, 53100, 53100, 53100, 53100, 53100, - 53100, 53100, 53100, 53100 ; - - fates_leaf_tpuhd = 150650, 150650, 150650, 150650, 150650, 150650, 150650, - 150650, 150650, 150650, 150650, 150650 ; - - fates_leaf_tpuse = 490, 490, 490, 490, 490, 490, 490, 490, 490, 490, 490, 490 ; - fates_leaf_vcmax25top = 50, 65, 39, 62, 41, 58, 62, 54, 54, 78, 78, 78 ; - fates_leaf_vcmaxha = 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330, + fates_leaf_vcmaxha = 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330 ; - fates_leaf_vcmaxhd = 149250, 149250, 149250, 149250, 149250, 149250, 149250, + fates_leaf_vcmaxhd = 149250, 149250, 149250, 149250, 149250, 149250, 149250, 149250, 149250, 149250, 149250, 149250 ; - fates_leaf_vcmaxse = 485, 485, 485, 485, 485, 485, 485, 485, 485, 485, 485, + fates_leaf_vcmaxse = 485, 485, 485, 485, 485, 485, 485, 485, 485, 485, 485, 485 ; - fates_leaf_xl = 0.1, 0.01, 0.01, 0.1, 0.01, 0.25, 0.01, 0.25, 0.25, -0.3, + fates_leaf_xl = 0.1, 0.01, 0.01, 0.1, 0.01, 0.25, 0.01, 0.25, 0.25, -0.3, -0.3, -0.3 ; fates_lf_fcel = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; - fates_lf_flab = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + fates_lf_flab = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25 ; - fates_lf_flig = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + fates_lf_flig = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25 ; - fates_maintresp_reduction_curvature = 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, + fates_maintresp_reduction_curvature = 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01 ; - fates_maintresp_reduction_intercept = 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1 ; + fates_maintresp_reduction_intercept = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_mort_bmort = 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, + fates_mort_bmort = 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014 ; - fates_mort_freezetol = 2.5, -55, -80, -30, 2.5, -30, -60, -10, -80, -80, + fates_mort_freezetol = 2.5, -55, -80, -30, 2.5, -30, -60, -10, -80, -80, -20, 2.5 ; - fates_mort_hf_flc_threshold = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + fates_mort_hf_flc_threshold = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; - fates_mort_hf_sm_threshold = 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, + fates_mort_hf_sm_threshold = 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06 ; fates_mort_ip_age_senescence = _, _, _, _, _, _, _, _, _, _, _, _ ; @@ -1057,16 +1158,19 @@ data: fates_mort_scalar_coldstress = 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3 ; - fates_mort_scalar_cstarvation = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, + fates_mort_scalar_cstarvation = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6 ; - fates_mort_scalar_hydrfailure = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, + fates_mort_scalar_hydrfailure = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6 ; fates_nfix1 = _, _, _, _, _, _, _, _, _, _, _, _ ; fates_nfix2 = _, _, _, _, _, _, _, _, _, _, _, _ ; + fates_nitr_store_ratio = 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, + 1.5, 1.5 ; + fates_phen_cold_size_threshold = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_phen_evergreen = 1, 1, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0 ; @@ -1079,98 +1183,87 @@ data: fates_phenflush_fraction = _, _, 0.5, _, 0.5, 0.5, _, 0.5, 0.5, 0.5, 0.5, 0.5 ; - fates_prescribed_mortality_canopy = 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, + fates_phos_store_ratio = 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, + 1.5, 1.5 ; + + fates_prescribed_mortality_canopy = 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194 ; - fates_prescribed_mortality_understory = 0.025, 0.025, 0.025, 0.025, 0.025, + fates_prescribed_mortality_understory = 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025 ; - fates_prescribed_npp_canopy = 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, + fates_prescribed_npp_canopy = 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4 ; - fates_prescribed_npp_understory = 0.03125, 0.03125, 0.03125, 0.03125, + fates_prescribed_npp_understory = 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125 ; - fates_prescribed_nuptake = 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0 ; + fates_prescribed_nuptake = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_prescribed_puptake = 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0 ; + fates_prescribed_puptake = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_prescribed_recruitment = 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, + fates_prescribed_recruitment = 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02 ; fates_prt_alloc_priority = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 ; fates_prt_nitr_stoich_p1 = 0.033, 0.029, 0.04, 0.033, 0.04, 0.04, 0.033, 0.04, 0.04, 0.04, 0.04, 0.04, - 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, + 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, - 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, - 1e-08, 1e-08, - 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, + 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, + 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047 ; fates_prt_nitr_stoich_p2 = 0.033, 0.029, 0.04, 0.033, 0.04, 0.04, 0.033, 0.04, 0.04, 0.04, 0.04, 0.04, - 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, + 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, - 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, - 1e-08, 1e-08, - 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, + 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, + 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047 ; fates_prt_phos_stoich_p1 = - 0.0033, 0.0029, 0.004, 0.0033, 0.004, 0.004, 0.0033, 0.004, 0.004, 0.004, + 0.0033, 0.0029, 0.004, 0.0033, 0.004, 0.004, 0.0033, 0.004, 0.004, 0.004, 0.004, 0.004, - 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, + 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, - 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, + 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, - 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, - 1e-09, 1e-09, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, + 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047 ; fates_prt_phos_stoich_p2 = - 0.0033, 0.0029, 0.004, 0.0033, 0.004, 0.004, 0.0033, 0.004, 0.004, 0.004, + 0.0033, 0.0029, 0.004, 0.0033, 0.004, 0.004, 0.0033, 0.004, 0.004, 0.004, 0.004, 0.004, - 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, + 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, - 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, - 1e-09, 1e-09, - 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, + 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, + 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047 ; - fates_recruit_hgt_min = 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 0.75, 0.75, 0.75, + fates_recruit_hgt_min = 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 0.75, 0.75, 0.75, 0.125, 0.125, 0.125 ; - fates_recruit_initd = 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, + fates_recruit_initd = 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2 ; - fates_rholnir = 0.45, 0.35, 0.35, 0.45, 0.45, 0.45, 0.35, 0.45, 0.45, 0.35, + fates_rholnir = 0.45, 0.35, 0.35, 0.45, 0.45, 0.45, 0.35, 0.45, 0.45, 0.35, 0.35, 0.35 ; fates_rholvis = 0.1, 0.07, 0.07, 0.1, 0.1, 0.1, 0.07, 0.1, 0.1, 0.1, 0.1, 0.1 ; - fates_rhosnir = 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.53, + fates_rhosnir = 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.53, 0.53, 0.53 ; - fates_rhosvis = 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.31, + fates_rhosvis = 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.31, 0.31, 0.31 ; fates_root_long = 1, 2, 1, 1.5, 1, 1, 1.5, 1, 1, 1, 1, 1 ; @@ -1179,45 +1272,43 @@ data: fates_seed_alloc_mature = 0, 0, 0, 0, 0, 0, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9 ; - fates_seed_dbh_repro_threshold = 150, 90, 90, 90, 90, 90, 3, 3, 2, 1.47, + fates_seed_dbh_repro_threshold = 150, 90, 90, 90, 90, 90, 3, 3, 2, 1.47, 1.47, 1.47 ; - fates_seed_decay_rate = 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, + fates_seed_decay_rate = 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51 ; - fates_seed_germination_rate = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + fates_seed_germination_rate = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; fates_seed_suppl = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_senleaf_long_fdrought = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_smpsc = -255000, -255000, -255000, -255000, -255000, -255000, -255000, + fates_smpsc = -255000, -255000, -255000, -255000, -255000, -255000, -255000, -255000, -255000, -255000, -255000, -255000 ; - fates_smpso = -66000, -66000, -66000, -66000, -66000, -66000, -66000, + fates_smpso = -66000, -66000, -66000, -66000, -66000, -66000, -66000, -66000, -66000, -66000, -66000, -66000 ; - fates_taulnir = 0.25, 0.1, 0.1, 0.25, 0.25, 0.25, 0.1, 0.25, 0.25, 0.34, + fates_taulnir = 0.25, 0.1, 0.1, 0.25, 0.25, 0.25, 0.1, 0.25, 0.25, 0.34, 0.34, 0.34 ; - fates_taulvis = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, + fates_taulvis = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05 ; - fates_tausnir = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, + fates_tausnir = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.25, 0.25, 0.25 ; - fates_tausvis = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, + fates_tausvis = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.12, 0.12, 0.12 ; - fates_trim_inc = 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, + fates_trim_inc = 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03 ; fates_trim_limit = 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3 ; fates_turnover_carb_retrans = - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, @@ -1227,28 +1318,40 @@ data: 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.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_turnover_phos_retrans = 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.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_turnover_retrans_mode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_wood_density = 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, + fates_wood_density = 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7 ; fates_woody = 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0 ; - fates_z0mr = 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, + fates_z0mr = 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055 ; + fates_hlm_pft_map = + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 ; + fates_fire_FBD = 15.4, 16.8, 19.6, 999, 4, 4 ; fates_fire_low_moisture_Coeff = 1.12, 1.09, 0.98, 0.8, 1.15, 1.15 ; @@ -1283,6 +1386,8 @@ data: fates_cwd_flig = 0.24 ; + fates_dev_arbitrary = _ ; + fates_eca_plant_escalar = 1.25e-05 ; fates_fire_active_crown_fire = 0 ; @@ -1343,6 +1448,8 @@ data: fates_logging_mechanical_frac = 0.05 ; + fates_maintresp_model = 1 ; + fates_mort_disturb_frac = 1 ; fates_mort_understorey_death = 0.55983 ; @@ -1367,9 +1474,21 @@ data: fates_phen_ncolddayslim = 5 ; + fates_photo_temp_acclim_timescale = 30 ; + + fates_photo_tempsens_model = 1 ; + fates_q10_froz = 1.5 ; fates_q10_mr = 1.5 ; fates_soil_salinity = 0.4 ; + + fates_theta_cj_c3 = 0.999 ; + + fates_theta_cj_c4 = 0.999 ; + + fates_vai_top_bin_width = 1 ; + + fates_vai_width_increase_factor = 1 ; } From a0b191ffa00e76829b90fcf14cb9a7f112c147d6 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Tue, 16 Nov 2021 09:03:13 -0700 Subject: [PATCH 479/578] add comments describing updates and appropriate suffixes --- main/EDMainMod.F90 | 2 +- main/FatesHistoryInterfaceMod.F90 | 28 ++++++++++++++++++++++++++++ 2 files changed, 29 insertions(+), 1 deletion(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index aa18dd2f5b..5699aae2a7 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -161,7 +161,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) call currentSite%flux_diags(el)%ZeroFluxDiags() end do - + ! zero dynamics (upfreq_in = 1) output history variables call fates_hist%zero_site_hvars(currentSite,upfreq_in=1) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 8018e564f9..e2c83e9e9f 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -4337,6 +4337,34 @@ subroutine define_history_vars(this, initialize_variables) ivar=0 + ! Variable names should start with the 'FATES_' prefix and end with a suffix + ! depending on how it is indexed (i.e. the dimension): + ! site (site_r8) : no suffix + ! cohort age (site_coage_r8) : AC + ! patch age (site_age_r8) : AP + ! canopy layer (site_can_r8) : CL + ! coarse woody debris size (site_cwdsc_r8) : DC + ! element (site_elem_r8) : EL + ! leaf layer : LL + ! fuel class (site_fuel_r8) : FC + ! height (site_height_r8) : HT + ! plant functional type (site_pft_r8) : PF + ! soil layer (site_ground_r8) : SL + ! cohort size (site_size_r8) : SZ + + ! Multiple dimensions should have multiple two-code suffixes: + ! cohort age x pft (site_cooage_r8) : ACPF + ! patch age x fuel class (site_agefuel_r8) : APFC + ! patch age x pft (site_agepft_r8) : APPF + ! canopy layer x leaf layer (site_cnlf_r8) : CLLL + ! canopy layer x leaf layer x pft (site_cnlfpft_r8) : CLLLPF + ! element x cwd size (site_elcwd_r8) : ELDC + ! cohort size x patch age (site_scag_r8) : SZAP + ! cohort size x patch age x pft (site_scagpft_r8) : SZAPPF + ! cohort size x pft (site_size_pft_r8) : SZPF + + + ! Site level counting variables call this%set_history_var(vname='FATES_NPATCHES', units='', & long='total number of patches per site', use_default='active', & From 38e3af7ba5d56c105e2a6a43a13db1a5f1092d3a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 16 Nov 2021 17:06:36 -0500 Subject: [PATCH 480/578] Removed duplicate fates_hydr_k_lwp in parameter file --- parameter_files/fates_params_default.cdl | 5 ----- 1 file changed, 5 deletions(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 931e0882fc..6d5fa2cb4e 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -228,9 +228,6 @@ variables: double fates_grperc(fates_pft) ; fates_grperc:units = "unitless" ; fates_grperc:long_name = "Growth respiration factor" ; - double fates_hydr_k_lwp(fates_pft) ; - fates_hydr_k_lwp:units = "unitless" ; - fates_hydr_k_lwp:long_name = "inner leaf humidity scale coefficient, between 1 to 10, set to 0 to disable this function" ; double fates_hydr_avuln_gs(fates_pft) ; fates_hydr_avuln_gs:units = "unitless" ; fates_hydr_avuln_gs:long_name = "shape parameter for stomatal control of water vapor exiting leaf" ; @@ -968,8 +965,6 @@ data: fates_hydr_avuln_gs = 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5 ; - fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; - fates_hydr_avuln_node = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, From 80ae09ec2d72d67e229443920f3a17f84cce6340 Mon Sep 17 00:00:00 2001 From: ckoven Date: Tue, 16 Nov 2021 18:01:45 -0700 Subject: [PATCH 481/578] added comment to nocomp+fixed_biogeog logic --- biogeochem/EDPhysiologyMod.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index e20b9896ca..6feb039d37 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1854,6 +1854,12 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) do ft = 1,numpft + + ! The following if block is for the prescribed biogeography and/or nocomp modes. + ! Since currentSite%use_this_pft is a site-level quantity and thus only limits whether a given PFT + ! is permitted on a given gridcell or not, it applies to the prescribed biogeography case only. + ! If nocomp is enabled, then we must determine whether a given PFT is allowed on a given patch or not. + if(currentSite%use_this_pft(ft).eq.itrue & .and. ((hlm_use_nocomp .eq. ifalse) .or. (ft .eq. currentPatch%nocomp_pft_label)))then From 5de148e83c4cfb04576c8f16ed1a1e120d0184e7 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 18 Oct 2021 14:39:51 -0400 Subject: [PATCH 482/578] Setting target_m to dummy value to overcome IBM issues with base functions not setting output result --- parteh/PRTGenericMod.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/parteh/PRTGenericMod.F90 b/parteh/PRTGenericMod.F90 index 76d0e01eda..3dab9563a3 100644 --- a/parteh/PRTGenericMod.F90 +++ b/parteh/PRTGenericMod.F90 @@ -1396,6 +1396,8 @@ function GetNutrientTargetBase(this,element_id,organ_id,stoich_mode) result(targ integer, intent(in),optional :: stoich_mode real(r8) :: target_m ! Target amount of nutrient for this organ [kg] + target_m = 0._r8 + write(fates_log(),*)'GetNutrientTargetBase must be extended by a child class.' call endrun(msg=errMsg(sourcefile, __LINE__)) From b18ea6194cff988cec21f1bc404a6c0d9f4b6a54 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 17 Nov 2021 13:46:22 -0500 Subject: [PATCH 483/578] Updated max_sf_interp per discussion with Junyan Ding --- biogeophys/FatesHydroWTFMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 5065771975..3b7659618c 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -35,8 +35,8 @@ module FatesHydroWTFMod ! 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.01 ! Linear interpolation below this saturated frac - real(r8), parameter :: max_sf_interp = 0.98 ! Linear interpolation above this saturated frac + real(r8), parameter :: min_sf_interp = 0.01 ! Linear interpolation below this saturated frac + real(r8), parameter :: max_sf_interp = 0.998 ! Linear interpolation above this saturated frac real(r8), parameter :: quad_a1 = 0.80_r8 ! smoothing factor "A" term ! in the capillary-elastic region From 010f8d34005aa41fd167a8f42d4f0ab806c878a1 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 23 Nov 2021 21:29:22 -0500 Subject: [PATCH 484/578] Reorder fixed window update --- main/FatesRunningMeanMod.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/main/FatesRunningMeanMod.F90 b/main/FatesRunningMeanMod.F90 index df1c12c7be..7fa3bfd7cc 100644 --- a/main/FatesRunningMeanMod.F90 +++ b/main/FatesRunningMeanMod.F90 @@ -263,17 +263,17 @@ subroutine UpdateRMean(this, new_value) ! end of the averaging memory period, and ! we are not using an indefinite running ! average, then zero things out + + this%c_index = this%c_index + 1 + wgt = this%def_type%up_period/this%def_type%mem_period + this%c_mean = this%c_mean + new_value*wgt if(this%c_index == this%def_type%n_mem) then this%l_mean = this%c_mean this%c_mean = 0._r8 this%c_index = 0 - end if - - this%c_index = this%c_index + 1 - wgt = this%def_type%up_period/this%def_type%mem_period - this%c_mean = this%c_mean + new_value*wgt + end if From 7042adad8ba79a2936afefd0830d79e0f1c195ae Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 30 Nov 2021 13:42:32 -0500 Subject: [PATCH 485/578] Removing unnecessary history updates during running mean update --- main/FatesInterfaceMod.F90 | 23 ----------------------- 1 file changed, 23 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index c7c20d6bc8..daef389587 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1901,29 +1901,6 @@ subroutine UpdateFatesRMeansTStep(sites,bc_in) enddo end do - ! Update running mean history variables - ! ------------------------------------------------------------------------------- - associate(hio_tveglpa_si_age => fates_hist%hvars(ih_tveglpa_si_age)%r82d, & - hio_tveglpa_si => fates_hist%hvars(ih_tveglpa_si)%r81d) - - do s = 1,size(sites,dim=1) - - io_si = sites(s)%h_gid - hio_tveglpa_si_age(io_si,:) = 0._r8 - hio_tveglpa_si(io_si) = 0._r8 - - cpatch => sites(s)%oldest_patch - do while(associated(cpatch)) - hio_tveglpa_si_age(io_si,cpatch%age_class) = & - hio_tveglpa_si_age(io_si,cpatch%age_class) + & - cpatch%tveg_lpa%GetMean()*cpatch%area/sites(s)%area_by_age(cpatch%age_class) - hio_tveglpa_si(io_si) = hio_tveglpa_si(io_si) + & - cpatch%tveg_lpa%GetMean()*cpatch%area*area_inv - cpatch => cpatch%younger - enddo - end do - end associate - return end subroutine UpdateFatesRMeansTStep From faa6313a4bbb2431627ffaa03c8bdb642a4550e3 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 30 Nov 2021 14:11:26 -0500 Subject: [PATCH 486/578] Adding history diagnostics to fates vegetation temperature --- main/FatesHistoryInterfaceMod.F90 | 39 ++++++++++++++++++++++--------- 1 file changed, 28 insertions(+), 11 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index e36792cc97..44116774fe 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -9,6 +9,7 @@ module FatesHistoryInterfaceMod use FatesConstantsMod , only : mg_per_kg use FatesConstantsMod , only : pi_const use FatesConstantsMod , only : nearzero + use FatesConstantsMod , only : t_water_freeze_k_1atm use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun use EDTypesMod , only : nclmax @@ -254,10 +255,6 @@ module FatesHistoryInterfaceMod integer :: ih_pefflux_scpf integer :: ih_pneed_scpf - integer :: ih_daily_temp - integer :: ih_daily_rh - integer :: ih_daily_prec - integer :: ih_bdead_si integer :: ih_balive_si integer :: ih_agb_si @@ -301,7 +298,8 @@ module FatesHistoryInterfaceMod integer :: ih_scorch_height_si_agepft ! Indices to (site) variables - + integer :: ih_tveg24_si + integer :: ih_tveg_si integer :: ih_nep_si integer :: ih_hr_si @@ -3594,10 +3592,10 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_fabi_sun_top_si_can => this%hvars(ih_fabi_sun_top_si_can)%r82d, & hio_fabi_sha_top_si_can => this%hvars(ih_fabi_sha_top_si_can)%r82d, & hio_parsun_top_si_can => this%hvars(ih_parsun_top_si_can)%r82d, & - hio_parsha_top_si_can => this%hvars(ih_parsha_top_si_can)%r82d & - ) - - + hio_parsha_top_si_can => this%hvars(ih_parsha_top_si_can)%r82d, & + hio_tveg24 => this%hvars(ih_tveg24_si)%r81d, & + hio_tveg => this%hvars(ih_tveg_si)%r81d) + ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=2) @@ -3641,9 +3639,14 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_c_lblayer_si(io_si) = hio_c_lblayer_si(io_si) + & cpatch%c_lblayer * cpatch%total_canopy_area / umol_per_mol - hio_rad_error_si(io_si) = hio_rad_error_si(io_si) + & + hio_rad_error_si(io_si) = hio_rad_error_si(io_si) + & cpatch%radiation_error * cpatch%area * AREA_INV - + + hio_tveg24(io_si) = hio_tveg24(io_si) + & + (bc_in(s)%t_veg24_pa(cpatch%patchno)- t_water_freeze_k_1atm)*cpatch%area*area_inv + hio_tveg(io_si) = hio_tveg(io_si) + & + (bc_in(s)%t_veg_pa(cpatch%patchno) - t_water_freeze_k_1atm)*cpatch%area*area_inv + ccohort => cpatch%shortest do while(associated(ccohort)) @@ -5106,6 +5109,20 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & ivar=ivar, initialize=initialize_variables, index = ih_c_lblayer_si) + ! Temperature + + call this%set_history_var(vname='FATES_TVEG24', units='degree_Celsius', & + long='fates 24-hr running mean vegetation temperature by site', & + use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_tveg24_si ) + + call this%set_history_var(vname='FATES_TVEG', units='degree_Celsius', & + long='fates instantaneous mean vegetation temperature by site', & + use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_tveg_si ) + ! radiation error call this%set_history_var(vname='FATES_RAD_ERROR', units='W m-2 ', & From d4b753ddbef0070b280b12128ce0a42daee29ca6 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 30 Nov 2021 15:11:29 -0500 Subject: [PATCH 487/578] Adding in history variables for tveg and tveg24 --- main/FatesHistoryInterfaceMod.F90 | 2 +- main/FatesInterfaceMod.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 44116774fe..eca0bb829f 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3643,7 +3643,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) cpatch%radiation_error * cpatch%area * AREA_INV hio_tveg24(io_si) = hio_tveg24(io_si) + & - (bc_in(s)%t_veg24_pa(cpatch%patchno)- t_water_freeze_k_1atm)*cpatch%area*area_inv + (cpatch%tveg24%GetMean()- t_water_freeze_k_1atm)*cpatch%area*area_inv hio_tveg(io_si) = hio_tveg(io_si) + & (bc_in(s)%t_veg_pa(cpatch%patchno) - t_water_freeze_k_1atm)*cpatch%area*area_inv diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index daef389587..0753c89829 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -79,7 +79,7 @@ module FatesInterfaceMod use FatesRunningMeanMod , only : moving_ema_window use FatesRunningMeanMod , only : fixed_window use FatesHistoryInterfaceMod , only : fates_hist - use FatesHistoryInterfaceMod , only : ih_tveglpa_si_age,ih_tveglpa_si + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg From 0dfab4189bb0aa86df13ea3aedba48e804bfbf67 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 1 Dec 2021 14:27:46 -0500 Subject: [PATCH 488/578] Minor updates to the tveg24 history diagnostic --- main/FatesHistoryInterfaceMod.F90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index eca0bb829f..20918251d2 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2063,6 +2063,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_cleafon_si => this%hvars(ih_cleafon_si)%r81d, & hio_dleafoff_si => this%hvars(ih_dleafoff_si)%r81d, & hio_dleafon_si => this%hvars(ih_dleafoff_si)%r81d, & + hio_tveg24 => this%hvars(ih_tveg24_si)%r81d, & hio_meanliqvol_si => this%hvars(ih_meanliqvol_si)%r81d, & hio_cbal_err_fates_si => this%hvars(ih_cbal_err_fates_si)%r81d, & hio_err_fates_si => this%hvars(ih_err_fates_si)%r82d ) @@ -2195,6 +2196,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_area_si_age(io_si,cpatch%age_class) = hio_area_si_age(io_si,cpatch%age_class) & + cpatch%area * AREA_INV + ! 24hr veg temperature + hio_tveg24(io_si) = hio_tveg24(io_si) + & + (cpatch%tveg24%GetMean()- t_water_freeze_k_1atm)*cpatch%area*AREA_INV + ! Increment some patch-age-resolved diagnostics hio_lai_si_age(io_si,cpatch%age_class) = hio_lai_si_age(io_si,cpatch%age_class) & @@ -3593,7 +3598,6 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_fabi_sha_top_si_can => this%hvars(ih_fabi_sha_top_si_can)%r82d, & hio_parsun_top_si_can => this%hvars(ih_parsun_top_si_can)%r82d, & hio_parsha_top_si_can => this%hvars(ih_parsha_top_si_can)%r82d, & - hio_tveg24 => this%hvars(ih_tveg24_si)%r81d, & hio_tveg => this%hvars(ih_tveg_si)%r81d) ! Flush the relevant history variables @@ -3642,8 +3646,6 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_rad_error_si(io_si) = hio_rad_error_si(io_si) + & cpatch%radiation_error * cpatch%area * AREA_INV - hio_tveg24(io_si) = hio_tveg24(io_si) + & - (cpatch%tveg24%GetMean()- t_water_freeze_k_1atm)*cpatch%area*area_inv hio_tveg(io_si) = hio_tveg(io_si) + & (bc_in(s)%t_veg_pa(cpatch%patchno) - t_water_freeze_k_1atm)*cpatch%area*area_inv @@ -5114,7 +5116,7 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FATES_TVEG24', units='degree_Celsius', & long='fates 24-hr running mean vegetation temperature by site', & use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_tveg24_si ) call this%set_history_var(vname='FATES_TVEG', units='degree_Celsius', & From 7f4d24a3b9e6d216ef40c5c1529e6556aac47521 Mon Sep 17 00:00:00 2001 From: Yilin Fang Date: Tue, 7 Dec 2021 13:54:49 -0800 Subject: [PATCH 489/578] Adjust bottom layer numbering for aggregation. --- biogeophys/FatesPlantHydraulicsMod.F90 | 292 ++++++++++++------------- main/FatesHydraulicsMemMod.F90 | 9 +- 2 files changed, 153 insertions(+), 148 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 13f8db49dd..31cb2361ac 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -67,6 +67,9 @@ module FatesPlantHydraulicsMod use FatesAllometryMod, only : CrownDepth use FatesAllometryMod , only : set_root_fraction use FatesHydraulicsMemMod, only: use_2d_hydrosolve +#if 1 + use FatesHydraulicsMemMod, only: solver_1d2d +#endif use FatesHydraulicsMemMod, only: ed_site_hydr_type use FatesHydraulicsMemMod, only: ed_cohort_hydr_type use FatesHydraulicsMemMod, only: n_hypool_plant @@ -388,22 +391,14 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) select case(soil_wrf_type) case(van_genuchten_type) do j=1,sites(s)%si_hydr%nlevrhiz - if(.not. aggregate_layers) then - j_bc=j+csite_hydr%i_rhiz_t-1 - else - j_bc = csite_hydr%map_r2s(j,2) !assign bottom soil layer parameters to rhizosphere, not accurate, but ok for larger fraction - end if + j_bc = csite_hydr%map_r2s(j,2) !assign bottom soil layer parameters to rhizosphere, not accurate, but ok for larger fraction 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 - if(.not. aggregate_layers) then - j_bc=j+csite_hydr%i_rhiz_t-1 - else - j_bc = csite_hydr%map_r2s(j,2) - end if + j_bc = csite_hydr%map_r2s(j,2) 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), & @@ -412,11 +407,7 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) end do case(smooth1_campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - if(.not. aggregate_layers) then - j_bc=j+csite_hydr%i_rhiz_t-1 - else - j_bc = csite_hydr%map_r2s(j,2) - end if + j_bc = csite_hydr%map_r2s(j,2) allocate(wrf_smooth_cch) sites(s)%si_hydr%wrf_soil(j)%p => wrf_smooth_cch call wrf_smooth_cch%set_wrf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -425,11 +416,7 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) end do case(smooth2_campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - if(.not. aggregate_layers) then - j_bc=j+csite_hydr%i_rhiz_t-1 - else - j_bc = csite_hydr%map_r2s(j,2) - end if + j_bc = csite_hydr%map_r2s(j,2) allocate(wrf_smooth_cch) sites(s)%si_hydr%wrf_soil(j)%p => wrf_smooth_cch call wrf_smooth_cch%set_wrf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -455,11 +442,7 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) end do case(campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - if(.not. aggregate_layers) then - j_bc=j+csite_hydr%i_rhiz_t-1 - else - j_bc = csite_hydr%map_r2s(j,2) - end if + j_bc = csite_hydr%map_r2s(j,2) 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), & @@ -468,11 +451,7 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) end do case(smooth1_campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - if(.not. aggregate_layers) then - j_bc=j+csite_hydr%i_rhiz_t-1 - else - j_bc = csite_hydr%map_r2s(j,2) - end if + j_bc = csite_hydr%map_r2s(j,2) allocate(wkf_smooth_cch) sites(s)%si_hydr%wkf_soil(j)%p => wkf_smooth_cch call wkf_smooth_cch%set_wkf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -481,11 +460,7 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) end do case(smooth2_campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - if(.not. aggregate_layers) then - j_bc=j+csite_hydr%i_rhiz_t-1 - else - j_bc = csite_hydr%map_r2s(j,2) - end if + j_bc = csite_hydr%map_r2s(j,2) allocate(wkf_smooth_cch) sites(s)%si_hydr%wkf_soil(j)%p => wkf_smooth_cch call wkf_smooth_cch%set_wkf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -1371,13 +1346,30 @@ subroutine InitHydrSites(sites,bc_in) integer :: j integer :: jj type(ed_site_hydr_type),pointer :: csite_hydr +#if 1 + integer :: my_2dn + integer :: my_toplayer +#endif if ( hlm_use_planthydro.eq.ifalse ) return ! Initialize any derived hydraulics parameters - +#if 1 + open(99010,file='my_param.txt',status='old') + read(99010,*) my_2dn,my_toplayer + if(my_2dn == 1) then !1d + solver_1d2d = 1 + use_2d_hydrosolve = .false. + elseif(my_2dn == 2) then !newton + solver_1d2d = 2 + use_2d_hydrosolve = .true. + elseif(my_2dn == 3) then !picard + solver_1d2d = 3 + use_2d_hydrosolve = .true. + endif +#endif nsites = ubound(sites,1) do s=1,nsites allocate(csite_hydr) @@ -1397,34 +1389,36 @@ subroutine InitHydrSites(sites,bc_in) ! csite_hydr%i_rhiz_t = 11 !one big layer ! csite_hydr%i_rhiz_t = 6 !top 5 layer aggregate csite_hydr%i_rhiz_t = 2 !no aggregate +#if 1 + csite_hydr%i_rhiz_t = my_toplayer +#endif csite_hydr%i_rhiz_b = bc_in(s)%nlevsoil - csite_hydr%nlevrhiz = csite_hydr%i_rhiz_b - csite_hydr%i_rhiz_t + 2 !ideally to be read in from the parameter file elseif(ignore_layer1) then - !csite_hydr%i_rhiz_t = 2 - csite_hydr%i_rhiz_t = 6 + 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 - if(.not. aggregate_layers) & - csite_hydr%nlevrhiz = csite_hydr%i_rhiz_b-csite_hydr%i_rhiz_t+1 + csite_hydr%nlevrhiz = csite_hydr%i_rhiz_b-csite_hydr%i_rhiz_t+1 call sites(s)%si_hydr%InitHydrSite(numpft,nlevsclass) if(.not. aggregate_layers) then jj=1 do j=csite_hydr%i_rhiz_t,csite_hydr%i_rhiz_b + csite_hydr%map_r2s(1,1) = 1 + csite_hydr%map_r2s(1,2) = csite_hydr%i_rhiz_t - 1 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 else csite_hydr%map_r2s(1,1) = 1 - csite_hydr%map_r2s(1,2) = csite_hydr%i_rhiz_t - 1 + csite_hydr%map_r2s(1,2) = csite_hydr%i_rhiz_t jj = 2 - do j = csite_hydr%i_rhiz_t,csite_hydr%i_rhiz_b + do j = csite_hydr%i_rhiz_t+1,csite_hydr%i_rhiz_b csite_hydr%map_r2s(jj,1:2) = j jj = jj + 1 end do @@ -1436,6 +1430,7 @@ subroutine InitHydrSites(sites,bc_in) end do + end subroutine InitHydrSites ! =================================================================================== @@ -1513,11 +1508,7 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) end do case(campbell_type) do j=1,site_hydr%nlevrhiz - if(.not. aggregate_layers) then - j_bc=j+site_hydr%i_rhiz_t-1 - else - j_bc = site_hydr%map_r2s(j,2) !assign bottom soil layer parameters to rhizosphere, not accurate, but ok for larger fraction - end if + j_bc = site_hydr%map_r2s(j,2) !assign bottom soil layer parameters to rhizosphere, not accurate, but ok for larger fraction allocate(wrf_cch) site_hydr%wrf_soil(j)%p => wrf_cch call wrf_cch%set_wrf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -1526,11 +1517,7 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) end do case(smooth1_campbell_type) do j=1,site_hydr%nlevrhiz - if(.not. aggregate_layers) then - j_bc=j+site_hydr%i_rhiz_t-1 - else - j_bc = site_hydr%map_r2s(j,2) - end if + j_bc = site_hydr%map_r2s(j,2) allocate(wrf_smooth_cch) site_hydr%wrf_soil(j)%p => wrf_smooth_cch call wrf_smooth_cch%set_wrf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -1539,11 +1526,7 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) end do case(smooth2_campbell_type) do j=1,site_hydr%nlevrhiz - if(.not. aggregate_layers) then - j_bc=j+site_hydr%i_rhiz_t-1 - else - j_bc = site_hydr%map_r2s(j,2) - end if + j_bc = site_hydr%map_r2s(j,2) allocate(wrf_smooth_cch) site_hydr%wrf_soil(j)%p => wrf_smooth_cch call wrf_smooth_cch%set_wrf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -1568,11 +1551,7 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) end do case(campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - if(.not. aggregate_layers) then - j_bc=j+site_hydr%i_rhiz_t-1 - else - j_bc = site_hydr%map_r2s(j,2) - end if + j_bc = site_hydr%map_r2s(j,2) allocate(wkf_cch) site_hydr%wkf_soil(j)%p => wkf_cch call wkf_cch%set_wkf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -1581,11 +1560,7 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) end do case(smooth1_campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - if(.not. aggregate_layers) then - j_bc=j+site_hydr%i_rhiz_t-1 - else - j_bc = site_hydr%map_r2s(j,2) - end if + j_bc = site_hydr%map_r2s(j,2) allocate(wkf_smooth_cch) site_hydr%wkf_soil(j)%p => wkf_smooth_cch call wkf_smooth_cch%set_wkf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -1594,11 +1569,7 @@ subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) end do case(smooth2_campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - if(.not. aggregate_layers) then - j_bc=j+site_hydr%i_rhiz_t-1 - else - j_bc = site_hydr%map_r2s(j,2) - end if + j_bc = site_hydr%map_r2s(j,2) allocate(wkf_smooth_cch) site_hydr%wkf_soil(j)%p => wkf_smooth_cch call wkf_smooth_cch%set_wkf_param([bc_in(s)%watsat_sisl(j_bc), & @@ -2044,11 +2015,7 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) do j = 1,nlevrhiz - if(.not. aggregate_layers) then - j_bc=j+csite_hydr%i_rhiz_t-1 - else - j_bc = csite_hydr%map_r2s(j,2) - end if + j_bc = csite_hydr%map_r2s(j,2) ! bc_in%hksat_sisl(j): hydraulic conductivity at saturation (mm H2O /s) ! @@ -2240,11 +2207,7 @@ subroutine UpdateSizeDepRhizHydStates(currentSite, bc_in) ! 1st guess at new s based on interpolated psi do j = 1,csite_hydr%nlevrhiz - if(.not. aggregate_layers) then - j_bc=j+csite_hydr%i_rhiz_t-1 - else - j_bc = csite_hydr%map_r2s(j,2) - end if + j_bc = csite_hydr%map_r2s(j,2) ! proceed only if l_aroot_coh has changed if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then @@ -2257,11 +2220,7 @@ subroutine UpdateSizeDepRhizHydStates(currentSite, bc_in) ! accumlate water across shells for each layer (initial and interpolated) do j = 1,csite_hydr%nlevrhiz - if(.not. aggregate_layers) then - j_bc=j+csite_hydr%i_rhiz_t-1 - else - j_bc = csite_hydr%map_r2s(j,2) - end if + j_bc = csite_hydr%map_r2s(j,2) ! 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 @@ -2281,11 +2240,7 @@ subroutine UpdateSizeDepRhizHydStates(currentSite, bc_in) ! estimate delta_s across all shells needed to ensure total water in each layer doesn't change ! BOC...FIX: need to handle special cases where delta_s causes s_shell to go above or below 1 or 0, respectively. do j = 1,csite_hydr%nlevrhiz - if(.not. aggregate_layers) then - j_bc=j+csite_hydr%i_rhiz_t-1 - else - j_bc = csite_hydr%map_r2s(j,2) - end if + j_bc = csite_hydr%map_r2s(j,2) ! 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)) / & @@ -2295,11 +2250,7 @@ subroutine UpdateSizeDepRhizHydStates(currentSite, bc_in) ! update h2osoi_liqvol_shell and h2osoi_liq_shell do j = 1,csite_hydr%nlevrhiz - if(.not. aggregate_layers) then - j_bc=j+csite_hydr%i_rhiz_t-1 - else - j_bc = csite_hydr%map_r2s(j,2) - end if + j_bc = csite_hydr%map_r2s(j,2) ! 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 @@ -2317,11 +2268,10 @@ subroutine UpdateSizeDepRhizHydStates(currentSite, bc_in) ! balance check do j = 1,csite_hydr%nlevrhiz + j_bc = csite_hydr%map_r2s(j,2) if(.not. aggregate_layers) then - j_bc=j+csite_hydr%i_rhiz_t-1 errh2o(j) = h2osoi_liq_col_new(j) - bc_in%h2o_liq_sisl(j_bc) else - j_bc = csite_hydr%map_r2s(j,2) errh2o(j) = h2osoi_liq_col_new(j) - sum(bc_in%h2o_liq_sisl(csite_hydr%map_r2s(j,1):csite_hydr%map_r2s(j,2))) end if if (abs(errh2o(j)) > 1.e-4_r8) then @@ -2451,11 +2401,7 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) ! patch without cohorts if( sum(csite_hydr%l_aroot_layer) == 0._r8 ) cycle do j = 1,csite_hydr%nlevrhiz - if(.not. aggregate_layers) then - j_bc=j+csite_hydr%i_rhiz_t-1 - else - j_bc = csite_hydr%map_r2s(j,2) - end if + j_bc = csite_hydr%map_r2s(j,2) cumShellH2O=sum(csite_hydr%h2osoi_liqvol_shell(j,:) *csite_hydr%v_shell(j,:)) * denh2o*AREA_INV if(.not. aggregate_layers) then @@ -2772,13 +2718,15 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) !--------------------------------------------------------------------------- - if(use_2d_hydrosolve) then -#if 0 +! if(use_2d_hydrosolve) then + if(solver_1d2d == 2) then +#if 1 call MatSolve2D(bc_in(s),site_hydr,ccohort,ccohort_hydr, & dtime,qflx_tran_veg_indiv, & sapflow,rootuptake(1:nlevrhiz),wb_err_plant,dwat_plant, & dth_layershell_col) #endif + elseif(solver_1d2d == 3) then #if 1 call PicardSolve2D(bc_in(s),site_hydr,ccohort,ccohort_hydr, & dtime,qflx_tran_veg_indiv, & @@ -2886,11 +2834,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) do j=1,site_hydr%nlevrhiz - if(.not. aggregate_layers) then - j_bc = j+site_hydr%i_rhiz_t-1 - else - j_bc = site_hydr%map_r2s(j,2) - end if + j_bc = site_hydr%map_r2s(j,2) ! Update the site-level state variable ! rhizosphere shell water content [m3/m3] @@ -3923,14 +3867,21 @@ subroutine ImTaylorSolve1D(site_hydr,cohort,cohort_hydr,dtime,q_top, & ! write(fates_log(),*)'Grid with problem -',wb_step_err,q_top_eff,'th-',dth_node(1:5),'w_totb',w_tot_beg,w_tot_end !endif !linear solver error cannot be avoided - !if(abs(wb_step_err)>1*max_wb_step_err .or. any(dth_node(:).ne.dth_node(:)) )then - if( any(dth_node(:).ne.dth_node(:)) )then + if(abs(wb_step_err)>1*max_wb_step_err .or. any(dth_node(:).ne.dth_node(:)) )then + !if( any(dth_node(:).ne.dth_node(:)) )then !if(abs(wb_step_err)>1*max_wb_step_err .or. any(dth_node(:).ne.dth_node(:)) )then !solution_found = .false. - solution_found = .false. - error_code = 1 - error_arr(:) = 0._r8 - exit + if(max_iter .and. psi_node(1) < -10.0) then + solution_found = .true. + error_code = 0 + + else + solution_found = .false. + error_code = 1 + error_arr(:) = 0._r8 + + exit + endif else ! Note: this is somewhat of a default true. And the sub-steps ! will keep going unless its changed and broken out of @@ -5443,18 +5394,18 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & if(pm_node(k) == rhiz_p_media) then j = node_layer(k) - if(abs(residual(k)) < dpsi_scap) then +! if(abs(residual(k)) < dpsi_scap) then psi_node(k) = psi_node(k) + residual(k) * rlfx_soil - else - psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_scap,residual(k)) - dpsi_scap*dpsi_scap/residual(k) - endif +! else +! psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_scap,residual(k)) - dpsi_scap*dpsi_scap/residual(k) +! endif th_node(k) = site_hydr%wrf_soil(j)%p%th_from_psi(psi_node(k)) else - if(abs(residual(k)) < dpsi_pcap) then +! if(abs(residual(k)) < dpsi_pcap) then psi_node(k) = psi_node(k) + residual(k) * rlfx_plnt - else - psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_pcap,residual(k)) - dpsi_pcap*dpsi_pcap/residual(k) - endif +! else +! psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_pcap,residual(k)) - dpsi_pcap*dpsi_pcap/residual(k) +! endif th_node(k) = wrf_plant(pm_node(k),ft)%p%th_from_psi(psi_node(k)) endif @@ -5664,7 +5615,7 @@ subroutine PicardSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ! Maximum number of times we re-try a round of Picard ! iterations, each time decreasing the time-step and ! potentially reducing relaxation factors - integer, parameter :: max_picard_rounds = 10 + integer, parameter :: max_picard_rounds = 100 ! dtime will shrink at the following rate (halving) [s]: ! 1800,900,450,225,112.5,56.25,28.125,14.0625,7.03125,3.515625, @@ -5673,9 +5624,6 @@ subroutine PicardSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ! 0.0034332275390625,0.00171661376953125, - ! Maximum number of Newton iterations in each round - integer, parameter :: max_newton_iter = 100 - ! Flag definitions for convergence flag (icnv) ! icnv = 1 fail the round due to either wacky math, or ! too many Newton iterations @@ -5724,7 +5672,8 @@ subroutine PicardSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & real(r8) :: dftc_dtheta_node(nnode) ! deriv FTC w.r.t. theta real(r8) :: dpsi_dtheta_node(nnode) ! deriv psi w.r.t. theta real(r8) :: volx !temporary volume - integer :: picd_iter !picard iteration counter + integer :: picd_iter !picard iteration counter + real(r8) :: th_prev(nnode) !temporary for th from previous iteration associate(conn_up => site_hydr%conn_up, & @@ -5837,7 +5786,7 @@ subroutine PicardSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & if(pm_node(k) == rhiz_p_media) then j = node_layer(k) - psi_node(k) = max(-1e2_r8, site_hydr%wrf_soil(j)%p%psi_from_th(th_node(k))) + psi_node(k) = max(-1e5_r8, site_hydr%wrf_soil(j)%p%psi_from_th(th_node(k))) ! Get total potential [Mpa] h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) @@ -5850,7 +5799,7 @@ subroutine PicardSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & else - psi_node(k) = max(-1e2_r8, wrf_plant(pm_node(k),ft)%p%psi_from_th(th_node(k))) + psi_node(k) = max(-1e5_r8, 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 [-] @@ -5899,9 +5848,10 @@ subroutine PicardSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & !Calculate time step that meet cfl condition if(cfl_max > cfl) then nsteps = min(int(cfl_max/cfl) + 1, 20) - nsteps = 1 dtime = tmx/nsteps end if + + icnv = 0 outerloop: do while( tm < tmx ) ! The solve may reduce the time-step, the shorter @@ -5914,9 +5864,6 @@ subroutine PicardSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ! Advance time forward tm = tm + dtime - ! If we have not exceeded our max number - ! of retrying rounds of Newton iterations, reduce - ! time and try a new round ! This is the newton search loop @@ -5932,6 +5879,7 @@ subroutine PicardSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ! to be zerod. ajac(:,:) = 0._r8 residual(:) = 0._r8 + th_prev(:) = th_node(:) do k=1,site_hydr%num_nodes @@ -6051,11 +5999,6 @@ subroutine PicardSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ! Update the water content th_node(:) = th_node(:) + residual(:) - -#if 1 -! if(qtop > 0._r8) then -! print * -! end if ! constrain th do k=1,site_hydr%num_nodes @@ -6072,17 +6015,33 @@ subroutine PicardSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & enddo -#endif wb_error = qtop*dtime - (sum( th_node_prev(:)*v_node(:) ) - sum( th_node(:)*v_node(:) ))*denh2o - ! Mass is conserved - if(abs(wb_error) < max_allowed_residual .or. maxval(abs(residual(:))) < 1.e-10_r8) exit picardloop + ! Mass is conserved or solver is converged + if(abs(wb_error) < max_allowed_residual .or. maxval(abs(residual(:))) < 1.e-3_r8 .or. maxval(abs(th_node(:) - th_prev(:))) < 1.e-3) exit picardloop + + if(icnv == 1 ) then +print *,'dtime-',dtime,tm + exit picardloop !explicit integration with small time step + end if + + if(picd_iter > max_picard_rounds) then - if(picd_iter > max_picard_rounds) continue_search = .false. + icnv = 1 + + ! reset to initial condition + tm = 0._r8 + th_node(:) = th_node_init(:) + th_node_prev(:) = th_node_init(:) + + cycle outerloop !do explicit integration + + endif end do picardloop + ! If we are here, that means we succesfully finished ! a solve with minimal error. More substeps may be required though ! ------------------------------------------------------------------------------ @@ -6095,6 +6054,47 @@ subroutine PicardSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & end do outerloop + !update psi + do k=1,site_hydr%num_nodes + + if(pm_node(k) == rhiz_p_media) then + + j = node_layer(k) + psi_node(k) = max(-1e2_r8, site_hydr%wrf_soil(j)%p%psi_from_th(th_node(k))) + + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = site_hydr%wkf_soil(j)%p%ftc_from_psi(psi_node(k)) + else + + psi_node(k) = max(-1e2_r8, 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)) + + end if + + enddo + + ! update fluxes + do icnx=1,site_hydr%num_connections + + id_dn = conn_dn(icnx) + id_up = conn_up(icnx) + + call GetImTaylorKAB(kmax_up(icnx),kmax_dn(icnx), & + ftc_node(id_up),ftc_node(id_dn), & + h_node(id_up),h_node(id_dn), & + dftc_dtheta_node(id_up), dftc_dtheta_node(id_dn), & + dpsi_dtheta_node(id_up), dpsi_dtheta_node(id_dn), & + k_eff, & + A_term, & + B_term) + + q_flux(icnx) = k_eff*(h_node(id_up)-h_node(id_dn)) + end do ! Save flux diagnostics ! ------------------------------------------------------ diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 61a458ab4b..6745de697c 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -9,8 +9,13 @@ module FatesHydraulicsMemMod implicit none private - - logical, parameter, public :: use_2d_hydrosolve = .false. +#if 0 + logical, parameter, public :: use_2d_hydrosolve = .true. +#endif + logical, public :: use_2d_hydrosolve +#if 1 + integer, public :: solver_1d2d ! =1,1d = 2, 2d newton, =3, picard +#endif ! Number of soil layers for indexing cohort fine root quanitities From 45f342496230b8f70620b1d41c44e4b362aab502 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 15 Dec 2021 00:29:42 -0800 Subject: [PATCH 490/578] Adding fix for RUN failure Avoid updating treelai and treesai in sp mode during update_hlm_dynamics --- biogeochem/EDCanopyStructureMod.F90 | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 5f8261ae26..1165c04daa 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1935,9 +1935,13 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) total_patch_area = 0._r8 total_canopy_area = 0._r8 bc_out(s)%canopy_fraction_pa(:) = 0._r8 - bc_out(s)%dleaf_pa(:) = 0._r8 - bc_out(s)%z0m_pa(:) = 0._r8 - bc_out(s)%displa_pa(:) = 0._r8 + + if (hlm_use_sp.eq.ifalse) then + bc_out(s)%dleaf_pa(:) = 0._r8 + bc_out(s)%z0m_pa(:) = 0._r8 + bc_out(s)%displa_pa(:) = 0._r8 + endif + currentPatch => sites(s)%oldest_patch c = fcolumn(s) do while(associated(currentPatch)) @@ -1963,9 +1967,10 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! Use canopy-only crown area weighting for all cohorts in the patch to define the characteristic ! Roughness length and displacement height used by the HLM ! use total LAI + SAI to weight the leaft characteristic dimension + ! Avoid this if running in satellite phenology mode ! ---------------------------------------------------------------------------- - if (currentPatch%total_canopy_area > nearzero) then + if (currentPatch%total_canopy_area > nearzero .and. hlm_use_sp.eq.ifalse) then currentCohort => currentPatch%shortest do while(associated(currentCohort)) if (currentCohort%canopy_layer .eq. 1) then From 1affa9fb90e5c8772384e1cc788d4a90dc2e9dd7 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 15 Dec 2021 00:31:37 -0800 Subject: [PATCH 491/578] Adding fix for ERS COMPARE_base_rest Given that UpdateCohortBioPhysRates is only called at initialization during sp mode and that during init all cohorts are set with arbitrary tlai, tsai and htop, all cohorts will likely have leaf biomass and thus assign vcmax25top. That said, its possible for the leaf biomass to be zero immediately after the first time step which can result in an eventual restart write of zero leaf biomass. This change makes sure that the cohorts get the vcmax25top value during restart in such an instance. --- biogeochem/EDCohortDynamicsMod.F90 | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 893c0e66db..a959ffe3d8 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -11,6 +11,7 @@ module EDCohortDynamicsMod use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking + use FatesInterfaceTypesMod , only : hlm_is_restart use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : fates_unset_int use FatesConstantsMod , only : itrue,ifalse @@ -2011,6 +2012,13 @@ subroutine UpdateCohortBioPhysRates(currentCohort) currentCohort%kp25top = sum(param_derived%kp25top(ipft,1:nleafage) * & frac_leaf_aclass(1:nleafage)) + elseif (hlm_use_sp .eq. itrue .and. hlm_is_restart .eq. itrue) then + + currentCohort%vcmax25top = EDPftvarcon_inst%vcmax25top(ipft,1:nleafage) + currentCohort%jmax25top = param_derived%jmax25top(ipft,1:nleafage) + currentCohort%tpu25top = param_derived%tpu25top(ipft,1:nleafage) + currentCohort%kp25top = param_derived%kp25top(ipft,1:nleafage) + else currentCohort%vcmax25top = 0._r8 From 46d18083221bb8134a0639ce78c5ef43e06c034d Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 15 Dec 2021 10:04:48 -0700 Subject: [PATCH 492/578] removing leaf age indexing compenent --- biogeochem/EDCohortDynamicsMod.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index a959ffe3d8..5446c94dda 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1993,9 +1993,10 @@ subroutine UpdateCohortBioPhysRates(currentCohort) ! We assume that leaf age does not effect the specific leaf area, so the mass ! fractions are applicable to these rates + ipft = currentCohort%pft + if(sum(frac_leaf_aclass(1:nleafage))>nearzero) then - ipft = currentCohort%pft frac_leaf_aclass(1:nleafage) = frac_leaf_aclass(1:nleafage) / & sum(frac_leaf_aclass(1:nleafage)) @@ -2014,10 +2015,10 @@ subroutine UpdateCohortBioPhysRates(currentCohort) elseif (hlm_use_sp .eq. itrue .and. hlm_is_restart .eq. itrue) then - currentCohort%vcmax25top = EDPftvarcon_inst%vcmax25top(ipft,1:nleafage) - currentCohort%jmax25top = param_derived%jmax25top(ipft,1:nleafage) - currentCohort%tpu25top = param_derived%tpu25top(ipft,1:nleafage) - currentCohort%kp25top = param_derived%kp25top(ipft,1:nleafage) + currentCohort%vcmax25top = EDPftvarcon_inst%vcmax25top(ipft,1) + currentCohort%jmax25top = param_derived%jmax25top(ipft,1) + currentCohort%tpu25top = param_derived%tpu25top(ipft,1) + currentCohort%kp25top = param_derived%kp25top(ipft,1) else From cb0db9a05adc871d4fc420a87982c03ed302c486 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 15 Dec 2021 13:58:33 -0500 Subject: [PATCH 493/578] Re-added Yilins picard solver, and the layer aggregation scheme. Re-implemented Yilins bug-fix to effective conductance calculations overwriting ftc, which was messing with downstream nodes in Taylor solutions. Minor improvement to make sure that node elevations were actually at the root layer mid-points, they were incorrectly at the layer bottom interface. --- biogeophys/FatesPlantHydraulicsMod.F90 | 1729 +++++++++++++++++------- main/EDMainMod.F90 | 3 +- main/EDParamsMod.F90 | 12 +- main/FatesHistoryInterfaceMod.F90 | 99 +- main/FatesHydraulicsMemMod.F90 | 130 +- 5 files changed, 1344 insertions(+), 629 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index bd77528b14..5cf34069e4 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -48,6 +48,7 @@ module FatesPlantHydraulicsMod use EDParamsMod , only : hydr_psi0 use EDParamsMod , only : hydr_psicap use EDParamsMod , only : hydr_htftype_node + use EDParamsMod , only : hydr_solver_type use EDTypesMod , only : ed_site_type use EDTypesMod , only : ed_patch_type @@ -66,7 +67,9 @@ module FatesPlantHydraulicsMod use FatesAllometryMod, only : bleaf use FatesAllometryMod, only : bsap_allom use FatesAllometryMod, only : CrownDepth - use FatesHydraulicsMemMod, only: use_2d_hydrosolve + use FatesHydraulicsMemMod, only: hydr_solver_1DTaylor + use FatesHydraulicsMemMod, only: hydr_solver_2DNewton + use FatesHydraulicsMemMod, only: hydr_solver_2DPicard use FatesHydraulicsMemMod, only: ed_site_hydr_type use FatesHydraulicsMemMod, only: ed_cohort_hydr_type use FatesHydraulicsMemMod, only: n_hypool_plant @@ -86,7 +89,7 @@ module FatesPlantHydraulicsMod use FatesHydraulicsMemMod, only: rhiz_p_media use FatesHydraulicsMemMod, only: nlevsoi_hyd_max use FatesHydraulicsMemMod, only: rwccap, rwcft - use FatesHydraulicsMemMod, only: ignore_layer1 + use PRTGenericMod, only : carbon12_element use PRTGenericMod, only : leaf_organ, fnrt_organ, sapw_organ @@ -104,6 +107,7 @@ module FatesPlantHydraulicsMod use FatesHydroWTFMod, only : wkf_arr_type use FatesHydroWTFMod, only : wrf_type, wrf_type_vg, wrf_type_cch, wrf_type_tfs use FatesHydroWTFMod, only : wkf_type, wkf_type_vg, wkf_type_cch, wkf_type_tfs + use FatesHydroWTFMod, only : wrf_type_smooth_cch, wkf_type_smooth_cch ! CIME Globals @@ -204,6 +208,8 @@ module FatesPlantHydraulicsMod integer, public, parameter :: van_genuchten_type = 2 integer, public, parameter :: campbell_type = 3 + integer, public, parameter :: smooth1_campbell_type = 31 + integer, public, parameter :: smooth2_campbell_type = 32 integer, public, parameter :: tfs_type = 1 integer, parameter :: soil_wrf_type = campbell_type @@ -254,7 +260,6 @@ module FatesPlantHydraulicsMod public :: UpdatePlantPsiFTCFromTheta public :: InitPlantHydStates public :: UpdateSizeDepRhizHydProps - public :: UpdateSizeDepRhizHydStates public :: RestartHydrStates public :: SavePreviousCompartmentVolumes public :: SavePreviousRhizVolumes @@ -264,6 +269,10 @@ module FatesPlantHydraulicsMod public :: ConstrainRecruitNumber public :: InitHydroGlobals + ! RGK 12-2021: UpdateSizeDepRhizHydStates was removed + ! this code can be found in tags prior to + ! sci.1.52.0_api.20.0.0 + !------------------------------------------------------------------------------ ! 01/18/16: Created by Brad Christoffersen ! 02/xx/17: Refactoring by Ryan Knox and Brad Christoffersen @@ -328,18 +337,24 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ! locals ! ---------------------------------------------------------------------------------- ! LL pointers - type(ed_patch_type),pointer :: cpatch ! current patch - type(ed_cohort_type),pointer :: ccohort ! current cohort - type(ed_cohort_hydr_type),pointer :: ccohort_hydr - type(ed_site_hydr_type),pointer :: csite_hydr - integer :: s ! site loop counter - integer :: j ! 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 + 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 + class(wrf_type_smooth_cch), pointer :: wrf_smooth_cch + class(wkf_type_smooth_cch), pointer :: wkf_smooth_cch + real(r8) :: watsat ! Mean wsat across soil layers contributing to current root layer + real(r8) :: sucsat ! Mean sucsat across soil layers contributing to current root layer + real(r8) :: bsw ! Mean bsw across soil layers contributing to current root layer + do s = 1,nsites csite_hydr=>sites(s)%si_hydr @@ -387,23 +402,50 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) 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 + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) allocate(wrf_vg) sites(s)%si_hydr%wrf_soil(j)%p => wrf_vg - call wrf_vg%set_wrf_param([alpha_vg, psd_vg, m_vg, bc_in(s)%watsat_sisl(j_bc), th_res_vg]) + call wrf_vg%set_wrf_param([alpha_vg, psd_vg, m_vg, watsat, 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 + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) 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)]) + call wrf_cch%set_wrf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw]) + end do + case(smooth1_campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + allocate(wrf_smooth_cch) + sites(s)%si_hydr%wrf_soil(j)%p => wrf_smooth_cch + call wrf_smooth_cch%set_wrf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw,1._r8]) + end do + case(smooth2_campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + allocate(wrf_smooth_cch) + sites(s)%si_hydr%wrf_soil(j)%p => wrf_smooth_cch + call wrf_smooth_cch%set_wrf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw,2._r8]) end do case(tfs_type) write(fates_log(),*) 'TFS water retention curves not available for soil' call endrun(msg=errMsg(sourcefile, __LINE__)) + case default + write(fates_log(),*) 'undefined water retention type for soil:',soil_wrf_type + call endrun(msg=errMsg(sourcefile, __LINE__)) end select ! ----------------------------------------------------------------------------------- @@ -413,28 +455,51 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) 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, m_vg, th_sat_vg, th_res_vg, soil_tort_vg]) end do case(campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) 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)]) + call wkf_cch%set_wkf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw]) + end do + case(smooth1_campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + allocate(wkf_smooth_cch) + sites(s)%si_hydr%wkf_soil(j)%p => wkf_smooth_cch + call wkf_smooth_cch%set_wkf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw,1._r8]) + end do + case(smooth2_campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + allocate(wkf_smooth_cch) + sites(s)%si_hydr%wkf_soil(j)%p => wkf_smooth_cch + call wkf_smooth_cch%set_wkf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw,2._r8]) end do case(tfs_type) write(fates_log(),*) 'TFS conductance not used in soil' call endrun(msg=errMsg(sourcefile, __LINE__)) + case default + write(fates_log(),*) 'undefined water conductance type for soil:',soil_wkf_type + call endrun(msg=errMsg(sourcefile, __LINE__)) end select - - - ! Update static quantities related to the rhizosphere call UpdateSizeDepRhizVolLenCon(sites(s), bc_in(s)) @@ -472,7 +537,7 @@ subroutine InitPlantHydStates(site, cohort) type(ed_cohort_type), intent(inout), target :: cohort ! current cohort pointer ! ! !LOCAL VARIABLES: - type(ed_site_hydr_type), pointer :: site_hydr + type(ed_site_hydr_type), pointer :: csite_hydr type(ed_cohort_hydr_type), pointer :: cohort_hydr integer :: j,k ! layer and node indices integer :: ft ! functional type index @@ -492,7 +557,7 @@ subroutine InitPlantHydStates(site, cohort) class(wrf_arr_type),pointer :: wrfa,wrft class(wkf_arr_type),pointer :: wkfa,wkft - site_hydr => site%si_hydr + csite_hydr => site%si_hydr cohort_hydr => cohort%co_hydr ft = cohort%pft wrfa => wrf_plant(aroot_p_media,ft) @@ -506,18 +571,19 @@ subroutine InitPlantHydStates(site, cohort) ! h_aroot_mean = 0._r8 - do j=1, site_hydr%nlevrhiz + do j=1, csite_hydr%nlevrhiz ! Checking apperance of roots. Only proceed if there are roots in that layer if(cohort_hydr%l_aroot_layer(j) > nearzero) then ! 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)) + cohort_hydr%psi_aroot(j) = csite_hydr%wrf_soil(j)%p%psi_from_th(csite_hydr%h2osoi_liqvol_shell(j,1)) ! Calculate the mean total potential (include height) of absorbing roots - ! h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(j)) + ! h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + + ! mpa_per_pa*denh2o*grav_earth*(-csite_hydr%zi_rhiz(j)) - cohort_hydr%th_aroot(j) = wrfa%p%th_from_psi(cohort_hydr%psi_aroot(j)) + cohort_hydr%th_aroot(j) = max(wrfa%p%th_from_psi(cohort_hydr%psi_aroot(j)),wrfa%p%get_thmin()) cohort_hydr%ftc_aroot(j) = wkfa%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) else cohort_hydr%psi_aroot(j) = psi_aroot_init @@ -529,17 +595,22 @@ subroutine InitPlantHydStates(site, cohort) else - do j=1, site_hydr%nlevrhiz + do j=1, csite_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) = wrfa%p%th_from_psi(cohort_hydr%psi_aroot(j)) + ! h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + + ! mpa_per_pa*denh2o*grav_earth*(-csite_hydr%zi_rhiz(j)) + cohort_hydr%th_aroot(j) = max(wrfa%p%th_from_psi(cohort_hydr%psi_aroot(j)), & + wrfa%p%get_thmin()) + cohort_hydr%ftc_aroot(j) = wkfa%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) end do end if - !h_aroot_mean = h_aroot_mean/real(site_hydr%nlevrhiz,r8) - h_aroot_mean = minval(cohort_hydr%psi_aroot(:) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(:))) + !h_aroot_mean = h_aroot_mean/real(csite_hydr%nlevrhiz,r8) + + h_aroot_mean = minval(cohort_hydr%psi_aroot(:) + mpa_per_pa*denh2o*grav_earth* & + ( -csite_hydr%zi_rhiz(:)+0.5*csite_hydr%dz_rhiz(:) )) ! Get layer centers ! initialize plant water potentials with slight potential gradient (or zero) (dh/dz = C) ! the assumption is made here that initial conditions for soil water will @@ -553,7 +624,8 @@ subroutine InitPlantHydStates(site, cohort) cohort_hydr%psi_troot = h_aroot_mean - & mpa_per_pa*denh2o*grav_earth*cohort_hydr%z_node_troot - dh_dz - cohort_hydr%th_troot = wrft%p%th_from_psi(cohort_hydr%psi_troot) + cohort_hydr%th_troot = max(wrft%p%th_from_psi(cohort_hydr%psi_troot), & + wrft%p%get_thmin()) cohort_hydr%ftc_troot = wkft%p%ftc_from_psi(cohort_hydr%psi_troot) @@ -565,7 +637,8 @@ subroutine InitPlantHydStates(site, cohort) 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%th_ag(n_hypool_ag) = max(wrf_plant(stem_p_media,ft)%p%get_thmin(), & + 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)) @@ -574,9 +647,9 @@ subroutine InitPlantHydStates(site, cohort) 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)) + cohort_hydr%th_ag(k) = max(wrf_plant(csite_hydr%pm_node(k),ft)%p%th_from_psi(cohort_hydr%psi_ag(k)), & + wrf_plant(csite_hydr%pm_node(k),ft)%p%get_thmin()) + cohort_hydr%ftc_ag(k) = wkf_plant(csite_hydr%pm_node(k),ft)%p%ftc_from_psi(cohort_hydr%psi_ag(k)) end do !initialize cohort-level btran @@ -731,8 +804,8 @@ subroutine UpdatePlantHydrNodes(ccohort,ft,plant_height,csite_hydr) 0.001_r8, 0.001_r8, 0.5_r8, z_cumul_rf) if(z_cumul_rf > csite_hydr%zi_rhiz(nlevrhiz) ) then - print*,"z_cumul_rf > zi_rhiz(nlevrhiz)?",z_cumul_rf,csite_hydr%zi_rhiz(nlevrhiz) - stop + write(fates_log(),*) 'z_cumul_rf > zi_rhiz(nlevrhiz)?',z_cumul_rf,csite_hydr%zi_rhiz(nlevrhiz) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if z_cumul_rf = min(z_cumul_rf, abs(csite_hydr%zi_rhiz(nlevrhiz))) @@ -807,7 +880,7 @@ end subroutine UpdateSizeDepPlantHydProps ! ===================================================================================== - subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) + subroutine UpdatePlantHydrLenVol(ccohort,csite_hydr) ! ----------------------------------------------------------------------------------- ! This subroutine calculates two attributes of a plant: @@ -823,7 +896,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! Arguments type(ed_cohort_type),intent(inout) :: ccohort - type(ed_site_hydr_type),intent(in) :: site_hydr + type(ed_site_hydr_type),intent(in) :: csite_hydr type(ed_cohort_hydr_type),pointer :: ccohort_hydr ! Plant hydraulics structure integer :: j,k @@ -865,7 +938,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ccohort_hydr => ccohort%co_hydr ft = ccohort%pft - nlevrhiz = site_hydr%nlevrhiz + nlevrhiz = csite_hydr%nlevrhiz leaf_c = ccohort%prt%GetState(leaf_organ, carbon12_element) sapw_c = ccohort%prt%GetState(sapw_organ, carbon12_element) fnrt_c = ccohort%prt%GetState(fnrt_organ, carbon12_element) @@ -973,23 +1046,19 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! calculations. - call MaximumRootingDepth(ccohort%dbh,ft,site_hydr%zi_rhiz(nlevrhiz),z_fr) + call MaximumRootingDepth(ccohort%dbh,ft,csite_hydr%zi_rhiz(nlevrhiz),z_fr) - - norm = 1._r8 - & - zeng2001_crootfr(roota, rootb,site_hydr%zi_rhiz(1)-site_hydr%dz_rhiz(1), z_fr ) - do j=1,nlevrhiz - - rootfr = norm*(zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j),z_fr) - & - zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j)-site_hydr%dz_rhiz(j),z_fr )) + + rootfr = zeng2001_crootfr(roota, rootb, csite_hydr%zi_rhiz(j),z_fr) - & + zeng2001_crootfr(roota, rootb, csite_hydr%zi_rhiz(j)-csite_hydr%dz_rhiz(j),z_fr) if(debug)then write(fates_log(),*) 'check rooting depth of cohort ' write(fates_log(),*) 'dbh: ',ccohort%dbh,' sice class: ',ccohort%size_class - write(fates_log(),*) 'site_hydr%dz_rhiz(j) is: ', site_hydr%dz_rhiz(j) + write(fates_log(),*) 'csite_hydr%dz_rhiz(j) is: ', csite_hydr%dz_rhiz(j) write(fates_log(),*) 'z_max cohort: ',z_fr - write(fates_log(),*) 'layer: ',j,' depth (m): ',site_hydr%zi_rhiz(j),' rooting fraction:',rootfr + write(fates_log(),*) 'layer: ',j,' bottom depth (m): ',csite_hydr%zi_rhiz(j),' rooting fraction:',rootfr write(fates_log(),*) 'End of Junyan check' end if @@ -1194,14 +1263,14 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne real(r8), intent(in) :: newn ! !LOCAL VARIABLES: - type(ed_site_hydr_type), pointer :: site_hydr + type(ed_site_hydr_type), pointer :: csite_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 real(r8) :: vol_c1,vol_c2 ! Total water volume in the each cohort integer :: j,k ! indices integer :: ft - site_hydr => currentSite%si_hydr + csite_hydr => currentSite%si_hydr ccohort_hydr => currentCohort%co_hydr ncohort_hydr => nextCohort%co_hydr @@ -1217,13 +1286,13 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne call SavePreviousCompartmentVolumes(ccohort_hydr) ! This updates all of the z_node positions - call UpdatePlantHydrNodes(currentCohort,ft,currentCohort%hite,site_hydr) + call UpdatePlantHydrNodes(currentCohort,ft,currentCohort%hite,csite_hydr) ! This updates plant compartment volumes, lengths and ! maximum conductances. Make sure for already ! initialized vegetation, that SavePreviousCompartment ! volumes, and UpdatePlantHydrNodes is called prior to this. - call UpdatePlantHydrLenVol(currentCohort,site_hydr) + call UpdatePlantHydrLenVol(currentCohort,csite_hydr) ! Conserve the total water volume @@ -1238,7 +1307,7 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne vol_c2 = nextCohort%n*ncohort_hydr%th_troot*ncohort_hydr%v_troot ccohort_hydr%th_troot = (vol_c1+vol_c2)/(ccohort_hydr%v_troot*newn) - do j=1,site_hydr%nlevrhiz + do j=1,csite_hydr%nlevrhiz vol_c1 = currentCohort%n*ccohort_hydr%th_aroot(j)*ccohort_hydr%v_aroot_layer_init(j) vol_c2 = nextCohort%n*ncohort_hydr%th_aroot(j)*ncohort_hydr%v_aroot_layer(j) ccohort_hydr%th_aroot(j) = (vol_c1+vol_c2)/(ccohort_hydr%v_aroot_layer(j)*newn) @@ -1267,7 +1336,7 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne ccohort_hydr%psi_troot = wrf_plant(troot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_troot) ccohort_hydr%ftc_troot = wkf_plant(troot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_troot) - do j=1,site_hydr%nlevrhiz + 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 @@ -1332,9 +1401,16 @@ subroutine InitHydrSites(sites,bc_in) integer :: nsites integer :: s integer :: j - integer :: jj + integer :: j_bc type(ed_site_hydr_type),pointer :: csite_hydr + integer :: aggmeth ! Aggregation method + integer :: aggN ! Number of resulting rhizosphere layers + ! if using a scheme that uses aggN + + ! Different aggregation method flags, see explanation below + integer, parameter :: rhizlayer_aggmeth_none = 1 + integer, parameter :: rhizlayer_aggmeth_combine12 = 2 if ( hlm_use_planthydro.eq.ifalse ) return @@ -1343,6 +1419,7 @@ subroutine InitHydrSites(sites,bc_in) 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 @@ -1354,26 +1431,76 @@ subroutine InitHydrSites(sites,bc_in) 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 + ! ---------------------------------------------------------------------------------- + ! Create the rhizosphere layers + ! + ! These layers are allowed to aggregate soil layers. Note that these layers + ! currently do not allow partial overlap of soil layers, the layer boundaries + ! should always match soil layer boundaries. We only allow root layers to contain + ! multiple soil layers. + ! + ! rhizlayer_aggmeth_none - perform no aggregation, root layers match + ! soil layers + ! + ! rhizlayer_aggmeth_combine12 - aggregate the 1st and 2nd layers, thats it + ! + ! rhizlayer_aggmeth_gt5cm - aggregate all layers that are thinner than 5cm + ! + ! rhizlayer_aggmeth_balN - aggregate all layers such that N layers are + ! left, balancing aggregations so that they are performed + ! in equal intervals over depth, which should maintain + ! the exponential layering + ! rhizlayer_aggmeth_eqN - aggregate all layers such that N layers are left, + ! but attempt to approach a more equal depth layering + ! rhizlayer_aggmeth_Nx - simply aggregate every N layers together + ! + ! where: N = aggN + ! ---------------------------------------------------------------------------------- - 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 + aggmeth = rhizlayer_aggmeth_none + aggN = -9 + + select case(aggmeth) + + case(rhizlayer_aggmeth_none) + + csite_hydr%nlevrhiz = bc_in(s)%nlevsoil + call sites(s)%si_hydr%InitHydrSite(numpft,nlevsclass,hydr_solver_type,bc_in(s)%nlevsoil) + do j=1,csite_hydr%nlevrhiz + csite_hydr%map_r2s(j,1) = j + csite_hydr%map_r2s(j,2) = j + csite_hydr%zi_rhiz(j) = bc_in(s)%zi_sisl(j) + csite_hydr%dz_rhiz(j) = bc_in(s)%dz_sisl(j) + end do + + case(rhizlayer_aggmeth_combine12) + + csite_hydr%nlevrhiz = max(1,bc_in(s)%nlevsoil-1) + call sites(s)%si_hydr%InitHydrSite(numpft,nlevsclass,hydr_solver_type,bc_in(s)%nlevsoil) + + csite_hydr%map_r2s(1,1) = 1 + j_bc = min(2,bc_in(s)%nlevsoil) ! this protects 1 soil layer + csite_hydr%map_r2s(1,2) = j_bc + csite_hydr%zi_rhiz(1) = bc_in(s)%zi_sisl(j_bc) + csite_hydr%dz_rhiz(1) = sum(bc_in(s)%dz_sisl(1:j_bc)) + + do j=2,csite_hydr%nlevrhiz + csite_hydr%map_r2s(j,1) = j+1 + csite_hydr%map_r2s(j,2) = j+1 + csite_hydr%zi_rhiz(j) = bc_in(s)%zi_sisl(j+1) + csite_hydr%dz_rhiz(j) = bc_in(s)%dz_sisl(j+1) + end do + + case default + + write(fates_log(),*) 'You specified an undefined rhizosphere layer aggregation method' + write(fates_log(),*) 'aggmeth: ',aggmeth + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end select + end do end subroutine InitHydrSites @@ -1388,37 +1515,43 @@ subroutine HydrSiteColdStart(sites, bc_in ) type(bc_in_type),intent(in) :: bc_in(:) ! Local - type(ed_site_hydr_type), pointer :: site_hydr + type(ed_site_hydr_type), pointer :: csite_hydr real(r8) :: smp ! matric potential temp real(r8) :: h2osoi_liqvol ! liquid water content (m3/m3) + real(r8) :: eff_por ! effective porosity (m3/m3) + real(r8) :: watsat,sucsat,bsw integer :: s - integer :: j,j_bc + integer :: j,j_t,j_b 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 - + class(wrf_type_smooth_cch), pointer :: wrf_smooth_cch + class(wkf_type_smooth_cch), pointer :: wkf_smooth_cch nsites = ubound(sites,1) do s = 1,nsites - site_hydr => sites(s)%si_hydr - nlevrhiz = site_hydr%nlevrhiz + csite_hydr => sites(s)%si_hydr + nlevrhiz = csite_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)) + j_t = csite_hydr%map_r2s(j,1) ! top soil layer matching rhiz layer + j_b = csite_hydr%map_r2s(j,2) ! bottom soil layer matching rhiz layer + eff_por = csite_hydr%AggBCToRhiz(bc_in(s)%eff_porosity_sl,j,bc_in(s)%dz_sisl) + + ! [kg/m2] / ([m] * [kg/m3]) = [m3/m3] + h2osoi_liqvol = min(eff_por, & + sum(bc_in(s)%h2o_liq_sisl(j_t:j_b))/(csite_hydr%dz_rhiz(j)*denh2o)) + csite_hydr%h2osoi_liqvol_shell(j,1:nshell) = h2osoi_liqvol - 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 + csite_hydr%l_aroot_layer(1:csite_hydr%nlevrhiz) = 0.0_r8 ! -------------------------------------------------------------------------------- @@ -1433,19 +1566,42 @@ subroutine HydrSiteColdStart(sites, bc_in ) 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 + csite_hydr%wrf_soil(j)%p => wrf_vg call wrf_vg%set_wrf_param([alpha_vg, psd_vg, m_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 + do j=1,csite_hydr%nlevrhiz 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)]) + csite_hydr%wrf_soil(j)%p => wrf_cch + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + call wrf_cch%set_wrf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw]) + end do + case(smooth1_campbell_type) + do j=1,csite_hydr%nlevrhiz + allocate(wrf_smooth_cch) + csite_hydr%wrf_soil(j)%p => wrf_smooth_cch + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + call wrf_smooth_cch%set_wrf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw,1._r8]) + end do + case(smooth2_campbell_type) + do j=1,csite_hydr%nlevrhiz + allocate(wrf_smooth_cch) + csite_hydr%wrf_soil(j)%p => wrf_smooth_cch + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + call wrf_smooth_cch%set_wrf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw,2._r8]) end do case(tfs_type) write(fates_log(),*) 'TFS water retention curves not available for soil' @@ -1460,23 +1616,47 @@ subroutine HydrSiteColdStart(sites, bc_in ) case(van_genuchten_type) do j=1,sites(s)%si_hydr%nlevrhiz allocate(wkf_vg) - site_hydr%wkf_soil(j)%p => wkf_vg + csite_hydr%wkf_soil(j)%p => wkf_vg call wkf_vg%set_wkf_param([alpha_vg, psd_vg, m_vg, th_sat_vg, th_res_vg, soil_tort_vg]) end do 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)]) + csite_hydr%wkf_soil(j)%p => wkf_cch + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + call wkf_cch%set_wkf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw]) + end do + case(smooth1_campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + allocate(wkf_smooth_cch) + csite_hydr%wkf_soil(j)%p => wkf_smooth_cch + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + call wkf_smooth_cch%set_wkf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw,1._r8]) + end do + case(smooth2_campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + allocate(wkf_smooth_cch) + csite_hydr%wkf_soil(j)%p => wkf_smooth_cch + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + call wkf_smooth_cch%set_wkf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw,2._r8]) end do case(tfs_type) write(fates_log(),*) 'TFS conductance not used in soil' call endrun(msg=errMsg(sourcefile, __LINE__)) end select - + end do ! -------------------------------------------------------------------------------- @@ -1667,7 +1847,7 @@ subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & err*csite_hydr%recruit_w_uptake(j)/sumrw_uptake enddo - write(fates_log(),*) 'math check on recruit water failed.' + write(fates_log(),*) 'math check on recruit water failed with err= ', err, sumrw_uptake, recruitw_total call endrun(msg=errMsg(sourcefile, __LINE__)) endif end do ! site loop @@ -1747,7 +1927,7 @@ subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) end do ! Prevent recruitment when temperatures are freezing or below - if (bc_in%t_veg_pa(1) <= 273.15_r8) then + if (cpatch%tveg24%GetMean() <= 273.15_r8) then nmin = 0._r8 end if @@ -1821,13 +2001,13 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) type(ed_cohort_type) , pointer :: cCohort type(ed_cohort_hydr_type), pointer :: ccohort_hydr real(r8) :: hksat_s ! hksat converted to units of 10^6sec - ! which is equiv to [kg m-1 s-1 MPa-1] + ! which is equiv to [kg m-1 s-1 MPa-1] integer :: j,k ! gridcell, soil layer, rhizosphere shell indices 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 + ! 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 !----------------------------------------------------------------------- @@ -1861,9 +2041,8 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) 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) + + ! bc_in%hksat_sisl(j_bc): hydraulic conductivity at saturation (mm H2O /s) ! ! converted from [mm H2O s-1] -> [kg s-1 MPa-1 m-1] ! @@ -1875,7 +2054,8 @@ subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) ! * 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 + hksat_s = csite_hydr%AggBCToRhiz(bc_in%hksat_sisl,j,bc_in%dz_sisl) * & + 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)) .and. & @@ -1937,195 +2117,9 @@ subroutine UpdateSizeDepRhizHydProps(currentSite, bc_in ) call UpdateSizeDepRhizVolLenCon(currentSite, bc_in) - return end subroutine UpdateSizeDepRhizHydProps -! ================================================================================= - -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 - ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains - ! the same. - ! - ! !USES: - ! - ! !ARGUMENTS: - type(ed_site_type), intent(inout), target :: currentSite - type(bc_in_type), intent(in) :: bc_in - ! - ! !LOCAL VARIABLES: - 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 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] - real(r8) :: h2osoi_liq_col_new(nlevsoi_hyd_max) ! water mass per area after interpolating to new rhizosphere [kg/m2] - real(r8) :: s_shell_init(nlevsoi_hyd_max,nshell) ! initial saturation fraction in rhizosphere compartment [0-1] - real(r8) :: s_shell_interp(nlevsoi_hyd_max,nshell) ! interpolated saturation fraction in rhizosphere compartment [0-1] - real(r8) :: psi_shell_init(nlevsoi_hyd_max,nshell) ! initial water potential in rhizosphere compartment [MPa] - real(r8) :: psi_shell_interp(nlevsoi_hyd_max,nshell) ! interpolated psi_shell to new r_node_shell [MPa] - 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 - s_shell_interp(:,:) = 0._r8 - - csite_hydr => currentSite%si_hydr - - bypass_routine: if(.false.) then - - 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 - psi_shell_init(j,k) = csite_hydr%wrf_soil(j)%p%psi_from_th(csite_hydr%h2osoi_liqvol_shell(j,k)) - end do - - end if !has l_aroot_coh changed? - enddo - - ! 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 - end if - end if !has l_aroot_coh changed? - enddo - - ! 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)) - - end if !has l_aroot_coh changed? - enddo - - ! 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 - 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 - 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 - 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 - - ! 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 ',& - ' updating rhizosphere shells: ',j,errh2o(j) - write(fates_log(),*)'errh2o= ',errh2o(j), ' [kg/m2]' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - enddo - - end if bypass_routine !nshell > 1 - - -end subroutine UpdateSizeDepRhizHydStates ! ==================================================================================== @@ -2212,6 +2206,7 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) 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_t,j_b ! top and bottom soil layer indices for currenth rhiz layer 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 @@ -2229,7 +2224,6 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) do s = 1,nsites - ! First step, identify how the liquid water in each layer has changed ! since the last time it was updated. This should be due to drainage. ! The drainage component should be the total change in liquid water content from the last time @@ -2244,13 +2238,16 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) if( sum(csite_hydr%l_aroot_layer) <= nearzero ) cycle do j = 1,csite_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 + + j_t = csite_hydr%map_r2s(j,1) ! top soil layer matching rhiz layer + j_b = csite_hydr%map_r2s(j,2) ! bottom soil layer matching rhiz layer if (csite_hydr%l_aroot_layer(j) <= nearzero ) cycle 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 + ! [kg/m2] + dwat_kgm2 = sum(bc_in(s)%h2o_liq_sisl(j_t:j_b)) - cumShellH2O dwat_kg = dwat_kgm2 * AREA @@ -2312,7 +2309,7 @@ subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) csite_hydr%v_shell(j,:) * denh2o - errh2o(j) = sum(h2osoi_liq_shell(j,:))*AREA_INV - bc_in(s)%h2o_liq_sisl(j_bc) + errh2o(j) = sum(h2osoi_liq_shell(j,:))*AREA_INV - sum(bc_in(s)%h2o_liq_sisl(j_t:j_b)) if (abs(errh2o(j)) > 1.e-9_r8) then write(fates_log(),*)'WARNING: water balance error in FillDrainRhizShells' @@ -2362,6 +2359,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) integer :: i ! shell index integer :: j,jj ! soil layer integer :: j_bc ! soil layer index for boundary conditions + integer :: j_b,j_t ! bottom and top soil layers for the current rhiz layer integer :: k ! 1D plant-soil continuum array integer :: ft ! plant functional type index integer :: sz ! plant's size class index @@ -2372,7 +2370,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) 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_site_hydr_type), pointer :: csite_hydr ! site hydraulics pointer type(ed_cohort_hydr_type), pointer :: ccohort_hydr ! cohort hydraulics pointer ! Local arrays @@ -2397,6 +2395,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! 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) :: qflx_soil2root_rhiz ! soil into root water flux at this rhiz layer 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) @@ -2410,7 +2409,11 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) integer :: nlevrhiz ! local for number of rhizosphere levels integer :: sc ! size class index real(r8) :: lat,lon ! latitude and longitude of site - + real(r8) :: eff_por ! effective porosity + real(r8) :: h2osoi_liqvol ! liquid water content [m3/m3] + real(r8) :: psi_layer ! matric potential [Mpa] + real(r8) :: ftc_layer ! fraction of maximum conductance [-] + real(r8) :: sumweight ! sum of weighting functions for disaggregating rhiz -> soil ! ---------------------------------------------------------------------------------- ! Important note: We are interested in calculating the total fluxes in and out of the @@ -2432,30 +2435,36 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) do s = 1, nsites - site_hydr => sites(s)%si_hydr + csite_hydr => sites(s)%si_hydr + + if( sum(csite_hydr%l_aroot_layer) == 0._r8 ) then + bc_out(s)%qflx_soil2root_sisl(:) = 0._r8 + cycle + end if + lat = sites(s)%lat lon = sites(s)%lon - nlevrhiz = site_hydr%nlevrhiz + nlevrhiz = csite_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 + csite_hydr%dwat_veg = 0._r8 + csite_hydr%errh2o_hyd = 0._r8 + prev_h2oveg = csite_hydr%h2oveg + prev_h2osoil = sum(csite_hydr%h2osoi_liqvol_shell(:,:) * & + csite_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 + csite_hydr%sapflow_scpf(:,:) = 0._r8 + csite_hydr%rootuptake_sl(:) = 0._r8 + csite_hydr%rootuptake0_scpf(:,:) = 0._r8 + csite_hydr%rootuptake10_scpf(:,:) = 0._r8 + csite_hydr%rootuptake50_scpf(:,:) = 0._r8 + csite_hydr%rootuptake100_scpf(:,:) = 0._r8 ! Initialize water mass balancing terms [kg h2o / m2] ! -------------------------------------------------------------------------------- @@ -2486,7 +2495,8 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ccohort=>cpatch%tallest do while(associated(ccohort)) ccohort_hydr => ccohort%co_hydr - gscan_patch = gscan_patch + ccohort%g_sb_laweight + ccohort_hydr%psi_ag(1) = wrf_plant(leaf_p_media,ccohort%pft)%p%psi_from_th(ccohort_hydr%th_ag(1)) + gscan_patch = gscan_patch + ccohort%g_sb_laweight ccohort => ccohort%shorter enddo !cohort @@ -2510,6 +2520,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! 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] + ! This can cause large transpiration due to small g_sb_laweight 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 @@ -2552,14 +2563,21 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! from leaf to the current soil layer. This does NOT ! update cohort%th_* - if(use_2d_hydrosolve) then + if(hydr_solver_type == hydr_solver_2DNewton) then - call MatSolve2D(bc_in(s),site_hydr,ccohort,ccohort_hydr, & + call MatSolve2D(csite_hydr,ccohort,ccohort_hydr, & dtime,qflx_tran_veg_indiv, & sapflow,rootuptake(1:nlevrhiz),wb_err_plant,dwat_plant, & dth_layershell_col) + + elseif(hydr_solver_type == hydr_solver_2DPicard) then - else + call PicardSolve2D(csite_hydr,ccohort,ccohort_hydr, & + dtime,qflx_tran_veg_indiv, & + sapflow,rootuptake(1:nlevrhiz),wb_err_plant,dwat_plant, & + dth_layershell_col,csite_hydr%num_nodes) + + elseif(hydr_solver_type == hydr_solver_1DTaylor ) then ! --------------------------------------------------------------------------------- ! Approach: do nlevsoi_hyd sequential solutions to Richards' equation, @@ -2577,9 +2595,9 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! layers have transporting-to-absorbing root water potential gradients of opposite sign ! ----------------------------------------------------------------------------------- - call OrderLayersForSolve1D(site_hydr, ccohort, ccohort_hydr, ordered, kbg_layer) + call OrderLayersForSolve1D(csite_hydr, ccohort, ccohort_hydr, ordered, kbg_layer) - call ImTaylorSolve1D(lat,lon,recruitflag,site_hydr,ccohort,ccohort_hydr, & + call ImTaylorSolve1D(lat,lon,recruitflag,csite_hydr,ccohort,ccohort_hydr, & dtime,qflx_tran_veg_indiv,ordered, kbg_layer, & sapflow,rootuptake(1:nlevrhiz), & wb_err_plant,dwat_plant, & @@ -2591,47 +2609,43 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ccohort_hydr%errh2o = ccohort_hydr%errh2o + wb_err_plant ! Update total error in [kg/m2 ground] - site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + wb_err_plant*ccohort%n*AREA_INV + csite_hydr%errh2o_hyd = csite_hydr%errh2o_hyd + wb_err_plant*ccohort%n*AREA_INV ! Accumulate site level diagnostic of plant water change [kg/m2] ! (this is zerod) - site_hydr%dwat_veg = site_hydr%dwat_veg + dwat_plant*ccohort%n*AREA_INV + csite_hydr%dwat_veg = csite_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 + csite_hydr%h2oveg = csite_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 + csite_hydr%sapflow_scpf(sc,ft) = csite_hydr%sapflow_scpf(sc,ft) + sapflow*ccohort%n/dtime ! Root uptake per pft x size class, over set layer depths [kg/ha/m/s] ! These are normalized by depth (in case the desired horizon extends ! beyond the actual rhizosphere) - site_hydr%rootuptake0_scpf(sc,ft) = site_hydr%rootuptake0_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,0._r8,0.1_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime + csite_hydr%rootuptake0_scpf(sc,ft) = csite_hydr%rootuptake0_scpf(sc,ft) + & + SumBetweenDepths(csite_hydr,0._r8,0.1_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - site_hydr%rootuptake10_scpf(sc,ft) = site_hydr%rootuptake10_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,0.1_r8,0.5_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime + csite_hydr%rootuptake10_scpf(sc,ft) = csite_hydr%rootuptake10_scpf(sc,ft) + & + SumBetweenDepths(csite_hydr,0.1_r8,0.5_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - site_hydr%rootuptake50_scpf(sc,ft) = site_hydr%rootuptake50_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,0.5_r8,1.0_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime + csite_hydr%rootuptake50_scpf(sc,ft) = csite_hydr%rootuptake50_scpf(sc,ft) + & + SumBetweenDepths(csite_hydr,0.5_r8,1.0_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - site_hydr%rootuptake100_scpf(sc,ft) = site_hydr%rootuptake100_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,1.0_r8,1.e10_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime + csite_hydr%rootuptake100_scpf(sc,ft) = csite_hydr%rootuptake100_scpf(sc,ft) + & + SumBetweenDepths(csite_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) + call UpdatePlantPsiFTCFromTheta(ccohort,csite_hydr) ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) @@ -2653,7 +2667,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! water contents. But the pre-adjusted value is the actual amount of root flux. ! [kg/m2] - root_flux = -sum(dth_layershell_col(1:site_hydr%nlevrhiz,:)*site_hydr%v_shell(:,:))*denh2o*AREA_INV + root_flux = -sum(dth_layershell_col(1:csite_hydr%nlevrhiz,:)*csite_hydr%v_shell(:,:))*denh2o*AREA_INV if(debug)then write(fates_log(),*) 'root_flux: ', root_flux @@ -2664,105 +2678,100 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) bc_out(s)%qflx_ro_sisl(:) = 0._r8 - do j=1,site_hydr%nlevrhiz - j_bc = j+site_hydr%i_rhiz_t-1 + do j=1,csite_hydr%nlevrhiz + ! loginfo if (debug) then write(fates_log(),*) 'hydraulics_bc() position I' write(fates_log(),*) 'layer: ', j write(fates_log(),*) 'dth_layershell_col(j,:):', dth_layershell_col(j,:) - write(fates_log(),*) 'site_hydr%v_shell(j,:):', site_hydr%v_shell(j,:) - write(fates_log(),*) 'site_hydr%h2osoi_liqvol_shell: ', site_hydr%h2osoi_liqvol_shell(j,:) + write(fates_log(),*) 'csite_hydr%v_shell(j,:):', csite_hydr%v_shell(j,:) + write(fates_log(),*) 'csite_hydr%h2osoi_liqvol_shell: ', csite_hydr%h2osoi_liqvol_shell(j,:) write(fates_log(),*) 'dth_layershell_col(j,:) ', dth_layershell_col(j,:) - write(fates_log(),*) 'site_hydr%l_aroot_layer(j): ' , site_hydr%l_aroot_layer(j) + write(fates_log(),*) 'csite_hydr%l_aroot_layer(j): ' , csite_hydr%l_aroot_layer(j) endif - if (site_hydr%l_aroot_layer(j) > nearzero) then + if (csite_hydr%l_aroot_layer(j) > nearzero) then ! Update the site-level state variable ! rhizosphere shell water content [m3/m3] - site_hydr%h2osoi_liqvol_shell(j,:) = site_hydr%h2osoi_liqvol_shell(j,:) + & + csite_hydr%h2osoi_liqvol_shell(j,:) = csite_hydr%h2osoi_liqvol_shell(j,:) + & dth_layershell_col(j,:) + ! Total root uptake flux at the rhizosphere layer [mm h2o/s] = [kg h2o/m2/s] + qflx_soil2root_rhiz = & + -(sum(dth_layershell_col(j,:)*csite_hydr%v_shell(j,:))*denh2o*AREA_INV/dtime) + & + csite_hydr%recruit_w_uptake(j) - bc_out(s)%qflx_soil2root_sisl(j_bc) = & - -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:))*denh2o*AREA_INV/dtime) + & - site_hydr%recruit_w_uptake(j) - - - ! 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) + ! Partition the uptake flux into the soil layer + ! Weight the flux by the vertically integrated conductance estimate "ftc*hksat*dz" + j_t = csite_hydr%map_r2s(j,1) + j_b = csite_hydr%map_r2s(j,2) + + sumweight = 0._r8 + do j_bc = j_t,j_b - end if - - ! We accept that it is possible for gravity to push - ! water into saturated soils, particularly at night when - ! transpiration has stopped. In the real world, the water - ! would be driven out of the layer, although we have no - ! boundary flux on the rhizospheres in these substeps. To accomodate - ! this, if soils are pushed beyond saturation minus a small buffer - ! then we remove that excess, send it to a runoff pool, and - ! fix the node's water content to the saturation minus buffer value - - 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 + ! h2osoi_liqvol: [kg/m2] / [m] / [kg/m3] = [m3/m3] - end if + eff_por = bc_in(s)%eff_porosity_sl(j_bc) + h2osoi_liqvol = min(eff_por, bc_in(s)%h2o_liq_sisl(j_bc)/(bc_in(s)%dz_sisl(j_bc)*denh2o)) + psi_layer = csite_hydr%wrf_soil(j)%p%psi_from_th(h2osoi_liqvol) + ftc_layer = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_layer) + sumweight = sumweight + bc_in(s)%hksat_sisl(j_bc)*ftc_layer*bc_in(s)%dz_sisl(j_bc) + end do - bc_out(s)%qflx_ro_sisl(j_bc) = site_runoff/dtime + do j_bc = j_t,j_b + eff_por = bc_in(s)%eff_porosity_sl(j_bc) + h2osoi_liqvol = min(eff_por, bc_in(s)%h2o_liq_sisl(j_bc)/(bc_in(s)%dz_sisl(j_bc)*denh2o)) + psi_layer = csite_hydr%wrf_soil(j)%p%psi_from_th(h2osoi_liqvol) + ftc_layer = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_layer) + + ! Fill the output array to the HLM + bc_out(s)%qflx_soil2root_sisl(j_bc) = qflx_soil2root_rhiz * & + (bc_in(s)%hksat_sisl(j_bc)*ftc_layer*bc_in(s)%dz_sisl(j_bc)/sumweight) + + ! Save root uptake for history diagnostics [kg/m/s] + csite_hydr%rootuptake_sl(j_bc) = qflx_soil2root_rhiz * & + (bc_in(s)%hksat_sisl(j_bc)*ftc_layer*bc_in(s)%dz_sisl(j_bc)/sumweight) + + end do + end if enddo - + + ! Removed supersaturation purge because + ! calculation is messier now that roots are on + ! different layering system. + ! see tags prior to 1.52.0_api.20.0.0 + ! to revive old code (RGK 12-2021) + bc_out(s)%qflx_ro_sisl(:) = 0._r8 ! Note that the cohort-level solvers are expected to update - ! site_hydr%h2oveg + ! csite_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_plant_storage = csite_hydr%h2oveg - prev_h2oveg - delta_soil_storage = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & - site_hydr%v_shell(:,:)) * denh2o * AREA_INV - prev_h2osoil + delta_soil_storage = sum(csite_hydr%h2osoi_liqvol_shell(:,:) * & + csite_hydr%v_shell(:,:)) * denh2o * AREA_INV - prev_h2osoil if(abs(delta_plant_storage - (root_flux - transp_flux)) > error_thresh ) 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 + write(fates_log(),*) 'end storage: ',csite_hydr%h2oveg write(fates_log(),*) 'pre_h2oveg', prev_h2oveg call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(abs(delta_soil_storage + root_flux + site_runoff) > 1.e-3_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 - - !----------------------------------------------------------------------- ! mass balance check and pass the total stored vegetation water to HLM ! in order for it to fill its balance checks @@ -2778,7 +2787,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! Now check on total error if( abs(wb_check_site) > 1.e-4_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(),*) 'csite_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 @@ -2786,7 +2795,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) end if - site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + site_hydr%errh2o_hyd + csite_hydr%h2oveg_hydro_err = csite_hydr%h2oveg_hydro_err + csite_hydr%errh2o_hyd call UpdateH2OVeg(sites(s),bc_out(s)) @@ -3033,10 +3042,10 @@ end subroutine UpdatePlantKmax ! =================================================================================== -subroutine OrderLayersForSolve1D(site_hydr,cohort,cohort_hydr,ordered, kbg_layer) +subroutine OrderLayersForSolve1D(csite_hydr,cohort,cohort_hydr,ordered, kbg_layer) ! Arguments (IN) - type(ed_site_hydr_type), intent(in),target :: site_hydr + type(ed_site_hydr_type), intent(in),target :: csite_hydr type(ed_cohort_type), intent(in),target :: cohort type(ed_cohort_hydr_type),intent(in),target :: cohort_hydr @@ -3070,7 +3079,7 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort,cohort_hydr,ordered, kbg_layer ft = cohort%pft - do j=1,site_hydr%nlevrhiz + do j=1,csite_hydr%nlevrhiz if(cohort_hydr%l_aroot_layer(j)>nearzero)then @@ -3080,7 +3089,7 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort,cohort_hydr,ordered, kbg_layer ! 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)) + psi_inner_shell = csite_hydr%wrf_soil(j)%p%psi_from_th(csite_hydr%h2osoi_liqvol_shell(j,1)) ! Note, since their is no elevation difference between ! the absorbing root and its layer, no need to calc @@ -3104,16 +3113,16 @@ subroutine OrderLayersForSolve1D(site_hydr,cohort,cohort_hydr,ordered, kbg_layer ! Path is across the upper an lower rhizosphere comparment ! on each side of the nodes. Since there is no flow across the outer ! node to the edge, we ignore that last half compartment - aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) + aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/csite_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 + kmax_up = csite_hydr%kmax_upper_shell(j,k)*aroot_frac_plant + kmax_lo = csite_hydr%kmax_lower_shell(j,k)*aroot_frac_plant - psi_shell = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,k)) + psi_shell = csite_hydr%wrf_soil(j)%p%psi_from_th(csite_hydr%h2osoi_liqvol_shell(j,k)) - ftc_shell = site_hydr%wkf_soil(j)%p%ftc_from_psi(psi_shell) + ftc_shell = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_shell) r_bg = r_bg + 1._r8/(kmax_up*ftc_shell) if(k site_hydr%pm_node) + associate(pm_node => csite_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) @@ -3305,7 +3314,7 @@ subroutine ImTaylorSolve1D(slat, slon,recruitflag,site_hydr,cohort,cohort_hydr,d ! Go through soil layers in order of decreasing total root-soil conductance ! ----------------------------------------------------------------------------------- - loop_root_layers: do jj=1,site_hydr%nlevrhiz + loop_root_layers: do jj=1,csite_hydr%nlevrhiz ilayer = ordered(jj) @@ -3324,7 +3333,7 @@ subroutine ImTaylorSolve1D(slat, slon,recruitflag,site_hydr,cohort,cohort_hydr,d if(weight_serial_dt)then dt_step = dtime*kbg_layer(ilayer) else - dt_step = dtime/real(site_hydr%nlevrhiz,r8) + dt_step = dtime/real(csite_hydr%nlevrhiz,r8) end if end if @@ -3340,9 +3349,9 @@ subroutine ImTaylorSolve1D(slat, slon,recruitflag,site_hydr,cohort,cohort_hydr,d ! 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] + ! csite_hydr%l_aroot_layer(ilayer) is units [m/site] - aroot_frac_plant = cohort_hydr%l_aroot_layer(ilayer)/site_hydr%l_aroot_layer(ilayer) + aroot_frac_plant = cohort_hydr%l_aroot_layer(ilayer)/csite_hydr%l_aroot_layer(ilayer) wb_err_layer = 0._r8 @@ -3371,15 +3380,15 @@ subroutine ImTaylorSolve1D(slat, slon,recruitflag,site_hydr,cohort,cohort_hydr,d v_node(i) = cohort_hydr%v_troot th_node_init(i) = cohort_hydr%th_troot elseif (i==n_hypool_ag+2) then ! i=4, fine roots - z_node(i) = -site_hydr%zi_rhiz(ilayer) + z_node(i) = -csite_hydr%zi_rhiz(ilayer)+0.5*csite_hydr%dz_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) ! i>=5, rhizosphere - z_node(i) = -site_hydr%zi_rhiz(ilayer) + z_node(i) = -csite_hydr%zi_rhiz(ilayer)+0.5*csite_hydr%dz_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) + v_node(i) = csite_hydr%v_shell(ilayer,ishell)*aroot_frac_plant + th_node_init(i) = csite_hydr%h2osoi_liqvol_shell(ilayer,ishell) if (th_node_init(i) < -nearzero) then write(fates_log(),*) 'ImTaylorSolve1D(), print out shell theta' write(fates_log(),*) 'layer: ',ilayer, 'shell:', ishell @@ -3401,7 +3410,7 @@ subroutine ImTaylorSolve1D(slat, slon,recruitflag,site_hydr,cohort,cohort_hydr,d ! Gracefully quit if too many iterations have been used if(iter>max_iter)then - call Report1DError(cohort,site_hydr,ilayer,z_node,v_node, & + call Report1DError(cohort,csite_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, & slat, slon,recruitflag) @@ -3474,11 +3483,11 @@ subroutine ImTaylorSolve1D(slat, slon,recruitflag,site_hydr,cohort,cohort_hydr,d ! 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)) + psi_node(i) = csite_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)) + ftc_node(i) = csite_hydr%wkf_soil(ilayer)%p%ftc_from_psi(psi_node(i)) + dpsi_dtheta_node(i) = csite_hydr%wrf_soil(ilayer)%p%dpsidth_from_th(th_node(i)) + dftc_dpsi = csite_hydr%wkf_soil(ilayer)%p%dftcdpsi_from_psi(psi_node(i)) dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) end do @@ -3590,7 +3599,7 @@ subroutine ImTaylorSolve1D(slat, slon,recruitflag,site_hydr,cohort,cohort_hydr,d 1._r8/cohort_hydr%kmax_aroot_radial_out(ilayer)) end if - kmax_up = site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant + kmax_up = csite_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant call GetImTaylorKAB(kmax_up,kmax_dn, & ftc_node(i_up),ftc_node(i_dn), & @@ -3610,8 +3619,8 @@ subroutine ImTaylorSolve1D(slat, slon,recruitflag,site_hydr,cohort,cohort_hydr,d 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 + kmax_dn = csite_hydr%kmax_lower_shell(ilayer,ishell_dn)*aroot_frac_plant + kmax_up = csite_hydr%kmax_upper_shell(ilayer,ishell_up)*aroot_frac_plant call GetImTaylorKAB(kmax_up,kmax_dn, & ftc_node(i_up),ftc_node(i_dn), & @@ -3705,7 +3714,7 @@ subroutine ImTaylorSolve1D(slat, slon,recruitflag,site_hydr,cohort,cohort_hydr,d 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)) + psi_node(i) = csite_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) end do ! If desired, check and trap pressures that are supersaturated @@ -3717,7 +3726,7 @@ subroutine ImTaylorSolve1D(slat, slon,recruitflag,site_hydr,cohort,cohort_hydr,d end if end do do i = n_hypool_plant+1,n_hypool_tot - if(psi_node(i)>site_hydr%wrf_soil(ilayer)%p%get_thsat()) then + if(psi_node(i)>csite_hydr%wrf_soil(ilayer)%p%get_thsat()) then solution_found = .false. error_code = 4 end if @@ -3854,7 +3863,7 @@ subroutine ImTaylorSolve1D(slat, slon,recruitflag,site_hydr,cohort,cohort_hydr,d dth_layershell_col(ilayer,:) = dth_layershell_col(ilayer,:) + & dth_node((n_hypool_tot-nshell+1):n_hypool_tot) * & cohort_hydr%l_aroot_layer(ilayer) * & - cohort%n / site_hydr%l_aroot_layer(ilayer) + cohort%n / csite_hydr%l_aroot_layer(ilayer) enddo loop_root_layers @@ -3864,7 +3873,7 @@ end subroutine ImTaylorSolve1D ! ===================================================================================== -subroutine Report1DError(cohort, site_hydr, ilayer, z_node, v_node, & +subroutine Report1DError(cohort, csite_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,slat,slon, recruitflag) @@ -3873,7 +3882,7 @@ subroutine Report1DError(cohort, site_hydr, ilayer, z_node, v_node, & ! Arguments (IN) type(ed_cohort_type),intent(in),target :: cohort - type(ed_site_hydr_type),intent(in), target :: site_hydr + type(ed_site_hydr_type),intent(in), target :: csite_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 @@ -3913,11 +3922,11 @@ subroutine Report1DError(cohort, site_hydr, ilayer, z_node, v_node, & 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)) + psi_node(i) = wrf_plant(csite_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)) + psi_node(i) = csite_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 @@ -3954,25 +3963,25 @@ subroutine Report1DError(cohort, site_hydr, ilayer, z_node, v_node, & 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/(csite_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/(csite_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(),*) ' ',1._r8/(1._r8/(csite_hydr%kmax_lower_shell(ilayer,1)*aroot_frac_plant) + 1._r8/(csite_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(),*) ' ',1._r8/(1._r8/(csite_hydr%kmax_lower_shell(ilayer,2)*aroot_frac_plant) + 1._r8/(csite_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(),*) ' ',1._r8/(1._r8/(csite_hydr%kmax_lower_shell(ilayer,3)*aroot_frac_plant) + 1._r8/(csite_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(),*) ' ',1._r8/(1._r8/(csite_hydr%kmax_lower_shell(ilayer,4)*aroot_frac_plant) + 1._r8/(csite_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(),*) 'aroot_frac_plant: ',aroot_frac_plant,cohort_hydr%l_aroot_layer(ilayer),csite_hydr%l_aroot_layer(ilayer) + write(fates_log(),*) 'kmax_upper_shell: ',csite_hydr%kmax_lower_shell(ilayer,:)*aroot_frac_plant + write(fates_log(),*) 'kmax_lower_shell: ',csite_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' @@ -3980,7 +3989,7 @@ subroutine Report1DError(cohort, site_hydr, ilayer, z_node, v_node, & 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(),*) ' ',2._r8 * pi_const * csite_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) @@ -3988,7 +3997,7 @@ subroutine Report1DError(cohort, site_hydr, ilayer, z_node, v_node, & 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 + write(fates_log(),*) 'inner shell kmaxs: ',csite_hydr%kmax_lower_shell(:,1)*aroot_frac_plant deallocate(psi_node) deallocate(h_node) @@ -4033,8 +4042,14 @@ subroutine GetImTaylorKAB(kmax_up,kmax_dn, & ! Locals real(r8) :: h_diff ! Total potential difference [MPa] + real(r8) :: ftc_dn_tmp, ftc_up_tmp ! working frac total conductance [-] + + ! Store ftc before changing it + ftc_dn_tmp = ftc_dn + ftc_up_tmp = ftc_up + ! Calculate difference in total potential over the path [MPa] h_diff = h_up - h_dn @@ -4068,7 +4083,9 @@ subroutine GetImTaylorKAB(kmax_up,kmax_dn, & 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 - + ! Restore ftc + ftc_dn = ftc_dn_tmp + ftc_up = ftc_up_tmp return end subroutine GetImTaylorKAB @@ -4269,7 +4286,7 @@ subroutine MaximumRootingDepth(dbh,ft,z_max_soil,z_fr) ! Calculate the maximum rooting depth of the plant. ! ! This is an exponential which is constrained by the maximum soil depth: - ! site_hydr%zi_rhiz(nlevrhiz) + ! csite_hydr%zi_rhiz(nlevrhiz) ! The dynamic root growth model by Junyan Ding, June 9, 2021 ! --------------------------------------------------------------------------------- @@ -4326,6 +4343,7 @@ subroutine bisect_rootfr(a, b, z_max, lower_init, upper_init, xtol, ytol, crootf real(r8) :: y_new ! corresponding y value at x.new real(r8) :: f_new ! y difference between new y guess at x.new and target y real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) + integer :: nitr ! number of iterations !---------------------------------------------------------------------- lower = lower_init @@ -4333,6 +4351,7 @@ subroutine bisect_rootfr(a, b, z_max, lower_init, upper_init, xtol, ytol, crootf f_lo = zeng2001_crootfr(a, b, lower, z_max) - crootfr f_hi = zeng2001_crootfr(a, b, upper, z_max) - crootfr chg = upper - lower + nitr = 0 do while(abs(chg) .gt. xtol) x_new = 0.5_r8*(lower + upper) f_new = zeng2001_crootfr(a, b, x_new, z_max) - crootfr @@ -4342,7 +4361,11 @@ subroutine bisect_rootfr(a, b, z_max, lower_init, upper_init, xtol, ytol, crootf 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> 100)then + write(fates_log(),*)'Warning: number of iteraction exceeds 100 for bisect_rootfr' + endif end subroutine bisect_rootfr ! ===================================================================================== @@ -4618,10 +4641,10 @@ end subroutine Hydraulics_Tridiagonal ! ===================================================================================== -subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & - tmx,qtop, & - sapflow,rootuptake,wb_err_plant , dwat_plant, & - dth_layershell_site) +subroutine MatSolve2D(csite_hydr,cohort,cohort_hydr, & + tmx,qtop, & + sapflow,rootuptake,wb_err_plant , dwat_plant, & + dth_layershell_site) ! --------------------------------------------------------------------------------- @@ -4656,8 +4679,7 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ! ARGUMENTS: ! ----------------------------------------------------------------------------------- - type(bc_in_type),intent(in) :: bc_in - type(ed_site_hydr_type), intent(inout),target :: site_hydr ! ED site_hydr structure + type(ed_site_hydr_type), intent(inout),target :: csite_hydr ! ED csite_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] @@ -4774,9 +4796,9 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ! reduction factor for soil compartments real(r8), parameter :: rlfx_plnt_init = 1.0 ! Initial Pressure update ! reduction factor for plant comparmtents - real(r8), parameter :: dpsi_scap = 0.2 ! Changes in psi (for soil) larger than this + real(r8), parameter :: dpsi_scap = 0.1 ! Changes in psi (for soil) larger than this ! will be subject to a capping routine - real(r8), parameter :: dpsi_pcap = 0.3 ! Change sin psi (for plants) larger than this + real(r8), parameter :: dpsi_pcap = 0.1 ! Change sin psi (for plants) larger than this ! will be subject to a capping routine real(r8), parameter :: rlfx_plnt_shrink = 1.0 ! Shrink the starting plant relaxtion factor ! by this multipliler each round @@ -4793,26 +4815,26 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & - 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_prev => site_hydr%th_node_prev, & - 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, & + associate(conn_up => csite_hydr%conn_up, & + conn_dn => csite_hydr%conn_dn, & + kmax_up => csite_hydr%kmax_up, & + kmax_dn => csite_hydr%kmax_dn, & + q_flux => csite_hydr%q_flux, & + residual => csite_hydr%residual, & + ajac => csite_hydr%ajac, & + ipiv => csite_hydr%ipiv, & + th_node => csite_hydr%th_node, & + th_node_prev => csite_hydr%th_node_prev, & + th_node_init => csite_hydr%th_node_init, & + psi_node => csite_hydr%psi_node, & + pm_node => csite_hydr%pm_node, & + ftc_node => csite_hydr%ftc_node, & + z_node => csite_hydr%z_node, & + v_node => csite_hydr%v_node, & + dth_node => csite_hydr%dth_node, & + node_layer => csite_hydr%node_layer, & + h_node => csite_hydr%h_node, & + dftc_dpsi_node => csite_hydr%dftc_dpsi_node, & ft => cohort%pft) @@ -4821,7 +4843,7 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ! This NaN's the scratch arrays - call site_hydr%FlushSiteScratch() + call csite_hydr%FlushSiteScratch(hydr_solver_type) ! This is the maximum number of iterations needed for this cohort ! (each soil layer has a different number, this saves the max) @@ -4860,14 +4882,14 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ! from the cohort structures, into the complete node vector i = n_hypool_ag + n_hypool_troot - do j = 1,site_hydr%nlevrhiz + do j = 1,csite_hydr%nlevrhiz ! Calculate the fraction of the soil layer ! folume that this plant's rhizosphere accounts forPath is across the upper an lower rhizosphere comparment ! on each side of the nodes. Since there is no flow across the outer ! node to the edge, we ignore that last half compartment if(cohort_hydr%l_aroot_layer(j)>nearzero)then - aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) + aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/csite_hydr%l_aroot_layer(j) else aroot_frac_plant = 0._r8 end if @@ -4875,15 +4897,15 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & do k = 1, n_hypool_aroot + nshell i = i + 1 if (k==1) then - z_node(i) = -site_hydr%zi_rhiz(j) + z_node(i) = -csite_hydr%zi_rhiz(j)+0.5*csite_hydr%dz_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) + z_node(i) = -csite_hydr%zi_rhiz(j)+0.5*csite_hydr%dz_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) + v_node(i) = csite_hydr%v_shell(j,kshell)*aroot_frac_plant + th_node_init(i) = csite_hydr%h2osoi_liqvol_shell(j,kshell) end if enddo @@ -4951,7 +4973,7 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ajac(:,:) = 0._r8 residual(:) = 0._r8 - do k=1,site_hydr%num_nodes + do k=1,csite_hydr%num_nodes ! This is the storage gained from previous newton iterations. residual(k) = residual(k) + denh2o*v_node(k)*(th_node(k) - th_node_prev(k))/dtime @@ -4959,14 +4981,14 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & 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)) + psi_node(k) = csite_hydr%wrf_soil(j)%p%psi_from_th(th_node(k)) ! Get total potential [Mpa] h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) ! Get Fraction of Total Conductivity [-] - ftc_node(k) = site_hydr%wkf_soil(j)%p%ftc_from_psi(psi_node(k)) + ftc_node(k) = csite_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)) + dftc_dpsi_node(k) = csite_hydr%wkf_soil(j)%p%dftcdpsi_from_psi(psi_node(k)) else @@ -4985,7 +5007,7 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & if(pm_node(k) == rhiz_p_media) then j = node_layer(k) - ajac(k,k) = -denh2o*v_node(k)/(site_hydr%wrf_soil(j)%p%dpsidth_from_th(th_node(k))*dtime) + ajac(k,k) = -denh2o*v_node(k)/(csite_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 @@ -4997,10 +5019,10 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ! 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) + call SetMaxCondConnections(csite_hydr, cohort_hydr, h_node, kmax_dn, kmax_up) ! calculate boundary fluxes - do icnx=1,site_hydr%num_connections + do icnx=1,csite_hydr%num_connections id_dn = conn_dn(icnx) id_up = conn_up(icnx) @@ -5076,7 +5098,7 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & residual_amax = 0._r8 nsd = 0 - do k = 1, site_hydr%num_nodes + do k = 1, csite_hydr%num_nodes rsdx = abs(residual(k)) ! check NaNs if( rsdx /= rsdx ) then @@ -5209,7 +5231,7 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ! --------------------------------------------------------------------------- !cohort_hydr%iterh2 = cohort_hydr%iterh2 - call DGESV(site_hydr%num_nodes,1,ajac,site_hydr%num_nodes,ipiv,residual,site_hydr%num_nodes,info) + call DGESV(csite_hydr%num_nodes,1,ajac,csite_hydr%num_nodes,ipiv,residual,csite_hydr%num_nodes,info) if ( info < 0 ) then @@ -5235,7 +5257,7 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & ! Update the matric potential of each node. Since this is a search ! we update matric potential as only a fraction of delta psi (residual) - do k = 1, site_hydr%num_nodes + do k = 1, csite_hydr%num_nodes if(pm_node(k) == rhiz_p_media) then j = node_layer(k) @@ -5244,7 +5266,7 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & else psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_scap,residual(k)) - dpsi_scap*dpsi_scap/residual(k) endif - th_node(k) = site_hydr%wrf_soil(j)%p%th_from_psi(psi_node(k)) + th_node(k) = csite_hydr%wrf_soil(j)%p%th_from_psi(psi_node(k)) else if(abs(residual(k)) < dpsi_pcap) then psi_node(k) = psi_node(k) + residual(k) * rlfx_plnt @@ -5291,7 +5313,7 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & sapflow = sapflow + q_flux(n_hypool_ag)*tmx - do j = 1,site_hydr%nlevrhiz + do j = 1,csite_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)*tmx @@ -5309,7 +5331,7 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & dwat_plant = sum(dth_node(1:n_hypool_ag+n_hypool_troot)*v_node(1:n_hypool_ag+n_hypool_troot))*denh2o inode = n_hypool_ag+n_hypool_troot - do j = 1,site_hydr%nlevrhiz + do j = 1,csite_hydr%nlevrhiz do k = 1, 1 + nshell inode = inode + 1 if(k==1) then @@ -5319,7 +5341,7 @@ subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & 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) + cohort%n / csite_hydr%l_aroot_layer(j) endif enddo @@ -5339,14 +5361,14 @@ end subroutine MatSolve2D ! ===================================================================================== -function SumBetweenDepths(site_hydr,depth_t,depth_b,array_in) result(depth_sum) +function SumBetweenDepths(csite_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 + ! for array_in do match csite_hydr%zi_rhiz (on rhizosphere layers), and that ! those coordinates are positive down. - type(ed_site_hydr_type), intent(in) :: site_hydr + type(ed_site_hydr_type), intent(in) :: csite_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?) @@ -5356,9 +5378,9 @@ function SumBetweenDepths(site_hydr,depth_t,depth_b,array_in) result(depth_sum) 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)1) then - frac = (site_hydr%zi_rhiz(i_rhiz_t-1)-depth_t)/site_hydr%dz_rhiz(i_rhiz_t-1) + frac = (csite_hydr%zi_rhiz(i_rhiz_t-1)-depth_t)/csite_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 rhizosphere shell + + integer :: nsd ! node index of highest residual + integer :: nwtn_iter ! number of (Newton) iterations on each substep + + ! to get a succesfull Newton solve. + integer :: kshell ! rhizosphere shell index, 1->nshell + + integer :: info + integer :: nstep !number of time steps + + + ! 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 + + ! Maximum number of times we re-try a round of Picard + ! iterations, each time decreasing the time-step and + ! potentially reducing relaxation factors + integer, parameter :: max_picard_rounds = 100 + + ! dtime will shrink at the following rate (halving) [s]: + ! 1800,900,450,225,112.5,56.25,28.125,14.0625,7.03125,3.515625, + ! 1.7578125,0.87890625,0.439453125,0.2197265625,0.10986328125, + ! 0.054931640625,0.0274658203125,0.01373291015625,0.006866455078125, + ! 0.0034332275390625,0.00171661376953125, + + + ! 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 + + + integer, parameter :: icnv_fail_round = 1 + integer, parameter :: icnv_pass_round = 2 + + ! Timestep reduction factor when a round of + ! newton iterations fail. + + real(r8), parameter :: dtime_rf = 0.5_r8 + + ! These are the initial relaxation factors at the beginning + ! of the large time-step. These may or may not shrink on + ! subsequent rounds, and may or may not grow over subsequent + ! iterations within rounds + real(r8), parameter :: rlfx_soil_init = 1.0 ! Initial Pressure update + ! reduction factor for soil compartments + real(r8), parameter :: rlfx_plnt_init = 1.0 ! Initial Pressure update + ! reduction factor for plant comparmtents + real(r8), parameter :: dpsi_scap = 0.1 ! Changes in psi (for soil) larger than this + ! will be subject to a capping routine + real(r8), parameter :: dpsi_pcap = 0.1 ! Change sin psi (for plants) larger than this + ! will be subject to a capping routine + real(r8), parameter :: rlfx_plnt_shrink = 1.0 ! Shrink the starting plant relaxtion factor + ! by this multipliler each round + real(r8), parameter :: rlfx_soil_shrink = 1.0 ! Shrink the starting soil relaxtion factor + ! by this multipliler each round + logical, parameter :: reset_on_fail = .false. ! If a round of Newton iterations is unable + ! to find a solution, you can either reset + ! to the beginning of the large timestep (true), or + ! to the beginning of the current substep (false) + + logical, parameter :: allow_lenient_lastiter = .true. ! If this is true, when the newton iteration + ! reaches its last allowed attempt, the + ! error tolerance will be increased (the bar lowered) by 10x + + real(r8), parameter :: cfl = 1.0_r8 !courant number (volume of water replaced in dt) + real(r8) :: cfl_max !maximum courant number + real(r8) :: wb_error ! sub sep error + real(r8) :: a_term ! flux contribution to dn_node + real(r8) :: b_term ! flux contribution to up_node + real(r8) :: dftc_dtheta_node(nnode) ! deriv FTC w.r.t. theta + real(r8) :: dpsi_dtheta_node(nnode) ! deriv psi w.r.t. theta + real(r8) :: volx !temporary volume + integer :: picd_iter !picard iteration counter + real(r8) :: th_prev(nnode) !temporary for th from previous iteration + + + associate(conn_up => csite_hydr%conn_up, & + conn_dn => csite_hydr%conn_dn, & + kmax_up => csite_hydr%kmax_up, & + kmax_dn => csite_hydr%kmax_dn, & + q_flux => csite_hydr%q_flux, & + residual => csite_hydr%residual, & + ajac => csite_hydr%ajac, & + ipiv => csite_hydr%ipiv, & + th_node => csite_hydr%th_node, & + th_node_prev => csite_hydr%th_node_prev, & + th_node_init => csite_hydr%th_node_init, & + psi_node => csite_hydr%psi_node, & + pm_node => csite_hydr%pm_node, & + ftc_node => csite_hydr%ftc_node, & + z_node => csite_hydr%z_node, & + v_node => csite_hydr%v_node, & + dth_node => csite_hydr%dth_node, & + node_layer => csite_hydr%node_layer, & + h_node => csite_hydr%h_node, & + dftc_dpsi_node => csite_hydr%dftc_dpsi_node, & + ft => cohort%pft) + + + !for debug only + nstep = get_nstep() + + + ! This NaN's the scratch arrays + call csite_hydr%FlushSiteScratch(hydr_solver_type) + + ! This is the maximum number of iterations needed for this cohort + ! (each soil layer has a different number, this saves the max) + cohort_hydr%iterh1 = 0 + cohort_hydr%iterh2 = 0 + + ! These are output fluxes from the subroutine, total integrated + ! mass fluxes [kg] over the time-step. sapflow is the integrated + ! flux between the transporting root and the 1st stem compartment. + ! The rootuptake is the integrated flux between the 1st rhizosphere + ! and absorbing roots + sapflow = 0._r8 + rootuptake(:) = 0._r8 + + ! Chnage in water content, over all substeps [m3/m3] + dth_node(:) = 0._r8 + + ! Transfer node heights, volumes and initial water contents for + ! the transporting root and above ground compartments to the + ! complete node vector + + 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,csite_hydr%nlevrhiz + + ! Calculate the fraction of the soil layer + ! folume that this plant's rhizosphere accounts forPath is across the upper an lower rhizosphere comparment + ! 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)/csite_hydr%l_aroot_layer(j) + + do k = 1, n_hypool_aroot + nshell + i = i + 1 + if (k==1) then + z_node(i) = -csite_hydr%zi_rhiz(j)+0.5*csite_hydr%dz_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) = -csite_hydr%zi_rhiz(j)+0.5*csite_hydr%dz_rhiz(j) + ! The volume of the Rhizosphere for a single plant + v_node(i) = csite_hydr%v_shell(j,kshell)*aroot_frac_plant + th_node_init(i) = csite_hydr%h2osoi_liqvol_shell(j,kshell) + end if + enddo + + enddo + ! Initialize variables and flags that track + ! the progress of the solve + + tm = 0 + nsteps = 0 + th_node_prev(:) = th_node_init(:) + th_node(:) = th_node_init(:) + dtime = tmx + + ! Total water mass in the plant at the beginning of this solve [kg h2o] + w_tot_beg = sum(th_node_init(:)*v_node(:))*denh2o + + ! calculate cfl + cfl_max = 0._r8 + do k=1,csite_hydr%num_nodes + + if(pm_node(k) == rhiz_p_media) then + + j = node_layer(k) + psi_node(k) = max(-1e5_r8, csite_hydr%wrf_soil(j)%p%psi_from_th(th_node(k))) + + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_node(k)) + dftc_dpsi_node(k) = csite_hydr%wkf_soil(j)%p%dftcdpsi_from_psi(psi_node(k)) + + dpsi_dtheta_node(k) = csite_hydr%wrf_soil(j)%p%dpsidth_from_th(th_node(k)) + dftc_dtheta_node(k) = dftc_dpsi_node(k) * dpsi_dtheta_node(k) + + else + + psi_node(k) = max(-1e5_r8, 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)) + dpsi_dtheta_node(k) = wrf_plant(pm_node(k),ft)%p%dpsidth_from_th(th_node(k)) + + dftc_dtheta_node(k) = dftc_dpsi_node(k) * dpsi_dtheta_node(k) + + end if + + + enddo + + + ! Calculations of maximum conductance for upstream and downstream sides + ! of each connection. This IS dependant on total potential h_node + ! because of the root-soil radial conductance. + + call SetMaxCondConnections(csite_hydr, cohort_hydr, h_node, kmax_dn, kmax_up) + + ! calculate boundary fluxes + do icnx=1,csite_hydr%num_connections + + id_dn = conn_dn(icnx) + id_up = conn_up(icnx) + call GetImTaylorKAB(kmax_up(icnx),kmax_dn(icnx), & + ftc_node(id_up),ftc_node(id_dn), & + h_node(id_up),h_node(id_dn), & + dftc_dtheta_node(id_up), dftc_dtheta_node(id_dn), & + dpsi_dtheta_node(id_up), dpsi_dtheta_node(id_dn), & + k_eff, & + A_term, & + B_term) + + q_flux(icnx) = k_eff*(h_node(id_up)-h_node(id_dn)) + volx = (v_node(id_dn) + v_node(id_up))/2._r8 + cfl_max = max(cfl_max,abs(k_eff*(h_node(id_dn) -h_node(id_up)))*dtime/volx/denh2o) + enddo + !Top node + cfl_max = max(cfl_max, abs(qtop * dtime/v_node(1)/denh2o)) + ! To avoid extreme large clf_max due to large qtop from small gw weight + cfl_max = min(20._r8,cfl_max) + + !Calculate time step that meet cfl condition + if(cfl_max > cfl) then + nsteps = min(int(cfl_max/cfl) + 1, 20) + dtime = tmx/nsteps + end if + + icnv = 0 + outerloop: do while( tm < tmx ) + + ! The solve may reduce the time-step, the shorter + ! time-steps may not be perfectly divisible into + ! the remaining time. If so, then make sure we + ! don't overshoot + + dtime = min(dtime,tmx-tm) + if( ((tmx-tm) < (2*dtime)) .and. ((tmx-tm) > dtime) ) dtime = tmx-tm + + ! Advance time forward + tm = tm + dtime + + + ! This is the newton search loop + + continue_search = .true. + picd_iter = 0 + picardloop: do while(continue_search) + + picd_iter = picd_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 + th_prev(:) = th_node(:) + + do k=1,csite_hydr%num_nodes + + ! This is the storage gained from previous newton iterations. + residual(k) = residual(k) + & + (th_node(k)-th_node_prev(k))*denh2o*v_node(k)/dtime + + if(pm_node(k) == rhiz_p_media) then + + j = node_layer(k) + psi_node(k) = max(-1e2_r8, csite_hydr%wrf_soil(j)%p%psi_from_th(th_node(k))) + + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_node(k)) + dftc_dpsi_node(k) = csite_hydr%wkf_soil(j)%p%dftcdpsi_from_psi(psi_node(k)) + + dpsi_dtheta_node(k) = csite_hydr%wrf_soil(j)%p%dpsidth_from_th(th_node(k)) + dftc_dtheta_node(k) = dftc_dpsi_node(k) * dpsi_dtheta_node(k) + + else + + psi_node(k) = max(-1e2_r8, 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)) + dpsi_dtheta_node(k) = wrf_plant(pm_node(k),ft)%p%dpsidth_from_th(th_node(k)) + + dftc_dtheta_node(k) = dftc_dpsi_node(k) * dpsi_dtheta_node(k) + + end if + + ! Fill the self-term on the Jacobian's diagonal with the + ! the change in storage wrt change in psi. + + ajac(k,k) = - denh2o*v_node(k)/dtime + + enddo + + + ! Calculations of maximum conductance for upstream and downstream sides + ! of each connection. This IS dependant on total potential h_node + ! because of the root-soil radial conductance. + + call SetMaxCondConnections(csite_hydr, cohort_hydr, h_node, kmax_dn, kmax_up) + + ! calculate boundary fluxes + do icnx=1,csite_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 GetImTaylorKAB(kmax_up(icnx),kmax_dn(icnx), & + ftc_node(id_up),ftc_node(id_dn), & + h_node(id_up),h_node(id_dn), & + dftc_dtheta_node(id_up), dftc_dtheta_node(id_dn), & + dpsi_dtheta_node(id_up), dpsi_dtheta_node(id_dn), & + k_eff, & + A_term, & + B_term) + + 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) + + ! Down-stream node's contribution to the down-stream node's mass balance + ajac(id_dn,id_dn) = ajac(id_dn,id_dn) + A_term + + ! Down-stream node's contribution to the up-stream node's mass balance + ajac(id_up,id_dn) = ajac(id_up,id_dn) - A_term + + ! Up-stream node's contribution to the down-stream node's mass balance + ajac(id_dn,id_up) = ajac(id_dn,id_up) + B_term + + ! Up-stream node's contribution to the up-stream node's mass balance + ajac(id_up,id_up) = ajac(id_up,id_up) - B_term + + + + 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 + + !Solve linear equations + call DGESV(csite_hydr%num_nodes,1,ajac,csite_hydr%num_nodes,ipiv,residual,csite_hydr%num_nodes,info) + + + if ( info < 0 ) then + write(fates_log(),*) 'illegal value generated in DGESV() linear' + write(fates_log(),*) 'system solver, see node: ',-info + 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 + + ! Update the water content + th_node(:) = th_node(:) + residual(:) + ! constrain th + do k=1,csite_hydr%num_nodes + + if(pm_node(k) == rhiz_p_media) then + + j = node_layer(k) + th_node(k) = max(th_node(k), csite_hydr%wrf_soil(j)%p%get_thmin()) + + else + + th_node(k) = max(th_node(k), wrf_plant(pm_node(k),ft)%p%get_thmin()) + + end if + + + enddo + + wb_error = qtop*dtime - (sum( th_node_prev(:)*v_node(:) ) - sum( th_node(:)*v_node(:) ))*denh2o + + ! Mass is conserved or solver is converged + if(abs(wb_error) < max_allowed_residual .or. maxval(abs(residual(:))) < 1.e-3_r8 .or. maxval(abs(th_node(:) - th_prev(:))) < 1.e-3) exit picardloop + + if(icnv == 1 ) then + print *,'dtime-',dtime,tm + exit picardloop !explicit integration with small time step + end if + + if(picd_iter > max_picard_rounds) then + + icnv = 1 + + ! reset to initial condition + tm = 0._r8 + th_node(:) = th_node_init(:) + th_node_prev(:) = th_node_init(:) + + cycle outerloop !do explicit integration + + endif + + end do picardloop + + + ! If we are here, that means we succesfully finished + ! a solve with minimal error. More substeps may be required though + ! ------------------------------------------------------------------------------ + + ! If there are any sub-steps left, we need to update + ! the initial water content + th_node_prev(:) = th_node(:) + + + + end do outerloop + + !update psi + do k=1,csite_hydr%num_nodes + + if(pm_node(k) == rhiz_p_media) then + + j = node_layer(k) + psi_node(k) = max(-1e2_r8, csite_hydr%wrf_soil(j)%p%psi_from_th(th_node(k))) + + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_node(k)) + else + + psi_node(k) = max(-1e2_r8, 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)) + + end if + + enddo + + ! update fluxes + do icnx=1,csite_hydr%num_connections + + id_dn = conn_dn(icnx) + id_up = conn_up(icnx) + + call GetImTaylorKAB(kmax_up(icnx),kmax_dn(icnx), & + ftc_node(id_up),ftc_node(id_dn), & + h_node(id_up),h_node(id_dn), & + dftc_dtheta_node(id_up), dftc_dtheta_node(id_dn), & + dpsi_dtheta_node(id_up), dpsi_dtheta_node(id_dn), & + k_eff, & + A_term, & + B_term) + + q_flux(icnx) = k_eff*(h_node(id_up)-h_node(id_dn)) + end do + ! Save flux diagnostics + ! ------------------------------------------------------ + + sapflow = sapflow + q_flux(n_hypool_ag)*tmx + + do j = 1,csite_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)*tmx + enddo + + + ! Update the total change in water content + dth_node(:) = dth_node(:) + (th_node(:) - th_node_init(:)) + + ! 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) + if(minval(cohort_hydr%th_ag(1:n_hypool_ag)) < 0._r8) then + write(fates_log(),*) 'negative water content', cohort_hydr%th_ag(1:n_hypool_ag),wrf_plant(pm_node(1),ft)%p%get_thmin() + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + 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,csite_hydr%nlevrhiz + do k = 1, 1 + nshell + 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 / csite_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*tmx)-(w_tot_beg-w_tot_end) + + + end associate + + return +end subroutine PicardSolve2D + +! ===================================================================================== + +subroutine SetMaxCondConnections(csite_hydr, cohort_hydr, h_node, kmax_dn, kmax_up) ! ------------------------------------------------------------------------------- ! This subroutine sets the maximum conductances @@ -5403,7 +6082,7 @@ subroutine SetMaxCondConnections(site_hydr, cohort_hydr, h_node, kmax_dn, kmax_u ! of plant geometry and material properties. ! ------------------------------------------------------------------------------- - type(ed_site_hydr_type), intent(in),target :: site_hydr + type(ed_site_hydr_type), intent(in),target :: csite_hydr type(ed_cohort_hydr_type), intent(in),target :: cohort_hydr real(r8),intent(in) :: h_node(:) ! Total (matric+height) potential at each node (Mpa) real(r8),intent(out) :: kmax_dn(:) ! Max conductance of downstream sides of connections (kg s-1 MPa-1) @@ -5442,9 +6121,9 @@ subroutine SetMaxCondConnections(site_hydr, cohort_hydr, h_node, kmax_dn, kmax_u ! Path is between the transporting root and the absorbing roots inode = n_hypool_ag - do j = 1,site_hydr%nlevrhiz + do j = 1,csite_hydr%nlevrhiz - aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) + aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/csite_hydr%l_aroot_layer(j) do k = 1, n_hypool_aroot + nshell icnx = icnx + 1 @@ -5465,11 +6144,11 @@ subroutine SetMaxCondConnections(site_hydr, cohort_hydr, h_node, kmax_dn, kmax_u kmax_dn(icnx) = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(j) + & 1._r8/cohort_hydr%kmax_aroot_radial_out(j)) end if - kmax_up(icnx) = site_hydr%kmax_upper_shell(j,1)*aroot_frac_plant + kmax_up(icnx) = csite_hydr%kmax_upper_shell(j,1)*aroot_frac_plant else ! soil - soil - kmax_dn(icnx) = site_hydr%kmax_lower_shell(j,k-2)*aroot_frac_plant - kmax_up(icnx) = site_hydr%kmax_upper_shell(j,k-1)*aroot_frac_plant + kmax_dn(icnx) = csite_hydr%kmax_lower_shell(j,k-2)*aroot_frac_plant + kmax_up(icnx) = csite_hydr%kmax_upper_shell(j,k-1)*aroot_frac_plant endif enddo @@ -5553,6 +6232,9 @@ subroutine InitHydroGlobals() cap_int, & cap_slp,real(pm,r8)]) end do + case default + write(fates_log(),*) 'undefined water retention type for plants, pm:',pm,'type: ',hydr_htftype_node(pm) + call endrun(msg=errMsg(sourcefile, __LINE__)) end select end do @@ -5580,6 +6262,9 @@ subroutine InitHydroGlobals() call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_node(ft,pm), & EDPftvarcon_inst%hydr_avuln_node(ft,pm)]) end do + case default + write(fates_log(),*) 'undefined water conductance type for plants, pm:',pm,'type: ',hydr_htftype_node(pm) + call endrun(msg=errMsg(sourcefile, __LINE__)) end select end do diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 75079c8071..944b8c02a0 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -79,7 +79,6 @@ module EDMainMod use FatesPlantHydraulicsMod , only : UpdateSizeDepRhizHydProps use FatesPlantHydraulicsMod , only : AccumulateMortalityWaterStorage use FatesAllometryMod , only : h_allom,tree_sai,tree_lai - use FatesPlantHydraulicsMod , only : UpdateSizeDepRhizHydStates use EDLoggingMortalityMod , only : IsItLoggingTime use EDPatchDynamicsMod , only : get_frac_site_primary use FatesGlobals , only : endrun => fates_endrun @@ -287,7 +286,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) ! density --> node radii and volumes) if( (hlm_use_planthydro.eq.itrue) .and. do_growthrecruiteffects) then call UpdateSizeDepRhizHydProps(currentSite, bc_in) - call UpdateSizeDepRhizHydStates(currentSite, bc_in) + !! call UpdateSizeDepRhizHydStates(currentSite, bc_in) ! keeping if re-implemented (RGK 12-2021) end if ! SP has changes in leaf carbon but we don't expect them to be in balance. diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 1f10aa2c7f..e078083b9d 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -89,7 +89,17 @@ module EDParamsMod ! Switch that defines the current pressure-volume and pressure-conductivity model ! to be used at each node (compartment/organ) ! 1 = Christofferson et al. 2016 (TFS), 2 = Van Genuchten 1980 - integer, protected,allocatable,public :: hydr_htftype_node(:) + integer, protected,allocatable,public :: hydr_htftype_node(:) + + ! Switch that defines which hydraulic solver to use + ! 1 = Taylor solution that solves plant fluxes with 1 layer + ! sequentially placing solution on top of previous layer solves + ! 2 = Newton-Raphson solution that solves all fluxes in a plant and + ! the soil simultaneously, 2D: soil x (root + shell) + ! 3 = Picard solution that solves all fluxes in a plant and + ! the soil simultaneously, 2D: soil x (root + shell) + + integer, parameter, public :: hydr_solver_type = 1 ! 1 = hydr_solver_1DTaylor character(len=param_string_length),parameter,public :: ED_name_vai_top_bin_width = "fates_vai_top_bin_width" character(len=param_string_length),parameter,public :: ED_name_vai_width_increase_factor = "fates_vai_width_increase_factor" diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 425ed8bdd4..04ac023642 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3966,10 +3966,11 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) 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 :: j ! rhizosphere (ie root) layer index + integer :: j_bc ! Soil layer index (ie boundary condition grid index) + integer :: j_t,j_b ! top and bottom soil layer matching current rhiz layer integer :: nlevrhiz ! number of rhizosphere layers + integer :: nlevsoil ! number of soil 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] @@ -3978,6 +3979,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) 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 + real(r8) :: depth_frac ! fraction of rhizosphere layer depth occupied by current soil layer character(2) :: fmt_char type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort @@ -4047,17 +4049,15 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) site_hydr => sites(s)%si_hydr nlevrhiz = site_hydr%nlevrhiz - jr1 = site_hydr%i_rhiz_t - if(aggregate_layers) jr1 = jr1 -1 - jr2 = site_hydr%i_rhiz_b - + nlevsoil = bc_in(s)%nlevsoil io_si = sites(s)%h_gid hio_h2oveg_si(io_si) = site_hydr%h2oveg hio_h2oveg_hydro_err_si(io_si) = site_hydr%h2oveg_hydro_err - - + hio_rootuptake_sl(io_si,1:nlevsoil) = site_hydr%rootuptake_sl(1:nlevsoil) + hio_rootuptake_si(io_si) = sum(site_hydr%rootuptake_sl,dim=1) + ! Get column means of some soil diagnostics, these are weighted ! by the amount of fine-root surface area in each layer ! -------------------------------------------------------------------- @@ -4067,55 +4067,48 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) mean_soil_vwcsat = 0._r8 areaweight = 0._r8 - do jrhiz=1,nlevrhiz - - if(.not. aggregate_layers) then - jsoil = jrhiz + jr1-1 - else - jsoil = site_hydr%map_r2s(jrhiz,2) - end if - - vwc = bc_in(s)%h2o_liqvol_sl(jsoil) - psi = site_hydr%wrf_soil(jrhiz)%p%psi_from_th(vwc) - !cap capillary pressure - psi = max(-1e5_r8,psi) - vwc_sat = bc_in(s)%watsat_sl(jsoil) - !patch with cohorts - if(site_hydr%l_aroot_layer(jrhiz) > 0._r8) then - 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 - endif + do j=1,nlevrhiz - hio_soilmatpot_sl(io_si,jsoil) = psi * pa_per_mpa - hio_soilvwc_sl(io_si,jsoil) = vwc - hio_soilvwcsat_sl(io_si,jsoil) = vwc_sat + j_t = site_hydr%map_r2s(j,1) ! top soil layer matching rhiz layer + j_b = site_hydr%map_r2s(j,2) ! bottom soil layer matching rhiz layer + do j_bc = j_t,j_b + + vwc = bc_in(s)%h2o_liqvol_sl(j_bc) + psi = site_hydr%wrf_soil(j)%p%psi_from_th(vwc) + ! cap capillary pressure + ! psi = max(-1e5_r8,psi) Removing cap as that is inconstistent + ! with model internals and physics. Should + ! implement caps inside the functions + ! if desired. (RGK 12-2021) + vwc_sat = bc_in(s)%watsat_sl(j_bc) + depth_frac = bc_in(s)%dz_sisl(j_bc)/site_hydr%dz_rhiz(j) + + ! If there are any roots, we use root weighting + if(sum(site_hydr%l_aroot_layer(:),dim=1) > nearzero) then + layer_areaweight = site_hydr%l_aroot_layer(j)*depth_frac*pi_const*site_hydr%rs1(j)**2.0 + + ! If there are no roots, we use depth weighting + else + layer_areaweight = bc_in(s)%dz_sisl(j_bc) + endif + + areaweight = areaweight + layer_areaweight + 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 + + hio_soilmatpot_sl(io_si,j_bc) = psi * pa_per_mpa + hio_soilvwc_sl(io_si,j_bc) = vwc + hio_soilvwcsat_sl(io_si,j_bc) = vwc_sat + + end do end do - - if(sum(site_hydr%l_aroot_layer) == 0._r8) then - !to avoid nan for patch without cohorts - hio_rootwgt_soilvwc_si(io_si) = 0._r8 - hio_rootwgt_soilvwcsat_si(io_si) = 0._r8 - hio_rootwgt_soilmatpot_si(io_si) = 0._r8 - hio_rootuptake_si(io_si) = 0._r8 - hio_rootuptake_sl(io_si,:) = 0._r8 - hio_rootuptake_sl(io_si,jr1:jr2) = 0._r8 - hio_rootuptake_si(io_si) = 0._r8 - else - 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 * pa_per_mpa + 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 * pa_per_mpa - hio_rootuptake_si(io_si) = sum(site_hydr%rootuptake_sl,dim=1) / m2_per_ha - hio_rootuptake_sl(io_si,:) = 0._r8 - hio_rootuptake_sl(io_si,jr1:jr2) = site_hydr%rootuptake_sl(1:nlevrhiz) / & - m2_per_ha - hio_rootuptake_si(io_si) = sum(site_hydr%sapflow_scpf) / m2_per_ha - endif ! Normalization counters nplant_scpf(:) = 0._r8 diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 758ea3764b..c709b6f5a9 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -9,14 +9,13 @@ module FatesHydraulicsMemMod implicit none private -#if 0 - logical, parameter, public :: use_2d_hydrosolve = .true. -#endif - logical, public :: use_2d_hydrosolve -#if 1 - integer, public :: solver_1d2d ! =1,1d = 2, 2d newton, =3, picard -#endif + + + ! Define the various different solver options for hydraulics + integer, parameter, public :: hydr_solver_1DTaylor = 1 + integer, parameter, public :: hydr_solver_2DNewton = 2 + integer, parameter, public :: hydr_solver_2DPicard = 3 ! Number of soil layers for indexing cohort fine root quanitities ! NOTE: The hydraulics code does have some capacity to run a single soil @@ -35,7 +34,7 @@ module FatesHydraulicsMemMod 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 -! integer, parameter, public :: nshell = 1 + ! number of aboveground plant water storage nodes integer, parameter, public :: n_hypool_ag = n_hypool_leaf+n_hypool_stem @@ -82,11 +81,9 @@ module FatesHydraulicsMemMod type, public :: ed_site_hydr_type ! Plant Hydraulics - 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) - integer, allocatable :: map_s2r(:) ! soil to rhizoshpere level mapping - integer, allocatable :: map_r2s(:,:) ! rhizoshpere to soil level mapping, 1 -top soil layer, 2- bottom soil layer + integer, allocatable :: map_s2r(:) ! soil to rhizoshpere level mapping + integer, allocatable :: map_r2s(:,:) ! rhizoshpere to soil level mapping, 1 -top soil layer, 2- bottom soil layer 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] @@ -114,12 +111,6 @@ module FatesHydraulicsMemMod ! encountering super- or sub-saturation real(r8),allocatable :: h2osoi_liqvol_shell(:,:) ! volumetric water in rhizosphere compartment (m3/m3) - real(r8),allocatable :: h2osoi_liq_prev(:) ! liquid water mass for the bulk soil layer - ! defined at the end of the hydraulics sequence - ! after root water has been extracted. This should - ! be equal to the sum of the water over the rhizosphere shells - ! [kg/m2] - real(r8),allocatable :: recruit_w_uptake(:) ! recruitment water uptake (kg H2o/m2/s) @@ -150,7 +141,11 @@ module FatesHydraulicsMemMod 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] + + ! Root uptake per SOIL layer [kg/m2/s] + ! !!!!!!!! IMPORTANT: THIS IS FOR DIAGNOSTICS, AND WE OUTPUT + ! AT THE SOIL LAYER, NOT RHIZ LAYER, SO THIS HAS A SOIL LAYER DIMENSION + real(r8),allocatable :: rootuptake_sl(:) ! Root uptake per pft x size class, over set layer depths [kg/ha/m/s] @@ -196,7 +191,7 @@ module FatesHydraulicsMemMod real(r8), allocatable :: kmax_dn(:) ! Scratch arrays - real(r8) :: cohort_recruit_water_layer(nlevsoi_hyd_max) ! the recruit water requirement for a + real(r8) :: cohort_recruit_water_layer(nlevsoi_hyd_max) ! the recruit water requirement for a cohort real(r8) :: recruit_water_avail_layer(nlevsoi_hyd_max) ! the recruit water avaibility from soil (kg H2o/m2) @@ -205,6 +200,8 @@ module FatesHydraulicsMemMod procedure :: InitHydrSite procedure :: SetConnections procedure :: FlushSiteScratch + procedure :: AggBCToRhiz + end type ed_site_hydr_type @@ -375,16 +372,19 @@ end subroutine DeallocateHydrCohortArrays ! =================================================================================== - subroutine InitHydrSite(this,numpft,numlevsclass) + subroutine InitHydrSite(this,numpft,numlevsclass,hydr_solver_type,nlevsoil) ! Arguments class(ed_site_hydr_type),intent(inout) :: this integer,intent(in) :: numpft integer,intent(in) :: numlevsclass - + integer,intent(in) :: hydr_solver_type + integer,intent(in) :: nlevsoil + associate(nlevrhiz => this%nlevrhiz) - allocate(this%zi_rhiz(1:nlevrhiz)); this%zi_rhiz(:) = nan + ! In all cases, the 0 index of the layer bottom is a value of 0 + allocate(this%zi_rhiz(1:nlevrhiz)); this%zi_rhiz(:) = nan allocate(this%dz_rhiz(1:nlevrhiz)); this%dz_rhiz(:) = nan allocate(this%map_s2r(1:nlevrhiz)); this%map_s2r(:) = -999 allocate(this%map_r2s(1:nlevrhiz,1:2)); this%map_r2s(:,:) = -999 @@ -399,12 +399,12 @@ subroutine InitHydrSite(this,numpft,numlevsclass) 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%rootuptake_sl(1:nlevsoil)) ; this%rootuptake_sl = 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 @@ -424,8 +424,9 @@ subroutine InitHydrSite(this,numpft,numlevsclass) allocate(this%wrf_soil(1:nlevrhiz)) allocate(this%wkf_soil(1:nlevrhiz)) - if(use_2d_hydrosolve) then - + if((hydr_solver_type == hydr_solver_2DNewton) .or. & + (hydr_solver_type == hydr_solver_2DPicard)) then + this%num_connections = n_hypool_leaf + n_hypool_stem + n_hypool_troot - 1 & + (n_hypool_aroot + nshell) * nlevrhiz @@ -470,7 +471,7 @@ subroutine InitHydrSite(this,numpft,numlevsclass) end if - call this%SetConnections() + call this%SetConnections(hydr_solver_type) end associate @@ -480,38 +481,64 @@ end subroutine InitHydrSite ! =================================================================================== - 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_prev(:) = 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 + subroutine FlushSiteScratch(this,hydr_solver_type) + + class(ed_site_hydr_type),intent(inout) :: this + integer,intent(in) :: hydr_solver_type + + if((hydr_solver_type == hydr_solver_2DNewton) .or. & + (hydr_solver_type == hydr_solver_2DPicard)) then + this%residual(:) = fates_unset_r8 + this%ajac(:,:) = fates_unset_r8 + this%th_node_init(:) = fates_unset_r8 + this%th_node_prev(:) = 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 + ! =================================================================================== + + function AggBCToRhiz(this,var_in,j,weight) result(var_out) + + class(ed_site_hydr_type) :: this + real(r8) :: var_in(:) + real(r8) :: weight(:) + integer :: j + integer :: j_t,j_b + real(r8) :: var_out + + ! This function aggregates properties on the soil layer to + ! the root(rhiz) layer + + j_t = this%map_r2s(j,1) + j_b = this%map_r2s(j,2) - subroutine SetConnections(this) + var_out = sum(var_in(j_t:j_b)*weight(j_t:j_b))/sum(weight(j_t:j_b)) + + end function AggBCToRhiz + + ! =================================================================================== + + subroutine SetConnections(this,hydr_solver_type) ! This routine should be updated ! when new layers are added as plants grow into them? class(ed_site_hydr_type),intent(inout) :: this - + integer,intent(in) :: hydr_solver_type + integer :: k, j integer :: num_cnxs integer :: num_nds @@ -535,7 +562,8 @@ subroutine SetConnections(this) this%pm_node(num_nds) = stem_p_media enddo - if(use_2d_hydrosolve) then + if((hydr_solver_type == hydr_solver_2DNewton) .or. & + (hydr_solver_type == hydr_solver_2DPicard)) then num_nds = n_hypool_ag+n_hypool_troot node_tr_end = num_nds From 4e2e762d53ed0d550fcc321b0442e61b8fd1fbc6 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 15 Dec 2021 14:27:40 -0500 Subject: [PATCH 494/578] Removed some deprecated constants and flags for hydro --- main/FatesHistoryInterfaceMod.F90 | 1 - main/FatesHydraulicsMemMod.F90 | 16 +--------------- 2 files changed, 1 insertion(+), 16 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 04ac023642..1a8f41dab9 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3934,7 +3934,6 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) use FatesHydraulicsMemMod, only : ed_cohort_hydr_type, nshell use FatesHydraulicsMemMod, only : ed_site_hydr_type - use FatesHydraulicsMemMod, only : aggregate_layers use EDTypesMod , only : maxpft diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index c709b6f5a9..d670196618 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -58,26 +58,12 @@ module FatesHydraulicsMemMod ! 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) - ! way around that: dynamic allocation, or just keep this, but set the value high - integer, parameter, public :: nlevcan_hyd = 2 - ! Mean fine root radius expected in the bulk soil real(r8), parameter, public :: fine_root_radius_const = 0.0001_r8 - ! Should we ignore the first soil layer and have root layers start on the second? - logical, parameter, public :: ignore_layer1=.false. - logical, parameter, public :: aggregate_layers=.true. - - - ! Derived parameters - ! ---------------------------------------------------------------------------------------------- - - !temporatory variables + type, public :: ed_site_hydr_type ! Plant Hydraulics From c988b40d4fb51b2ce5ad7a49fcd8800f33cf4df2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 15 Dec 2021 16:00:53 -0500 Subject: [PATCH 495/578] Updated history variable output names for hydraulics, so it follows the form organ_type_dimension --- main/FatesHistoryInterfaceMod.F90 | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 1a8f41dab9..a04fd4efe6 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -6817,75 +6817,75 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_iterh2_scpf ) - call this%set_history_var(vname='FATES_ROOTH2O_ABS_SZPF', & + call this%set_history_var(vname='FATES_ABSROOT_H2O_SZPF', & units='m3 m-3', & long='absorbing volumetric root water content by size class x pft', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=4, ivar=ivar, & initialize=initialize_variables, index = ih_ath_scpf) - call this%set_history_var(vname='FATES_ROOTH2O_TRANS_SZPF', & + call this%set_history_var(vname='FATES_TRANSROOT_H2O_SZPF', & units='m3 m-3', & long='transporting volumetric root water content by size class x pft', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=4, ivar=ivar, & initialize=initialize_variables, index = ih_tth_scpf) - call this%set_history_var(vname='FATES_STEMH2O_SZPF', units='m3 m-3', & + call this%set_history_var(vname='FATES_STEM_H2O_SZPF', units='m3 m-3', & long='stem volumetric water content by size class x pft', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=4, ivar=ivar, & initialize=initialize_variables, index = ih_sth_scpf) - call this%set_history_var(vname='FATES_LEAFH2O_SZPF', units='m3 m-3', & + call this%set_history_var(vname='FATES_LEAF_H2O_SZPF', units='m3 m-3', & long='leaf volumetric water content by size class x pft', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=4, ivar=ivar, & initialize=initialize_variables, index = ih_lth_scpf) - call this%set_history_var(vname='FATES_ROOTH2O_POT_SZPF', units='Pa', & + call this%set_history_var(vname='FATES_ABSROOT_H2OPOT_SZPF', units='Pa', & long='absorbing root water potential by size class x pft', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=4, ivar=ivar, & initialize=initialize_variables, index = ih_awp_scpf) - call this%set_history_var(vname='FATES_ROOTH2O_TRANSPOT_SZPF', & + call this%set_history_var(vname='FATES_TRANSROOT_H2OPOT_SZPF', & units='Pa', long='transporting root water potential by size class x pft', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=4, ivar=ivar, & initialize=initialize_variables, index = ih_twp_scpf) - call this%set_history_var(vname='FATES_STEMH2O_POT_SZPF', units='Pa', & + call this%set_history_var(vname='FATES_STEM_H2OPOT_SZPF', units='Pa', & long='stem water potential by size class x pft', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=4, ivar=ivar, & initialize=initialize_variables, index = ih_swp_scpf) - call this%set_history_var(vname='FATES_LEAFH2O_POT_SZPF', units='Pa', & + call this%set_history_var(vname='FATES_LEAF_H2OPOT_SZPF', units='Pa', & long='leaf water potential by size class x pft', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=4, ivar=ivar, & initialize=initialize_variables, index = ih_lwp_scpf) - call this%set_history_var(vname='FATES_ROOT_ABSFRAC_SZPF', units='1', & + call this%set_history_var(vname='FATES_ABSROOT_CONDFRAC_SZPF', units='1', & long='absorbing root fraction (0-1) of condutivity by size class x pft', & use_default='active', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=4, ivar=ivar, & initialize=initialize_variables, index = ih_aflc_scpf) - call this%set_history_var(vname='FATES_ROOT_TRANSFRAC_SZPF', units='1', & + call this%set_history_var(vname='FATES_TRANSROOT_CONDFRAC_SZPF', units='1', & long='transporting root fraction (0-1) of condutivity by size class x pft', & use_default='active', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=4, ivar=ivar, & initialize=initialize_variables, index = ih_tflc_scpf) - call this%set_history_var(vname='FATES_STEMH2O_FRAC_SZPF', units='1', & + call this%set_history_var(vname='FATES_STEM_CONDFRAC_SZPF', units='1', & long='stem water fraction (0-1) of condutivity by size class x pft', & use_default='active', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=4, ivar=ivar, & initialize=initialize_variables, index = ih_sflc_scpf) - call this%set_history_var(vname='FATES_LEAFH2O_FRAC_SZPF', units='1', & + call this%set_history_var(vname='FATES_LEAF_CONDFRAC_SZPF', units='1', & long='leaf water fraction (0-1) of condutivity by size class x pft', & use_default='active', avgflag='A', vtype=site_size_pft_r8, & hlms='CLM:ALM', upfreq=4, ivar=ivar, & From 8e3110547a5d92eeffd25e49573a1904e55019f5 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 31 Dec 2021 14:38:23 -0500 Subject: [PATCH 496/578] Cleaning up history interface, removing patches and fixing the belowground dimension matchig to soil layers instead of ground layers. --- biogeochem/FatesSoilBGCFluxMod.F90 | 3 +- biogeophys/FatesPlantHydraulicsMod.F90 | 2 +- main/FatesHistoryInterfaceMod.F90 | 105 +++++++------------------ main/FatesHistoryVariableType.F90 | 28 +------ main/FatesIODimensionsMod.F90 | 17 ++-- main/FatesIOVariableKindMod.F90 | 6 +- main/FatesInterfaceMod.F90 | 16 ++-- main/FatesInterfaceTypesMod.F90 | 10 +-- main/FatesRestartVariableType.F90 | 20 +---- 9 files changed, 56 insertions(+), 151 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 133d6a3efd..d14ce7b005 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -915,7 +915,6 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) use FatesConstantsMod, only : sec_per_day 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 @@ -939,7 +938,7 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) ! element's root efflux type(litter_type), pointer :: litt - real(r8) :: surface_prof(1:hlm_numlevgrnd) ! this array is used to distribute + real(r8) :: surface_prof(bc_in%nlevsoil) ! this array is used to distribute ! fragmented litter on the surface ! into the soil/decomposition ! layers. It exponentially decays diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 5cf34069e4..5008c9cdba 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -1458,7 +1458,7 @@ subroutine InitHydrSites(sites,bc_in) ! ---------------------------------------------------------------------------------- - aggmeth = rhizlayer_aggmeth_none + aggmeth = rhizlayer_aggmeth_combine12 aggN = -9 select case(aggmeth) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index a04fd4efe6..407ab91159 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -656,7 +656,7 @@ module FatesHistoryInterfaceMod type(fates_io_dimension_type) :: dim_bounds(fates_history_num_dimensions) !! THESE WERE EXPLICITLY PRIVATE WHEN TYPE WAS PUBLIC - integer, private :: patch_index_, column_index_, levgrnd_index_, levscpf_index_ + integer, private :: column_index_, levsoil_index_, levscpf_index_ integer, private :: levscls_index_, levpft_index_, levage_index_ integer, private :: levfuel_index_, levcwdsc_index_, levscag_index_ integer, private :: levcan_index_, levcnlf_index_, levcnlfpft_index_ @@ -681,9 +681,8 @@ module FatesHistoryInterfaceMod ! 'get' methods used by external callers to access private read only data procedure :: num_history_vars - procedure :: patch_index procedure :: column_index - procedure :: levgrnd_index + procedure :: levsoil_index procedure :: levscpf_index procedure :: levscls_index procedure :: levcapf_index @@ -710,9 +709,8 @@ module FatesHistoryInterfaceMod procedure, private :: set_history_var procedure, private :: init_dim_kinds_maps procedure, private :: set_dim_indices - procedure, private :: set_patch_index procedure, private :: set_column_index - procedure, private :: set_levgrnd_index + procedure, private :: set_levsoil_index procedure, private :: set_levscpf_index procedure, private :: set_levcacls_index procedure, private :: set_levcapf_index @@ -755,7 +753,7 @@ module FatesHistoryInterfaceMod subroutine Init(this, num_threads, fates_bounds) - use FatesIODimensionsMod, only : patch, column, levgrnd, levscpf + use FatesIODimensionsMod, only : column, levsoil, levscpf use FatesIODimensionsMod, only : levscls, levpft, levage use FatesIODimensionsMod, only : levcacls, levcapf use FatesIODimensionsMod, only : levfuel, levcwdsc, levscag @@ -774,20 +772,15 @@ subroutine Init(this, num_threads, fates_bounds) integer :: dim_count = 0 - dim_count = dim_count + 1 - call this%set_patch_index(dim_count) - call this%dim_bounds(dim_count)%Init(patch, num_threads, & - fates_bounds%patch_begin, fates_bounds%patch_end) - dim_count = dim_count + 1 call this%set_column_index(dim_count) call this%dim_bounds(dim_count)%Init(column, num_threads, & fates_bounds%column_begin, fates_bounds%column_end) dim_count = dim_count + 1 - call this%set_levgrnd_index(dim_count) - call this%dim_bounds(dim_count)%Init(levgrnd, num_threads, & - fates_bounds%ground_begin, fates_bounds%ground_end) + call this%set_levsoil_index(dim_count) + call this%dim_bounds(dim_count)%Init(levsoil, num_threads, & + fates_bounds%soil_begin, fates_bounds%soil_end) dim_count = dim_count + 1 call this%set_levscpf_index(dim_count) @@ -905,17 +898,13 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) integer :: index - index = this%patch_index() - call this%dim_bounds(index)%SetThreadBounds(thread_index, & - thread_bounds%patch_begin, thread_bounds%patch_end) - index = this%column_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%column_begin, thread_bounds%column_end) - index = this%levgrnd_index() + index = this%levsoil_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & - thread_bounds%ground_begin, thread_bounds%ground_end) + thread_bounds%soil_begin, thread_bounds%soil_end) index = this%levscpf_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & @@ -1006,8 +995,7 @@ end subroutine SetThreadBoundsEach ! =================================================================================== subroutine assemble_history_output_types(this) - use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 - use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_soil_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 use FatesIOVariableKindMod, only : site_coage_r8, site_coage_pft_r8 use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 @@ -1023,18 +1011,10 @@ subroutine assemble_history_output_types(this) call this%init_dim_kinds_maps() - call this%set_dim_indices(patch_r8, 1, this%patch_index()) - call this%set_dim_indices(site_r8, 1, this%column_index()) - call this%set_dim_indices(patch_ground_r8, 1, this%patch_index()) - call this%set_dim_indices(patch_ground_r8, 2, this%levgrnd_index()) - - call this%set_dim_indices(site_ground_r8, 1, this%column_index()) - call this%set_dim_indices(site_ground_r8, 2, this%levgrnd_index()) - - call this%set_dim_indices(patch_size_pft_r8, 1, this%patch_index()) - call this%set_dim_indices(patch_size_pft_r8, 2, this%levscpf_index()) + call this%set_dim_indices(site_soil_r8, 1, this%column_index()) + call this%set_dim_indices(site_soil_r8, 2, this%levsoil_index()) call this%set_dim_indices(site_size_pft_r8, 1, this%column_index()) call this%set_dim_indices(site_size_pft_r8, 2, this%levscpf_index()) @@ -1140,20 +1120,6 @@ subroutine set_dim_indices(this, dk_name, idim, dim_index) end subroutine set_dim_indices - ! ======================================================================= - subroutine set_patch_index(this, index) - implicit none - class(fates_history_interface_type), intent(inout) :: this - integer, intent(in) :: index - this%patch_index_ = index - end subroutine set_patch_index - - integer function patch_index(this) - implicit none - class(fates_history_interface_type), intent(in) :: this - patch_index = this%patch_index_ - end function patch_index - ! ======================================================================= subroutine set_column_index(this, index) implicit none @@ -1169,18 +1135,18 @@ integer function column_index(this) end function column_index ! ======================================================================= - subroutine set_levgrnd_index(this, index) + subroutine set_levsoil_index(this, index) implicit none class(fates_history_interface_type), intent(inout) :: this integer, intent(in) :: index - this%levgrnd_index_ = index - end subroutine set_levgrnd_index + this%levsoil_index_ = index + end subroutine set_levsoil_index - integer function levgrnd_index(this) + integer function levsoil_index(this) implicit none class(fates_history_interface_type), intent(in) :: this - levgrnd_index = this%levgrnd_index_ - end function levgrnd_index + levsoil_index = this%levsoil_index_ + end function levsoil_index ! ======================================================================= subroutine set_levscpf_index(this, index) @@ -1591,15 +1557,13 @@ subroutine init_dim_kinds_maps(this) ! This subroutine simply initializes the structures that define the different ! array and type formats for different IO variables ! - ! PA_R8 : 1D patch scale 8-byte reals ! SI_R8 : 1D site scale 8-byte reals ! ! The allocation on the structures is not dynamic and should only add up to the ! number of entries listed here. ! ! ---------------------------------------------------------------------------------- - use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 - use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_soil_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 use FatesIOVariableKindMod, only : site_coage_r8, site_coage_pft_r8 use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 @@ -1617,25 +1581,13 @@ subroutine init_dim_kinds_maps(this) integer :: index - ! 1d Patch index = 1 - call this%dim_kinds(index)%Init(patch_r8, 1) - ! 1d Site - index = index + 1 call this%dim_kinds(index)%Init(site_r8, 1) - ! patch x ground - index = index + 1 - call this%dim_kinds(index)%Init(patch_ground_r8, 2) - - ! patch x size-class/pft - index = index + 1 - call this%dim_kinds(index)%Init(patch_size_pft_r8, 2) - - ! site x ground + ! site x soil index = index + 1 - call this%dim_kinds(index)%Init(site_ground_r8, 2) + call this%dim_kinds(index)%Init(site_soil_r8, 2) ! site x size-class/pft index = index + 1 @@ -4339,8 +4291,7 @@ subroutine define_history_vars(this, initialize_variables) ! a real. The applied flush value will use the NINT() intrinsic function ! --------------------------------------------------------------------------------- - use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 - use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_soil_r8, site_size_pft_r8 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, site_agefuel_r8 @@ -4375,7 +4326,7 @@ subroutine define_history_vars(this, initialize_variables) ! fuel class (site_fuel_r8) : FC ! height (site_height_r8) : HT ! plant functional type (site_pft_r8) : PF - ! soil layer (site_ground_r8) : SL + ! soil layer (site_soil_r8) : SL ! cohort size (site_size_r8) : SZ ! Multiple dimensions should have multiple two-code suffixes: @@ -4735,7 +4686,7 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FATES_FRAGMENTATION_SCALER_SL', units='', & long='factor (0-1) by which litter/cwd fragmentation proceeds relative to max rate by soil layer', & - use_default='active', avgflag='A', vtype=site_ground_r8, & + use_default='active', avgflag='A', vtype=site_soil_r8, & hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & index = ih_fragmentation_scaler_sl) @@ -6918,19 +6869,19 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FATES_SOILMATPOT_SL', units='Pa', & long='soil water matric potenial by soil layer', & - use_default='inactive', avgflag='A', vtype=site_ground_r8, & + use_default='inactive', avgflag='A', vtype=site_soil_r8, & hlms='CLM:ALM', 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, & + use_default='inactive', avgflag='A', vtype=site_soil_r8, & hlms='CLM:ALM', 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, & + use_default='inactive', avgflag='A', vtype=site_soil_r8, & hlms='CLM:ALM', upfreq=4, ivar=ivar, & initialize=initialize_variables, index = ih_soilvwcsat_sl) @@ -6942,7 +6893,7 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='FATES_ROOTUPTAKE_SL', & units='kg m-2 s-1', & long='root water uptake rate by soil layer', & - use_default='inactive', avgflag='A', vtype=site_ground_r8, & + use_default='inactive', avgflag='A', vtype=site_soil_r8, & hlms='CLM:ALM', upfreq=4, ivar=ivar, & initialize=initialize_variables, index = ih_rootuptake_sl) diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 index 6457e644f1..c56d1db984 100644 --- a/main/FatesHistoryVariableType.F90 +++ b/main/FatesHistoryVariableType.F90 @@ -4,11 +4,10 @@ module FatesHistoryVariableType use FatesGlobals, only : fates_log use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : fates_io_variable_kind_type - use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 - use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_soil_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 use FatesIOVariableKindMod, only : site_coage_r8, site_coage_pft_r8 - use FatesIOVariableKindMod, only : site_height_r8, patch_int + use FatesIOVariableKindMod, only : site_height_r8 use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 use FatesIOVariableKindMod, only : site_scagpft_r8, site_agepft_r8 use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 @@ -105,23 +104,12 @@ subroutine Init(this, vname, units, long, use_default, & ! array spaces. select case(trim(vtype)) - case(patch_r8) - allocate(this%r81d(lb1:ub1)) - this%r81d(:) = flushval case(site_r8) allocate(this%r81d(lb1:ub1)) this%r81d(:) = flushval - case(patch_ground_r8) - allocate(this%r82d(lb1:ub1, lb2:ub2)) - this%r82d(:,:) = flushval - - case(patch_size_pft_r8) - allocate(this%r82d(lb1:ub1, lb2:ub2)) - this%r82d(:,:) = flushval - - case(site_ground_r8) + case(site_soil_r8) allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval @@ -282,15 +270,9 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) call this%GetBounds(thread, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) select case(trim(dim_kinds(this%dim_kinds_index)%name)) - case(patch_r8) - this%r81d(lb1:ub1) = this%flushval case(site_r8) this%r81d(lb1:ub1) = this%flushval - case(patch_ground_r8) - this%r82d(lb1:ub1, lb2:ub2) = this%flushval - case(patch_size_pft_r8) - this%r82d(lb1:ub1, lb2:ub2) = this%flushval - case(site_ground_r8) + case(site_soil_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_size_pft_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval @@ -322,8 +304,6 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_agepft_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval - case(patch_int) - this%int1d(lb1:ub1) = nint(this%flushval) case(site_elem_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_elpft_r8) diff --git a/main/FatesIODimensionsMod.F90 b/main/FatesIODimensionsMod.F90 index 522da97653..6760bf0dbe 100644 --- a/main/FatesIODimensionsMod.F90 +++ b/main/FatesIODimensionsMod.F90 @@ -11,9 +11,8 @@ module FatesIODimensionsMod character(*), parameter, public :: levcacls = 'fates_levcacls' ! matches histFileMod character(*), parameter, public :: cohort = 'cohort' ! matches clm_varcon - character(*), parameter, public :: patch = 'patch' ! matches clm_varcon character(*), parameter, public :: column = 'column' ! matches clm_varcon - character(*), parameter, public :: levgrnd = 'levgrnd' ! matches clm_varcon + character(*), parameter, public :: levsoil = 'levsoi' ! matches clm_varcon character(*), parameter, public :: levscag = 'fates_levscag' ! matches histFileMod character(*), parameter, public :: levscagpft = 'fates_levscagpf' ! matches histFileMod character(*), parameter, public :: levagepft = 'fates_levagepft' ! matches histFileMod @@ -34,16 +33,12 @@ module FatesIODimensionsMod character(*), parameter, public :: levelcwd = 'fates_levelcwd' character(*), parameter, public :: levelage = 'fates_levelage' - ! patch = This is a structure that records where FATES patch boundaries - ! on each thread point to in the host IO array, this structure - ! is allocated by number of threads - ! column = This is a structure that records where FATES column boundaries ! on each thread point to in the host IO array, this structure ! is allocated by number of threads - ! ground = This is a structure that records the boundaries for the - ! ground level (includes rock) dimension + ! levsoil = This is a structure that records the boundaries for the + ! soil level (includes rock) dimension ! levscpf = This is a structure that records the boundaries for the ! number of size-class x pft dimension @@ -100,14 +95,12 @@ module FatesIODimensionsMod type, public :: fates_bounds_type - integer :: patch_begin - integer :: patch_end integer :: cohort_begin integer :: cohort_end integer :: column_begin ! FATES does not have a "column" type integer :: column_end ! we call this a "site" (rgk 11-2016) - integer :: ground_begin - integer :: ground_end + integer :: soil_begin + integer :: soil_end integer :: sizeage_class_begin integer :: sizeage_class_end integer :: sizeagepft_class_begin diff --git a/main/FatesIOVariableKindMod.F90 b/main/FatesIOVariableKindMod.F90 index 93b34ebab3..daba4f3c20 100644 --- a/main/FatesIOVariableKindMod.F90 +++ b/main/FatesIOVariableKindMod.F90 @@ -10,17 +10,13 @@ module FatesIOVariableKindMod ! FIXME(bja, 2016-10) do these need to be strings, or can they be integer enumerations? ! FIXME(rgk, 2016-11) these should probably be moved to varkindmod? - character(*), parameter, public :: patch_r8 = 'PA_R8' - character(*), parameter, public :: patch_ground_r8 = 'PA_GRND_R8' - character(*), parameter, public :: patch_size_pft_r8 = 'PA_SCPF_R8' character(*), parameter, public :: site_r8 = 'SI_R8' character(*), parameter, public :: site_int = 'SI_INT' - character(*), parameter, public :: site_ground_r8 = 'SI_GRND_R8' + character(*), parameter, public :: site_soil_r8 = 'SI_SOIL_R8' character(*), parameter, public :: site_size_pft_r8 = 'SI_SCPF_R8' character(*), parameter, public :: site_size_r8 = 'SI_SCLS_R8' character(*), parameter, public :: site_coage_pft_r8 = 'SI_CAPF_R8' character(*), parameter, public :: site_coage_r8 = 'SI_CACLS_R8' - character(*), parameter, public :: patch_int = 'PA_INT' character(*), parameter, public :: cohort_r8 = 'CO_R8' character(*), parameter, public :: cohort_int = 'CO_INT' character(*), parameter, public :: site_pft_r8 = 'SI_PFT_R8' diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 0753c89829..ad0d7de3a4 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -779,7 +779,7 @@ subroutine SetFatesGlobalElements(use_fates) ! These values are used to define the restart file allocations and general structure ! of memory for the cohort arrays - fates_maxElementsPerPatch = max(maxCohortsPerPatch, ndcmpy*numlevsoil_max ,ncwd*numlevsoil_max) + fates_maxElementsPerPatch = max(maxCohortsPerPatch, ndcmpy*hlm_maxlevsoil ,ncwd*hlm_maxlevsoil) if (maxPatchesPerSite * fates_maxElementsPerPatch < numWaterMem) then write(fates_log(), *) 'By using such a tiny number of maximum patches and maximum cohorts' @@ -1224,7 +1224,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! call set_fates_ctrlparms('flush_to_unset') ! call set_fates_ctrlparms('num_sw_bbands',numrad) ! or other variable ! ... - ! call set_fates_ctrlparms('num_lev_ground',nlevgrnd) ! or other variable + ! call set_fates_ctrlparms('num_lev_soil',nlevsoi) ! or other variable ! call set_fates_ctrlparms('check_allset') ! ! RGK-2016 @@ -1254,7 +1254,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_inir = unset_int hlm_ivis = unset_int hlm_is_restart = unset_int - hlm_numlevgrnd = unset_int + hlm_maxlevsoil = unset_int hlm_name = 'unset' hlm_hio_ignore_val = unset_double hlm_masterproc = unset_int @@ -1431,9 +1431,9 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(hlm_numlevgrnd .eq. unset_int) then + if(hlm_maxlevsoil .eq. unset_int) then if (fates_global_verbose()) then - write(fates_log(), *) 'FATES dimension/parameter unset: numlevground, exiting' + write(fates_log(), *) 'FATES dimension/parameter unset: hlm_maxlevsoil, exiting' end if call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1638,10 +1638,10 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering flag signaling restart / not-restart = ',ival,' to FATES' end if - case('num_lev_ground') - hlm_numlevgrnd = ival + case('num_lev_soil') + hlm_maxlevsoil = ival if (fates_global_verbose()) then - write(fates_log(),*) 'Transfering num_lev_ground = ',ival,' to FATES' + write(fates_log(),*) 'Transfering num_lev_soil = ',ival,' to FATES' end if case('soilwater_ipedof') diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index aaf4b51e84..ff56797a77 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -31,10 +31,8 @@ module FatesInterfaceTypesMod 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_maxlevsoil ! Max number of soil layers - 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? @@ -482,10 +480,10 @@ module FatesInterfaceTypesMod ! volumetric soil water at saturation (porosity) real(r8), allocatable :: watsat_sl(:) - ! Temperature of ground layers [K] + ! Temperature of soil layers [K] real(r8), allocatable :: tempk_sl(:) - ! Liquid volume in ground layer (m3/m3) + ! Liquid volume in soil layer (m3/m3) real(r8), allocatable :: h2o_liqvol_sl(:) ! Site level filter for uptake response functions @@ -540,7 +538,7 @@ module FatesInterfaceTypesMod ! Shaded canopy LAI real(r8),allocatable :: laisha_pa(:) - ! Logical stating whether a ground layer can have water uptake by plants + ! Logical stating whether a soil 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(:) diff --git a/main/FatesRestartVariableType.F90 b/main/FatesRestartVariableType.F90 index 48152ec955..4cec99c349 100644 --- a/main/FatesRestartVariableType.F90 +++ b/main/FatesRestartVariableType.F90 @@ -39,8 +39,8 @@ module FatesRestartVariableMod subroutine Init(this, vname, units, long, vtype, flushval, num_dim_kinds, dim_kinds, dim_bounds) use FatesIODimensionsMod, only : fates_io_dimension_type - use FatesIOVariableKindMod, only : patch_r8, site_r8, cohort_r8 - use FatesIOVariableKindMod, only : patch_int, site_int, cohort_int + use FatesIOVariableKindMod, only : site_r8, cohort_r8 + use FatesIOVariableKindMod, only : site_int, cohort_int use FatesIOVariableKindMod, only : iotype_index implicit none @@ -85,10 +85,6 @@ subroutine Init(this, vname, units, long, vtype, flushval, num_dim_kinds, dim_ki allocate(this%r81d(lb1:ub1)) this%r81d(:) = flushval - case(patch_r8) - allocate(this%r81d(lb1:ub1)) - this%r81d(:) = flushval - case(site_r8) allocate(this%r81d(lb1:ub1)) this%r81d(:) = flushval @@ -97,10 +93,6 @@ subroutine Init(this, vname, units, long, vtype, flushval, num_dim_kinds, dim_ki allocate(this%int1d(lb1:ub1)) this%int1d(:) = idnint(flushval) - case(patch_int) - allocate(this%int1d(lb1:ub1)) - this%int1d(:) = idnint(flushval) - case(site_int) allocate(this%int1d(lb1:ub1)) this%int1d(:) = idnint(flushval) @@ -170,8 +162,8 @@ end subroutine GetBounds subroutine flush(this, thread, dim_bounds, dim_kinds) use FatesIODimensionsMod, only : fates_io_dimension_type - use FatesIOVariableKindMod, only : patch_r8, site_r8, cohort_r8 - use FatesIOVariableKindMod, only : patch_int, site_int, cohort_int + use FatesIOVariableKindMod, only : site_r8, cohort_r8 + use FatesIOVariableKindMod, only : site_int, cohort_int implicit none @@ -185,14 +177,10 @@ subroutine flush(this, thread, dim_bounds, dim_kinds) call this%GetBounds(thread, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) select case(trim(dim_kinds(this%dim_kinds_index)%name)) - case(patch_r8) - this%r81d(lb1:ub1) = this%flushval case(site_r8) this%r81d(lb1:ub1) = this%flushval case(cohort_r8) this%r81d(lb1:ub1) = this%flushval - case(patch_int) - this%int1d(lb1:ub1) = nint(this%flushval) case(site_int) this%int1d(lb1:ub1) = nint(this%flushval) case(cohort_int) From 8b5af00c1792ef2268774bb76c57b1becc5fd24e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 5 Jan 2022 12:41:18 -0500 Subject: [PATCH 497/578] Testing harmonic averaging in upscaling, depth and K weighted disaggregation, and more aggressive aggregations schemes in plant hydraulics. --- biogeophys/FatesPlantHydraulicsMod.F90 | 141 ++++++++++++++++++++----- main/FatesHydraulicsMemMod.F90 | 14 ++- 2 files changed, 127 insertions(+), 28 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 5008c9cdba..8449bb9df3 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -1401,7 +1401,9 @@ subroutine InitHydrSites(sites,bc_in) integer :: nsites integer :: s integer :: j - integer :: j_bc + integer :: j_bc,j_t,j_b + integer,allocatable :: ns_per_rhiz(:) + integer :: ntoagg type(ed_site_hydr_type),pointer :: csite_hydr integer :: aggmeth ! Aggregation method @@ -1411,7 +1413,7 @@ subroutine InitHydrSites(sites,bc_in) ! Different aggregation method flags, see explanation below integer, parameter :: rhizlayer_aggmeth_none = 1 integer, parameter :: rhizlayer_aggmeth_combine12 = 2 - + integer, parameter :: rhizlayer_aggmeth_balN = 3 if ( hlm_use_planthydro.eq.ifalse ) return @@ -1458,8 +1460,8 @@ subroutine InitHydrSites(sites,bc_in) ! ---------------------------------------------------------------------------------- - aggmeth = rhizlayer_aggmeth_combine12 - aggN = -9 + aggmeth = rhizlayer_aggmeth_balN + aggN = 10 select case(aggmeth) @@ -1493,6 +1495,61 @@ subroutine InitHydrSites(sites,bc_in) csite_hydr%dz_rhiz(j) = bc_in(s)%dz_sisl(j+1) end do + case(rhizlayer_aggmeth_balN) + + csite_hydr%nlevrhiz = min(aggN,bc_in(s)%nlevsoil) + call sites(s)%si_hydr%InitHydrSite(numpft,nlevsclass,hydr_solver_type,bc_in(s)%nlevsoil) + + ntoagg = int(ceiling(real(bc_in(s)%nlevsoil)/real(csite_hydr%nlevrhiz)-nearzero)) + + if(ntoagg<1)then + write(fates_log(),*) 'rhizosphere balancing method rhizlayer_aggmeth_balN' + write(fates_log(),*) 'is failing to get a starting estimate of soil layers per rhiz layers:',ntoagg + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! This array defines the number of soil layers + ! in each rhiz layer, start off with a max value + ! then we incrementally work our way from bottom up + ! reducing this number, until the number of soil + ! layers in the array matches the total actual + + allocate(ns_per_rhiz(csite_hydr%nlevrhiz)) + ns_per_rhiz(:) = ntoagg + + do while( sum(ns_per_rhiz(:)) > bc_in(s)%nlevsoil ) + do j = csite_hydr%nlevrhiz,1,-1 + + ns_per_rhiz(j) = ns_per_rhiz(j) - 1 + if(sum(ns_per_rhiz(:))<=bc_in(s)%nlevsoil)then + exit + end if + if(ns_per_rhiz(j)==0)then + write(fates_log(),*) 'rhizosphere balancing method rhizlayer_aggmeth_balN' + write(fates_log(),*) 'produced a rhizosphere layer with 0 soil layers...exiting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do + end do + + ! Assign the mapping + csite_hydr%map_r2s(1,1) = 1 + do j=1,csite_hydr%nlevrhiz-1 + j_t = csite_hydr%map_r2s(j,1) + j_b = j_t + ns_per_rhiz(j) - 1 + csite_hydr%map_r2s(j,2) = j_b + csite_hydr%map_r2s(j+1,1) = j_b + 1 + csite_hydr%zi_rhiz(j) = bc_in(s)%zi_sisl(j_b) + csite_hydr%dz_rhiz(j) = sum(bc_in(s)%dz_sisl(j_t:j_b)) + end do + j_t = csite_hydr%map_r2s(csite_hydr%nlevrhiz,1) + j_b = j_t + ns_per_rhiz(csite_hydr%nlevrhiz) - 1 + csite_hydr%map_r2s(csite_hydr%nlevrhiz,2) = j_b + csite_hydr%zi_rhiz(csite_hydr%nlevrhiz) = bc_in(s)%zi_sisl(j_b) + csite_hydr%dz_rhiz(csite_hydr%nlevrhiz) = sum(bc_in(s)%dz_sisl(j_t:j_b)) + + deallocate(ns_per_rhiz) + case default write(fates_log(),*) 'You specified an undefined rhizosphere layer aggregation method' @@ -2413,8 +2470,16 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) real(r8) :: h2osoi_liqvol ! liquid water content [m3/m3] real(r8) :: psi_layer ! matric potential [Mpa] real(r8) :: ftc_layer ! fraction of maximum conductance [-] + real(r8) :: weight ! weighting function for each layer when disaggregating rhiz->soil real(r8) :: sumweight ! sum of weighting functions for disaggregating rhiz -> soil + + integer, parameter :: soilz_disagg = 0 ! disaggregate rhizosphere layers based on depth + integer, parameter :: soilk_disagg = 1 ! disaggregate rhizosphere layers based on conductance + + integer, parameter :: rootflux_disagg = soilz_disagg + + ! ---------------------------------------------------------------------------------- ! 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 @@ -2705,38 +2770,60 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) -(sum(dth_layershell_col(j,:)*csite_hydr%v_shell(j,:))*denh2o*AREA_INV/dtime) + & csite_hydr%recruit_w_uptake(j) - - ! Partition the uptake flux into the soil layer - ! Weight the flux by the vertically integrated conductance estimate "ftc*hksat*dz" + + ! -------------------------- Disaggregation --------------------------------- + ! Partition the uptake flux into the soil layers + j_t = csite_hydr%map_r2s(j,1) j_b = csite_hydr%map_r2s(j,2) - + + ! First pass, get sum of weighting factors for disaggregation sumweight = 0._r8 do j_bc = j_t,j_b - - ! h2osoi_liqvol: [kg/m2] / [m] / [kg/m3] = [m3/m3] - - eff_por = bc_in(s)%eff_porosity_sl(j_bc) - h2osoi_liqvol = min(eff_por, bc_in(s)%h2o_liq_sisl(j_bc)/(bc_in(s)%dz_sisl(j_bc)*denh2o)) - psi_layer = csite_hydr%wrf_soil(j)%p%psi_from_th(h2osoi_liqvol) - ftc_layer = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_layer) - sumweight = sumweight + bc_in(s)%hksat_sisl(j_bc)*ftc_layer*bc_in(s)%dz_sisl(j_bc) - + if(rootflux_disagg == soilk_disagg)then + ! Weight disaggregation by K*dz, but only for flux + ! into the root, othersize weight by depth + if(qflx_soil2root_rhiz>0._r8)then + ! h2osoi_liqvol: [kg/m2] / [m] / [kg/m3] = [m3/m3] + eff_por = bc_in(s)%eff_porosity_sl(j_bc) + h2osoi_liqvol = min(eff_por, bc_in(s)%h2o_liq_sisl(j_bc)/(bc_in(s)%dz_sisl(j_bc)*denh2o)) + psi_layer = csite_hydr%wrf_soil(j)%p%psi_from_th(h2osoi_liqvol) + ftc_layer = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_layer) + weight = bc_in(s)%hksat_sisl(j_bc)*ftc_layer*bc_in(s)%dz_sisl(j_bc) + else + weight = bc_in(s)%dz_sisl(j_bc) + end if + elseif(rootflux_disagg == soilz_disagg) then + ! weight by depth + weight = bc_in(s)%dz_sisl(j_bc) + else + write(fates_log(),*) 'Unknown rhiz->soil disaggregation method',rootflux_disagg + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + sumweight = sumweight + weight end do - - do j_bc = j_t,j_b - eff_por = bc_in(s)%eff_porosity_sl(j_bc) - h2osoi_liqvol = min(eff_por, bc_in(s)%h2o_liq_sisl(j_bc)/(bc_in(s)%dz_sisl(j_bc)*denh2o)) - psi_layer = csite_hydr%wrf_soil(j)%p%psi_from_th(h2osoi_liqvol) - ftc_layer = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_layer) + ! Second pass, apply weighting factors for fluxes + do j_bc = j_t,j_b + if(rootflux_disagg == soilk_disagg)then + if(qflx_soil2root_rhiz>0._r8)then + eff_por = bc_in(s)%eff_porosity_sl(j_bc) + h2osoi_liqvol = min(eff_por, bc_in(s)%h2o_liq_sisl(j_bc)/(bc_in(s)%dz_sisl(j_bc)*denh2o)) + psi_layer = csite_hydr%wrf_soil(j)%p%psi_from_th(h2osoi_liqvol) + ftc_layer = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_layer) + weight = bc_in(s)%hksat_sisl(j_bc)*ftc_layer*bc_in(s)%dz_sisl(j_bc) + else + weight = bc_in(s)%dz_sisl(j_bc) + end if + elseif(rootflux_disagg == soilz_disagg) then + weight = bc_in(s)%dz_sisl(j_bc) + end if + ! Fill the output array to the HLM - bc_out(s)%qflx_soil2root_sisl(j_bc) = qflx_soil2root_rhiz * & - (bc_in(s)%hksat_sisl(j_bc)*ftc_layer*bc_in(s)%dz_sisl(j_bc)/sumweight) + bc_out(s)%qflx_soil2root_sisl(j_bc) = qflx_soil2root_rhiz * weight/sumweight ! Save root uptake for history diagnostics [kg/m/s] - csite_hydr%rootuptake_sl(j_bc) = qflx_soil2root_rhiz * & - (bc_in(s)%hksat_sisl(j_bc)*ftc_layer*bc_in(s)%dz_sisl(j_bc)/sumweight) + csite_hydr%rootuptake_sl(j_bc) = qflx_soil2root_rhiz * weight/sumweight end do diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index d670196618..fb0d295f69 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -504,6 +504,10 @@ function AggBCToRhiz(this,var_in,j,weight) result(var_out) integer :: j integer :: j_t,j_b real(r8) :: var_out + + integer, parameter :: arithmetic_mean = 0 + integer, parameter :: harmonic_mean = 1 + integer, parameter :: mean_type = harmonic_mean ! This function aggregates properties on the soil layer to ! the root(rhiz) layer @@ -511,7 +515,15 @@ function AggBCToRhiz(this,var_in,j,weight) result(var_out) j_t = this%map_r2s(j,1) j_b = this%map_r2s(j,2) - var_out = sum(var_in(j_t:j_b)*weight(j_t:j_b))/sum(weight(j_t:j_b)) + + if(mean_type.eq.arithmetic_mean) then + var_out = sum(var_in(j_t:j_b)*weight(j_t:j_b))/sum(weight(j_t:j_b)) + else + + var_out = sum(weight(j_t:j_b)) / sum( weight(j_t:j_b) / var_in(j_t:j_b) ) + + end if + end function AggBCToRhiz From 291980b93b92bc045c0dd36ee92f34e324d36b42 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 6 Jan 2022 10:22:41 -0700 Subject: [PATCH 498/578] avoid only the carea_allom and treelai/treesai function calls --- biogeochem/EDCanopyStructureMod.F90 | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 1165c04daa..01672df57f 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1935,12 +1935,9 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) total_patch_area = 0._r8 total_canopy_area = 0._r8 bc_out(s)%canopy_fraction_pa(:) = 0._r8 - - if (hlm_use_sp.eq.ifalse) then - bc_out(s)%dleaf_pa(:) = 0._r8 - bc_out(s)%z0m_pa(:) = 0._r8 - bc_out(s)%displa_pa(:) = 0._r8 - endif + bc_out(s)%dleaf_pa(:) = 0._r8 + bc_out(s)%z0m_pa(:) = 0._r8 + bc_out(s)%displa_pa(:) = 0._r8 currentPatch => sites(s)%oldest_patch c = fcolumn(s) @@ -1970,7 +1967,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) ! Avoid this if running in satellite phenology mode ! ---------------------------------------------------------------------------- - if (currentPatch%total_canopy_area > nearzero .and. hlm_use_sp.eq.ifalse) then + if (currentPatch%total_canopy_area > nearzero) then currentCohort => currentPatch%shortest do while(associated(currentCohort)) if (currentCohort%canopy_layer .eq. 1) then @@ -1988,7 +1985,8 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentCohort => currentPatch%shortest do while(associated(currentCohort)) - ! mkae sure that allometries are correct + if (hlm_use_sp.eq.ifalse) then + ! make sure that allometries are correct call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& currentCohort%pft,currentCohort%c_area) @@ -2000,6 +1998,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & currentPatch%canopy_layer_tlai, currentCohort%treelai , & currentCohort%vcmax25top,4) + endif total_patch_leaf_stem_area = total_patch_leaf_stem_area + & (currentCohort%treelai + currentCohort%treesai) * currentCohort%c_area From 1188a50a29fedfd2feffe32024d76a354759be2d Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 7 Jan 2022 11:48:03 -0700 Subject: [PATCH 499/578] removing redundant treelai and unused code --- biogeochem/EDCanopyStructureMod.F90 | 7 ------- 1 file changed, 7 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 01672df57f..73fa1e008b 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1289,7 +1289,6 @@ subroutine canopy_summarization( nsites, sites, bc_in ) integer :: ft ! plant functional type integer :: ifp ! the number of the vegetated patch (1,2,3). In SP mode bareground patch is 0 integer :: patchn ! identification number for each patch. - real(r8) :: canopy_leaf_area ! total amount of leaf area in the vegetated area. m2. real(r8) :: leaf_c ! leaf carbon [kg] real(r8) :: fnrt_c ! fineroot carbon [kg] real(r8) :: sapw_c ! sapwood carbon [kg] @@ -1318,7 +1317,6 @@ subroutine canopy_summarization( nsites, sites, bc_in ) !zero cohort-summed variables. currentPatch%total_canopy_area = 0.0_r8 currentPatch%total_tree_area = 0.0_r8 - canopy_leaf_area = 0.0_r8 !update cohort quantitie s currentCohort => currentPatch%shortest @@ -1347,11 +1345,6 @@ subroutine canopy_summarization( nsites, sites, bc_in ) call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& currentCohort%pft,currentCohort%c_area) endif - currentCohort%treelai = tree_lai(leaf_c, & - currentCohort%pft, currentCohort%c_area, currentCohort%n, & - currentCohort%canopy_layer, currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) - - canopy_leaf_area = canopy_leaf_area + currentCohort%treelai *currentCohort%c_area if(currentCohort%canopy_layer==1)then currentPatch%total_canopy_area = currentPatch%total_canopy_area + currentCohort%c_area From b5c38f005911a20bdd77f20b554fb8cd93329bc8 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 11 Jan 2022 21:04:14 -0500 Subject: [PATCH 500/578] Using root density for disaggregation --- biogeophys/FatesPlantHydraulicsMod.F90 | 57 +++++++++++++++++++------- main/FatesHydraulicsMemMod.F90 | 6 +++ 2 files changed, 48 insertions(+), 15 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 8449bb9df3..bb56b73086 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -1266,7 +1266,7 @@ subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, ne type(ed_site_hydr_type), pointer :: csite_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 - real(r8) :: vol_c1,vol_c2 ! Total water volume in the each cohort + real(r8) :: vol_c1,vol_c2 ! Total water volume in the each cohort integer :: j,k ! indices integer :: ft @@ -1460,8 +1460,8 @@ subroutine InitHydrSites(sites,bc_in) ! ---------------------------------------------------------------------------------- - aggmeth = rhizlayer_aggmeth_balN - aggN = 10 + aggmeth = rhizlayer_aggmeth_combine12 + aggN = -9 select case(aggmeth) @@ -2472,12 +2472,14 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) real(r8) :: ftc_layer ! fraction of maximum conductance [-] real(r8) :: weight ! weighting function for each layer when disaggregating rhiz->soil real(r8) :: sumweight ! sum of weighting functions for disaggregating rhiz -> soil - - + real(r8) :: sum_l_aroot ! sum of root length of cohort, for disaggregation + real(r8) :: rootfr ! fraction of root mass in soil layer, for disaggregation + real(r8) :: z_fr ! Maximum fine root depth, used in disaggregation + integer, parameter :: soilz_disagg = 0 ! disaggregate rhizosphere layers based on depth integer, parameter :: soilk_disagg = 1 ! disaggregate rhizosphere layers based on conductance - integer, parameter :: rootflux_disagg = soilz_disagg + integer, parameter :: rootflux_disagg = soilk_disagg ! ---------------------------------------------------------------------------------- @@ -2717,7 +2719,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ccohort => ccohort%shorter enddo !cohort - endif ! not barground patch + endif ! not bareground patch cpatch => cpatch%younger enddo !patch @@ -2742,7 +2744,33 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) bc_out(s)%qflx_soil2root_sisl(:) = 0._r8 bc_out(s)%qflx_ro_sisl(:) = 0._r8 - + ! To disaggregate, we need the root density (length) on the soil layer + csite_hydr%rootfr_sl(:) = 0._r8 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ccohort=>cpatch%tallest + do while(associated(ccohort)) + + sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) + ft = ccohort%pft + + call MaximumRootingDepth(ccohort%dbh,ft,bc_in(s)%zi_sisl(bc_in(s)%nlevsoil),z_fr) + + do j_bc = 1,bc_in(s)%nlevsoil + + rootfr = zeng2001_crootfr(prt_params%fnrt_prof_a(ft),prt_params%fnrt_prof_b(ft),bc_in(s)%zi_sisl(j_bc),z_fr) - & + zeng2001_crootfr(prt_params%fnrt_prof_a(ft),prt_params%fnrt_prof_b(ft), bc_in(s)%zi_sisl(j_bc)-bc_in(s)%dz_sisl(j_bc),z_fr) + + csite_hydr%rootfr_sl(j_bc) = csite_hydr%rootfr_sl(j_bc) + sum_l_aroot*rootfr*ccohort%n + + end do + + ccohort => ccohort%shorter + enddo !cohort + cpatch => cpatch%younger + enddo !patch + + do j=1,csite_hydr%nlevrhiz @@ -2777,7 +2805,6 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) j_t = csite_hydr%map_r2s(j,1) j_b = csite_hydr%map_r2s(j,2) - ! First pass, get sum of weighting factors for disaggregation sumweight = 0._r8 do j_bc = j_t,j_b if(rootflux_disagg == soilk_disagg)then @@ -2789,13 +2816,13 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) h2osoi_liqvol = min(eff_por, bc_in(s)%h2o_liq_sisl(j_bc)/(bc_in(s)%dz_sisl(j_bc)*denh2o)) psi_layer = csite_hydr%wrf_soil(j)%p%psi_from_th(h2osoi_liqvol) ftc_layer = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_layer) - weight = bc_in(s)%hksat_sisl(j_bc)*ftc_layer*bc_in(s)%dz_sisl(j_bc) + weight = bc_in(s)%hksat_sisl(j_bc)*ftc_layer*csite_hydr%rootfr_sl(j_bc) !bc_in(s)%dz_sisl(j_bc) else - weight = bc_in(s)%dz_sisl(j_bc) + weight = csite_hydr%rootfr_sl(j_bc) !bc_in(s)%dz_sisl(j_bc) end if elseif(rootflux_disagg == soilz_disagg) then ! weight by depth - weight = bc_in(s)%dz_sisl(j_bc) + weight = csite_hydr%rootfr_sl(j_bc) !bc_in(s)%dz_sisl(j_bc) else write(fates_log(),*) 'Unknown rhiz->soil disaggregation method',rootflux_disagg call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -2811,12 +2838,12 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) h2osoi_liqvol = min(eff_por, bc_in(s)%h2o_liq_sisl(j_bc)/(bc_in(s)%dz_sisl(j_bc)*denh2o)) psi_layer = csite_hydr%wrf_soil(j)%p%psi_from_th(h2osoi_liqvol) ftc_layer = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_layer) - weight = bc_in(s)%hksat_sisl(j_bc)*ftc_layer*bc_in(s)%dz_sisl(j_bc) + weight = bc_in(s)%hksat_sisl(j_bc)*ftc_layer*csite_hydr%rootfr_sl(j_bc) !bc_in(s)%dz_sisl(j_bc) else - weight = bc_in(s)%dz_sisl(j_bc) + weight = csite_hydr%rootfr_sl(j_bc) !bc_in(s)%dz_sisl(j_bc) end if elseif(rootflux_disagg == soilz_disagg) then - weight = bc_in(s)%dz_sisl(j_bc) + weight = csite_hydr%rootfr_sl(j_bc) !bc_in(s)%dz_sisl(j_bc) end if ! Fill the output array to the HLM diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index fb0d295f69..75f56c3f5c 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -134,6 +134,11 @@ module FatesHydraulicsMemMod real(r8),allocatable :: rootuptake_sl(:) + ! Absorbing root fraction on the soil grid. We need this to + ! disaggregate uptake fluxes from the rhizosphere layers to + ! the soil layers + real(r8),allocatable :: rootfr_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) @@ -389,6 +394,7 @@ subroutine InitHydrSite(this,numpft,numlevsclass,hydr_solver_type,nlevsoil) allocate(this%recruit_w_uptake(1:nlevrhiz)); this%recruit_w_uptake = nan allocate(this%rootuptake_sl(1:nlevsoil)) ; this%rootuptake_sl = nan + allocate(this%rootfr_sl(1:nlevsoil)) ; this%rootfr_sl = 0._r8 allocate(this%sapflow_scpf(1:numlevsclass,1:numpft)) ; this%sapflow_scpf = nan allocate(this%rootuptake0_scpf(1:numlevsclass,1:numpft)) ; this%rootuptake0_scpf = nan From 6a536b193e1cd89409e20238013b7d3fb58c7033 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 21 Jan 2022 10:25:29 -0800 Subject: [PATCH 501/578] first cut at refactoring terminate_cohorts --- biogeochem/EDCohortDynamicsMod.F90 | 150 ++++++++++++++++++----------- 1 file changed, 94 insertions(+), 56 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 5446c94dda..5cb339da4f 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -713,10 +713,9 @@ end subroutine zero_cohort subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_in) ! ! !DESCRIPTION: - ! terminates cohorts when they get too small + ! terminates all cohorts when they get too small ! ! !USES: - ! ! !ARGUMENTS type (ed_site_type) , intent(inout), target :: currentSite @@ -746,8 +745,6 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ real(r8) :: repro_c ! reproductive carbon [kg] real(r8) :: struct_c ! structural carbon [kg] integer :: terminate ! do we terminate (itrue) or not (ifalse) - integer :: c ! counter for litter size class. - integer :: levcan ! canopy level !---------------------------------------------------------------------- currentCohort => currentPatch%shortest @@ -814,64 +811,105 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ endif ! if (.not.currentCohort%isnew .and. level == 2) then if (terminate == itrue) then - - ! preserve a record of the to-be-terminated cohort for mortality accounting - levcan = currentCohort%canopy_layer - - if( hlm_use_planthydro == itrue ) & - call AccumulateMortalityWaterStorage(currentSite,currentCohort,currentCohort%n) - - if(levcan==ican_upper) then - currentSite%term_nindivs_canopy(currentCohort%size_class,currentCohort%pft) = & - currentSite%term_nindivs_canopy(currentCohort%size_class,currentCohort%pft) + currentCohort%n - - currentSite%term_carbonflux_canopy = currentSite%term_carbonflux_canopy + & - currentCohort%n * (struct_c+sapw_c+leaf_c+fnrt_c+store_c+repro_c) - else - currentSite%term_nindivs_ustory(currentCohort%size_class,currentCohort%pft) = & - currentSite%term_nindivs_ustory(currentCohort%size_class,currentCohort%pft) + currentCohort%n - - currentSite%term_carbonflux_ustory = currentSite%term_carbonflux_ustory + & - currentCohort%n * (struct_c+sapw_c+leaf_c+fnrt_c+store_c+repro_c) - end if - - ! put the litter from the terminated cohorts - ! straight into the fragmenting pools - - if (currentCohort%n.gt.0.0_r8) then - call SendCohortToLitter(currentSite,currentPatch, & - currentCohort,currentCohort%n,bc_in) - end if - - ! Set pointers and remove the current cohort from the list - shorterCohort => currentCohort%shorter - - if (.not. associated(tallerCohort)) then - currentPatch%tallest => shorterCohort - if(associated(shorterCohort)) shorterCohort%taller => null() - else - tallerCohort%shorter => shorterCohort - - endif - - if (.not. associated(shorterCohort)) then - currentPatch%shortest => tallerCohort - if(associated(tallerCohort)) tallerCohort%shorter => null() - else - shorterCohort%taller => tallerCohort - endif - - - call DeallocateCohort(currentCohort) - deallocate(currentCohort) - nullify(currentCohort) - + call terminate_cohort(currentSite, currentCohort, bc_in) endif currentCohort => tallerCohort enddo end subroutine terminate_cohorts + !-------------------------------------------------------------------------------------! + subroutine terminate_cohort(currentSite, currentCohort, bc_in) + ! + ! !DESCRIPTION: + ! Terminates an individual cohort and updates the site-level + ! updates the carbon flux and nuber of individuals appropriately + ! + ! !USES: + ! + ! !ARGUMENTS + type (ed_site_type) , intent(inout), target :: currentSite + type (ed_cohort_type), intent(inout), target :: currentCohort + type(bc_in_type), intent(in) :: bc_in + + ! !LOCAL VARIABLES: + type (ed_cohort_type) , pointer :: shorterCohort + type (ed_cohort_type) , pointer :: tallerCohort + type (ed_patch_type) , pointer :: currentPatch + + real(r8) :: leaf_c ! leaf carbon [kg] + real(r8) :: store_c ! storage carbon [kg] + real(r8) :: sapw_c ! sapwood carbon [kg] + real(r8) :: fnrt_c ! fineroot carbon [kg] + real(r8) :: repro_c ! reproductive carbon [kg] + real(r8) :: struct_c ! structural carbon [kg] + integer :: terminate ! do we terminate (itrue) or not (ifalse) + integer :: c ! counter for litter size class. + integer :: levcan ! canopy level + !---------------------------------------------------------------------- + + currentCohort%patchptr => currentPatch + + leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) + store_c = currentCohort%prt%GetState(store_organ, carbon12_element) + sapw_c = currentCohort%prt%GetState(sapw_organ, carbon12_element) + fnrt_c = currentCohort%prt%GetState(fnrt_organ, carbon12_element) + struct_c = currentCohort%prt%GetState(struct_organ, carbon12_element) + repro_c = currentCohort%prt%GetState(repro_organ, carbon12_element) + + ! preserve a record of the to-be-terminated cohort for mortality accounting + levcan = currentCohort%canopy_layer + + if( hlm_use_planthydro == itrue ) & + call AccumulateMortalityWaterStorage(currentSite,currentCohort,currentCohort%n) + + ! Update the site-level carbon flux and individuals count for the appropriate canopy layer + if(levcan==ican_upper) then + currentSite%term_nindivs_canopy(currentCohort%size_class,currentCohort%pft) = & + currentSite%term_nindivs_canopy(currentCohort%size_class,currentCohort%pft) + currentCohort%n + + currentSite%term_carbonflux_canopy = currentSite%term_carbonflux_canopy + & + currentCohort%n * (struct_c+sapw_c+leaf_c+fnrt_c+store_c+repro_c) + else + currentSite%term_nindivs_ustory(currentCohort%size_class,currentCohort%pft) = & + currentSite%term_nindivs_ustory(currentCohort%size_class,currentCohort%pft) + currentCohort%n + + currentSite%term_carbonflux_ustory = currentSite%term_carbonflux_ustory + & + currentCohort%n * (struct_c+sapw_c+leaf_c+fnrt_c+store_c+repro_c) + end if + + ! put the litter from the terminated cohorts + ! straight into the fragmenting pools + + if (currentCohort%n.gt.0.0_r8) then + call SendCohortToLitter(currentSite,currentPatch, & + currentCohort,currentCohort%n,bc_in) + end if + + ! Set pointers and remove the current cohort from the list + shorterCohort => currentCohort%shorter + + if (.not. associated(tallerCohort)) then + currentPatch%tallest => shorterCohort + if(associated(shorterCohort)) shorterCohort%taller => null() + else + tallerCohort%shorter => shorterCohort + endif + + if (.not. associated(shorterCohort)) then + currentPatch%shortest => tallerCohort + if(associated(tallerCohort)) tallerCohort%shorter => null() + else + shorterCohort%taller => tallerCohort + endif + + + call DeallocateCohort(currentCohort) + deallocate(currentCohort) + nullify(currentCohort) + + end subroutine terminate_cohort + ! ===================================================================================== subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) From 52e1cd28b319633ded0553b0fa7c7b7e27456de7 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 21 Jan 2022 12:41:03 -0800 Subject: [PATCH 502/578] need to pass in currentpatch and forgot tallercohort pointer --- biogeochem/EDCohortDynamicsMod.F90 | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 5cb339da4f..a46aac2c60 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -113,6 +113,7 @@ module EDCohortDynamicsMod public :: zero_cohort public :: nan_cohort public :: terminate_cohorts + public :: terminate_cohort public :: fuse_cohorts public :: insert_cohort public :: sort_cohorts @@ -811,15 +812,15 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ endif ! if (.not.currentCohort%isnew .and. level == 2) then if (terminate == itrue) then - call terminate_cohort(currentSite, currentCohort, bc_in) - endif - currentCohort => tallerCohort + call terminate_cohort(currentSite, currentPatch, currentCohort, bc_in) + endif + currentCohort => tallerCohort enddo end subroutine terminate_cohorts !-------------------------------------------------------------------------------------! - subroutine terminate_cohort(currentSite, currentCohort, bc_in) + subroutine terminate_cohort(currentSite, currentPatch, currentCohort, bc_in) ! ! !DESCRIPTION: ! Terminates an individual cohort and updates the site-level @@ -829,13 +830,13 @@ subroutine terminate_cohort(currentSite, currentCohort, bc_in) ! ! !ARGUMENTS type (ed_site_type) , intent(inout), target :: currentSite + type (ed_patch_type) , intent(inout), target :: currentPatch type (ed_cohort_type), intent(inout), target :: currentCohort type(bc_in_type), intent(in) :: bc_in ! !LOCAL VARIABLES: type (ed_cohort_type) , pointer :: shorterCohort type (ed_cohort_type) , pointer :: tallerCohort - type (ed_patch_type) , pointer :: currentPatch real(r8) :: leaf_c ! leaf carbon [kg] real(r8) :: store_c ! storage carbon [kg] @@ -848,8 +849,6 @@ subroutine terminate_cohort(currentSite, currentCohort, bc_in) integer :: levcan ! canopy level !---------------------------------------------------------------------- - currentCohort%patchptr => currentPatch - leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) store_c = currentCohort%prt%GetState(store_organ, carbon12_element) sapw_c = currentCohort%prt%GetState(sapw_organ, carbon12_element) @@ -886,8 +885,9 @@ subroutine terminate_cohort(currentSite, currentCohort, bc_in) currentCohort,currentCohort%n,bc_in) end if - ! Set pointers and remove the current cohort from the list + ! Set pointers and deallocate the current cohort from the list shorterCohort => currentCohort%shorter + tallerCohort => currentCohort%taller if (.not. associated(tallerCohort)) then currentPatch%tallest => shorterCohort @@ -903,10 +903,7 @@ subroutine terminate_cohort(currentSite, currentCohort, bc_in) shorterCohort%taller => tallerCohort endif - call DeallocateCohort(currentCohort) - deallocate(currentCohort) - nullify(currentCohort) end subroutine terminate_cohort From f5b9596bcb44d7c6c5dc37258954e34c23f22365 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 21 Jan 2022 13:44:17 -0800 Subject: [PATCH 503/578] adding missing deallocate call --- biogeochem/EDCohortDynamicsMod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index a46aac2c60..b5a4b414f7 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -813,6 +813,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ if (terminate == itrue) then call terminate_cohort(currentSite, currentPatch, currentCohort, bc_in) + deallocate(currentCohort) endif currentCohort => tallerCohort enddo From f6f95d97790725fc24c1d6ae648eb640552a8cdb Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 21 Jan 2022 14:49:29 -0800 Subject: [PATCH 504/578] replace sendcohort... with terminate... --- biogeochem/EDCanopyStructureMod.F90 | 18 +++++------------- 1 file changed, 5 insertions(+), 13 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 130fd776f7..90b7136444 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -14,10 +14,9 @@ module EDCanopyStructureMod use EDPftvarcon , only : EDPftvarcon_inst use PRTParametersMod , only : prt_params use FatesAllometryMod , only : carea_allom - use EDCohortDynamicsMod , only : copy_cohort, terminate_cohorts, fuse_cohorts + use EDCohortDynamicsMod , only : copy_cohort, terminate_cohorts, terminate_cohort, fuse_cohorts use EDCohortDynamicsMod , only : InitPRTObject use EDCohortDynamicsMod , only : InitPRTBoundaryConditions - use EDCohortDynamicsMod , only : SendCohortToLitter use FatesAllometryMod , only : tree_lai use FatesAllometryMod , only : tree_sai use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type @@ -718,22 +717,15 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) end if ! kill the ones which go into canopy layers that are not allowed - if(currentCohort%canopy_layer>nclmax )then - ! put the litter from the terminated cohorts ! straight into the fragmenting pools - call SendCohortToLitter(currentSite,currentPatch, & - currentCohort,currentCohort%n,bc_in) - - currentCohort%n = 0.0_r8 - currentCohort%c_area = 0.0_r8 - currentCohort%canopy_layer = i_lyr - - end if - + call terminate_cohort(currentSite,currentPatch,currentCohort,bc_in) + deallocate(currentCohort) + else call carea_allom(currentCohort%dbh,currentCohort%n, & currentSite%spread,currentCohort%pft,currentCohort%c_area) + end if endif !canopy layer = i_ly From 816176b80f67fe09b409ca5054bcec627fff3e25 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 21 Jan 2022 16:51:17 -0800 Subject: [PATCH 505/578] adding comments regarding sp mode --- biogeochem/EDCohortDynamicsMod.F90 | 1 + biogeochem/EDPhysiologyMod.F90 | 1 + 2 files changed, 2 insertions(+) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 5446c94dda..d5cc4d1877 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1323,6 +1323,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) currentCohort%canopy_layer, currentPatch%canopy_layer_tlai, & currentCohort%vcmax25top) + ! We don't need check on sp mode here since we don't fuse_cohorts with sp mode currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & currentCohort%c_area, newn, currentCohort%canopy_layer, & currentPatch%canopy_layer_tlai, currentCohort%treelai,currentCohort%vcmax25top,1 ) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index c51ab7867e..9b071d5fc3 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -467,6 +467,7 @@ subroutine trim_canopy( currentSite ) currentCohort%n, currentCohort%canopy_layer, & currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + ! We don't need check on sp mode here since we don't trim_canopy with sp mode currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & currentPatch%canopy_layer_tlai, currentCohort%treelai, & From 6214207c64e9e960036599df85c88646515ea326 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 21 Jan 2022 16:53:15 -0800 Subject: [PATCH 506/578] initial refactor of the patch-level lai update in leaf_area_profile --- biogeochem/EDCanopyStructureMod.F90 | 123 ++++++++++++++++++---------- 1 file changed, 79 insertions(+), 44 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 130fd776f7..1dfba3f6f5 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1523,8 +1523,6 @@ subroutine leaf_area_profile( currentSite ) ! calculate tree lai and sai. ! -------------------------------------------------------------------------------- - currentPatch%canopy_layer_tlai(:) = 0._r8 - currentPatch%ncan(:,:) = 0 currentPatch%nrad(:,:) = 0 patch_lai = 0._r8 currentPatch%tlai_profile(:,:,:) = 0._r8 @@ -1542,45 +1540,7 @@ subroutine leaf_area_profile( currentSite ) if (currentPatch%total_canopy_area > nearzero ) then - - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) - - ft = currentCohort%pft - cl = currentCohort%canopy_layer - - ! Calculate LAI of layers above - ! Note that the canopy_layer_lai is also calculated in this loop - ! but since we go top down in terms of plant size, we should be okay - - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - - currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & - currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) - - if (hlm_use_sp .eq. ifalse) then - currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & - currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai, currentCohort%treelai , & - currentCohort%vcmax25top,4) - end if - - currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area - currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area - - ! Number of actual vegetation layers in this cohort's crown - currentCohort%nv = count((currentCohort%treelai+currentCohort%treesai) .gt. dlower_vai(:)) + 1 - - currentPatch%ncan(cl,ft) = max(currentPatch%ncan(cl,ft),currentCohort%NV) - - patch_lai = patch_lai + currentCohort%lai - - currentPatch%canopy_layer_tlai(cl) = currentPatch%canopy_layer_tlai(cl) + currentCohort%lai - - currentCohort => currentCohort%shorter - - enddo !currentCohort + call UpdatePatchLAI(currentPatch, patch_lai) if(smooth_leaf_distribution == 1)then @@ -2211,8 +2171,8 @@ subroutine CanopyLayerArea(currentPatch,site_spread,layer_index,layer_area) real(r8),intent(inout) :: layer_area type(ed_cohort_type), pointer :: currentCohort - - + + layer_area = 0.0_r8 currentCohort => currentPatch%tallest do while (associated(currentCohort)) @@ -2224,7 +2184,82 @@ subroutine CanopyLayerArea(currentPatch,site_spread,layer_index,layer_area) currentCohort => currentCohort%shorter enddo return - end subroutine CanopyLayerArea + end subroutine CanopyLayerArea + + ! =============================================================================================== + + subroutine UpdatePatchLAI(currentPatch, patch_lai) + + ! -------------------------------------------------------------------------------------------- + ! This subroutine works through the current patch cohorts and updates the canopy_layer_tlai + ! and related variables + ! --------------------------------------------------------------------------------------------- + + ! Arguments + type(ed_patch_type),intent(inout), target :: currentPatch + real(r8), intent(out) :: patch_lai + + ! Local Variables + type(ed_cohort_type), pointer :: currentCohort + integer :: cl ! Canopy layer index + integer :: ft ! Plant functional type index + + ! Zero out the patch-level canopy layer variables + currentPatch%canopy_layer_tlai(:) = 0._r8 + currentPatch%ncan(:,:) = 0 + + ! Calculate LAI of layers above. Because it is possible for some understory cohorts + ! to be taller than cohorts in the top canopy layer, we must iterate through the + ! patch by canopy layer first. Given that canopy_layer_tlai is a patch level variable + ! we could iterate through each cohort in any direction as long as we go down through + ! the canopy layers. + + !canopyloop: do cl = 1,nclmax + currentCohort => currentPatch%tallest + cohortloop: do while(associated(currentCohort)) + + ! Only update the current cohort tree lai if lai of the above layers have been calculated + !if (currentCohort%canopy_layer .eq. cl) then + cl = currentCohort%canopy_layer + ft = currentCohort%pft + leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + + ! Note that tree_lai has an internal check on the canopy + currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & + currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + + if (hlm_use_sp .eq. ifalse) then + currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & + currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai, currentCohort%treelai , & + currentCohort%vcmax25top,4) + end if + + ! Update the cohort lai and sai + currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area + currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area + + ! Number of actual vegetation layers in this cohort's crown + currentCohort%nv = count((currentCohort%treelai+currentCohort%treesai) .gt. dlower_vai(:)) + 1 + + ! Update the number of number of vegetation layers + currentPatch%ncan(cl,ft) = max(currentPatch%ncan(cl,ft),currentCohort%NV) + + ! Update the patch canopy layer tlai + currentPatch%canopy_layer_tlai(cl) = currentPatch%canopy_layer_tlai(cl) + currentCohort%lai + + ! Calculate the total patch lai + patch_lai = patch_lai + currentCohort%lai + + !end if + + currentCohort => currentCohort%shorter + + end do cohortloop + !end do canopyloop + + end subroutine UpdatePatchLAI ! =============================================================================================== From 86000654e090bb2163f4b3af99cf5b791275e0a6 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 25 Jan 2022 14:44:30 -0500 Subject: [PATCH 507/578] Using root length instead of fraction to perform disaggregation of root water uptake in hydro --- biogeophys/FatesPlantHydraulicsMod.F90 | 70 ++++++++++---------------- main/FatesHydraulicsMemMod.F90 | 8 +-- 2 files changed, 31 insertions(+), 47 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index bb56b73086..5571adc089 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -1461,7 +1461,7 @@ subroutine InitHydrSites(sites,bc_in) aggmeth = rhizlayer_aggmeth_combine12 - aggN = -9 + aggN = 10 select case(aggmeth) @@ -2410,18 +2410,14 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! ! !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 :: j_b,j_t ! bottom and top soil layers for the current rhiz layer - 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 + integer :: s ! index of FATES site + integer :: i ! shell index + integer :: j ! soil layer + integer :: ifp ! boundary condition, patch index + integer :: j_bc ! soil layer index for boundary conditions + integer :: j_b,j_t ! bottom and top soil layers for the current rhiz layer + integer :: k ! 1D plant-soil continuum array + integer :: ft ! plant functional type index !---------------------------------------------------------------------- @@ -2433,23 +2429,24 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) ! Local arrays ! accumulated water content change over all cohorts in a column [m3 m-3] - real(r8) :: dth_layershell_col(nlevsoi_hyd_max,nshell) + 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)/) + integer :: ordered(nlevsoi_hyd_max) = (/(j,j=1,nlevsoi_hyd_max,1)/) + real(r8) :: weight_sl(nlevsoi_hyd_max) ! Weighting factor for disaggregation + ! on the soil grid (not rhizoshere grid) + ! 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) :: 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 + ! runoff. This is either banked, or sent to the correct flux pool [kg/m2] real(r8) :: wb_err_plant ! Solve error for a single plant [kg] real(r8) :: wb_check_site ! the water balance error we get from summing fluxes - ! and changes in storage - ! and is just a double check on our error accounting). [kg/m2] + ! 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) :: qflx_soil2root_rhiz ! soil into root water flux at this rhiz layer @@ -2745,7 +2742,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) bc_out(s)%qflx_ro_sisl(:) = 0._r8 ! To disaggregate, we need the root density (length) on the soil layer - csite_hydr%rootfr_sl(:) = 0._r8 + csite_hydr%rootl_sl(:) = 0._r8 cpatch => sites(s)%oldest_patch do while (associated(cpatch)) ccohort=>cpatch%tallest @@ -2761,7 +2758,7 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) rootfr = zeng2001_crootfr(prt_params%fnrt_prof_a(ft),prt_params%fnrt_prof_b(ft),bc_in(s)%zi_sisl(j_bc),z_fr) - & zeng2001_crootfr(prt_params%fnrt_prof_a(ft),prt_params%fnrt_prof_b(ft), bc_in(s)%zi_sisl(j_bc)-bc_in(s)%dz_sisl(j_bc),z_fr) - csite_hydr%rootfr_sl(j_bc) = csite_hydr%rootfr_sl(j_bc) + sum_l_aroot*rootfr*ccohort%n + csite_hydr%rootl_sl(j_bc) = csite_hydr%rootl_sl(j_bc) + sum_l_aroot*rootfr*ccohort%n*prt_params%c2b(ft)*EDPftvarcon_inst%hydr_srl(ft) end do @@ -2816,41 +2813,28 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) h2osoi_liqvol = min(eff_por, bc_in(s)%h2o_liq_sisl(j_bc)/(bc_in(s)%dz_sisl(j_bc)*denh2o)) psi_layer = csite_hydr%wrf_soil(j)%p%psi_from_th(h2osoi_liqvol) ftc_layer = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_layer) - weight = bc_in(s)%hksat_sisl(j_bc)*ftc_layer*csite_hydr%rootfr_sl(j_bc) !bc_in(s)%dz_sisl(j_bc) + weight_sl(j_bc) = bc_in(s)%hksat_sisl(j_bc)*ftc_layer*csite_hydr%rootl_sl(j_bc) else - weight = csite_hydr%rootfr_sl(j_bc) !bc_in(s)%dz_sisl(j_bc) + weight_sl(j_bc) = csite_hydr%rootl_sl(j_bc) end if elseif(rootflux_disagg == soilz_disagg) then ! weight by depth - weight = csite_hydr%rootfr_sl(j_bc) !bc_in(s)%dz_sisl(j_bc) + weight_sl(j_bc) = csite_hydr%rootl_sl(j_bc) else write(fates_log(),*) 'Unknown rhiz->soil disaggregation method',rootflux_disagg call endrun(msg=errMsg(sourcefile, __LINE__)) end if - sumweight = sumweight + weight + sumweight = sumweight + weight_sl(j_bc) end do - ! Second pass, apply weighting factors for fluxes + ! Second pass, apply normalized weighting factors for fluxes do j_bc = j_t,j_b - if(rootflux_disagg == soilk_disagg)then - if(qflx_soil2root_rhiz>0._r8)then - eff_por = bc_in(s)%eff_porosity_sl(j_bc) - h2osoi_liqvol = min(eff_por, bc_in(s)%h2o_liq_sisl(j_bc)/(bc_in(s)%dz_sisl(j_bc)*denh2o)) - psi_layer = csite_hydr%wrf_soil(j)%p%psi_from_th(h2osoi_liqvol) - ftc_layer = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_layer) - weight = bc_in(s)%hksat_sisl(j_bc)*ftc_layer*csite_hydr%rootfr_sl(j_bc) !bc_in(s)%dz_sisl(j_bc) - else - weight = csite_hydr%rootfr_sl(j_bc) !bc_in(s)%dz_sisl(j_bc) - end if - elseif(rootflux_disagg == soilz_disagg) then - weight = csite_hydr%rootfr_sl(j_bc) !bc_in(s)%dz_sisl(j_bc) - end if ! Fill the output array to the HLM - bc_out(s)%qflx_soil2root_sisl(j_bc) = qflx_soil2root_rhiz * weight/sumweight + bc_out(s)%qflx_soil2root_sisl(j_bc) = qflx_soil2root_rhiz * weight_sl(j_bc)/sumweight ! Save root uptake for history diagnostics [kg/m/s] - csite_hydr%rootuptake_sl(j_bc) = qflx_soil2root_rhiz * weight/sumweight + csite_hydr%rootuptake_sl(j_bc) = qflx_soil2root_rhiz * weight_sl(j_bc)/sumweight end do diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 75f56c3f5c..65163e1c8c 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -134,10 +134,10 @@ module FatesHydraulicsMemMod real(r8),allocatable :: rootuptake_sl(:) - ! Absorbing root fraction on the soil grid. We need this to + ! Absorbing root length on the soil grid. We need this to ! disaggregate uptake fluxes from the rhizosphere layers to ! the soil layers - real(r8),allocatable :: rootfr_sl(:) + real(r8),allocatable :: rootl_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 @@ -371,7 +371,7 @@ subroutine InitHydrSite(this,numpft,numlevsclass,hydr_solver_type,nlevsoil) integer,intent(in) :: numlevsclass integer,intent(in) :: hydr_solver_type integer,intent(in) :: nlevsoil - + associate(nlevrhiz => this%nlevrhiz) ! In all cases, the 0 index of the layer bottom is a value of 0 @@ -394,7 +394,7 @@ subroutine InitHydrSite(this,numpft,numlevsclass,hydr_solver_type,nlevsoil) allocate(this%recruit_w_uptake(1:nlevrhiz)); this%recruit_w_uptake = nan allocate(this%rootuptake_sl(1:nlevsoil)) ; this%rootuptake_sl = nan - allocate(this%rootfr_sl(1:nlevsoil)) ; this%rootfr_sl = 0._r8 + allocate(this%rootl_sl(1:nlevsoil)) ; this%rootl_sl = 0._r8 allocate(this%sapflow_scpf(1:numlevsclass,1:numpft)) ; this%sapflow_scpf = nan allocate(this%rootuptake0_scpf(1:numlevsclass,1:numpft)) ; this%rootuptake0_scpf = nan From 19598c582953652656172b8838ba80eee0eea8e0 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 26 Jan 2022 10:34:56 -0500 Subject: [PATCH 508/578] Code style update to smoothed cambpell PV-PK functions. --- biogeophys/FatesHydroWTFMod.F90 | 41 ++++++++++++++++++++++----------- 1 file changed, 28 insertions(+), 13 deletions(-) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index acbf6e0252..8356b2b165 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -1062,7 +1062,8 @@ function psi_from_th_smooth_cch(this,th) result(psi) real(r8) :: resid real(r8) :: dx real(r8), parameter :: relTol = 1.d-9 - + integer :: iter + sat_res = 0._r8 alpha = -1._r8/this%psi_sat lambda = 1._r8/this%beta @@ -1110,13 +1111,19 @@ function psi_from_th_smooth_cch(this,th) result(psi) ! 1.d0 - Se, & ! ' r{xR}', xR*xR*(scch_b2 + scch_b3*xR) + ! 1.d0 - Se - do + + iter = 0 + dx = 1.e20_r8 ! something large + do while( abs(dx) >= -relTol*this%scch_pu ) + ! Here, assume: ! + Have a bracket on the root, between `xL` and `xR`. - ! + The residual `r{xL} < 0` and `r{xR} > 0`. + ! + The residual `r{xL} < 0` and `r{xR} > 0`. ! + Have a current guess `xc` at the root. However, that guess ! might not lie in the bracket. + iter=iter+1 + ! Reset `xc` using bisection if necessary. if( xc<=xL .or. xc>=xR ) then ! write(unit=*, fmt='("Bisecting")') @@ -1146,10 +1153,9 @@ function psi_from_th_smooth_cch(this,th) result(psi) ! ' r{xR}', xR*xR*(scch_b2 + scch_b3*xR) + ! 1.d0 - Se - ! Test for convergence. - ! Note this test implicitly also tests `resid == 0`. - if( abs(dx) < -relTol*this%scch_pu ) then - exit + if( iter>10000) then + write(fates_log(),*) "psi_from_th_smooth_cch iteration not converging" + call endrun(msg=errMsg(__FILE__, __LINE__)) endif enddo @@ -1362,7 +1368,8 @@ real(r8) function findGu_SBC_zeroCoeff(lambda, AA, gs) real(r8) :: deltaGu, resid, dr_dGu ! Newton-Raphson search. real(r8) :: guInv, guToMinusLam, gsOnGu ! Helper variables. real(r8), parameter :: relTol = 1.d-12 - + integer :: iter + ! Check arguments. ! Note this is more for documentation than anything else-- this ! fcn should only get used internally, by trusted callers. @@ -1389,7 +1396,13 @@ real(r8) function findGu_SBC_zeroCoeff(lambda, AA, gs) if( gs > 0.d0 ) then guLeft = 1.d0 guRight = gu - do + + ! Test for convergence. + ! Note this test implicitly also tests `resid == 0`. + iter = 0 + deltaGu=1.e20_r8 ! something large + do while( abs(deltaGu) >= relTol*abs(gu) ) + ! Here, assume: ! + Have an bracket on the root, between `guLeft` and `guRight`. ! + The derivative `dr/d{gu} > 0`. @@ -1397,6 +1410,8 @@ real(r8) function findGu_SBC_zeroCoeff(lambda, AA, gs) ! + Have a current guess `gu` at the root. However, that guess ! might not lie in the bracket (and does not at first iteration). + iter=iter+1 + ! Reset `gu` using bisection if necessary. if( gu<=guLeft .or. gu>=guRight ) then gu = guLeft + 0.5d0*(guRight - guLeft) @@ -1424,11 +1439,11 @@ real(r8) function findGu_SBC_zeroCoeff(lambda, AA, gs) ! 'deltaGu', deltaGu, 'resid', resid, 'dr_dGu', dr_dGu gu = gu - deltaGu - ! Test for convergence. - ! Note this test implicitly also tests `resid == 0`. - if( abs(deltaGu) < relTol*abs(gu) ) then - exit + if( iter>10000) then + write(fates_log(),*) "findGu_SBC_zeroCoeff iteration not converging" + call endrun(msg=errMsg(__FILE__, __LINE__)) endif + enddo endif From e22dc7246df6a2f8398386f24db2e6df2d08f390 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 27 Jan 2022 11:27:47 -0800 Subject: [PATCH 509/578] adding initialization diagnostics --- biogeochem/EDPhysiologyMod.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 6feb039d37..df16d855b6 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1520,6 +1520,10 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l ! ------------------------------------------ currentCohort%treelai = tlai canopylai(:) = 0._r8 + ! If we are initializing, the canopy layer has not been set yet, so just set to 1 + if(init.eq.itrue)then + currentCohort%canopy_layer = 1 + endif leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) @@ -1532,6 +1536,8 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzero write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%treelai-check_treelai + write(fates_log(),*) 'tree_lai inputs: ', currentCohort%pft, currentCohort%c_area, currentCohort%n, & + currentCohort%canopy_layer, currentCohort%vcmax25top call endrun(msg=errMsg(sourcefile, __LINE__)) end if From b611e0757a197fd64b71a565da48e232a193a640 Mon Sep 17 00:00:00 2001 From: Jacquelyn Shuman Date: Thu, 27 Jan 2022 18:02:04 -0700 Subject: [PATCH 510/578] Update FATES PFT optical to Majasalmi Bright 2019 FATES PFT optical params are updated to those published in Majasalmi & Bright 2019 GeoSciModelDev and are consistent with CLM PFT optical params Fixes: #578 User interface changes?:No Code review: none Test suite: Test baseline: Test namelist changes: Test answer changes: will change answers Test summary: --- parameter_files/fates_params_default.cdl | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 6d5fa2cb4e..1871f3af64 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -1115,8 +1115,8 @@ data: fates_leaf_vcmaxse = 485, 485, 485, 485, 485, 485, 485, 485, 485, 485, 485, 485 ; - fates_leaf_xl = 0.1, 0.01, 0.01, 0.1, 0.01, 0.25, 0.01, 0.25, 0.25, -0.3, - -0.3, -0.3 ; + fates_leaf_xl = 0.32, 0.01, 0.01, 0.32, 0.2, 0.59, 0.32, 0.59, 0.59, -0.23, + -0.23, -0.23 ; fates_lf_fcel = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; @@ -1250,15 +1250,15 @@ data: fates_recruit_initd = 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2 ; - fates_rholnir = 0.45, 0.35, 0.35, 0.45, 0.45, 0.45, 0.35, 0.45, 0.45, 0.35, - 0.35, 0.35 ; + fates_rholnir = 0.46, 0.41, 0.39, 0.46, 0.41, 0.41, 0.46, 0.41, 0.41, 0.28, + 0.28, 0.28 ; - fates_rholvis = 0.1, 0.07, 0.07, 0.1, 0.1, 0.1, 0.07, 0.1, 0.1, 0.1, 0.1, 0.1 ; + fates_rholvis = 0.11, 0.09, 0.08, 0.11, 0.08, 0.08, 0.11, 0.08, 0.08, 0.05, 0.05, 0.05 ; - fates_rhosnir = 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.53, + fates_rhosnir = 0.49, 0.36, 0.36, 0.49, 0.49, 0.49, 0.49, 0.49, 0.49, 0.53, 0.53, 0.53 ; - fates_rhosvis = 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.31, + fates_rhosvis = 0.21, 0.12, 0.12, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.31, 0.31, 0.31 ; fates_root_long = 1, 2, 1, 1.5, 1, 1, 1.5, 1, 1, 1, 1, 1 ; @@ -1286,10 +1286,10 @@ data: fates_smpso = -66000, -66000, -66000, -66000, -66000, -66000, -66000, -66000, -66000, -66000, -66000, -66000 ; - fates_taulnir = 0.25, 0.1, 0.1, 0.25, 0.25, 0.25, 0.1, 0.25, 0.25, 0.34, - 0.34, 0.34 ; + fates_taulnir = 0.33, 0.32, 0.42, 0.33, 0.43, 0.43, 0.33, 0.43, 0.43, 0.4, + 0.4, 0.4 ; - fates_taulvis = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, + fates_taulvis = 0.06, 0.04, 0.04, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.05, 0.05, 0.05 ; fates_tausnir = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, From 5487d7c1b21d17724ecc5eab7bad12d0454c7823 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 2 Feb 2022 13:26:51 -0700 Subject: [PATCH 511/578] removed logic that prevented patch dynamics when nocomp was running --- main/EDMainMod.F90 | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 75079c8071..03150d2adc 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -260,15 +260,10 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) ! Patch dynamics sub-routines: fusion, new patch creation (spwaning), termination. !********************************************************************************* + ! turn off patch dynamics if SP or ST3 modes in use do_patch_dynamics = itrue if(hlm_use_ed_st3.eq.itrue .or. & - hlm_use_nocomp.eq.itrue .or. & hlm_use_sp.eq.itrue)then - ! n.b. this is currently set to false to get around a memory leak that occurs - ! when we have multiple patches for each PFT. - ! when this is fixed, we will need another option for 'one patch per PFT' vs 'multiple patches per PFT' - ! hlm_use_sp check provides cover for potential changes in nocomp logic (nocomp required by spmode, but - ! not the other way around). do_patch_dynamics = ifalse end if From bd707e41bc77b9178fe6fe0d3a9bcc16b4eb7468 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 2 Feb 2022 16:10:12 -0700 Subject: [PATCH 512/578] added history vars that only apply to nocomp case --- main/FatesHistoryInterfaceMod.F90 | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 20918251d2..73b75e856d 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -48,6 +48,7 @@ module FatesHistoryInterfaceMod use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_model_day use FatesInterfaceTypesMod , only : nlevcoage + use FatesInterfaceTypesMod , only : hlm_use_nocomp use FatesAllometryMod , only : CrownDepth use EDPftvarcon , only : EDPftvarcon_inst @@ -513,6 +514,8 @@ module FatesHistoryInterfaceMod integer :: ih_canopycrownarea_si_pft integer :: ih_gpp_si_pft integer :: ih_npp_si_pft + integer :: ih_nocomp_pftpatchfraction_si_pft + integer :: ih_nocomp_pftnpatches_si_pft ! indices to (site x patch-age) variables integer :: ih_area_si_age @@ -2237,6 +2240,16 @@ subroutine update_history_dyn(this,nc,nsites,sites) 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 + + ! and also pft-labeled patch areas in the event that we are in nocomp mode + if ( hlm_use_nocomp .eq. itrue .and. cpatch%nocomp_pft_label .eq. i_pft) then + this%hvars(ih_nocomp_pftpatchfraction_si_pft)%r82d(io_si,i_pft) = & + this%hvars(ih_nocomp_pftpatchfraction_si_pft)%r82d(io_si,i_pft) + cpatch%area * AREA_INV + + this%hvars(ih_nocomp_pftnpatches_si_pft)%r82d(io_si,i_pft) = & + this%hvars(ih_nocomp_pftnpatches_si_pft)%r82d(io_si,i_pft) + 1._r8 + endif + end do ! fractional area burnt [frac/day] -> [frac/sec] @@ -4535,6 +4548,20 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index=ih_mortality_si_pft) + nocomp_if: if (hlm_use_nocomp .eq. itrue) then + call this%set_history_var(vname='FATES_NOCOMP_NPATCHES_PF', units='', & + long='number of patches per PFT (nocomp-mode-only)', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_nocomp_pftnpatches_si_pft) + + call this%set_history_var(vname='FATES_NOCOMP_PATCHAREA_PF', units='m2 m-2',& + long='total patch area allowed per PFT (nocomp-mode-only)', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_nocomp_pftpatchfraction_si_pft) + endif nocomp_if + ! patch age class variables call this%set_history_var(vname='FATES_PATCHAREA_AP', units='m2 m-2', & long='patch area by age bin per m2 land area', use_default='active', & From a128271c47a2352483e9c9ef5e83e283b6ec9c43 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 2 Feb 2022 16:57:48 -0700 Subject: [PATCH 513/578] added bare-ground-patch diagnostic for nocomp mode --- main/FatesHistoryInterfaceMod.F90 | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 73b75e856d..6dd13b2f2d 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -339,6 +339,7 @@ module FatesHistoryInterfaceMod integer :: ih_h2oveg_recruit_si integer :: ih_h2oveg_growturn_err_si integer :: ih_h2oveg_hydro_err_si + integer :: ih_nocomp_baregroundpatchfraction_si integer :: ih_site_cstatus_si integer :: ih_site_dstatus_si @@ -2252,6 +2253,12 @@ subroutine update_history_dyn(this,nc,nsites,sites) end do + ! and also the bareground-labeled patch area in the event that we are in nocomp mode + if ( hlm_use_nocomp .eq. itrue .and. cpatch%nocomp_pft_label .eq. 0) then + this%hvars(ih_nocomp_baregroundpatchfraction_si)%r82d(io_si) = & + this%hvars(ih_nocomp_baregroundpatchfraction_si)%r82d(io_si) + cpatch%area * AREA_INV + endif + ! fractional area burnt [frac/day] -> [frac/sec] 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 / sec_per_day @@ -4560,6 +4567,12 @@ subroutine define_history_vars(this, initialize_variables) use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & index=ih_nocomp_pftpatchfraction_si_pft) + + call this%set_history_var(vname='FATES_NOCOMP_BAREGROUND_PATCHAREA', units='m2 m-2',& + long='total bare-ground patch area (nocomp-mode-only)', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_nocomp_baregroundpatchfraction_si) endif nocomp_if ! patch age class variables From 8cf15bac6a0662fa0340b58db8cd50b97472d7a2 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 2 Feb 2022 17:06:05 -0700 Subject: [PATCH 514/578] bugfix on prior --- main/FatesHistoryInterfaceMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 6dd13b2f2d..b9fb8d6879 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2255,8 +2255,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! and also the bareground-labeled patch area in the event that we are in nocomp mode if ( hlm_use_nocomp .eq. itrue .and. cpatch%nocomp_pft_label .eq. 0) then - this%hvars(ih_nocomp_baregroundpatchfraction_si)%r82d(io_si) = & - this%hvars(ih_nocomp_baregroundpatchfraction_si)%r82d(io_si) + cpatch%area * AREA_INV + this%hvars(ih_nocomp_baregroundpatchfraction_si)%r81d(io_si) = & + this%hvars(ih_nocomp_baregroundpatchfraction_si)%r81d(io_si) + cpatch%area * AREA_INV endif ! fractional area burnt [frac/day] -> [frac/sec] From fea565816fa4129970a284162a6cbd48d02e47d0 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 7 Feb 2022 10:33:17 -0700 Subject: [PATCH 515/578] updated PatchynamicsMod to allow for nocomp with disturbance --- biogeochem/EDPatchDynamicsMod.F90 | 191 +++++++++++++++++++++--------- 1 file changed, 132 insertions(+), 59 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 5f89ba0b07..941c98e889 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -489,24 +489,37 @@ subroutine spawn_patches( currentSite, bc_in) ! for both woody and grass species real(r8) :: leaf_m ! leaf mass during partial burn calculations logical :: found_youngest_primary ! logical for finding the first primary forest patch + integer :: min_nocomp_pft, max_nocomp_pft, i_nocomp_pft !--------------------------------------------------------------------- storesmallcohort => null() ! storage of the smallest cohort for insertion routine storebigcohort => null() ! storage of the largest cohort for insertion routine - ! calculate area of disturbed land, in this timestep, by summing contributions from each existing patch. - currentPatch => currentSite%youngest_patch - - site_areadis_primary = 0.0_r8 - site_areadis_secondary = 0.0_r8 + if (hlm_use_nocomp .eq. itrue) then + min_nocomp_pft = 0 + max_nocomp_pft = maxpft + else + min_nocomp_pft = fates_unset_int + max_nocomp_pft = fates_unset_int + endif ! zero the diagnostic disturbance rate fields currentSite%disturbance_rates_primary_to_primary(1:N_DIST_TYPES) = 0._r8 currentSite%disturbance_rates_primary_to_secondary(1:N_DIST_TYPES) = 0._r8 currentSite%disturbance_rates_secondary_to_secondary(1:N_DIST_TYPES) = 0._r8 + nocomp_pft_loop: do i_nocomp_pft = min_nocomp_pft,max_nocomp_pft + + ! calculate area of disturbed land, in this timestep, by summing contributions from each existing patch. + currentPatch => currentSite%youngest_patch + + site_areadis_primary = 0.0_r8 + site_areadis_secondary = 0.0_r8 + do while(associated(currentPatch)) + cp_nocomp_matches_1: if ( hlm_use_nocomp .eq. ifalse .or. & + currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then if(currentPatch%disturbance_rate > (1.0_r8 + rsnbl_math_prec)) then write(fates_log(),*) 'patch disturbance rate > 1 ?',currentPatch%disturbance_rate @@ -553,7 +566,8 @@ subroutine spawn_patches( currentSite, bc_in) endif end if - + + end if cp_nocomp_matches_1 currentPatch => currentPatch%older enddo ! end loop over patches. sum area disturbed for all patches. @@ -568,7 +582,7 @@ subroutine spawn_patches( currentSite, bc_in) allocate(new_patch_primary) call create_patch(currentSite, new_patch_primary, age, & - site_areadis_primary, primaryforest, fates_unset_int) + site_areadis_primary, primaryforest, i_nocomp_pft) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -590,7 +604,7 @@ subroutine spawn_patches( currentSite, bc_in) if ( site_areadis_secondary .gt. nearzero) then allocate(new_patch_secondary) call create_patch(currentSite, new_patch_secondary, age, & - site_areadis_secondary, secondaryforest,fates_unset_int) + site_areadis_secondary, secondaryforest,i_nocomp_pft) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -616,6 +630,9 @@ subroutine spawn_patches( currentSite, bc_in) currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) + cp_nocomp_matches_2: if ( hlm_use_nocomp .eq. ifalse .or. & + currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then + ! This is the amount of patch area that is disturbed, and donated by the donor patch_site_areadis = currentPatch%area * currentPatch%disturbance_rate @@ -1113,7 +1130,8 @@ subroutine spawn_patches( currentSite, bc_in) currentPatch%disturbance_rate = 0._r8 currentPatch%disturbance_rates = 0._r8 currentPatch%fract_ldist_not_harvested = 0._r8 - + + end if cp_nocomp_matches_2 currentPatch => currentPatch%younger enddo ! currentPatch patch loop. @@ -1195,6 +1213,7 @@ subroutine spawn_patches( currentSite, bc_in) call check_patch_area(currentSite) call set_patchno(currentSite) + end do nocomp_pft_loop return end subroutine spawn_patches @@ -2270,7 +2289,9 @@ subroutine fuse_patches( csite, bc_in ) integer :: iterate !switch of patch reduction iteration scheme. 1 to keep going, 0 to stop integer :: fuse_flag !do patches get fused (1) or not (0). integer :: i_disttype !iterator over anthropogenic disturbance categories + integer :: i_pftlabel !nocomp pft iterator real(r8) :: primary_land_fraction_beforefusion,primary_land_fraction_afterfusion + integer :: pftlabelmin, pftlabelmax ! !--------------------------------------------------------------------- @@ -2295,11 +2316,18 @@ subroutine fuse_patches( csite, bc_in ) currentPatch => currentPatch%older enddo + pftlabelmin = 0 + if ( hlm_use_nocomp .eq. itrue ) then + pftlabelmax = maxpft + else + pftlabelmax = 0 + endif + !---------------------------------------------------------------------! ! iterate over anthropogenic disturbance categories !---------------------------------------------------------------------! - do i_disttype = 1, n_anthro_disturbance_categories + disttype_loop: do i_disttype = 1, n_anthro_disturbance_categories !---------------------------------------------------------------------! ! We only really care about fusing patches if nopatches > 1 ! @@ -2311,7 +2339,14 @@ subroutine fuse_patches( csite, bc_in ) ! Keep doing this until nopatches <= maxPatchesPerSite ! !---------------------------------------------------------------------! - do while(iterate == 1) + iterate_eq_1: do while(iterate == 1) + + !---------------------------------------------------------------------! + ! iterate over nocomp pft labels (if nocomp is false, then this isn't much of a loop) + !---------------------------------------------------------------------! + + pftlabel_loop: do i_pftlabel = pftlabelmin, pftlabelmax + !---------------------------------------------------------------------! ! Calculate the biomass profile of each patch ! !---------------------------------------------------------------------! @@ -2325,22 +2360,26 @@ subroutine fuse_patches( csite, bc_in ) ! Loop round current & target (currentPatch,tpp) patches to assess combinations ! !-------------------------------------------------------------------------------! currentPatch => currentSite%youngest_patch - do while(associated(currentPatch)) + currentpatch_loop: do while(associated(currentPatch)) tpp => currentSite%youngest_patch - do while(associated(tpp)) + tpp_loop: do while(associated(tpp)) if(.not.associated(currentPatch))then write(fates_log(),*) 'ED: issue with currentPatch' endif - if(associated(tpp).and.associated(currentPatch))then + both_associated: if(associated(tpp).and.associated(currentPatch))then !--------------------------------------------------------------------! ! only fuse patches whose anthropogenic disturbance category matches ! ! that of the outer loop that we are in ! !--------------------------------------------------------------------! - if ( tpp%anthro_disturbance_label .eq. i_disttype .and. & + anthro_dist_labels_match: if ( tpp%anthro_disturbance_label .eq. i_disttype .and. & currentPatch%anthro_disturbance_label .eq. i_disttype) then + nocomp_pft_labels_match: if (hlm_use_nocomp .eq. ifalse .or. & + (tpp%nocomp_pft_label .eq. i_pftlabel .and. & + currentPatch%nocomp_pft_label .eq. i_pftlabel)) then + !-------------------------------------------------------------------------------------------- ! The default is to fuse the patches, unless some criteria is met which keeps them separated. ! there are multiple criteria which all need to be met to keep them distinct: @@ -2351,13 +2390,13 @@ subroutine fuse_patches( csite, bc_in ) !-------------------------------------------------------------------------------------------- fuse_flag = 1 - if(currentPatch%patchno /= tpp%patchno) then !these should be the same patch + different_patches: if(currentPatch%patchno /= tpp%patchno) then !these should be the same patch !----------------------------------------------------------------------------------- ! check to see if both patches are older than the age at which we force them to fuse !----------------------------------------------------------------------------------- - if ( tpp%age .le. max_age_of_second_oldest_patch .or. & + maxage_if: if ( tpp%age .le. max_age_of_second_oldest_patch .or. & currentPatch%age .le. max_age_of_second_oldest_patch ) then @@ -2372,21 +2411,23 @@ subroutine fuse_patches( csite, bc_in ) ! oscillations in the patch dynamics and dependent variables. !------------------------------------------------------------ - if(sum(currentPatch%pft_agb_profile(:,:)) > force_patchfuse_min_biomass .or. & + patchfuse_min_biomass_if: if & + (sum(currentPatch%pft_agb_profile(:,:)) > force_patchfuse_min_biomass .or. & sum(tpp%pft_agb_profile(:,:)) > force_patchfuse_min_biomass ) then !---------------------------------------------------------------------! ! Calculate the difference criteria for each pft and dbh class ! !---------------------------------------------------------------------! - do ft = 1,numpft ! loop over pfts - do z = 1,n_dbh_bins ! loop over hgt bins + pft_loop: do ft = 1,numpft ! loop over pfts + hgt_bin_loop: do z = 1,n_dbh_bins ! loop over hgt bins !---------------------------------- ! is there biomass in this category? !---------------------------------- - if(currentPatch%pft_agb_profile(ft,z) > 0.0_r8 .or. & + agbprof_gt_zero: if & + (currentPatch%pft_agb_profile(ft,z) > 0.0_r8 .or. & tpp%pft_agb_profile(ft,z) > 0.0_r8)then !---------------------------------------------------------------------! @@ -2406,26 +2447,20 @@ subroutine fuse_patches( csite, bc_in ) fuse_flag = 0 !do not fuse - keep apart. - endif ! profile tol - endif ! biomass(ft,z) .gt. 0 - enddo !ht bins - enddo ! PFT - endif ! sum(biomass(:,:) .gt. force_patchfuse_min_biomass - endif ! maxage - + endif + endif agbprof_gt_zero + enddo hgt_bin_loop + enddo pft_loop + endif patchfuse_min_biomass_if + endif maxage_if - ! Do not fuse patches that have different PFT labels in nocomp mode - if(hlm_use_nocomp.eq.itrue.and. & - tpp%nocomp_pft_label.ne.currentPatch%nocomp_pft_label)then - fuse_flag = 0 - end if !-------------------------------------------------------------------------! ! Call the patch fusion routine if there is not a meaningful difference ! ! any of the pft x height categories ! ! or both are older than forced fusion age ! !-------------------------------------------------------------------------! - if(fuse_flag == 1)then + fuseflagset: if(fuse_flag == 1)then !-----------------------! ! fuse the two patches ! @@ -2452,12 +2487,13 @@ subroutine fuse_patches( csite, bc_in ) else ! write(fates_log(),*) 'patches not fused' - endif - endif !are both patches the same anthropogenic disturbance category as the disturbance type loop iterator? - endif !are both patches associated? - endif !are these different patches? + endif fuseflagset + endif different_patches + endif nocomp_pft_labels_match + endif anthro_dist_labels_match + endif both_associated tpp => tpp%older - enddo !tpp loop + enddo tpp_loop if(associated(currentPatch))then currentPatch => currentPatch%older @@ -2465,7 +2501,9 @@ subroutine fuse_patches( csite, bc_in ) currentPatch => null() endif !associated currentPatch - enddo ! currentPatch loop + enddo currentpatch_loop + + end do pftlabel_loop !---------------------------------------------------------------------! ! Is the number of patches larger than the maximum? ! @@ -2490,9 +2528,9 @@ subroutine fuse_patches( csite, bc_in ) iterate = 0 endif - enddo !do while nopatches>maxPatchesPerSite + enddo iterate_eq_1 ! iterate .eq. 1 ==> nopatches>maxPatchesPerSite - end do ! i_disttype loop + end do disttype_loop currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) @@ -2560,6 +2598,14 @@ subroutine fuse_2_patches(csite, dp, rp) call endrun(msg=errMsg(sourcefile, __LINE__)) endif + if ( hlm_use_nocomp .eq. itrue .and. rp%nocomp_pft_label .ne. dp%nocomp_pft_label) then + write(fates_log(),*) 'trying to fuse patches with different nocomp_pft_label values' + write(fates_log(),*) 'rp%nocomp_pft_label, dp%nocomp_pft_label',rp%nocomp_pft_label, dp%nocomp_pft_label + write(fates_log(),*) 'rp%area, dp%area',rp%area, dp%area + write(fates_log(),*) 'sum(rp%pft_agb_profile(:,:), sum(dp%pft_agb_profile(:,:)',sum(rp%pft_agb_profile(:,:)), sum(dp%pft_agb_profile(:,:)) + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + ! Weighted mean of the running means call rp%tveg24%FuseRMean(dp%tveg24,rp%area*inv_sum_area) call rp%tveg_lpa%FuseRMean(dp%tveg_lpa,rp%area*inv_sum_area) @@ -2696,6 +2742,7 @@ subroutine terminate_patches(currentSite) type(ed_patch_type), pointer :: currentPatch type(ed_patch_type), pointer :: olderPatch type(ed_patch_type), pointer :: youngerPatch + type(ed_patch_type), pointer :: patchpointer integer, parameter :: max_cycles = 10 ! After 10 loops through ! You should had fused integer :: count_cycles @@ -2708,22 +2755,46 @@ subroutine terminate_patches(currentSite) currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - - if(currentPatch%area <= min_patch_area)then + lessthan_min_patcharea: if(currentPatch%area <= min_patch_area)then - + nocomp_if: if (hlm_use_nocomp .eq. itrue) then + + gotfused = .false. + patchpointer => currentSite%youngest_patch + do while(associated(patchpointer)) + if ( .not.associated(currentPatch,patchpointer) .and. & + patchpointer%nocomp_pft_label .eq. currentPatch%nocomp_pft_label .and. & + patchpointer%anthro_disturbance_label .eq. currentPatch%anthro_disturbance_label .and. & + .not. gotfused) then + + call fuse_2_patches(currentSite, patchpointer, currentPatch) + + gotfused = .true. + else + patchpointer => patchpointer%older + endif + end do + + if ( .not. gotfused ) then + !! somehow didn't find a patch to fuse with. + write(fates_log(),*) 'Warning. small nocomp patch wasnt able to find another patch to fuse with.', & + currentPatch%nocomp_pft_label, currentPatch%anthro_disturbance_label + endif + + else + ! Even if the patch area is small, avoid fusing it into its neighbor ! if it is the youngest of all patches. We do this in attempts to maintain ! a discrete patch for very young patches ! However, if the patch to be fused is excessivlely small, then fuse ! at all costs. If it is not fused, it will make - if ( .not.associated(currentPatch,currentSite%youngest_patch) .or. & + notyoungest: if ( .not.associated(currentPatch,currentSite%youngest_patch) .or. & currentPatch%area <= min_patch_area_forced ) then gotfused = .false. - if(associated(currentPatch%older) )then + if_older_1: if(associated(currentPatch%older) )then if(debug) & write(fates_log(),*) 'fusing to older patch because this one is too small',& @@ -2735,7 +2806,7 @@ subroutine terminate_patches(currentSite) olderPatch => currentPatch%older - if (currentPatch%anthro_disturbance_label .eq. olderPatch%anthro_disturbance_label) then + distlabel_1: if (currentPatch%anthro_disturbance_label .eq. olderPatch%anthro_disturbance_label) then call fuse_2_patches(currentSite, olderPatch, currentPatch) @@ -2755,10 +2826,10 @@ subroutine terminate_patches(currentSite) call fuse_2_patches(currentSite, olderPatch, currentPatch) gotfused = .true. endif !countcycles - endif !distlabel - endif !older patch - - if( .not. gotfused .and. associated(currentPatch%younger) ) then + endif distlabel_1 + endif if_older_1 + + not_gotfused: if( .not. gotfused .and. associated(currentPatch%younger) ) then if(debug) & write(fates_log(),*) 'fusing to younger patch because oldest one is too small', & @@ -2766,7 +2837,7 @@ subroutine terminate_patches(currentSite) youngerPatch => currentPatch%younger - if (currentPatch%anthro_disturbance_label .eq. youngerPatch% anthro_disturbance_label) then + distlabel_2: if (currentPatch%anthro_disturbance_label .eq. youngerPatch% anthro_disturbance_label) then call fuse_2_patches(currentSite, youngerPatch, currentPatch) @@ -2780,10 +2851,12 @@ subroutine terminate_patches(currentSite) call fuse_2_patches(currentSite, youngerPatch, currentPatch) gotfused = .true. endif ! count cycles - endif ! anthro labels - endif ! has an older patch - endif ! is not the youngest patch - endif ! very small patch + endif distlabel_2 ! anthro labels + endif not_gotfused ! has an older patch + endif notyoungest ! is not the youngest patch + endif nocomp_if + endif lessthan_min_patcharea ! very small patch + ! It is possible that an incredibly small patch just fused into another incredibly ! small patch, resulting in an incredibly small patch. It is also possible that this ! resulting incredibly small patch is the oldest patch. If this was true than @@ -2791,7 +2864,7 @@ subroutine terminate_patches(currentSite) ! Think this is impossible? No, this really happens, especially when we have fires. ! So, we don't move forward until we have merged enough area into this thing. - if(currentPatch%area > min_patch_area_forced)then + if(currentPatch%area > min_patch_area_forced)then currentPatch => currentPatch%older count_cycles = 0 @@ -2815,7 +2888,7 @@ subroutine terminate_patches(currentSite) currentPatch => currentPatch%older count_cycles = 0 end if !count cycles - + enddo ! current patch loop !check area is not exceeded From 8c0cb2c7ff0b68469544b1bf71fad3c204b7ec97 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 7 Feb 2022 11:27:29 -0700 Subject: [PATCH 516/578] deleted nocomp bare-ground history var after confirming that it always adds up to 1-pftpatcharea --- main/FatesHistoryInterfaceMod.F90 | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index b9fb8d6879..73b75e856d 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -339,7 +339,6 @@ module FatesHistoryInterfaceMod integer :: ih_h2oveg_recruit_si integer :: ih_h2oveg_growturn_err_si integer :: ih_h2oveg_hydro_err_si - integer :: ih_nocomp_baregroundpatchfraction_si integer :: ih_site_cstatus_si integer :: ih_site_dstatus_si @@ -2253,12 +2252,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) end do - ! and also the bareground-labeled patch area in the event that we are in nocomp mode - if ( hlm_use_nocomp .eq. itrue .and. cpatch%nocomp_pft_label .eq. 0) then - this%hvars(ih_nocomp_baregroundpatchfraction_si)%r81d(io_si) = & - this%hvars(ih_nocomp_baregroundpatchfraction_si)%r81d(io_si) + cpatch%area * AREA_INV - endif - ! fractional area burnt [frac/day] -> [frac/sec] 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 / sec_per_day @@ -4567,12 +4560,6 @@ subroutine define_history_vars(this, initialize_variables) use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & index=ih_nocomp_pftpatchfraction_si_pft) - - call this%set_history_var(vname='FATES_NOCOMP_BAREGROUND_PATCHAREA', units='m2 m-2',& - long='total bare-ground patch area (nocomp-mode-only)', & - use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & - upfreq=1, ivar=ivar, initialize=initialize_variables, & - index=ih_nocomp_baregroundpatchfraction_si) endif nocomp_if ! patch age class variables From 439379f53ea1f60967b566fa70df775ea8899bb3 Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 7 Feb 2022 17:12:06 -0700 Subject: [PATCH 517/578] tried to be more consistent in naming of logic and loop blocks --- biogeochem/EDPatchDynamicsMod.F90 | 72 +++++++++++++++---------------- 1 file changed, 35 insertions(+), 37 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 941c98e889..90d23a186d 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -518,7 +518,7 @@ subroutine spawn_patches( currentSite, bc_in) do while(associated(currentPatch)) - cp_nocomp_matches_1: if ( hlm_use_nocomp .eq. ifalse .or. & + cp_nocomp_matches_1_if: if ( hlm_use_nocomp .eq. ifalse .or. & currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then if(currentPatch%disturbance_rate > (1.0_r8 + rsnbl_math_prec)) then @@ -567,7 +567,7 @@ subroutine spawn_patches( currentSite, bc_in) end if - end if cp_nocomp_matches_1 + end if cp_nocomp_matches_1_if currentPatch => currentPatch%older enddo ! end loop over patches. sum area disturbed for all patches. @@ -630,7 +630,7 @@ subroutine spawn_patches( currentSite, bc_in) currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) - cp_nocomp_matches_2: if ( hlm_use_nocomp .eq. ifalse .or. & + cp_nocomp_matches_2_if: if ( hlm_use_nocomp .eq. ifalse .or. & currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then ! This is the amount of patch area that is disturbed, and donated by the donor @@ -1131,7 +1131,7 @@ subroutine spawn_patches( currentSite, bc_in) currentPatch%disturbance_rates = 0._r8 currentPatch%fract_ldist_not_harvested = 0._r8 - end if cp_nocomp_matches_2 + end if cp_nocomp_matches_2_if currentPatch => currentPatch%younger enddo ! currentPatch patch loop. @@ -2339,7 +2339,7 @@ subroutine fuse_patches( csite, bc_in ) ! Keep doing this until nopatches <= maxPatchesPerSite ! !---------------------------------------------------------------------! - iterate_eq_1: do while(iterate == 1) + iterate_eq_1_loop: do while(iterate == 1) !---------------------------------------------------------------------! ! iterate over nocomp pft labels (if nocomp is false, then this isn't much of a loop) @@ -2368,15 +2368,15 @@ subroutine fuse_patches( csite, bc_in ) write(fates_log(),*) 'ED: issue with currentPatch' endif - both_associated: if(associated(tpp).and.associated(currentPatch))then + both_associated_if: if(associated(tpp).and.associated(currentPatch))then !--------------------------------------------------------------------! ! only fuse patches whose anthropogenic disturbance category matches ! ! that of the outer loop that we are in ! !--------------------------------------------------------------------! - anthro_dist_labels_match: if ( tpp%anthro_disturbance_label .eq. i_disttype .and. & + anthro_dist_labels_match_if: if ( tpp%anthro_disturbance_label .eq. i_disttype .and. & currentPatch%anthro_disturbance_label .eq. i_disttype) then - nocomp_pft_labels_match: if (hlm_use_nocomp .eq. ifalse .or. & + nocomp_pft_labels_match_if: if (hlm_use_nocomp .eq. ifalse .or. & (tpp%nocomp_pft_label .eq. i_pftlabel .and. & currentPatch%nocomp_pft_label .eq. i_pftlabel)) then @@ -2390,7 +2390,7 @@ subroutine fuse_patches( csite, bc_in ) !-------------------------------------------------------------------------------------------- fuse_flag = 1 - different_patches: if(currentPatch%patchno /= tpp%patchno) then !these should be the same patch + different_patches_if: if(currentPatch%patchno /= tpp%patchno) then !these should be the same patch !----------------------------------------------------------------------------------- ! check to see if both patches are older than the age at which we force them to fuse @@ -2426,7 +2426,7 @@ subroutine fuse_patches( csite, bc_in ) ! is there biomass in this category? !---------------------------------- - agbprof_gt_zero: if & + agbprof_gt_zero_if: if & (currentPatch%pft_agb_profile(ft,z) > 0.0_r8 .or. & tpp%pft_agb_profile(ft,z) > 0.0_r8)then @@ -2448,7 +2448,7 @@ subroutine fuse_patches( csite, bc_in ) fuse_flag = 0 !do not fuse - keep apart. endif - endif agbprof_gt_zero + endif agbprof_gt_zero_if enddo hgt_bin_loop enddo pft_loop endif patchfuse_min_biomass_if @@ -2460,7 +2460,7 @@ subroutine fuse_patches( csite, bc_in ) ! or both are older than forced fusion age ! !-------------------------------------------------------------------------! - fuseflagset: if(fuse_flag == 1)then + fuseflagset_if: if(fuse_flag == 1)then !-----------------------! ! fuse the two patches ! @@ -2485,13 +2485,11 @@ subroutine fuse_patches( csite, bc_in ) profiletol = ED_val_patch_fusion_tol - else - ! write(fates_log(),*) 'patches not fused' - endif fuseflagset - endif different_patches - endif nocomp_pft_labels_match - endif anthro_dist_labels_match - endif both_associated + endif fuseflagset_if + endif different_patches_if + endif nocomp_pft_labels_match_if + endif anthro_dist_labels_match_if + endif both_associated_if tpp => tpp%older enddo tpp_loop @@ -2528,7 +2526,7 @@ subroutine fuse_patches( csite, bc_in ) iterate = 0 endif - enddo iterate_eq_1 ! iterate .eq. 1 ==> nopatches>maxPatchesPerSite + enddo iterate_eq_1_loop ! iterate .eq. 1 ==> nopatches>maxPatchesPerSite end do disttype_loop @@ -2755,7 +2753,7 @@ subroutine terminate_patches(currentSite) currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - lessthan_min_patcharea: if(currentPatch%area <= min_patch_area)then + lessthan_min_patcharea_if: if(currentPatch%area <= min_patch_area)then nocomp_if: if (hlm_use_nocomp .eq. itrue) then @@ -2781,7 +2779,7 @@ subroutine terminate_patches(currentSite) currentPatch%nocomp_pft_label, currentPatch%anthro_disturbance_label endif - else + else nocomp_if ! Even if the patch area is small, avoid fusing it into its neighbor ! if it is the youngest of all patches. We do this in attempts to maintain @@ -2789,12 +2787,12 @@ subroutine terminate_patches(currentSite) ! However, if the patch to be fused is excessivlely small, then fuse ! at all costs. If it is not fused, it will make - notyoungest: if ( .not.associated(currentPatch,currentSite%youngest_patch) .or. & + notyoungest_if: if ( .not.associated(currentPatch,currentSite%youngest_patch) .or. & currentPatch%area <= min_patch_area_forced ) then gotfused = .false. - if_older_1: if(associated(currentPatch%older) )then + associated_older_if: if(associated(currentPatch%older) )then if(debug) & write(fates_log(),*) 'fusing to older patch because this one is too small',& @@ -2806,7 +2804,7 @@ subroutine terminate_patches(currentSite) olderPatch => currentPatch%older - distlabel_1: if (currentPatch%anthro_disturbance_label .eq. olderPatch%anthro_disturbance_label) then + distlabel_1_if: if (currentPatch%anthro_disturbance_label .eq. olderPatch%anthro_disturbance_label) then call fuse_2_patches(currentSite, olderPatch, currentPatch) @@ -2817,19 +2815,19 @@ subroutine terminate_patches(currentSite) ! patch. As mentioned earlier, we try not to fuse it. gotfused = .true. - else !anthro labels of two patches are not the same - if (count_cycles .gt. 0) then + else distlabel_1_if !i.e. anthro labels of two patches are not the same + countcycles_if: if (count_cycles .gt. 0) then ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its older sibling ! and then allow them to fuse together. currentPatch%anthro_disturbance_label = olderPatch%anthro_disturbance_label call fuse_2_patches(currentSite, olderPatch, currentPatch) gotfused = .true. - endif !countcycles - endif distlabel_1 - endif if_older_1 + endif countcycles_if + endif distlabel_1_if + endif associated_older_if - not_gotfused: if( .not. gotfused .and. associated(currentPatch%younger) ) then + not_gotfused_if: if( .not. gotfused .and. associated(currentPatch%younger) ) then if(debug) & write(fates_log(),*) 'fusing to younger patch because oldest one is too small', & @@ -2837,13 +2835,13 @@ subroutine terminate_patches(currentSite) youngerPatch => currentPatch%younger - distlabel_2: if (currentPatch%anthro_disturbance_label .eq. youngerPatch% anthro_disturbance_label) then + distlabel_2_if: if (currentPatch%anthro_disturbance_label .eq. youngerPatch% anthro_disturbance_label) then call fuse_2_patches(currentSite, youngerPatch, currentPatch) ! The fusion process has updated the "younger" pointer on currentPatch - else + else distlabel_2_if if (count_cycles .gt. 0) then ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling @@ -2851,11 +2849,11 @@ subroutine terminate_patches(currentSite) call fuse_2_patches(currentSite, youngerPatch, currentPatch) gotfused = .true. endif ! count cycles - endif distlabel_2 ! anthro labels - endif not_gotfused ! has an older patch - endif notyoungest ! is not the youngest patch + endif distlabel_2_if ! anthro labels + endif not_gotfused_if ! has an older patch + endif notyoungest_if ! is not the youngest patch endif nocomp_if - endif lessthan_min_patcharea ! very small patch + endif lessthan_min_patcharea_if ! very small patch ! It is possible that an incredibly small patch just fused into another incredibly ! small patch, resulting in an incredibly small patch. It is also possible that this From 882eedac3f3c82903913a78271df2be871441eb8 Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 9 Feb 2022 14:13:10 -0700 Subject: [PATCH 518/578] added nocomp-pft-resolved burn area output --- main/FatesHistoryInterfaceMod.F90 | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 73b75e856d..6609f986de 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -516,6 +516,7 @@ module FatesHistoryInterfaceMod integer :: ih_npp_si_pft integer :: ih_nocomp_pftpatchfraction_si_pft integer :: ih_nocomp_pftnpatches_si_pft + integer :: ih_nocomp_pftburnedarea_si_pft ! indices to (site x patch-age) variables integer :: ih_area_si_age @@ -2248,6 +2249,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) this%hvars(ih_nocomp_pftnpatches_si_pft)%r82d(io_si,i_pft) = & this%hvars(ih_nocomp_pftnpatches_si_pft)%r82d(io_si,i_pft) + 1._r8 + + this%hvars(ih_nocomp_pftburnedarea_si_pft)%r82d(io_si,i_pft) = & + this%hvars(ih_nocomp_pftburnedarea_si_pft)%r82d(io_si,i_pft) + & + cpatch%frac_burnt * cpatch%area * AREA_INV / sec_per_day endif end do @@ -4560,6 +4565,12 @@ subroutine define_history_vars(this, initialize_variables) use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, & index=ih_nocomp_pftpatchfraction_si_pft) + + call this%set_history_var(vname='FATES_NOCOMP_BURNEDAREA_PF', units='s-1', & + long='total burned area of PFT-labeled patch area (nocomp-mode-only)',& + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_nocomp_pftburnedarea_si_pft) endif nocomp_if ! patch age class variables From b705816cf79d873429bc61e50f18d7cfe334f2d5 Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 11 Feb 2022 11:35:56 -0700 Subject: [PATCH 519/578] added logic to prevent infiite loops in nocomp w/o fixed_biogeog, and catch them in other cases --- biogeochem/EDPatchDynamicsMod.F90 | 32 ++++++++++++++++++++++++++++--- 1 file changed, 29 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 90d23a186d..0753d5cc47 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -497,7 +497,7 @@ subroutine spawn_patches( currentSite, bc_in) if (hlm_use_nocomp .eq. itrue) then min_nocomp_pft = 0 - max_nocomp_pft = maxpft + max_nocomp_pft = numpft else min_nocomp_pft = fates_unset_int max_nocomp_pft = fates_unset_int @@ -2292,6 +2292,7 @@ subroutine fuse_patches( csite, bc_in ) integer :: i_pftlabel !nocomp pft iterator real(r8) :: primary_land_fraction_beforefusion,primary_land_fraction_afterfusion integer :: pftlabelmin, pftlabelmax + real(r8) :: maxpatches(n_anthro_disturbance_categories) ! !--------------------------------------------------------------------- @@ -2303,6 +2304,19 @@ subroutine fuse_patches( csite, bc_in ) primary_land_fraction_afterfusion = 0._r8 nopatches(1:n_anthro_disturbance_categories) = 0 + + if (hlm_use_nocomp.eq.itrue .and. hlm_use_fixed_biogeog .eq. ifalse) then + maxpatches(primaryforest) = max(maxPatchesPerSite_by_disttype(primaryforest), numpft) + maxpatches(secondaryforest) = maxPatchesPerSite - maxpatches(primaryforest) + if (maxPatchesPerSite .lt. maxpatches(primaryforest)) then + write(fates_log(),*) 'too many PFTs and not enough patches for nocomp w/o fixed biogeog' + write(fates_log(),*) 'maxPatchesPerSite,numpft',maxPatchesPerSite,numpft + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + else + maxpatches(:) = maxPatchesPerSite_by_disttype(:) + endif + currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) nopatches(currentPatch%anthro_disturbance_label) = & @@ -2318,7 +2332,7 @@ subroutine fuse_patches( csite, bc_in ) pftlabelmin = 0 if ( hlm_use_nocomp .eq. itrue ) then - pftlabelmax = maxpft + pftlabelmax = numpft else pftlabelmax = 0 endif @@ -2515,13 +2529,25 @@ subroutine fuse_patches( csite, bc_in ) currentPatch => currentPatch%older enddo - if(nopatches(i_disttype) > maxPatchesPerSite_by_disttype(i_disttype))then + if(nopatches(i_disttype) > maxpatches(i_disttype))then iterate = 1 profiletol = profiletol * patch_fusion_tolerance_relaxation_increment !---------------------------------------------------------------------! ! Making profile tolerance larger means that more fusion will happen ! !---------------------------------------------------------------------! + + ! its possible that there are too many categorical patch types and the tolerances + ! will never allow patch fusion to occur. In this case crash and let the user know. + ! the 100 is sort of a random number, in principle since profile tolerance is compared + ! against relative biomass size, it shoudnt ever get above 2 (which would mean fusing + ! a zero with a nonzero biomass in a given category) + if (profiletol .gt. 100._r8) then + write(fates_log(),*) 'profile tolerance is too big, this shouldnt happen.' + write(fates_log(),*) 'probably this means there are too many distinct categorical ' + write(fates_log(),*) 'patch types for the maximum number of patches' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif else iterate = 0 endif From fa364372709f7973a373a2518bea14117af2b8eb Mon Sep 17 00:00:00 2001 From: jkshuman Date: Tue, 15 Feb 2022 14:58:58 -0700 Subject: [PATCH 520/578] Update parameter_files/fates_params_default.cdl correcting taulvis per tableS1 Majaslami Bright 2019 --- parameter_files/fates_params_default.cdl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 1871f3af64..7a914fb573 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -1289,7 +1289,7 @@ data: fates_taulnir = 0.33, 0.32, 0.42, 0.33, 0.43, 0.43, 0.33, 0.43, 0.43, 0.4, 0.4, 0.4 ; - fates_taulvis = 0.06, 0.04, 0.04, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.05, + fates_taulvis = 0.06, 0.04, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.05, 0.05, 0.05 ; fates_tausnir = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, From ffb229140cd2a1f4bd0977cef8e26f2eba513f0f Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 16 Feb 2022 13:16:03 -0700 Subject: [PATCH 521/578] removing restart check and skipping check to output more diagnostics --- biogeochem/EDCohortDynamicsMod.F90 | 4 +++- biogeochem/EDPhysiologyMod.F90 | 6 +++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 5446c94dda..7032f1e7a1 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1995,6 +1995,8 @@ subroutine UpdateCohortBioPhysRates(currentCohort) ipft = currentCohort%pft + write(fates_log(),*) 'UpdateCohortBPRates: frac_leaf_aclass: ', sum(frac_leaf_aclass(1:nleafage))>nearzero + if(sum(frac_leaf_aclass(1:nleafage))>nearzero) then @@ -2013,7 +2015,7 @@ subroutine UpdateCohortBioPhysRates(currentCohort) currentCohort%kp25top = sum(param_derived%kp25top(ipft,1:nleafage) * & frac_leaf_aclass(1:nleafage)) - elseif (hlm_use_sp .eq. itrue .and. hlm_is_restart .eq. itrue) then + elseif (hlm_use_sp .eq. itrue) then currentCohort%vcmax25top = EDPftvarcon_inst%vcmax25top(ipft,1) currentCohort%jmax25top = param_derived%jmax25top(ipft,1) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index a0897ff34c..21c0161149 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1534,12 +1534,12 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l currentCohort%n, currentCohort%canopy_layer, & canopylai,currentCohort%vcmax25top ) - if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzero + !if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzero write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%treelai-check_treelai write(fates_log(),*) 'tree_lai inputs: ', currentCohort%pft, currentCohort%c_area, currentCohort%n, & currentCohort%canopy_layer, currentCohort%vcmax25top - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + ! call endrun(msg=errMsg(sourcefile, __LINE__)) + !end if ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area ! these mean that the canopy area does not exactly add up to the patch area, which causes chaos in From b5f2c45c82fe9c3950beab6034110033aa80f02c Mon Sep 17 00:00:00 2001 From: ckoven Date: Wed, 16 Feb 2022 13:29:28 -0700 Subject: [PATCH 522/578] updated logic slightly and added some documentation --- biogeochem/EDPatchDynamicsMod.F90 | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 0753d5cc47..537e74824d 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -508,6 +508,10 @@ subroutine spawn_patches( currentSite, bc_in) currentSite%disturbance_rates_primary_to_secondary(1:N_DIST_TYPES) = 0._r8 currentSite%disturbance_rates_secondary_to_secondary(1:N_DIST_TYPES) = 0._r8 + ! in the nocomp cases, since every patch has a PFT identity, it can only receive patch area from patches + ! that have the same identity. In order to allow this, we have this very high level loop over nocomp PFTs + ! and only do the disturbance for any patches that have that nocomp PFT identity. + ! If nocomp is not enabled, then this is not much of a loop, it only passes through once. nocomp_pft_loop: do i_nocomp_pft = min_nocomp_pft,max_nocomp_pft ! calculate area of disturbed land, in this timestep, by summing contributions from each existing patch. @@ -2305,12 +2309,16 @@ subroutine fuse_patches( csite, bc_in ) nopatches(1:n_anthro_disturbance_categories) = 0 - if (hlm_use_nocomp.eq.itrue .and. hlm_use_fixed_biogeog .eq. ifalse) then - maxpatches(primaryforest) = max(maxPatchesPerSite_by_disttype(primaryforest), numpft) + ! Its possible that, in nocomp modes, there are more categorically distinct patches than we allow as + ! primary patches in non-nocomp mode. So if this is the case, bump up the maximum number of primary patches + ! to let there be one for each type of nocomp PFT on the site. this is likely to lead to problems + ! if anthropogenic disturance is enabled. + if (hlm_use_nocomp.eq.itrue) then + maxpatches(primaryforest) = max(maxPatchesPerSite_by_disttype(primaryforest), sum(csite%use_this_pft)) maxpatches(secondaryforest) = maxPatchesPerSite - maxpatches(primaryforest) if (maxPatchesPerSite .lt. maxpatches(primaryforest)) then write(fates_log(),*) 'too many PFTs and not enough patches for nocomp w/o fixed biogeog' - write(fates_log(),*) 'maxPatchesPerSite,numpft',maxPatchesPerSite,numpft + write(fates_log(),*) 'maxPatchesPerSite,numpft',maxPatchesPerSite,numpft, sum(csite%use_this_pft) call endrun(msg=errMsg(sourcefile, __LINE__)) endif else From ccda175b37a6ae54f80c7bcc7027bb87a5080ff4 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 16 Feb 2022 15:55:48 -0700 Subject: [PATCH 523/578] reinstating check_treelai check --- biogeochem/EDPhysiologyMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 21c0161149..a0897ff34c 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1534,12 +1534,12 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l currentCohort%n, currentCohort%canopy_layer, & canopylai,currentCohort%vcmax25top ) - !if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzero + if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzero write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%treelai-check_treelai write(fates_log(),*) 'tree_lai inputs: ', currentCohort%pft, currentCohort%c_area, currentCohort%n, & currentCohort%canopy_layer, currentCohort%vcmax25top - ! call endrun(msg=errMsg(sourcefile, __LINE__)) - !end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area ! these mean that the canopy area does not exactly add up to the patch area, which causes chaos in From 7287d45be63df16d4c25c237e4d2ca15b1d460d5 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 16 Feb 2022 16:23:55 -0700 Subject: [PATCH 524/578] setting FDI to be nan to pass gnu ers --- main/EDInitMod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index bb83ffb668..11c8adf2e7 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -211,6 +211,7 @@ subroutine zero_site( site_in ) ! FIRE site_in%acc_ni = 0.0_r8 ! daily nesterov index accumulating over time. time unlimited theoretically. + site_in%FDI = nan site_in%NF = 0.0_r8 ! daily lightning strikes per km2 site_in%NF_successful = 0.0_r8 ! daily successful iginitions per km2 From f5e75ef615913c1a6dfe4451bc50c72a2ed2a922 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 16 Feb 2022 17:47:12 -0700 Subject: [PATCH 525/578] changing fdi init from nan to zero to pass intel sp mode baseline compare --- main/EDInitMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 11c8adf2e7..06bcd1858a 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -211,7 +211,7 @@ subroutine zero_site( site_in ) ! FIRE site_in%acc_ni = 0.0_r8 ! daily nesterov index accumulating over time. time unlimited theoretically. - site_in%FDI = nan + site_in%FDI = 0.0_r8 ! daily fire danger index (0-1) site_in%NF = 0.0_r8 ! daily lightning strikes per km2 site_in%NF_successful = 0.0_r8 ! daily successful iginitions per km2 From 3132918710c0b3af3048167a760a14d7245bf6b0 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 17 Feb 2022 15:35:32 -0800 Subject: [PATCH 526/578] removing temporary diagnostic output --- biogeochem/EDCohortDynamicsMod.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 7032f1e7a1..8364e5dae5 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1995,8 +1995,6 @@ subroutine UpdateCohortBioPhysRates(currentCohort) ipft = currentCohort%pft - write(fates_log(),*) 'UpdateCohortBPRates: frac_leaf_aclass: ', sum(frac_leaf_aclass(1:nleafage))>nearzero - if(sum(frac_leaf_aclass(1:nleafage))>nearzero) then From 553f3a2506a3a0842d8a433f492a770dc9b22301 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 16 Feb 2022 17:47:12 -0700 Subject: [PATCH 527/578] changing fdi init from nan to zero to pass intel sp mode baseline compare --- main/EDInitMod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 9c67689684..4812cc9daa 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -208,6 +208,7 @@ subroutine zero_site( site_in ) ! FIRE site_in%acc_ni = 0.0_r8 ! daily nesterov index accumulating over time. time unlimited theoretically. + site_in%FDI = 0.0_r8 ! daily fire danger index (0-1) site_in%NF = 0.0_r8 ! daily lightning strikes per km2 site_in%NF_successful = 0.0_r8 ! daily successful iginitions per km2 From 9927878b5f8599c9e1f4959e0888cfbc5e21c91a Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 16 Feb 2022 13:16:03 -0700 Subject: [PATCH 528/578] removing restart check and skipping check to output more diagnostics --- biogeochem/EDCohortDynamicsMod.F90 | 11 +++++++++++ biogeochem/EDPhysiologyMod.F90 | 6 +++--- 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index ecdb731621..bbeac3c4f9 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1971,6 +1971,10 @@ subroutine UpdateCohortBioPhysRates(currentCohort) ! We assume that leaf age does not effect the specific leaf area, so the mass ! fractions are applicable to these rates + ipft = currentCohort%pft + + write(fates_log(),*) 'UpdateCohortBPRates: frac_leaf_aclass: ', sum(frac_leaf_aclass(1:nleafage))>nearzero + if(sum(frac_leaf_aclass(1:nleafage))>nearzero) then ipft = currentCohort%pft @@ -1990,6 +1994,13 @@ subroutine UpdateCohortBioPhysRates(currentCohort) currentCohort%kp25top = sum(param_derived%kp25top(ipft,1:nleafage) * & frac_leaf_aclass(1:nleafage)) + elseif (hlm_use_sp .eq. itrue) then + + currentCohort%vcmax25top = EDPftvarcon_inst%vcmax25top(ipft,1) + currentCohort%jmax25top = param_derived%jmax25top(ipft,1) + currentCohort%tpu25top = param_derived%tpu25top(ipft,1) + currentCohort%kp25top = param_derived%kp25top(ipft,1) + else currentCohort%vcmax25top = 0._r8 diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index df16d855b6..9b28c5d8b4 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1534,12 +1534,12 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l currentCohort%n, currentCohort%canopy_layer, & canopylai,currentCohort%vcmax25top ) - if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzero + !if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzero write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%treelai-check_treelai write(fates_log(),*) 'tree_lai inputs: ', currentCohort%pft, currentCohort%c_area, currentCohort%n, & currentCohort%canopy_layer, currentCohort%vcmax25top - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + ! call endrun(msg=errMsg(sourcefile, __LINE__)) + !end if ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area ! these mean that the canopy area does not exactly add up to the patch area, which causes chaos in From 1069fdd68f3755da14efc874b856c403d88babb2 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 16 Feb 2022 15:55:48 -0700 Subject: [PATCH 529/578] reinstating check_treelai check --- biogeochem/EDPhysiologyMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 9b28c5d8b4..df16d855b6 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -1534,12 +1534,12 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l currentCohort%n, currentCohort%canopy_layer, & canopylai,currentCohort%vcmax25top ) - !if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzero + if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzero write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%treelai-check_treelai write(fates_log(),*) 'tree_lai inputs: ', currentCohort%pft, currentCohort%c_area, currentCohort%n, & currentCohort%canopy_layer, currentCohort%vcmax25top - ! call endrun(msg=errMsg(sourcefile, __LINE__)) - !end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area ! these mean that the canopy area does not exactly add up to the patch area, which causes chaos in From b78153defbbace110ee92eb48a966ff56d0b3d61 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 17 Feb 2022 15:35:32 -0800 Subject: [PATCH 530/578] removing temporary diagnostic output --- biogeochem/EDCohortDynamicsMod.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index bbeac3c4f9..d3dfd22f58 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1973,8 +1973,6 @@ subroutine UpdateCohortBioPhysRates(currentCohort) ipft = currentCohort%pft - write(fates_log(),*) 'UpdateCohortBPRates: frac_leaf_aclass: ', sum(frac_leaf_aclass(1:nleafage))>nearzero - if(sum(frac_leaf_aclass(1:nleafage))>nearzero) then ipft = currentCohort%pft From 48ab4505ca05f2565655ad110aa6b3bb114f1b07 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 18 Feb 2022 15:37:46 -0800 Subject: [PATCH 531/578] adding missing local variables --- biogeochem/EDCanopyStructureMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 1dfba3f6f5..aaed60cd31 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1504,7 +1504,6 @@ subroutine leaf_area_profile( currentSite ) real(r8) :: min_chite ! bottom of cohort canopy (m) real(r8) :: max_chite ! top of cohort canopy (m) real(r8) :: lai ! summed lai for checking m2 m-2 - real(r8) :: leaf_c ! leaf carbon [kg] !---------------------------------------------------------------------- @@ -2197,12 +2196,13 @@ subroutine UpdatePatchLAI(currentPatch, patch_lai) ! Arguments type(ed_patch_type),intent(inout), target :: currentPatch - real(r8), intent(out) :: patch_lai + real(r8), intent(inout) :: patch_lai ! Local Variables type(ed_cohort_type), pointer :: currentCohort integer :: cl ! Canopy layer index integer :: ft ! Plant functional type index + real(r8) :: leaf_c ! leaf carbon [kg] ! Zero out the patch-level canopy layer variables currentPatch%canopy_layer_tlai(:) = 0._r8 From 5beb7fbdc54d4d18225e492ae358796510505e81 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 18 Feb 2022 15:56:22 -0800 Subject: [PATCH 532/578] misded dlower_vai --- biogeochem/EDCanopyStructureMod.F90 | 3 +++ 1 file changed, 3 insertions(+) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index aaed60cd31..b3686ae047 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -2194,6 +2194,9 @@ subroutine UpdatePatchLAI(currentPatch, patch_lai) ! and related variables ! --------------------------------------------------------------------------------------------- + ! Uses + use EDtypesMod, only : dlower_vai + ! Arguments type(ed_patch_type),intent(inout), target :: currentPatch real(r8), intent(inout) :: patch_lai From d451203d51a559ad5697d2456461ad65ebd15ea0 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 18 Feb 2022 23:45:48 -0800 Subject: [PATCH 533/578] putting ncan and canopy_layer_tlai back outside of update call --- biogeochem/EDCanopyStructureMod.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index b3686ae047..3443f7bc06 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1522,6 +1522,8 @@ subroutine leaf_area_profile( currentSite ) ! calculate tree lai and sai. ! -------------------------------------------------------------------------------- + currentPatch%canopy_layer_tlai(:) = 0._r8 + currentPatch%ncan(:,:) = 0 currentPatch%nrad(:,:) = 0 patch_lai = 0._r8 currentPatch%tlai_profile(:,:,:) = 0._r8 @@ -2208,8 +2210,8 @@ subroutine UpdatePatchLAI(currentPatch, patch_lai) real(r8) :: leaf_c ! leaf carbon [kg] ! Zero out the patch-level canopy layer variables - currentPatch%canopy_layer_tlai(:) = 0._r8 - currentPatch%ncan(:,:) = 0 + !currentPatch%canopy_layer_tlai(:) = 0._r8 + !currentPatch%ncan(:,:) = 0 ! Calculate LAI of layers above. Because it is possible for some understory cohorts ! to be taller than cohorts in the top canopy layer, we must iterate through the From 355a9458a7c510f731a7df398b4373e2f9a7ca34 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Sat, 19 Feb 2022 23:03:36 -0700 Subject: [PATCH 534/578] adding canopy layer loop to fix #823 --- biogeochem/EDCanopyStructureMod.F90 | 14 ++++---------- 1 file changed, 4 insertions(+), 10 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 3443f7bc06..6392b1f448 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -2209,22 +2209,18 @@ subroutine UpdatePatchLAI(currentPatch, patch_lai) integer :: ft ! Plant functional type index real(r8) :: leaf_c ! leaf carbon [kg] - ! Zero out the patch-level canopy layer variables - !currentPatch%canopy_layer_tlai(:) = 0._r8 - !currentPatch%ncan(:,:) = 0 - ! Calculate LAI of layers above. Because it is possible for some understory cohorts ! to be taller than cohorts in the top canopy layer, we must iterate through the ! patch by canopy layer first. Given that canopy_layer_tlai is a patch level variable ! we could iterate through each cohort in any direction as long as we go down through ! the canopy layers. - !canopyloop: do cl = 1,nclmax + canopyloop: do cl = 1,nclmax currentCohort => currentPatch%tallest cohortloop: do while(associated(currentCohort)) ! Only update the current cohort tree lai if lai of the above layers have been calculated - !if (currentCohort%canopy_layer .eq. cl) then + if (currentCohort%canopy_layer .eq. cl) then cl = currentCohort%canopy_layer ft = currentCohort%pft leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) @@ -2256,13 +2252,11 @@ subroutine UpdatePatchLAI(currentPatch, patch_lai) ! Calculate the total patch lai patch_lai = patch_lai + currentCohort%lai - - !end if - + end if currentCohort => currentCohort%shorter end do cohortloop - !end do canopyloop + end do canopyloop end subroutine UpdatePatchLAI From 5d40c3e4f86b2dc9b304b14277397f508455835a Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 25 Feb 2022 17:04:53 -0800 Subject: [PATCH 535/578] adding vcmax25top init --- biogeochem/EDCohortDynamicsMod.F90 | 2 +- biogeochem/EDPhysiologyMod.F90 | 5 ++++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index d3dfd22f58..2807d03a7b 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1973,7 +1973,7 @@ subroutine UpdateCohortBioPhysRates(currentCohort) ipft = currentCohort%pft - if(sum(frac_leaf_aclass(1:nleafage))>nearzero) then + if(sum(frac_leaf_aclass(1:nleafage))>nearzero .and. hlm_use_sp .eq. ifalse) then ipft = currentCohort%pft diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index df16d855b6..1b3275f6e7 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -29,6 +29,7 @@ module EDPhysiologyMod use EDCohortDynamicsMod , only : zero_cohort use EDCohortDynamicsMod , only : create_cohort, sort_cohorts use EDCohortDynamicsMod , only : InitPRTObject + use EDCohortDynamicsMod , only : UpdateCohortBioPhysRates use FatesAllometryMod , only : tree_lai use FatesAllometryMod , only : tree_sai use FatesAllometryMod , only : leafc_from_treelai @@ -1520,9 +1521,11 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l ! ------------------------------------------ currentCohort%treelai = tlai canopylai(:) = 0._r8 - ! If we are initializing, the canopy layer has not been set yet, so just set to 1 if(init.eq.itrue)then + ! If we are initializing, the canopy layer has not been set yet, so just set to 1 currentCohort%canopy_layer = 1 + ! We need to get the vcmax25top + currentCohort%vcmax25top = EDPftvarcon_inst%vcmax25top(currentCohort%pft,1) endif leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) From 41cdf296d83671a9c9bf129f9ca532bc1ad50105 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 25 Feb 2022 17:06:11 -0800 Subject: [PATCH 536/578] removing unnecessary use statement --- biogeochem/EDPhysiologyMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 1b3275f6e7..4b5cfe3c50 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -29,7 +29,6 @@ module EDPhysiologyMod use EDCohortDynamicsMod , only : zero_cohort use EDCohortDynamicsMod , only : create_cohort, sort_cohorts use EDCohortDynamicsMod , only : InitPRTObject - use EDCohortDynamicsMod , only : UpdateCohortBioPhysRates use FatesAllometryMod , only : tree_lai use FatesAllometryMod , only : tree_sai use FatesAllometryMod , only : leafc_from_treelai From e061dddd1ae4406427fb549c8ef1429bd862a618 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 8 Mar 2022 13:59:50 -0700 Subject: [PATCH 537/578] bugfix - need to reassign currentcohort safely following its deallocation and termination during canopy structure --- biogeochem/EDCanopyStructureMod.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 90b7136444..6433567f6b 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -721,7 +721,13 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) ! put the litter from the terminated cohorts ! straight into the fragmenting pools call terminate_cohort(currentSite,currentPatch,currentCohort,bc_in) + ! Since this cohort will be removed from the list + ! lets temporarily remember the cohort that was taller than + ! current, because that cohort now points to the cohort that + ! is shorter + nextc => currentCohort%taller deallocate(currentCohort) + currentCohort => nextc else call carea_allom(currentCohort%dbh,currentCohort%n, & currentSite%spread,currentCohort%pft,currentCohort%c_area) From 1e444708d265da1712c8fb63529e1a97945a2bf6 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 8 Mar 2022 15:42:17 -0700 Subject: [PATCH 538/578] Fixing the terminate_cohort fix, Greg found a scenario where the previous fix breaks down --- biogeochem/EDCanopyStructureMod.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 6433567f6b..c12ec2edda 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -621,6 +621,8 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) currentCohort => currentPatch%tallest do while (associated(currentCohort)) + nextc => currentCohort%shorter + if(currentCohort%canopy_layer == i_lyr )then cc_loss = currentCohort%excl_weight @@ -721,13 +723,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) ! put the litter from the terminated cohorts ! straight into the fragmenting pools call terminate_cohort(currentSite,currentPatch,currentCohort,bc_in) - ! Since this cohort will be removed from the list - ! lets temporarily remember the cohort that was taller than - ! current, because that cohort now points to the cohort that - ! is shorter - nextc => currentCohort%taller deallocate(currentCohort) - currentCohort => nextc else call carea_allom(currentCohort%dbh,currentCohort%n, & currentSite%spread,currentCohort%pft,currentCohort%c_area) @@ -735,7 +731,11 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) endif !canopy layer = i_ly - currentCohort => currentCohort%shorter + ! We dont use our typical (point to smaller) + ! here, because, we may had deallocated the existing + ! currentCohort + + currentCohort => nextc enddo !currentCohort From 3a593ad8a438c994888a877daaae24543cd5f084 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 11 Mar 2022 11:15:47 -0800 Subject: [PATCH 539/578] remove the redundant calls in update_hlm_dynamics. See discussion in #823 and #821 --- biogeochem/EDCanopyStructureMod.F90 | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 58552ffa11..eb3ef5fbfd 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1936,21 +1936,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) currentCohort => currentPatch%shortest do while(associated(currentCohort)) - if (hlm_use_sp.eq.ifalse) then - ! make sure that allometries are correct - call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& - currentCohort%pft,currentCohort%c_area) - - currentCohort%treelai = tree_lai(currentCohort%prt%GetState(leaf_organ, all_carbon_elements), & - currentCohort%pft, currentCohort%c_area, currentCohort%n, & - currentCohort%canopy_layer, currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) - - currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & - currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai, currentCohort%treelai , & - currentCohort%vcmax25top,4) - endif - total_patch_leaf_stem_area = total_patch_leaf_stem_area + & (currentCohort%treelai + currentCohort%treesai) * currentCohort%c_area currentCohort => currentCohort%taller From d1a2bddf02bd4d602dd49704a628066e0e398ad8 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 11 Mar 2022 12:24:56 -0800 Subject: [PATCH 540/578] refactoring UpdatePatchLAI to break out the cohort lai updates to a separate subroutine --- biogeochem/EDCanopyStructureMod.F90 | 69 ++++++++++++++++++++--------- 1 file changed, 48 insertions(+), 21 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index eb3ef5fbfd..d354c13fc6 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -55,6 +55,8 @@ module EDCanopyStructureMod public :: canopy_summarization public :: update_hlm_dynamics public :: UpdateFatesAvgSnowDepth + public :: UpdatePatchLAI + public :: UpdateCohortLAI logical, parameter :: debug=.false. @@ -2206,27 +2208,10 @@ subroutine UpdatePatchLAI(currentPatch, patch_lai) if (currentCohort%canopy_layer .eq. cl) then cl = currentCohort%canopy_layer ft = currentCohort%pft - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - - ! Note that tree_lai has an internal check on the canopy - currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & - currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) - - if (hlm_use_sp .eq. ifalse) then - currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & - currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai, currentCohort%treelai , & - currentCohort%vcmax25top,4) - end if - - ! Update the cohort lai and sai - currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area - currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area - - ! Number of actual vegetation layers in this cohort's crown - currentCohort%nv = count((currentCohort%treelai+currentCohort%treesai) .gt. dlower_vai(:)) + 1 - + + ! Update the cohort level lai and related variables + call UpdateCohortLAI(currentCohort,currentPatch%canopy_layer_tlai,currentPatch%total_canopy_area) + ! Update the number of number of vegetation layers currentPatch%ncan(cl,ft) = max(currentPatch%ncan(cl,ft),currentCohort%NV) @@ -2242,7 +2227,49 @@ subroutine UpdatePatchLAI(currentPatch, patch_lai) end do canopyloop end subroutine UpdatePatchLAI + ! =============================================================================================== + + subroutine UpdateCohortLAI(currentCohort, canopy_layer_tlai, patcharea) + + ! We need to pass in the the patch as well, since this cohort might not yet + ! be inserted into the cohort list such as during create_cohort procedure + + ! patch area could be patch%total_canopy_area or patch%area depending on call + + + ! Uses + use EDtypesMod, only : dlower_vai + + ! Arguments + type(ed_cohort_type),intent(inout), target :: currentCohort + real(r8), intent(in) :: canopy_layer_tlai(nclmax) ! total leaf area index of each canopy layer + real(r8), intent(in) :: patcharea ! either patch%total_canopy_area or patch%area + + ! Obtain the leaf carbon + leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + + ! Note that tree_lai has an internal check on the canopy locatoin + currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & + currentCohort%n, currentCohort%canopy_layer, & + canopy_layer_tlai,currentCohort%vcmax25top ) + + if (hlm_use_sp .eq. ifalse) then + currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & + currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & + canopy_layer_tlai, currentCohort%treelai , & + currentCohort%vcmax25top,4) + end if + + ! Update the cohort lai and sai + currentCohort%lai = currentCohort%treelai *currentCohort%c_area/patcharea + currentCohort%sai = currentCohort%treesai *currentCohort%c_area/patcharea + + ! Number of actual vegetation layers in this cohort's crown + currentCohort%nv = count((currentCohort%treelai+currentCohort%treesai) .gt. dlower_vai(:)) + 1 + + end subroutine UpdateCohortLAI + ! =============================================================================================== function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) result(z) From 53d1312754c71f912aff35f30dbee10ff29a76e3 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 11 Mar 2022 14:31:23 -0800 Subject: [PATCH 541/578] forgot to remove the cl index inside the do loop --- biogeochem/EDCanopyStructureMod.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 58552ffa11..919e8c2290 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -2219,7 +2219,6 @@ subroutine UpdatePatchLAI(currentPatch, patch_lai) ! Only update the current cohort tree lai if lai of the above layers have been calculated if (currentCohort%canopy_layer .eq. cl) then - cl = currentCohort%canopy_layer ft = currentCohort%pft leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) From 1fdf747ee98a747ce9543a620d2162541dd63707 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 11 Mar 2022 15:02:26 -0800 Subject: [PATCH 542/578] fix missing local variable --- biogeochem/EDCanopyStructureMod.F90 | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 9539ab0b17..99cac36684 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -2192,7 +2192,6 @@ subroutine UpdatePatchLAI(currentPatch, patch_lai) type(ed_cohort_type), pointer :: currentCohort integer :: cl ! Canopy layer index integer :: ft ! Plant functional type index - real(r8) :: leaf_c ! leaf carbon [kg] ! Calculate LAI of layers above. Because it is possible for some understory cohorts ! to be taller than cohorts in the top canopy layer, we must iterate through the @@ -2230,11 +2229,7 @@ end subroutine UpdatePatchLAI subroutine UpdateCohortLAI(currentCohort, canopy_layer_tlai, patcharea) - ! We need to pass in the the patch as well, since this cohort might not yet - ! be inserted into the cohort list such as during create_cohort procedure - - ! patch area could be patch%total_canopy_area or patch%area depending on call - + ! Update LAI and related variables for a given cohort ! Uses use EDtypesMod, only : dlower_vai @@ -2244,6 +2239,8 @@ subroutine UpdateCohortLAI(currentCohort, canopy_layer_tlai, patcharea) real(r8), intent(in) :: canopy_layer_tlai(nclmax) ! total leaf area index of each canopy layer real(r8), intent(in) :: patcharea ! either patch%total_canopy_area or patch%area + ! Local variables + real(r8) :: leaf_c ! leaf carbon [kg] ! Obtain the leaf carbon leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) From 7cbf81706ba637aeb5e669d6ba64727396782204 Mon Sep 17 00:00:00 2001 From: Adrianna Foster Date: Wed, 16 Mar 2022 08:47:40 -0600 Subject: [PATCH 543/578] move frac_lai and frac_sai calculation outside do ib=1,hlm_numSWb loop --- biogeophys/EDSurfaceAlbedoMod.F90 | 38 ++++++++++++++++--------------- 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index f88c20dede..7799ee4333 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -142,7 +142,7 @@ subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 currentPatch%radiation_error = 0.0_r8 - + do ib = 1,hlm_numSWb bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) @@ -320,16 +320,18 @@ subroutine PatchNormanRadiation (currentPatch, & do iv = 1, currentPatch%nrad(L,ft) if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then currentPatch%canopy_mask(L,ft) = 1 - ! layer level reflectance qualities - do ib = 1,hlm_numSWb !vis, nir - if(currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv).gt.0.0_r8) then - frac_lai = currentPatch%elai_profile(L,ft,iv)/& - (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) - else - frac_lai = 1.0_r8 - endif - !frac_lai = 1.0_r8 ! make the same as previous codebase, in theory. - frac_sai = 1.0_r8 - frac_lai + + if(currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv).gt.0.0_r8) then + frac_lai = currentPatch%elai_profile(L,ft,iv)/& + (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) + else + frac_lai = 1.0_r8 + endif + !frac_lai = 1.0_r8 ! make the same as previous codebase, in theory. + frac_sai = 1.0_r8 - frac_lai + + ! layer level reflectance qualities + do ib = 1,hlm_numSWb !vis, nir rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) tau_layer(L,ft,iv,ib)=frac_lai*taul(ft,ib)+frac_sai*taus(ft,ib) @@ -340,7 +342,7 @@ subroutine PatchNormanRadiation (currentPatch, & tau_layer(L,ft,iv,ib)=tau_layer(L,ft,iv,ib)*(1.0_r8- currentPatch%fcansno) & + tau_snow(ib) * currentPatch%fcansno - ! fraction of incoming light absorbed by leaves or stems. + ! fraction of incoming light absorbed by leaves or stems. f_abs(L,ft,iv,ib) = 1.0_r8 - tau_layer(L,ft,iv,ib) - rho_layer(L,ft,iv,ib) ! the fraction of the vegetation absorbed light which is absorbed by leaves @@ -594,10 +596,10 @@ subroutine PatchNormanRadiation (currentPatch, & endif ! currentPatch%canopy_mask end do!ft end do!L - + ! Zero out the radiation error for the current patch before conducting the conservation check currentPatch%radiation_error = 0.0_r8 - + do ib = 1,hlm_numSWb Dif_dn(:,:,:) = 0.00_r8 Dif_up(:,:,:) = 0.00_r8 @@ -1011,7 +1013,7 @@ subroutine PatchNormanRadiation (currentPatch, & ! ignore the current patch radiation error if the veg-covered fraction of the patch is really small if ( (currentPatch%total_canopy_area / currentPatch%area) .gt. tolerance ) then - ! normalize rad error by the veg-covered fraction of the patch because that is + ! normalize rad error by the veg-covered fraction of the patch because that is ! the only part that this code applies to currentPatch%radiation_error = currentPatch%radiation_error + error & * currentPatch%total_canopy_area / currentPatch%area @@ -1242,11 +1244,11 @@ subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) end do !iv end do !FT end do !CL - - ! Convert normalized radiation error units from fraction of radiation to W/m2 + + ! Convert normalized radiation error units from fraction of radiation to W/m2 cpatch%radiation_error = cpatch%radiation_error * (bc_in(s)%solad_parb(ifp,ipar) + & bc_in(s)%solai_parb(ifp,ipar)) - + ! output the actual PAR profiles through the canopy for diagnostic purposes do CL = 1, cpatch%NCL_p do FT = 1,numpft From 423dde81bd7b8387fc7a0719de048765eb01002a Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 18 Mar 2022 09:56:25 -0700 Subject: [PATCH 544/578] added logo to front page. We never added the logo that we had decided on a while ago to our GitHub repository, so here it is. --- README.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index e3886bc268..62456d72e4 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,5 @@ -# FATES + +![FATES_logo](https://user-images.githubusercontent.com/10852790/159047944-ddf920d0-62f7-45a4-ad58-bcee2daada19.png) ------------------------------ [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.3825473.svg)](https://doi.org/10.5281/zenodo.3825473) From 44deaf2a9c88183cf7012e56c91b8e8adc351ff7 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 18 Mar 2022 10:17:15 -0700 Subject: [PATCH 545/578] updating readme with user's guide and removing reference to wiki --- README.md | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index 62456d72e4..36580e66f0 100644 --- a/README.md +++ b/README.md @@ -5,15 +5,19 @@ 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. -For more information on the FATES model, see our [wiki](https://github.com/NGEET/fates/wiki) and [technical documentation](https://fates-docs.readthedocs.io/en/latest/index.html). +For more information on the FATES model, see our [User's Guide](https://fates-users-guide.readthedocs.io/en/latest/) and [technical documentation](https://fates-docs.readthedocs.io/en/latest/index.html). ## Important Guides: ------------------------------ +[User's Guide](https://fates-users-guide.readthedocs.io/en/latest/) + [How to Contribute](https://github.com/NGEET/fates/blob/master/CONTRIBUTING.md) -[List of Unsupported or Broken Features](https://github.com/NGEET/fates/wiki/Current-Unsupported-or-Broken-Features) +[Table of FATES and Host Land Model API compatability](https://fates-users-guide.readthedocs.io/en/latest/user/Table-of-FATES-API-and-HLM-STATUS.html) + +[List of Unsupported or Broken Features](https://fates-users-guide.readthedocs.io/en/latest/user/Current-Unsupported-or-Broken-Features.html) [Code of Conduct](https://github.com/NGEET/fates/blob/master/CODE_OF_CONDUCT.md) @@ -28,8 +32,6 @@ FATES has support to be run via the Energy Exascale Earth System Model (E3SM), t https://github.com/E3SM-Project/E3SM https://github.com/ESCOMP/cesm -https://github.com/ESCOMP/ctsm - ## Important Note About Host-Models and Compatible Branches: ------------------------------------------------------------ From 12516b51fa0833c113e040c7c98d3aac29d12c80 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 21 Mar 2022 11:21:42 -0700 Subject: [PATCH 546/578] adding logo and updating readme --- .github/images/fates_logo.png | Bin 0 -> 56551 bytes README.md | 2 +- 2 files changed, 1 insertion(+), 1 deletion(-) create mode 100644 .github/images/fates_logo.png diff --git a/.github/images/fates_logo.png b/.github/images/fates_logo.png new file mode 100644 index 0000000000000000000000000000000000000000..91907d7545fda878f875bae295f37ab53b390416 GIT binary patch literal 56551 zcmc$Gg;!Kx)b;=Z64EK@C@{1F(ozl}9fByG3eqJVigbw#AWDvegp_o5hk$^9bhmWF zcdozpegB1zmx<8{nzDiQQIoydNx zPxcB+!`pA%;}NWfX*QBf{vQ2Z-DkOcnJg*yktM$;LV$n6V8>f>U^u(@pubn`_s9Al z(=%t>{vrSWek}E!)2bESZXuB}syai|NNyU(@-gAi*L=&%tclAycJ7Ff zkfAW>4inusV<&AgPrb2LF+<;{{Veq`c(u{Yc^8gWHkM+8JB7qI-cGgk(xcQeSWh)L zV&|M_908K7n1PE!Hl|pJU-6~&Bs#;PArX!Ks>qB%Z$W>aq)h@ntV2C(uQUGR&p>Ge zB>b)RvtB(6?VL2Gi|qPJF8&f}?FZfFvkZ zJsb6^SJHSzD2%AZ=H6i`{^+NMAt9QsvCDZ z8D8ke$jFWA36}&Jq&XaV{R0~-g$FTPUv}1Qej4DA##ljXHpa&v#H18GoPA{^N~$pr zK0@RbXR=@+W#&mG&xb-o$Xa5Np$O}TxVd?IoAb;q9-rB@b4@vZ*H%b3r^@#BuIZso00T14wo?* zf>u0UB&w}a0TrVEPg+xsPKRx>q`xxA7ZJc~5o3@=+O$5z>i&^$@>BkbJAU2gKTqf;94&Vkl=GB)!7R6ttOqI-FHQ2*M4rC~YWz z|BqOyH?sL}aiUD_!G$2n7w#v$66;rFgS$b0eZ8Obl>V_OX%#gVxc_Z-z))L;JeSpM zJ`kM_l3zT9NRfa3tsHVu21LlBCE|yD3C9eo#g7G*eN-o#=!16FVg=Wa$J) zws(>*2A5ZI_2QlrTXJ;2K+2%a%@(Q)1gA1dNc$k^MDSZq1;}nDPagd-Bz|tIo+}U# zClcRy#R0@mgrJQ+VD7@SD=BH5?D+!u7bE(lf-MGf8Ty#DVFE%&F_ai&~JNLd0n zSCJW0(7o!f1GYs=$?>Gqt@f+?N43Na{)2)@ZeD!_Huw)n^=DwgA!nP*cqxk)1qOez z($+OkYgtXfOP@lQ1vlfO$SoxQxW5`}cd2iOPypjlUDT-M1|%{j5P1mgVecC7?(iFU z6&W78^kr6!SU{qCRs7ULUyaqyGmQwcnpgVTE!-lFxF~-b1gm0>PgEBCP#D{=he}LanBI@-<5UoE z^iUx3WkI=Q%JHd;n~K)XDp6_lIFmnvJmxXL8V$M98>1)pmbdyR913zWEqMONAurC4 zn}KJET0t&aRj{bPh<`=pPhCfwid526h#c~9yOVvtu;F#_o zL9$4V206!&+@};_@PfD-JY0 zUW>2uGlDTcGO=#lDHXg2@0QS)WeJ{ZzGDfm&8?Fu`hE;!Yg;wH-?#q~m?v!O@~Jd=mO?Ia zV?d$|po+vE9eCtY-;k=qc~?w11`)O%)w&#)u?QaBauXrM!P?+r0h zrrNrT0$Y3RLjR#WFPVmJaa&->GK;k?eWkR6>bQFv=}s1jhA0#;mq%0OnX(h_zxqX+?%AP1T-8NYKr}l{gyWJ4Uya@wPAwVh*8{m>w zL55{vsaNRV@>$unVz86+M~t*Tu9iA;8T&}87#Fs+^_%P)*DyeyDgx+Mu4%V|b(gUi zL;B1LlE^ZHDN^e+{11#%W#%|+H6$AAkW@0Cu|~8NQ9ao@_mi@lM<-IQKnWX&|4@*& z4k79qC_#S$z92&_RsRu-H;zB2zH<|<GySm}Ez(>9pzvUlQ|7m> zsXO6w;tVCWEDS{x(CXEB%;dc1D1e07#>0m&V%|wv*lZ9a0otP!7dS6xrJM$xT_1 z#8g3bYB&s+@bJU7=#VtC4^T5~PJF*4XDW~_l5Ef$=s740Ndn3q;3B#q?_2Ns;;{MX zVp@BX?Z2rx-tMJ|QUA?9yFe!mSEK^9W)KBKyjCS+1@6E%4=^Ur1b3QC>4meAm>-z@o_F1t0B?cpkmVj?_oGNS`#cbwYwVF zR_CQ9J_KkGPUaTPqLnK!#$z`Oct_$}ZXV>~^eEN;Q4yA`|AWgRCB{Fs1+loaq=WfT z4i(tgl6LY0Isa(gap?@G-gv@$_>a4}Q6d*@0B*kMPyWt5L|%+@8-#qG|sm5c|V$_?igqH&lhc)6S$}3*pO&eV=xLdY~!-!mD zgg|WhL;qknQh*%C1uzrPF2nLn59rAuj>_Mg`hT zPOj(1(#e)PyCjR*=1$FQEC)nTXn{IaF}4A0ofPN{L{k1gy!aK9(zhWhQr^F$|LCs4 zy$tceT$QqOFINDq{lG0~t`dOUFZC>k4dlB+-p~7VFTN>Ai7C*^`8_QNMVvEaj2QhI z_pk4Ae;UZ=hR6%6J_xV$lB?FGo2gVmwo*}}^9P{{EVjZh<(fehtvv8-@@UkhX2*fM zXe2O%6#zIwsdAl4R4DLe8OS*5C#l<_no-|*kODy%$q0hhY-FXya@E26M_4x4ou*Jz zVG^p;!JAtKkst__JV8`jU}(gPJ^Lan15v>K9Ej(mD)%BklZ|v^MTC@qFpB8`WZ%kZ zpj|zMLXldaVB<9?xcN0vs09o;D>_BU> z(5aST$IudTou8rl%BIt-LhqfWJZbu^SWT?crX#<|$-c00z0<7;Vu)v?q^6xXQ*gDw ztf~F1-!(zHe`!?ZD}F9qC+xG!m^3mGAnBr}X}W^jtsG`W!IGV%<#}*}Vm|IaoY-JS z_ky;_DgES=;J%j=b_u6%tJvV5+heX}Rl6A)7I}hG4@op$0>!I7z8*4YlEKU1HN7RU zS`g4nmKwwR2t+lvc9pGtubgG+|H>3C66Fi61v%WgZCym3Lo=+hn8|?4ff9HUgi6(WF(Q_axFVV{nigoL zDQztaZ$)y_szj(8m$?_@?z5H=|uXi3v*2%WM)9P441D7i7Pf7N1FqhWCp0=U!yH5qBY0A=F}ks1ES zF?yJf!=7Um+^+l9>X`;So()7laomK*h(Wh0bAftca_2@#+*3V7 zEc|tm0<#a$filYAo)a5*)#Jnl&wi{>#D4kc(Se@eZSWRR`kE(;a=>~)d_ITzb;Z>D0A}g&e0782RKuIPMbW4Qc zBWgU^U&gW9e2AK=?<2B!f_8w_K^06BG_albmkU#RV@}{lG?Su^XSX6Io$&K z1pMcXQ;;^ji7Sgp2-;=LYk*axrERV7@^_(kQ-OT$B!OCLs3T|CZ;nh~bTAoclnZ$e z^v7pyh+#tuL&o`Zp_D-PxN8kEPPmf-LA)kiWtghDAh`B#0zzBkNwhZCuFfZYF_W_i zpo!ztMNmozi1G;Iy>{Ld8bwx(XQk3^x7eG2>|cRHME(Hcok+(2xIpU7ZmT+97ZeGY z8RN+f*37Kl_(a?jcKfvbU5Q@nZA;fS8^cobnDBC(vVa)L| z3LOoy)c_03`FWx5nn$*Q0mbtZ#3t?ET^0Tq5m43^)j6^V4GurDPEnF%Dk5(Q()u-j z)6DdE;~22b7lLqvUI$eW{#|4A$+`$J3;g&uzyabwRr3{NFXzug=%=xF{{28GO&Hp$>77C_3?4oyTKW(@-`56*#N+YdRzO_G1tPG{>Y%}z-TLP zE^pP9zUs-MGBCww+G>$f1vhMDwJj*+LcWw!N1$N5{WreINVH-L#)tf_^97hLsj&nN zSlIJ4oGEOQ!8RbQK-i3-;Krgl_75GxP|dD`P#*kT)5(;{$k)Yp|IM6kkIz4_j*WkU zu(?&b#uLz~pqv`c)BXCV0T!tW=w32n5nrDbAk$qz!vQ%bsTCWDCjJ7|`2t#fynN-z z6I(kS_@gpyCLY19Y$UtVg+}%_gGVDReyxij%k2TZ$OF>_wh4$AGS|3_Juv#e1@1c@ zRgsmh6};{2;+p((>lY|}zUT*}A{ZcgaF+Wd5`6xnfA2cG=4bAffZ*P@SPX4P@<6f$ zntXYD2k6Vp_jYcEQ|?k9?!=#214G;V_}54Bih?*nwh^ z{~Id;Vqzf%NVvtPx5H!;F4R)yWU<8i^U5ypR{+PlYk?8(1$?Cp{YYMpGx4809au$U z_#rN%4nU4rJr001jXWnAi|yupUb9K0(-!;)O>PC|N+@YlugJ5uj=?bGzS&We>`Ply zHmAFQpY;OMN}+EI{kuZmuy4NHDO+AevIYu0>P}W!#i!cA$WAMps4cWh!Wimh;rSUm&blNnBCcA>8CF_IJBU%^K;ZK)5pFz4BDX-%oIdJs3`ZtH_QrX6XkAhlh=`4_b)Kt~ zMMszbm9Wgt9*$4Tpd8!Ft7rrS<2zj-QyQx`u(pWAP_dR*ed`9}K|X+I7Fa+O3hRGe zz~lMf(=r(WIkr5k$x+JYe9#sCm$mRoy^zvzfYbJi>9WB4-8cVTSfc)fxZye`g<6X6 z3gGJgaQP4!1er74-7hQmmw~*g^5$C>Ct?fP$a6+5b;^JE=}J0s)mjd_eGCy5T4ag2A z6Zwo7-gd}Q1m(Dj5=(SYhPEWke45t}y=iL7sXMR1OZ-KS}SE`@C z>zar&3pLahsw3aO02+!*Eeb+cUpBix7|*W3ge&$#NS0+wVf!ynuwuSI zFAQKeYeR-=a5^Fd+AAZ`ZxW&KeGiN#0U7hhby6o1JhF6;8vP5z%4g!of+3$rdlZoi z89Hv*3Vidg;4$owVof2p(C|Bq>PT}$iz7w%?g8Qu^;D(tuL0)~-QuYRj_}(fwnPgB4^I*N;4(;in z>0K(`5M>BQ?mf+-bO=Di>_(h1E`O6n|AMgMBPN8RH-tjS68lPPjI+25NfIGMQouX` zyih2GSWqTygGtcuI806tKr?JUFnC5tm$OJ;d^%U*RK`$=dn8B46tuTzTqeGIq7*2a=gbY73^ef0QKw-wBL_6g?mNmL=jtvi*i z4$ruejqw>0bsMOQ_Y_jMoo;Ky;N4_o;cK=0XW=O6oZUW0a%nweTKD$E7d~RsaU4$2)FPZ`o?6Cp-@Ul z`Ic5H5(+<*LY-rIPDMSID74VN!`ONW^X4GSnGJJ4(v-qRX(7_=oGfukw4^FDIV_#L zB1#5rn+H-I!6s*J`vi~KwHG-=G&L}h;}-t%ZnStG45uhFG^b*BP#$+lCEJ@T!>;|N zWwJ#gRZ_=c#x2jidQZ#~nQb^bV?L~z$;K@lZ;*&U)e;l=LYp^WHKLRNuwk5TyTPEMjpzgp_c%Cl!OhLHX5rO3zliRcUM*y00VJ=__ z)M*aA_rr-6iDGla+oa&L4;bxPZQ>}i7sTJ~CI8^Y5cQNy9F#RbAx=BVibp6x$u1== zQcdl->5mqia)mS{rp$ZA%qA477OFuU(usAurP@r_E(CE2;pXfn?P`e{v+cj#;9AH} z_4GZt!3e+F)G-`fhL2x-1oAo4;%x6TrN4i)iX;H_RsdJNUy6F1htX=}fwjBO`J89S zNxIhMZ-khXLRJs+klp6YwL4v}ghuXGhf#GsH$x$dR0F%cPuw>SFzbR2IdqaN*m8l1 zHq^4T+qsQx2`}!ui~IJ-UH<+>Q2w37=RM{qM@-pqIg=e_+TGWaD(r^ZJ2>hI%`11| zxPTsg4zO)16pHGW2$`C2A0wds66P?|e^(nmPc0pw`R)BpF`W>yr@8*OMB>ZtOy#X3 z7Y%_CRqv5u{!AAi%z|n#|L(`*EpbhY$v0T2T!GrqT`ua-;a{qEmJG;Et zwp*XTZ z8_1|1V;+a`jkPzct7fR=Xs*Ad&twEy;_k)gv#z*lhfw?6qeO}UcCfigKo7-3Yhz}D zU~`IB@L9*hc4c|i@M+IBPb&wMe`P?`1lY<1;|8cw+ur17 z2ZzHKpc17HOi*9B|D4~p*C!!IUlCH$f1BMJ`1e1NYluPz7s9vUAqX>Y3zdHpw610( zpeu|ty`czgbjZ;<7#}2otz85jSP=EPrrya66rhlQJv~{GZ-<5?YAP4P5E-EJHfU!B z2>Kte!NCCmC_m)>aiKy#3eA#Qu78s+uT7 zW~JSTsL@@jO4P#D;S+31IR=fdD+Up^f z`r>P|pQ(X2J;|z70W`BsEoB5LwtSIAbAd2>A8K5$Aq%I&K&=-9N4VZ`Q6u_OPI&{? zbN5p6Z0NAyCNIA?1B3IUg6%H1?%KP995D5G0~RS-WOtg@g_+cwvRL+m0UuK4?p)2a zf)U-_bUXtE~z!h?J$G!!v(6K8;iKnV0 zJ7Y2I>zcO#+w+EnZ+`hRb@=`>3R^aqHa_!L+A7Wl;6O^&V`PVq<-{?3suL3Y1S_?>F9Uslq|r^Y2?pZF=nUSjA|EVi~H@bX4}$hQayb% z*47*tw@)S$SPkZ6S$!!Qgq}wnPs?0AwVzwI*V~!)wwT*6(kq`AxLWs{38mXB+%c-! zjOEqNuRLTb(7y;Zu;OKHX`e=6cU+4fy_||BcssRA_momy@K~GZ4#(O~4MU`>FLLla zu3>!SOHf!y1PHH!XaC`nE$anlR%>M0w;Pl{xywhk-fQnVuJqTrP0hKz^E>d|$uqiY zEB;N{aK82Gdka&%8A8y^O|kvfxM30_d+P`r?%!T#YX{3E`))gf!G406#cm z3C~h%s}Dvy5|(vJ3-vuF2VBR#yf(A{BYNLzz4v#zxi1ab@2Pgo+q2R>USnf(>g~v@~)#_6rkG50{0~q$S@gR3y7X+c->FAVCyAm*4t%;d7cN6jgKD6z<9iA zJQuxGc+!x7Wi&s#9y?A zH!#|{)lhvCc2utwTGw!P5)lpTNK?{R_2Px4?Cx4z9inPc+^%NnFf^J|&t&aO8;#*o zo5#Ql{qohIzib63$sGke4VMiG%e-DnW?i(}AfR|VO4grJj<%J*Cbt^oV^8DMdo46I zMXS90U@P))*v|)k?&PfQH!x}tRc$Q?O+ps&0YRC*nTD6tKkvT4xd;Oe(yg4Odu*Grg#-hlqBf#R=2 zsv&;)R2{cnRf2N-o4@D1V)YMCr0l`CfLaNgO4lsw9^Fqjfzea$-pfNgbDb3GTly;5 zHlWvSzdd=QJ8_xl9;gZ~&lO#T%YwZHXHM7LCJnuIe(o5}dyV`+P}8&pIv7qHMG<>Z z&CQurV8XTyoCvQzF1RnYzTOmbJ8gBP^jL9xT?(t9O8vCAn>lTg&n*%KSEI<5BT%=D zoUdo;V3qK5sH6`lroWiNP3>&d@hmPhI=fw-TJ5O##OR|?#6|7>y)by?e!QK2-F$2Q zKun)>9aQ6-;4wi+oslV;pF)LR5;-<8mQuK|koPu$XN3Yg`2E>}(BZLI$L&dvjPCNx zNVXfIickEBG&pE_y4LQe+ggZTpZ#En7I*!&uU1gM{Ykgh5*BYO%}zk__SFsl?|-)m z#!QZJbfRw&7gKYe4t78w@65!t3;1=J#C_ zn`sZ?cn`V1TbyE~JW+7Z0$B9L%ZG-y^@DCH%^>aFNpZ|XK-@|hxsz^lO9lbIPO44$ z>xHS#>v0;k4_`{q(>xE77Qs>sG7aHPIsrunAveO=1heQjr4yV6H4leHG*RNyg>-yq99@MYB zHlf|azx(Zl&rKz2SrXYr^a{sbeAiaO^_AHRx?c;inV+)=*8joeObgfp`AqSVph(mL zo`&Tw<;f-8l2E?Ix6Q*as1FeGrv5`W9MS_spkSuf&(_hn=!x?lql=~rH_6LF3nf)g zP927n-Rh-|_}STD7Wd8HuLS-TwKr!(iaooXr?nh#=;G@|ii-ta02>LvTCK0Rppj^(B*w*wpA%zyW|re7ycU^j ztrTT;KR!T6j>=3po_}|jlPXo-V~s?jew`$qS0tR;unsSiWkuu1*-sD_mfRm*g(Oan z^LWoUD?V~GvyAQtuLqatv0c+U8%cppq%qgCSP$g+ay2vR^Na*M%IsbOVB#GMxmAV> z>E6G}#gr#zMZTybw62WYBz`%s9wc(w6?!u;O~FK8%&qDFW|Za{XdfUhY*st=!-qL2 z4R)PyoPIQ0rPCWZ0tHqD`xOXf@6nMhkk}A3*>OvRqKhdH%x!&k%HL1uzkK~dq5Wg+ z9j(RG$6RVZot;Erv(*;a8Xm(Y-cH(k!-|!j(koRFx=PdE4_`w))!K z_1$xwvTBwj$*IEwrqOH3KBi^v%O%RPih6M~;p2!h*WdAJilJwvP=dem`Be(c2j9|l zSnQkNGuhsP+3DEk~x-lr9DpxQuQHn9=2sPc9<9 z@vZv0?R~db%v@cm%_RxcnGhPWt!uE*dHOmf7CIX0gbE#&Y655N@7;sj##@v<+J2X^ zm$-Rx%yb>sa5||sHg!cNQEoYl9w1&KGF|;BjY{E?A=HRK$&vPjqYum<*c2LP2t>@2 zpH_BzG3vx6cf5V8wCmD9Twm*4Y2Wog+;uc~E8DJh;^RUr5$9)*eO8C`Lvsl`jwBy` zD^~g)-Y?F7(BDmOa?|;TvAfGcugJjPi?P8^dz{>;-sCHt zptmX;1%BN1w4XJe&ram4^6B$&W-2xE{tgfMM>HIa(l#;JU6I$8^gNLj4HT)JsZLut zmKgPA7Z%?2`NWc%$2c^%m6#1w16az{qJ{_KW0Nc)6CaD{&nuS+9kL?v6;%zF+81P>Z@_5 zeodrBH(GM1PQhS1keAy6Q6|V2W>{YPAqSj^h$^}&7Sf9=VFCx7zo^(8_4e8FyQ+Hd z5!D`jzUIF^ye2r2+=ts4IypW+de7auw;3uKjvKPvdOwUHU1TR;W?Sl_V=-qClb)uQ z0$`YlZI`3?)XtYr=#pPz5nm+uSc`e}`OItqJNaGYvTVinLqu3V3JWWtf1}vBYOCAu z#4nE=HY;{X71Xku!_CPf5`OXL=Ctp%=0PfNdmgTRYw^?Y-JFe?w`|MOz2r)(r~A13 zbF>tM`5}#D#HJjgOZzKM{qAp4uU7odjtj1L^-{lI^|TH(^t{l}X2s#od{Mrxvh9h= zw9Qe^(Zn#cvd{PW@YJwVfN(W~vV$$l0FVKtoY9UQw-t_4mx&bb&6q;Tqn5&%eZBKn ze{P71Bzf8JnvMn*3EyUK{<%wbF`sGufTFL-m${o>KV4` zp5SyVm(+dS{Blj`?X#ZVaeLz;X-@_kSJ^@Xq=1l8j<(3O9M*S?#aek?*`EDl*N1Mz z4AQBYub6w1{63Xm5@x7jXlRHLX zY?u#)#nf-W+&6P-{sxvcGiolRs=w^N zQco)`=gbL&X(XPWQD_+mb2KG?*>Eoc-?6|*=KF7;5%VOEY&@-os)E#5%qFkzAokJ9 zU66Nvc0F!tS6M}q`;)1kd;}{xj+B!qZvQ~vWUQhcsCT~`^p*Phi8x>=J%f{M6FTk0 zG@>91=PmC1Ar0mI%P8J(1MpJ~^GH*x{$5;62AYsm(a-tQ4tPh&HT35nea%hdjht{q zV(255`{`2(4IMFO&eSB^l^SxJqm6VUKMpw~cvNRFkAp>aRxbC${oGHsDr)Lo4o5~_ zh?5!>B~e|BP>qxklQn_a==Nv3Vh1m9sba^FP#6M!2>Lyt`eFjSfaqSahNY)dC(CteCKjh2zgM#Qh1Dq4eg(Yy zQH8*#{FdBtwI?5JMpuoT8;;VyQcJ77r z%VyVIDT${$9_f^A74Z!bzge)Jdl%hLp8%YjS$I@)n2tw5Nw3GeLk%?>#+lXsQ1YZ- zQGCRe0A@TnRxi2a+>?-$Sg!U++jN?ywvFXxDwAB-uDDC*%*Be)wnxVDu$#|9d}-ac zyXtJ^97&SFu%9AbGCV za5>+4v#pJZt9g9MnF;pG$DQ&Gj{TSY>ag1VlhM6|T|-|Y-yt_FBBBJf-a9kC>vA^F zJ#T_iJLi!VnV!nK5gD!JU5rRCUB7}y)1F;xY;Av$XgcW^3&sU4rcBs?2_@lo;y<~w`}3MDdE;V z1ChoG<2R#-dh6Dix*tW-FPc!yi4>{?u`Of3kc#Na{OlX@1!C%Zo!efjp`CnVYVM() zK6ZA))B*BQktzOHkKOy*#g95^i%2*l??~F8 z?S?Pd8BGUE>U-13ex>F$AsRQlXe-RaFzz3X1@zW?`J>w$?Vj@ask~}_${W#M<$=R& zrpag{?@BVx_#|2BIfPxeNMyo*VbD%peNlh(1$s>=xZcf)G|1HOfW8VNZp^5*s?0ot zur1i1Kkh3{F%Gp>i@8YWV}aXmA96h3Riy3bW@@rDA=IfYrPcQ96_$S7=O|0VaL07cMw5eoh#7F*^Odhc?HS7CA};xCP|DuQeLyq zV4ui_yrS}DY#d1K&VJ{0R=o6UiOtt|ukkAtcPAv!L4(j@$MAVu!{(u^yIWsQEz_gp z#zNUe#fl&omcLCI?^EtYH?paoopF_A))n_BY_!RNSO?=Hl%}g%{nL1IMq8{5@TJTk z)BCAy$0@!Cehk9LCrn0l@M)~=;=0Cfkxg{GhROYSUfDs;u#|6svTS?zOa922G#v}r*1e2;R!|>lA_MGnseUz171Cj zTV6^JsuAxjeF+EXYiW5K>gZd3^ctqB000xZl%Z;{<;rjsEQ*%DNAW`QMt+3#Y4k(?7l~BuZ|O zle!&caGtm%e27qSbHjNMp-_xu&E@)J`P@y1j9Z&Rsl+(@ zBHlY|^4B`YU8xtldvUwWt8w(G;{>xCD-Jxz^A5t(qkJ#=i*N_M>83S!b0ywTGI|$-Nr&bB3S7+1ZoVYaD8v^Q+xbE z|Fk$jc!RF_v`6l~zVN%ZN$!nT^9BQ7mxz7CW;nfZ?IZ3K8`CfI2Pj=4*ZsUG`-{pt4B1NtfT2hK$w{70l9Y!Uj~ov< z{cS}al*E+L+wy?a=9nK!#fNp1WOmVAsO(gufFFEeq^&|8QAno;WTD4>)XWkZ%V01| z7@R$N*~=+38>}`Z;%J*oncUYg?}qOJ+T3BuJ<=8Z|>iWl(c^@5grm^MshTe(`e z`$sCShg*@ZwmF^>Y{HJqKeq-NrlvP*E`(K$gl-ltHio_EWH^}5wL6|cD0x}CX6?DG}8@FhE~a<+HS7xfegqK=+l;cGZf2i<=Z_@b!8%OaSh z-|lFrGY^%&bAjbBt-Q`zp|s4{#>uDv9tcLApjKd-eavj3LarY)U>{XLtmE69HZ``*D>}^h&cJ_ zooH%9#NvAjcsK=I)_LImfHaTX1FBkin+Q}?v)E>nSz$XdOxO9+>s$5QO$suCgq26H z28~GD`ggu39*-@WHwhKU^@hz2v1I?9Pv?9k5iCJ`=~Lu|bE@uW3L%udYzuH@xr ztJ$=>HTKm(kEFutt^V4Z>fUhT>6kTnt)oKvckb9nX^l_U+s5gd-LG)37wr2PC7m30 zm&UHS9?4n+S&{3be)H^%JfoYS+i1k&MX~EkXJ<@7rAP|P%aRD z**BGX@0V^L%TU`eQBYjX=?snDV2V4*P(^_)XGcF6+)x75fNw|_QOV$ zTJM735Aw_N{XVZCqD#+2HX+=*JvRDIr8IL+bW8>H?xUyXN)94>EvJ=>Q#rPX2b@8~ zIzc35Xv@nz)jt~N-M>3l3_}MP#4epLCdBNwlRI=WW|EmUTCyb$@e7Q6sW_Ezmus(% z?ao>3PFp!iZeFb=s?BX3^R_ieUegjrtJdx68V3%K21tk`HBfQ3q&@PiVd%NeDbQM5F*<5`@cD|pef|daugAlx?nQmXtCHStIwa}cFPB`uVn0Z#hQEI| zD3et0Nm5KkjDCGK%!84(ITqOIu_YdVMA3M=^5j4bR>Vc{IMbw6`~gC&`0DMG-Crbr z`)ow%qizDbyq$M!Lg&{h*?#`5k!*3*NlMv2TOpo#zogV}EF2$j{df1S`&wJ{LV`T6 za%$C-8+}7VIc|mDW(NTpm61sdkO$8o*%)$0UyehLG z9~7_HCGDMiL$3;qM|qFBWYX17jjk7Qy(H>R3@CYS%c`nM$TLCI*Bo3QO({7Zz`q73A;s2xQ zE2HY@nr06Nhv4oOB*EQXgA)jD!QI{6-GfVTf;$01aCdi?;O^YvdGGg=wOD7%%btE-QK3pH zG}Z>L#QTLK>9atk+8SX2=rn)JY3GcM+2Xr;>9lpeDJyIs|M(F#18RZPKN`Lk>FKW;8GW52 zwSQIFvdbqXT*Mx6rbyO1@%*a`RFyClgG;u3PX}Pl5N*1m9Kw+#i#5BRxO6{T=OQBq&=0;wPEkLJO6ax zzTUYEduk?>Swp}R4f)W*4q6e76d4@wxLtE%eLO{tU(ol@c1`6ZI>})!!`4|ZkdRG< z$=qPj*b@6wh`qT5#m4BkPOC=vJnm}zEta7UM#*mu)&nZ<(r1YiU3wrx_9trqQk{m8 zTj7C_&R_asYz_9$!5Gqq{{mDAuE|6_o3OFa^*NI@5*JjsR4=SA&IDg#d5aX9x>5)c zBfBDSB?-l%;Si~^Nr|)4qc>)ts}O)h(m)RdHs|7|$pE;*GJ zsqKo`CpufBpzo!C7^e}%S4odWUAY$Fb`d3{#7K_44? zzU!wz$}gZ%Q;~K25VCg8_4ar57YG{7>&lyUZ`S6-KxFZV&svQkc)6IklGm;n{!?>x z#l+e{LZnL6dJJRKn^B|h1BqW{3iHn}G&m_qb$oo#1F^Nj{wT?D`T|P=0IcZFY(1*UOCFIp?~89D|&*N5n}tfG4|IEAkVj7#&`E% zl`}m7X2OL7WzSG2x&5cy_GNQ;r5=&*Owqs0Pxyt@AcNhmNcOmv2;W8|R07zde6~B5Q3oOy3Lzv$Y*@x$CMZXeXnJUft9Q`RK@FY1_XX z)Dl#)wBgB|R`jXuI|Sagbc=h-@PO|2Piyf&AhqSMe=I}(Jv!D|#%E1#xm(A&%Bibj zevnA1)2_-!DVK@vPBrmZRU?(J&~~s_Iq^znhyOPB@ww6ZqQslq|4+g(h#J-GX*TR+ zu7J7)ha~6up)K#>W0$B+!(yU6&_WW+wK!4~!x8|2aqt0UWP61Zlj{hx_t`bl(G}Kl z)w>EanF}ftQnJy#LGDA6eg&Gun98?bJX3b39f#8%LfjFrPPFLwAF4;lm=rc#4l+1iYwB2SwyKC3`ZGV=1<7WJ1`4JTi^#RL$+j#XVb{XQ z|0$3uzu4*4+gR&OjmI>^YckOqK~ooOO*_vc3Ja-n$gc zS-o`{`91t(BX9QpuKk~q<}D329bisFv;=_(1sl*C=*@Lw2Zw+4jb{t`Wtw+Kx0YJ` z!;N)X8|z9x5IXasz5YeGrFCsKp~IZX^$-e4_M)g9B%*s82<%D?{ADXVJR#K-o^oh% zGZW}Tq$3kS@A6@R&=;EL5$=c+HYf}s6f0WkxM7;3w{ITjb{7Ho>a!r*?KpK?p)*-p zE}tzKWxW)nF|C`!no6h-B_7|YR;7-m{f2t;Y?u7zO_Z|wHqrJ(wOis~%N>tVGiM*1 z)gAA+6-xWxnhyDsyzfarXB5G{ey7}$9o5b(#cMy&)UO#E%y_BtPs=GgYycEaW2FJoYkkT4;sNS(buKjzyw<~#T%kGVH%*ca8R zBEFi!Ly&U5zeaV3+>NNTFd1L5->i(qu&`L(3)Fh*z%)jl@wJORhYt zo%tojF(QB$63c~WM5#-?z413(O3}w7&Wd4K6ACGo-l2tZ%?)jz&lQX4AN&NT0hv8JzF~PEwds0xbQYRB6(5RFt}kWIT?;;Z^L6X znSlgdfBYStn5XZeO0c%@Mw9-y&AQBHmKZTfb`ETy#q~5i zaB5=5M_|WB`uVR20K|BybjGOVf#1&Q%;jXrA&(+28k*Zbjzbi{xU4TX z5DRqn^QboHqUA=5F&tJ<#yMSdDDftZ_J2e?aHNu5?9jntHRo5?BT(b9z`(WD=Y$n z4z;jvE7GdF3)c)XSIL{tu6K=h_1MSemSz%;WGpb+M5=MG-_Tu7Wj|r0pm!@wXiSxa zvJN&vii&U*R_=b5deZ8_VwL?w*d4=Ym#siENg-fUVV!lHwC0dKtdj)yGmMi^j-`&< z{*md``)+?q2|9Jivzu5J^w>!3-Q_iPIK?y zazn2-xoc%6(!|Aw*9^k%4$jDVAy?0#P*=pE=G~P3mS|@eP7WuPts~S@`|lJl&(C*D-RcW!EpXrQJ=gd83EX0xEr)Xl06ONE}%$&=RKtF@Hf?{DMwt{1}@!crxQe zO>rfGZ{eX#g=P3NZy&ls#{n`aB8|Ha{-}AA0E0|c0X~JUIY42Y?%HzQs2wZZzPlY7 zIGPLJRL!{bAC7ql+c`);b``cTr>7lZ=1s(1AK-8DauO{J^}k@9F9!R*!WTN>kbN{L zl2?ksME{}DY^CE!e*S?cUM=fI#XizWbByIMN=P5fFa2=Zk&Ye{eih$rIhr#Juleht zLoMR+Q}uEVe6DbCq?PaH(%xPsx8SS(>D-NJ7pFa{dqfu|ENO`RkKZqAJejs~Bn|Yg zy8KJa%611kS=%Nyl9%EqD~dtX@GxusK{EttiIdnaomXV&+c0qzO)(eAvePc?nJwG@F8s&4ypSY zUrv!g1S02?RM2@p6_0SifyBu?;Fdq{Z*Q7VtVkMHXEdql=zFlM=B>#>zbw$Nz+qym zg?_YMdwniwSZo-GnG~Jh2ZL6A*O91{gEtU{xHE5Y*<5dQ9Y6|6n^o9{?4RL)GP*GV_#ZNaO57xcatH~6h;Api3^QE$O8*}>;vE* z87tlf9H*IVZ@-Ou@_iE}J-z+b;ks~^>452LS<$zV{?G3EmSV5<%)G|W^Rc8uG8)mF zgirjFTvQOx%X$JmsLNmqhW_t#)Am@lW7x3KMUOzxhQG@5BjX-5xwLx_qizFhAm_R*D`J;Ov&f?C?2fV)k&aHl_lvqO7Hy_*OLT$8a0iEdP&)nrC&nR|04O@=hpJ zts6bpR~KQHvvP#4zaS2p9CxYp-W-J>LgBJd32NSKyhWHl`RhKH9p*|zTOn8=xJbn# zmwz$6N5nW#g2LGER*aA?rrCQlHk3DKnplNYs%h*Iv ze%U=Dvy?)fGR_#zgU90Ke)V{W79Q;1kBo8n!B?M>K?(f6 zbp8Iqbo`tI{$9zN14q1=)&q)HbSS^|8oSG>5V6S6;+u9Oeo2q{R0R~+ z5Sba^W#nA+zB*{|XCttbE` ze$kIyKLIJfsm4CF)CoZKyFtaU@H^kOSh3Vw5Dm%IVfYdBw^l?+uv*xkB8wTu-VZNu z8;Tike`0Gjr~hLYJ#}i>7N@Q6tCER`Ahz)bq3Mr86X9lh6M`51K6ba4e7|o7%W^BQ zMzw9_ZyweZIiBz5X_XeakU;uaZogkP1FN}L8lwp22z%?+TfprWZX-&DzJ#~QRYJ}$ z2QbTJk95zQSG#U+{|dQW?1>|C?nkz#w!*OV7>!wI$I|n?l5;|39MuzwBavB zp_YL%QIazLPRs8^9~v<8m4Yk1Bo$${*mQIQY$E-WYoYvu?){mU)3r>t_14^AI`6Mw zeqZMJMx%_6U;Vz@8Dcd%j_hSzdt?|>Wq<|Ijh6p;dwE^HU%Y~?X7j#39N;v?arZf8 z?$6)K;Ek_n0E50dsj{(;LxD<&EEZH$xsb?h7+4E@Lp*bQobp4@g#LYH{ZQ%lQG3>n z4%0mY0Un82svR9xCkG$79r1P{e7MNT+ain)+Pu-OU;b@b%m1|_ptn+#c3#H$bdco` zX40Oj9MGEgfLu8V0U8m{627$OAa}*kdoya*(*pkn@OKAkt zrFCtR+mgU>tI_xrPSqb;MciHVDics0!}2LKNe1Y)8?cu#+%;#beX?JgA2ZKA2i~gpW;BH zZc|q>yB>)DcY-PcDNb;g%t67ejbO2aZC=iILS-E0R)gd9?74= zLJ>oa*vZmFuoMpZU>$$HwkoQeubRlD`E|eZg20l{(Nu3)(cEN%mje(CB175&FJ)VW z@}V%?S4X)vfNp}|H|Kp=TA2~ex$ccQUp0nz9HS7r18H5&5bzMFbDzOw{I1Hf1? z>_lJgo0@XorGsr5%ecgaQ}?s;o5clF4_q7uIx%-0bb)&l4q58dEj?s`FbNqx(1w8_ z3`5TY_5ry9*(K&9F}s0n>&wKiaKmka!KPV9;jwbN)~#PTF>Qu$3oaiSAsmJ=m6z@= z(-Uv<1V$a(WVP~#cZ01=$g`NCFb)s`!>_a$=zCj&yDm9WY1u^j%-AXwK{kMe!&c68gG#=75_;_IaL zV_DHQC-&B`TcetQ-xR`_tu|^^oJ|c|_ip_V9oWH0sn+&YzrnJa6lgmZV4tmai= z__b{D$1_I|lra>+uxv)#=g3*S`3pm)`tIJrYnpAi?j^4+xo&QH~Cy`S=(@esP*JM@L%hq|3BquXQ) zZ9)l_P%9m!5rG8A3B6pL=_=eY^8EA%uj1{RC@!uPaf7_GHHS~bzWHxgauQV>OPDOW{*2$L zkcZ}UTh{OZIjcT8vFi)xa(|TXoMZFuz&GWc`rVO=w;n4Dd-1r|QlxV1?Mq*qFyfQ7 zUsvavJ8S|1u`NWSx}O<;eg1WrFG_flS1PxqyY4<5Bu(gfmS|G$@w&Nqef9d@J_*sPPq*J)GNYb zrCcQVeD$4NoMrz`CDGxLRDHe97IHxPlg}mx_~Lelr&fnesryljuD0!3sH(1%2Gzdm zxq4OOz1ibucVVo3JA)Ayx}Q*aaU*+J2@^UXzVa$>IB0xz5afqQk9Xhd6SD7IyN19o=);Ww(ms(Af6BiI=BGxr19x4jyL!J!w$~}H z33^rPH8O|;B2A~Y*72fCzBQGP>(E|X5jB+9P-3OfM$ftNL})Yn0u4#-_YVIA7?FY4 zTR_DncP9LB2pnz*OrjE*jguG$5z-dYL@>fJT75cjcU$nyCa?K9pP%TL#bNOTlYJlW z-&Z!Ev>b1wbe9PKW?}7;4oIE33(1q%P#2-iPn{^boRLAz< zOb;}JHoPxtHv<`SEQePBr`pExUGtlAC5FTj?~ECY_!sK$cyF9)j^(!S@1>4j@8?+` z>z8>D=xwbLmr+}9f3WDxtQA&LGRy^ZpKpPEw|mj~Ea*coAg;?_OP=9(UpXJHsOxj? z)}pe{ux9=l;vlw=$CoQF==Y$Q$Ms*RR`3QRpV*VD*N0)keeoRq@{BDl+f|@C}0jzzb z9U8H%dxt(%89(&&mu$C@%N){bKlR=4+8uw<^+HgLPyOy5d2LJuD28ohQ%I8&eA4jl%12^|qWEb- zsoV;w-%`^Q9D*#1=A z?n;tpw6}8+JY710u0I&{bg-&l{P6!SeBFW~K zU0Yom<92Se?&Xi{8UUxq#5j6QNY}kkq3a5r1yXJ)G(Lm@k?L$qsWmjNqW5CI=;s_z=wI}*~StZa- zOAu4QRg5**{wd8}CvrqNT*@{*=H8K9SGEl`VFBqggr$RJe9mOdXsOzHQYG^SJF!ej zKe;!jiFxS1`SnasI6*lS0Yuqz}io@@fb^{V6`B4AHR zBnp$pl$^g+pV*jXx9!P78m>?uOH%m>fg`zu7mERRm1?7iT1w0I2(ZrOH5_4+Z^&>TiA|EoCr_YinTv|1gm6b z`5(O|F+aVHuI}5ZojQL+nBKsj5OVzj2(h3*#X~W!n=S@{24|A^Z zhm+*KHwci%54mjX;__!kwJ#ZS!AmJ@dyd3l9w>f0S`F>#i~!EJOPcgHjK1eel94h= z-B;(8N#-yCe-Td;v(Ni>@QAj`{!P)u_&eoneK-KGf7{PyjGG)XWYUdBE^gb;?Jm9J zs&?YKVJd+-=-krJ=J)&j50Ek;7MFb9Q$#=d(TjlIhy9+$5#qd2m|0=MLImiFVp2DW_{a}i;Vdza_b@pQPz6~^_ZDKhxVCK9|*kdPeWcd{T z>x6_dTX|L$_|p#Tul!F$-T-#(Fg;XQDcZv`Q*s9O@4yX&{*v{NH;KrY%+fMVtnuW>%kpc>V41ev@agWAoT4Ojrow23ctCD2A8~iml%aqB#HC1L~rQQLC%^j|84aQ z0J~G^b+?x>{8a04hk0GerX-2Q9Si?^Z;~|n230l6=kGf#5W%@e+z0G>GjEai$SY7= zm|1>dG?s2I@~7wv#wphOV{6MGkxU8y_SDx7@oN*wb~Jxox9n*x3HzpNi~{<>p3F^&`xH?`fwhceV|Zlwedyuf^XAiBpCc~T{RA;J51;^p1)iOu;-bxpR` z4EH9x0vSa5Y;39=9KiAW_nuMvjQ#y^pH9)&!bqpR_)04vazp$Vx#5zth~|y*Fq4Dg z{YaN|gYSd2mTE|i2S(;ASD#g;J~gnCfCkcRZ10f3|xI2jc$Ssz!7`uUgy>relR@ zpmV20KV>co>k2>4{WDtlJdzX>HEAK$UW#+RSJ>f{(EL6_Hy-z=`l0lo^+x(^l@^&> zINxisG3`ne3vAWwX;BEFsFmU$+tq+-qB02?ZR7q^hWRW2O%sqg^|M#i633NVwT`&{ z2CwjqiQ^ehK=^?v^91@&u61jJWAJatGOpl zxH%nhFAki|2@P0ewIOf$s{>=OZ#|KX_n`!yEdh`_#-n>9&2jk1U(DV<9GkULZ#bk1 z+gq)^OqONb$@5PsB|*8jSEHK0?)wANJItICZ`IK!*D(k7FHbDX5RsCKJKRyoM4ka| zTxBw4>{WcNQLyEd$w&M8lh5M_+Q&Ym+*%%-;>s8om&4kB7lRjIzWOZ(8qp{ZlOL-J ztSVq(18@Cyi1@L(CTSf|)B00(479TDl@L7%@2nyu8pQ zAvm8Z4+rVL86+AaLf`&=(jN2R4! zBE|2EA!*@6HIwmUL4kd>9VHr(m{B3xBoDyMD+1YN9pvr|GT9+zyz z59nmBi>QK$f+~=cGi3Di^rlXb@>TsMdy^-@hZ#e>{W`_N6_VPTLEw$RBe9U%c_jonl~X;NXY20@8&YFf4DG)ER9C@ zC#xxrI50L8nw(r70@{A9B__1U{@xbt@PhH||74|7)93J59aSO*l~sR9wHYYRKQ#S+ z;P3Z;^g~_}rm|ANl6lYYB6ha7xJ_9;9Q}fWT1;v3OaB=|hDoFO6T<)#URqjp5%)3aPuh-f`H<-c z#Lc3$Ulc&<|Va{43xGc{V5l>YY~HFM>_onBIlXnhHxH~6#t9h2rIg{X_v{Xd z&l_lxi1>-MBe>;jrM+80johL{UfddR;Fm} z*p_qWN)oYAG_LB5@iYZ(SCp*bb@;HpBJMh2@?Wno0Ce!L9r(4G*U!lCd$jZWtQCy6O;tOO!Y}HqgN?Ttrn%#TeBv@bRu?HP0z9VYU4kL`(<}f8S#|&BPkv}}1^(sdA3PovTgzL6eL_NwvbXA=;&&UY6W*Z! zbrOuTg;kG`BK~Jbki-E%8bu^#vS{%sBOO5#W;^$k5+*0Bnku*>SpCB+0R7Exu;dcO zBUlc`WMrUM_3!6w=q5hADryRxM*)MT65B2YR%g3DXw(4DBSX20G{lgT4RkJh*`RcD z;5;_z5^eh7ol&?wnQNorGG* zv*hrTNq~XHfPp0gx$a2&CA%>Hb^lO0Y{bu<=K+DDe`y@lKCQdD-Y-+$9~mIurZ9>s zH!T;%C%4_37_G8*k778MpNpL0{k&9lg7YA>&4CxDHjtb?C;g?e)-*iY(AOwQ<$jd# zg_!!2bc5P;=(`4!G&K*v>HE0RC*4n<<9QH5e3|?iAe59`<--jAP_G)7==%)nBY=C3pAhGt!s zb@J~iaA*#XYd#wya=`QU$-HkdH`{eTKESIbrHN)ycakJ~*?0*&!T+@%&5EWv1Bp2S zRyH^Ehgk`4F=n#-uU0W2#f9_zn}CQXr5Uw^41DE(J!9?%fh_QgQku`|4=)aX1RpfY z55CCT<8pnEYS6DY98}8l&coB0Zk=>eKr!H=2I8p*P$2i^K(^dBO{j!kzX%y(^+W~* zVPL-S@1ne$Y9cTWt-|81fapDPj@)lUIiIB*AuU|~iOo7~mG@$8=zBM^a@ET7g#Uzl z{!{*y#Al%5Y<3)*;btoFN35z!RiF~(K;_~^602^)$SM6Q1MK<=fF`nxHobG<@UXQq?ee13=RE@yQYVx@n+7P z^Z=~%)TyfJ=3|VzI^(H#;D?AeW(ff+hR{Ix)2 zl?Ap}7$gCpRW$Gafj%0atra(`6=NRiVMH#nzEYE~00g=lPB~t^1RqF^sL1!8`**td zPx`S>hVRWn+WkFU>{E8-j{Na2Bu@)ztw`j%7c22ZQ$SNG-_xpqu@j3GkgPx=Mi2FD znnj^7Lq+qlH&8T5yXgxYLV4S@tF+}+ZO14{-2OYXruY0pH`Z|nIU^dUYD=N4zb7V!}^pAQ`zg%pdinJA9-Lnr(GDFr~2lK(cuJ#cKK!4|e(_x9y*O z0cC%`0kxi*sH0|J*FHl7qErk;8mfp7=JDWERB1PqN7yEO@xl}~Ah-K2rYV1RCX5f# zKEa0YlP8PJj<>pQ^DoP{pt{7??HX#KZ+?p@FIe+*)4=jM-$CQkwZj*rc?3L@_%O*E zhLn9LKpZI*g~OW@yBiH^^4@Q*NQ8I7t5 zr|>vy{3)Y!xhRf1f@MBNW@0Y2C+aFI>;_wc(i3nB({Y@l9IP&2tqCSL*C8xhm%9qr zhy`!_jE}vM_tv&J|2y>#E@VAsI1AH>QUUPSs29f_>0V%~MBp3>0UAqmNVp@3ol1wE z1G1#s5$!m8;nrg`raCmc$`-*!R5@1Fw5 z{t0oDUe5fxef>a?jtKi*&MBX9I$*6u)oGV^BeS4iXoZxGlQ7#GIt%f(dC=P=)DYE+ zQCvH#&EIK9Wpa5iC)uethdo?MnhHx+jCAOBi4t0qI2dFd#}lLfzxqkd*)5zuFln-g zdX*zw5iva#&#WhZO?o|lWCkyw^+s)_acWxG^E`3%=_0EaN3wl=A`N0#=rd5;vM05b z&}tS*q=%7@o2}08qQiMSb#fn4gHb-I#>=uh(%C45A(Ej#$Tsw+TthB5K{aXiMAt-s znQWblnR}`*qdDjs?M-|ddDLY$;Hl4^Po?X~5x_NM!{87*=F?ULi|lAjNtv(H{_99N zYmfoI7rfESn4ZKVPBsa3`_GXu4#+ls)E?0z&|4o;1TonQKr{_$8$BK*jv(BfN0c`> zw%g>S&IaQh-ek}BDtLvwLyS3wX0)P#ozTplmR!fKvE>QwUj!%akY?_GLNX$sCUeZi z&*%_gRNC$SZr-RudlL}kbRhu)GDa&JXSeNv`spDUMCHG&lDb7=*RP%UPs z1rJ>ODe%B^g$IsmQzIK?h$QNP(;c_TU5Sa{Wc@vc-k%JCWlRFCmPc`zzF?B;5G^GM zh6>6VA2wU_4w|_2j&^5PmBQ5nrPko-+{|XyNK_FD@Gb&hhMN#vhL{`kxDxunlt4;eAJrY$jBXLcE=%%FWb>-8y?as zlD#M|I=N(rI|oZP)_f|M`U?d>`ePw-Y1xq)N+ynWld@FXABcbC$Rh>J2YT9~`der9 zwkjz(&+TvWH+m?PRmXlq%q9>Y+;d&`-Q=@hQSlhq=F7~7Kzw6d!bzV@cgHZPB)}d8 zjli&0@I>yrMVf$O@J_3Oe%iuCsj;KF9}V`Qgx`@tWeq2y;W#k>wQAdMUB6MyGG?L4 zeu#SdL#FgvsAHFtnTacAU~m}jxHUM+gGZu6b&R_UmqzUGbQ+nSA5^|3L#uRN}U!>OaytAK&MBe!W&6 zOj<8>#1(*KiI9bVNvsLwXW&g57>SPLr7!)29VB1Vw~LL4t(Na5C$2b`Knpl_(ho#x zT{vAa#;+ z3do}XIHglBjbvl;7Z8s?o}u)^kO7kJLUqx^2I+pDIB5^=z(zjh;wMu`esLcO-nrHN zZ+Eg0fM3kbX>m697d2;x%|O7vKBv;|Fs_hvH3%U}JE_i;D7TEKwQ0b3ZRLI0+`pb< za;L$ipbel2NKo260{r+1i?xz8KY$VpA*24HU>qn1xpFn4>Zi=uLt#iO4W^3(25LqJ z)>cY>T-dV3_SRKhqV{L-z0=vxop!rx&88c^8iR7?=eF<0j@2V>B}nbmrE#V~6Ys3V zxmE94Jt$M|vI~TCm2t=^9}Au>B)+?UC|x49U2Y;8lmU@t1QOe&<>n%3&1dQ>d=Z7h z!er|SLt;YUmCaS~f3MTRzf0}`vN=M%H(z1%FyEtmzyMz)!~On2LVOBl91DZCdSn!4 zRjaA=0UL5f>y^jEd@^DdGXJaFs}136iO`WEc|?~nUquUF?zcS7;fO9SSH|we&u4+P z5?lWc<0PVzJ;@7HjzCEx?+`8m&!7heHyFTf#ee9>9mR$H(ckNcU;FcD#PATEIDNuV z_1IfG)NisPa!toW-FDV62BhPP$e6$0x4L7eGcaBpd0<3epA#K0JLNlSa(e79Z3GeV z@2Ruh_Q|$*GHhY<1oSxhj1}%u4-% zqgzcFpN}UUN~%J&L+Y}<{VAC=r)K}10Exk4eGjujs0%Rz4H+p5gYC~`#wuFfsPz#FIcD0EYBs^3N@#ebxgmsonEg6(%|0SmOd+GQOE`gB8L7RN{USpB>Jh0 zBF~2Gin4JL=ck@B%i?^EfJ+P;t6Q%owrsHTB@1H=Ki?;clN77EV&?W`%z00+pyYPeqwIAWySfV(f_c7&mHCUem(a4@>x#b_?mX;dglvh2IqyA2%f#v z^oD7sdE=*HD6LMbQ?Z^U=E#ieT1Pax`+Rob6hH5riiF;3YR^0FPQI~(B(Mkgo;?KKq;g1Fr!b_Si3*Pbr;yXBJnitwn^BMib_QZf-a8Qj?xJVWnbp z48**Gzi~)@cf$PA`J${_)sG%~CrH;L_{8e-iU4dl-iCWVD3gotvmm zhS!IuXzuhpbo#~jGLr?;=eg}Yq7p=j*tRxx5!C8?ds^hE?RvHUm5^W`k?k<-=?mS)OUYiex}zJMM4|+ zq!euRME3D{M*%x0Y<)PRVAElUVLUTJfT1%e&=Uzn6rmX0%Q0m_tnzceQGrdX?>DPdZGyX>R% zI&Rp;ROkW$U#jy9;ql@dl+VlQ_I<7cLz!oSU2kR-?Vgc}E7jKd?hoLy_ElwmhOxIz z6~5hKr^-2Z9o>K93c43n60aA*@Xi!^mOTsfq+)ZFF@*MmulPTqBJ|j;)dFtFAwC%( z73BHDI|-5{*#JdX{VqDJLQ(k9eBim~s5`C)fpe$xBu8@VC8U6=F#vF-@dIao!oeE9 zBka3r`1s*k7nnrIwb!7grO@jg7%hNU)KU$-LjEo2E#e=6w9Ef_0ib_8Np?`FoWej{ z(_9I}5^@F0;u-({vE6{KsjDI!reiZ_$V@VWznJ-BWBELS)WuZv%2_r=em91^sjLikbmTb8gHRW1ysmb{y{A+2qew4(gLI%=>zf@5$ zIKW_jKr$90Ym7+Bcks18bt&D}2jvcxh~GI2cl?W4d}E)yz>b$(?RD=$8By38b>VBN z$CjzJk;WFSXLjAgmASCrM7w9A4fOVU>RG~mOIMNP;C)}6h|ta}W-@!I1Wg2u^LGr1 zKxB-AZ97YvNe)0W!LF#MbU+n4LvGcdx}lT^Bzb*kdBaG zK;o7$8>ZtVLc%UGia>Dy=wd^Op+kCbSHb2vee(Eq$F0e;dVc%n`fYAsR8ZOGImC=x z2+-ObgvbgR%7=9s67DMe0IKaoLi5QJIi5D22dYo~-Oo9^?tmsxJV>uqe~>1qEFR1G zwEu-j9%ynn@97S`*w9J+i7c*^X)V_an^TE&@+C^MBplh^AYr~~I<%rJ=NJsSIGc2}HWZme%w4we z^Cm^)t8;!gJ#e#xW4uNq7j-+5`?Qw*S%oU@Z=*dte@DO?`jfn!Buh~gl64<@3!kO6 zzON0d%n7Iw_tUxBq7BoVm!pR`aaY?5qEpWwY7G6Reb9shaH zUOy*y7KjyaA+{W+EXhM}1|L91bxm}SQY42LTym94+b>))r+3qgSYwDQ+``lY248Z&_( zHiPgp=R1guP!uXfyg9k-Jx8IMu-!gvS3`s+eTrlOyw*MS-(9L^?3t*<(DZUMEsm!_ z1(OReiC9bUzj$pHwwUesn@97z{&4>l7b~{k$nM>*cHfq~*Yj;ac{d=Xj9iW@XE3L9 zvo8WpLF6TmnbXVGRlj?sD%-{plAFiPw#wXc3L;QkzP`h3^Hb?H% zDLc9n##ze*K=Wwt40vcTJ1`=m`5{)Ko=@87t$m|FFnklJ62uC9S#%V}1pF`ln>^2iRq7J7J;_K=!a zTUIF;(gEex>HT|nIGan|mawF%2v~l-cz{jyMNyQv%>;_~wWpRTKjS~W4M!z?uz729eznv4$!jhfa6AJ5peFa541Yf)_F%ALm#>LA` zj)A#}ej-ajR^KaEm0U)mIAzSO2Fc8aC=Z?GgpfWTSD2U507t1W9pQDUd%(5K3U$1x zjJn#DX~!+-_!9-0TUkY`mv<6(YdJk>xWHSHmjt8$e5hy%w8aH85$3>1kRnSX_d#&J z^Y|01#`uWKh zs%habzUXc^4b3jOgvsg}p%EK?+uOJ(UXHxePw}1aWzC4;&K@P34C0F2os-A$JwPk9 z)Z7zsR1dDnW5rT+W-;IbRI_dEy^ny7240Pl5~pQPn>30K6`DS3KMZR3lTH_FiW0n0 zX#C`O<#sO>)~e|qjr74pr=@xSG2bEt%MZz%(nI;4mdKZ!kv{dlFfrLVkaE1JXHo$e z$OqbwisJYzDWgWa46jU6pQu&pT_`sdNCY?B`GMA?>omiQ(OEo@ABo^g))^%5Ffo#= zb&haxyF|MUBUcC{+FQJs`$FNJXiP0=B*VUDgT?6czaB}nv%x-Oh{O5`HZuI(O+<`) zMhcx7Qvq59dcrPiXV{C@<9MJn>~Mp#?|n*VJH-9G4~Y*I5l`~a9< z|CUko(^*0Nf8)M;A!~D(hLnPz2@o-q7$>k2_|Gud@KgBJ;PO{kDJhy)T_%Cd|K>9N z*Z21B{@wWM{`Nt(jSyBzTr^$Wb!uZaYMBr}vs?yg$wS)2Mb&d)?)Cm&n(d}9dg*qf ztV+>d_eaD2h^ErwfX`o=;e1#z6<~#s&hQApX)%e;8xsDa;RH@lYiux^8Qt#dpKsrZ zWqd?^x1$0+r5+cvymCjNxt&@-N`y~CE93cSuUk%4mLz3A3x04ZnH^D4iPeM0dNT{S z_2n|M4&sC9xVSu7p>ghVVT>OdPty77pW1_0j9GA&E0(C=n1%L0IEX;{sj-q@>9aF#)C74ekhwI& zH2r;OJsEucik$bhk7N-5}B>F?4q${k!vef4=|2&$U>~1?Svz&OUoT``P>Kd+r_fc&9~e zsnG~pF>KYz{;JilYQyPL{C9n*R#xvBh;8Z_8CybRm) zt5|FykjH^2uDy76jkY(L5W*da0t@ST56v#e!{d)!3l zxJlw68&NO$G&x5e>qwW1#^gsG~NAsRGyFK?@K<&y;L^3Am zACmCEZvile|BEKnHN#AUBC-f$u=wj>mgDlQ5DrYSuNn``936C@`M}BpS&Iw2HUJ9x zT?XBxUtT&!^<|qg*i8ue)bJkgWv0nKjbu@L_T{%>LP=fQ)Hpuq`&4S^#OiG@1m-XW zso(^UbN2>>U9te5iw!C-xBO>hfsz@@nO&fw+F*_)ZxDzL*@;Ce|DV5$_>&H*cz*p4 znkwywdV>bMw(tHrBI4a}Hukf3qcY*6+|jkwxYZN6zs0XNAamlJccJ| z%~+}aoOpIK+;)_X0&=nmW&qX#{mGCEyomLyUb+kS4(sl=YRz)d0EQ<5pZ4|@7&233 zlgY%XP%{jBLs%?_t_%tipn&jnByT}Yl7Tl4<$7i?x{URJ>>b0txx|E?orbFzaKiL} zk4>RbE|g+bv>7{xt#RF)D<$+a1}Pp#wiZM*Gu-MZ7iSN12~>@bHD61UcNZZ$Vdlhu zCQ9pdm_l&&`2Oe2qmN`U-@&>>GR`ivlEx0X?kc2u-5z)lnLU`GUw>TGom1UJ2`)rfJ;bq-6ri?^6u`SMD+aC_qK^@J^&{nn zLDC9~e|%ib_!hW$jy#82n@RW8OBx)6K|~2`EUPL|&nSVOi3A^tR8!o6EN|8#3EkRQ2|z`)Y&HHd&&&S+C?H*ud5=sJ^)w&!Y4od<^+u*=b7Cn@XP)9;F!c01dU1YX zR_>v;lwt2?c2PkFn7ZC8_C8*S_>{h>JSuWj zF6Cv<2x_{%Y7PMN6Qe4VqWD9HpE^9q$Z^Wy6U!O$0Ge6#owSiY>*gW ztl-Zig%;m&fGL31q-5;zf=gPE)JR}*eiy%I9}f_{+@YN^Xi^Ok{P_M68Vx;Qw7+-O zex>U@j^1OUQvaE9DvDQh(`yTqYOMSXX?PhoSHW_BhVpnApvb4n82*9ZlxfkKD&xH= zQhzsfFp@z-qZ-CEuGR+GNACIe&){~Y?jxxZY$J9nHw6Vs=F1s)uMtPt2}X8g~CI- ze3$t%skuB4iJQm2Q5D6(&Qds9e~CdzZdZ)xKIp+)c& zb}+D92Fsedr(Gs@IhG3^s@b`zxZwKN%)m>PTLp~F%g5R=A1M!e`YkS(Q{*_0&I@mj zHcaT+XKE+nf5t86Np)f^lm!}S$T1MqiAWs**Ge==)hGd)eZ5#}C_F)i!#1Fs@NW1C zDP)(m#PW1s{Z00hZrn4}Wd~q}ImHw*k?Wxz8lmt&zDQJE5LvYrklufc>E?afdAGEg zk`E-pyj0_a|E@TWCOm3`g%Rv5lwI)QywqqZ`A6V;AEx?mvDKRZ_y*Ra@%0&xLob2_ zDRJslp}Q_z-X`;<+tboGhf&77*XZp__ooj@+nR#s*WBzJcMD_mgfBwS+EDL_a`x&H z16$t%MP=35Hd#w(dMmf&*o-q=AXBetJHHY&>}!R!g{u^dl@vbWn+>VRF_DLE_UY)s@L}(A{gb(YccBVWMD~Q`9?^ z=p9s7$opMxg!7Td>C&q8!TrNrui z{GjgT-IZ^Pci3sjXq|7R?-ODTNvfh1{dv_U;>Jz5hOS@7Z~qpq2{7`aGZW{ziOBs$ z*0vbi_gHnxNF1*3W!b41pOd9hy}BtU4;z5@7Vby8M(>fb*O%pY7{2rl!E=T6tL4Ta z)1}A=diOhzn>oV%W$G3`ys%~X9zCMQ;&2c$kvthQy)<0bVzzi#cR|%o3`j+c2=5R;$T}C)le5=T?%PC5T*T!tc!A9H-{CVd*!d@s7{aIkoW&63kXyd zmYb5t2FcjhX(kzloblYP!~V553Ojl16B(c1#)wx<`dlqG3K6a*pIR7Af4up2JXO~^ zqH+$GK1Xlye(UFr=~uD7GCw9Yb1KdD%Ui_nY^B*LK&3W+jA4Y_ZMcwF$bGcIxq@Q? zOiS^=!ujj^rqg|0Wm=}4qGurL;;Ae6f?%7+j<(}uu?hTew6RMBD!)5Uom;GB=Sk;7 zZp}-5pKdPtxQMG-h`Am!-L|h?pX$}==eJ!meO%XiBzN0RxDc+sDdm4CL^TAKMh+Rx z;R-3u6ZtZ#r9FLV*!R}kDpW~|Fe+3egK(%hzWQoIgS`KHS->6lKFqcyj&AYCyz^2S`Z}4N@E`xWl)BcJvCDr7l-1QK7G-cYAPRTs?ztI$< zd8hSB52W&R8sS3_{X*@opWng9%cTxK(@g1M>J#MVdb32U=gCU&);|4y$7S_ru|=$@~j0=yw0o zBq}$mHT3Xya9|Evrepr^($9&|cvfPqdpOih^g}(fC=-z@J#Aua1X6GB#DGM}1HJbwF)~ zzqz@)Uq-!7|5rLK@yTJjF2F|Vp;M}XaMAnn^&B?Q;!&dB@~@j6YTtRuy%`sCFQeL8#2%U@nBH~Q@-`I`BbACl%#1Md!G zVgjb2(@W3!H4|Zrh|PoE{<7XeL!37bzc6y(Un|#V?XgQ0Z6epZpmQy}ndscEw)NfmHszVYJbp1@^X*sdwtl1R$(4KzC1v3r5r>#G9=K1^C_ zO=QY#m|TCo8#)m=`^T&YPP@+%-!iO{b8)xg`cHV_vTs`8aKBYRw|!Ihpq*9f0epKd zUd*&pcUK2|Ev~A(UETMA^|)@a6@Bq}>*Hw-zWFP}LuB^lz2dMR!9@LD*um|5KAl=? zX=CF}cXP{dHsxVV=Su2uqn4!Kb)VkvynzhI0w09UX16@v)^euJp#zH^r~c`1HT_GXoy`gX~8aoSb9im2k^&nRa>+3Vi- zJ@6-F+!w}1%*~BRZd%MtoUOu!%@xR&08H^qy+Oh(%U5g#ut?;seO>fI32G((37D>> zZg>SCDwjGVxj*7r457a*5c_gJ{ovSGC;vun;U+X@*H6%?`aw?7 z*L6`{Wyp6~4-3P5Uuo4|J04Kl+5Hj5wNhF?`16-~e*-lz;RC&fCq|`8`_7*b8hA+j z>^3fkC(UnB>YDB)a#uSX+q^qb$K8radCw8s`p}RB0)26~pK19d8A9?W_-bZiE%>#m57oBi>)mAh#j4SQ*fAE zVRMH^C!6E0p@REqCR1zj-N0U}2lB4`PSHfF?sJ>LVH{Xne47mKf68vPFei0i0l>1& z!l(T2En=iaqZA+_%e>fy<3`A}&9)R1)4E(#M=3L|!%U+?hPE zxW$)wBD2$5rJmHLZsNdFMZEflK=Qg&FAdpd5YD6ISn!W;B^OqHd8;h|zw4X14s4>= zi~o3LF>KO$x$tmFs4nHa*>mn)e*0m#*zux_XPL?UmfW{v=B!9%wzHzn*7$D6g1+U3 z0b9mBx#{opsu(u4OJzg>^%zecyAp=mJ(5_7!$y2mj&y{J&S803tWX+P2@VP{Q9tV;fixn_T=JWMLwcBO5B3{c4&m!&wZP;^*q^d zUuf~Qib*Q5QaNSKkL&@`!yEoZ>^_&8yqLs8Y&END#8&2`E#0`fBS$vR60a{mbF0E` zK97b(Xd`~mdpayO`+ZtY=oMde$GaPvrHySVI`vBVn4R(tr2#E>bM)TGR+{UW(f7We zs1yxB(zJlG-CAs$X@=Cq{LKr7WXwq{pb1+VK4ObkpyRUasHdg{k@X4j$N5(I9jDNH zFU_cbn!lQGx@s0~y_eo3EtL5WU=AhjGaIQzF}$jN#nwun-~M14KEWfo>Y3`yLfeiS z`~I2@4N2LxMy;=;c!>Q+3I8P@=Cq+M$y3+NmvbAmwzky z-EU|4Y%ckU)eQUBY_6hRYFfP+Nmdj5bgr+qc7LHC{&Zja+n;*iK9?+!aRa=;GV)p zX`v8I*b0Fa`Ar}1t+bx%^m5F`=IDQFxbkpOfqmF|a;VmH;2yg0uko<{?pYme9QAwm z9u7Og4QUTWLo$Td##U}LK=P8!Q{C=UBgei+or7U!o4vF+&naVDt85Vjk>4!dguD>$ zq7B#me^35z6C8ZJnpSszTwX|_yv<>>&g}V7rsE!0iXNrH;&p%PL$e>(KHi2a-({`Q zmVzNj#NOk9PV0y^g`z+j*HGfmyyX>I*h%*VC+ z*oBceNqZK%J6-A%uzKLaU${%e&q(LGjr@CdusU~ea6lR6x9Su3+-IfE_%yXw3Vu0} zFxN_vSa#ic>E?4&WpOBWUaB7F9_?p)6l5HF+8^a3DgCIqzB*#^L^)UvY>>%rE@J5|6Jv|L5V>{vMlL-z?rtpPc{kzVWl# zifO$8oX^AH?&kS`_u?-npPjyalbgN2jcR7gIiFB!_7c9P=ks=SYJK5bm{J}6@H#8G zr8@nU@(i373MxTH(1q|(7AqRP@1Dsf5qus5v8 z?Yn>Vu#LM2IN7B8vfcQIr%%sOQuSL+mDD@%>80lRw4~>^UGd)iTip)I3!|UZM{Hhb z?VDQ910%V*SZTe&b{>V(;=h5>i5e;;b9cU;!a8ejp!~d2e{q+IHkD4-(3tBp2;Hv~ z{IOGLn-xq%*MSZyC~GuSqVX%y5PI7KyjV|ba((T0{ny0j^6=$9`T@U(1Im`VV}tR` zJK8#iWH9iF76#BOsEl^&TFdE>oRr$x!f|PO!|8%g$e88Y& zj3k|}?~)<`_Bi|DUZu!()myscjmhrh+iZp{L74Qo<;S+3avm}_-=ENBIKTjFc@v&$ z$grUkLlL=ePG5g1%;~2*F<=!lyjiR*_d88#bvsw&xjUOq=S=^1aOwN6_VCl8qJ#Bi z`}k#x+3NM2$>MoXdfehwOu8rR^0)fk+Q-)WkF968r;BJuTp$@SMj^m;DH;I*OeZc5 zmkRICH=sfY58Cd_SIxe(=)d6UH!^>zM;Kp?lM4bLu|RwG&o)!gPwWMzB8%$uO32PL zg=Be<)xjc)K9t<8qWDmh-^C`A_`@A=6Z+Y>-#N1Nh5-8hzbDQ})azG|_^)XqU+fH*-*1*WPJ+YfCA)Eb|G_ znZbqZ1GSz#?RTaxr}=L(rLG*Z6?qn@3D=e7LH=dHibo0!zN()rTVKe#PXe3W1~9A3=OD)<9uzc;J)$NlO}W#&(D?2MI{P8)qy&&FMe z_N@SsTCT6V2Ig#&G?~Ms=?y$yf^pr`<#J6C7+FE#v>nm~im)Q#7z$NAnaKth&0a+3 z2kgv|$;ewa3j{${P^HtKXMgG<4Jb!oI-F8Nj; z*AVXm8b_m?{MeFUH${PvI0LU@Yehxi67wlcc-zooc&S`i$!(DOsNjh;V|kJK_p(ky zelb6m?n(F1V6OujgQXCtWePy^vtrWIrlz<;V_m^8f8X&Jg31Bw9Tmb=Uu1Q+#e$<{ z^;D*pxjcWSz-}ow8e9s>^nMn97=K6fqPv3|QIHxlcc)K2g1yOOc%{HGzaUE?CZwZ} zd$%L+p91?Nboa++``1vaUIUFCqjv+v26@5(Z%e2l`ADXly+gwR;^HoVRaRS;PxA2C#^{(3DF6xd^3Y^Edn08WURma>TN^JsUZ{}MJmBw3vk-BVwh!D zyf5$g@O*keU%|FmQ_e`?_+hKIAPhSpsp~f%CFki%S;?a<^JOf`bualy|AcK>=8aLt zvC@vH=nK;87%mV9ChBsg)dMGo8oSVPQpW(r7|j?jGYGjPfLn)%JkWB)?b3*MZ-jC6s?vot9ano_sg{ zOt2j>U!T&34cAl!@W}~~?5Ng$HFTMTDfBEw-aHjjR2PyadTl!dxUiPWBVA4Wej2YO zbg_w!@?a4^HDW=2Sf9em2%9m%cHSG#id1!3q3k1N!o6@eZ_j6U}&999T|FNpcMNHdfCM<7SIKPNeRr0q|+r1&NlOtFkP z4;kXkVfNoBodpy=x+hZ;6hB%Jdd9XVRzCK|DptafABLI0E+ho&a5U4*Ku5$-lF77D zI!9KcNLj_{K_H7fPfj{&vwt0mVHdeQkYimU9x6X zvx`^(F{f_@pFIk38A>Gu6XBvG#4d(2vBffq3tU^<3=IwC0ieZfKbnzM(@E!rh52>R zk7bh#Wg>&uYpD-+JE*R4V|wv}NlC?jRd0 zUY-{Pr0uu$yX%HK7XWWELG$JBQ5ILwFyKI_d7h)8BNU%E$((f@*HNlYOOt7LTH!te_W<;o=gA%5 z8y9-s_EnkGOR?@qSRx2o!_AlePwB{@LdN2*81|9 zi;qc$=^Im<*+q1@$T0Ow%CrZ~IM`(7ZNlRErUtAi{8x8XEv2 z*Ko4jUqvg`MgBY$$eAV#Quxq&B{X?z75g$p0EU%NGtnXnA5Yg7;&cSVXr>V+N;97; zx1WaFx&yfjvPn_^1Z3og2GiBvHTk9~O8NO!3OUgI=**bY9(J+7)%*zE+sQz0`^FHT zQguOE?_Wk?@3@Sg1>NWSR2v^$i%B|)+zNI%xypJ%Vr2?@ z6oy$BbCtXq;$=QjivA!hc)0$g%qHpqFMtOG6~6(-ms8ke)v`k--fwLls`t##DJRf; z0E4!Ehq}DzkKuxriob-h0a&N`o4{+X3-DEsz`cgyvvzBvvMe@rG4`a}4!vb(C`y*@ zyK&zn=B&xkY*#b{usOU<=>Gd@7Rosx^eIg43|!Mm>IfX+dLmCVluFqs0sY{v;@B9U zZLDCrny_htcOtAd!UIAL(t9?yQLd+5-Kym)0M7sR4Z`2O??NTRR~OvbqpuwAYgAcH0eD-oEq)h zw<#Wrxq|RreKPJKl5S9^Xo9;@8=}<&)z?5eE`>XT80UFPSpXZ(|ASt*QdqRTZPqqE z50JEQ_RU_kp&1!zv1gwr{hx^vWNFM*+hWoBTbQAL2RFZXH;zdp4;#1C+?JDh@@Ga{+m0uDl%W8EeW$ zaF@}UiLhn`RX9+3Iiev}SyYoo9$}X33K56k%X!5p)uA{1-D`noc=@0GDVGwb`{x>6 zBe^+0C2JYGt3M@!J+g=O{7oR~$o?B47>JlJXR$4z|0+UzyqGE=X_^n~#F@=l77A5G z)P9(j8D+pc%h^VIn)O@wQI@}{(xOaGt26Dou7WX;fhz%)@_|8rm&!F{`6n9{f%~lc z+XTBnvXOmA2YMD1+!5a*N3CG&zayrw{a59?NpArs^^i`eOO`)?P`|j*XWZUunxY{< zcR=j@NbflbCV||wstprQsja7|&l=~u>|H9IVFwYtFK-leOK>ru%kO74SO>T{aa5%1 z@KNpGNao0OdguDcL9bH@zHX@JV;Oi-kpjKuSy>j`*#{lf$fSQ)c^KnBrR$uq#ZX$?F-C&DNTnbU8GKv^6{hb}ksm||wBGO4PY=sM2Q@2pDHofTpe7;1XbX>pKt6WY$gO&ICLPJ{xeqIMt52Mv;$ zK*qcGV{_lobJ9vICe~wOi=F7Oo@Eu_LZ$WozNqK4h&UDj$5wL##=K$&_KJ01KmqLtX>;(~sgtu7B*P$ung2mrX~%)T1bvJOQRL9as3U?TjYek?ln z@5Tp!4Bj`PpT+%1)OZZEDG|WxD!C?KK^16Gi3XTlc5PRhKpgN45CTBRa3ESS2Dlq> z&3hDyUMkIQEVlFdVCLZELz`Vcsm@7;z(I<+0jaWpam5xbdzW@7G}BxnBmY~O{^=wh zamWBbmkNu&F#0&~8#Kh8009AVkLjoHL+*+~@1#d}LozB))LAWD|BX`pI1paYtnI-Qtrv|ApL;w~UbIN{v-RieK}kws z7$I?u{XbjA-WSo>3}fYxMeBESxWqHBjT+yN*pUSL(*aaW{1GpZZ%__8O%j+_k+WfIef@bYpdr59^3FH8IPX}s5BIP{qHTY4w_DENM5q*F}7?Mm!n0cRlz zji-Yz7jA!O4_(K7iZRn*#rb?SUI=!Lr%?J0=Snk^mij(1?{X{`>(XtB53VSab{ltf z30XaSp28iKTqL;71b5A=TS;M<(nR+T2+ z7Pf%MrK}dsWmf;wK!t$QSf$#TxP^#OWtAnvA zT&j6q9McJegJv9Ww39OXVkHc$z0ShJjoF=%Cz8=Bn=x_j^cd(~ZBA;bTT>U*W*>q% zbcGtt`*rWjoJ_nLw~E;K0opD)o=7xf^MQZT5Ux^`YVt%w-T=c6nUfVs-kSjDw0Mt7Y$_&f8hKF{l*uKy!qz-8zHXUr z0O>1&_)v5IayemhX(|8qtAQurzaMPk(TdS5%Ny;}!j#!Ln()>e^(hl9IT=%nshTr3 z1Q%e_JdH5O>F&d>p)H7bEo$=c<#acG~$uC7r{ z^_&%TU+rB}Na~tAR9tBTC9Ed<-Oi5_XJypi=L-EdXSg3< z$rpCiF@I{JG70$LGd)y%iWjZvZ=Vzbhhf(qGE7WW3AXy(-20z&6iPYcvEvt`yCdf- z)b@n{6(osG!5ew**;w7QjQMxr6ODA-_%u$RJqBY25WS z-rlGHU3w=V#OXfXtJu&GEtJ`Y%j#kDIlWIccyX!3u`n9I z+_=`>>A#Q@_s4_|J09G)9Z*x%xd8quLPE+dhdaz#>mOWi5BZHeR;aeXw?G0;X&J|P zukuG;aZz7XmI#n^bU-}Csr?@cGXLC>@fiAyO^NP>`&YGY2!ZwtBoBJ#HnY$7pS25T z7CD6;PgQ^Hd`$~5w?1+2Y1!~M{agYd62 zAB6MW#I0zgWwl8-l9#?K-xQj^dxH#c^9lHE@1?QLVPod=5m!F8Gk6i09e4swRD4a> zLfYXA3aHeaP8bcxDc%<82V`Jm;9*_XqTuroYGp(toC&;f%Iq%^RDU>I8S2F9HXd}a z-bRqoMbL=+#_~pTS}4JB-o~9qI#6J38JN*~l%GL6!sp1baoK-Y@QtAo3&`O}i%w5(V(G+|5AwBed?62#M%j8J$%}0?twl+ z5cArV46{b_E8Q<#`%<@3v-uDAa1Qi#5pgfKLc4HwFk6FkL?+U&MkmY(^jO=fcNK4S zwA259aVT%xxK{j_hx6d}BDLLDSS_q%Hma*YQOZL+Fs=WZ(I;eHs`p$Sd|(=O#vLMp?Rm%XMl;f+E~ z6I}l}x*1i%6xw!Vdou3VUlII-*)6sQDjbhNu~9iVUOBVmaaBxejpL^WEc`-uw3R{` z)5jEAkV=`xY2K;-pgN@wjemBiH#egw#9ihI_iqTB!>jW*ohWuTGdpWx21)!&awfuE zv}p&LAov)V{#4Uq4|l^AIK?!*nLRE6eF}nPwP~475K>AEcsAXRZ^Gd#H{9(2j&K*?Se?c%J#ao?r{dBO_Nyl4p%NHj-0E0%NZ0dH$0mO!rb zJF1rzf`d2d%2ruHRcSUGP4?TLz;Q1mJWxHL5SPi_s>$n9Y%`Ijb%@~i=@38$lVu{q z&H%f?OrZQo<3Biep$38`jV4ooXkAM!UoR?IE%4D~l0RH)l@k{KwW}*ZnT!-uj zz<7RcE8i0R@HZ9~@e^fg6A?*QgKhvQw+Kf@o763H1E^7h+`iRL2uD-T)^4a?XQM1A5vRv9 z{%d&jqZxuzH&f|FGn7DSggaw+pc5QAB?U|~KsNUzuSfrBcZM4DeoO~6qtEJWw$L|* zhjj+yEg;qWGDY4e4tZN{k8|ER&s11H9)Ty^LX^Pzf3CbQh5K0n)rbS?!8zfva$oC? ziAU1{MGO}RfVoW=|KyQk1N_rcv=}kc)|)hHcOy{DaDf~3H;LE^!5{#Rf&VAel}Xc; zeQ9*O-IpKl{ucwRfj~JE(a`2iNXjpZI58dxNF-WfVB`jO^!%XkQ($hRboDX0 zc2pyV@jy;#-0AMxzu-N_5`kG3uO@pv!HJNa*)erp3lT9$+V!o!(S-fY840>q%8@ic zKea0$f%C4@gJC{pO{uj(h#*1K;~%*VNOl7-gQ~Mhg{(q8WA&PZqs3)5HG2rKYu2-) zoXOrd?mX>OILEH)}*7%mB|4pIhZ$%i^0{z-lHj8+~C(xe{P=Y_zb6rGljMLPTO zX55%sFJA>0i*dJs{_3#u2MMez*wVA<;5n+L_CbnviPm5YsI-(IOl<;ayoVxS@-GGr zl_MndU=fej8hpB&Q0V@S^aE&>#*Y!F?E29_rd*$kLxU*ZR_KIVQ9d}Q0UTN&sa=6) zJ?ivx9?0r76>?{wxD8q~ZgAL61e$avC)(P)>Y8W=2_D`SxQ&=9E3Z^8cT23#0q}jI z>h?(uids&+GRbo$;VL6KI%^Ff&%RTQpucy#KLPoJLtV3wlZ|U5v7g8sPVtKW$4KAn zrS`p^)Hu*~|91MO2V@~l$Q$Ykkq*!S0WS5#-|F9_)g-wRZZP$)aDyHVdnPRS>xoV= ze`c#G_O+=@tzc_SXynglab-XR&{3K;{>lX%Pm_u2w_UHledd2)yqgDp<=iV40zwzv z|9B6#0TE!;mnB%c4-ZV-mk;xyh6AELU z5xoYEu(nIIKQHZxU0J~bNc-iv(`@Ay8oBp2m%vH>Y)_KhZ5n@h+2qNTmSD5Aaa?R=)` zs3X2w!;5nE;%c?}-<6(e^JM^QL?ocSa(xn+_2@)m=@kfF3~31{P!~l!(X^^GbNdLL zWRX6x(p&l0j;SjwLIZozZ}k62evWj9GZY3gH||=haK$$gMA8^$B6%~$TihP+KR#Mv z-kl_HD9iMEtnmZp6q)7aP8-M!{Tt8Vz#IQ2h-##e{XeDOitcp!0$KsB?A2mx-Hp6| zBK@T74O|Q!BlFYR9YvsfjLe!}WzvCRYT5FcoLYCO>E2wsI064+S5 zgWc7FWzN41@l*Bm1LU`IVWi{qvHNQ;xBEI;CL!;L>3esL_1T9D-Cf(mE^cAXGuyBW z8v#bJ{Lj<9_S_M2&^xE%R43xE4Lk8F7SgN`$Voc@ks@Nm?ncbZ3`0u?RbGnorEc9% zy4d@uMk2z)@rvB%#mSs>x&YciHd!Sm@pTpi3(0B{2yP^pB5=O9*On`Yi05%>vqiCiF4 zHU_qW-^`MQz_m>9Zk4=PU*d^_i3}9FmeT%%x$Bj*Ab}E^G+Lm&dfMv>0)Ub}l6k!H zjaN$dVy&S7@Fo!|RB3}?D!XmI3CV!&3M28~j1Wj%&d@o7n;mF{`6KM;<@ht13LF_? z>9q77tT%A<>ya-rvwEeLKcg*<13qtad>Xg8Y*MR;?*7t0g^N>=nNQ;XUNuQ3&-3iM z?b08F+wLuUe*O`Zg&y!|?M9q1^jvyd5auuX**{|uPL5&v@nhT%M7;C6CN7hwxYv9l zU-0&$GaDy^2*Ugnvxlmtv0Jb)zLg$6W)g6+6-6hCmaDG2rZ3$NibbR99@!J~e@-LZ z%STm3gGy{G?-&s>Y}ZPrF|FEpKZihU=8yJ3p=p2QQaK%uL@=83UfU#RPzSy$aKY@X z5{>@TrJ6*h189|Rq)yMA7m*TkH>Cyyf*$&Qj4GK6T|W>=L5R{(z0(j51E==!6uL-) zW*3ijS;sGWnIV9K2x<`7EIIf_Z}g&oQ1VAfgM+I9g&8CR@U`P56_QT% zZxFIS4$LP+=862FR@f>@B$%i%kBYpFH^n{-)1`#7{npy_;+05|3v(I$9P@mkQ0T`u z-ZRTIB;0{7gY=5g&91HLHCs{7mH8{^#QPwDS6v+Ms=XZK|Ayxf6@LX}CJ0m3N44x& z6?KvkHYc}-GeT^VGH39_en!y=>+L<;QV4S)rvI_-9fu7}u}Mhq%f$y{zWq)YBH|E3 zKx!x<0pyH~Q^cdmOG|fsDKT+~D$o`o6xm}nNIu~I zEki35F=?nHuIbyoE`!=22my$Q6)b}abApFcA2ji#ezYm*k%W+beEHJB8knJHf9ru~ z%oi|l9qUzixNL`|h+c^t5Fz(=^xp>f8NK+G^zlKrX?ZR*O&KHxYRkW5+?JbGATD&l z+qP@-w@;3GGiO4pIJvP*^lG-K5jord6~7%pDZMp68xPT%|GkU^movzx4$P#M}s+SBwpIf zALr{=MSeYzR6qJBxa&@N3j}iN&@ni1VTxSQgG zafua<{4rdYk1{wHBoodui&q|od7!Ax(b!MBr1riiFgAihtIIQIqKC^TH!D2GK3QFL z=o8}-vSeHbhYj;bX0kpROX>1gTf=;VJWYx*w`8%e$AV-n6$xqG8s=`TkWr}R`FOVk z>3?#h*-1OvJC>*GINI~Kilav%>Hd3!w{d+bqOlp=(Wc69LQtB=r41-v6sY{6eo_1wAvCVbJq4uBjy&hGevb%ud-@|nZjEsJy^6s&48roz*ALY7w}R)(#yw-FoDxl zaUH}M-C*{mOYuNEZw6_N98u$@YoIaSU=Dy+P)lt?p>x|=hn22W&FZj#H)cG3!bIh&9U0z_AdF|z1tfI#09GL z@}*&a@8-$S3i>n9=G=Y#Ue;k0uw-&w`0z)JJ1Q>@GXx$4vUp6|wc%MC5vrPPXeP~S z6T*c&1*F&VodIIQ+WYGIHd;PCeOP=_lhy&THNREK3Jf*%m%>BQQxk(&KJNNdvkS%R>jj5b|MDr0SCOb$mZ!Vri<16?U=&IsT*ZGtWC z_O4VrPCkH$N9n{gg)ZhH>RuB=s zd(vCE>unG*F{q$j^eic6g{f-UmnX9p*veV;nnnp51YTTBWt19p`Ps8^a)2mG4DG*# z69KEdIj(Hn>#pe^bZ!_83GYx26hP-562+73KaYaH2L4{R;(0kgC|$FJTotzbnSvG0 z_7&JbnF@PEv>k-di6zxO1f061+q9on4uCnfUeM^PLi?vnpO}e5zA%Wu&WZr6ers+K z>;@=%b<$2$UQ*TOq^Yl2$)oPdu;KCW>TR^}aEXfb4V9!L<*_jR-00;Q@OYxeFTjxY zy9ewm&1n<=4y3xsXdt$lCE9?KCb(IN^(W+tJq8kla%SI<@FGCsv#RIvV*^fc&v96% zY9H*DEnkXYD>OJKgv%pCxihW&7)BO46La!N~h-|4BugIFU`S4AWhPQ38VQ_ z5U?8tGy|B{IY)^Y&0CJ#l__dKTjA3dZ{PdS15em_3={lwGAP?fLf=RIXKgeml;~ok zgI%i!SGW3}!w#igl>sx8bL~-4;cPh^upe!o%p2%sq@b+<%QG|%pJEAsElvffLrqzT zusu>z(e+H;B~8-LLgDJYG&ECNqylSNHHAA{CfhL;7(?KvI-wNMgWAKBFM+~-Msksx zQQ8ozsi`0$yf0^mmh4U5fOR;EtN^|q>)a6#UC}AR+joRou9)$@$;wsm{Z|JNl*}NC zRp8Ok?tVL8K^Pq{Um>2xP5m5uW;f6O6 z^qX5>BywKLb`P34J-0$c8WxpRp8WD&FkMQc=d`ePdlKmDfMe4qqP1DsSQg5hHFYG( zKqZ9uyfw>)HfDwRnx`!srwY-1Wns-i`p?8+mJ%J|G=|Lw3+kO@gUC1BKkuGGB%Uin zM}Il;<5T7Xv_S}OXUa@E-x}BX@{^&45JHI_%j$DpF+k(G$62fXI>%vbxNW+bYSdw& zi^)&-sm#yKxKvw7Xp*7%cqSS?UcbxfiJ#Az_&h0lfh zz32L6TyZ)u2db}c&wTMD6M11+#0d^NF5BE{n0ar@=!ujp@0y)E z=KiT4#IQKkYrDW^(iXw?d87At=6)W!zY@-lQTvf?Y~APNZhy5=3qydp2RiGM`Tqy~ zX6osGvPhzsp6^nbd?2e(Ztz+r{?P`sTYYy)1ELY$>|Y&jg~9P{;4(YpP^e=xUy% zPh7Sg-d0|rVUh8+T1&W2598Lw-f=UXTm!Fe*T`OFT@oiP6~HEn|IrcAO)mC&xVF}R zd2FU}7$&C2D<~e){pHE{dN8e`5t~>M(-Y$%HSameau;;|sQ<5dYyXFGYv0c}n=NLF zP);GC9CO|?V=$z*VyFq#NT{TUoCh@-Wpav2BE}@4l*lopkYqc?j#P?t%XC3bQy07b6Yw3>tV=GG{nYt;o-P^d2Xdu(c$h-4;`sViH&kG>> zZR7d}gJdp+rX82tX=Q~dTpmp%4Rctq)tfj7W^$-rYaSoHJgc#^n$^lmn{y!v{1aKLfyPUW zKY@S`09^6sm*l%t-8O0ZzV*m8W}|kn6_qd7a}AvS%5@|w%OiDGBxx(yFk%gf| zV-q4D)X{G0l>;#7thz~-i)Vw_>k#1mWY`D3ui;mNsOFNjvs{}RTa8{v2hj=U_(G>I zxaa`LKElP|uA-fif*LAYsZc+#8gTY`#Z^8*O46eZFEAEAenGOc)pP7&?6~$h2=-yl z=mT@B30A*O@+jNYm})2EqPr0rG5LSgd+6IOnYr;8e|uu)UQ`RbZD_bD&i=2m7TFQT z0RHJ8Z|!8Q^wwdcO+__6w!rb!aP>7L$>K}Q{IFUXuBiOF1L)L>H0AVBi4NMD!U-~7 zG{xwcFxJWF&{VTM&;bs{TV>3I+QSl(&+8nG8Jsp;pF=Ou_sxYZU54nHAM%aX-Pb|e z>n6$^NVg_Q%R|-z_m@h;sYK_u4WzNRQqy)-AM$Wi2)s8vM44;oT`yV8D46~?jSO+2 z$n6}>sg4g@1ud@FEW}4Zu>M{B?&H)3EcPdq<1IXvKJ^VtlG2mEPfS}R7%l2gP+yk zy+3m>C_#+&yDW%cv8ck}2ZFn=cQSIH!oqIm@Co0UB>JmAv1YoZxaOr zL{97(!Uy>PyXiZY!w2zUpN#-)S@?P_8%GV58-`So-{jqix@1clNd++%CN+8ctZDGa z^TXasHf2RChb&xS)Pygc202nE%|sEGvN16tQ51O>h^$|Sa4L-GZ+AMaNbJ1XVq!f< zhm*T#n*8bRR$Z_Gh;$}^A)s7zypW++R+Sd#Q9-e5s+%p^IxAkg@HjZh6% z&|;u@COBwccrEwS=d5vbrB>B6CN=I*Jd04TCI~+{5Kn5WD<}|@i=bSrak#h7WZ2WZ zG~TsUO7BSokruSi=J@KU&R(ri$_Wy8B8p<}EQtuf%$m$R1A&v==`xLy=U{`?4vW8$ zbXP^^@LY4kWM{-^HlYm;1MR)M_zdm_6IiIG?t|h0Oa4UbBIQTad5_OZqQD|kZ&{IsH*|;4=~-KS=fOEYw_ahSF!WvAsUAqI+>+TJ(`tJbj&K*;Q2PKX zrzus@iL}KZPCQmW#dBaN_+5nSEhf&{e8P{&Ep-2mv)t(cLI_RJtBNL-MM_FLJhs9l zRvd|O2bJ=669fZUCwyfWXCl{hZ>du2(vYABvA_dRQ5Pk@pudg$=hy7=aWqr&F-|E+ z+))-kxpt5iW%mkHwDh?zph&Kt78~gf4V388x#CErTOkaMheF&2x8llqwAB~Rgxf)NY*GF8V*h0qfpD;|#>Zsbh zj+hhzpeEP~l*ywL0`#d5wcqoCgleL46}odX_FW4g^rQ=#Fj3htjKQEefrYcL(-I)Dft(Uo zCVj7~9@g>#S0j?FoV6F|keKN8WkR0-(k+u*X_Vg!r)c%OmOfX*+Y()@xN8SjO*hSZ zhKJG>Wzoig8|AVLsJ12Nlyra2(q4e8VzYaPN~d{OPEqle?eL}>YsmW~LT$A$1v zBtB4#kB>}V)$AJ{L%uS$LaA;bXLorm;ly5d5EbW8aEX|MoWFY?6EtmR*iOoqOMQ3uIx*k0GPIgb}>z2=AMDF)Ko?ve*?WraYwXXp)5k9j#kv;FL|)_v#Jtv zic%wz3(B~4n0xa7&k0T$r9{SF(>w+q*y{5$MkCTi65J;sqRKwtrF6yL{$-1h*G*F8 zU95KEAZWjm^kVkLeb5?+iFVH=T=jYcecDv_(uuRoxTd+~wRe--4oY4<4zLy8* zOk6>}7A6>V>RMob<_CCg04jo*9mdbwKV{#s-hO*1|H&fsboZmUUv+=#O!)@+Py*l-h9)W~l?|ysO(H*L=Y*>m)tL8TNLwSGW;NIAT!m3G%9F(OXOV zJ%_zB6@xB8jeiNIHd_vS#{vA3-NF@fl|j|<+TllMRaFlHXt?4s8osrf(Y=sP(NpRr z^6`{H0xB)cYq&uO4As%Z=klOb+01LdN&ZMFv~jyyzR+uN%R~+D*Gk^7Hk_%e3^0^Z zkwWBHige$NDJU^oQeVi<_z+?OSu3}x!|O72mW=_vg$3if@9lmC-5YduWN$cat))I# zIA!CpTPn^YNjVLmgkb+^qyY4m2{w+Ses=8ve=QeJpEq8u1|Dzu80Ea-Yw^+8-qJVv v{^0Y#W>PNuQQXhFfq6H9+We0^)+1}8Cm9_UaWUQ|2t0dj9Z1F29x?v~b9rA- literal 0 HcmV?d00001 diff --git a/README.md b/README.md index 36580e66f0..7f447c1ae2 100644 --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ -![FATES_logo](https://user-images.githubusercontent.com/10852790/159047944-ddf920d0-62f7-45a4-ad58-bcee2daada19.png) +![FATES_logo](.github/images/fates_logo.png) ------------------------------ [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.3825473.svg)](https://doi.org/10.5281/zenodo.3825473) From 0e093bdfe5c423b5641e20624502faf6054840c5 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 21 Mar 2022 11:26:44 -0700 Subject: [PATCH 547/578] adding different size logos --- .../{fates_logo.png => logo_fates_large.png} | Bin .github/images/logo_fates_medium.png | Bin 0 -> 40574 bytes .github/images/logo_fates_small.png | Bin 0 -> 26080 bytes README.md | 2 +- 4 files changed, 1 insertion(+), 1 deletion(-) rename .github/images/{fates_logo.png => logo_fates_large.png} (100%) create mode 100644 .github/images/logo_fates_medium.png create mode 100644 .github/images/logo_fates_small.png diff --git a/.github/images/fates_logo.png b/.github/images/logo_fates_large.png similarity index 100% rename from .github/images/fates_logo.png rename to .github/images/logo_fates_large.png diff --git a/.github/images/logo_fates_medium.png b/.github/images/logo_fates_medium.png new file mode 100644 index 0000000000000000000000000000000000000000..32a1473b5e9e866b12c7c844d69050eac9a8a31b GIT binary patch literal 40574 zcma%hWmsF!6K-&a;10pvp?Gn3hvHhaxLa^5?k>e$io3fMFHqcFic4>P|NGqU_eoAZ z?CzNzd1v0qIUA*_EQ5wjgbV-x(Bxz#)d2t~H^^0i2oD*_9h@!#09X-xG;QKVliKJNn4|^GM0XiMC=mC<48@$jQ6^y~DnnCiP+rMFwQP=jXq3K062W<_Ba> zzU+zLZ~X(M8297{Y|?&wjGVk??yU#D^+&#|#NWO9UR^%s%`QwEWd3@IE$98cGivEo z$Z>G;{^dYr&vEDO;RE%KD1D@FctHQ7_i68=mHdM) zaHCs61IO>*)Pgq(3GNE21XEd{H!cd+rRSfC>}~SEp2@2~e34K_Cf!YLPckQ;SAzlh zCzh6Z{iC5XWO5M(9E0^O6n3eNPIiKU&mkNXsj4B494)|%(HUqZY30w7=5XQ+&Rk;| z8kN7ASASeiU;Vr`B37tY+k(&5jZCt&t)7-m9-e3iim-T^S*K~bFqEWecQE~!%CfC3 zSzfCY{noPR!c^0;>_hDEu;|Lx{jlsy?jOg8MW8E9>hPCiB(t=~%X!ycBHllo7qYTc3R4Qi z_`141Z&+i^y&2t9fl{0p4nZs_!)%?Su zKV7jw7tFMkG*e;l?chst{zXnIG6tFS=Qrf|v<%{756x-q%LXe`TSFTAKshI1N{oo?IUe-x>qDIfJdg>YDZC62RP^Wn1^m1O(8%2EHDDT*CFf5@=r$-{y0mQ{ty( zCTB#OP$f>^-dx9An~0j0$Qd|V&eP<7)6GPz3M#L3-m+YlI>()=q;bUgmyY~&O z0kG^#m${KXUt~{=Up!p^mYc)4z^geimi+rIP*JUUFp>7Pf^2%mYL1g^-}*_h$rC-E zi(Z+r*qD1&qfMD<<4%~;y`&9`|Dd;F3i3e*U&kD0n(n=H%hKkVE0SfD8&JD;vxfEi zO#AB*)(?QYQ8;tkRM@qBuaR8g!C^c7Wa{o-QLgHQ_R(RBXe~`BUxcg7=}L2rx8>R? z6Bou#0@e=0;0a*`L91DVmlcYCG7qelMGmmqF5TK2XI>1Fp8q{H)VrYbOJ`BUUy=x| zQAc2UIj55Wv<52kqR!D&KW2*W9J;8B0GwxAf{6GoUC#WnSW$EG282?BZ?Jp6tqd$* z)?~VyYUHO1pCa9h>PvXAuI1@p{4JD!+ScMof~?P*-A zz3`KK<9&H)Xoroj$!5*!jzSh9rud^27FaNr8GbFD#+@v%%(H_(>fbDD6*mhX)V?EZ zLpi+wvOKA%iByTFB^<8d`cWj07)uT8qS8(+o{!9u%=oi!s3J$ZnOR!rxA=*%YY&Lc zFk#HU-9vNiW2=2)_JwKrG5rOBum6bZJ4|xOJgIEPd#!Xp3tCfp^rnYKwa!#L(z
J z4}sC+{T8ns%O&bKjGM<{hJ=R)I5>G@{AQJ)1dMKqh6~}YngndL1h{El?xND!0O!B%U2Eb+t@|ZU8 z*RC}`xJ|_$TVlg(0LVCfTTF3Lg^iL2)DaP+A#t~CV{#lmT2s^j~ zNrjY}B&P+q^qJG6G3~fb@}E#RC`1Dr)q9LzyV;#K${0&fTsomoGLMgvU#gL~U3l1W z$H`{(N_+-CdksFt=ta74omst_eXIhp!p~dxZ)tp#&45*fpXxZpTmvXfhRKPHYh)MA z8vSMpy!Rux1rVN@yZD4r&|w#Q z#F~Qf!v4cd+4j1VFMQ@QGQnzrK%&2WJ@hPF=evDZ%@q zAMH9SRCpg+&%-DQYGF=UDgK@js6(M{LY*|8_N9itG`d*j`v#Edd##o+d|fYwDz^7> zyYHF4#RjEvaqRVTgS@#SJ=-((>kf2+RP%mNFH}t-M&``oo}cM>$6?L2($`|8+CM@6 z#6s=)P!Wug+S;UhMX7Xxak(z{3nGL&>XA+&jWe-f1`$9O`r8OnGGCe-8fLk&Qlp!WW{ zn)D8^{4V)M+bx$ET}HvhT>n742wDNN=D<)+-O~A-27<^!!39gZ93(5p^dN0(YK%RJ z(oP;KuQ9B&Kt?$M>gY{$b!+kbsZrJiiGsx#wCiD(pK6s^-&;O?LdGQ4V#mTNP$;ll z%q^NL-k&2TCSFuUnNm0foT=&N?qraH134%9VSaQa=6Ydb{l=(I=oF)MvDuy)nG2of zI|UNN89I^8{gA0HihntDx0ca^KL2!hzaOM(qVAlWxZz*|)FElBADS>3TG&K&yMjh4 zmd%45l_y;)LCmJ?mq6#hr)E}PR9CcaO5`nIEDW0KHW$1$<>WCj zuDd0XY5ZAF0NPCo9c~XDe_}cbZzXO>Y6Pb2(lg_20ag6ax zuTSQ9#Hp7>Q&@J%8j9_qdlFElVVGAn0xmma=uejC;DWzJBE`-l-+{{yE$c~^@lk^9 zOjxAt0Nx$3+oDaIJ=j zRDLJL`F+Ud8Q!SgpA1~M6nWfL&X$)Jc97`W5wAWrof6p#^MgyYn7GGSoUgC+IpHQ_ znAL8)9#a_iUwpkJ_y>vtdMU%_<6gH}Av%;6XB#!jantCQa~&L#Lh`oM5p?eIP&bc_ zfQBh?Hc8B6$?x(BL2-DZd zvfl`z&OEd8Ev-l4rCf=~7GSve8nAoO36lB;T&tv%09~_AUFbg#PXaMO85d zLUEbu^h;23qoHI7had|9p{qn?#NrLxJ8i@6DbsvMU&Z3_x!`>$u~?}E;?q;B^LfN~E@&;^lx9LKfJzd%C*35Sz|g?EKnpB_!M-yRe@;FwnL;v+Au9~RGNQ&u zcnH>yd}a;b)hAtb+vgu7fuGC%$pH3&eJvL(4(;%MotN4!fcShwyGjG zHKTDl-5U%Z71v>Fb}!GJ>%b|8hZ>rnD=K1lV`>}W;_Z`R2&N$; z-VfgUH6+XErZ5fvoQ!!58@I!%f90^!nvE;;2 ztius=b{$eC?My6y;m&-k%@v~0i9b5ERCKo)fS8bE0;nuz9rbiX_$#8w7ZyzsTQs%* zT;hmc1BlTdS2Wq|tBqO({seG@5@ko?{f%xjhR@i;iS0vV=YkB!8dVwA-45^b>auNz zXTFOtHayQUzcyz|T3-g1#?Pro4RtIyLFjhrNE~msyi<{fgQA6k5{6;C| zPp$bfo_Bfdhs0g*cVKZEUkdPm8nvhB^c*2F5+&(rKi436uW6S?d=vZ zS}>Z4OZm4|<*`quE{8cL$~+vO47@|*fRbhg4l(6eu#Z$n{&P!gJJi$C+N=ngy~dk5 z&BF+sv=M$KlGn>7o>qoyRz;#()oezY*;XkBzrx|YtJPbGu~G`A6yG9WO|4Pr3v)4y z7Jc#5elG<>?N*y$Heu}_Vv2Q_50L$QTbmVo0-dDIZGfX%6D5_=CCNQ7VvhUw7LyT! z3RHJUR_3(glU@OrJI!JbTq8j(Q7HMg&Qt{ADli{V<&R7u=g>K~$T@y}yrGh?3gWJ3 z;qU<89H+ga9y;tlpo6ZerPbCwuK*P-m07d@~Wb>Vq zMgrNw8i&Th3yk`#m>+%K%w*Nc>IY_w^}u>Op=F*#RU-Vg$905H@I5EvOaJj zJm-0C$&KWX6* z(urgPaAom*9xC`Pu0)-8<>AY+ER!R5mzmC0XUkBk-y^X?Hz+S^? z%IW#phAPQxPJ1g57KJ#<`CS00zVo>yHrFfxhRHOxXbR%LK5`;wXHT#kjQVHD#Xn5v z|AFPnEC)k9%BVzht%#=MZxm1pPsSGCF&e}8GC~!6zOiPE?e?$!Vp*qSg?k+=swyeD zIMW*bNnGoWk)|Ux$0)v2A@QxM7kT8!MROut#R%OavRDP-G)^PltXP5-nq?JLTvHJ#QJ=GZ0Cr2gfX|gg_Va%qARBTxO zw7^=HRiIrYXrz`aL7$6&nP&|NE?BaHat~_iMMpz3*2#LwT$b^{Qk};Jdv?BT|J;iF zii?N(=jqYkhl?w5Xwm-hHGjdZa>WZ4@l>g9NyB@aUxhb;m(xl}7#mQ#*eCY1@F+^1 zWOyd@8Y`q$GnDLdCYn}EV{^M?8SZ+isPnO>E|<8nP%f&I%-AAZW9|!9YM|P2T8oP4 z%(1c%1K9#-Cf+D0yrP!x#>y@ULke2caMg@!2{{dxbNbtD`EeSSWGPGJsS1q`E-X^g zvnr7%8)6Ilh(ZMKaDjipXj%0XZe9dP!9e8dtay(-J?WGcvdq;!5kJ{pv&uy&=cRGz zSYT-a&b;8^sU1f%|ClnU3V>d2g83)=d?s|V-{w{nH!&)jyKIfrB@%l4iiD@hq58EMe~JFDXn_VbJjJtoj?72RynBDk5V>KoD`CujEa z`davMsuT^wwhaYx7cCg-&_HoPi((%%hy6UPf_c7%C7ykil)>l(6(G+36>kXULF*Qa zK#d2O7$t<`Q1xEUE|sC4>fT)l&_!FYuj&ug`GJc*^gWTPiftz>=JRyo#;O%m|G;|D z7YoAi*cDx_rArI>Gq1OGHUMR*2qUfO^}hbmvNq*QWMYujeySO2h2%E*lK&FN56&?> zSM1l}4F5%tX?ndbael`VbPy5HG()3lVLx0e7K<;x;;U{s_dQ8a0y_2WJ}0biBwuaQq+4s9LGqv8F~UkI#!0cOpbKfq7){XGD}`x z1pidHi?0t6_P5a%Awl&$USn*ei5c+(F!M2FkxqkrNJJy+Vl`tBeiLb2_USdB0PFBQ zofDrWToWvAn_*;yX2Q-a7|ZPvPv1) zOd2XM^sS8wPo50 zir~dT{c&2I0lp`Ktw$%^35x0JhIw2w-YFChn?wN%I^Q6Q{>4Ox(Y!xccPKm*;;VKa zZ)Rdc5i!LA<_WTcVJOYs`WA?BOCu%ONNYx*WJ#aU38&zgK&18OwS)wOy?T;pprk*A zd1a;V)zvTZ3F?yEA&x`gD7J0#%+1~|$X4RH9Mq*@IRNRWPwmL%Hk1?=JTA=df61&) zD_dzKd3?Pyy$!I>I)dI~P1M{m%L4P2CppJXM>~ChfB7vifIE%q`SIpjF6-cbvmX^P zG+O?wFLSCJp7G#v(JC8Wzy}-!+D;wmOKC5%Yok6-Cc~ai^DmYlR8%zX2T>erV;ZGh zF=->gA9htS;lwHzZ#lK3x$>ZEyUL5)4$@%47qJDijGwdPgIqdt4m^f6m`|m2UYjGX zv_9}zOVk|lyzWASQjPPqww;wR35ZD~F)z!Jl+BG52EX^z9ap5iNqLCi_4q}l&hG!;ye*QWqsu(oUEh(Qg2frk0V`2T`x> z+46vU>4>l@aYS&QevE&i;!tf8* zsz&DKP6_={IcS3kQI+2BiOL^e`3MCaM4{AS)T$5;2ob!9H9tg=6KJ1)%*!Dd4B{a> z-tYOPJAO;!v}#>+d}KU7{o?KJZUOXQfsv|PCQW82X^s$zqimH^0QbPBH&zGtc96vL z<)y;6EV7OllLh|VYFqj!&0@wn!~Mz*b9}yxnv#0?#RcXD)CDGpaEf@;hxq7~RP@;j#&nZJP~oS2)82?D$NzJVVtpy*_dkdLmHTwa3^I0CK9~O&n+-x_cg=8vz7BCzsI}0 z@|Rw~@#uB_4tC}Z<95IeKRbKoP|6ZHR8gznV<7OBF4Kz0U;O3%yW(R&I;LMlxl#D1INF^i=vkD{ zX-Ry>bhWE;SgD!hXD8JmXB;rH5(-|9Puo4dnB5rLKw}h3!_QT{ioBmFlM+Xlf1k9U z@TLzq>WnSYU)9k#Nrtal$umEXB<~q9tm@Xh~JbmWKG*!@&auv!x6+x?f`7@)Kd@-lb zJmu7~98GibHalhVkbNan-_NhXl8C+-LO<4a|KPIh(lDBlBrB7F+LtF3JNbmZO5ZjkB(Yfdotc^yDw?5Aj@EKP*z9O%ddBa6cP>7cBILkLxLK6S@D zq8dIg`Kd@*G?FKFjvNTv&wf!TfwwlIV*6Lx_`cxsr#?@`B#*s{W*}QmA*Dzqaq_gg zLvj3%0q{~@hFWojs!xW_!K)8zSO<^P9Xr07nX}ufmsf5#$c(Eeyh3d<{XyhSl~CjJ zw@OUdVzGY>2Kl8*&Epl%2&Ga;i5Oh&Azv`#ytp+S=OuM3p7}%np2~{fBzHYbxQWXs zI^BH)bG6U;M2JVpbGI zR8N~Jo_4>T7HB!hfQgR725-jgq)nU2u3-F10yRmDG|lOBjx-o;AbK z6bXeo$0g%8Af4aYeJrGm^4-2IcV$`O(Bz;ywKmAT(L0TTx>GCb8&0sgQt>YFUmOWm zq|&HD@9Q&$wa^1Rjwu1+E*mFqjW<_Smjz1GU86x8h)VL*`6I4Se0~r zVpm% z{#f0O0IIfGf6xTfgI3!0#X{v(b!C&f`}Oxo)uX|sv~YuQASw2;1SvJH*e|`HO841) z5vnN};XBE;JS^GtS26q25ZqzzN@K0{p?zY$q7V$Z>>Yd`{EJ*%qI5i2!@oZ&X3N=w z^z=8yfGP9q{D%Un_NryDFJ$l%MeCY(2xEg>T`+(rL-=*KE<_E4Qzg=P>ZIr|65$IC zyyonrI8;yQoOpMz4_(vP%}yjIWX;P#Y#Yq%_>p*8RX?|)RTXsq0KO*>5E$!*14dg5 zHE{$XJi2`eh?q1VX=m#N{6N+AHN0Zt&MU_auP7-c4x$Kw6@#32(tI9m=TRs&F zfme&7DP2O<^j%GD(n)HNhs(9y1*5<5?ISTC>^zln2?-&8=-$$wI1$a=&RiyD#w?mv z>ek)b`nMZ;K|6(rMYy1?TVpZ6-Bi`6;qHS_Qxvu6$oR|T*XF|~bx)zQ)Zl=$$ZFRY z;)e~JnDB|RYQ|fPU`0^Ot-87Mqd*PkFZmcJnf~UQ8M_fZR&}XvL)9k9{y$G2$bHm` z3*LsBmQ~n(Rle;-@coKfI-7DqyA+8P%3#Ffq?J4!GD^w;Gjw6_wKk8wLv5dM+GQ&6 z(fE4^NlK*8{RUGsozi6``e1R(V10yiVb^Jn$DacfWGu$# zE!HF0p2~YJTx)IzpGrV&sVwQMwoJWz&Z&}FBCgBY{+uc1#d#6E=3^Z_cbNkkt$U)0 z!aYqtMN^UmSpw~_LTrZ#v#m_R*Oc>}lGa0PMACajr@BYnWiE)qA$$KgmJO*T4G}Z(o zrCzvKbw6yz5;WC?q1G#E%i(ScGd>&Ye=TU2lkSRm>1bv+Ub@RmQa;)aakIw3a}(gr zaMg@I^tu0AjCY|(B%K12JZZ0ZjGzC^aCSQ!|H9hf^DgMwC9tg$O+tn&f}T(jn1G;X zn-vD%)e&c^c|JO8{Cq<^R}5DGcMLs1^2R1p*W|WVwJ67mThiLW@$;@cFDLYjOd$W0 zrt4OIJ>`I-?g1CniNJksZzySgDB9Xo_TA;@S(HJ!w%;|j?+bAuw#n;hLUW5^IHVRJ zftWp=mgs}io7`@#d(X&CjTX96;+-h0bgebQ8$Cijn^QKbw}@kvuais+1I5%k6v#+T z9qwb9h&tY`{#c;i&60+OS)t&Ev0cB23dHwhB5-9IvyRz$U+r3b~k7f z@SKzL^6!`8a13}}Ab6#)w%f;2Hopdj)#nkXIqS~LajnyqK{D^_lU!%Bmf8VTmellg zB{DP)2Opw)dD8S3%?81$T4+v6QvM-=pM!K#R0wL$uxQn3qrnyFX0u#>3)Cu69@SAC&!Cf-8Lx9XRCwWeS0Wo*G}x_NQdDKFJMAkZVDQm|_$zz`CRUH39GZ|j zIIl-)Q{-_{z$xy}cN93e7t1BFL&uI0wNH5Zq=o&v;AXzXY_IyPE=vN!)yMy}&Z$%MxUia9b5#%dg$b(!aHmynmSp3EMZ zr0c{h+J2B3u~3aA8+G%@#z_b>9W|f%SQTh?TOugx%TaM+WIspyR(8@ZtxRLED5(`T zvvvQ9nIYtM-#GoFdJ2$~Ppy#ah7-C_t&#G-IW_+UzsIv`ITFLKR4SHKQa7yWSnO2% zyCYbEc+$2`LW@$uIC%!qXOwnngM8p8jS~IP3WL~1G4#827nT+m?XG=HC(+!P)RX)u zLX|)f5UDaS{NCnM1m>e%G(n{pbm9>yNt?QmfA3xP6)I|%itdqOhbYda=<_K%JiMS4 zQ!85D+QzoI#P9k&UL>0#d0x|5m&&1+7`uvU`(VBR%=W9#qWHa)** zqR#^@W_Me6>XhU>tlnlUR9|0&?(TUu+f;#mJ9A%0l-;l(aaOr5F)3igewZ3h0#2mw4$0%njxRgh!W`AjH=X1Z=SpP>eXtce0QeD*C6C zS-DkrrqcaZZ_flTg_5ItG0Y}XdRc3=I51>OV7+i!WyF`7t!fidQi|}9tf8uOO`|rd~^GnFeI7M!n)c;Tlei{8ngbjp678~ejuM`G0%(jt9)2b{q*sD5id&uw6}B4Ql7oQlzDZRk7SYsCv1gy zin?Khgt4A60(XIb(bq7rX6@vCF?1r3i}O0!?r~p>ial7ST3UWFrfMMB(Gah$MjP39|C;tZc{Y&xoNGz)tpPu zOyf-`dckPa8fsKi33HRO8t~Vg)GOa?=hpJyHUHX%?9^6LUIqd#TPFs&JvE*n=fgv7 zBqUVjBqaXdk#NXC@Erd{Vc9`Zl3`w7RQ znp||ukL@o`*X9kU+q>0OAypv605G2bKSPIX)IS9j7BeBf%h68X_)br-DhubdEinT3 zpHJ8gg>ord--NY5rM04wz#9upFMKckhTNiYyXz^YQkB4 zmaF4#zQ&wuLNhSn<*~$Q+kk@4NBx~*IIf~GW)<|v^-{_`=ZWH0yX0$kzV{bOR$b?Y zczYX2Fs=5`G1@8k#rO45@kcK?_moSV{#INhfs7zI$?CZR z04Ui1T~L6m90JH7f}5O@6v814E*1gq#zg2P0008WNs4KDt)1ukdTA~#{p)?55`JWY zO%iPjuPWHU)&vz6nIIfsmFwEX)U~YXyjJ-yefRHgrM8ZVW@-6iQ-T{NMky&(h!r9a zO+O};Kn;rs1ci!zOSa%lZwd^Yazc^=AvMiTQJ*c0mSJ!uH+^0HedN2W=X=o%2nHek z|9|tTsCXG7t3};#2{OUQ-<< z66n=@KqypOc94I5X7U@gUIYju7xX4J=9)wYrHfv#RudTQ2v<)pOjDP_ES*q*9U9-j zO;^ziYXb*9ad=B+1plKIrg7xaiwB9(A(ET?J{mVQ7{CGxLy7+Rpt`nq@>cUXok4D- z6$@4d8c}l5d1LmaK}B{9OK3TbiEx$d2a0Rc$j%{&i*dHlpqVRvfiubZ8b7tQixoJ+ z&A%nCP5a*@=#qPg2Jp%vfMaBX9Y%61q#^$i(8%|nOlT*|x_VwHYDV@Pn7*rd4UcNj zBsTRi><$H|OLB0=l#vUY4V#~BKsDN9OpdYY=+96PF=PT%ut)-8Ka+>s zsTKwJkNLqY;cdF!z6C(k|HNNBP9*OETF^xs>->4qzl9IstKt1`f|r7d&W0%DFY7nq zI)mbBa`@5nzl&Ya0_OioGl&ozYQ!;_eHqtjaT>d`p~Cu4)=EOVgE&scPjnN8fQKbg zKp+Ria}2ps!LYfi_`>-oig5 zw~89_0ff1F1M8|GDB^k?vvNkzBg-CG90*`%)cIDz^`!7$ziGxK=sI98hi8`nzU9du zk|+^EqbW(fVKbi~YPfyb(0>wvTK$vzRwe-WnEad4rRBDa;N9|>Am_;5ki?BsgMwd&h8ok{vd&-){XcPj2E*^tPZJrw_#$rWEUaM z94H&!SpUt82mV*eLhQrolB7;p+ z8(WqWFykk~f9Yt24e{TOFvskF$>>Ae*R}N8glzDk=VSX(sxPc+rF^>pc*X9*(6;Fg0e#TO#X2;DEqYZ zp*LaHo2U!4h7D8*qVb$Q!;3a}2H__P_${?@t4N6rya3*X0enXl%sza72@Cy+ z>B~A8bnY0hYa%GG0;Yi)WK_2IkqUI1J_U!!9HIP3#{}l}^F*`&m(`(Su@9T%WK)QuD5QqavFnse zMO}+=MEHIEYTJ7l=I4(PAv6MsQN9%$1c%Ol40CI=Wv7_>p5Jq8(ybs?+k*co_fssP z&Lb>dL_$zd`^cJ#+zfg1gD|gghb-`ebV1`bE#z(mm!z?msXGN!>pl}%%X~Ot+3fVZ z^LO!$$FQ%I7>A{M@&G|-sXGe7AJ>lBjFgAlgoa{MP+++@IKZriQ(r4rt5Rf9gHx;0#A)m2uy~s@41F@y;3&zfUQ4U-98+Yf1@~Aj{O!4&oNLWaV)-84t1Y zSC-E06oZV0Khmc?k4h&-*8xP;MHgk$o!&ZS zj49x~UoUghevzY(5n_Z%Q4r>NW0Ue8CmI)f@=sLQ`?negcfmw+*Dl4#;T zvjku!KdYd_T&MI=Fq8OU>UF$x%cmUxJeb%Qn|_9*Ks1JRiV{XET*7&dDNX6ZYIJ+` zcD{v*n94zcibRiqg|bJ|%Yn@WUA;-01+=L(s%lTNTo0t=!pVmk5v;PM9a7)Z#UvMC z2b|@aC+c32#P{+&gF~48?b;lpizL`=kZ2Z9m6YwP zWfet?t)_8*=dd9U{n|a&TDCC4b~}e8ayMgnPw8xij)JgcdqaI`SX@W%)Xqj>_un={ z|5Z@1FpE=UIwYShEo?AE7!~4Z0P?UH=2KI0L~_ftVsvk?H6+|HyB=X_?BhK-)#u&@ zHD~)<^iF35x&lZ7JG^;htFA?H)BJ&n9;DHOkn}?8)9&XQk|kt=kPvx7X0i}bAD>u+ zh>85PzLGXx%v6qwg#EfeGxc?;%72ydt|yd5+rQ;h6qj9A13-MSiNY<+ zo;i8dN)QqwxYQgTmGVA1VenobpFrL!F#Ih^xgasvrqP|i{J#YP{MJNZ-P;*Kj9Poj zkH*zbc;BS|&E$#DjR_uk@8|k1D0p@uZD;gRgj;=6$dgTjIK(fsgdcksut6m`1GOf( zZ^@SH+LO}d77W`xnImcgHN+fF_NipwffB{{`K^-V4D>1O+tkJSexlG9PGGTL7*Hn_1767o`Z*ALEV;!FZE-7x2q6rz!#UXdbB{;>T zI(wu2ULIxB9dAI|RVVnr6H#qWC|l>O>+(B1TS*ZlJ7g$D`nhQWMZhq@=;YZDKFh2APe-bgyvG8*z^ngy zE(`tM+l8=HE0g^a2%vYzA)rO0h-H3)Z>$ZZkl2U*gapB8VW{V4i9WH};0Z2p;M=itv+fF(7s;-I4FY76(Ast zAC(lAcsHIKz98SmI`{!mGH>L9;r`*;v_{dzp6cv{_k`iu7m$PR_9SOv3JKi87$qnA zQ~IJ+T-V=hA>5=0;wM1atruw2_#w@oA}`tt$lWCsXs=m$in zNgBv@jy2|{y^9}G5d7cGuiFY-$Ec5U(}jbD{(V?{!E)POW}{X)0tix%x96X)$$drH zi+~koN{YB-Q@OW*-lG1ml^j>EiNNp${l^M8Cqov8iq&x2H`OW971|Q9L*o*30?`Rm z&^-~T>nE6v=9)*SilBw00&LPiFRXgd1bU*Opy0p&D~=3=?*#mw5hL|oXf@ut?q*3S zczpO^{!?s-W&1fHW@=pG>W$2&0faymXAg;|8;J^=kr8*vWi_bD!$Vl6p@1s6;1$Z2 zGw7<}{BEBe-R#*E7e?|8XvPc2qN2E@cQQ+)pqT3|U_@#X95TG{znl(=TXaxz_UHpQTbs+&00Mw@L|2aFA91OSp6F~-(>3jpT%)+W<%5X&q!HkcAGyul7vu4hbk|eY{_>`Bd>Ad_bozzUOhRTxcH5M!h9a;$M zW1hfCTHrk8AiNZ`^F{abBZ>w-Ix4pv_O22~HHrRhTT`WO7|wQ@`}K)tDyMc7-mu*OO8?-N}_kHz>ctNP-RxNJb>Dk5wM`X>e96Z zytMyQXeYUI@_oYtL_nSI^aVJzj214COav6fLub3{5(*iYa3$3$K#1F%+RI=D_jZol zz!+zck9^j^-C7!&0FAHHv)`2f)`SG?JjL>tD0^C9-JlJ>4;}qHnAu?#;z0SnRdI1K zNYCpGsp}Q97Bvv9#WIRt~bq)Qb2B_{C z?>vtJ@r&W?e%$||=`4fdYMKSScyM=z00|m=aSIR}f(Do1?(XguB)9~3ch}(Vu)yL@ za9H5(`&Hel^Y7HDnlm%q)ADpr9?v7eT~+u88luo zw_eBOGWA?Q_50>GS~`p&fA3$^2bO+-AT^BA1P|fGK`%NpkEy+Rc z^Ltq@9fVDkD}NZsO;^TDwsI2R#umU40XprA`DO;H#)e6t7xyKOnVnP zUM@st*h4A)9z8hszFO-tnu-JutZp%~026@0-=CFsa$2TKYlTJ$d!c9^S)GpkdX9q)shO^%7qOV0&w+YlMVC&E1POg)b|hw>WnguE9TTkM-3r%}V4!?|#W^T%X3 zh7)2^&>_B}x%)u)0ze8&RMkg(<_p>hRALXb)VY5H=m1g)+!3ccS=_6{Cw4~PpvKV0 zy$}#G|KpuybmMXWbPb594K&loh*FaiaBX)6p5VquQQ(o=r;$BpEruVR0C=+yPzmvbwQVML0gW3Q?4iCG!qf~6cg^`mb?nae7Nxubh?Ihr9`aObNdmD`@-C0o>e0VH-l1BCWPP z&W%O%RJIC%&Eb08O(b=jTpAlfokYn}V}xpA8qT1Ed~c+1r42kv5sgIcPZzLOVB#;x z)$jcEAKv!E8V6;TyP+m=Czj!*hu}7>@anImme=Ry<=-)2;*q?@iL*tQ(BwS#qN_1E zG>=MXz=|ng6X51(NEmJPjkmEK59neB? zknlAzz#oU|2v`2IXGgXFrVWQMMr}{v&7`4+APa4#@%ewJ^XfrA0zm)t=MFwofFOnq z+~GQT*5!j*)=RW6Q%TwagE^x8LU?c3Uou8}`QEd9>N}uxng2(MhDbdKN zU7CaWoS)078-W&Z$>^YFhK z=<$PEgL_*9kf$I-{r%wSXQeOWESBqe?xDU7nT1Xmy30Ov!dPoIbklovcT$eC_ZY|# zuaJ?}4-&Ek1iO@9dMM~nBP0-!Y(RRaQX*qAdI?uviMzRJ3 z8f7P{&sQ`+XJhS^&%f4#5;RwlJYxgNNxZYV3A{;yxA)L|Y04enH(#*k&u>#6XyFi3 zhu|5^ARb5WoqzGFvv=(XTLWN}V2Rcc#SGB5v0;KJw!YsfHCURVg0Gp0wYWrRGi9HW z^4w8sATogQZ4lq227nL1^Eat+e}E4zL{RqqZPV0J*Z-fo-ZwF&s=@r`iaP&giw(1` z4;>PrEGb7Phh0LYw=GCYqYT$?_%oH`~}I7*)(gh;CA>9itj7P3)uoZ$d}em#20 zzNGjuK@s~_8&&d z!tAQzocoppA^+@L-F@sL?V!=F?M8{{LiGI7T1%t4GHityv}++J3V<<2<}MqEGnbb> zK{g@$;zj=ndaB7MY4$aF>?`d7v<8UQspfEdQs4dVrjxPt|4o;!bRk=%%yT321?Ouc zSx2B_Gr(cHNTH@E^e->^Dxc378|ZQ6oV6jT-%|-{@;{H&JzH05&Al*Lq;KqM=`e+X zb5rVUpY?rRG)n2>3em$V81Z$(!!I_2Yp+xl*hm=QOaSHpbF%z)VM3F=Ev4yp>tho8 z+?kk-KUDN`O|TeU+(M=!ji&~>nRYRWL;}mhCTf8<;qx2~BGijmaJJ0tchVr4n7@}O z|DwJ+Aoem&t(;W0!O8t1^SCZ=@zW%J+@~~YZ-YAA4XjqEb(7%NhpjzT3Rz0^P zqTYqY%vTE{iJ=a&g8znb)~t(vDEc?@_fCm6{>^Tfg-!MGQt>5zSp)TX;Q0)aT7JGt z{B|$D+G5D|)q@Gu&9GVSAtQ!uHewurSP`hQ=|NME$NzJA?}upaR+GCVVB`1{BaY6vw{P#)~23DcSM#wpKQQ{b4$wa-(}ke)wzQLAfe zS`)n9Eyml<=5FBPs(Hqe0MO7FD%?oyl^V?`5(Udz(o zxVZ~bx=-_cYhHt-+HtU4V^(+z(p*2#y0GEEY}8zTV6z-8xT`&UOeEkHvyjCMEy!qS zrg$l7Yb`f&B!)jfZ4da5zy1vXkKFigwAjxfun9Ro5W4KmX$+r=5`_v`J73M7&c~u2 zn3<^-eZz6N{I~sFK=jv42aalJq^CR-?j2yl)Np{od_PR+;eV6r7yo9vA2zttA%#eE zQjIGXcX>}|G{E~>-C1l*_Ff(lo-OxnVbRFLka~-c7ty!Twe+z1*b1%k>)572{>yCf zZ$>xPoknihl-QjWecbhfOQK#~UIL6b-*9{B_)-4bh|m3R@No zw{H98<{pxfk~gawLOi{MyqnbA1ESOI0MJG$B_-2MT}{{l4qZ~FqWP22beE+6TID>Z_(B~-7OYGSNt4ge1RhIHSJ zF?R1%!G@+7kP_ohZp-1u(fd}m71!(t3WFQF3%fohA9?hN98CLeIY?v>!4|IAcmOLa zmxRsyOv5fTIaeYqI16q!3)*RkNp1%Y2H+m490j-*UdOPBdyt}CtK;RBd|KiC?_gRp zqm3JN(3BoNtIn>5c&wx0nYDBK^?yek_aD}eM^PN>x{qkOZTsC;Ehc1ICkgwmTcwH~ zEbm+YE(61@oA-xD2yPdCaMgyib;lK}pm$8c=v9$m=*&;Xi%|OD$?PC}(Ou}Juc+

1>_T`?_VF;l?KqRY=v2b!|TPOV2{A%TRN1MKlUk!jK6~$y_4S#ouS3&-v`C$ zenjNK1yICvS@RHwtLSFK>tP>MvZ3r|^&oFk=Mp$oxy8<1UlR;L=G}4PdH43hBq=V9 zTJZwH97usbzx?j2cJ}S+jpm29s!{A=pKT&yfAr=m|LAjggjt-z4v+rWXJ_GLLyV(l z$NqlQ|D{uNu|CI!Ad( zmEXKG;YG{zK;y~gY&P+2XAk=o4!;SW;2?}k1%i-3Os+b8fuI#r&y~p#AL#4REIVB* zMcygg*WY%f$^Xv+6aj0N)Uu}El;^ujOU6F;k=RH}Bs9r<>)+3|cKjtt{h-SXO+^^@ z_6p5d*k}q9mTT;In`5f+>-Yt1c$Ja9)wrynhqep(+}_y&RVjk~ZPFuEOI{=jlh|pR zNdQ;`R)NedzGM*Cs{dh!S0`>NJ;GA}JqH{GcemeXhNk~a;-8FM`YWUk4!084b^ZVDM6QzxhU961& zH{%~Q%)fn96^|(oE>3_2yZnYQ{+X5O$Xw7n-)&g2x8X+yiNXbdbRP4WH^v8BQKxqf z_*S7y)g~{9DH!i-c^1%zi(*6xP0SyT}?Z!^8Aymb0Ug;xK$9m9@&uaz@BGBxc7@V3OX1@iR7ZJHsG^7+}4l6WTOE zMwFG3`q)3op*e9pd~G&Ap$F)w--!fyoZhqCjJ?#nUg#?P-FUXcSa5eQVBbEWDQH&- zjSy#XajnLRQZSePHsJ^#rVlHvTK7wxjEwC1dL)5J8_E~%x4O$>;Lv0gt5DRiQ!zGD zc)mREoEBJ2bb>!pw6Rg*Sg%hG5uAPXZA8yq38%W8!vct!q{9Ukk-(=}DXTj(dmbYB zdrE9u60wcyBd|n;pOrm&M#ICLanj{53*a_>S`(b8hwW7rzD>b!u4QPLL$vEzMOrQ) zH344X5Ls*Rryy_qZTFcJNqSs;hs^SgB7Q-%7M({zij*lmJ{0Y`KdF}c&5iGrspo8} ziV0Y0iveWIjy|BHS4ik@{glscMS6zRJyuV+f~xB)U?NQp8g(tWm*_!;;{%CgeR*Z7`P3U2dMPC8zLh`?$dkYC%WS!=iC^at9E^y9@@SE#oY2FcDBNnL zm@4i}v*ACcHriq*UxT*HHUvbL*+FF^#xNt%ZrN@_lLP|G!qy9%+}>eu(_Y}Rg8JsG zOGkF@T7F_1FK^r$9TQav)8sr`LkIZMnInuMhtY&KC{`%p0MRAFAb1!Y6f=#8tdvxd z;Z@_71!_?oU0-_XoY75WG$Yhh=0vZge}X)2y^Cgh6Lx=&>}ON$mh^cKa-*ELTQ+`~ za!mJHUT$4zK->uoE&Y@oA(GRH`yiRskCj>RHLzVp+&2UrVaonZL(h+&p-~4yr}SEF zn#&OGn3tO{;z5j172@%W(fvAO^=FLC_^4mpuPAX=Ueo^qLa~$0L*auyoB@5L2Xw4G zztd}YiOuC0-6CN8Tl3RV+aKjC^bK&Z9UMxzdr=}eN6)OJB8pXF0p3`ZVs0yU99e4> z`KaNlp#`|FGXig)>`pZir_@)TeFd8@&!cw+P#g;czeX5UR9R*53lVW+pl3OVR#Xk_ z?U5gmFGS4P9j^O!?(VKTJiGX3@!`fs$yM(YNE~_onOupQc|`n~iY_jeZM~VmN4(&M z+>{E<E+vh;^>OazNz;641s_*E*Uoe`J;M`m4fJq~S?wSyR)8@JQtatP%*fVsig&{6<6`%{p$pS%$E?NNh z3QX`~fOag?kXDtGu`;L-5YTCll)rY65oLmuE9LT&&yQmtu(ifN3`P|8WQVu+J1Jk$ z(#MWVQk}ngJyxE`Y$wd8Ufezx+)6a5D{aM#zzW8#@%w`RIzaNp%mXii$!XHU33_lQS!I{&ve1Qsud2t}bl0spku$98 zrj0|tqC3JmE#oE?Yqyj`mpqB>0e zE;uH|O++~&i6eF)H8*4xX;>8vO$aY0)P==y(a77&vKn~s96ac4kByGSW2MLJDodBk zI)o+K!_~Sj>>K`!5TAkq9DWH2(l>yo( zX5uqEB3HcN?Zpom$P63~*u!Vo?x+cU=7c0qoJQH zb$g17rk4%Ml&Z0;U@GGUs z-xI!43m4lzB0unF;w5d0{H*FG2@a1q+9*=EbX=c3*-#Al~z8SwcdktA{wx z6knY{PLRE7ShO=YjIO)1nU4oojKpvbMl^A*3H&X_Ip+;F1BnzSDf4831|i;#&LDsSRbvHk8}=kOHGTBI9yP{vRpB88-S2tIlkDWPkp^3pQHkdF;S(gm}n4-rWmP4Ni5T0wr1JJG{-vyo}v z&Dys2g_NQbx)2)<|* zhR9JZsCW!N$-!#D;V4@Ho*ZzyNV1?kCFCy`gdwaTe-zwOmh;j%aYk;fFuYD@NZxy) zaxY*1g9pg~-4N!lCm~AP#18|!!H-Y4_ECID^+YBuEs_&M8xE^1Y+1fZH?GE!H;~Pp zz}VUf8=!kNX5~`q%@7mopwXdw_m3o#lRqUAiQhwU!5cv&O{pl4iGE~`q7^FSlrqXNmp*?D$a>Y?pJ$4`l^ zhrf^G(zq(OcUnFTFRZ{#7SL4AdHf2>O(G@0?0#$SOT zOwk?BsT_{Xm~ojIfsS;0!F&z5ITE%g&)*a5t`geD()5`n9q4o!xx7-FV=z`Edj@wZ zx#CsA@Ra0EMFiCX6yXXl-r&c`KA<}fHj_wBKtXh%un=3iiz_wnUKYhpDF0|$hNjT_ zKP^1g6O&gZE6z{TC-Uk!L*(v8 ztK#|y@mqE(q6e;~R_i|1AsOyZrI#5T`mPkhIdT~xRDL8D;Q#0D%vs+8@IeEFu2a;5 zG88y->BTMwOKqD|^fzF<0^o3kv(j3-g8ltx!TM<-7^uB-Efda6e@+Y~bh-awVub72 z@%ze7yA1>eZTYdYF}rHo15>{-kw|3M;!7EHeIb%I4nYvCfV{p6EzuXIlOEAzvjP1^Z$ijE~>q@K7BI_G`>n?9?J;27W zQXz}rw$CruhsQcs{iE6G%&!4;B`052HC9gQjBhpI^^?OvO4dW1^BBf{qnMgwNBVLh z#fZ_y-O@4b*f$;i@$Yd?ckvF|=py#h_M=eN0|iRF(69MbAbrzG)uR?jM7d%%C3n47 z)MV*ew`|abrtAoN)j@-##&5D3+Pj<-${?IZdtM8jqgrYA;^K?G*;xh^FEhX%L55uE zY=j(7tieQl{|NxkPHFJ!LTHBe4@@(swxHm@Pf0E#hPA+afhxr9kR{*9(w|}MYtLp1 zrL^iikTQQ(GIVV&Aa}&V!T@7MAB#qo%k3b7&X;E*R#9g?dp&OBB;Z{%2%_oKk!WmOk5u_3W-FKc8J zKMgqt`P%-uDN(So(7sp#dQ`6#5Mj<5s+Xp!=aHW)T@haCu445)o@)W=xlrG5&e;wJ z+QVv)j;Eo^|K?#5q|~!prrFxLplmyT))+tD&MWhDikQ=XINAzEE)-gLVwm)+1(8LMzRgs_nOQXfq zDF6!aDAs6#H`h}cBhPX4=?5i{;LKVc>}k;Yk^#NPYQe!Kvc`M_^6LorV4}GO*m=Y> z?~+Psq+?RGaBsEH2!4W?+CuW02rR0mEqDooBC!aY0sj%daLBW=kFuL|G`lN6)A&la ze$sM&BVlo#s`6e4L^E~)9hFAF%@a!0^M|Q+#mE3fx}&TcS3nq}pbc^F1>}qEHii#aRye=>Ww{EC*!i8*$mWN*HC2r9bpJ}n8&hb#pC^MwsIlS8^mHi9auV}8X~Plsm0|c2 z!MC~XOPu2y>n}Zcby+AR3x|On^F_qoMpZ9UFI)+|=N_~)3VA#^t1TTb=}o^ z&I@)^;=Qt!T^nRM!DQmn#p>nRI$;7>cQvs82e)Vy})Y#0aNp|txDHkume+N$yX;D%83h}gKHpDq7+%C2%YjlxTlHXK+g z`*LKPK=e@d?h9%5Omu%D%w+*xsRx1;HARtXij>Esb z=D%)=j2`RdqqFiaCsx9ortZ=P_#C##i#+a;oEx5!ZxHZ6XuB_pczA{SxER4^)Kq#k z+xA9OS+}dXb6Ab-@+5VKOMn9L(&@6yY>ZKmgL!KgANb90;tA-%yZv#{|7o}_NkFWs zTJR=tYgLN*mOXt_jY;CiTY~wQysJoc{9!u<_2(t;48$G_A5TuU>c6iOyDOH!6&sM z_At&$XuzHZ$|0e`5T%gB!}VO>V$9rg@N%xhZp*3UpqQUsllu047RXG|5cH?6UtRK# zbPOr;t!V;FmLLu_`F1{&TX}OA@aJQbaR7l?wS|ncVWYxny+094XnSduR9n8xw`9;C z>iF#VO#1V!pKMK5iVC@=)=zQW5WC<&WM`n<4lV#9DaP(URM_;xE>;Pi;-!w1CGLbf z!;Ek#2dt6~gb*RR*1!WG&w;j&ixbn>xIeGkhLi!NZbvD^5ireE3@5wf4k2v>v8TId ztuvsY_TFcD$|~fBUgD2^*q;h7=<~~B*pi^U6P-i7|E}EOcnVsc{2?tO^C|Pwu^%0D zs?i;pAj=J_`HRAb0t`{nKC%&YtM&z@1PVNo zx>0X$*W+X*8QQT%@DBT;uu+e)1b$ZgLBUv2g%WODZ?nh`hseVG61cQy?(K!_MIdK8 z3O6>vf|Rz=^2$yKIiYcd3bp~Nj_B$9D8-aftc!8as}&Mm(_jW9P~ZVV9XMTJPzmOe39A@Li z>A@fU30(YFS(?O;Lb?xTlY=LxGt#uqqNNgu3AhZrBd3xQ=#5=ptZXWVU0&+>0JD z5wYHvI{NA^^?&B07DJda1^$McW6|Y@QP&o&k?QKEAbi#+{A0M_+N_#w<)!~;1R-PO zBzhv@!8mfB{4h-dY0B9QRE(C>}9&V*iu9<1n3 z{^i@dJ4u-hLQSmp~@xzgV;4= zjR~sc-Top%Gp~lh^W^A>_SBW6Dg;4SwA%0sq=rb+Q(GbQmxtNyE~e%V(Aorx2wgM; z&`HHkD!sD^=XyV1F7kEsALOhj`!c;;0vGTatrudon#TB2W#d;7V508Nt;!5eE}aiK z{B{n}e2-m0m94M$*|z*wGt}PLls0!6i(6~#WS~ppQ(W^}#%79UJG3xa^rq$FP=$l=YLEq&DI{IO=;R;~P$Y<5&&%`cLH39@2=U zfh|H;IR_!uL5Hu~H8GZa830!F_5U%8%&@ZujULs(k#-O3V! zpC{VwIsG_ANFUGzN?OmevUV;7aE$CNbQ~2ASnbED0{P$sO>{G1CVW>Hc~24zX1e~q z7+Dc>7H_nT3%w;{wQ%AActu1!Tk!o5-M1|P;Ru+V3kQaNEjy#;2-%KrNh^PSO#h^b zK%LBi9y2Zjx)u6(z00C-i@V7sf;h^{m4Rd_gZMvx*uFF`OV*@cM%&`5sLb9J=T>wR zMe7;7e;C)C9Gdf=`f6**_N7`(($gk<je}0VTKf{0V_2eO{@dqM+F6F`|^wI(*tNV^sgB=PyfQs2< zLH2Hn!*Znb;6loFaDi$t|Bq1hT!x({f8hxHOnR`#tSvc72lboPQF-1U@0-jBb$wL8 zMw$MH{JW?}cKejEyHW0h#4dwCh>H-BMnWE_-2X#$2sTUB4MKOLXQ}Tp?Uve{od5Qe z7^UtzvbU=TX}8&FrYlXMQej#efoyh`(K)a0_1iPj)nty0R-GBo+x;q0XErB}y&Z9= z0#fF~Ot;~D-bQ}t1o2r_h@o~zpdO!8{1_8&0>or?ax0ggV?lj38QFis06~O-#d#hj zqQY@cIDf)|hq&Y^TERzg#=OlfBu?3|^swOoo$-G8??kVr#98VQz5a8|UtBr!`|rG~ zhQB&`c!8Rr{ykM{nwbuvZ~mnyy~SPElj4-T5+(K)%joh!C+*PG@o!%IcVN}TyY*5$ z542co8h%D;d)m$6(Y&>Yn8V=1Y*|cJ)omKW_gowo%?ug>rt5{SKKCd)*NC>?tESsn zy1W@eZnpaEo77c3_nZCNLQ~lkGu5MZre>mm$Jc(C30A~cJ*|p&l$JKKM@g=iHfab4P2o4-VbeFg;97KoFR6M72XgH~l z?c_dEGkk~BqCSKLaL_cE>IST#VUsB9msG6 zCxlKn&|N9B`5@<~?y+{OgqY^OdEpd!KflRK>29ce#8``DIP{77qpvP(`I79)pC#aZ zbGrVwI!u!_&9tV<3HfZjD{j=|L0iIR<%ozVlIr~JoxU}v4q%~yQp z_eT-*zC}E~t9ZimOf3|H8ihd6!EKYP&##)562Q5^U9>p%c6Ng%KkvA=}6A@xR`u1+~vPL~jdFp#XtJq!8a{^Zo=Da74yH`I9 zR0P@m2lI=Xjk9+&H?V{>Z+o}7Ek|MSjC^ybx)t#-hs-aJ%sp@+ZbR{ZBOp!?zCW>P~Ymt{FF54`YqM5R)9{P+#9dW``Ji~@-;fZBR(E3drP24 zKBGbpJRa0_OV|Cl-oiNlW#48hs z25hOtywQU}4zNTFYh}>FOIvY5akr~9z%LZC-3zFp_Z8=sK7I|W>xGdGD)r;?KSMiR zxRJbZ0TkZb&7e)Zkd0pJt`ZZ-25aowhZ`|1`hpS#KpH=ZqTzh9wz;|fJw(;LJ z&G07BsQj{t;!pJMjddi|iw|B=Vv!!q27#=@khF%XZODW1-T1@Ush7fk&WLA5LAsFB7f8F>uKsruL-T9p0_Z`PJtn58-@SDRV3#&+Z(!afwoQpJjjNY<=iU*d%~ z9@(l05^m}!27bOf8xLp=11-05+drD%qALA|cwz*wVS5ulrlwusi{&;!k@lA)3N$3XqVpwZ&WV=Rgll(}k@`0ZQGgurQWGu0BVA zi1mhkR(>Uy`@-VrubDk~(RuqFy7>&!=VNir z<#V+7n`cTV(HUdS3SXJlt&J-WbYi~n#x zmFBYlR52Jd!yTVh@t^1SzTcK>=jkTiLN8?4uz4pd&KSh+^JqeD<6IJvcA=<J!#1UjeU^rUT_+{xV>6^I&b8IlZu{3M8T33~b13GzTXJ(bd7+&) zXnHAdE`9~|EdH>{@g9{kV7xjq!ddCBCV}2v=0?-7&*fdS(4=hE7gh(&hg2`VHOU=J zX3b@vcR-fRQ(gfTC`rj;EC#mE{TuHcscRXZAoGHxY~2FnHTH_bBF(YA2${p?wiAC2 z*5B^X`E^Ur<9d9#um*SSf?u z)3{6#LmR$UWw(deKe+RT;Jp6pUUE6#=1Z3}KE4Zmt7<|`TJ!DPM?XYk?|6N)kjcOz zfWt@vwR(;4Z^5VfQvdI3q!_`tFs?8OJB)OvhWBPVZ>HvX20!lC!?1u&)gT9IwNM40 zFZ!=8y13Imvt8H8|7pvd|5|9o;=0tin&Ye=O3g5{No?^iG!D9`UauG3 z#$tdXu?$?cnF_nG0X@|d7H2I7F5pLNNncs_=1XPI5BEA?Y?VLK4*Tku8#|pOn)aor zQWy6-ex~axaICxEJb-T-Koq5m-%*$t^tzT1pQ>~?fcc!$2UhI!Fb*9%pkydd2z#{> zub1nrG`pDQ`dKny5QQ|r#8k6%bq@Qd;pf4$W!F%BB5!vn>2_3KYOkBYV`paH{8S?# zwX4Mo*N=++p|SPr=EcnJdTE8iuqpTsJ>xstw@Nc)&IB2R@@=clPaE>vfngzUO zGw5G3Los-=fdwzFCKTE?c(;t+Qj$QSU_X69vqSQLUU=ZSWj@XuhNfdVh4_ zk+WXeJ4l;08MwPNH~+Kgxty-D52%G!K~or_Oe*AvZ9OSeheEYJfKbya!?OjZizev8 z&e#YKIM`EvfSDKR1D+Wt0eFsWbgr5}r+mWN;N^dkXAdg%=A|SCIq=K{%v{1=+fHdg zjyI7UO9fXh&q+&Co_0HEa(zx8;sx3bz{K8|~i< z_%^-OiSV&qxRZ-vuzh5E0lq- z^=zBOvCLzJDhS!CY#bEgQdr+BA`H0E#3NxvF|_7^nrJn?j>CJAMb`4~ms{llpHUgX zA5ViKoR!%x((dKawx`~C=^xwPAy0(v%>UUpO_wZF(PCg@G9cG* zvC{dZn$+x;rFo?7)PamYq*jQ8fVdH=O&ENU@&q5*o>O>WC*lyRZeZ|H$HtcWb zaRO;&l^gbEe0&;iMbjnxCKaOkXcinEBU;Ulm+GituOn7X%~r4>C^RM+8(4cb$Cl&7;ZNG zJ;9UHZ&xWT-NMh|BAL7y#CmSGye7Hi6wdUv1KjwmExygW5c7(6h`}3Z2!ttIdwX#E zFRUgj=U0W#)xDKtc1yr&U<~c^;#63luUX$vT?eNIn5w5Q_xbjaiRqSeRl{SS`l#f} zQZ=++6LI&hnMmzp7kQl({u6>S;ml`g_^zrVCf~W};4VMNAo@G_t|hJ0Y4?4J;z`q7 z`)p0*Wx`-d&5t18>2{zlv!Yl@BzWx7{~f8tjiYzI(Thqp_#hK^TQIehi+gpp7A@IR4 zyM%hetIwp8sYsq|er9dVceeeJ>3QDrrU<7WicL3L^Fi#X)N@VJIs6{hDW$hylONIX zj<-QEHoVq%si~94*xLb0;WbKC@rx9L=y68F_3aeH>`x+L!DVIA- z{&eRn*QrDQsV`bG{>kno**&KgXSQ2V{%%_4*Y+HtFZS(ljwHH= z<+0KK{dz1$#qcIj(v~U`fL~J4u+s!KEAq2sed8X%{z08UMKq<{ByO-C@X``geUO?#fK(#cKwB%c z6bPbaAz%GkjObjM$Ic|buRG><@UGfE>&xxjj~xB9W|p4{?ZNaqmzt3iw*ooxI;tHl z0aK7iEa!3#+-&L)!`RZ#cDn2!1zx(7$(L-g2mP_pS?%YghtgavJ5*|s-)wMuvf!Nih*yo5h|p5z z`F0C&aTUY}RYV3@!Y9sP@$M#%?Pkp3gwLxOJMo&y?k154s!(hB>3SmystBx*<2DF< zd*%q?EaeWRM@{n$5Oc~Z8>`-6z-C&p{?U?Y&ZrkeQ>oE~La@ z_?9Y4Lp8@tflD9TLFVc|XwNRXAn+0NtElG`YrYIeJ>1(Q?-Or#%Ua1!S(+0)B!b2L zLBVZ2Sv}LwQTe@WRc))6uGIEIE?3sFjx=5Wid7mK<~R$3n({Xeod1;Iohxtt)e?4#HL=wGVSN1W&;$tJZ_tkH zp_&!r3POp_L+v)5k9;mp+(K!uK`pQfqM&yYkV(V#I6w^$Jdu_K)3M*=k(Oj3=+(VV z74pELBQtf(9R@x?*bV#%rMhlr$d^TGh7(Q9%ywwDQYa8#8T(R^i2RvIMmTQI`~(kV z?*F$0wEy@6!+#JVJm_0%VMD{sPHM5=Mu$copPm9!NvG3&L%%P?2XD!3AIJPqaWAgx zS>b?zDjqA`tl&q@izgJemY2!6uw|QjVnv7}4IK?NAtYL$+p-zoN(B^u!Yk|KlqkvQ z^pgXjD+dUyF@}oWx>ycvtA2S}`BO5vob8RWg^JMed}7T_gGORn(8V&_v`j;FLiF>2 z3+7c7PWGD_z9)3a$Jg^$ZX4DQCLBau;rC{7%7!onNDz55_CqpM{m54kK(c_4EeXw` ze@?VJWtW?X&zm^e-57g!Ia4c1Ouk2D!7UoL!nGd3h4WjmcApc|dwlwc>$3B9+`lXC zsDdq!JMs=WbgQo|^=*SFh*gwo3O|y@14^OFvMf$(-Lz<-Djk`bVWkR^rr(#xuOY_H z@u}oBkqfyk{Gzp6&rpgjhhseIS7{B*t7D|1LExx!+0;sEhOX~?{)G2^p7Yzi=bm%c zy3byF?{m-H<#1+*x!{3|-$AAv8h|K!KzSlB&-`BAIfF_FoAV1p7e#?DkvzMWs3SrCsv?3vvB)ooAsxyS|7`J*AVvRpYVk4W zWZvx)(uMUHHV%dz6EsN!BhIy{K_6`-~7XFC- zRQEV+>k}RieKv=MqUo;o*U6cx4uYf)0{`NVQr}Sx^lB^f))9ZUQxgtL*^NK7sAX~c z(Cd8tds>7a?Td($HlslBg<3*)v7Q#+XeaZ3;UHn`P1}0|5=O?oPltD{M=+|u;hDVW^+3HH${7flVQjjlA}@k)3vx^ZA zwIj~PI&CzP1E~HGK!BIxWk&bB&f9~kB%N*1-7qN z_^{mS#N?|HFutCXqpWKgeax}lx#H{e*yK>dkFk9G_Jq&qcH#M64iIvliNbB=DsJ&1 z_ghdnBN_wD4%k<6x%TAG*}T4yT4|m=2@qC$7_fo%-RtvMrT7DstE?9?Fq_ZsJU=nk zkla$HSOtiDD^`=@3~RC(%XOb$p~c0RIha;rwSB?RKhwYAkedozH>3wt6`@ zKk??PR0Jb8=?)gB*x3O=T?Cdvk{gBiNl+vkpdGtd`b56S=(tAh2p)C<{~A;h4#nBP z-nGb{zE7Vq`@bTEB$GC#BJmK^jGxJZeLU#6U*7tJ>a8+*V1R%|p8>-SAXK>%Bn$;p z?d&+W{(1H7O4aL7e!8}5Sk+WNBwDX8cqeJrtz+qae~uRvlLe*<`V$z7PrE$hxhL6O|lsq z*S1>B3375|YRM+;CQ-GGI-f7oI0x?8Iju9b0@i9A`k1(U4{(}DQR zIL^K9e+_d^1eCC?tc=Zxs|DfRNst`Hw9o~VeqSDa=P2+TiTwjimueqUZL3Y?DXKy7 z&_tW<+MNrvftR|wu{y=#8{oZJK zwoNv$&-OZL^MwlumDx8hL3*{NP|}tH6{$v0+lC8(RUqnDX9Vedq5eR~2C)W9vVlJR zW$Dz8oZ&X79HcsA92ZP}l2l#w`5WPkV{e;5?* zC&!H*k~O-75Brwxv}$$S&E=g7@T&uZ-vZ}727;e_08F=n^`~u}1!lMJ0_oj#TFI+> zQn7$0n9%*V-iQOLgc?hq{uGiwEQE?N!(vpr*f2aQU?%e|Ta^K*HhKhiyKqETgRc-d5RH1w>x>HHW>qv{5)3VG*AjTqzoaa8yTiyX-7Tp& zOqXAA-y6@#Qr4}S?EmsSoskYz=$=ZfWBxsF`^a0X!uj+iqk56YdAsELPiHvzRi)Uq zD9_q#xA3gT#}35jaOC3VCwc2eIw<>ugNo~>CX}GFzQfKyMk-h{Q@!lJew^rDqE)G+ zW%lfrd}GvE5A%4G#rLuVTP+;sepMLRKJ7HRe(O$)QA2<2-c>1 z|KAHcF*6#me8I@XUQ@Y<%@R;xYs7Ppa4{~P1gZU=oAV5vejYw=Xyygj^7s8VxuNmW z?#Jc}F=ombo47KAWXtdSv`zBFHTc~8MFE!M6|ISIr?tH~f)dZa<@_QXn1~J|EAX*5 z*-L;qlFwINesxZJvD3rt#Fbk`Gx-W?(BeuNv(j{GWL38(^Qm_;204r#urbob zcV(|?NTJ{AXGfg~W2*OG<5zK=w$*Jx6lM{W&=1?PY&HAn4 zv>{7I9Bn!Rq#^2x4nHfv3`mzHK_(M4WuMjL{1h3E`P4CAS7!@{9?3@xad^lmq%*sh z$zlC>DbM>tX%A;r9q79`r`;4kY=&)`q0=w^$0zQExd*-Yy_W_Dq4QigCCe zuQ=UhcSD;wz58*3@*20{d4`J2Z@gQZ%?Wk}fRPs3SqaMnU49l{)x_-c z14ZnbT6f{Zp(SaWy&KdXc`h?k92U!L!Tf=ql@!sLIyZcy9fyYPl_%T+XfH2LOTEiY z*82<>jqKF;a}_#SS%l{X)2FLnlZ#YU#-_1w>NM_Xq00BaA1DD>-b}01*s+jEE1zdw zzxiNK%z!Kyp}H(@Hhw%$E<78FdK0Vz9i4VZyS)Svr31@J)13r5lG)njZ6p(a;F(6l zt$&yS4a5XxR-{ie3pM(-Ufxu=({_t1=M#r@UFW`~a-yoi-F`B@nM9<%$RN7J7~ujdj%j>u)@JG8Ct%*T*l6t?5TaA2NbW0{!w_ zsJRkIOC>6MtytPKI3rAwpIN}%Z+N^ZZ{18jqG3xu&oij~;CWuCx{0o!LY-dBR|<25(Eq2Y<25+N>6dcPlUKLz-X>1=qK_{RFJ>Y*IKR=I`L783QAr3HsC}S2ZvnszZwBSIgv#-ltk|l z?~p;8vDW170y^>xldG&Fr>zVh#7F(XuZI1V&)DOrhCaZA-z%h@d{LzTm#anT&)7s& zJk-l&f=kxg#fC^>!GR*Oqg_sRh~rUIpK1Y2=8)MBkIl?e*jRdb-@{GVe($e}T%J~UEeWKS1B=0KV zZcU!^O7_I=gBL~Dmv*~VH!1@QIkpESqdV~h`H#~LarCeo5)q}F)#ar5krstAWI|KU zRO=FlrW&i2jZz`%yfKO z)0&<{@k$ME6<+%j7?bHF@1Uq7!c))Q|FH21ie0&vshh|)rB1na6p$NMyW|LrfxcYy z(fSd!A7=agJWt(BC)oPu+M)eq&@4{wX1<(a*pMqm(Nnxy#Ze5y%i$upz9^~fwctXT z@b&g(T~=DA3PWHFT`IL#$W*0%0FC+UTk5ZFQd*LQb%>N4$1pIhr?Z|tK9N1QHYkZ{&R5?XTPW|8qy=|bJ}3WprZCy5K9WK|CXP-K?UYqvq6@(!B9 z^}i%vZ4~e4P-yd5i0xlD+f}J;@0FNv=$7Yj(O^U;VMX+OPROP7dQTknm>k+H`9U`V z11EDkhWU48mq$3qkBvY~Z)q^EH>!KPmSGJRG6SLjdT$Mi3b!fe$}j{%*> zthI}(ce0I;jR5|EZ~M56p?n6t!1cX$|+0f;Q>%Z6mv2?nR{r#_c~j7Ss67{KVT z(hA6goFmiAl=L^d>TaKWJzI0CZmOkX35;>|YaqaA@>8;Q|FP8N1|~g-4R8CL7-OyS)7+c4LGg*%}i`%%!Ul@O_C)Nt@ufz1bJk47Vq$HI^xaaZV^2A4D z!Jm!ltX=xGx<9FX3Y-rR|3W1g7<0he@;&G5QX4{i-S6pvr9exIW5u6m_V8#oFL7P1 zKaTD|{1x}^fcw%V@9N3CIUB>-)68v{mX@c^l$KRy0R#(>Ev{F{oyOSax#2RnVD7?7 zsMf1Xk+~&dgzHY4|7>&xnM7~ z{ypVAz;J)jMuaz`Km^8WP6)>Ud#S=miQu5DmA>P!vA=DLncE7w9`BNB%lwhVR}1Ig zJilZl!{_gdBNQ8w=De;eSlX3Z9v%kdkNZjYh&X80mPt1#^7q2mAU6 zjdL|L>4R&mw{YU!zXpk_SQciJq}?8A2a%wc;(B-U9Cy_( zy|eGTX6|shD{WV~_kY^D7!EA0uU{pDDW3qnuy-a=T*?tY3@-;~V=4$(nE(W_UA7IL zIQ@nUXL72RWwK08$bLM^*yV5y{1C=k?R#g6olsK45Ubu;4QtvA-TF-0 zY;;vd?MTA3knLDPu3C z!ke*4Wks>3MhXLX3nAz;%$vT(t=h)jrWtJY3>3ZZhG+I*cyw_sm6Lu~98M%W9OCu6 zYlHe*|1S0#mbcG=^UDx-ppZOd@qrX4R%~TvIVwzFOol92fA1vDcM)8hMDjgr7PYK> zup0|&ZSK}O`#km(w(n^|coSFN{rMYn)n@Ba* zE%LW1Bq$x0#wgcKC1)M9%D*L{ns@}{D43^wUp1BzLkS8)=YM+tGUrlo9Zd?ZoDa&( z*wl~JOIX6GuK(b=dH?oxYRmFNM3Wcp?ZKTKS?x9TWR5kOPvTl!@C!PL;YUQzH>IbV zHIK+JkBmBa7kntNx(Ou&(^~CCkOUHx3Y~lqIGx z`yJSa0~tS*7!kBfLsO8!-$?!1u?0v2#Ty2bTT~VXOg^Ewi>KGwcuoc`E?9 zU&uNGcIIs?frD;rWCpHWG~ObE{i!zie(=Hl+GgtHghi!;P{CKAOyACLHz!xXaujk?9bAm?YznLzn@E9?$h`dfu7f{BhSS4P-BGiX zEJvA1jqydr@N_~JnawHtZ>d6fL3Oc6gLHMj6$hkH17T*cR(IQvSczj`PFO=PZS(iS zXR~A?J(=Arql*l2TWs<32t%HF-X|dMI!wjbl((EQ+*c|>8umJBl&kuYM_3#7axzVvO%PSb~UuQDW_!q8jMCl?7upM4T4J2=+W#M6RAc#$!22;q|H2MCkFM4<8XqD#u zX8(ZW=h89KK3?r9Hm2_)e_|)JWr*MBJ}?$DZq4jG1L`xrput$fy!>DxZm?Iu*MAYK zv!-@R?`aP_s~sR>j&2=n9&R|DYR4sfJiTUCiVVxlD4l&$8>zU5ZL>dhnIi?)9inZJ zkQB+4^%LjFC{L39FZwe7SxX)$2O6nw3?SqUs_RQ<#Gfc%8IBwp|C2pOUHVAq^3$6V zJLXh9wnt?W;ll9%z3sq+z!;U}24WB2LfvEQeHot+h%lTY>{4UegVw5WmS+6MR|FOl#T->{Q*%NM~M=7vn=x{XEbX99# HScUx$ii~DD literal 0 HcmV?d00001 diff --git a/.github/images/logo_fates_small.png b/.github/images/logo_fates_small.png new file mode 100644 index 0000000000000000000000000000000000000000..ed014a552c311082eb343a60dfc29a09248c6a4a GIT binary patch literal 26080 zcmV)VK(D`vP)I?001oUdQ@0+Qek%> zaB^>EX>4U6ba`-PAZ2)IW&i+q+O3>xmRq-Sh5us|cL;a`H5@$G$_z66d>f=>OLlJJ zthg<8i%lNl09E@@DA1k%{EzGY^{;;gpIUagv|g=N&wtsn#la8VfBv)gckucB{r;Qd z`@8V#<8GJlFCq^mzNgPW+xG=w@Ob&-1wY;+%wHdO{rj8PzZVKWFZ}*XdT0H-|2#+@ zkDtdw{$9w==Z9*&{c;Q63$5=H-%!4P^3P#?zUklYmj@cN#Jxt|FP;>Ve}DJS2$KH9 zH29wQJEp+%0$=($JHC}vzZYXde!0CL-@X6y1pP9}`+jfj_u2pX({Ga>$M^B{+g#Qk z7pi~%i%@=hJpFu|_~$oH-=7>0|MClFsQu-3zJKoB{oeDryOAq1TE7wXCOiDN3{RX) zd3rCad^P?Qes1r}`09T6#gcEo{N!r|3z1d1F66Mo2sfPfeTBskb3C!}J;uf2=&_z! zw78PiDeEiT*pj84I%~G#aV%v{@#k2=dtZC+w?gNgci^cpaIx@~|G)Wi|L&Ln2ee=ook@!o~O5cWCv8d3>0_!eUefqCpK&|u``L!7KYC?#$N8FNZC zx)yuXd-IwW-g9G#HR@roiG?76Qe$l_4HhfsLj1JciJ?(a$)%K9TIsG>88y{hORcq4 zf!t^yUMsD()_Suxdg{5CUVH1kTOSrJfq})UHS1E>H*z3ujEcl=zn z@J-v_zy86hh3~4xw^Dju`?+d7>RS78i6A&BS~FHG=D>{DDfcF~NQfQzoiBBq-ZF1e z>rCUA$b6R*XJvs-TO;ud*1fOVj0g#xyS!zb+g5b*`V+Zfu9l|pexcYod!CxS9YP?4 z?eAdt^USjE;J?^Q(J%o%B7~WkAvm+x@6^=Z#7j40wvbL;^X@cm%WHNJ;})JGO0^R+ za}I_F^DM<}VG#hs-H~Rg8zjEFp50eyx1JgK!H<NXv;6=2;tR;5oIEAj2xJ8Fe43=VGcJL)d7T^Z`hYHEn-)i zA-Tp3rfj?`=wKzRQ$`|OnWlS~%}oq5LkiK#WGyM0>bv5T+wa#iuY}xnnMJL~CePKx zMh0*^Flcv<>`zB;TtCPV&sw!~_ujb;KqfJAD3Z)bfO~WR#N1Mm<6(yXzkYYTTRsHJ zWj#wJ*5+=kY(yWI2{pmcVESD*YGfx66MLjJ#{mp{Q7|#qQ`{zEw^o*Ex;YjgHwPem zhCMb}JE8pmZh-k``2v8OflqJ|qkQTp$1% zaKk0aD_9MNcMy-r$gE#C-nNhAh{SW2$ZaSYnE%e?x0TD7d7O>ZtK2J3=QfGNNG@tk znecRG=kMuT7ag58&YCU7(fp~k_+1+p*_)>lj^_>{6FW6wAd4`Z~%fCvYV% z*dmjLm!UJNyDg^yc>pTnc8Ia&$iKNM6pch(~E1Y#>a1e$Fi1m3B zR_^$Cqzxl&s2+a;OM%ulAy7eAgmAdV2RY_IVtz3M4u<;~$U&3=xG)$o4nPyYN#w4e zX#C0T2pe+Mv;9GgRp16R*mEQ^*$PL59w2BVHtPCf6G|nJYruCt(9*qS`$_=R3bG4I zdpHNW*^9`8b3iD>=x$6v0;ti9Fc2I8fz*whxN|N=+ZD(oNHba?a@&|4;A$_zIB=V=m8wgz?F8m| zWDg7G9iyBZ^#E$O?C0UvtsoiTwGBU-`K6 zEzAh@u&^Wzt3hJHnF%i8jtA??R7Z4C48XgXCE}J)nUF2g0m_aIz$LbjEX0wrgUL(L zfEQx<VEbt~i6h@DHllL`^)@C{(QO}B?M6Nx8OKL8@l znlL7a2{;88OmK)wvCWCZf$FlLqNV{$gL^=oA4gh{+LkU05f*mO?o<64&k79?d<{*)yHD6=L%v)K1p(yqiXG3wR`o7m z!zP2!0R?d4P{EauZ8wjJ&(4}v8F|DBLLiG9MOY{;+34F!#uWNdmUsLntSu?Wt?*2X zTxubudK$Zkq!plecBJA`l<;6ezmAh{gbMMgmANUdU`Cna#z0Pj5gzY}l_^Xi#vNwGRa|b(gJ7f$gMyF{hlrJp4`#DTB|zctJ=Vb=EnF(UHe z0GcbgT7;T$1+EmNg-sk8CUhiqXd`G1m)2G=Q*LYT5#k6nbqE_G50ZB=0#dD!izpD% zpZjTHi?%Y<#H(S>^Dt{;6an~(EJYc^Pg_4MBqUS6oMvXB3!rG?5N8fm-0k~V;H3&C zTPk`I?LVYdA==+h{?FgtuMa>BCu&D70LM0+A&e!3V0^SYW0a;}HKfdHtg8Gsas*<4<>x~!+7KTV7 zPeE-}#KI)4?J_WGDkhMA{soBBVl^nTy(^Nvf08 z##$DlRN( z>!_xWR#|U1>Ef&z=}>VYf&b9^Z5C^WAoC&CiKY(Ivt+ESXr8p6twMJ{q0s7WiJ=0?Ok5stQ54=l z8kvYhAEAtHF%L2r@5cZ5OakXX$6!2uFYbxfBHv&+ggx@N1>tv=-0h`79V=@5JetLtmnNxWf z0FH>_&6W!I;Dj*!N>Y%75(VNhkeg|;y8Ch{nWUN$q8m*EOBwPD%gLf3!FkT)&L#E3 zCLOpBJ6wJPvG5FuUyNujJG+k6jDZXU{Z|h!zEF8P2RVoRj3Ti?NCsSnWfUJg+<+>0 zp+|BvAa>Gm*9aA?gZyg7lBtx4CdX1kgE$~y9)ylNauHt6I`osZ3q+_vDX3HQJ#*{O z5($|_VxV6a?A0_OxFqSb4OQXnnF}I8q*?r1Q5+l60>3yVqo7h8q$*`(4!_Bm33Nlm z(J++UQO__(@c2LS?ik;o3|N}yp~F~W#u}rSRBqLQa#akCKZ3#F7Z6UHY%sXO1n@#= z?R4ub5RR(2ObH2uS_?!?FIYwN_;t4ea#yiiiz)}qB_>Mfsxr8NI>j$}&?;>cP&7Ac zkSL%Oz2UJ`=$~CoJ5ZSbs33INKm@~Hc1Yg6fvkXd0!~%4fj(AwMLa?Z0uC%_Q~`KF zN8C?9S>XK?-zR7Vm_CT!qjvF>70HUl2og_-CR4!<&-X4?!7^4E7h-OSFA9Ujd8^C{ z(2z>VM8xe~PrjfpH<9s|vO7Wr;%dDTme*~@oNargF>#76#>-BrJtQb*op>kt0*f$9 zm_m=U5ge+~*Np>4&<_ALgT2S-zGrKg^|&S zAwm&eBicql9(y8&`I3Y8s+)QI(pH@bW8JX>M7e6UWdfbD1$ARWPK$`C{;V>F4h_jd zD`F9NBQ2I+bc*gLB;bjwdS6ZzwiF2!d;4^R)CNa7(R0GlWs`DkNuy#sC&A1=VnYm8 z9M1x7`+!hMorq1tI0f_`vi9Q7kt?vOd<>!s)vJv<=@3<2n9IUN_SF2z=oI7~?9BS3 znHe{8H%dr&a+IGKii9QN!N3tFFe0l9mmnX5Nwj*onW=$7-u9|*tUX9uu<|If1X9I_ zlLa34i8&|Wf4jcGeDu*BT|yHFj235cQ7ssHlssO+w6TD9%Bl~M8cWp*o(nd6oc=N) zBzMdzPtZlaF`^ElPzbs-R4*41abpqMEO@=JaSTj)>0pGmsfbuCCc&ptJu{P7#4}zk z5c4dj9Ef;k0fxfCkUIn~LEJ=nkP$?V5m}0?OspXyoe>etC@Y^8`2y*1(GV;EfB@;> za1djc`_KX*3}tY6)4V&kx5<5=R2q^vCuT4L+~9^5w`d2^76o(&AbEUdezVXZh|0R4 z8WU4JfDRo1kpPQ#a_FohON|XC#gzLzqXFLo<<2T`H8PkSBd6rjk=Iz(6iIvTQ`lru^QTdX=Hi!+X6v~BZh(s7n z6Al3dIk^J4H6$cq?a9(0R#lf%q4#*0o#bFfpg&pja@?bZxi#=nfn8F7`$XSY(9MwU zyFC#B2@t5jK>*)aZy*EbfhP!(ml=5s@WYMByLnW3!QF8Y71~qoP++f&swLPPO$$Z^ z7z$v9xwr*5!L%g^7CHi+xCUg}4z0*T`vYbyZnt5$8ulK&s+|`k%auH1E&=r!Jr8G9 zbrXJQI_(QGwJ2D$mhNsKIJGmog0=;uL7R5^gqu|&22qaT+1jsz-^azTAQrHqyl*AF z!E@R6M5atM5VSTi-soI|nRqXsj9ZjAXV~LubhHGivbV|&*+~MZDuR&65g(%>UQk&t zzDhA;#fYj-b8#tXaaFQ^_6q19EBGZ6J`dBz<6%0{^apH*=9t#*!i_z0w}) z7T=w5o(=s{)`Oo$bT;T3pzcU#k_IG3cEC+8oCkzg(IEF3h59IA{*7=U=|dzoVh6_O zxBg82KH;^3jR7l&RlGY_H;&LifaVC9a5LJtQiI9HTHxzDcFKCoz<(`WJHsSGJ%t&8 z)%2S?nj=F9Kddt5RA6SzGIyPF2x6uDf<0kgeTRoDtb&%Tc!O6pBtr+@HP-Hs=Mf{e zHNv!m;#>tG2yQ^3QSzE> zKpSprud*|p7qEf(WTjt7>@pg*5P5@-!ZtEsm>$t93D2xzn}MSJEEk-s>i1x_&UFbO zudnRk5k6t6IOI!^I@i8A!ASmbr|M5q#fUf14&Wxjv0T=*_k*AdE~^r#%9(r*jB*r_ zQMM7R0I?@5JBX8|y$$}+Wa$TBBBwQ0c%=!_fyjOv1X~p=W_7b{vnCY38dz|_2wUG# z_Q#V7NL%eF9>t#8XXGX@;;buBOO{0(8h3I@+}F+lCCSoj=auS34gdfW&2RSv%rYyVU?R0W}FM)H%Ki(pGx~ zU{ll-pmm7k8b)QRlLqKYQ;U(cg|OhYBW0Sxvyolfs+vNS`jYlLO1v$9UJQ<&xFfEN zFvVD+{-Z~tVv!AGHAx4=5PCX58VBm~NmPxVN}g!@PNpYXCkHMpY2f`E$8 zqiRpTFVvT00<6(qol0%Nh=f0?d&57%gfF$hQVw<-b&X+~*ee30vk+X2r9maGZOC)f z%oGcs295BvFp%0L17JroHFMZ6HK(Xemca#)WWb(rA>=BlOeP)mP2gMXsY(_w%7`Dv zhRHx`uLu5E0xx>R9Ix{Bzg4@yj^r_dN>mwi7|g3p?f*cFyuk34B&*`g49l@IahLcs`W8zi^)_gO!F1Ki<}XI(=HAOV#Rz?msxjFEiPTUtv3>jxk~cr z2yTX;joPMd8{YnCaGIv0+WnO_P%42qEKEHPz|~%vN-SuDixP&lRcS?$;!!+K4i`w& ztJthUml~tCRTzDZS`_F){pFBWq!UAyz+$Ng7;GjWIk6Ktg@Ba7#g0+5F9K8?8SSk? zxh77l0aZhgN7jPaQmYw}alc8f7X(E|RO^hViV%!vMk%>D4KWIZ zW2dosNzIFipat)hTP!;0ubLzG7&YIj9wD%Vs1Up4*sG`@P0Znl*LUNd*)$9c(@CZy zgljHppdi+19Md<56&qRn3qK#4l6D$`Em9 z7=(zqG=j!yI<>QbT>~eox*!Xp1)1l`PMrHwp9B)YP|a=*=q#l!nFHlyL1C@l+*F$Z zxLVYb0CgcQ07DHK1}8#rkBewm(cQD66L-Zlqe(&mMpW)b1mU|KVV<>9STQPUbpm!$ zf#Mei5OWkYr6jpz!zH$)O=WYSnGr*%%haC-*^vEU7}I(1>_t0%lB?V`Nd+?VKvNSe zQ#Zw0*f|{E>v04AqVg^VMQd_`0_lEs|90`#nv$HHB;$00zTXSh)f3BT2)oCiZzgx9*3776?sZ_(Rw z=7A|w>y8&$1G~j4`dfAKRy_C&Ha}2VX}O3ymuuN7TW0NcCm=CFBvadIi8ZcXy>3HA z&bOrrNpzxtXqmREja^EpR9&ZA2*A+33bpWa77bPVzvvUt=er=uO>!@5z0i6 z?h)pGc!X|jJQ-O{0H9(6&s=KcWu1sG9x`p4#G>BCGW5d6Ahq|Kx9VzYri0-fu8F)= zfgN{8%wiI?bE!fof_uKwPR%e1*8-Oa6tBWdSZX&QoYL9F-)>I*VVKw?xwMq5tb4$o z9)%~lk3)=12+-$M6cv>Xeq*Q$#1Kh*X4O`&)6j=tgGop2_jZ2)IoAAw^(FMvvi3>h4`QS+oYLMVhr&7tnSrc(Q{-SrMLx_$Efsvf5WoWC8dK zJEf`4t1#h15CH*`MhEog(mV4aHH)J(5FHNb3pP|FmDi#i6vb3+uv{*yCPHmCK3Y2J zjb7jy!mw^B=M&(C9vA)m{T!D-bG2F z67V88O+xTo*`=#(0@$aC*-$=KM2jQ5erf~~Ag|6|h4mRb4fK)B7^1zC609jAeXFV| z>l{s@OxEjwPzhZMp<`q^s@~Km0~HtvsGZ$nZmH6Q8H4z`rkJ=?&29)@<@c*<@3l+5 zFn_A2c%i%ci6hzFE;g0t*yAP$ix9tJfBEuR=9Ylpm)udqAajR%X zLIJWWGFjkY7ThC=qPC1BJ&{|Q_XchwC#G8M$a;uu;rwz$0X3)AcPs*0h$}Rl*wAh| zf`ygAcaC?&3i%{CMxx^=XXqJ?rCrdKLNt$*)Bc(dr20vrFE!*L8F9kN<_2u5wm|eK z*Yq)}t2#Aqf z8@C(0{V3YqXj6NKBcQd_A&O<(1bmdjW3b#RikeX@P>uBm&8M1X39PdB?hZj(Sx(p) z9U=WxWRRHnZ&kLV?$OS~xwMjwk;tN{R3uTSA_?*trRl68hSVF6GEmt|qDM_Jh!-ps zC;;2>3lLG7`Qrezh1;d?c%62gw2S2$7KYSEUPN_=)YEVD)8NX=TjL5zbBo7gK2RFw zQ5CQKWBQL+kVtsKOwxP!IYA<_m;P?!1i8#Do>+C_~tep3p< zSP>?T1DYEc_v&7R(x=HtPE+1fCyBTNO8<-j)ql6XHx`_OdkVBtd6GYO` z=@1oPI=U4-nnxt1(ONoNf?L2U)lZ8^54b zW{&B5)#@XuFVoo3Fn~W<#U$rNZq3 z&k7PG<9V@i3#R{E80W}0AWorkp%^keq$gs~zAV{+I$S^*X)lS1XR;HbUVDMen;J%% zl1=qshFiDxr-V*eNU~q;V`{N~Ek&r>s?$#R&h^@p+Sa!>2J|@Nv!f73l)PpgSQE-e zz9SEC%)W8W)wJz^&PM8I9m{BVNQ_a#TOREn6lHjd+%R+q;|x6SMP?-l^4K1FlLiGS z^T4JnIvay@tR#KZHc$tw5GWI60(C56SJzNyf73C5x_TxBhbl>4n^qOCT1s(J4|!Le zU|CFdj=)+~(*Us&v@KQDb33(bl(n7sw6R`+)lf?hvYweO*-48bNSnHE%Fx*zRnF|~ zY^4#@vcO_7%>XJ`+eyKUF$?Nd3IvQA9k|=$SUDC>+xWQfR{e#?L{m72`vLmP` zU}#?^s3i?_yT4xXb3KsGrT=~$Dq~!1*3Y-f+F#SAJ4=UKfK-oIhV&21soF$vR&6e+ zc`GFFYUQRv3W^@jdVB_jbSxvPQB?cSI+Lf4Doh8_zE%3c(`L!y$HOf3`8V^S;P*|H zM(kH>9c@k;s+L-;wbtJ<_i6_$ph#q;LCv}3_WFHM2@ilTs zXGK4_@e69aS^C?Bk2+2EN{bPVbyc4re8X|}kyWN`5#7z_9pU-*S&hX{+C9Jyfo1Bw z+_}q5rZGBD)>NNNMVpyVF)W1ZWMWlld_8q)ce+X2=q!6wCr_!8O;Cv{J8>d#@F7tr zw!pCJco;jjbhTaj*#|~eKlUV&CQdyC9qT+8dAMC$LCP8RP7kJjmlW~&OGkwPDFOs} z6xH*!mp?BG@G9?Ap07HtsOB!U`ZZvMS+3~IPp3Ghgjv+IGugM{VRbA;t-nY*1j1>i zCN8`&Vj5z_)*uzY2UZuW0&t`AB62`o=na8!(AiAfj@*Anud{xzJL2Y9H_-0K;eb|O z^XTg8@YSLtOpsCxx|OJ~OimR8ohh=4IDb9nx$9UVQ}$YiPxiY$S?uGdbF|B|Rp4}@ zW7Nyq1&dBqRJDMB<@KG#DH7bcxOk9sTnrf?U@JGFO*h`Umrua3<_eZb^bxi0q!)bZ z<6+vkQO5s5510RKy|3IAK1lzXXR%O4+td~DLbQ-3#M2CJrKUY~9gs-c3|8R{$)Ltu zBnN^}o(6f29rBu7C1@cm!&#TaCg!3#Q}H5cs_RG;eAO}nK!ic2>CoFL=n1iK&bQQIEbq^DvLbySUGs6K7L1IhUK$(ZQ*LKE`T!3<>&QYj?88hT{B8;H0 z`}Y6Tut`{%c2n*-^BMA075iSB?0Gn~9Zz*2s;dO8+;jw2Z6Zf|);dPQJA&Nm^#z~_ zBg~IyN&(AVKSo~Bn17o9U=) zbvg}%#3EGzDIi8jAENHp_VcR0Wr&Unv+^(G8&ik+W69LX+SgRS@1wn=*Al%SMgeo8 zYHtu3s56NvoKJAc;2=DVy_yj;fcqe`@$TU3s|FDVOdUc1O)S~NRH0aSvnGv!H$%_d zMT&seI_9#hsu&7K>kPvyIV1vD4Q-vZ3+j_XzOp7ds9>*Mz|_O0bN&s%ezoI4;2>DA zY7c{eL({JAP?v!Ev-z)hbrc{%k`BI~40KQJbVlv1V=^4UhNS2^8<_Ae5b+qQbu$w~ zpFE*WvaGtJIz|}#VR=bDqJ!ZEDNSOP!MsX@&YeAl*13=>bys^lhN95Ps)%FFk`0Iz zX*!JS#*>_$fFqrd*TK~0(05ubVDKX8rNBy8M-^Cev_Yh1^r>hcdB!C&PT)CYDpk*FVzZSRiDe9q^#-F&seNPsA=;4tA zJS}=q+oJ5+RKFK|tJ;8?kD_Ny{`xBSc^RzwXa=sf58Wiu4NIWU=x93Lh;CAAV@^67 zUF1ecna2jtMIa)clTm9`lNK4TOI*7*3N8Pd)zbhR&(S9Ilbet{n8_3p;Of87r@T1s zILYzo+_3f-_5@G#nLLwcLET5S@tLF~qCP4Hkj6Tg8s{eK8PWL=iatzXE;U=~6n)ZG zQ+gfc0h+O`YL`xs2kqTVZqb#S*H$xT1>)LLsAInj(kwV z!t&SVgnrUzIe;v40etwiIJpz<{pcuXM0j@foxT3r&n_e8!6t(x4s^tsn+=d&*=pay z9jPXqI+6W4XeNk_6eXb%H@M&FU#pG|lySFM@ch#GFX)dn^UC4q?hCE?Yyd;ku??Lx zP(Res!H7%DGye1{cjh0ME-zmmbTR`3A41B`ts&@M{Hfx>MCvm+BC{D-%EuApxn#ui z0+E;KD94gkQu$M_0-vur!Nr*%#ozq$^E-^dXO$kj1F%57)&#>b6}sw1Y0)j5OTnde z@!_Y86CrGba{mac`_B5IRM~uIVGBWOG$~Y3du&mXJEX&+%T( z03_@+9bZH@MNOzRZ|;S(#ocB=n-{3r>hzKj?ocyuN(yP(B_}n=4zv#9=%{ke zdpDgqMu-*3G<|l4R}(=8Ofbm21C)bXiaHXhUwjUp>9o_0Ar*3snUlX6>fO^`YSJ|c zBDIKt5ylMTxbn09P0Y05w*5>I5w#HL`Oci4a*8@q?)aR*&PUlrgG4+99dLf z)lYnx5^xxAl8e9vb zkaIH5VUtAmKHR401AK-~X&@!=#J7_!nLaNo+;G1;j7LnCU(9M1X4duJfH2U7#*2M{xin6m&+Z4 z`*_r-bN^Va(+c`ZZ3pmRAUuM7;>;A&<>RE(TcrIp4HF*$)P}d&pl-jvjPvbK!Lyhf zea4YCeL9jm4K-zT***qORvhdL?Uj%}Ct4%k7gZ)}ko5^m(q1|RPiW{9nX1mdtpq8&5B39- z@GJVHgqtIo3xfxO&30GqMfaapysG969rXSXTdR-P^hpFY#FalMM&Q6H^);3{J(BE+ zq$f#;aK7pQKo|kDHq{QbbdX^ehxU~&A=$i&Wm?>dHc{sjSg(%1P!|(jtGYK>Pt;5# zp(l8#lfU4pN^{=5POhs8JUn)@J|<*!AZwt}^$ANlpb8$2=L|`+8dA(-5$X7&uI6@q z9t0v{g57QEuqARt=Ujatz93z)0M%RLmM|Y`@;KU?)yXby?F^lxjM|D(=Ds7I+(Ofd zp>6KJ00BuI;gglwivR!tglR)VP)S2WAaHVTW@&6?004NLeUUv#!$2IxUsI(bRY5C? zIAo|!7DPoHwF*V35Nd^19ZW9$f+h_~ii@M*T5#}VvFhOBtgC~oAP9bdI665gx=4xt zOA9SxJUH&hyL*qjcYshWGRDu$r-;LSslwHYBQ^;n4 z_cQvYG|+bobgtEVYwY9n0Z39;@f+aa5E#u-_PWQrJ6e1D_e`U|A2iHzj$7Z3hyVZp z24YJ`L;&dk=>X?M+JYqj000SaNLh0L01FcU01FcV0GgZ_00007bV*G`2j&A65*Rt| z66g&803ZNKL_t(|+U=cpcvMyT$3N%JOnL|{2uN2cRs<0N7leTB+CobP?7FU?``fjy zLW11{yY8whvAd#>K#(9dAYcOo3r)oUQlv;Hfz&DY{rzz#5FlmlWYX{VdFDx;nRCuP z_uTJ&&wJkUp7#X{7A#n>V8Ma~3l=O`Xu?QYGSC`?I)JioA1=<)pw%6{D z`_dW|i|CC9Ph<~7L$`zN5m3p#ueX9+4y;d#TWSqbEkLt|pa#{H#TTQYZUOs|G9(A+ z0_qpw!IZ^Atbwv5dIMEcvIha`JYW`ZMis@^fquEbj^wyy*5Fx0Zx{F93fx zS^YYY_bpY%B6w^?uGys%p1KMZ6`9W-22Z;yfTdGWOU|C%PCix&x+Cb2@2ASl(=b}CW z9-6xFPu5^tM6W}ATyZ<7r9gNMPPmVXCbJ*=tgrQ)EY+oUF?Hd^h$jCA_0L+o>?+WQ zB*iT|Vm$$i=ru3NKfg%BZl4W|s)Nh#0KH#{R}SAsY6Nf#G%7 zjXco%ipForL#@pvOGmF6l7A5dk}n4~RHJ?jXzP?tuas=d3(_Kbkku6p`x0P4HJWjO z{1s#%n!N|eJJo0_9JF-`b-qP*OLYkf{=M*O3bcct0)MVXGe3e{D#(FSUl!jk>h+-B z25bSg>jCK}nyj|e7>nouBW2NGl+xb=t_!>sc}8Koe{$ScC(jhwg8(@bv@d|z054Dg z(x*hr-(W3JEux!OR}6{!7^nvWY@!fk6e0_fhA*p1|BuqJF9XgA@LGpKKPxG2*$(T; zSwuHW@{m-Q4+hGlg*UYbV(3j-s$EQq$9 z(l-#2157gX_}hU;0_^^|8unRJ7hG&TNQ>x|NYu~&gil>*7XZm;i)feqh4z#PYvnx%Br$$G99(U0Qs>;W3aA!f5!uDt51 zV3WKo*+E_c0x@wqKz;f|_C5>$;G~bfwP4NxaJlB{cIUsk6Cg0XY ze;~eP1g$3QAT?G^>yETT7F-Ml$q#@9O=m{XtcY09wW=(_g~AkW;wRC^}1 ziAnV)q`GK#8&kJ`!V>srLkRFWWyJDA%*SFM4fM2#-pG)eJnjZBC3UTdDz7voOG_0} z{RNY+#|;+I8z@9o-osDe_ zl7}tJ1wJ-W<*L+011zF9Fx$fj{6AbVs}Tp$pJ}4(g`iqkL~mF`_jhF_h@RP4AFhsP zt{L?OrAAmpZzyWZ;sF4c`dNHg((q;b8tcQI68CK}u)u_XxWpoQ!&!x$0`&5;^hY#) zd}^ZX#VJb$T10Okw=}GVNYF6fd&Go9=NzRIX%W3)z~AUw`%$vC@e6d%24I&7O7ydc zUeDp1cKw}u7bgu{+URMX9Jd0%OxWM^EuzoJesaMerTed6uCIwcjG3_! zG`-w3BD0;{8Tsz-3cwaxV)vGW9^IO^hZUcsRtTU(WA?b99sbz__~ja*P#rKGC&nUr zt-x!elk(q@D`29JPTz#)i^H#><3$To5DA1M5-V^4#?I_nKv$px5I#12!|?+jR(xX9 zI`BKN#W&;pjFOdO({uI%1&As@iQ9My6q(NMX1l)4MA=gae(8W8l29F8v!W7Bh119_E@eus(cw6KU?f6>v8GKYYtCy!Wqr1Xn~j17ngUNp^y-Ws?{ zlzL1-`v!8~!xWVI_v`|09h08(rGi3tNC;V@x|Ysj2Tdd)Y;F;~{-UCk;9@Mq^zoqm zkQDa~@iW%r&@=?>BGMj6vY}6C1Y^)%9ZUK0f!*!CD=}lkzKq1~2;`YitD+kl(HoO_ z@x#QRz9#u4(OoX$suFMcM=!AFfd%dv%fN0Gdv&NfpVG z==BtB%cv)hYofg%;^q7O@1ZoEvFSt!jI}`;&?Mpw`p^aojY^{L1?dgaGAZtx7rxv7 z29wYG29%tN;dg#S!P`xYT>H&I7fM6YKUld%EaqbcxSpcyvhs0J|s z)gHM@C3>i(x->w8Yt2LNJ;sDf`fDrquWGgTko%<%=7%`H z{JnXVa<_}UgpT3Gj2O0*=51{yr$qMrYj{+P57+H`qA=-_T$HN(@r=&cfF{D~=FL^_ z+}yi?`!W1fY-NhwFx%PVz0~ZB2jTzO(btpWzPSw`JvshDP#=Qy19ml3vNsrsJ~llE zF}C@atD5z$E5_JFdf28^x<>?$u9G$XW9CU}0#%$(;%bTmzS4!GU706pw0W5%9-po}c+0JI0S z6Xebr$ydJ|W>@;CN3$%V2UUvC*oe|}8!$z|BQ%TIMjWzkDgWcl~95*niCJ((I1+=YHSz7H^@;HD>S=Ro+DAxTDTo z_l`}^xfgg4IOzMXt%>p2U3TIrL;8Pfs2km0{*;~+U+7G2IApKa8%AT&b3jQ8;5UL# zau2Wy!*4vot?QR&j_a{`wzEg2B+tvsBjvRZYzcX(ZA1wGHVt07<#&+$0ZLd%qI?#n_^9FE% zy$D@b3~RfIKML9r3XF~2c2ttMbUPm(?0iz2y<+o89Q`3)-OjqT{W+2!O<33=P@pTp z<;~T$u>6}#PMtXA@ugR!b{=$<-=@D~o{NA9H)f7MU)rf$0jbmvnvzNBldpc-Idz^` zL^lba+pLWe*PFnNL2P5Rcd z+H@{yvyGn)x8aLD-B?@{!{1u(OfE4&TYpjb}wBVZnnA|N85E5+Y#Wm zO}#m<_fj;mVI0Pj<7@`|N`84F`{0p2OMaY|FtpFaKn`~MeI`$iKbX>?5?jWTXlihJ za(uiJJc;#Km8n;%%NS$98HI7wEm$PqF3?M$-RyBaRwS;upY$YiQ?5uJE_Y%31EE>J zwF=oCUJ~L4pxNFiq8&OD2K|hFP97V*kt{B11_-T{n@xqMa`Wb)yq(t;l+dMlA<-en zM{yq7)5t*(8dk#0dGT!D)t&P8YhpJ=5x%xy^tNrwKUnkiyQZvVQx^?X_#b%HtLgk+ zg+xDY@&)x95S5V}ZxP)es|wH!k^KZG9pHX}z5<;xojra{TysC^$?+O67L(Da)~sC+ zS}56T99nKzad$6r7(Q!K++ZP-o*S^jq?L7B5(yllV#kzv< zqXTbK!i?2jSiW*FG0hH8T;f2pm6R_#-5Q!lQG9r}^S52=9!WLxqN2{g|MRq)CXX;e z_033*SNL}TrIRSNALwLOh%_mpk1O20oMq`W;%QPIQGZ;`S|V;0Np|D zL8)1C%%iVLyg1_nwPelb3)~@xTYK#~nn$C>jwnhZ-SoU{37XB2&>rQcedoO=u(M*- zH8#x6EhB!S&~4-MH68h3^_jG9QAo??dru}giY-MQ*-_MvX1|BAKli7H2G4wcY~Ef! zL$xT?$He#@J;kl*Wi2jMB2-Y@fPU%qP_oxK(I>4IfSZ9u)oeB%Ee8j<-Ckzb-z4!%Rb3S#^s`TsK6pSS8Rd-(5zU7?1gb-3*TkR@;0xT1XI7LD)L zT)?b(SMlA-!OUHLy5F6RzvO4OZ;$0~e_q99J@yhebODzR|Af%6Fmxuh3H*jZ1Ajj|G<%5{+CR{HgyQ&@Uk=gy0b`69!Yv~yd8K%X(}HWe8R)<>pWPiOyKzF+&~eD>u=u>8l~98h z!}!_EcXT3`C~W%+LKd!nzRGcXc*%JH7nzV3Ys-j^0R4y5JmA{*C&gPtA319yc3po2 zc)pra{8gakY-f+nK0RCkaiEHUhbyR8rK#=dw`Q}q=;x4Y`i+WG`~Ne{CtXukr!6&j%GmLjYLEq+lV}Hpd%$E$J|mnwl1bmkG%}& z`#m;~gTyx9bGW6Quze1~e=Qh0XL0hym0!kgGe>mFL|zny;RX>1*{9oW+%&zOkiAZb zKI*;A*meEkN{HyMF5XvH>W@6*%iF|`S}zVHOK39ux8a@^7C8r#aBaExcD!)Jt4Sp zGq~qc&fF?Q?~Nc_d1>o5_H#lHIXJRo%cGwyeX7E1I3&D3;PA6cMWW#`>Vf)CtjTA?`b=-cILg&8CIVcJ^3R#@_=`>UR7KdvRfU6}x(?{@8g> zbjR)N&1>URD-`)hTC?bzb3hBu{>YRY=kVx+>BLAOUw<=<^p%}iv8o$iZfZ$xeh906 zxR|0N5v<>N7XRDdmzDVWPyT9)kZ09U6ckE~Oo*Xo9m&$@C0@M1Mol^1|}Gsc!{fh_W~o!%I(tp(-% zIQ8{(wR6u;xBjrTAMdW{NL-Kogoo(N|0%fVj0*~z)2u|tv#kvael^?~10_Yr}rZVFok<<%OSj_u!9`D1Iz#M(hFmjmN7T27C!}<4km^+?ess zlq@om+m-Uo}Fzp?)ff#!U39&i2-L_k{{ZVcpuE>)X;+4yh3f*`U zQ?fvp6p%y$JAw2S&^@D$?CiB7(GxN@;1#;6z)grAfeSO8JyumNIM`&O&C7st{b=$E zy(5~H96QT!Xj>$1Z}46B7v{8~_c=M-*y0)3TuYzk>zTdhe0qfz(XXXp z@$()L-rv=qYubH}P3a75`7>V8cxabu_FCqbeSzaMTPWLA<^-=^X;LTW)GUD6>B%Ge z1K*k#lxh`7d(1^7XiyS8Ohdj4ux^o#>QW`i0YNsHnPg^Fut+NO=p%}YL%8NoztXW; zA?_$S>S-8E+;_$X&fZ#p=CYk|ABqUg!wv1eJ4$i@n_H34ZZ*?(3^*#;ZAz!Jy@a)! zi^@|`Mw#f&cS*yR`$a%!%G~b|>4llB)CM9%sUK!P7;kTML?4r}L5avhpj80X4-0gd zX?^D(yKP?{C^^kx7xHqOv;A-cQQ@u{8Tgod4|bEM zGsBdNgf_pj{NR}Yl<0Q0dP31~oLRQqql^3405cNZ)NJca&Dwy-*#VIKG_S5QYugf2 zvqb-R14<+nxHv$Pcg=M6IB2roxBkzhI8XfQndzVQ6;TuxMv!;Jh;{Vcju={ox`QUu zZNPszt)yGz?*Y|s6MBFx#m!iMq$>wqEdf~kM^Tp(%!*fGBE*Ft3(fY!nVOY@$hiUN z>{o+&aQ$m>jf3c8^W{=tQZ16abkXB4uAlQz{Be52wC`OJ03R&tOrLWNO{li3emXh0+|+RWUWG(7NZ zl+Kj7OF_m3P<0-)6uDQcA(Eqv%nXsHX$k}9IJ@r%^x6t?fXybV-2TyH$D~TJ$942< z<-sEn0EB2lxE7owcDg7^yb;xE<6y61NUxl2-M&Y}#@-@NL>X(#b>=K;GN;=2 zF^1o*2Njw1R;)xD?jPh|n}B4{f68a; z&|FH|=y*eQLikygjA6ZUn16|Qh>N*NKk zbbBA5pNTHbPa3|wFc{;r5abb!r6_p^D(es-UJkR504r=VqVh3&)~jHK0$Xx8Q#KJe>uUB4N#sW#E1SeOw^ z4meZiA|gXEobF6$0cu7~o=yrX(e0Wx3>a^++F^mK0!SxVvHJ2v7J!-AK@+9!2bg;2 z4c~|RoVG@EKS0}dCodca4_Zd|mIVR#@5#(zwU4wpYMg@+&Fri3}%cG;Q$7o_md6vP&o` zs5~)T^W72T=AO#;zC%WKyXR+x_IGoOP~M+BbcLrTh$SB81Fx8@_CosP_~!MR=n9zt zoN2P!b0uM+i)-S>oT*uxfNV1pk|>pIs6J{TK)a}tN-K2kypC3(f$`+0!y!EJUOWr4 zFDK>AYnk%e^*r{!t6BC(GiI*q$m7$mgTpCWY^APabhm)8NCQ2_M#a& zzC{gT{8L#V{2%5L`P$LcOCLTQUq6W+KV!Wem};`xHsHRG;yc&e3PeaVS>wKpr1%yw z;c5ZE$D3M`f4KZpLpI%pO%y}V-4Sp!aRHWWYDIxZLzk1AiHzP?ZoLrQI6q$G^O3ov zwPUxt^S>_wTAH~0MybSGF@*`$M5)K)2gQDNK{G86VB6O6*A8CIi>~SP>GL(I6Q|Rs{h^?T&(Ha_cbVamva4+r ziil7z-I^ES75z;h$>iv~njE)`TEGg-pFemZ*gK}xCi<8e8$*GIOjdjAaEq9wH9f-P z40G3WCae9u+3MH3hC9?70P|OLMBI)l-`cTP%_nu@bZ#BGK4^rWvAiosj+{KBxG2UZ z4)*Skrt2yBTz=Im0aKwVyog>KVYhLn&c$w%`#2Wt)USo981Z-N57CvT-;KHaI3)uA zTyR<2+8AeaU0$YwlSCEXlc*Q2yX2G?loIlE8{59?k4^kp;|blmf6oKsmIST;#YN4^ z{r+Hna~z>AIMRBSgs!>PWV3H34PRbBEn&=KSzeIa%@Iqb2GiVFEuvpF?{{T>$|T7w z@v5~bdNRw6*+>J5_~vWhIBQ5N`^x~Yuj|Ue&-&r;`gg`SKR+gD{r7lJencKm2(M+v zQB-W_lA-Ii1Ew}x1o=0$j||{z6Xnl9sT=AA(L;-h{)RcHoE-u$WY(~5ev(v2rcx$d ziJxpwOS=C2$-TmrTYzVOKb;m|o`Mmoyf|KirX4yP|wTzkJ7+LxE@$iOwB<<-AQmtjR^_lgV*QsS9*Hl^=mwCaUy8srWi2IwHe?o@UHhI!v#N0Un={ zg?J?e6EPQkcw$`W{OrEXR64*<`LWpZ%CUl!C3b%YE5o&_Ri&nMhJBM9D&0TW#rIdaV4@i}!P&3*4B zZXntGZR*qe4(>nx+$gqW7R2D%*SuV5u6sk+xxG7!*PRlyK1VB1zC+oCF)mj9IE3$a zMG@c8epmSEZ;irax_3dIntbU}>KL0bT)6$kKn>NePKZ7_J*Oq+4&MGDsOfb%y5pb9 zLXej*=c^7dBrfOSTc_S|-Z?$P)&4IEdl7XY426cxx7%J=7|oP7oV@Z$fAT!Gp!Ip9 z$7o+1!Z({QV%B$^7~eJGsf#Xu_bcF5lg+IJ`M9oGZsa|ZRFl>IuTF@r?u1_-000)$ zNklFi$T=|9G$WC_SW0;u}m`~_2+J#*tZUDq6p-Cy!YERGTlw|G%X zXVnw@r!ry=WGc(t8V0_nzr)TuNev+WSj``G?$+fgW9Y;UVTx0c?L$bE>k8>n<#Z- ztrFd?v@cd)cx!O3 zIy+K3_`(%!x;bp>y_6+GS`bJ$Kau+_$wVZv=SMzUz`M)hqL8y)G`5_{n* zXkvd4^U>9&13%Wc2Qb!%!Dz?`0$tRxt*@cAI+Y@&9w` zw($?u6EP+xUZEBCSKIk#it z;IlxtOlOZR^>vhuFbnD-;L!l8Peqp`U*OH7nE3enOndNJZhiEBp_}#;hhA|(?C`WN z_FQyfyQr=qA#}HE+P+PDOMYwJ%(H9gIj7G0a^2o-=X4D%S+>5=GyMGK+z>+Zujdj3rhl{5@XgCtS@$d~LK*_lDkLGBKIX0WZu7TaAuqlPZrs&*0 znvCl%C&O3w(-YsMCH)aydn^EwgOZz*ht+SA8{L%IqSU+oYZvNrjC4LVBhkmq{1v5C z0pPDa^P$;2egB*i02eGFXgXO%2x%3RawGyK=ll^S4zPhVW`W2AV0{49Pt`ST)q4+A-^(sFdk{so{45|4zk*jn^sohw4qelrc}q9o0%oQz8U(242rO>pCh*>Q--w1d z^jUx@_u>9ELUg618@}}7e(L96({Qm5b14hUq93S*fsj2Vdk`o!8Mr5)*&i8^6t~>l zfXCg;uGU3n?dkrhE=tUp-gXzb-M=-|(e|YW{01aY*U;gh7MLM>>Y_m?)a^iOV3(9@ zK(;nuk|QE3Ocd`};xU&h$X^}(JQHnx``LA8H{>zLnKBoTgI9n+4-t<5^{qeY!Besa zf>M(RECMmWi@GOtMm=)D4G6l%dQ4=iQ>flGLG*J?wD~=a0M|Z}1?YDJ9|qV&e}_%| z^q=Q%sdV9~(B8m&l(SMS1n<35E?eB-$NL&1FszwX^qDn5bTf^vrjfvzGEWdmFsVP5 z#aX8uIJiAM`Rd~`e@tD{pU0M57!K+e%mwW)i;W;xB*iV)X*@6!ouFq>i9Tk=#t@*J z|GJi1-G~Oh)Dklc^PY~S=m6TD^rZOHN*7R~+nd?-kgY(VCpPwr(l1DgTk391V~v;^ z{QF~VV^NGa)64YE5xeF*A>)3RHW6t~Q+bTvVc0r;Pk zHdm0-LG~sOUDo&pSr;=z@030zK6pgOT=2?GG*XOuGz*7~LZ#%)YLHz4ccIj}^!u+4 znLOfaK)waN8C7qxZAa-{LH0Cs3rmG$w3~{h9wOrZ-i}3d^JFgo=}Gm%x}A+f%S}&? zzwETdu_VPUD>_WUaFE0b%6|p=8KTH-tRx4pYj}V?eoGCZeK3jM-b7!w(a16C(JY)P zSw$dyFk*iPif~Y$Db&0f502u=xK#kNKw4qsN-bTX-LK=mBq?rLNuyL(P8eHYumAI- zY936Yn~Cqdl_mmbN>&NFelccKJ)VrKG+mCQC&yoLT6Qc-^BmOioGHl7Af13`ro^of znhp+_DBB{KL_gKUg`Xdto)hB>K-&1pK6Rc4^ic#7g5r2YftrtERksDF#B|R-MF)8Y z(YGhXEv1R!kl!UGxI{N|sGzq72b9R1+g|^U(M^Ex&Xjo~O5Gjc!Htu~4^2BDO3m!K zxGi0mv}rQzPEQ_5deYS$FtZDZY24-2h4Cp_jgQ=u<3Up(T#Mpqlj}i% zyPYX>U#vFK$IRFmqclCYn)l-YR_c(bU}r-meEf{{I5Z6%I%x0)@F$F;g*&`x=YHrs z<4}5XJPKk2^&Jqbs7=MdOt;N(v%~8u^{#B-(mNg{(pr@E1~38>M>J2s!_Jhsk5!-O z={cQMa2J@nffq&ODU_nVlYUHk4hj&VgHpTz45R!MhxtH1cSy*uH?6)4mrHDD+KU7s z3hW62<2!V@2E|q*Ds973P0s8&mtTGz`6O@?5RCZRk2+K4J`xO~_f<9Hjp)TNMZW0p zdS7zeY`Arutnt0-^kI~$Budi}UAq?J5X9+#KhgbNz(`%GPv<0dXJ*n!G$lg>^+gSI zbuaKvE};)Jrvzup+OXGIX z_gNwEx#%p>GyNt4R}j*@7qeVl_17ABnDB{DYJ+~7jLMh*~aga*Y2};*Z_xb77E39QER); zpJ}@OmkggemYy^ckQkJjzGSWR1BY5Q$EL4SGywLkYXOE+PnLr~I3#0=fa8ejAICbZNN7 z=ZbZ9fsvWc9>-^>@;wXLqZu7!w4fKi@)#=G20f|O<5T*WQ4O_V)JQ>uhz@h3`m#RG_jhV3#&E`RL zts9EBfFVuvi4*|;1m*$zbxmVVf`5BP=}GaRR7>Cy;2##b*^6NX`vRmS7@K54)4k$n ztjD1gD0K>O7ci*_JdhHBhZTHa^Ln>?Z8m0C!z7xXJQ74=P)q>zR1+k48ZcFq+J>$( zE{K+*8d+rcbofw#{>q4r(z_8ojLkmDyV&OS?(}FjGRFni-k+Wv4LF~+T->GJOaFJnY2E~pK1*9p;&)8{|jg5Bjp8T-Z2 z7(Ni^VWeHZ3W%zOZX5;{U>r(b4(#zNwbv%11Gqy%$QsqP-m&GwhvRX16hw!>5m#r7 z5XyG}ed<|PKl06l>xc^3LB0!}x^p+KHyZ(EBt9NAn@#jq%5bcY0lEovSB4+TsTel= z7~kyBqKwt!5XL6RK46!?c4Zvc{tY8L+Yy00cX8OEkg#F_YTT!$HY7bLM0AJJw2l~2 z)e?Y__~(ok415VP7t|8q4{X|AygDKh)CFauAbO=Q!ORUO`L6f_@oiy?u9!2vJ52#T zQ>AhLy6#Y#7V8rR?GU*DrFvpS2V8Ma~ z3l=QYI2yOrB{A*f?=mJ>PrbG<=2g(NikT+BtO*T(=m}}5AQ}ks z(Yp|1b8jo~KT0!p*PsxxSMxO)2Rv7!LoAE|=9sQ`&CB2+`GlAG95gioSZJy(uO|wd z_D!AAyxeh6-BHv=zh1)dwXcNWuYq`*qtv^=WmJAfH`@2siH%il%uv*)@3X$$yJmZPlziC ze=~HowG>2bfUpwPcbJx+h1gJ>tz6`v`%nGh;^eG?bG$*18fD@(8J0zwpCu734 z;B>X|VTd2nSE0BE3)Mv>0!4q)FDpv=M9{g7rHPtSiTSnH|AMRa3O{0*!$fyA_C z7FPpRTc*VTaTWZ!AH$W`Kg^!s0m=*aaTQ8C-y-_Sw{t%J2UH5BDwCOoN`_jUO~v~# zQAC%RYcF=^N5IB%e)+pa^s*T9DyS-T^Am9o39r~K)&{i5tt{ej7)Qd*#g}~LF)-}! zgHHIo)G!vKwFR5j3m9XvRtuE%-Nr%m5LX9`ApR%fTi}i=YInoq z7;Q1vG<9-;MO75)gRq0KX}x`$coxyCIgL)LU|}>BuPYrRK1*fzS50g?H)_nf4TQV> zDA^W`RVdzJT$+usuhmI+YhFjs%*YFfME<&PCQNHX`I{E&(QWg{{0AhaJxAq9Z%YH* zH^%I>1p&XrRoTIXpHSQnJnctoH=>h>l2^Fxxqope0%qObh$MRAI4_1%khzcICjX?l zx(6d*{fQ6ZNoL<#`u}Sfnd2(M1B`jK@zGrIc|hZD#C)tAvnPP2KLb4GXK%t$+(&NI zVU+d=&Nrwn2Rp4+hB~m1A1_f_ByeXrzibEBF+Y-76N-TURMFa1*t8xrMyl83Gnjch zz{3b5@!y*=+Nk3_jM64E?)6fGLX*_d{mFv&FAQh?6Y&(Y{-K{B;h(2!FUtEY<@+f7 zPjYLhI9Uj>m^(WV4Wy#$dkA%ntI2gz&FkoHZ%Z~EFrR(8xl}G4#=IU1dU?`(KjqoQ zHT?jhy#w4@Nvk)JFfEB$6ZbV5x(cKDb+7qY%q`3=PA32yATezW!g;==5dOx4Yy->y z?jbSlN?>oWPaD-d(KRKkdocJ11Z;Xmk$9gkcatLhb{L!XBwD3JxBGPd$&E-d*Ub1= zCf(!TUPEX}Uqtms@m~{!?+5Gv5=ls#8%(duhG|~>%X11yD%ZjwQt_6tsNaC9;;H=~ z329-L=28u0-3%EM!49l(buZVjd?(=dr19rZVih`J}@6=qGW*t(K= z8&quyi$Za`#nzw_{#%ef80SN``dRyR;Li<5bqO}cz6p3LQY}0rrd73xAsAt$V=G;h zUjFYF`Q%Qq*cv3l12|v(8clV@qwYoVtRFSsC*k!D%=%kV(<8d(8HW)ky*wlZ=_>7s z3cHrtIO^7vknWo(6Vjdoz5u?Wa_de@lztmV9;_y$x+F{kc(|6XHi^V(7CCDI#v=0v zjNRy}X3e;!r@AP0CD5~+U-GGX=kr8_QF;EPvp`*nk^aTPiKu9y=&xBYV*-p#TaCtJ zRS2(6O=~e~c)vYZ&M#iyV6-#!DRj5?uCS58O`09!DkZI%7(XY90Szgw6+0d!ue zqLe2XoozT0T`>f>u$*7sLFtE%>VN*jOJdr~RG#>EC`!%))>yng3F|NttDPV^)kuu2 ze*Qu9eV`qt;(SZLHyw#?NY#fbu%SE_0Le@1KJS|mDto~u;e6Gi^~qzGS>Y@={=fdW z6I}%5IprP0(xyXnC4GQl<^1wKsv2*+rtbsZsiM?4MC)WR`y|Yu{ODn4;RS25@_=Hgt(9xCF3nORdiI{_^U#mX_s|_IYfh#L1HGzb*hnO`XuK`kW014GR zw<&C5_JotyDK`C0yxNr&JfAca*N~Vt8GLaoOS9YMxixIsM9`n0V)wCi=-LC!4vxP| z{U*BeRgeldfl`?rgdmiew?SgslT{Es6vaP)CmI~hRfSU5OdBs#UP|^Ew?ksuSm0xf zP!%U)2(ZjY@!wGt0PicNeO6TB$-Gg7JbN?}9==mk_o@~LD@IFH#A@`HH;)g`*!FL@9+9e)>NVib4Yb;$m#P$&3*r|bX{yudB#00000NkvXXu0mjfzU%kB literal 0 HcmV?d00001 diff --git a/README.md b/README.md index 7f447c1ae2..a7688d60fa 100644 --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ -![FATES_logo](.github/images/fates_logo.png) +![FATES_logo](.github/images/logo_fates_small.png) ------------------------------ [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.3825473.svg)](https://doi.org/10.5281/zenodo.3825473) From 4cbf4f2f44c7f7ac53c9f67e6a1e273fbcca85fe Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 6 Apr 2022 10:48:16 -0400 Subject: [PATCH 548/578] Initial work on FATES mimics coupling --- biogeochem/FatesSoilBGCFluxMod.F90 | 39 ++++++++++++++++++++++++++++++ main/EDPftvarcon.F90 | 2 ++ main/FatesInterfaceTypesMod.F90 | 8 ++++++ 3 files changed, 49 insertions(+) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index d14ce7b005..467c91e6eb 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -55,6 +55,7 @@ module FatesSoilBGCFluxMod use FatesInterfaceTypesMod, only : hlm_nu_com use FatesInterfaceTypesMod, only : hlm_parteh_mode use FatesInterfaceTypesMod, only : hlm_use_ch4 + use FatesInterfaceTypesMod, only : hlm_use_mimics use FatesConstantsMod , only : prescribed_p_uptake use FatesConstantsMod , only : prescribed_n_uptake use FatesConstantsMod , only : coupled_p_uptake @@ -993,6 +994,9 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) ! Zero out the boundary flux arrays ! Make a pointer to the cellulose, labile and lignan ! flux partitions. + if(hlm_use_mimics) then + bc_out%litt_flux_ligc_per_n(:) = 0._r8 + end if select case (element_list(el)) case (carbon12_element) @@ -1126,6 +1130,41 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) end do ! do elements + + if(hlm_use_mimics) then + + ! If we track nitrogen (ie cnp or other) then + ! we diagnose the c-lig/n ratio directly from the pools + if(element_pos(nitrogen_element)>0) then + + ! Sum ligC and totalN fluxes over depth + sum_N = sum((bc_out%litt_flux_cel_n_si(1:nlev_eff_soil) + & + bc_out%litt_flux_lig_n_si(1:nlev_eff_soil) + & + bc_out%litt_flux_lab_n_si(1:nlev_eff_soil)) * & + bc_in%dz_sisl(1:nlev_eff_soil)) + + sum_ligC = sum(bc_out%litt_flux_lig_c_si(1:nlev_eff_soil) * bc_in%dz_sisl(1:nlev_eff_soil)) + + if(sum_N>nearzero)then + bc_out%litt_flux_ligc_per_n = sum_ligC / sum_N + else + bc_out%litt_flux_ligc_per_n = 0._r8 + end if + + else + + write(fates_log(),*) 'If FATES is coupled with MIMICS, N cycling' + write(fates_log(),*) 'must be turned on. Both coupled N cycling, as' + write(fates_log(),*) 'well as a prescribed N cycle' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end if + + end if + + + + return end subroutine FluxIntoLitterPools diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index a149132a8d..faa0144d7d 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -1605,7 +1605,9 @@ subroutine FatesCheckParams(is_master) p_uptake_mode = coupled_p_uptake end if + + do ipft = 1,npft diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index ee18396d70..3f154532f6 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -602,6 +602,11 @@ module FatesInterfaceTypesMod 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 + ! MIMICS Boundary Conditions + ! ----------------------------------------------------------------------------------- + real(r8), allocatable :: litt_flux_ligc_per_n(:) ! Grams of lignin carbon per grams of nitrogen + ! in the fragmentation flux, per square meter + ! Nutrient competition boundary conditions ! (These are all pointer allocations, this is because the host models @@ -641,6 +646,9 @@ module FatesInterfaceTypesMod ! for use in ELMs CTC/RD [g/m2/s] + + + ! CH4 Boundary Conditions ! ----------------------------------------------------------------------------------- real(r8), pointer :: annavg_agnpp_pa(:) ! annual average patch npp above ground (gC/m2/s) From c14c30939a489d0128f55263ce717725c9e81743 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 6 Apr 2022 15:37:17 -0400 Subject: [PATCH 549/578] More code to add in the litter quality flux for mimics. incremental --- biogeochem/FatesSoilBGCFluxMod.F90 | 69 +++++++++++++++++++++++++++--- main/FatesInterfaceMod.F90 | 39 ++++++++++++++++- main/FatesInterfaceTypesMod.F90 | 11 +++-- parteh/PRTGenericMod.F90 | 2 +- 4 files changed, 110 insertions(+), 11 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 467c91e6eb..75459fdce0 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -955,6 +955,16 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) integer :: ic ! CWD type index integer :: ipft ! PFT index + ! The following are used for the MIMICS ligC/N boundary condition + real(r8) :: leaf_c, sapw_c ! leaf and sapwood carbon, per plant [kg] + real(r8) :: fnrt_c, struct_c ! fineroot and struct carbon, per plant [kg] + real(r8) :: leaf_n, sapw_n ! leaf and sapwood N, per plant [kg] + real(r8) :: fnrt_n, struct_n ! fineroot and struct N, per plant [kg] + real(r8) :: total_c, total_n ! Total estimated C and N for plants, [kg/m2] + real(r8) :: sum_ligC ! Flux of lignan C [kg/m2/s] + real(r8) :: sum_C ! Flux of all C [kg/m2/s] + real(r8) :: sum_N ! Flux of all N [kg/m2/s] + ! NOTE(rgk, 201705) this parameter was brought over from SoilBiogeochemVerticalProfile ! how steep profile is for surface components (1/ e_folding depth) (1/m) real(r8), parameter :: surfprof_exp = 10. @@ -1131,7 +1141,7 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) end do ! do elements - if(hlm_use_mimics) then + if(trim(hlm_decomp).eq.'MIMICS') then ! If we track nitrogen (ie cnp or other) then ! we diagnose the c-lig/n ratio directly from the pools @@ -1152,11 +1162,60 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) end if else + + ! In this case (Carbon Only), we use the stoichiometry parameters to estimate + ! the C:N of live vegetation and the seedbank, and use that + ! as a proxy for the C:N of the litter flux + + total_c = 0._r8 + total_n = 0._r8 + currentPatch => csite%oldest_patch + do while (associated(currentPatch)) + + litt => currentPatch%litter(element_pos(carbon12_element)) + area_frac = currentPatch%area*area_inv + + do ipft = 1,numpft + total_c = total_c + & + area_frac*(litt%seed(ipft) + litt%seed_germ(ipft)) + total_n = total_n + area_frac*prt_params%nitr_recr_stoich(ipft) * & + (litt%seed(ipft) + litt%seed_germ(ipft)) + end do - write(fates_log(),*) 'If FATES is coupled with MIMICS, N cycling' - write(fates_log(),*) 'must be turned on. Both coupled N cycling, as' - write(fates_log(),*) 'well as a prescribed N cycle' - call endrun(msg=errMsg(sourcefile, __LINE__)) + ccohort => cpatch%tallest + do while (associated(ccohort)) + + leaf_c = ccohort%prt%GetState(leaf_organ, carbon12_element) + sapw_c = ccohort%prt%GetState(sapw_organ, carbon12_element) + fnrt_c = ccohort%prt%GetState(fnrt_organ, carbon12_element) + struct_c = ccohort%prt%GetState(struct_organ, carbon12_element) + + leaf_n = leaf_c*prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(leaf_organ)) + sapw_n = sapw_c*prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(sapw_organ)) + fnrt_n = fnrt_c*prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(fnrt_organ)) + struct_n = struct_c*prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(struct_organ)) + + total_c = total_c + ccohort%n * area_inv * (leaf_c+fnrt_c+sapw_c+struct_c) + total_n = total_n + ccohort%n * area_inv * (leaf_n+fnrt_n+sapw_n+struct_n) + + ccohort => ccohort%shorter + end do + + currentPatch => currentPatch%younger + end do + + sum_ligC = sum(bc_out%litt_flux_lig_c_si(1:nlev_eff_soil) * bc_in%dz_sisl(1:nlev_eff_soil)) + sum_C = sum( (bc_out%litt_flux_cel_c_si(1:nlev_eff_soil)+ & + bc_out%litt_flux_lab_c_si(1:nlev_eff_soil)+ & + bc_out%litt_flux_lig_c_si(1:nlev_eff_soil)) * bc_in%dz_sisl(1:nlev_eff_soil)) + + !bc_out%litt_flux_ligc_per_n = ligC/TotalN = ligC/totalC * (totalC/totalN) + + if((sum_C>nearzero) .and. (total_n>nearzero))then + bc_out%litt_flux_ligc_per_n = sum_ligC/sum_C * total_c/total_n + else + bc_out%litt_flux_ligc_per_n = 0._r8 + end if end if diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 3ce7589f48..c7bc24acca 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -36,6 +36,7 @@ module FatesInterfaceMod use FatesGlobals , only : fates_global_verbose use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun + use FatesGlobals , only : fates_unset_r8 use FatesLitterMod , only : ncwd use FatesLitterMod , only : ndcmpy use EDPftvarcon , only : FatesReportPFTParams @@ -304,6 +305,10 @@ subroutine zero_bcs(fates,s) fates%bc_out(s)%rootr_pasl(:,:) = 0.0_r8 fates%bc_out(s)%btran_pa(:) = 0.0_r8 + ! MIMIC litter quality, always initialize to unset + fates%bc_out(s)%litt_flux_ligc_per_n = fates_unset_r8 + + ! Fates -> BGC fragmentation mass fluxes select case(hlm_parteh_mode) case(prt_carbon_allom_hyp) @@ -624,7 +629,6 @@ subroutine allocate_bcout(bc_out, nlevsoil_in, nlevdecomp_in) bc_out%rootfr_pa(0,1:nlevsoil_in)=1._r8/real(nlevsoil_in,r8) end if - ! Fates -> BGC fragmentation mass fluxes select case(hlm_parteh_mode) case(prt_carbon_allom_hyp) @@ -1275,10 +1279,12 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_masterproc = unset_int hlm_ipedof = unset_int hlm_nu_com = 'unset' + hlm_decomp = 'unset' hlm_nitrogen_spec = unset_int hlm_phosphorus_spec = unset_int hlm_max_patch_per_site = unset_int hlm_use_ch4 = unset_int + hlm_use_mimics = unset_int hlm_use_vertsoilc = unset_int hlm_parteh_mode = unset_int hlm_spitfire_mode = unset_int @@ -1460,6 +1466,28 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if(trim(hlm_decomp) .eq. 'unset') then + if (fates_global_verbose()) then + write(fates_log(),*) 'FATES dimension/parameter unset: hlm_decomp, exiting' + write(fates_log(),*) 'valid: MIMICS, CENTURY, CTC' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if( .not. ((trim(hlm_decomp) .eq. 'MIMICS') .or. & + (trim(hlm_decomp) .eq. 'CENTURY') .or. & + (trim(hlm_decomp) .eq. 'CTC') .or. & + (trim(hlm_decomp) .eq. 'NONE')) ) then + if (fates_global_verbose()) then + write(fates_log(),*) 'FATES dimension/parameter unset: hlm_decomp, exiting' + write(fates_log(),*) 'valid: NONE, MIMICS, CENTURY, CTC, yours: ',trim(hlm_decomp) + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + print*,trim(hlm_decomp) + stop + + if(trim(hlm_nu_com) .eq. 'unset') then if (fates_global_verbose()) then write(fates_log(),*) 'FATES dimension/parameter unset: hlm_nu_com, exiting' @@ -1467,6 +1495,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if(hlm_nitrogen_spec .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(),*) 'FATES parameters unset: hlm_nitrogen_spec, exiting' @@ -1524,7 +1553,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) end if call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + if(hlm_use_vertsoilc .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'switch for the HLMs soil carbon discretization unset: hlm_use_vertsoilc, exiting' @@ -1839,6 +1868,12 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering the nutrient competition name = ',trim(cval) end if + case('decomp_method') + hlm_decomp = trim(cval) + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering the decomp method name = ',trim(cval) + end if + case('inventory_ctrl_file') hlm_inventory_ctrl_file = trim(cval) if (fates_global_verbose()) then diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 3f154532f6..3e3e0191a3 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -46,7 +46,11 @@ module FatesInterfaceTypesMod ! specficially packaged for them. ! This string sets which filter is enacted. - + character(len=16), public :: hlm_decomp ! This string defines which soil decomposition + ! scheme is active + ! expected values are one of CENTURY,MIMICS,CTC + + character(len=16), public :: hlm_nu_com ! This string defines which soil ! nutrient competition scheme is in use. ! current options with @@ -602,10 +606,11 @@ module FatesInterfaceTypesMod 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 + ! MIMICS Boundary Conditions ! ----------------------------------------------------------------------------------- - real(r8), allocatable :: litt_flux_ligc_per_n(:) ! Grams of lignin carbon per grams of nitrogen - ! in the fragmentation flux, per square meter + real(r8) :: litt_flux_ligc_per_n ! lignin carbon per total nitrogen + ! in the fragmentation flux, per square meter [g/g] ! Nutrient competition boundary conditions diff --git a/parteh/PRTGenericMod.F90 b/parteh/PRTGenericMod.F90 index 3dab9563a3..35488bd8cc 100644 --- a/parteh/PRTGenericMod.F90 +++ b/parteh/PRTGenericMod.F90 @@ -279,7 +279,7 @@ module PRTGenericMod ! examples are carbon12_element ! nitrogen_element, etc. - integer, public :: element_pos(num_organ_types) ! This is the reverse lookup + integer, public :: element_pos(num_element_types) ! This is the reverse lookup ! for element types. Pick an element ! global index, and it gives you ! the position in the element_list From ede09355962751fae522ab0cf376732ef93ef7ba Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 6 Apr 2022 17:54:19 -0400 Subject: [PATCH 550/578] Restructured the C-only method of calculating litter N flux for MIMICS --- biogeochem/FatesSoilBGCFluxMod.F90 | 118 +++++++++++++++++------------ 1 file changed, 71 insertions(+), 47 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 75459fdce0..bb6c8efe28 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -960,10 +960,15 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) real(r8) :: fnrt_c, struct_c ! fineroot and struct carbon, per plant [kg] real(r8) :: leaf_n, sapw_n ! leaf and sapwood N, per plant [kg] real(r8) :: fnrt_n, struct_n ! fineroot and struct N, per plant [kg] - real(r8) :: total_c, total_n ! Total estimated C and N for plants, [kg/m2] real(r8) :: sum_ligC ! Flux of lignan C [kg/m2/s] - real(r8) :: sum_C ! Flux of all C [kg/m2/s] real(r8) :: sum_N ! Flux of all N [kg/m2/s] + real(r8) :: tot_leaf_c ! total leaf C of all cohorts in patch [kg/m2] + real(r8) :: tot_leaf_n ! total leaf N of all cohorts in patch [kg/m2] + real(r8) :: tot_fnrt_c ! total fineroot C of all cohorts in patch [kg/m2] + real(r8) :: tot_fnrt_n ! total fineroot N of all cohorts in patch [kg/m2] + real(r8) :: tot_wood_c ! total wood C of all cohorts in patch [kg/m2] + real(r8) :: tot_wood_n ! total wood N of all cohorts in patch [kg/m2] + ! NOTE(rgk, 201705) this parameter was brought over from SoilBiogeochemVerticalProfile ! how steep profile is for surface components (1/ e_folding depth) (1/m) @@ -998,6 +1003,10 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) surface_prof(id) = surface_prof(id)/surface_prof_tot end do + + + + ! Loop over the different elements. do el = 1, num_elements @@ -1062,6 +1071,7 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) flux_lig_si(id) = flux_lig_si(id) + & litt%ag_cwd_frag(ic) * ED_val_cwd_flig * area_frac * surface_prof(id) + end do do j = 1, nlev_eff_soil @@ -1077,6 +1087,9 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) end do end do + + + ! leaf and fine root fragmentation fluxes do id = 1,nlev_eff_decomp @@ -1140,26 +1153,23 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) end do ! do elements - + ! If we are coupled with MIMICS, then we need some assessment of litter quality + ! ie ligC/totalN. If we are not tracking N in the litter flux (ie C-only model) + ! then we need to approximate this by estimating the mean C:N ratios of each + ! plant organ, and mulitplying that by the different C Fluxes to get a total + ! approximate N flux. Note, in C-only, we will not capture any re-absorption. + if(trim(hlm_decomp).eq.'MIMICS') then ! If we track nitrogen (ie cnp or other) then ! we diagnose the c-lig/n ratio directly from the pools if(element_pos(nitrogen_element)>0) then - ! Sum ligC and totalN fluxes over depth + ! Sum totalN fluxes over depth [g/m2] sum_N = sum((bc_out%litt_flux_cel_n_si(1:nlev_eff_soil) + & bc_out%litt_flux_lig_n_si(1:nlev_eff_soil) + & bc_out%litt_flux_lab_n_si(1:nlev_eff_soil)) * & bc_in%dz_sisl(1:nlev_eff_soil)) - - sum_ligC = sum(bc_out%litt_flux_lig_c_si(1:nlev_eff_soil) * bc_in%dz_sisl(1:nlev_eff_soil)) - - if(sum_N>nearzero)then - bc_out%litt_flux_ligc_per_n = sum_ligC / sum_N - else - bc_out%litt_flux_ligc_per_n = 0._r8 - end if else @@ -1167,58 +1177,72 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) ! the C:N of live vegetation and the seedbank, and use that ! as a proxy for the C:N of the litter flux - total_c = 0._r8 - total_n = 0._r8 + sum_N = 0._r8 + currentPatch => csite%oldest_patch do while (associated(currentPatch)) litt => currentPatch%litter(element_pos(carbon12_element)) area_frac = currentPatch%area*area_inv - do ipft = 1,numpft - total_c = total_c + & - area_frac*(litt%seed(ipft) + litt%seed_germ(ipft)) - total_n = total_n + area_frac*prt_params%nitr_recr_stoich(ipft) * & - (litt%seed(ipft) + litt%seed_germ(ipft)) - end do + tot_leaf_c = 0._r8 + tot_leaf_n = 0._r8 + tot_fnrt_c = 0._r8 + tot_fnrt_n = 0._r8 + tot_wood_c = 0._r8 + tot_wood_n = 0._r8 ccohort => cpatch%tallest do while (associated(ccohort)) - - leaf_c = ccohort%prt%GetState(leaf_organ, carbon12_element) - sapw_c = ccohort%prt%GetState(sapw_organ, carbon12_element) - fnrt_c = ccohort%prt%GetState(fnrt_organ, carbon12_element) - struct_c = ccohort%prt%GetState(struct_organ, carbon12_element) - - leaf_n = leaf_c*prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(leaf_organ)) - sapw_n = sapw_c*prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(sapw_organ)) - fnrt_n = fnrt_c*prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(fnrt_organ)) - struct_n = struct_c*prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(struct_organ)) - - total_c = total_c + ccohort%n * area_inv * (leaf_c+fnrt_c+sapw_c+struct_c) - total_n = total_n + ccohort%n * area_inv * (leaf_n+fnrt_n+sapw_n+struct_n) - + leaf_c = ccohort%n * area_inv * ccohort%n*ccohort%prt%GetState(leaf_organ, carbon12_element) + sapw_c = ccohort%n * area_inv * ccohort%n*ccohort%prt%GetState(sapw_organ, carbon12_element) + fnrt_c = ccohort%n * area_inv * ccohort%n*ccohort%prt%GetState(fnrt_organ, carbon12_element) + struct_c = ccohort%n * area_inv * ccohort%n*ccohort%prt%GetState(struct_organ, carbon12_element) + leaf_n = leaf_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(leaf_organ)) + sapw_n = sapw_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(sapw_organ)) + fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(fnrt_organ)) + struct_n = struct_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(struct_organ)) + tot_leaf_c = tot_leaf_c + leaf_c + tot_leaf_n = tot_leaf_n + leaf_n + tot_fnrt_c = tot_fnrt_c + fnrt_c + tot_fnrt_n = tot_fnrt_n + fnrt_n + tot_wood_c = tot_wood_c + sapw_c + struct_c + tot_wood_n = tot_wood_n + sapw_n + struct_n ccohort => ccohort%shorter end do + + if(tot_wood_c>nearzero) then + sum_N = sum_N + area_frac*sum(litt%ag_cwd_frag)*(tot_wood_n/tot_wood_c) + sum_N = sum_N + area_frac*sum(litt%bg_cwd_frag)*(tot_wood_n/tot_wood_c) + end if + if(tot_leaf_c>nearzero)then + sum_N = sum_N + area_frac*sum(litt%leaf_fines_frag)*(tot_leaf_n / tot_leaf_c) + end if + if(tot_fnrt_c>nearzero)then + sum_N = sum_N + area_frac*sum(litt%root_fines_frag)*(tot_fnrt_n / tot_fnrt_c) + end if + do ipft = 1,numpft + sum_N = sum_N + area_frac * prt_params%nitr_recr_stoich(ipft) * & + (litt%seed_decay(ipft) + litt%seed_germ_decay(ipft)) + end do currentPatch => currentPatch%younger end do - - sum_ligC = sum(bc_out%litt_flux_lig_c_si(1:nlev_eff_soil) * bc_in%dz_sisl(1:nlev_eff_soil)) - sum_C = sum( (bc_out%litt_flux_cel_c_si(1:nlev_eff_soil)+ & - bc_out%litt_flux_lab_c_si(1:nlev_eff_soil)+ & - bc_out%litt_flux_lig_c_si(1:nlev_eff_soil)) * bc_in%dz_sisl(1:nlev_eff_soil)) - !bc_out%litt_flux_ligc_per_n = ligC/TotalN = ligC/totalC * (totalC/totalN) - - if((sum_C>nearzero) .and. (total_n>nearzero))then - bc_out%litt_flux_ligc_per_n = sum_ligC/sum_C * total_c/total_n - else - bc_out%litt_flux_ligc_per_n = 0._r8 - end if + ! Convert from kg/m2/day -> g/m2/s + sum_N = sum_N * days_per_sec * g_per_kg end if - + + ! Sum over layers and multiply by depth g/m3/s * m -> g/m2/s + sum_ligC = sum(bc_out%litt_flux_lig_c_si(1:nlev_eff_soil) * bc_in%dz_sisl(1:nlev_eff_soil)) + + if(sum_N>nearzero)then + bc_out%litt_flux_ligc_per_n = sum_ligC / sum_N + else + bc_out%litt_flux_ligc_per_n = 0._r8 + end if + end if From bc1c39f61e498049e9808a82dfc0de2bc15766d5 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 6 Apr 2022 17:55:52 -0400 Subject: [PATCH 551/578] Removed unnecessary zeroing of ligCN bcout --- biogeochem/FatesSoilBGCFluxMod.F90 | 11 ----------- 1 file changed, 11 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index bb6c8efe28..0815e4ecc0 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -1002,21 +1002,10 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) do id = 1,nlev_eff_decomp surface_prof(id) = surface_prof(id)/surface_prof_tot end do - - - - ! Loop over the different elements. do el = 1, num_elements - ! Zero out the boundary flux arrays - ! Make a pointer to the cellulose, labile and lignan - ! flux partitions. - if(hlm_use_mimics) then - bc_out%litt_flux_ligc_per_n(:) = 0._r8 - end if - select case (element_list(el)) case (carbon12_element) bc_out%litt_flux_cel_c_si(:) = 0.0_r8 From fe891c7992079614ef1b4791fe43860c0a08eeb2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 6 Apr 2022 17:56:41 -0400 Subject: [PATCH 552/578] Fixed comments --- biogeochem/FatesSoilBGCFluxMod.F90 | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 0815e4ecc0..75dc65f3c2 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -1006,6 +1006,10 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) ! Loop over the different elements. do el = 1, num_elements + ! Zero out the boundary flux arrays + ! Make a pointer to the cellulose, labile and lignan + ! flux partitions. + select case (element_list(el)) case (carbon12_element) bc_out%litt_flux_cel_c_si(:) = 0.0_r8 From c87dc5cea74652716028a7d1c8d702535a96eed8 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 6 Apr 2022 19:06:48 -0400 Subject: [PATCH 553/578] debugging mimics coupling, adding print statements --- biogeochem/FatesSoilBGCFluxMod.F90 | 26 +++++++++++++++++++------- main/FatesInterfaceMod.F90 | 8 +++----- 2 files changed, 22 insertions(+), 12 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 75dc65f3c2..74160bb8cf 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -55,7 +55,7 @@ module FatesSoilBGCFluxMod use FatesInterfaceTypesMod, only : hlm_nu_com use FatesInterfaceTypesMod, only : hlm_parteh_mode use FatesInterfaceTypesMod, only : hlm_use_ch4 - use FatesInterfaceTypesMod, only : hlm_use_mimics + use FatesInterfaceTypesMod, only : hlm_decomp use FatesConstantsMod , only : prescribed_p_uptake use FatesConstantsMod , only : prescribed_n_uptake use FatesConstantsMod , only : coupled_p_uptake @@ -931,7 +931,7 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) ! !LOCAL VARIABLES: type (ed_patch_type), pointer :: currentPatch - type (ed_cohort_type), pointer :: currentCohort + type (ed_cohort_type), pointer :: ccohort real(r8), pointer :: flux_cel_si(:) real(r8), pointer :: flux_lab_si(:) real(r8), pointer :: flux_lig_si(:) @@ -1185,12 +1185,13 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) tot_wood_c = 0._r8 tot_wood_n = 0._r8 - ccohort => cpatch%tallest + ccohort => currentPatch%tallest do while (associated(ccohort)) - leaf_c = ccohort%n * area_inv * ccohort%n*ccohort%prt%GetState(leaf_organ, carbon12_element) - sapw_c = ccohort%n * area_inv * ccohort%n*ccohort%prt%GetState(sapw_organ, carbon12_element) - fnrt_c = ccohort%n * area_inv * ccohort%n*ccohort%prt%GetState(fnrt_organ, carbon12_element) - struct_c = ccohort%n * area_inv * ccohort%n*ccohort%prt%GetState(struct_organ, carbon12_element) + ipft = ccohort%pft + leaf_c = ccohort%n * area_inv * ccohort%prt%GetState(leaf_organ, carbon12_element) + sapw_c = ccohort%n * area_inv * ccohort%prt%GetState(sapw_organ, carbon12_element) + fnrt_c = ccohort%n * area_inv * ccohort%prt%GetState(fnrt_organ, carbon12_element) + struct_c = ccohort%n * area_inv * ccohort%prt%GetState(struct_organ, carbon12_element) leaf_n = leaf_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(leaf_organ)) sapw_n = sapw_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(sapw_organ)) fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(fnrt_organ)) @@ -1204,6 +1205,13 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) ccohort => ccohort%shorter end do + !print*,prt_params%nitr_stoich_p1(ipft,:), & + ! prt_params%organ_param_id(leaf_organ), & + ! prt_params%organ_param_id(sapw_organ), & + ! prt_params%organ_param_id(fnrt_organ), & + ! prt_params%organ_param_id(struct_organ) + !stop + if(tot_wood_c>nearzero) then sum_N = sum_N + area_frac*sum(litt%ag_cwd_frag)*(tot_wood_n/tot_wood_c) sum_N = sum_N + area_frac*sum(litt%bg_cwd_frag)*(tot_wood_n/tot_wood_c) @@ -1218,6 +1226,8 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) sum_N = sum_N + area_frac * prt_params%nitr_recr_stoich(ipft) * & (litt%seed_decay(ipft) + litt%seed_germ_decay(ipft)) end do + +! print*,(tot_leaf_n / tot_leaf_c),(tot_fnrt_n / tot_fnrt_c),(tot_wood_n/tot_wood_c),prt_params%nitr_recr_stoich(1) currentPatch => currentPatch%younger end do @@ -1235,6 +1245,8 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) else bc_out%litt_flux_ligc_per_n = 0._r8 end if + + print*,"--",bc_out%litt_flux_ligc_per_n,sum_ligC,sum_N end if diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index c7bc24acca..6e84921f4f 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -36,7 +36,7 @@ module FatesInterfaceMod use FatesGlobals , only : fates_global_verbose use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun - use FatesGlobals , only : fates_unset_r8 + use FatesConstantsMod , only : fates_unset_r8 use FatesLitterMod , only : ncwd use FatesLitterMod , only : ndcmpy use EDPftvarcon , only : FatesReportPFTParams @@ -1284,7 +1284,6 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_phosphorus_spec = unset_int hlm_max_patch_per_site = unset_int hlm_use_ch4 = unset_int - hlm_use_mimics = unset_int hlm_use_vertsoilc = unset_int hlm_parteh_mode = unset_int hlm_spitfire_mode = unset_int @@ -1484,9 +1483,8 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - print*,trim(hlm_decomp) - stop - + ! TEMPORARY TESTING OVERRIDE !!!!!!!! + hlm_decomp = 'MIMICS' if(trim(hlm_nu_com) .eq. 'unset') then if (fates_global_verbose()) then From ece2cb2da05b1e8a33bd4314e8f68baf15bf1f77 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 6 Apr 2022 19:08:41 -0400 Subject: [PATCH 554/578] Removed mimics forced override and comments --- biogeochem/FatesSoilBGCFluxMod.F90 | 11 ----------- main/FatesInterfaceMod.F90 | 2 +- 2 files changed, 1 insertion(+), 12 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 74160bb8cf..9f5d37187b 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -1205,13 +1205,6 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) ccohort => ccohort%shorter end do - !print*,prt_params%nitr_stoich_p1(ipft,:), & - ! prt_params%organ_param_id(leaf_organ), & - ! prt_params%organ_param_id(sapw_organ), & - ! prt_params%organ_param_id(fnrt_organ), & - ! prt_params%organ_param_id(struct_organ) - !stop - if(tot_wood_c>nearzero) then sum_N = sum_N + area_frac*sum(litt%ag_cwd_frag)*(tot_wood_n/tot_wood_c) sum_N = sum_N + area_frac*sum(litt%bg_cwd_frag)*(tot_wood_n/tot_wood_c) @@ -1227,8 +1220,6 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) (litt%seed_decay(ipft) + litt%seed_germ_decay(ipft)) end do -! print*,(tot_leaf_n / tot_leaf_c),(tot_fnrt_n / tot_fnrt_c),(tot_wood_n/tot_wood_c),prt_params%nitr_recr_stoich(1) - currentPatch => currentPatch%younger end do @@ -1246,8 +1237,6 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) bc_out%litt_flux_ligc_per_n = 0._r8 end if - print*,"--",bc_out%litt_flux_ligc_per_n,sum_ligC,sum_N - end if diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 6e84921f4f..093d822969 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1484,7 +1484,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) end if ! TEMPORARY TESTING OVERRIDE !!!!!!!! - hlm_decomp = 'MIMICS' + ! hlm_decomp = 'MIMICS' if(trim(hlm_nu_com) .eq. 'unset') then if (fates_global_verbose()) then From cc833b51fc0f4f1d2aaaf2420d555c06d644a825 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 7 Apr 2022 10:37:44 -0400 Subject: [PATCH 555/578] Removed unused whitespace changes --- main/EDPftvarcon.F90 | 2 -- 1 file changed, 2 deletions(-) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index faa0144d7d..a149132a8d 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -1605,9 +1605,7 @@ subroutine FatesCheckParams(is_master) p_uptake_mode = coupled_p_uptake end if - - do ipft = 1,npft From cadce7cd9d1446b5e86c551037ed38013daf928e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 18 Apr 2022 13:39:40 -0400 Subject: [PATCH 556/578] fixing the spelling of lignin. No A! --- biogeochem/FatesSoilBGCFluxMod.F90 | 4 ++-- main/EDPftvarcon.F90 | 2 +- main/FatesInterfaceTypesMod.F90 | 6 +++--- main/FatesInventoryInitMod.F90 | 4 ++-- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 9f5d37187b..2d06229463 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -960,7 +960,7 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) real(r8) :: fnrt_c, struct_c ! fineroot and struct carbon, per plant [kg] real(r8) :: leaf_n, sapw_n ! leaf and sapwood N, per plant [kg] real(r8) :: fnrt_n, struct_n ! fineroot and struct N, per plant [kg] - real(r8) :: sum_ligC ! Flux of lignan C [kg/m2/s] + real(r8) :: sum_ligC ! Flux of lignin C [kg/m2/s] real(r8) :: sum_N ! Flux of all N [kg/m2/s] real(r8) :: tot_leaf_c ! total leaf C of all cohorts in patch [kg/m2] real(r8) :: tot_leaf_n ! total leaf N of all cohorts in patch [kg/m2] @@ -1007,7 +1007,7 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) do el = 1, num_elements ! Zero out the boundary flux arrays - ! Make a pointer to the cellulose, labile and lignan + ! Make a pointer to the cellulose, labile and lignin ! flux partitions. select case (element_list(el)) diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index a149132a8d..027abb152c 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -59,7 +59,7 @@ module EDPftvarcon real(r8), allocatable :: lf_flab(:) ! Leaf litter labile fraction [-] real(r8), allocatable :: lf_fcel(:) ! Leaf litter cellulose fraction [-] - real(r8), allocatable :: lf_flig(:) ! Leaf litter lignan fraction [-] + real(r8), allocatable :: lf_flig(:) ! Leaf litter lignin fraction [-] real(r8), allocatable :: fr_flab(:) ! Fine-root litter labile fraction [-] real(r8), allocatable :: fr_fcel(:) ! Fine-root litter cellulose fraction [-] real(r8), allocatable :: fr_flig(:) ! Fine-root litter lignatn fraction [-] diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 3e3e0191a3..e8ddf63e48 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -597,13 +597,13 @@ module FatesInterfaceTypesMod ! 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_lig_c_si(:) ! lignin 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_lig_n_si(:) ! lignin 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_lig_p_si(:) ! lignin phosphorus litter, fates->BGC g/m3/s real(r8), allocatable :: litt_flux_lab_p_si(:) ! labile phosphorus litter, fates->BGC g/m3/s diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 507f01dbee..0d9891ee4f 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -734,7 +734,7 @@ subroutine set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name ! water (NA) Water content of soil (NOT USED) ! fsc (kg/m2) Fast Soil Carbon ! stsc (kg/m2) Structural Soil Carbon - ! stsl (kg/m2) Structural Soil Lignan + ! stsl (kg/m2) Structural Soil Lignin ! ssc (kg/m2) Slow Soil Carbon ! psc (NA) Passive Soil Carbon (NOT USED) ! msn (kg/m2) Mineralized Soil Nitrogen @@ -763,7 +763,7 @@ subroutine set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name real(r8) :: p_water ! Patch water (unused) real(r8) :: p_fsc ! Patch fast soil carbon real(r8) :: p_stsc ! Patch structural soil carbon - real(r8) :: p_stsl ! Patch structural soil lignans + real(r8) :: p_stsl ! Patch structural soil lignins real(r8) :: p_ssc ! Patch slow soil carbon real(r8) :: p_psc ! Patch P soil carbon real(r8) :: p_msn ! Patch mean soil nitrogen From 84a67fae3778b0e0332f94f0a46b7eb1bdde6e69 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 18 Apr 2022 15:00:44 -0400 Subject: [PATCH 557/578] small bug fix from merge --- biogeophys/FatesPlantHydraulicsMod.F90 | 1 - main/FatesGlobals.F90 | 3 +-- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index ecfd9d5b97..3998d963da 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -2883,7 +2883,6 @@ subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) wb_check_site = delta_plant_storage+delta_soil_storage+site_runoff+transp_flux ! Now check on total error - end if if(debug)then if( abs(wb_check_site) > 1.e-4_r8 ) then diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 index 48f8ffcdcb..8d46d5a0d9 100644 --- a/main/FatesGlobals.F90 +++ b/main/FatesGlobals.F90 @@ -139,8 +139,7 @@ end function N2S function A2S(reals_in) result(str) real(r8) :: reals_in(:) - character(len=512) :: str - character(len=16) :: str_frag + character(len=1024) :: str integer :: i, nreal str = ', ' From 0f65e9151e6052e5783bb963e96e32c7c3cbd5a3 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 18 Apr 2022 16:39:21 -0400 Subject: [PATCH 558/578] Removing endruns in the NL passing --- main/FatesInterfaceMod.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 3387c18140..4c2b3cae4b 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1724,7 +1724,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) case default write(fates_log(), *) 'fates NL tag not recognized:',trim(tag) - call endrun(msg=errMsg(sourcefile, __LINE__)) + !! call endrun(msg=errMsg(sourcefile, __LINE__)) end select end if @@ -1738,7 +1738,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) end if case default write(fates_log(),*) 'fates NL tag not recognized:',trim(tag) - call endrun(msg=errMsg(sourcefile, __LINE__)) + !! call endrun(msg=errMsg(sourcefile, __LINE__)) end select end if @@ -1765,7 +1765,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) case default write(fates_log(),*) 'fates NL tag not recognized:',trim(tag) - call endrun(msg=errMsg(sourcefile, __LINE__)) + !! call endrun(msg=errMsg(sourcefile, __LINE__)) end select end if From 9e90ddee7a88a74e2b5db22c8ef756c8cce1f7c1 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 20 Apr 2022 18:37:28 -0400 Subject: [PATCH 559/578] Various updates to FatesWarn --- biogeochem/EDPatchDynamicsMod.F90 | 3 +- biogeochem/FatesAllometryMod.F90 | 16 ++++++-- biogeophys/FatesPlantRespPhotosynthMod.F90 | 10 +++-- main/EDMainMod.F90 | 2 +- main/FatesGlobals.F90 | 45 ++++++++++++++++++++-- 5 files changed, 62 insertions(+), 14 deletions(-) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index c6eceb620c..13552c899a 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -338,8 +338,7 @@ subroutine disturbance_rates( site_in, bc_in) end do ! Fires can't burn the whole patch, as this causes /0 errors. - !if (currentPatch%disturbance_rates(dtype_ifire) > 0.98_r8)then - if(.true.)then + if (currentPatch%disturbance_rates(dtype_ifire) > 0.98_r8)then msg = 'very high fire areas'//trim(A2S(currentPatch%disturbance_rates(:)))//trim(N2S(currentPatch%frac_burnt)) call FatesWarn(msg,index=2) endif diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index ba72c539e0..df05b7de29 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -95,6 +95,7 @@ module FatesAllometryMod use shr_log_mod , only : errMsg => shr_log_errMsg use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun + use FatesGlobals , only : FatesWarn,N2S,A2S,I2S use EDTypesMod , only : nlevleaf, dinc_vai use EDTypesMod , only : nclmax @@ -130,6 +131,8 @@ module FatesAllometryMod logical, parameter :: debug = .false. + + character(len=1024) :: warn_msg ! for defining a warning message ! If testing b4b with older versions, do not remove sapwood ! Our old methods with saldarriaga did not remove sapwood from the @@ -2455,11 +2458,16 @@ subroutine ForceDBH( ipft, canopy_trim, d, h, bdead, bl ) call h_allom(d,ipft,h) - if(debug) then - if(counter>10)then - write(fates_log(),*) 'dbh counter: ',counter,' is woody: ',& - int(prt_params%woody(ipft))==itrue + if(counter>20)then + write(fates_log(),*) 'dbh counter: ',counter,' is woody: ',& + int(prt_params%woody(ipft))==itrue + + if(int(prt_params%woody(ipft))==itrue)then + warn_msg = 'dbh counter: '//trim(I2S(counter))//' is woody' + else + warn_msg = 'dbh counter: '//trim(I2S(counter))//' is not woody' end if + call FatesWarn(warn_msg,index=3) end if diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 1ab9eabdaa..bd6855bbda 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -22,6 +22,7 @@ module FATESPlantRespPhotosynthMod use FatesGlobals, only : endrun => fates_endrun use FatesGlobals, only : fates_log + use FatesGlobals, only : FatesWarn,N2S,A2S use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : itrue use FatesConstantsMod, only : nearzero @@ -63,6 +64,10 @@ module FATESPlantRespPhotosynthMod character(len=*), parameter, private :: sourcefile = & __FILE__ + + + character(len=1024) :: warn_msg ! for defining a warning message + !------------------------------------------------------------------------------------- ! maximum stomatal resistance [s/m] (used across several procedures) @@ -1262,9 +1267,8 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in end if if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then - write (fates_log(),*) 'Stomatal model error check - stomatal conductance error:' - write (fates_log(),*) gs_mol, gs_mol_err - call endrun(msg=errMsg(sourcefile, __LINE__)) + warn_msg = 'Stomatal conductance error check - weak convergence: '//trim(N2S(gs_mol))//' '//trim(N2S(gs_mol_err)) + call FatesWarn(warn_msg,index=4) end if enddo !sunsha loop diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 0a67a313ed..d05966ef14 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -149,7 +149,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) !----------------------------------------------------------------------- - if ( hlm_masterproc==itrue ) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& + if (debug .and.( hlm_masterproc==itrue)) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& hlm_current_year,'-',hlm_current_month,'-',hlm_current_day ! Consider moving this towards the end, because some of these diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 index 8d46d5a0d9..19713ec3f1 100644 --- a/main/FatesGlobals.F90 +++ b/main/FatesGlobals.F90 @@ -20,7 +20,9 @@ module FatesGlobals public :: FatesWarn public :: A2S public :: N2S - + public :: I2S + public :: FatesReportTotalWarnings + ! ------------------------------------------------------------------------------------- ! Warning handling ! The objective here is to stop writing the same warning over and over again. After @@ -42,6 +44,8 @@ module FatesGlobals ! printing any of these warnings to the log ! It should also bypass the logicals bound inside ! at the compiler level (?) and be faster + + contains @@ -113,15 +117,36 @@ subroutine FatesWarn(msg,index) warn_counts(ind) = warn_counts(ind) + 1 if(warn_active(ind))then - write(fates_log(),*) 'FWARN: ',ind,'m: ',msg + write(fates_log(),*) 'FWARN: '//trim(ADJUSTL(I2S(ind)))//' m: '//trim(msg) if(warn_counts(ind)> max_warnings) then warn_active(ind) = .false. - write(fates_log(),*) 'FWARN: ',ind,'has saturated messaging, no longer reporting' + write(fates_log(),*) 'FWARN: '//trim(ADJUSTL(I2S(ind)))//' has saturated messaging, no longer reporting' end if end if return end subroutine FatesWarn + ! ===================================================================================== + + + subroutine FatesReportTotalWarnings() + + integer :: ind + + do ind = 1,max_ids + + if(warn_counts(ind)>0)then + + write(fates_log(),*) 'FWARN: '//trim(ADJUSTL(I2S(ind)))//' was triggered ',trim(ADJUSTL(I2S(warn_counts(ind))))//' times' + + end if + + end do + + + end subroutine FatesReportTotalWarnings + + ! ===================================================================================== function N2S(real_in) result(str) @@ -130,9 +155,21 @@ function N2S(real_in) result(str) character(len=16) :: str !write(str,*) real_in - write(str,'(a,E12.6)') ', ',real_in + write(str,'(E12.6)') real_in end function N2S + + ! ===================================================================================== + + function I2S(int_in) result(str) + + integer :: int_in + character(len=16) :: str + + !write(str,*) real_in + write(str,'(I15)') int_in + + end function I2S ! ===================================================================================== From 9457e94a83286a515c6f0fc12b5d0f0233a4f6a3 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 22 Apr 2022 11:48:02 -0400 Subject: [PATCH 560/578] Update main/FatesGlobals.F90 Co-authored-by: Gregory Lemieux <7565064+glemieux@users.noreply.github.com> --- main/FatesGlobals.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 index 19713ec3f1..f75aa32fd8 100644 --- a/main/FatesGlobals.F90 +++ b/main/FatesGlobals.F90 @@ -117,10 +117,10 @@ subroutine FatesWarn(msg,index) warn_counts(ind) = warn_counts(ind) + 1 if(warn_active(ind))then - write(fates_log(),*) 'FWARN: '//trim(ADJUSTL(I2S(ind)))//' m: '//trim(msg) + write(fates_log(),*) 'FATESWARN: '//trim(ADJUSTL(I2S(ind)))//' m: '//trim(msg) if(warn_counts(ind)> max_warnings) then warn_active(ind) = .false. - write(fates_log(),*) 'FWARN: '//trim(ADJUSTL(I2S(ind)))//' has saturated messaging, no longer reporting' + write(fates_log(),*) 'FATESWARN: '//trim(ADJUSTL(I2S(ind)))//' has saturated messaging, no longer reporting' end if end if return @@ -137,7 +137,7 @@ subroutine FatesReportTotalWarnings() if(warn_counts(ind)>0)then - write(fates_log(),*) 'FWARN: '//trim(ADJUSTL(I2S(ind)))//' was triggered ',trim(ADJUSTL(I2S(warn_counts(ind))))//' times' + write(fates_log(),*) 'FATESWARN: '//trim(ADJUSTL(I2S(ind)))//' was triggered ',trim(ADJUSTL(I2S(warn_counts(ind))))//' times' end if From d974364675b4e285a1bcb15ad8878fc4c24253fd Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 26 Apr 2022 12:35:29 -0600 Subject: [PATCH 561/578] Fixed some logging indices --- biogeophys/FatesPlantRespPhotosynthMod.F90 | 2 +- main/FatesGlobals.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index bd6855bbda..3b34342149 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -1268,7 +1268,7 @@ subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then warn_msg = 'Stomatal conductance error check - weak convergence: '//trim(N2S(gs_mol))//' '//trim(N2S(gs_mol_err)) - call FatesWarn(warn_msg,index=4) + call FatesWarn(warn_msg,index=1) end if enddo !sunsha loop diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 index f75aa32fd8..ebc0f326ff 100644 --- a/main/FatesGlobals.F90 +++ b/main/FatesGlobals.F90 @@ -133,7 +133,7 @@ subroutine FatesReportTotalWarnings() integer :: ind - do ind = 1,max_ids + do ind = 0,max_ids if(warn_counts(ind)>0)then From b9c88317d50090584ac1a1e093a03214668a7e2e Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 26 Apr 2022 14:30:50 -0600 Subject: [PATCH 562/578] Removed extra def of msgErr --- biogeophys/EDAccumulateFluxesMod.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index 090b7848b0..8eae0f4a50 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -13,7 +13,7 @@ module EDAccumulateFluxesMod use FatesGlobals, only : fates_log use shr_log_mod , only : errMsg => shr_log_errMsg use FatesConstantsMod , only : r8 => fates_r8 - use shr_log_mod , only : errMsg => shr_log_errMsg + implicit none private From e1b3bf89a03ddfaf7e8ba57a3f194cfe255f2e62 Mon Sep 17 00:00:00 2001 From: Marcos Longo Date: Tue, 3 May 2022 13:44:44 -0700 Subject: [PATCH 563/578] Make parameter woody integer. Parameter prt_params%woody is used to decide whether a PFT is woody or not. Instead of converting it to integer whenever a logical test is to be performed, I turned the parameter integer. --- biogeochem/EDCanopyStructureMod.F90 | 4 ++-- biogeochem/EDCohortDynamicsMod.F90 | 2 +- biogeochem/EDLoggingMortalityMod.F90 | 4 ++-- biogeochem/EDPatchDynamicsMod.F90 | 8 ++++---- biogeochem/FatesAllometryMod.F90 | 4 ++-- fire/SFMainMod.F90 | 14 +++++++------- main/FatesHistoryInterfaceMod.F90 | 2 +- parteh/PRTParametersMod.F90 | 2 +- parteh/PRTParamsFATESMod.F90 | 16 ++++++++++------ 9 files changed, 30 insertions(+), 26 deletions(-) diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index c12ec2edda..5bd85cb5a1 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1235,7 +1235,7 @@ subroutine canopy_spread( currentSite ) do while (associated(currentCohort)) call carea_allom(currentCohort%dbh,currentCohort%n, & currentSite%spread,currentCohort%pft,currentCohort%c_area) - if( ( int(prt_params%woody(currentCohort%pft)) .eq. itrue ) .and. & + if( ( prt_params%woody(currentCohort%pft) .eq. itrue ) .and. & (currentCohort%canopy_layer .eq. 1 ) ) then sitelevel_canopyarea = sitelevel_canopyarea + currentCohort%c_area endif @@ -1346,7 +1346,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) if(currentCohort%canopy_layer==1)then currentPatch%total_canopy_area = currentPatch%total_canopy_area + currentCohort%c_area - if( int(prt_params%woody(ft))==itrue)then + if( prt_params%woody(ft) == itrue)then currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area endif endif diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 4318ee469f..8c6f589c04 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -2107,7 +2107,7 @@ subroutine EvaluateAndCorrectDBH(currentCohort,delta_dbh,delta_hite) delta_dbh = 0._r8 delta_hite = 0._r8 - if( int(prt_params%woody(currentCohort%pft)) == itrue) then + if( prt_params%woody(currentCohort%pft) == itrue) then struct_c = currentCohort%prt%GetState(struct_organ, all_carbon_elements) diff --git a/biogeochem/EDLoggingMortalityMod.F90 b/biogeochem/EDLoggingMortalityMod.F90 index f1f23d9f33..74f21d8bc2 100644 --- a/biogeochem/EDLoggingMortalityMod.F90 +++ b/biogeochem/EDLoggingMortalityMod.F90 @@ -258,7 +258,7 @@ subroutine LoggingMortality_frac( pft_i, dbh, canopy_layer, lmort_direct, & ! transfer of area to secondary land is based on overall area affected, not just logged crown area ! l_degrad accounts for the affected area between logged crowns - if(int(prt_params%woody(pft_i)) == 1)then ! only set logging rates for trees + if(prt_params%woody(pft_i) == itrue)then ! only set logging rates for trees ! direct logging rates, based on dbh min and max criteria if (dbh >= logging_dbhmin .and. .not. & @@ -542,7 +542,7 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site ! plants that were impacted. Thus, no direct dead can occur ! here, and indirect are impacts. - if(int(prt_params%woody(pft)) == itrue) then + if(prt_params%woody(pft) == itrue) then direct_dead = 0.0_r8 indirect_dead = logging_coll_under_frac * & (1._r8-currentPatch%fract_ldist_not_harvested) * currentCohort%n * & diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 537e74824d..487318fa9d 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -777,7 +777,7 @@ subroutine spawn_patches( currentSite, bc_in) else ! small trees - if( int(prt_params%woody(currentCohort%pft)) == itrue)then + if( prt_params%woody(currentCohort%pft) == itrue)then ! Survivorship of undestory woody plants. Two step process. @@ -917,7 +917,7 @@ subroutine spawn_patches( currentSite, bc_in) ! burned off. Here, we remove that mass, and ! tally it in the flux we sent to the atmosphere - if(int(prt_params%woody(currentCohort%pft)) == itrue)then + if(prt_params%woody(currentCohort%pft) == itrue)then leaf_burn_frac = currentCohort%fraction_crown_burned else @@ -995,7 +995,7 @@ subroutine spawn_patches( currentSite, bc_in) ! WHat to do with cohorts in the understory of a logging generated ! disturbance patch? - if(int(prt_params%woody(currentCohort%pft)) == itrue)then + if(prt_params%woody(currentCohort%pft) == itrue)then ! Survivorship of undestory woody plants. Two step process. @@ -1905,7 +1905,7 @@ subroutine mortality_litter_fluxes(currentSite, currentPatch, & num_dead = currentCohort%n * min(1.0_r8,currentCohort%dmort * & hlm_freq_day * fates_mortality_disturbance_fraction) - elseif(int(prt_params%woody(pft)) == itrue) then + elseif(prt_params%woody(pft) == itrue) then ! Understorey trees. The total dead is based on their survivorship ! function, and the total area of disturbance. diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index 42264ca776..ef3c58495b 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -2370,7 +2370,7 @@ subroutine ForceDBH( ipft, canopy_trim, d, h, bdead, bl ) integer, parameter :: max_counter = 200 ! Do reduce "if" calls, we break this call into two parts - if ( int(prt_params%woody(ipft)) == itrue ) then + if ( prt_params%woody(ipft) == itrue ) then if(.not.present(bdead)) then write(fates_log(),*) 'woody plants must use structure for dbh reset' @@ -2456,7 +2456,7 @@ subroutine ForceDBH( ipft, canopy_trim, d, h, bdead, bl ) call h_allom(d,ipft,h) if(counter>10)then write(fates_log(),*) 'dbh counter: ',counter,' is woody: ',& - int(prt_params%woody(ipft))==itrue + (prt_params%woody(ipft) == itrue) end if diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index aedcb4aa7c..ee8e4c2400 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -192,7 +192,7 @@ subroutine charecteristics_of_fuel ( currentSite ) currentPatch%livegrass = 0.0_r8 currentCohort => currentPatch%tallest do while(associated(currentCohort)) - if( int(prt_params%woody(currentCohort%pft)) == ifalse)then + if( prt_params%woody(currentCohort%pft) == ifalse)then currentPatch%livegrass = currentPatch%livegrass + & currentCohort%prt%GetState(leaf_organ, all_carbon_elements) * & @@ -374,7 +374,7 @@ subroutine wind_effect ( currentSite, bc_in) do while(associated(currentCohort)) if (debug) write(fates_log(),*) 'SF currentCohort%c_area ',currentCohort%c_area - if( int(prt_params%woody(currentCohort%pft)) == itrue)then + if( prt_params%woody(currentCohort%pft) == itrue)then currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area else total_grass_area = total_grass_area + currentCohort%c_area @@ -864,7 +864,7 @@ subroutine crown_scorching ( currentSite ) if (currentPatch%fire == 1) then currentCohort => currentPatch%tallest; do while(associated(currentCohort)) - if ( int(prt_params%woody(currentCohort%pft)) == itrue) then !trees only + if ( prt_params%woody(currentCohort%pft) == itrue) then !trees only leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) sapw_c = currentCohort%prt%GetState(sapw_organ, all_carbon_elements) @@ -878,7 +878,7 @@ subroutine crown_scorching ( currentSite ) enddo !end cohort loop do i_pft=1,numpft - if (tree_ag_biomass > 0.0_r8 .and. int(prt_params%woody(i_pft)) == itrue) then + if (tree_ag_biomass > 0.0_r8 .and. prt_params%woody(i_pft) == itrue) then !Equation 16 in Thonicke et al. 2010 !Van Wagner 1973 EQ8 !2/3 Byram (1959) currentPatch%Scorch_ht(i_pft) = EDPftvarcon_inst%fire_alpha_SH(i_pft) * (currentPatch%FI**0.667_r8) @@ -920,7 +920,7 @@ subroutine crown_damage ( currentSite ) do while(associated(currentCohort)) currentCohort%fraction_crown_burned = 0.0_r8 - if ( int(prt_params%woody(currentCohort%pft)) == itrue) then !trees only + if ( prt_params%woody(currentCohort%pft) == itrue) then !trees only ! Flames lower than bottom of canopy. ! c%hite is height of cohort @@ -984,7 +984,7 @@ subroutine cambial_damage_kill ( currentSite ) if (currentPatch%fire == 1) then currentCohort => currentPatch%tallest; do while(associated(currentCohort)) - if ( int(prt_params%woody(currentCohort%pft)) == itrue) then !trees only + if ( prt_params%woody(currentCohort%pft) == itrue) then !trees only ! Equation 21 in Thonicke et al 2010 bt = EDPftvarcon_inst%bark_scaler(currentCohort%pft)*currentCohort%dbh ! bark thickness. ! Equation 20 in Thonicke et al. 2010. @@ -1036,7 +1036,7 @@ subroutine post_fire_mortality ( currentSite ) do while(associated(currentCohort)) currentCohort%fire_mort = 0.0_r8 currentCohort%crownfire_mort = 0.0_r8 - if ( int(prt_params%woody(currentCohort%pft)) == itrue) then + if ( prt_params%woody(currentCohort%pft) == itrue) then ! Equation 22 in Thonicke et al. 2010. currentCohort%crownfire_mort = EDPftvarcon_inst%crown_kill(currentCohort%pft)*currentCohort%fraction_crown_burned**3.0_r8 ! Equation 18 in Thonicke et al. 2010. diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index f43289da15..af02d730a3 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -2506,7 +2506,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) store_m_net_alloc*n_perm2 / days_per_year / sec_per_day ! Woody State Variables (basal area growth increment) - if ( int(prt_params%woody(ft)) == itrue) then + if ( prt_params%woody(ft) == itrue) then ! basal area [m2/m2] hio_ba_si_scpf(io_si,scpf) = hio_ba_si_scpf(io_si,scpf) + & diff --git a/parteh/PRTParametersMod.F90 b/parteh/PRTParametersMod.F90 index 04a0f5dda0..a0b6cbb44e 100644 --- a/parteh/PRTParametersMod.F90 +++ b/parteh/PRTParametersMod.F90 @@ -100,7 +100,7 @@ module PRTParametersMod real(r8), allocatable :: c2b(:) ! Carbon to biomass multiplier [kg/kgC] real(r8), allocatable :: wood_density(:) ! wood density g cm^-3 ... - real(r8), allocatable :: woody(:) ! Does the plant have wood? (1=yes, 0=no) + integer , allocatable :: woody(:) ! Does the plant have wood? (1=yes, 0=no) real(r8), allocatable :: crown(:) ! fraction of the height of the plant ! that is occupied by crown real(r8), allocatable :: slamax(:) ! Maximum specific leaf area of plant (at bottom) [m2/gC] diff --git a/parteh/PRTParamsFATESMod.F90 b/parteh/PRTParamsFATESMod.F90 index 208ff848fb..16c05cb2b0 100644 --- a/parteh/PRTParamsFATESMod.F90 +++ b/parteh/PRTParamsFATESMod.F90 @@ -441,8 +441,12 @@ subroutine PRTReceivePFT(fates_params) name = 'fates_woody' call fates_params%RetreiveParameterAllocate(name=name, & - data=prt_params%woody) - + data=tmpreal) + allocate(prt_params%woody(size(tmpreal,dim=1))) + call ArrayNint(tmpreal,prt_params%woody) + deallocate(tmpreal) + + name = 'fates_wood_density' call fates_params%RetreiveParameterAllocate(name=name, & data=prt_params%wood_density) @@ -1076,13 +1080,13 @@ subroutine PRTCheckParams(is_master) ! Check if woody plants have a structural biomass (agb) intercept ! ---------------------------------------------------------------------------------- if ( ( prt_params%allom_agb1(ipft) <= tiny(prt_params%allom_agb1(ipft)) ) .and. & - ( int(prt_params%woody(ipft)) .eq. 1 ) ) then + ( prt_params%woody(ipft) .eq. 1 ) ) then write(fates_log(),*) 'Woody plants are expected to have a non-zero intercept' write(fates_log(),*) ' in the diameter to AGB allometry equations' write(fates_log(),*) ' PFT#: ',ipft write(fates_log(),*) ' allom_agb1: ',prt_params%allom_agb1(ipft) - write(fates_log(),*) ' woody: ',int(prt_params%woody(ipft)) + write(fates_log(),*) ' woody: ',prt_params%woody(ipft) write(fates_log(),*) ' Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1091,7 +1095,7 @@ subroutine PRTCheckParams(is_master) ! Check if non-woody plants have structural biomass (agb) intercept ! ---------------------------------------------------------------------------------- ! if ( ( prt_params%allom_agb1(ipft) > tiny(prt_params%allom_agb1(ipft)) ) .and. & -! ( int(prt_params%woody(ipft)) .ne. 1 ) ) then +! ( iprt_params%woody(ipft) .ne. 1 ) ) then ! ! write(fates_log(),*) 'Non-woody plants are expected to have a zero intercept' ! write(fates_log(),*) ' in the diameter to AGB allometry equations' @@ -1100,7 +1104,7 @@ subroutine PRTCheckParams(is_master) ! write(fates_log(),*) ' woody tissues (sap and structural dead wood).' ! write(fates_log(),*) ' PFT#: ',ipft ! write(fates_log(),*) ' allom_agb1: ',prt_params%allom_agb1(ipft) -! write(fates_log(),*) ' woody: ',int(prt_params%woody(ipft)) +! write(fates_log(),*) ' woody: ',prt_params%woody(ipft) ! write(fates_log(),*) ' Aborting' ! call endrun(msg=errMsg(sourcefile, __LINE__)) ! From 3d63f877ff60769339dbcf4cf9286c0bd77565a0 Mon Sep 17 00:00:00 2001 From: Marcos Longo Date: Tue, 3 May 2022 15:57:33 -0700 Subject: [PATCH 564/578] Replaced variable laimemory with leafmemory. Rationale: "laimemory" was a misnomer, as we were tracking leaf biomass. I renamed it leafmemory to be consistent with the memory term for other tissues. --- biogeochem/EDCohortDynamicsMod.F90 | 26 +++++++------- biogeochem/EDPhysiologyMod.F90 | 56 +++++++++++++++--------------- main/EDInitMod.F90 | 28 +++++++-------- main/EDTypesMod.F90 | 4 +-- main/FatesInventoryInitMod.F90 | 8 ++--- main/FatesRestartInterfaceMod.F90 | 16 ++++----- 6 files changed, 69 insertions(+), 69 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 4318ee469f..8e4698f5ea 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -147,7 +147,7 @@ module EDCohortDynamicsMod subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & - prt, laimemory, sapwmemory, structmemory, & + prt, leafmemory, sapwmemory, structmemory, & status, recruitstatus,ctrim, carea, clayer, spread, bc_in) ! ! !DESCRIPTION: @@ -181,7 +181,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & real(r8), intent(in) :: dbh ! dbh: cm class(prt_vartypes),target :: prt ! The allocated PARTEH ! object - real(r8), intent(in) :: laimemory ! target leaf biomass- set from + real(r8), intent(in) :: leafmemory ! target leaf biomass- set from ! previous year: kGC per indiv real(r8), intent(in) :: sapwmemory ! target sapwood biomass- set from ! previous year: kGC per indiv @@ -237,7 +237,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & new_cohort%canopy_trim = ctrim new_cohort%canopy_layer = clayer new_cohort%canopy_layer_yesterday = real(clayer, r8) - new_cohort%laimemory = laimemory + new_cohort%leafmemory = leafmemory new_cohort%sapwmemory = sapwmemory new_cohort%structmemory = structmemory @@ -541,7 +541,7 @@ subroutine nan_cohort(cc_p) currentCohort%dbh = nan ! 'diameter at breast height' in cm currentCohort%coage = nan ! age of the cohort in years currentCohort%hite = nan ! height: meters - currentCohort%laimemory = nan ! target leaf biomass- set from previous year: kGC per indiv + currentCohort%leafmemory = nan ! target leaf biomass- set from previous year: kGC per indiv currentCohort%sapwmemory = nan ! target sapwood biomass- set from previous year: kGC per indiv currentCohort%structmemory = nan ! target structural biomass- set from previous year: kGC per indiv currentCohort%lai = nan ! leaf area index of cohort m2/m2 @@ -765,7 +765,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ if (currentcohort%n < min_n_safemath .and. level == 1) then terminate = itrue if ( debug ) then - write(fates_log(),*) 'terminating cohorts 0',currentCohort%n/currentPatch%area,currentCohort%dbh,call_index + write(fates_log(),*) 'terminating cohorts 0',currentCohort%n/currentPatch%area,currentCohort%dbh,currentCohort%pft,call_index endif endif @@ -778,7 +778,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ (currentCohort%dbh < 0.00001_r8 .and. store_c < 0._r8) ) then terminate = itrue if ( debug ) then - write(fates_log(),*) 'terminating cohorts 1',currentCohort%n/currentPatch%area,currentCohort%dbh,call_index + write(fates_log(),*) 'terminating cohorts 1',currentCohort%n/currentPatch%area,currentCohort%dbh,currentCohort%pft,call_index endif endif @@ -786,7 +786,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ if (currentCohort%canopy_layer > nclmax ) then terminate = itrue if ( debug ) then - write(fates_log(),*) 'terminating cohorts 2', currentCohort%canopy_layer,call_index + write(fates_log(),*) 'terminating cohorts 2', currentCohort%canopy_layer,currentCohort%pft,call_index endif endif @@ -796,7 +796,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ terminate = itrue if ( debug ) then write(fates_log(),*) 'terminating cohorts 3', & - sapw_c,leaf_c,fnrt_c,store_c,call_index + sapw_c,leaf_c,fnrt_c,store_c,currentCohort%pft,call_index endif endif @@ -805,7 +805,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ terminate = itrue if ( debug ) then write(fates_log(),*) 'terminating cohorts 4', & - struct_c,sapw_c,leaf_c,fnrt_c,store_c,call_index + struct_c,sapw_c,leaf_c,fnrt_c,store_c,currentCohort%pft,call_index endif endif @@ -1196,7 +1196,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) write(fates_log(),*) 'Cohort I, Cohort II' write(fates_log(),*) 'n:',currentCohort%n,nextc%n write(fates_log(),*) 'isnew:',currentCohort%isnew,nextc%isnew - write(fates_log(),*) 'laimemory:',currentCohort%laimemory,nextc%laimemory + write(fates_log(),*) 'leafmemory:',currentCohort%leafmemory,nextc%leafmemory write(fates_log(),*) 'hite:',currentCohort%hite,nextc%hite write(fates_log(),*) 'coage:',currentCohort%coage,nextc%coage write(fates_log(),*) 'dbh:',currentCohort%dbh,nextc%dbh @@ -1234,8 +1234,8 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) ! ----------------------------------------------------------------- call UpdateCohortBioPhysRates(currentCohort) - currentCohort%laimemory = (currentCohort%n*currentCohort%laimemory & - + nextc%n*nextc%laimemory)/newn + currentCohort%leafmemory = (currentCohort%n*currentCohort%leafmemory & + + nextc%n*nextc%leafmemory)/newn currentCohort%sapwmemory = (currentCohort%n*currentCohort%sapwmemory & + nextc%n*nextc%sapwmemory)/newn @@ -1828,7 +1828,7 @@ subroutine copy_cohort( currentCohort,copyc ) n%dbh = o%dbh n%coage = o%coage n%hite = o%hite - n%laimemory = o%laimemory + n%leafmemory = o%leafmemory n%sapwmemory = o%sapwmemory n%structmemory = o%structmemory n%lai = o%lai diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 5d66f56d39..72959ddf21 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -425,8 +425,8 @@ subroutine trim_canopy( currentSite ) real(r8) :: initial_trim ! Initial trim real(r8) :: optimum_trim ! Optimum trim value - real(r8) :: initial_laimem ! Initial laimemory - real(r8) :: optimum_laimem ! Optimum laimemory + real(r8) :: initial_leafmem ! Initial leafmemory + real(r8) :: optimum_leafmem ! Optimum leafmemory !---------------------------------------------------------------------- @@ -446,15 +446,15 @@ subroutine trim_canopy( currentSite ) currentCohort => currentPatch%tallest do while (associated(currentCohort)) - ! Save off the incoming trim and laimemory + ! Save off the incoming trim and leafmemory initial_trim = currentCohort%canopy_trim - initial_laimem = currentCohort%laimemory + initial_leafmem = currentCohort%leafmemory ! Add debug diagnstic output to determine which cohort if (debug) then write(fates_log(),*) 'Current cohort:', icohort write(fates_log(),*) 'Starting canopy trim:', initial_trim - write(fates_log(),*) 'Starting laimemory:', currentCohort%laimemory + write(fates_log(),*) 'Starting leafmemory:', currentCohort%leafmemory endif trimmed = .false. @@ -601,7 +601,7 @@ subroutine trim_canopy( currentSite ) currentCohort%canopy_trim = currentCohort%canopy_trim - & EDPftvarcon_inst%trim_inc(ipft) if (prt_params%evergreen(ipft) /= 1)then - currentCohort%laimemory = currentCohort%laimemory * & + currentCohort%leafmemory = currentCohort%leafmemory * & (1.0_r8 - EDPftvarcon_inst%trim_inc(ipft)) endif @@ -649,15 +649,15 @@ subroutine trim_canopy( currentSite ) ! optimum_trim = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_trim - optimum_laimem = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_laimem + optimum_leafmem = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_leafmem ! Determine if the optimum trim value makes sense. The smallest cohorts tend to have unrealistic fits. if (optimum_trim > 0. .and. optimum_trim < 1.) then currentCohort%canopy_trim = optimum_trim - ! If the cohort pft is not evergreen we reduce the laimemory as well + ! If the cohort pft is not evergreen we reduce the leafmemory as well if (prt_params%evergreen(ipft) /= 1) then - currentCohort%laimemory = optimum_laimem + currentCohort%leafmemory = optimum_leafmem endif trimmed = .true. @@ -1123,14 +1123,14 @@ subroutine phenology_leafonoff(currentSite) ! stop flow of carbon out of bstore. if(store_c>nearzero) then - ! flush either the amount required from the laimemory, or -most- of the storage pool + ! flush either the amount required from the leafmemory, or -most- of the storage pool ! RF: added a criterion to stop the entire store pool emptying and triggering termination mortality ! n.b. this might not be necessary if we adopted a more gradual approach to leaf flushing... store_c_transfer_frac = min((EDPftvarcon_inst%phenflush_fraction(ipft)* & - currentCohort%laimemory)/store_c,(1.0_r8-carbon_store_buffer)) + currentCohort%leafmemory)/store_c,(1.0_r8-carbon_store_buffer)) if(prt_params%woody(ipft).ne.itrue)then - totalmemory=currentCohort%laimemory+currentCohort%sapwmemory+currentCohort%structmemory + totalmemory=currentCohort%leafmemory+currentCohort%sapwmemory+currentCohort%structmemory store_c_transfer_frac = min((EDPftvarcon_inst%phenflush_fraction(ipft)* & totalmemory)/store_c, (1.0_r8-carbon_store_buffer)) endif @@ -1144,7 +1144,7 @@ subroutine phenology_leafonoff(currentSite) if(prt_params%woody(ipft) == itrue) then call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, store_c_transfer_frac) - currentCohort%laimemory = 0.0_r8 + currentCohort%leafmemory = 0.0_r8 else @@ -1152,7 +1152,7 @@ subroutine phenology_leafonoff(currentSite) if (stem_drop_fraction .gt. 0.0_r8) then call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac*currentCohort%laimemory/totalmemory) + store_c_transfer_frac*currentCohort%leafmemory/totalmemory) call PRTPhenologyFlush(currentCohort%prt, ipft, sapw_organ, & store_c_transfer_frac*currentCohort%sapwmemory/totalmemory) @@ -1167,7 +1167,7 @@ subroutine phenology_leafonoff(currentSite) end if - currentCohort%laimemory = 0.0_r8 + currentCohort%leafmemory = 0.0_r8 currentCohort%structmemory = 0.0_r8 currentCohort%sapwmemory = 0.0_r8 @@ -1188,10 +1188,10 @@ subroutine phenology_leafonoff(currentSite) ! This sets the cohort to the "leaves off" flag currentCohort%status_coh = leaves_off - ! Remember what the lai was (leaf mass actually) was for next year + ! Remember what the leaf mass was for next year ! the same amount back on in the spring... - currentCohort%laimemory = leaf_c + currentCohort%leafmemory = leaf_c ! Drop Leaves (this routine will update the leaf state variables, ! for carbon and any other element that are prognostic. It will @@ -1238,12 +1238,12 @@ subroutine phenology_leafonoff(currentSite) if(store_c>nearzero) then store_c_transfer_frac = & - min((EDPftvarcon_inst%phenflush_fraction(ipft)*currentCohort%laimemory)/store_c, & + min((EDPftvarcon_inst%phenflush_fraction(ipft)*currentCohort%leafmemory)/store_c, & (1.0_r8-carbon_store_buffer)) if(prt_params%woody(ipft).ne.itrue)then - totalmemory=currentCohort%laimemory+currentCohort%sapwmemory+currentCohort%structmemory + totalmemory=currentCohort%leafmemory+currentCohort%sapwmemory+currentCohort%structmemory store_c_transfer_frac = min(EDPftvarcon_inst%phenflush_fraction(ipft)*totalmemory/store_c, & (1.0_r8-carbon_store_buffer)) @@ -1260,7 +1260,7 @@ subroutine phenology_leafonoff(currentSite) call PRTPhenologyFlush(currentCohort%prt, ipft, & leaf_organ, store_c_transfer_frac) - currentCohort%laimemory = 0.0_r8 + currentCohort%leafmemory = 0.0_r8 else @@ -1268,7 +1268,7 @@ subroutine phenology_leafonoff(currentSite) if (stem_drop_fraction .gt. 0.0_r8) then call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac*currentCohort%laimemory/totalmemory) + store_c_transfer_frac*currentCohort%leafmemory/totalmemory) call PRTPhenologyFlush(currentCohort%prt, ipft, sapw_organ, & store_c_transfer_frac*currentCohort%sapwmemory/totalmemory) @@ -1283,7 +1283,7 @@ subroutine phenology_leafonoff(currentSite) end if - currentCohort%laimemory = 0.0_r8 + currentCohort%leafmemory = 0.0_r8 currentCohort%structmemory = 0.0_r8 currentCohort%sapwmemory = 0.0_r8 @@ -1300,8 +1300,8 @@ subroutine phenology_leafonoff(currentSite) ! This sets the cohort to the "leaves off" flag currentCohort%status_coh = leaves_off - ! Remember what the lai (leaf mass actually) was for next year - currentCohort%laimemory = leaf_c + ! Remember what the leaf mass was for next year + currentCohort%leafmemory = leaf_c call PRTDeciduousTurnover(currentCohort%prt,ipft, & leaf_organ, leaf_drop_fraction) @@ -1890,7 +1890,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) ! Default assumption is that leaves are on cohortstatus = leaves_on - temp_cohort%laimemory = 0.0_r8 + temp_cohort%leafmemory = 0.0_r8 temp_cohort%sapwmemory = 0.0_r8 temp_cohort%structmemory = 0.0_r8 @@ -1899,7 +1899,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) ! as "cold", then set the cohort's status to leaves_off, and remember the leaf biomass if ((prt_params%season_decid(ft) == itrue) .and. & (any(currentSite%cstatus == [phen_cstat_nevercold,phen_cstat_iscold]))) then - temp_cohort%laimemory = c_leaf + temp_cohort%leafmemory = c_leaf c_leaf = 0.0_r8 ! If plant is not woody then set sapwood and structural biomass as well @@ -1917,7 +1917,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) ! biomass if ((prt_params%stress_decid(ft) == itrue) .and. & (any(currentSite%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff]))) then - temp_cohort%laimemory = c_leaf + temp_cohort%leafmemory = c_leaf c_leaf = 0.0_r8 ! If plant is not woody then set sapwood and structural biomass as well @@ -2103,7 +2103,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) ! This initializes the cohort call create_cohort(currentSite,currentPatch, temp_cohort%pft, temp_cohort%n, & temp_cohort%hite, temp_cohort%coage, temp_cohort%dbh, prt, & - temp_cohort%laimemory, temp_cohort%sapwmemory, temp_cohort%structmemory, & + temp_cohort%leafmemory, temp_cohort%sapwmemory, temp_cohort%structmemory, & cohortstatus, recruitstatus, & temp_cohort%canopy_trim,temp_cohort%c_area, & currentPatch%NCL_p, currentSite%spread, bc_in) diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 06bcd1858a..3b6074d643 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -787,7 +787,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) call bstore_allom(temp_cohort%dbh, pft, temp_cohort%canopy_trim, c_store) - temp_cohort%laimemory = 0._r8 + temp_cohort%leafmemory = 0._r8 temp_cohort%sapwmemory = 0._r8 temp_cohort%structmemory = 0._r8 cstatus = leaves_on @@ -798,7 +798,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) if( prt_params%season_decid(pft) == itrue .and. & any(site_in%cstatus == [phen_cstat_nevercold,phen_cstat_iscold])) then - temp_cohort%laimemory = c_leaf + temp_cohort%leafmemory = c_leaf temp_cohort%sapwmemory = c_sapw * stem_drop_fraction temp_cohort%structmemory = c_struct * stem_drop_fraction c_leaf = 0._r8 @@ -809,7 +809,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) if ( prt_params%stress_decid(pft) == itrue .and. & any(site_in%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then - temp_cohort%laimemory = c_leaf + temp_cohort%leafmemory = c_leaf temp_cohort%sapwmemory = c_sapw * stem_drop_fraction temp_cohort%structmemory = c_struct * stem_drop_fraction c_leaf = 0._r8 @@ -850,21 +850,21 @@ subroutine init_cohorts( site_in, patch_in, bc_in) case(nitrogen_element) - m_struct = c_struct*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(struct_organ)) - m_leaf = c_leaf*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(leaf_organ)) - m_fnrt = c_fnrt*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(fnrt_organ)) - m_sapw = c_sapw*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(sapw_organ)) + m_struct = c_struct*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(struct_organ)) + m_leaf = c_leaf*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(leaf_organ)) + m_fnrt = c_fnrt*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(fnrt_organ)) + m_sapw = c_sapw*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(sapw_organ)) m_repro = 0._r8 - m_store = StorageNutrientTarget(pft,element_id,m_leaf,m_fnrt,m_sapw,m_struct) + m_store = StorageNutrientTarget(pft,element_id,m_leaf,m_fnrt,m_sapw,m_struct) case(phosphorus_element) - m_struct = c_struct*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(struct_organ)) - m_leaf = c_leaf*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(leaf_organ)) - m_fnrt = c_fnrt*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(fnrt_organ)) - m_sapw = c_sapw*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(sapw_organ)) + m_struct = c_struct*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(struct_organ)) + m_leaf = c_leaf*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(leaf_organ)) + m_fnrt = c_fnrt*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(fnrt_organ)) + m_sapw = c_sapw*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(sapw_organ)) m_repro = 0._r8 - m_store = StorageNutrientTarget(pft,element_id,m_leaf,m_fnrt,m_sapw,m_struct) + m_store = StorageNutrientTarget(pft,element_id,m_leaf,m_fnrt,m_sapw,m_struct) end select @@ -893,7 +893,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) call prt_obj%CheckInitialConditions() call create_cohort(site_in, patch_in, pft, temp_cohort%n, temp_cohort%hite, & - temp_cohort%coage, temp_cohort%dbh, prt_obj, temp_cohort%laimemory, & + temp_cohort%coage, temp_cohort%dbh, prt_obj, temp_cohort%leafmemory, & temp_cohort%sapwmemory, temp_cohort%structmemory, cstatus, rstatus, & temp_cohort%canopy_trim, temp_cohort%c_area,1, site_in%spread, bc_in) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 9ce4d5fe44..d377002aa3 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -219,7 +219,7 @@ module EDTypesMod real(r8) :: coage ! cohort age in years real(r8) :: hite ! height: meters integer :: indexnumber ! unique number for each cohort. (within clump?) - real(r8) :: laimemory ! target leaf biomass- set from previous year: kGC per indiv + real(r8) :: leafmemory ! target leaf biomass- set from previous year: kGC per indiv real(r8) :: sapwmemory ! target sapwood biomass- set from previous year: kGC per indiv real(r8) :: structmemory ! target structural biomass- set from previous year: kGC per indiv integer :: canopy_layer ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) @@ -1049,7 +1049,7 @@ subroutine dump_cohort(ccohort) write(fates_log(),*) 'co%dbh = ', ccohort%dbh write(fates_log(),*) 'co%hite = ', ccohort%hite write(fates_log(),*) 'co%coage = ', ccohort%coage - write(fates_log(),*) 'co%laimemory = ', ccohort%laimemory + write(fates_log(),*) 'co%leafmemory = ', ccohort%leafmemory write(fates_log(),*) 'co%sapwmemory = ', ccohort%sapwmemory write(fates_log(),*) 'co%structmemory = ', ccohort%structmemory diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 507f01dbee..07da027056 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -1039,7 +1039,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & call bstore_allom(temp_cohort%dbh, temp_cohort%pft, temp_cohort%canopy_trim, c_store) - temp_cohort%laimemory = 0._r8 + temp_cohort%leafmemory = 0._r8 temp_cohort%sapwmemory = 0._r8 temp_cohort%structmemory = 0._r8 cstatus = leaves_on @@ -1048,7 +1048,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & if( prt_params%season_decid(temp_cohort%pft) == itrue .and. & any(csite%cstatus == [phen_cstat_nevercold,phen_cstat_iscold])) then - temp_cohort%laimemory = c_leaf + temp_cohort%leafmemory = c_leaf temp_cohort%sapwmemory = c_sapw * stem_drop_fraction temp_cohort%structmemory = c_struct * stem_drop_fraction c_leaf = 0._r8 @@ -1059,7 +1059,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & if ( prt_params%stress_decid(temp_cohort%pft) == itrue .and. & any(csite%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then - temp_cohort%laimemory = c_leaf + temp_cohort%leafmemory = c_leaf temp_cohort%sapwmemory = c_sapw * stem_drop_fraction temp_cohort%structmemory = c_struct * stem_drop_fraction c_leaf = 0._r8 @@ -1167,7 +1167,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & call create_cohort(csite, cpatch, temp_cohort%pft, temp_cohort%n, temp_cohort%hite, & temp_cohort%coage, temp_cohort%dbh, & - prt_obj, temp_cohort%laimemory,temp_cohort%sapwmemory, temp_cohort%structmemory, & + prt_obj, temp_cohort%leafmemory,temp_cohort%sapwmemory, temp_cohort%structmemory, & cstatus, rstatus, temp_cohort%canopy_trim,temp_cohort%c_area, & 1, csite%spread, bc_in) diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 0605767cd6..a2b8fc425e 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -100,7 +100,7 @@ module FatesRestartInterfaceMod integer :: ir_coage_co integer :: ir_g_sb_laweight_co integer :: ir_height_co - integer :: ir_laimemory_co + integer :: ir_leafmemory_co integer :: ir_sapwmemory_co integer :: ir_structmemory_co integer :: ir_nplant_co @@ -714,10 +714,10 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - plant height', units='m', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_height_co ) - call this%set_restart_var(vname='fates_laimemory', vtype=cohort_r8, & + call this%set_restart_var(vname='fates_leafmemory', vtype=cohort_r8, & long_name='ed cohort - target leaf biomass set from prev year', & units='kgC/indiv', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_laimemory_co ) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leafmemory_co ) call this%set_restart_var(vname='fates_sapwmemory', vtype=cohort_r8, & long_name='ed cohort - target sapwood biomass set from prev year', & @@ -1769,7 +1769,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_coage_co => this%rvars(ir_coage_co)%r81d, & rio_g_sb_laweight_co => this%rvars(ir_g_sb_laweight_co)%r81d, & rio_height_co => this%rvars(ir_height_co)%r81d, & - rio_laimemory_co => this%rvars(ir_laimemory_co)%r81d, & + rio_leafmemory_co => this%rvars(ir_leafmemory_co)%r81d, & rio_sapwmemory_co => this%rvars(ir_sapwmemory_co)%r81d, & rio_structmemory_co => this%rvars(ir_structmemory_co)%r81d, & rio_nplant_co => this%rvars(ir_nplant_co)%r81d, & @@ -1997,7 +1997,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_dbh_co(io_idx_co) = ccohort%dbh rio_coage_co(io_idx_co) = ccohort%coage rio_height_co(io_idx_co) = ccohort%hite - rio_laimemory_co(io_idx_co) = ccohort%laimemory + rio_leafmemory_co(io_idx_co) = ccohort%leafmemory rio_sapwmemory_co(io_idx_co) = ccohort%sapwmemory rio_structmemory_co(io_idx_co) = ccohort%structmemory rio_g_sb_laweight_co(io_idx_co)= ccohort%g_sb_laweight @@ -2600,7 +2600,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_coage_co => this%rvars(ir_coage_co)%r81d, & rio_g_sb_laweight_co => this%rvars(ir_g_sb_laweight_co)%r81d, & rio_height_co => this%rvars(ir_height_co)%r81d, & - rio_laimemory_co => this%rvars(ir_laimemory_co)%r81d, & + rio_leafmemory_co => this%rvars(ir_leafmemory_co)%r81d, & rio_sapwmemory_co => this%rvars(ir_sapwmemory_co)%r81d, & rio_structmemory_co => this%rvars(ir_structmemory_co)%r81d, & rio_nplant_co => this%rvars(ir_nplant_co)%r81d, & @@ -2802,9 +2802,9 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%coage = rio_coage_co(io_idx_co) ccohort%g_sb_laweight= rio_g_sb_laweight_co(io_idx_co) ccohort%hite = rio_height_co(io_idx_co) - ccohort%laimemory = rio_laimemory_co(io_idx_co) + ccohort%leafmemory = rio_leafmemory_co(io_idx_co) ccohort%sapwmemory = rio_sapwmemory_co(io_idx_co) - ccohort%structmemory= rio_structmemory_co(io_idx_co) + ccohort%structmemory = rio_structmemory_co(io_idx_co) ccohort%n = rio_nplant_co(io_idx_co) ccohort%gpp_acc = rio_gpp_acc_co(io_idx_co) ccohort%npp_acc = rio_npp_acc_co(io_idx_co) From 03fc6392cee1f34f180dab492675b263a827ca7c Mon Sep 17 00:00:00 2001 From: Marcos Longo Date: Tue, 3 May 2022 16:19:07 -0700 Subject: [PATCH 565/578] Added two history files (default inactive) with LAI by size and PFT (canopy/understory). --- main/FatesHistoryInterfaceMod.F90 | 26 +++++++++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index f43289da15..c461baa658 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -220,6 +220,9 @@ module FatesHistoryInterfaceMod integer :: ih_bstor_understory_si_scpf integer :: ih_bleaf_canopy_si_scpf integer :: ih_bleaf_understory_si_scpf + ! Size-class x PFT LAI states + integer :: ih_lai_canopy_si_scpf + integer :: ih_lai_understory_si_scpf @@ -1861,6 +1864,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_bstor_understory_si_scpf => this%hvars(ih_bstor_understory_si_scpf)%r82d, & hio_bleaf_canopy_si_scpf => this%hvars(ih_bleaf_canopy_si_scpf)%r82d, & hio_bleaf_understory_si_scpf => this%hvars(ih_bleaf_understory_si_scpf)%r82d, & + hio_lai_canopy_si_scpf => this%hvars(ih_lai_canopy_si_scpf)%r82d, & + hio_lai_understory_si_scpf => this%hvars(ih_lai_understory_si_scpf)%r82d, & hio_mortality_canopy_si_scpf => this%hvars(ih_mortality_canopy_si_scpf)%r82d, & hio_mortality_understory_si_scpf => this%hvars(ih_mortality_understory_si_scpf)%r82d, & hio_nplant_canopy_si_scpf => this%hvars(ih_nplant_canopy_si_scpf)%r82d, & @@ -2633,6 +2638,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) store_m * ccohort%n / m2_per_ha hio_bleaf_canopy_si_scpf(io_si,scpf) = hio_bleaf_canopy_si_scpf(io_si,scpf) + & leaf_m * ccohort%n / m2_per_ha + hio_lai_canopy_si_scpf(io_si,scpf) = hio_lai_canopy_si_scpf(io_si,scpf) + & + ccohort%treelai*ccohort%c_area * AREA_INV hio_canopy_biomass_si(io_si) = hio_canopy_biomass_si(io_si) + n_perm2 * total_m @@ -2726,6 +2733,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) leaf_m * ccohort%n / m2_per_ha hio_understory_biomass_si(io_si) = hio_understory_biomass_si(io_si) + & n_perm2 * total_m + hio_lai_understory_si_scpf(io_si,scpf) = hio_lai_understory_si_scpf(io_si,scpf) + & + ccohort%treelai*ccohort%c_area * AREA_INV !hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & ! (ccohort%bmort + ccohort%hmort + ccohort%cmort + @@ -4044,7 +4053,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) do j_bc = j_t,j_b vwc = bc_in(s)%h2o_liqvol_sl(j_bc) - psi = site_hydr%wrf_soil(j)%p%psi_from_th(vwc) + psi = site_hydr%wrf_soil(j)%p%psi_from_th(vwc) ! MLO: Any reason for not using smp_sl? ! cap capillary pressure ! psi = max(-1e5_r8,psi) Removing cap as that is inconstistent ! with model internals and physics. Should @@ -5793,6 +5802,14 @@ subroutine define_history_vars(this, initialize_variables) ivar=ivar, initialize=initialize_variables, & index = ih_bleaf_canopy_si_scpf) + call this%set_history_var(vname='FATES_LAI_CANOPY_SZPF', & + units = 'm2 m-2', & + long='Leaf area index (LAI) of canopy plants by pft/size', & + use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, & + index = ih_lai_canopy_si_scpf ) + call this%set_history_var(vname='FATES_NPLANT_CANOPY_SZPF', units = 'm-2', & long='number of canopy plants by size/pft per m2', & use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & @@ -5821,6 +5838,13 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_bleaf_understory_si_scpf) + call this%set_history_var(vname='FATES_LAI_USTORY_SZPF', & + units = 'm2 m-2', & + long='Leaf area index (LAI) of understory plants by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_lai_understory_si_scpf ) + call this%set_history_var(vname='FATES_NPLANT_USTORY_SZPF', & units = 'm-2', & long='density of understory plants by pft/size in number of plants per m2', & From c9e6df7de0746a065ae3328073256c6cf5b26a63 Mon Sep 17 00:00:00 2001 From: Marcos Longo Date: Tue, 3 May 2022 16:47:23 -0700 Subject: [PATCH 566/578] Updates to target carbon sub-routine to improve readability. Rationale: I rewrote sub-routine TargetAllometryCheck. Instead of using if statements to set logical variables, I assigned the logical variables directly. Also, I added more information to the error message in case the sub-routine fails, which may be useful for debugging. None of the changes should have impacts on FATES results. --- parteh/PRTAllometricCNPMod.F90 | 150 +++++++++++-------- parteh/PRTAllometricCarbonMod.F90 | 234 ++++++++++++++++-------------- 2 files changed, 211 insertions(+), 173 deletions(-) diff --git a/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 index 5617d71e5d..d1fd48c7ed 100644 --- a/parteh/PRTAllometricCNPMod.F90 +++ b/parteh/PRTAllometricCNPMod.F90 @@ -2222,72 +2222,94 @@ end function AllomCNPGrowthDeriv ! ==================================================================================== - subroutine TargetAllometryCheck(bleaf,bfroot,bsap,bstore,bdead, & - bt_leaf,bt_froot,bt_sap,bt_store,bt_dead, & - grow_leaf,grow_froot,grow_sapw,grow_store) - - ! Arguments - real(r8),intent(in) :: bleaf !actual - real(r8),intent(in) :: bfroot - real(r8),intent(in) :: bsap - real(r8),intent(in) :: bstore - real(r8),intent(in) :: bdead - real(r8),intent(in) :: bt_leaf !target - real(r8),intent(in) :: bt_froot - real(r8),intent(in) :: bt_sap - real(r8),intent(in) :: bt_store - real(r8),intent(in) :: bt_dead - logical,intent(out) :: grow_leaf !growth flag - logical,intent(out) :: grow_froot - logical,intent(out) :: grow_sapw - logical,intent(out) :: grow_store - - if( (bt_leaf - bleaf)>calloc_abs_error) then - write(fates_log(),*) 'leaves are not on-allometry at the growth step' - write(fates_log(),*) 'exiting',bleaf,bt_leaf - call endrun(msg=errMsg(sourcefile, __LINE__)) - elseif( (bleaf - bt_leaf)>calloc_abs_error) then - ! leaf is above allometry, ignore - grow_leaf = .false. - else - grow_leaf = .true. - end if - - if( (bt_froot - bfroot)>calloc_abs_error) then - write(fates_log(),*) 'fineroots are not on-allometry at the growth step' - write(fates_log(),*) 'exiting',bfroot, bt_froot - call endrun(msg=errMsg(sourcefile, __LINE__)) - elseif( ( bfroot-bt_froot)>calloc_abs_error ) then - grow_froot = .false. - else - grow_froot = .true. - end if - - if( (bt_sap - bsap)>calloc_abs_error) then - write(fates_log(),*) 'sapwood is not on-allometry at the growth step' - write(fates_log(),*) 'exiting',bsap, bt_sap - call endrun(msg=errMsg(sourcefile, __LINE__)) - elseif( ( bsap-bt_sap)>calloc_abs_error ) then - grow_sapw = .false. - else - grow_sapw = .true. - end if + subroutine TargetAllometryCheck(b0_leaf,b0_fnrt,b0_sapw,b0_store,b0_struct, & + bleaf,bfnrt,bsapw,bstore,bstruct, & + bt_leaf,bt_fnrt,bt_sapw,bt_store,bt_struct, & + carbon_balance,ipft,leaf_status, & + grow_leaf,grow_fnrt,grow_sapw,grow_store,grow_struct) - if( (bt_store - bstore)>calloc_abs_error) then - write(fates_log(),*) 'storage is not on-allometry at the growth step' - write(fates_log(),*) 'exiting',bstore,bt_store - call endrun(msg=errMsg(sourcefile, __LINE__)) - elseif( ( bstore-bt_store)>calloc_abs_error ) then - grow_store = .false. - else - grow_store = .true. - end if + ! Arguments + real(r8),intent(in) :: b0_leaf !initial + real(r8),intent(in) :: b0_fnrt + real(r8),intent(in) :: b0_sapw + real(r8),intent(in) :: b0_store + real(r8),intent(in) :: b0_struct + real(r8),intent(in) :: bleaf !actual + real(r8),intent(in) :: bfnrt + real(r8),intent(in) :: bsapw + real(r8),intent(in) :: bstore + real(r8),intent(in) :: bstruct + real(r8),intent(in) :: bt_leaf !target + real(r8),intent(in) :: bt_fnrt + real(r8),intent(in) :: bt_sapw + real(r8),intent(in) :: bt_store + real(r8),intent(in) :: bt_struct + real(r8),intent(in) :: carbon_balance !remaining carbon balance + integer,intent(in) :: ipft !Plant functional type + integer,intent(in) :: leaf_status !Phenology status + logical,intent(out) :: grow_leaf !growth flag + logical,intent(out) :: grow_fnrt + logical,intent(out) :: grow_sapw + logical,intent(out) :: grow_store + logical,intent(out) :: grow_struct + ! Local variables + logical :: fine_leaf + logical :: fine_fnrt + logical :: fine_sapw + logical :: fine_store + logical :: fine_struct + logical :: all_fine + ! Local constants + character(len= 3), parameter :: fmth = '(a)' + character(len=27), parameter :: fmtb = '(a,3(1x,es12.5,1x,a),1x,l1)' + character(len=13), parameter :: fmte = '(a,1x,es12.5)' + character(len=10), parameter :: fmti = '(a,1x,i12)' + + + ! First test whether or not each pool looks reasonable. + fine_leaf = (bt_leaf - bleaf ) <= calloc_abs_error + fine_fnrt = (bt_fnrt - bfnrt ) <= calloc_abs_error + fine_sapw = (bt_sapw - bsapw ) <= calloc_abs_error + fine_store = (bt_store - bstore ) <= calloc_abs_error + fine_struct = (bt_struct - bstruct) <= calloc_abs_error + all_fine = fine_leaf .and. fine_fnrt .and. fine_sapw .and. & + fine_store .and. fine_struct + + ! Decide whether or not to grow tissues (but only if all tissues look fine). + ! We grow only when biomass is less than target biomass (with tolerance). + if (all_fine) then + grow_leaf = ( bleaf - bt_leaf ) <= calloc_abs_error + grow_fnrt = ( bfnrt - bt_fnrt ) <= calloc_abs_error + grow_sapw = ( bsapw - bt_sapw ) <= calloc_abs_error + grow_store = ( bstore - bt_store ) <= calloc_abs_error + grow_struct = ( bstruct - bt_struct ) <= calloc_abs_error + else + ! If anything looks not fine, write a detailed report + write(fates_log(),fmt=fmth) '======' + write(fates_log(),fmt=fmth) ' At least one tissue is not on-allometry at the growth step' + write(fates_log(),fmt=fmth) '======' + write(fates_log(),fmt=fmth) '' + write(fates_log(),fmt=fmth) ' Biomass and on-allometry test (''F'' means problem)' + write(fates_log(),fmt=fmth) '------' + write(fates_log(),fmt=fmth) ' Tissue | Initial | Current | Target | On-allometry' + write(fates_log(),fmt=fmtb) ' Leaf |',b0_leaf ,'|',bleaf ,'|',bt_leaf ,'|',fine_leaf + write(fates_log(),fmt=fmtb) ' Fine root |',b0_fnrt ,'|',bfnrt ,'|',bt_fnrt ,'|',fine_fnrt + write(fates_log(),fmt=fmtb) ' Sap wood |',b0_sapw ,'|',bsapw ,'|',bt_sapw ,'|',fine_sapw + write(fates_log(),fmt=fmtb) ' Storage |',b0_store ,'|',bstore ,'|',bt_store ,'|',fine_store + write(fates_log(),fmt=fmtb) ' Structural |',b0_struct ,'|',bstruct ,'|',bt_struct ,'|',fine_struct + write(fates_log(),fmt=fmth) '' + write(fates_log(),fmt=fmth) ' Ancillary information' + write(fates_log(),fmt=fmth) '------' + write(fates_log(),fmt=fmti) ' PFT = ',ipft + write(fates_log(),fmt=fmti) ' leaf_status = ',leaf_status + write(fates_log(),fmt=fmte) ' carbon_balance = ',carbon_balance + write(fates_log(),fmt=fmte) ' calloc_abs_error = ',calloc_abs_error + write(fates_log(),fmt=fmth) '' + write(fates_log(),fmt=fmth) '======' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - if( (bt_dead - bdead)>calloc_abs_error) then - write(fates_log(),*) 'structure not on-allometry at the growth step' - write(fates_log(),*) 'exiting',bdead,bt_dead - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + return end subroutine TargetAllometryCheck diff --git a/parteh/PRTAllometricCarbonMod.F90 b/parteh/PRTAllometricCarbonMod.F90 index 5bdf624502..c2cd84a7fc 100644 --- a/parteh/PRTAllometricCarbonMod.F90 +++ b/parteh/PRTAllometricCarbonMod.F90 @@ -376,6 +376,10 @@ subroutine DailyPRTAllometricCarbon(this) integer, parameter :: iexp_leaf = 1 ! index 1 is the expanding (i.e. youngest) ! leaf age class, and therefore ! all new allocation goes into that pool + character(len= 9), parameter :: fmti = '(a,1x,i5)' + character(len=13), parameter :: fmt0 = '(a,1x,es12.5)' + character(len=19), parameter :: fmth = '(a,1x,a5,3(1x,a12))' + character(len=22), parameter :: fmtg = '(a,5x,l1,3(1x,es12.5))' real(r8) :: intgr_params(num_bc_in) ! The boundary conditions to this routine, ! are pressed into an array that is also @@ -639,24 +643,15 @@ subroutine DailyPRTAllometricCarbon(this) ! allow actual pools to be above the target, and in these cases, it sends ! a false on the "grow_<>" flag, allowing the plant to grow into these pools. ! It also checks to make sure that structural biomass is not above the target. + ! ( MLO. Removed the check for storage because the same test is done inside + ! sub-routine TargetAllometryCheck.) - if( (target_store_c - store_c)>calloc_abs_error) then - write(fates_log(),*) 'storage is not on-allometry at the growth step' - write(fates_log(),*) 'exiting' - write(fates_log(),*) 'cbal: ',carbon_balance - write(fates_log(),*) 'near-zero',nearzero - write(fates_log(),*) 'store_c: ',store_c - write(fates_log(),*) 'target c: ',target_store_c - write(fates_log(),*) 'store_c0:', store_c0 - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - call TargetAllometryCheck(sum(leaf_c(1:nleafage)), fnrt_c, sapw_c, & - store_c, struct_c, & - target_leaf_c, target_fnrt_c, & - target_sapw_c, target_store_c, target_struct_c, & - grow_struct, grow_leaf, grow_fnrt, grow_sapw, grow_store) + call TargetAllometryCheck(sum(leaf_c0(1:nleafage)),fnrt_c0,sapw_c0,store_c0,struct_c0, & + sum(leaf_c(1:nleafage)), fnrt_c, sapw_c,store_c, struct_c, & + target_leaf_c, target_fnrt_c, target_sapw_c, & + target_store_c, target_struct_c, & + carbon_balance,ipft,leaf_status, & + grow_leaf, grow_fnrt, grow_sapw, grow_store, grow_struct) ! -------------------------------------------------------------------------------- ! The numerical integration of growth requires that the instantaneous state @@ -697,28 +692,30 @@ subroutine DailyPRTAllometricCarbon(this) end if c_mask(fnrt_c_id) = grow_fnrt c_mask(sapw_c_id) = grow_sapw - c_mask(store_c_id) = grow_store c_mask(struct_c_id) = grow_struct + c_mask(store_c_id) = grow_store c_mask(repro_c_id) = .true. ! Always calculate reproduction on growth c_mask(dbh_id) = .true. ! Always increment dbh on growth step - + ! When using the Euler method, we keep things simple. We always try ! to make the first integration step to span the entirety of the integration ! window for the independent variable (available carbon) - if(ODESolve == 2) then + select case (ODESolve) + case (2) this%ode_opt_step = totalC - end if + end select do_solve_check: do while( ierr .ne. 0 ) deltaC = min(totalC,this%ode_opt_step) - if(ODESolve == 1) then + select_ODESolve: select case (ODESolve) + case (1) call RKF45(AllomCGrowthDeriv,c_pool,c_mask,deltaC,totalC, & max_trunc_error,intgr_params,c_pool_out,this%ode_opt_step,step_pass) - elseif(ODESolve == 2) then + case (2) call Euler(AllomCGrowthDeriv,c_pool,c_mask,deltaC,totalC,intgr_params,c_pool_out) ! step_pass = .true. @@ -741,11 +738,11 @@ subroutine DailyPRTAllometricCarbon(this) else this%ode_opt_step = 0.5*deltaC end if - else + case default write(fates_log(),*) 'An integrator was chosen that does not exist' write(fates_log(),*) 'ODESolve = ',ODESolve call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + end select select_ODESolve nsteps = nsteps + 1 @@ -755,17 +752,22 @@ subroutine DailyPRTAllometricCarbon(this) end if if(nsteps > max_substeps ) then - write(fates_log(),*) 'Plant Growth Integrator could not find' - write(fates_log(),*) 'a solution in less than ',max_substeps,' tries' - write(fates_log(),*) 'Aborting' - write(fates_log(),*) 'carbon_balance',carbon_balance - write(fates_log(),*) 'deltaC',deltaC - write(fates_log(),*) 'totalC',totalC - write(fates_log(),*) 'leaf:',grow_leaf,target_leaf_c,target_leaf_c - sum(leaf_c(:)) - write(fates_log(),*) 'fnrt:',grow_fnrt,target_fnrt_c,target_fnrt_c - fnrt_c - write(fates_log(),*) 'sap:',grow_sapw,target_sapw_c, target_sapw_c - sapw_c - write(fates_log(),*) 'store:',grow_store,target_store_c,target_store_c - store_c - write(fates_log(),*) 'dead:',target_struct_c,target_struct_c - struct_c + write(fates_log(),fmt=*) '---~---' + write(fates_log(),fmt=*) 'Plant Growth Integrator could not find' + write(fates_log(),fmt=*) 'a solution in less than ',max_substeps,' tries.' + write(fates_log(),fmt=*) 'Aborting!' + write(fates_log(),fmt=*) '---~---' + write(fates_log(),fmt=fmti) 'Leaf status =',leaf_status + write(fates_log(),fmt=fmt0) 'Carbon_balance =',carbon_balance + write(fates_log(),fmt=fmt0) 'deltaC =',deltaC + write(fates_log(),fmt=fmt0) 'totalC =',totalC + write(fates_log(),fmt=fmth) ' Tissue |', ' Grow',' Current',' Target' ,' Deficit' + write(fates_log(),fmt=fmtg) ' Leaf |', grow_leaf , sum(leaf_c(:)),target_leaf_c , target_leaf_c - sum(leaf_c(:)) + write(fates_log(),fmt=fmtg) ' Fine root |', grow_fnrt , fnrt_c,target_fnrt_c , target_fnrt_c - fnrt_c + write(fates_log(),fmt=fmtg) ' Sapwood |', grow_sapw , sapw_c,target_sapw_c , target_sapw_c - sapw_c + write(fates_log(),fmt=fmtg) ' Storage |', grow_store , store_c,target_store_c , target_store_c - store_c + write(fates_log(),fmt=fmtg) ' Structural |', grow_struct , struct_c,target_struct_c, target_struct_c - struct_c + write(fates_log(),fmt=*) '---~---' call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1008,80 +1010,94 @@ end function AllomCGrowthDeriv ! ==================================================================================== - subroutine TargetAllometryCheck(bleaf,bfroot,bsap,bstore,bdead, & - bt_leaf,bt_froot,bt_sap,bt_store,bt_dead, & - grow_dead,grow_leaf,grow_froot,grow_sapw,grow_store) - - ! Arguments - real(r8),intent(in) :: bleaf !actual - real(r8),intent(in) :: bfroot - real(r8),intent(in) :: bsap - real(r8),intent(in) :: bstore - real(r8),intent(in) :: bdead - real(r8),intent(in) :: bt_leaf !target - real(r8),intent(in) :: bt_froot - real(r8),intent(in) :: bt_sap - real(r8),intent(in) :: bt_store - real(r8),intent(in) :: bt_dead - logical,intent(out) :: grow_leaf !growth flag - logical,intent(out) :: grow_froot - logical,intent(out) :: grow_sapw - logical,intent(out) :: grow_store - logical,intent(out) :: grow_dead - - if( (bt_leaf - bleaf)>calloc_abs_error) then - write(fates_log(),*) 'leaves are not on-allometry at the growth step' - write(fates_log(),*) 'exiting',bleaf,bt_leaf - call endrun(msg=errMsg(sourcefile, __LINE__)) - elseif( (bleaf - bt_leaf)>calloc_abs_error) then - ! leaf is above allometry, ignore - grow_leaf = .false. - else - grow_leaf = .true. - end if - - if( (bt_froot - bfroot)>calloc_abs_error) then - write(fates_log(),*) 'fineroots are not on-allometry at the growth step' - write(fates_log(),*) 'exiting',bfroot, bt_froot - call endrun(msg=errMsg(sourcefile, __LINE__)) - elseif( ( bfroot-bt_froot)>calloc_abs_error ) then - grow_froot = .false. - else - grow_froot = .true. - end if - - if( (bt_sap - bsap)>calloc_abs_error) then - write(fates_log(),*) 'sapwood is not on-allometry at the growth step' - write(fates_log(),*) 'exiting',bsap, bt_sap - call endrun(msg=errMsg(sourcefile, __LINE__)) - elseif( ( bsap-bt_sap)>calloc_abs_error ) then - grow_sapw = .false. - else - grow_sapw = .true. - end if - - if( (bt_store - bstore)>calloc_abs_error) then - write(fates_log(),*) 'storage is not on-allometry at the growth step' - write(fates_log(),*) 'exiting',bstore,bt_store - call endrun(msg=errMsg(sourcefile, __LINE__)) - elseif( ( bstore-bt_store)>calloc_abs_error ) then - grow_store = .false. - else - grow_store = .true. - end if - - if( (bt_dead - bdead)>calloc_abs_error) then - write(fates_log(),*) 'structure not on-allometry at the growth step' - write(fates_log(),*) 'exiting',bdead,bt_dead - call endrun(msg=errMsg(sourcefile, __LINE__)) - elseif( (bdead-bt_dead)> calloc_abs_error) then - grow_dead = .false. - else - grow_dead = .true. - end if - + subroutine TargetAllometryCheck(b0_leaf,b0_fnrt,b0_sapw,b0_store,b0_struct, & + bleaf,bfnrt,bsapw,bstore,bstruct, & + bt_leaf,bt_fnrt,bt_sapw,bt_store,bt_struct, & + carbon_balance,ipft,leaf_status, & + grow_leaf,grow_fnrt,grow_sapw,grow_store,grow_struct) - return + ! Arguments + real(r8),intent(in) :: b0_leaf !initial + real(r8),intent(in) :: b0_fnrt + real(r8),intent(in) :: b0_sapw + real(r8),intent(in) :: b0_store + real(r8),intent(in) :: b0_struct + real(r8),intent(in) :: bleaf !actual + real(r8),intent(in) :: bfnrt + real(r8),intent(in) :: bsapw + real(r8),intent(in) :: bstore + real(r8),intent(in) :: bstruct + real(r8),intent(in) :: bt_leaf !target + real(r8),intent(in) :: bt_fnrt + real(r8),intent(in) :: bt_sapw + real(r8),intent(in) :: bt_store + real(r8),intent(in) :: bt_struct + real(r8),intent(in) :: carbon_balance !remaining carbon balance + integer,intent(in) :: ipft !Plant functional type + integer,intent(in) :: leaf_status !Phenology status + logical,intent(out) :: grow_leaf !growth flag + logical,intent(out) :: grow_fnrt + logical,intent(out) :: grow_sapw + logical,intent(out) :: grow_store + logical,intent(out) :: grow_struct + ! Local variables + logical :: fine_leaf + logical :: fine_fnrt + logical :: fine_sapw + logical :: fine_store + logical :: fine_struct + logical :: all_fine + ! Local constants + character(len= 3), parameter :: fmth = '(a)' + character(len=27), parameter :: fmtb = '(a,3(1x,es12.5,1x,a),1x,l1)' + character(len=13), parameter :: fmte = '(a,1x,es12.5)' + character(len=10), parameter :: fmti = '(a,1x,i12)' + + + ! First test whether or not each pool looks reasonable. + fine_leaf = (bt_leaf - bleaf ) <= calloc_abs_error + fine_fnrt = (bt_fnrt - bfnrt ) <= calloc_abs_error + fine_sapw = (bt_sapw - bsapw ) <= calloc_abs_error + fine_store = (bt_store - bstore ) <= calloc_abs_error + fine_struct = (bt_struct - bstruct) <= calloc_abs_error + all_fine = fine_leaf .and. fine_fnrt .and. fine_sapw .and. & + fine_store .and. fine_struct + + ! Decide whether or not to grow tissues (but only if all tissues look fine). + ! We grow only when biomass is less than target biomass (with tolerance). + if (all_fine) then + grow_leaf = ( bleaf - bt_leaf ) <= calloc_abs_error + grow_fnrt = ( bfnrt - bt_fnrt ) <= calloc_abs_error + grow_sapw = ( bsapw - bt_sapw ) <= calloc_abs_error + grow_store = ( bstore - bt_store ) <= calloc_abs_error + grow_struct = ( bstruct - bt_struct ) <= calloc_abs_error + else + ! If anything looks not fine, write a detailed report + write(fates_log(),fmt=fmth) '======' + write(fates_log(),fmt=fmth) ' At least one tissue is not on-allometry at the growth step' + write(fates_log(),fmt=fmth) '======' + write(fates_log(),fmt=fmth) '' + write(fates_log(),fmt=fmth) ' Biomass and on-allometry test (''F'' means problem)' + write(fates_log(),fmt=fmth) '------' + write(fates_log(),fmt=fmth) ' Tissue | Initial | Current | Target | On-allometry' + write(fates_log(),fmt=fmtb) ' Leaf |',b0_leaf ,'|',bleaf ,'|',bt_leaf ,'|',fine_leaf + write(fates_log(),fmt=fmtb) ' Fine root |',b0_fnrt ,'|',bfnrt ,'|',bt_fnrt ,'|',fine_fnrt + write(fates_log(),fmt=fmtb) ' Sap wood |',b0_sapw ,'|',bsapw ,'|',bt_sapw ,'|',fine_sapw + write(fates_log(),fmt=fmtb) ' Storage |',b0_store ,'|',bstore ,'|',bt_store ,'|',fine_store + write(fates_log(),fmt=fmtb) ' Structural |',b0_struct ,'|',bstruct ,'|',bt_struct ,'|',fine_struct + write(fates_log(),fmt=fmth) '' + write(fates_log(),fmt=fmth) ' Ancillary information' + write(fates_log(),fmt=fmth) '------' + write(fates_log(),fmt=fmti) ' PFT = ',ipft + write(fates_log(),fmt=fmti) ' leaf_status = ',leaf_status + write(fates_log(),fmt=fmte) ' carbon_balance = ',carbon_balance + write(fates_log(),fmt=fmte) ' calloc_abs_error = ',calloc_abs_error + write(fates_log(),fmt=fmth) '' + write(fates_log(),fmt=fmth) '======' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + return end subroutine TargetAllometryCheck ! ===================================================================================== From 6529a175df4ce05bc80d9591de015d3a0b95a303 Mon Sep 17 00:00:00 2001 From: Marcos Longo Date: Tue, 3 May 2022 17:04:36 -0700 Subject: [PATCH 567/578] Rename subroutines that have the word retrieve misspelt. No actual change in functionality. --- fire/SFParamsMod.F90 | 42 +++--- main/EDParamsMod.F90 | 108 +++++++-------- main/EDPftvarcon.F90 | 214 +++++++++++++++--------------- main/FatesParametersInterface.F90 | 38 +++--- parteh/PRTParamsFATESMod.F90 | 132 +++++++++--------- 5 files changed, 267 insertions(+), 267 deletions(-) diff --git a/fire/SFParamsMod.F90 b/fire/SFParamsMod.F90 index 02c0ce7756..3d903397bc 100644 --- a/fire/SFParamsMod.F90 +++ b/fire/SFParamsMod.F90 @@ -260,37 +260,37 @@ subroutine SpitFireReceiveScalars(fates_params) real(r8) :: tmp_real - call fates_params%RetreiveParameter(name=SF_name_fdi_a, & + call fates_params%RetrieveParameter(name=SF_name_fdi_a, & data=SF_val_fdi_a) - call fates_params%RetreiveParameter(name=SF_name_fdi_b, & + call fates_params%RetrieveParameter(name=SF_name_fdi_b, & data=SF_val_fdi_b) - call fates_params%RetreiveParameter(name=SF_name_fdi_alpha, & + call fates_params%RetrieveParameter(name=SF_name_fdi_alpha, & data=SF_val_fdi_alpha) - call fates_params%RetreiveParameter(name=SF_name_miner_total, & + call fates_params%RetrieveParameter(name=SF_name_miner_total, & data=SF_val_miner_total) - call fates_params%RetreiveParameter(name=SF_name_fuel_energy, & + call fates_params%RetrieveParameter(name=SF_name_fuel_energy, & data=SF_val_fuel_energy) - call fates_params%RetreiveParameter(name=SF_name_part_dens, & + call fates_params%RetrieveParameter(name=SF_name_part_dens, & data=SF_val_part_dens) - call fates_params%RetreiveParameter(name=SF_name_miner_damp, & + call fates_params%RetrieveParameter(name=SF_name_miner_damp, & data=SF_val_miner_damp) - call fates_params%RetreiveParameter(name=SF_name_max_durat, & + call fates_params%RetrieveParameter(name=SF_name_max_durat, & data=SF_val_max_durat) - call fates_params%RetreiveParameter(name=SF_name_durat_slope, & + call fates_params%RetrieveParameter(name=SF_name_durat_slope, & data=SF_val_durat_slope) - call fates_params%RetreiveParameter(name=SF_name_drying_ratio, & + call fates_params%RetrieveParameter(name=SF_name_drying_ratio, & data=SF_val_drying_ratio) - call fates_params%RetreiveParameter(name=SF_name_fire_threshold, & + call fates_params%RetrieveParameter(name=SF_name_fire_threshold, & data=SF_val_fire_threshold) @@ -323,7 +323,7 @@ subroutine SpitFireReceiveNCWD(fates_params) class(fates_parameters_type), intent(inout) :: fates_params - call fates_params%RetreiveParameter(name=SF_name_CWD_frac, & + call fates_params%RetrieveParameter(name=SF_name_CWD_frac, & data=SF_val_CWD_frac) @@ -380,31 +380,31 @@ subroutine SpitFireReceiveNFSC(fates_params) class(fates_parameters_type), intent(inout) :: fates_params - call fates_params%RetreiveParameter(name=SF_name_SAV, & + call fates_params%RetrieveParameter(name=SF_name_SAV, & data=SF_val_SAV) - call fates_params%RetreiveParameter(name=SF_name_FBD, & + call fates_params%RetrieveParameter(name=SF_name_FBD, & data=SF_val_FBD) - call fates_params%RetreiveParameter(name=SF_name_min_moisture, & + call fates_params%RetrieveParameter(name=SF_name_min_moisture, & data=SF_val_min_moisture) - call fates_params%RetreiveParameter(name=SF_name_mid_moisture, & + call fates_params%RetrieveParameter(name=SF_name_mid_moisture, & data=SF_val_mid_moisture) - call fates_params%RetreiveParameter(name=SF_name_low_moisture_Coeff, & + call fates_params%RetrieveParameter(name=SF_name_low_moisture_Coeff, & data=SF_val_low_moisture_Coeff) - call fates_params%RetreiveParameter(name=SF_name_low_moisture_Slope, & + call fates_params%RetrieveParameter(name=SF_name_low_moisture_Slope, & data=SF_val_low_moisture_Slope) - call fates_params%RetreiveParameter(name=SF_name_mid_moisture_Coeff, & + call fates_params%RetrieveParameter(name=SF_name_mid_moisture_Coeff, & data=SF_val_mid_moisture_Coeff) - call fates_params%RetreiveParameter(name=SF_name_mid_moisture_Slope, & + call fates_params%RetrieveParameter(name=SF_name_mid_moisture_Slope, & data=SF_val_mid_moisture_Slope) - call fates_params%RetreiveParameter(name=SF_name_max_decomp, & + call fates_params%RetrieveParameter(name=SF_name_max_decomp, & data=SF_val_max_decomp) end subroutine SpitFireReceiveNFSC diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index 51926d275a..c0d14bf208 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -477,171 +477,171 @@ subroutine FatesReceiveParams(fates_params) real(r8) :: tmpreal ! local real variable for changing type on read real(r8), allocatable :: hydr_htftype_real(:) - call fates_params%RetreiveParameter(name=ED_name_photo_temp_acclim_timescale, & + call fates_params%RetrieveParameter(name=ED_name_photo_temp_acclim_timescale, & data=photo_temp_acclim_timescale) - call fates_params%RetreiveParameter(name=name_photo_tempsens_model, & + call fates_params%RetrieveParameter(name=name_photo_tempsens_model, & data=tmpreal) photo_tempsens_model = nint(tmpreal) - call fates_params%RetreiveParameter(name=name_maintresp_model, & + call fates_params%RetrieveParameter(name=name_maintresp_model, & data=tmpreal) maintresp_model = nint(tmpreal) - call fates_params%RetreiveParameter(name=ED_name_mort_disturb_frac, & + call fates_params%RetrieveParameter(name=ED_name_mort_disturb_frac, & data=fates_mortality_disturbance_fraction) - call fates_params%RetreiveParameter(name=ED_name_comp_excln, & + call fates_params%RetrieveParameter(name=ED_name_comp_excln, & data=ED_val_comp_excln) - call fates_params%RetreiveParameter(name=ED_name_vai_top_bin_width, & + call fates_params%RetrieveParameter(name=ED_name_vai_top_bin_width, & data=ED_val_vai_top_bin_width) - call fates_params%RetreiveParameter(name=ED_name_vai_width_increase_factor, & + call fates_params%RetrieveParameter(name=ED_name_vai_width_increase_factor, & data=ED_val_vai_width_increase_factor) - call fates_params%RetreiveParameter(name=ED_name_init_litter, & + call fates_params%RetrieveParameter(name=ED_name_init_litter, & data=ED_val_init_litter) - call fates_params%RetreiveParameter(name=ED_name_nignitions, & + call fates_params%RetrieveParameter(name=ED_name_nignitions, & data=ED_val_nignitions) - call fates_params%RetreiveParameter(name=ED_name_understorey_death, & + call fates_params%RetrieveParameter(name=ED_name_understorey_death, & data=ED_val_understorey_death) - call fates_params%RetreiveParameter(name=ED_name_cwd_fcel, & + call fates_params%RetrieveParameter(name=ED_name_cwd_fcel, & data=ED_val_cwd_fcel) - call fates_params%RetreiveParameter(name=ED_name_cwd_flig, & + call fates_params%RetrieveParameter(name=ED_name_cwd_flig, & data=ED_val_cwd_flig) - call fates_params%RetreiveParameter(name=ED_name_base_mr_20, & + call fates_params%RetrieveParameter(name=ED_name_base_mr_20, & data=ED_val_base_mr_20) - call fates_params%RetreiveParameter(name=ED_name_phen_drought_threshold, & + call fates_params%RetrieveParameter(name=ED_name_phen_drought_threshold, & data=ED_val_phen_drought_threshold) - call fates_params%RetreiveParameter(name=ED_name_phen_doff_time, & + call fates_params%RetrieveParameter(name=ED_name_phen_doff_time, & data=ED_val_phen_doff_time) - call fates_params%RetreiveParameter(name=ED_name_phen_a, & + call fates_params%RetrieveParameter(name=ED_name_phen_a, & data=ED_val_phen_a) - call fates_params%RetreiveParameter(name=ED_name_phen_b, & + call fates_params%RetrieveParameter(name=ED_name_phen_b, & data=ED_val_phen_b) - call fates_params%RetreiveParameter(name=ED_name_phen_c, & + call fates_params%RetrieveParameter(name=ED_name_phen_c, & data=ED_val_phen_c) - call fates_params%RetreiveParameter(name=ED_name_phen_chiltemp, & + call fates_params%RetrieveParameter(name=ED_name_phen_chiltemp, & data=ED_val_phen_chiltemp) - call fates_params%RetreiveParameter(name=ED_name_phen_mindayson, & + call fates_params%RetrieveParameter(name=ED_name_phen_mindayson, & data=ED_val_phen_mindayson) - call fates_params%RetreiveParameter(name=ED_name_phen_ncolddayslim, & + call fates_params%RetrieveParameter(name=ED_name_phen_ncolddayslim, & data=ED_val_phen_ncolddayslim) - call fates_params%RetreiveParameter(name=ED_name_phen_coldtemp, & + call fates_params%RetrieveParameter(name=ED_name_phen_coldtemp, & data=ED_val_phen_coldtemp) - call fates_params%RetreiveParameter(name=ED_name_cohort_size_fusion_tol, & + call fates_params%RetrieveParameter(name=ED_name_cohort_size_fusion_tol, & data=ED_val_cohort_size_fusion_tol) - call fates_params%RetreiveParameter(name=ED_name_cohort_age_fusion_tol, & + call fates_params%RetrieveParameter(name=ED_name_cohort_age_fusion_tol, & data=ED_val_cohort_age_fusion_tol) - call fates_params%RetreiveParameter(name=ED_name_patch_fusion_tol, & + call fates_params%RetrieveParameter(name=ED_name_patch_fusion_tol, & data=ED_val_patch_fusion_tol) - call fates_params%RetreiveParameter(name=ED_name_canopy_closure_thresh, & + call fates_params%RetrieveParameter(name=ED_name_canopy_closure_thresh, & data=ED_val_canopy_closure_thresh) - call fates_params%RetreiveParameter(name=ED_name_stomatal_model, & + call fates_params%RetrieveParameter(name=ED_name_stomatal_model, & data=tmpreal) stomatal_model = nint(tmpreal) - call fates_params%RetreiveParameter(name=hydr_name_kmax_rsurf1, & + call fates_params%RetrieveParameter(name=hydr_name_kmax_rsurf1, & data=hydr_kmax_rsurf1) - call fates_params%RetreiveParameter(name=hydr_name_kmax_rsurf2, & + call fates_params%RetrieveParameter(name=hydr_name_kmax_rsurf2, & data=hydr_kmax_rsurf2) - call fates_params%RetreiveParameter(name=hydr_name_psi0, & + call fates_params%RetrieveParameter(name=hydr_name_psi0, & data=hydr_psi0) - call fates_params%RetreiveParameter(name=hydr_name_psicap, & + call fates_params%RetrieveParameter(name=hydr_name_psicap, & data=hydr_psicap) - call fates_params%RetreiveParameter(name=bgc_name_soil_salinity, & + call fates_params%RetrieveParameter(name=bgc_name_soil_salinity, & data=bgc_soil_salinity) - call fates_params%RetreiveParameter(name=logging_name_dbhmin, & + call fates_params%RetrieveParameter(name=logging_name_dbhmin, & data=logging_dbhmin) - call fates_params%RetreiveParameter(name=logging_name_dbhmax, & + call fates_params%RetrieveParameter(name=logging_name_dbhmax, & data=logging_dbhmax) - call fates_params%RetreiveParameter(name=logging_name_collateral_frac, & + call fates_params%RetrieveParameter(name=logging_name_collateral_frac, & data=logging_collateral_frac) - call fates_params%RetreiveParameter(name=logging_name_coll_under_frac, & + call fates_params%RetrieveParameter(name=logging_name_coll_under_frac, & data=logging_coll_under_frac) - call fates_params%RetreiveParameter(name=logging_name_direct_frac, & + call fates_params%RetrieveParameter(name=logging_name_direct_frac, & data=logging_direct_frac) - call fates_params%RetreiveParameter(name=logging_name_mechanical_frac, & + call fates_params%RetrieveParameter(name=logging_name_mechanical_frac, & data=logging_mechanical_frac) - call fates_params%RetreiveParameter(name=logging_name_event_code, & + call fates_params%RetrieveParameter(name=logging_name_event_code, & data=logging_event_code) - call fates_params%RetreiveParameter(name=logging_name_dbhmax_infra, & + call fates_params%RetrieveParameter(name=logging_name_dbhmax_infra, & data=logging_dbhmax_infra) - call fates_params%RetreiveParameter(name=logging_name_export_frac, & + call fates_params%RetrieveParameter(name=logging_name_export_frac, & data=logging_export_frac) - call fates_params%RetreiveParameter(name=eca_name_plant_escalar, & + call fates_params%RetrieveParameter(name=eca_name_plant_escalar, & data=eca_plant_escalar) - call fates_params%RetreiveParameter(name=name_theta_cj_c3, & + call fates_params%RetrieveParameter(name=name_theta_cj_c3, & data=theta_cj_c3) - call fates_params%RetreiveParameter(name=name_theta_cj_c4, & + call fates_params%RetrieveParameter(name=name_theta_cj_c4, & data=theta_cj_c4) - call fates_params%RetreiveParameter(name=fates_name_q10_mr, & + call fates_params%RetrieveParameter(name=fates_name_q10_mr, & data=q10_mr) - call fates_params%RetreiveParameter(name=fates_name_q10_froz, & + call fates_params%RetrieveParameter(name=fates_name_q10_froz, & data=q10_froz) - call fates_params%RetreiveParameter(name=name_dev_arbitrary, & + call fates_params%RetrieveParameter(name=name_dev_arbitrary, & data=dev_arbitrary) - call fates_params%RetreiveParameter(name=fates_name_active_crown_fire, & + call fates_params%RetrieveParameter(name=fates_name_active_crown_fire, & data=tmpreal) active_crown_fire = (abs(tmpreal-1.0_r8) RetreiveParameterScalar, RetreiveParameter1D, RetreiveParameter2D - generic :: RetreiveParameterAllocate => RetreiveParameter1DAllocate, RetreiveParameter2DAllocate + generic :: RetrieveParameter => RetrieveParameterScalar, RetrieveParameter1D, RetrieveParameter2D + generic :: RetrieveParameterAllocate => RetrieveParameter1DAllocate, RetrieveParameter2DAllocate generic :: SetData => SetDataScalar, SetData1D, SetData2D procedure :: GetUsedDimensions procedure :: SetDimensionSizes @@ -70,11 +70,11 @@ module FatesParametersInterface procedure :: FindIndex ! Private functions - procedure, private :: RetreiveParameterScalar - procedure, private :: RetreiveParameter1D - procedure, private :: RetreiveParameter2D - procedure, private :: RetreiveParameter1DAllocate - procedure, private :: RetreiveParameter2DAllocate + procedure, private :: RetrieveParameterScalar + procedure, private :: RetrieveParameter1D + procedure, private :: RetrieveParameter2D + procedure, private :: RetrieveParameter1DAllocate + procedure, private :: RetrieveParameter2DAllocate procedure, private :: SetDataScalar procedure, private :: SetData1D procedure, private :: SetData2D @@ -151,7 +151,7 @@ subroutine RegisterParameter(this, name, dimension_shape, dimension_names, & end subroutine RegisterParameter !----------------------------------------------------------------------- - subroutine RetreiveParameterScalar(this, name, data) + subroutine RetrieveParameterScalar(this, name, data) implicit none @@ -165,10 +165,10 @@ subroutine RetreiveParameterScalar(this, name, data) ! assert(size(data) == size(this%parameters(i)%data)) data = this%parameters(i)%data(1, 1) - end subroutine RetreiveParameterScalar + end subroutine RetrieveParameterScalar !----------------------------------------------------------------------- - subroutine RetreiveParameter1D(this, name, data) + subroutine RetrieveParameter1D(this, name, data) use abortutils, only : endrun @@ -182,7 +182,7 @@ subroutine RetreiveParameter1D(this, name, data) i = this%FindIndex(name) if (size(data) /= size(this%parameters(i)%data(:, 1))) then - write(fates_log(), *) 'ERROR : retreiveparameter1d : ', name, ' size inconsistent.' + write(fates_log(), *) 'ERROR : RetrieveParameter1d : ', name, ' size inconsistent.' write(fates_log(), *) 'ERROR : expected size = ', size(data) write(fates_log(), *) 'ERROR : data size received from file = ', size(this%parameters(i)%data(:, 1)) write(fates_log(), *) 'ERROR : dimesions received from file' @@ -194,10 +194,10 @@ subroutine RetreiveParameter1D(this, name, data) end if data = this%parameters(i)%data(:, 1) - end subroutine RetreiveParameter1D + end subroutine RetrieveParameter1D !----------------------------------------------------------------------- - subroutine RetreiveParameter2D(this, name, data) + subroutine RetrieveParameter2D(this, name, data) use abortutils, only : endrun @@ -212,7 +212,7 @@ subroutine RetreiveParameter2D(this, name, data) i = this%FindIndex(name) if (size(data, 1) /= size(this%parameters(i)%data, 1) .and. & size(data, 2) /= size(this%parameters(i)%data, 2)) then - write(fates_log(), *) 'ERROR : retreiveparameter2d : ', name, ' size inconsistent.' + write(fates_log(), *) 'ERROR : RetrieveParameter2d : ', name, ' size inconsistent.' write(fates_log(), *) 'ERROR : expected shape = ', shape(data) write(fates_log(), *) 'ERROR : dim 1 expected size = ', size(data, 1) write(fates_log(), *) 'ERROR : dim 2 expected size = ', size(data, 2) @@ -227,10 +227,10 @@ subroutine RetreiveParameter2D(this, name, data) end if data = this%parameters(i)%data - end subroutine RetreiveParameter2D + end subroutine RetrieveParameter2D !----------------------------------------------------------------------- - subroutine RetreiveParameter1DAllocate(this, name, data) + subroutine RetrieveParameter1DAllocate(this, name, data) use abortutils, only : endrun @@ -248,10 +248,10 @@ subroutine RetreiveParameter1DAllocate(this, name, data) allocate(data(lower_bound:upper_bound)) data(lower_bound:upper_bound) = this%parameters(i)%data(:, 1) - end subroutine RetreiveParameter1DAllocate + end subroutine RetrieveParameter1DAllocate !----------------------------------------------------------------------- - subroutine RetreiveParameter2DAllocate(this, name, data) + subroutine RetrieveParameter2DAllocate(this, name, data) use abortutils, only : endrun @@ -271,7 +271,7 @@ subroutine RetreiveParameter2DAllocate(this, name, data) allocate(data(lb_1:ub_1, lb_2:ub_2)) data(lb_1:ub_1, lb_2:ub_2) = this%parameters(i)%data - end subroutine RetreiveParameter2DAllocate + end subroutine RetrieveParameter2DAllocate !----------------------------------------------------------------------- function FindIndex(this, name) result(i) diff --git a/parteh/PRTParamsFATESMod.F90 b/parteh/PRTParamsFATESMod.F90 index 208ff848fb..a88bb2c570 100644 --- a/parteh/PRTParamsFATESMod.F90 +++ b/parteh/PRTParamsFATESMod.F90 @@ -127,7 +127,7 @@ subroutine PRTReceiveOrgan(fates_params) real(r8), allocatable :: tmpreal(:) ! Temporary variable to hold floats name = 'fates_prt_organ_id' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=tmpreal) allocate(prt_params%organ_id(size(tmpreal,dim=1))) call ArrayNint(tmpreal,prt_params%organ_id) @@ -391,232 +391,232 @@ subroutine PRTReceivePFT(fates_params) ! that are converted to ints name = 'fates_phen_stress_decid' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=tmpreal) allocate(prt_params%stress_decid(size(tmpreal,dim=1))) call ArrayNint(tmpreal,prt_params%stress_decid) deallocate(tmpreal) name = 'fates_phen_season_decid' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=tmpreal) allocate(prt_params%season_decid(size(tmpreal,dim=1))) call ArrayNint(tmpreal,prt_params%season_decid) deallocate(tmpreal) name = 'fates_phen_evergreen' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=tmpreal) allocate(prt_params%evergreen(size(tmpreal,dim=1))) call ArrayNint(tmpreal,prt_params%evergreen) deallocate(tmpreal) name = 'fates_leaf_slamax' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%slamax) name = 'fates_leaf_slatop' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%slatop) name = 'fates_allom_sai_scaler' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_sai_scaler) name = 'fates_fnrt_prof_a' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%fnrt_prof_a) name = 'fates_fnrt_prof_b' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%fnrt_prof_b) name = 'fates_fnrt_prof_mode' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%fnrt_prof_mode) name = 'fates_fire_crown_depth_frac' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%crown) name = 'fates_woody' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%woody) name = 'fates_wood_density' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%wood_density) name = 'fates_seed_dbh_repro_threshold' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%dbh_repro_threshold) name = 'fates_alloc_storage_cushion' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%cushion) name = 'fates_leaf_stor_priority' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%leaf_stor_priority) name = 'fates_senleaf_long_fdrought' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%senleaf_long_fdrought) name = 'fates_root_long' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%root_long) name = 'fates_seed_alloc_mature' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%seed_alloc_mature) name = 'fates_seed_alloc' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%seed_alloc) name = 'fates_c2b' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%c2b) name = 'fates_grperc' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%grperc) name = 'fates_allom_dbh_maxheight' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_dbh_maxheight) name = 'fates_allom_hmode' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_hmode) name = 'fates_allom_lmode' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_lmode) name = 'fates_allom_fmode' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_fmode) name = 'fates_allom_amode' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_amode) name = 'fates_allom_stmode' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_stmode) name = 'fates_allom_cmode' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_cmode) name = 'fates_allom_smode' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_smode) name = 'fates_allom_la_per_sa_int' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_la_per_sa_int) name = 'fates_allom_la_per_sa_slp' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_la_per_sa_slp) name = 'fates_allom_l2fr' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_l2fr) name = 'fates_allom_agb_frac' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_agb_frac) name = 'fates_allom_d2h1' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_d2h1) name = 'fates_allom_d2h2' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_d2h2) name = 'fates_allom_d2h3' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_d2h3) name = 'fates_allom_d2bl1' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_d2bl1) name = 'fates_allom_d2bl2' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_d2bl2) name = 'fates_allom_d2bl3' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_d2bl3) name = 'fates_allom_blca_expnt_diff' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_blca_expnt_diff) name = 'fates_allom_d2ca_coefficient_max' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_d2ca_coefficient_max) name = 'fates_allom_d2ca_coefficient_min' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_d2ca_coefficient_min) name = 'fates_allom_agb1' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_agb1) name = 'fates_allom_agb2' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_agb2) name = 'fates_allom_agb3' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_agb3) name = 'fates_allom_agb4' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_agb4) name = 'fates_allom_zroot_max_dbh' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_zroot_max_dbh) name = 'fates_allom_zroot_max_z' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_zroot_max_z) name = 'fates_allom_zroot_min_dbh' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_zroot_min_dbh) name = 'fates_allom_zroot_min_z' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_zroot_min_z) name = 'fates_allom_zroot_k' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%allom_zroot_k) name = 'fates_branch_turnover' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%branch_long) name = 'fates_turnover_retrans_mode' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%turnover_retrans_mode) name = 'fates_nitr_store_ratio' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%nitr_store_ratio) name = 'fates_phos_store_ratio' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%phos_store_ratio) @@ -703,7 +703,7 @@ subroutine Receive_PFT_nvariants(fates_params) character(len=param_string_length) :: name !X! name = '' - !X! call fates_params%RetreiveParameter(name=name, & + !X! call fates_params%RetrieveParameter(name=name, & !X! data=this%) end subroutine Receive_PFT_nvariants @@ -722,7 +722,7 @@ subroutine PRTReceivePFTLeafAge(fates_params) character(len=param_string_length) :: name name = 'fates_leaf_long' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%leaf_long) return @@ -799,35 +799,35 @@ subroutine PRTReceivePFTOrgans(fates_params) character(len=param_string_length) :: name name = 'fates_prt_nitr_stoich_p1' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%nitr_stoich_p1) name = 'fates_prt_nitr_stoich_p2' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%nitr_stoich_p2) name = 'fates_prt_phos_stoich_p1' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%phos_stoich_p1) name = 'fates_prt_phos_stoich_p2' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%phos_stoich_p2) name = 'fates_prt_alloc_priority' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%alloc_priority) name = 'fates_turnover_carb_retrans' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%turnover_carb_retrans) name = 'fates_turnover_nitr_retrans' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%turnover_nitr_retrans) name = 'fates_turnover_phos_retrans' - call fates_params%RetreiveParameterAllocate(name=name, & + call fates_params%RetrieveParameterAllocate(name=name, & data=prt_params%turnover_phos_retrans) end subroutine PRTReceivePFTOrgans From b95ec13aef8d9bc6c25a14118247d288e1bd0d68 Mon Sep 17 00:00:00 2001 From: Marcos Longo Date: Tue, 3 May 2022 17:31:16 -0700 Subject: [PATCH 568/578] A few additional misspellings, all in commented lines. --- main/FatesSynchronizedParamsMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/FatesSynchronizedParamsMod.F90 b/main/FatesSynchronizedParamsMod.F90 index 7f35b8eeec..8cbda3fdb1 100644 --- a/main/FatesSynchronizedParamsMod.F90 +++ b/main/FatesSynchronizedParamsMod.F90 @@ -126,11 +126,11 @@ subroutine ReceiveParamsScalar(this, fates_params) character(len=param_string_length) :: name ! name = 'q10_mr' -! call fates_params%RetreiveParameter(name=name, & +! call fates_params%RetrieveParameter(name=name, & ! data=this%Q10) ! name = 'froz_q10' -! call fates_params%RetreiveParameter(name=name, & +! call fates_params%RetrieveParameter(name=name, & ! data=this%froz_q10) end subroutine ReceiveParamsScalar From 6ae65be520bfbfcdc07810eabde04a61fc881f8b Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 16 May 2022 11:40:15 -0700 Subject: [PATCH 569/578] removing redundant call to tree_lai --- biogeochem/EDCohortDynamicsMod.F90 | 7 ------- 1 file changed, 7 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index c8e7e8eaf5..277f91b2c6 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1533,13 +1533,6 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) ! update hydraulics quantities that are functions of hite & biomasses ! deallocate the hydro structure of nextc if (hlm_use_planthydro.eq.itrue) then - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) - leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) - currentCohort%treelai = tree_lai(leaf_c, & - currentCohort%pft, currentCohort%c_area, currentCohort%n, & - currentCohort%canopy_layer, currentPatch%canopy_layer_tlai, & - currentCohort%vcmax25top ) call UpdateSizeDepPlantHydProps(currentSite,currentCohort, bc_in) endif From 428d679652d740769b52be1fafd65679c9fa40d0 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 16 May 2022 11:44:13 -0700 Subject: [PATCH 570/578] removing unnecessary calls to tree_lai --- biogeochem/EDCohortDynamicsMod.F90 | 12 ------------ 1 file changed, 12 deletions(-) diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 277f91b2c6..866fac5a81 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1353,21 +1353,9 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) call endrun(msg=errMsg(sourcefile, __LINE__)) end select - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - - currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, newn, & - currentCohort%canopy_layer, currentPatch%canopy_layer_tlai, & - currentCohort%vcmax25top) - - ! We don't need check on sp mode here since we don't fuse_cohorts with sp mode - currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & - currentCohort%c_area, newn, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai, currentCohort%treelai,currentCohort%vcmax25top,1 ) - call sizetype_class_index(currentCohort%dbh,currentCohort%pft, & currentCohort%size_class,currentCohort%size_by_pft_class) - if(hlm_use_planthydro.eq.itrue) then call FuseCohortHydraulics(currentSite,currentCohort,nextc,bc_in,newn) endif From 8040e3c53875853ff159587434a4db7dd0bef3dc Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 31 May 2022 10:23:17 -0700 Subject: [PATCH 571/578] first cut at updated tveg calculation --- main/FatesHistoryInterfaceMod.F90 | 27 ++++++++++++++++++++++----- 1 file changed, 22 insertions(+), 5 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index d3f7bcfae1..89ee555a9a 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3584,11 +3584,31 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_hr_si(io_si) = bc_in(s)%tot_het_resp / g_per_kg ipa = 0 - cpatch => sites(s)%oldest_patch - + patch_area_by_age(1:nlevage) = 0._r8 canopy_area_by_age(1:nlevage) = 0._r8 + site_area_veg = 0._r8 + + ! Calculate the site-level total vegetated area (i.e. non-bareground) + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + if (nocomp_pft_label .ne. 0) then + site_area_veg = site_area_veg + cpatch%area + endif + cpatch => cpatch%younger + end do + ! Only calculate the instantaneous vegetation temperature for vegetated sites + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + if (nocomp_pft_label .ne. 0) then + hio_tveg(io_si) = hio_tveg(io_si) + & + (bc_in(s)%t_veg_pa(cpatch%patchno) - t_water_freeze_k_1atm) * cpatch%area / site_area_veg + end if + cpatch => cpatch%younger + end do + + cpatch => sites(s)%oldest_patch do while(associated(cpatch)) patch_area_by_age(cpatch%age_class) = & @@ -3615,9 +3635,6 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_rad_error_si(io_si) = hio_rad_error_si(io_si) + & cpatch%radiation_error * cpatch%area * AREA_INV - hio_tveg(io_si) = hio_tveg(io_si) + & - (bc_in(s)%t_veg_pa(cpatch%patchno) - t_water_freeze_k_1atm)*cpatch%area*area_inv - ccohort => cpatch%shortest do while(associated(ccohort)) From bf34299c3ff998cffb413154b79ce9f20ecb18d3 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 31 May 2022 10:49:57 -0700 Subject: [PATCH 572/578] updating with simpler version --- main/FatesHistoryInterfaceMod.F90 | 25 +++++++++++-------------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 89ee555a9a..07a65666ed 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3488,8 +3488,9 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) real(r8) :: npp ! npp for this time-step (adjusted for g resp) [kgC/indiv/step] real(r8) :: aresp ! autotrophic respiration (adjusted for g resp) [kgC/indiv/step] 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) :: 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 + real(r8) :: site_area_veg ! area of the site that is not bare-ground real(r8), parameter :: tiny = 1.e-5_r8 ! some small number integer :: ipa2 ! patch incrementer integer :: cnlfpft_indx, cnlf_indx, ipft, ican, ileaf ! more iterators and indices @@ -3587,27 +3588,17 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) patch_area_by_age(1:nlevage) = 0._r8 canopy_area_by_age(1:nlevage) = 0._r8 - site_area_veg = 0._r8 + site_area_veg = area ! Calculate the site-level total vegetated area (i.e. non-bareground) cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - if (nocomp_pft_label .ne. 0) then - site_area_veg = site_area_veg + cpatch%area + if (nocomp_pft_label .eq. 0) then + site_area_veg = site_area_veg - cpatch%area endif cpatch => cpatch%younger end do - ! Only calculate the instantaneous vegetation temperature for vegetated sites - cpatch => sites(s)%oldest_patch - do while(associated(cpatch)) - if (nocomp_pft_label .ne. 0) then - hio_tveg(io_si) = hio_tveg(io_si) + & - (bc_in(s)%t_veg_pa(cpatch%patchno) - t_water_freeze_k_1atm) * cpatch%area / site_area_veg - end if - cpatch => cpatch%younger - end do - cpatch => sites(s)%oldest_patch do while(associated(cpatch)) @@ -3634,6 +3625,12 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_rad_error_si(io_si) = hio_rad_error_si(io_si) + & cpatch%radiation_error * cpatch%area * AREA_INV + + ! Only accumulate the instantaneous vegetation temperature for vegetated patches + if (nocomp_pft_label .ne. 0) then + hio_tveg(io_si) = hio_tveg(io_si) + & + (bc_in(s)%t_veg_pa(cpatch%patchno) - t_water_freeze_k_1atm) * cpatch%area / site_area_veg + end if ccohort => cpatch%shortest do while(associated(ccohort)) From d597f4117c4bbae5fc22fd5dcb9bc2a091573219 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 31 May 2022 10:56:32 -0700 Subject: [PATCH 573/578] fixed missing type call --- main/FatesHistoryInterfaceMod.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 07a65666ed..bb511461cf 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3593,7 +3593,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! Calculate the site-level total vegetated area (i.e. non-bareground) cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - if (nocomp_pft_label .eq. 0) then + if (cpatch%nocomp_pft_label .eq. 0) then site_area_veg = site_area_veg - cpatch%area endif cpatch => cpatch%younger @@ -3627,7 +3627,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) cpatch%radiation_error * cpatch%area * AREA_INV ! Only accumulate the instantaneous vegetation temperature for vegetated patches - if (nocomp_pft_label .ne. 0) then + if (cpatch%nocomp_pft_label .ne. 0) then hio_tveg(io_si) = hio_tveg(io_si) + & (bc_in(s)%t_veg_pa(cpatch%patchno) - t_water_freeze_k_1atm) * cpatch%area / site_area_veg end if From adcaa0639a8534188629ca8ac43c990e7828ba42 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 31 May 2022 14:49:28 -0700 Subject: [PATCH 574/578] simplifying further --- main/FatesHistoryInterfaceMod.F90 | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 07a65666ed..59c19ff533 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -3588,16 +3588,13 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) patch_area_by_age(1:nlevage) = 0._r8 canopy_area_by_age(1:nlevage) = 0._r8 - site_area_veg = area ! Calculate the site-level total vegetated area (i.e. non-bareground) - cpatch => sites(s)%oldest_patch - do while(associated(cpatch)) - if (nocomp_pft_label .eq. 0) then - site_area_veg = site_area_veg - cpatch%area - endif - cpatch => cpatch%younger - end do + if (hlm_use_nocomp .eq. itrue) then + site_area_veg = area - sites(s)%area_pft(0) + else + site_area_veg = area + end if cpatch => sites(s)%oldest_patch do while(associated(cpatch)) @@ -3627,9 +3624,10 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) cpatch%radiation_error * cpatch%area * AREA_INV ! Only accumulate the instantaneous vegetation temperature for vegetated patches - if (nocomp_pft_label .ne. 0) then + if (cpatch%patchno .ne. 0) then hio_tveg(io_si) = hio_tveg(io_si) + & - (bc_in(s)%t_veg_pa(cpatch%patchno) - t_water_freeze_k_1atm) * cpatch%area / site_area_veg + (bc_in(s)%t_veg_pa(cpatch%patchno) - t_water_freeze_k_1atm) * & + cpatch%area / site_area_veg end if ccohort => cpatch%shortest From fc472cfb9f9b8a3097f6bb131dff1cf11f7c790e Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 28 Jun 2022 15:17:38 -0700 Subject: [PATCH 575/578] wholesale copy of @mpaiao version of the vincety algorithm --- main/FatesUtilsMod.F90 | 47 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 47 insertions(+) diff --git a/main/FatesUtilsMod.F90 b/main/FatesUtilsMod.F90 index 20416e16d6..a36261cc76 100644 --- a/main/FatesUtilsMod.F90 +++ b/main/FatesUtilsMod.F90 @@ -74,6 +74,53 @@ subroutine check_var_real(r8_var, var_name, return_code) end subroutine check_var_real + + !==========================================================================================! + ! Function to compute the great circle distance between two points: the s suffix denotes ! + ! source point, and f denotes the destination - "forepoint"). The results are given in ! + ! metres. The formula is intended to be accurate for both small and large distances and ! + ! uses double precision to avoid ill-conditioned behaviour of sin and cos for numbers ! + ! close to the n*pi/2. ! + !------------------------------------------------------------------------------------------! + real function dist_gc(slons,slonf,slats,slatf) + use consts_coms, only : erad & ! intent(in) + , pio1808 ! ! intent(in) + implicit none + !----- Local variables. ----------------------------------------------------------------! + real, intent(in) :: slons + real, intent(in) :: slonf + real, intent(in) :: slats + real, intent(in) :: slatf + !----- Local variables. ----------------------------------------------------------------! + real(kind=8) :: lons + real(kind=8) :: lonf + real(kind=8) :: lats + real(kind=8) :: latf + real(kind=8) :: dlon + real(kind=8) :: dlat + real(kind=8) :: x + real(kind=8) :: y + !---------------------------------------------------------------------------------------! + + !----- Convert the co-ordinates to double precision and to radians. --------------------! + lons = dble(slons) * pio1808 + lonf = dble(slonf) * pio1808 + lats = dble(slats) * pio1808 + latf = dble(slatf) * pio1808 + dlon = lonf - lons + dlat = latf - lats + + !----- Find the arcs. ------------------------------------------------------------------! + x = dsin(lats) * dsin(latf) + dcos(lats) * dcos(latf) * dcos(dlon) + y = dsqrt( (dcos(latf)*dsin(dlon)) * (dcos(latf)*dsin(dlon)) & + + (dcos(lats)*dsin(latf)-dsin(lats)*dcos(latf)*dcos(dlon)) & + * (dcos(lats)*dsin(latf)-dsin(lats)*dcos(latf)*dcos(dlon)) ) + + !----- Convert the arcs to actual distance. --------------------------------------------! + dist_gc = erad*sngl(datan2(y,x)) + + return + end function dist_gc end module FatesUtilsMod From ef30ae81583b61dbd14c45d9d5623e27a20f2f83 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Tue, 28 Jun 2022 15:43:31 -0700 Subject: [PATCH 576/578] updating gcd import code with fates constants. Adding new constant params --- main/FatesConstantsMod.F90 | 5 +++ main/FatesUtilsMod.F90 | 84 ++++++++++++++++++++------------------ 2 files changed, 50 insertions(+), 39 deletions(-) diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 726100a37b..11d209865a 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -223,6 +223,11 @@ module FatesConstantsMod real(fates_r8), parameter, public :: fates_huge = huge(g_per_kg) real(fates_r8), parameter, public :: fates_tiny = tiny(g_per_kg) + + ! Geodesy constants (WGS 84) + real(fates_r8), parameter, public :: earth_radius_eq = 6378137_fates_r8 ! equitorial radius, earth [m] + real(fates_r8), parameter, public :: earth_flattening = 1.0_fates_r8 / 298.257223563_fates_r8 ! flattening [non-dimensional] + ! Geometric Constants diff --git a/main/FatesUtilsMod.F90 b/main/FatesUtilsMod.F90 index a36261cc76..13176ddec8 100644 --- a/main/FatesUtilsMod.F90 +++ b/main/FatesUtilsMod.F90 @@ -82,45 +82,51 @@ end subroutine check_var_real ! uses double precision to avoid ill-conditioned behaviour of sin and cos for numbers ! ! close to the n*pi/2. ! !------------------------------------------------------------------------------------------! - real function dist_gc(slons,slonf,slats,slatf) - use consts_coms, only : erad & ! intent(in) - , pio1808 ! ! intent(in) - implicit none - !----- Local variables. ----------------------------------------------------------------! - real, intent(in) :: slons - real, intent(in) :: slonf - real, intent(in) :: slats - real, intent(in) :: slatf - !----- Local variables. ----------------------------------------------------------------! - real(kind=8) :: lons - real(kind=8) :: lonf - real(kind=8) :: lats - real(kind=8) :: latf - real(kind=8) :: dlon - real(kind=8) :: dlat - real(kind=8) :: x - real(kind=8) :: y - !---------------------------------------------------------------------------------------! - - !----- Convert the co-ordinates to double precision and to radians. --------------------! - lons = dble(slons) * pio1808 - lonf = dble(slonf) * pio1808 - lats = dble(slats) * pio1808 - latf = dble(slatf) * pio1808 - dlon = lonf - lons - dlat = latf - lats - - !----- Find the arcs. ------------------------------------------------------------------! - x = dsin(lats) * dsin(latf) + dcos(lats) * dcos(latf) * dcos(dlon) - y = dsqrt( (dcos(latf)*dsin(dlon)) * (dcos(latf)*dsin(dlon)) & - + (dcos(lats)*dsin(latf)-dsin(lats)*dcos(latf)*dcos(dlon)) & - * (dcos(lats)*dsin(latf)-dsin(lats)*dcos(latf)*dcos(dlon)) ) - - !----- Convert the arcs to actual distance. --------------------------------------------! - dist_gc = erad*sngl(datan2(y,x)) - - return - end function dist_gc + real(r8) function GreatCircleDist(slons,slonf,slats,slatf) + + use FatesConstantsMod, only : earth_radius_eq & + , pi_const + implicit none + + !----- Local variables. ----------------------------------------------------------------! + real(r8), intent(in) :: slons + real(r8), intent(in) :: slonf + real(r8), intent(in) :: slats + real(r8), intent(in) :: slatf + + !----- Local variables. ----------------------------------------------------------------! + real(r8) :: lons + real(r8) :: lonf + real(r8) :: lats + real(r8) :: latf + real(r8) :: dlon + real(r8) :: dlat + real(r8) :: x + real(r8) :: y + !---------------------------------------------------------------------------------------! + + !----- Convert the co-ordinates to double precision and to radians. --------------------! + lons = slons * pi_const + lonf = slonf * pi_const + lats = slats * pi_const + latf = slatf * pi_const + dlon = lonf - lons + dlat = latf - lats + + !----- Find the arcs. ------------------------------------------------------------------! + x = dsin(lats) * dsin(latf) + dcos(lats) * dcos(latf) * dcos(dlon) + y = dsqrt( (dcos(latf)*dsin(dlon)) * (dcos(latf)*dsin(dlon)) & + + (dcos(lats)*dsin(latf)-dsin(lats)*dcos(latf)*dcos(dlon)) & + * (dcos(lats)*dsin(latf)-dsin(lats)*dcos(latf)*dcos(dlon)) ) + + !----- Convert the arcs to actual distance. --------------------------------------------! + GreatCircleDist = earth_radius_eq*datan2(y,x) + + return + + end function GreatCircleDist + + end module FatesUtilsMod From 4772c5235217bee346df88a22dadb09a1e216413 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 21 Jul 2022 14:45:33 -0700 Subject: [PATCH 577/578] making great circle distance public --- main/FatesUtilsMod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/main/FatesUtilsMod.F90 b/main/FatesUtilsMod.F90 index 13176ddec8..6dfd2dbcc0 100644 --- a/main/FatesUtilsMod.F90 +++ b/main/FatesUtilsMod.F90 @@ -12,6 +12,7 @@ module FatesUtilsMod ! Make public necessary subroutines and functions public :: check_hlm_list public :: check_var_real + public :: GreatCircleDist contains From 8186d50c402df8737a891b5fdcd1d27bff434c05 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 3 Aug 2022 15:19:15 -0700 Subject: [PATCH 578/578] correct conversion to radians --- main/FatesConstantsMod.F90 | 1 + main/FatesUtilsMod.F90 | 10 +++++----- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 11d209865a..dfade42b5b 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -233,5 +233,6 @@ module FatesConstantsMod ! PI real(fates_r8), parameter, public :: pi_const = 3.14159265359_fates_r8 + real(fates_r8), parameter, public :: rad_per_deg = pi_const/180.0_fates_r8 end module FatesConstantsMod diff --git a/main/FatesUtilsMod.F90 b/main/FatesUtilsMod.F90 index 6dfd2dbcc0..27eef57247 100644 --- a/main/FatesUtilsMod.F90 +++ b/main/FatesUtilsMod.F90 @@ -86,7 +86,7 @@ end subroutine check_var_real real(r8) function GreatCircleDist(slons,slonf,slats,slatf) use FatesConstantsMod, only : earth_radius_eq & - , pi_const + , rad_per_deg implicit none !----- Local variables. ----------------------------------------------------------------! @@ -107,10 +107,10 @@ real(r8) function GreatCircleDist(slons,slonf,slats,slatf) !---------------------------------------------------------------------------------------! !----- Convert the co-ordinates to double precision and to radians. --------------------! - lons = slons * pi_const - lonf = slonf * pi_const - lats = slats * pi_const - latf = slatf * pi_const + lons = slons * rad_per_deg + lonf = slonf * rad_per_deg + lats = slats * rad_per_deg + latf = slatf * rad_per_deg dlon = lonf - lons dlat = latf - lats