From fc77a8b8103817a0ae37fc62a887bd2cd2efb94d Mon Sep 17 00:00:00 2001 From: rosiealice Date: Fri, 12 Apr 2019 15:38:33 +0200 Subject: [PATCH 001/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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/337] 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 8c3a99a44c48b0a0d0176357e82fb70865aa4188 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 16 Nov 2020 10:30:56 -0500 Subject: [PATCH 136/337] 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 2a7c346282dfd290225c0c9d264a0ea4fe75c10a Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 20 Nov 2020 11:21:08 -0700 Subject: [PATCH 137/337] 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 5f556966f71984d701833acbfb45328c355d011a Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Mon, 23 Nov 2020 14:20:37 +0100 Subject: [PATCH 138/337] 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 139/337] 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 140/337] 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 141/337] 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 142/337] 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 143/337] 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 144/337] 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 145/337] 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 146/337] 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 147/337] 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 148/337] 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 60dcff6f39d3c424970aaa70b135336b695d51a9 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Tue, 24 Nov 2020 06:41:25 -0700 Subject: [PATCH 149/337] 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 150/337] 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 151/337] 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 152/337] 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 153/337] 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 9b31a8ccb79e8c072ef4491b6de8cb3d1dac5b7a Mon Sep 17 00:00:00 2001 From: Rosie Fisher Date: Wed, 25 Nov 2020 10:58:16 +0100 Subject: [PATCH 154/337] 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 155/337] 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 156/337] 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 157/337] 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 158/337] 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 159/337] 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 160/337] 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 161/337] 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 162/337] 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 163/337] 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 164/337] 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 165/337] 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 29d528b42d1bfeb3aba520a81ef71c289b7f5f19 Mon Sep 17 00:00:00 2001 From: rosiealice Date: Thu, 26 Nov 2020 07:11:58 -0700 Subject: [PATCH 166/337] 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 167/337] 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 3b0d8b14cb3411971b046c831939c7217bd033d6 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 2 Dec 2020 21:43:38 -0500 Subject: [PATCH 168/337] 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 169/337] 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 c8778be187b120362e35c539164f436c7701da74 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 8 Dec 2020 15:51:38 -0500 Subject: [PATCH 170/337] 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 74c320bb350d901e6d060a8f4406d8da240a9d09 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 24 Jan 2021 15:04:05 -0500 Subject: [PATCH 171/337] 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 172/337] 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 173/337] 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 174/337] 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 175/337] 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 176/337] 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 177/337] 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 178/337] 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 179/337] 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 228039b44434aed4c05f9767c04f9e59b7cfa435 Mon Sep 17 00:00:00 2001 From: Joshua Rady Date: Sun, 7 Mar 2021 16:24:50 -0500 Subject: [PATCH 180/337] 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 7cf61e2a53344d4f42d76538453ee49faa23b9ee Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 15 Mar 2021 14:09:45 -0400 Subject: [PATCH 181/337] 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 182/337] 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 183/337] 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 6b393abb7f94293a7fa64e2a1c40634e0baeac45 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 24 Mar 2021 14:08:36 -0400 Subject: [PATCH 184/337] 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 185/337] 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 186/337] 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 187/337] 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 188/337] 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 189/337] 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 190/337] 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 191/337] 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 192/337] 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 193/337] 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 194/337] 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 195/337] 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 196/337] 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 197/337] 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 b974c17b936352004fb95a3333c149ba54db341b Mon Sep 17 00:00:00 2001 From: Junyan Ding Date: Sat, 27 Mar 2021 21:38:30 -0700 Subject: [PATCH 198/337] 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 199/337] 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 200/337] 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 201/337] 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 202/337] 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 203/337] 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 204/337] 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 205/337] 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 2bbe5f99b3ac6a3dfee9bc394e74a4ffa61ef3fa Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 2 Apr 2021 14:06:21 -0400 Subject: [PATCH 206/337] 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 207/337] 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 2e3fe61e5f9b2966245afaca14c66acb9c0eef0c Mon Sep 17 00:00:00 2001 From: ckoven Date: Mon, 5 Apr 2021 22:23:50 -0600 Subject: [PATCH 208/337] 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 209/337] 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 210/337] 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 211/337] 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 212/337] 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 213/337] 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 214/337] 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 215/337] 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 216/337] 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 217/337] 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 218/337] 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 219/337] 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 220/337] 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 221/337] 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 222/337] 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 223/337] 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 224/337] 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 225/337] 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 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 226/337] 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 227/337] 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 228/337] 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 229/337] 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 230/337] 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 231/337] 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 232/337] 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 233/337] 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 234/337] 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 235/337] 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 236/337] 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 237/337] 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 238/337] 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 239/337] 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 6c3e30ebe6335dd5ac891dfb567d5749f17c7cdd Mon Sep 17 00:00:00 2001 From: Azamat Mametjanov Date: Wed, 12 May 2021 22:19:27 -0400 Subject: [PATCH 240/337] Add initialization of th_sat --- biogeophys/FatesHydroWTFMod.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index 85b4965a0a..cda65a12ae 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -304,6 +304,7 @@ end subroutine set_wrf_param_base function get_thsat_base(this) result(th_sat) class(wrf_type) :: this real(r8) :: th_sat + th_sat = 0._r8 write(fates_log(),*) 'The base thsat call' write(fates_log(),*) 'should never be actualized' write(fates_log(),*) 'check how the class pointer was setup' From 1d215b8f5d57200554b880ffe391a038d41b41d9 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Mon, 17 May 2021 14:36:21 -0700 Subject: [PATCH 241/337] 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 c31e17d35ab4fa84ba18ddaa89adf1f64bc30cfb Mon Sep 17 00:00:00 2001 From: Charlie Koven Date: Fri, 21 May 2021 15:26:06 -0700 Subject: [PATCH 242/337] 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 243/337] 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 244/337] 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 e9a5da90fb74b1db8993b7b35cf2589c20d6e2e1 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 2 Jun 2021 17:57:08 -0600 Subject: [PATCH 245/337] 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 58c33ee2232e9d602948e29417b030e2289afc44 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 3 Jun 2021 12:16:08 -0600 Subject: [PATCH 246/337] 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 247/337] 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 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 248/337] 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 249/337] 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 250/337] 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 251/337] 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 252/337] 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 253/337] 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 7fe7af7e7298db25e55d45e5cc43157a79ea38db Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 23 Jun 2021 15:49:12 -0700 Subject: [PATCH 254/337] 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 255/337] 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 256/337] 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 257/337] 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 8c8da99540ffc4a2f887368d4e8339192e433323 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 22 Jun 2021 12:06:02 -0600 Subject: [PATCH 258/337] 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 259/337] 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 260/337] 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 261/337] 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 262/337] 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 263/337] 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 264/337] 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 265/337] 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 266/337] 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 267/337] 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 268/337] 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 269/337] 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 270/337] 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 271/337] 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 272/337] 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 273/337] 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 274/337] 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 275/337] 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 276/337] 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 6ee0d72ddfa1063091b8e8ac60ed1e736465afdb Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 1 Jul 2021 07:50:24 -0400 Subject: [PATCH 277/337] 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 3150bdc4944134b105cd1f0a9c37d1318d47e5d0 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Mon, 5 Jul 2021 18:03:29 -0400 Subject: [PATCH 278/337] 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 279/337] 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 280/337] 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 5730cedef519a0821e77d24284be55a7d95d097e Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Fri, 9 Jul 2021 16:48:57 -0700 Subject: [PATCH 281/337] 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 b97565a96f93625aff4afcf0336eb7fa0a67a55b Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Fri, 16 Jul 2021 10:29:46 -0400 Subject: [PATCH 282/337] 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 283/337] 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 2c892f7b84a7a56322e568dfa57ebb0c4e8225d1 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 21 Jul 2021 10:03:12 -0400 Subject: [PATCH 284/337] 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 5b25b2bb9d276e8eee19a46d30995d096dbadf3b Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Thu, 22 Jul 2021 15:21:53 -0700 Subject: [PATCH 285/337] 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 286/337] 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 287/337] 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 288/337] 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 289/337] 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 290/337] 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 291/337] 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 292/337] 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 293/337] 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 294/337] 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 295/337] 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 296/337] 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 297/337] 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 298/337] 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 299/337] 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 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 300/337] 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 301/337] 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 302/337] 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 303/337] 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 304/337] 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 305/337] 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 306/337] 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 307/337] 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 308/337] 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 309/337] 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 310/337] 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 311/337] 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 312/337] 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 313/337] 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 314/337] 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 315/337] 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 316/337] 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 317/337] 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 318/337] 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 319/337] 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 320/337] 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 321/337] 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 322/337] 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 323/337] 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 324/337] 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 a7b29b4e14e16880f1720ea9297ddfabc54b1952 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Thu, 30 Sep 2021 17:39:27 -0400 Subject: [PATCH 325/337] 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 326/337] 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 327/337] 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 43683ae1d54f0b4b5352f1d945b678d4335de102 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 6 Oct 2021 09:34:50 -0700 Subject: [PATCH 328/337] 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 20224fe84dc0c1332775d7eac1a41c7cc5451883 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Sun, 10 Oct 2021 21:25:37 -0400 Subject: [PATCH 329/337] 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 abc07905819a9068b819d68c5422615c6b09998a Mon Sep 17 00:00:00 2001 From: ckoven Date: Fri, 22 Oct 2021 17:31:30 -0600 Subject: [PATCH 330/337] 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 331/337] 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 14828199548e28f85fb80bb29fc09f1bf94f7072 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Wed, 27 Oct 2021 12:53:12 -0400 Subject: [PATCH 332/337] 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 c9dfafcbe3d26940930051c7e65dd23fe89f6276 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 2 Nov 2021 11:50:53 -0400 Subject: [PATCH 333/337] 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 1d21c5be340200bbd0f78836d54ec4ffa53c8307 Mon Sep 17 00:00:00 2001 From: Gregory Lemieux Date: Wed, 10 Nov 2021 13:03:18 -0700 Subject: [PATCH 334/337] 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 335/337] 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 ebd60a022d6c999aa9e882cd24a6162684c2dca2 Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 16 Nov 2021 10:42:11 -0500 Subject: [PATCH 336/337] 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 38e3af7ba5d56c105e2a6a43a13db1a5f1092d3a Mon Sep 17 00:00:00 2001 From: Ryan Knox Date: Tue, 16 Nov 2021 17:06:36 -0500 Subject: [PATCH 337/337] 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,