diff --git a/biogeochem/DamageMainMod.F90 b/biogeochem/DamageMainMod.F90 new file mode 100644 index 0000000000..f0a05f7ee6 --- /dev/null +++ b/biogeochem/DamageMainMod.F90 @@ -0,0 +1,229 @@ +module DamageMainMod + + use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : i4 => fates_int + use FatesConstantsMod , only : itrue, ifalse + use FatesConstantsMod , only : years_per_day + use FatesConstantsMod , only : nearzero + use FatesGlobals , only : fates_log + use FatesGlobals , only : endrun => fates_endrun + use shr_log_mod , only : errMsg => shr_log_errMsg + use EDPftvarcon , only : EDPftvarcon_inst + use EDParamsMod , only : damage_event_code + use EDParamsMod , only : ED_val_history_damage_bin_edges + use EDTypesMod , only : ed_site_type + use EDTypesMod , only : ed_patch_type + use EDTypesMod , only : ed_cohort_type + use EDTypesMod , only : AREA + use FatesInterfaceTypesMod, only : hlm_current_day + use FatesInterfaceTypesMod, only : hlm_current_month + use FatesInterfaceTypesMod, only : hlm_current_year + use FatesInterfaceTypesMod, only : hlm_model_day + use FatesInterfaceTypesMod, only : hlm_day_of_year + + implicit none + private + + logical, protected :: damage_time ! if true then damage occurs during current time step + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + public :: GetCrownReduction + public :: GetDamageFrac + public :: IsItDamageTime + public :: damage_time + public :: GetDamageMortality + + + logical :: debug = .false. ! for debugging + + + ! The following is the special classification for undamaged plants + ! and is used in contexts where cohort%damageclass is used. This is + ! to flag to the user that an undamaged plant is assumed in those contexts + + integer, parameter, public :: undamaged_class = 1 + + + ! ============================================================================ + ! ============================================================================ + +contains + + + + + subroutine IsItDamageTime(is_master, currentSite) + + !---------------------------------------------------------------------------- + ! This subroutine determines whether damage should occur (it is called daily) + ! This is almost an exact replica of the IsItLoggingTime subroutine + !----------------------------------------------------------------------------- + + + integer, intent(in) :: is_master + type(ed_site_type), intent(inout), target :: currentSite + + integer :: icode ! Integer equivalent of the event code (parameter file only allows reals) + integer :: damage_date ! Day of month for damage extracted from event code + integer :: damage_month ! Month of year for damage extracted from event code + integer :: damage_year ! Year for damage extracted from event code + integer :: model_day_int ! Model day + + character(len=64) :: fmt = '(a,i2.2,a,i2.2,a,i4.4)' + + damage_time = .false. + icode = int(damage_event_code) + + model_day_int = int(hlm_model_day) + + if(icode .eq. 1) then + ! Damage is turned off + damage_time = .false. + + else if(icode .eq. 2) then + ! Damage event on first time step + if(model_day_int .eq.1) then + damage_time = .true. + end if + + else if(icode .eq. 3) then + ! Damage event every day - this is not recommended as it will result in a very large + ! number of cohorts which will likely be terminated + damage_time = .true. + + else if(icode .eq. 4) then + ! Damage event once a month + if(hlm_current_day.eq.1 ) then + damage_time = .true. + end if + + else if(icode < 0 .and. icode > -366) then + ! Damage event every year on a specific day of the year + ! specified as negative day of year + if(hlm_day_of_year .eq. abs(icode) ) then + damage_time = .true. + end if + + else if(icode > 10000 ) then + ! Specific Event: YYYYMMDD + damage_date = icode - int(100* floor(real(icode,r8)/100._r8)) + damage_year = floor(real(icode,r8)/10000._r8) + damage_month = floor(real(icode,r8)/100._r8) - damage_year*100 + + if(hlm_current_day .eq. damage_date .and. & + hlm_current_month .eq. damage_month .and. & + hlm_current_year .eq. damage_year ) then + damage_time = .true. + end if + + else + ! Bad damage event flag + write(fates_log(),*) 'An invalid damage code was specified in fates_params' + write(fates_log(),*) 'Check DamageMainMod.F90:IsItDamageTime()' + write(fates_log(),*) 'for a breakdown of the valid codes and change' + write(fates_log(),*) 'fates_damage_event_code in the file accordingly.' + write(fates_log(),*) 'exiting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(damage_time .and. (is_master.eq.itrue) ) then + write(fates_log(),fmt) 'Damage Event Enacted on date: ', & + hlm_current_month,'-', hlm_current_day,'-',hlm_current_year + end if + + return + + end subroutine IsItDamageTime + + !---------------------------------------------------------------------------- + + subroutine GetDamageFrac(cc_cd, nc_cd, pft, dist_frac) + + + ! Given the current cohort damage class find the fraction of individuals + ! going to the new damage class. + ! This subroutine consults a look up table of transitions from param derived. + + ! USES + use FatesParameterDerivedMod, only : param_derived + + + ! ARGUMENTS + integer, intent(in) :: cc_cd ! current cohort crown damage + integer, intent(in) :: nc_cd ! new cohort crown damage + integer, intent(in) :: pft ! plant functional type + real(r8), intent(out) :: dist_frac ! fraction of current cohort moving to + ! new damage level + + dist_frac = param_derived%damage_transitions(cc_cd, nc_cd, pft) + + end subroutine GetDamageFrac + + !------------------------------------------------------- + + subroutine GetCrownReduction(crowndamage, crown_reduction) + + !------------------------------------------------------------------ + ! This subroutine takes the crown damage class of a cohort (integer) + ! and returns the fraction of the crown that is lost. + !------------------------------------------------------------------- + + integer(i4), intent(in) :: crowndamage ! crown damage class of the cohort + real(r8), intent(out) :: crown_reduction ! fraction of crown lost from damage + + crown_reduction = ED_val_history_damage_bin_edges(crowndamage)/100.0_r8 + + return + end subroutine GetCrownReduction + + + !---------------------------------------------------------------------------------------- + + + subroutine GetDamageMortality(crowndamage,pft, dgmort) + + !------------------------------------------------------------------ + ! This subroutine calculates damage-dependent mortality. + ! Not all damage related mortality will be captured by mechanisms in FATES + ! (e.g. carbon starvation mortality). Damage could also lead to damage + ! due to unrepresented mechanisms such as pathogens or increased + ! vulnerability to wind throws. This function captures mortality due to + ! those unrepresented mechanisms. + !------------------------------------------------------------------ + + use EDPftvarcon , only : EDPftvarcon_inst + + integer(i4), intent(in) :: crowndamage ! crown damage class of the cohort + integer(i4), intent(in) :: pft ! plant functional type + real(r8), intent(out) :: dgmort ! mortality directly associated with damage + + ! local variables + real(r8) :: damage_mort_p1 ! inflection point of the damage mortalty relationship + real(r8) :: damage_mort_p2 ! rate parameter for the damage mortality relationship + real(r8) :: crown_loss ! fraction of crown lost + + damage_mort_p1 = EDPftvarcon_inst%damage_mort_p1(pft) + damage_mort_p2 = EDPftvarcon_inst%damage_mort_p2(pft) + + ! make damage mortality a function of crownloss and not crowndamage + ! class so that it doesn't need to be re-parameterised if the number + ! of damage classes change. + crown_loss = ED_val_history_damage_bin_edges(crowndamage)/100.0_r8 + + if (crowndamage .eq. 1 ) then + dgmort = 0.0_r8 + else + dgmort = 1.0_r8 / (1.0_r8 + exp(-1.0_r8 * damage_mort_p2 * & + (crown_loss - damage_mort_p1) ) ) + + end if + + return + end subroutine GetDamageMortality + !---------------------------------------------------------------------------------------- + + +end module DamageMainMod + diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 0c508edce3..7407cf0ca3 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -382,7 +382,8 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) currentCohort => currentPatch%shortest do while (associated(currentCohort)) call carea_allom(currentCohort%dbh,currentCohort%n, & - currentSite%spread,currentCohort%pft,currentCohort%c_area) + currentSite%spread,currentCohort%pft, & + currentCohort%crowndamage, currentCohort%c_area) if(debug) then if(currentCohort%c_area<0._r8)then @@ -695,9 +696,10 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) 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(copyc%dbh,copyc%n,currentSite%spread,copyc%pft, & + copyc%crowndamage, copyc%c_area) call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) + currentCohort%pft,currentCohort%crowndamage, currentCohort%c_area) !----------- Insert copy into linked list ------------------------! copyc%shorter => currentCohort @@ -728,7 +730,8 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) deallocate(currentCohort) else call carea_allom(currentCohort%dbh,currentCohort%n, & - currentSite%spread,currentCohort%pft,currentCohort%c_area) + currentSite%spread,currentCohort%pft,currentCohort%crowndamage, & + currentCohort%c_area) end if endif !canopy layer = i_ly @@ -839,7 +842,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) currentCohort%canopy_layer = i_lyr call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) + currentCohort%pft,currentCohort%crowndamage, 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 @@ -865,7 +868,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) currentCohort => currentPatch%tallest do while (associated(currentCohort)) call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) + currentCohort%pft,currentCohort%crowndamage,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 @@ -1139,7 +1142,7 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) 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) + currentCohort%pft,currentCohort%crowndamage, currentCohort%c_area) ! number of individuals in promoted cohort. copyc%n = currentCohort%n*cc_gain/currentCohort%c_area @@ -1158,8 +1161,9 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) (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) + currentCohort%pft,currentCohort%crowndamage, currentCohort%c_area) + call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,& + copyc%crowndamage,copyc%c_area) !----------- Insert copy into linked list ------------------------! copyc%shorter => currentCohort @@ -1236,7 +1240,7 @@ 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%crowndamage,currentCohort%c_area) if( ( prt_params%woody(currentCohort%pft) .eq. itrue ) .and. & (currentCohort%canopy_layer .eq. 1 ) ) then sitelevel_canopyarea = sitelevel_canopyarea + currentCohort%c_area @@ -1343,7 +1347,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) if(hlm_use_sp.eq.ifalse)then call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& - currentCohort%pft,currentCohort%c_area) + currentCohort%pft,currentCohort%crowndamage, currentCohort%c_area) endif if(currentCohort%canopy_layer==1)then @@ -1409,6 +1413,8 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentPatch => currentPatch%younger end do !patch loop + + call leaf_area_profile(sites(s)) end do ! site loop @@ -1528,7 +1534,7 @@ subroutine leaf_area_profile( currentSite ) currentPatch%layer_height_profile(:,:,:) = 0._r8 currentPatch%canopy_area_profile(:,:,:) = 0._r8 currentPatch%canopy_mask(:,:) = 0 - + ! ------------------------------------------------------------------------------ ! It is remotely possible that in deserts we will not have any canopy ! area, ie not plants at all... @@ -1796,7 +1802,7 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) 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 @@ -1855,7 +1861,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) total_patch_leaf_stem_area = 0._r8 currentCohort => currentPatch%shortest do while(associated(currentCohort)) - total_patch_leaf_stem_area = total_patch_leaf_stem_area + & (currentCohort%treelai + currentCohort%treesai) * currentCohort%c_area currentCohort => currentCohort%taller @@ -2084,7 +2089,7 @@ subroutine CanopyLayerArea(currentPatch,site_spread,layer_index,layer_area) currentCohort => currentPatch%tallest do while (associated(currentCohort)) call carea_allom(currentCohort%dbh,currentCohort%n,site_spread, & - currentCohort%pft,currentCohort%c_area) + currentCohort%pft,currentCohort%crowndamage, currentCohort%c_area) if (currentCohort%canopy_layer .eq. layer_index) then layer_area = layer_area + currentCohort%c_area end if @@ -2128,7 +2133,8 @@ subroutine UpdatePatchLAI(currentPatch) ft = currentCohort%pft ! Update the cohort level lai and related variables - call UpdateCohortLAI(currentCohort,currentPatch%canopy_layer_tlai,currentPatch%total_canopy_area) + call UpdateCohortLAI(currentCohort,currentPatch%canopy_layer_tlai, & + currentPatch%total_canopy_area) ! Update the number of number of vegetation layers currentPatch%ncan(cl,ft) = max(currentPatch%ncan(cl,ft),currentCohort%NV) @@ -2146,7 +2152,7 @@ subroutine UpdatePatchLAI(currentPatch) end subroutine UpdatePatchLAI ! =============================================================================================== - subroutine UpdateCohortLAI(currentCohort, canopy_layer_tlai, patcharea) + subroutine UpdateCohortLAI(currentCohort, canopy_layer_tlai, total_canopy_area) ! Update LAI and related variables for a given cohort @@ -2156,28 +2162,28 @@ subroutine UpdateCohortLAI(currentCohort, canopy_layer_tlai, patcharea) ! Arguments type(ed_cohort_type),intent(inout), target :: currentCohort real(r8), intent(in) :: canopy_layer_tlai(nclmax) ! total leaf area index of each canopy layer - real(r8), intent(in) :: patcharea ! either patch%total_canopy_area or patch%area - + real(r8), intent(in) :: total_canopy_area ! either patch%total_canopy_area or patch%area + ! Local variables real(r8) :: leaf_c ! leaf carbon [kg] - + ! Obtain the leaf carbon leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + ! Note that tree_lai has an internal check on the canopy locatoin currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & currentCohort%n, currentCohort%canopy_layer, & canopy_layer_tlai,currentCohort%vcmax25top ) - + if (hlm_use_sp .eq. ifalse) then - currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & - currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & - canopy_layer_tlai, currentCohort%treelai , & - currentCohort%vcmax25top,4) + currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%crowndamage, & + currentCohort%canopy_trim, & + currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & + canopy_layer_tlai, currentCohort%treelai , & + currentCohort%vcmax25top,4) end if - - ! Number of actual vegetation layers in this cohort's crown currentCohort%nv = count((currentCohort%treelai+currentCohort%treesai) .gt. dlower_vai(:)) + 1 @@ -2218,7 +2224,8 @@ function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) res 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) + call carea_allom(currentCohort%dbh,currentCohort%n,site_spread,currentCohort%pft, & + currentCohort%crowndamage, c_area) arealayer = arealayer + c_area end if currentCohort => currentCohort%shorter diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 2d796a9048..5e77496713 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1,4 +1,4 @@ -module EDCohortDynamicsMod +Module EDCohortDynamicsMod ! ! !DESCRIPTION: ! Cohort stuctures in ED. @@ -11,6 +11,7 @@ module EDCohortDynamicsMod use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking + use FatesInterfaceTypesMod , only : hlm_use_tree_damage use FatesInterfaceTypesMod , only : hlm_is_restart use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : fates_unset_int @@ -29,6 +30,7 @@ module EDCohortDynamicsMod use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDTypesMod , only : nclmax use PRTGenericMod , only : element_list + use PRTGenericMod , only : StorageNutrientTarget use FatesLitterMod , only : ncwd use FatesLitterMod , only : ndcmpy use FatesLitterMod , only : litter_type @@ -41,6 +43,7 @@ module EDCohortDynamicsMod use EDTypesMod , only : ican_upper use EDTypesMod , only : site_fluxdiags_type use PRTGenericMod , only : num_elements + use EDTypesMod , only : leaves_on use EDParamsMod , only : ED_val_cohort_age_fusion_tol use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_parteh_mode @@ -66,6 +69,7 @@ module EDCohortDynamicsMod use FatesAllometryMod , only : bdead_allom use FatesAllometryMod , only : h_allom use FatesAllometryMod , only : carea_allom + use FatesAllometryMod , only : bstore_allom use FatesAllometryMod , only : ForceDBH use FatesAllometryMod , only : tree_lai, tree_sai use FatesAllometryMod , only : set_root_fraction @@ -89,17 +93,17 @@ module EDCohortDynamicsMod use PRTAllometricCarbonMod, only : ac_bc_in_id_pft use PRTAllometricCarbonMod, only : ac_bc_in_id_ctrim use PRTAllometricCarbonMod, only : ac_bc_inout_id_dbh - use PRTAllometricCarbonMod, only : ac_bc_in_id_lstat + use PRTAllometricCarbonMod, only : ac_bc_in_id_lstat, ac_bc_in_id_cdamage use PRTAllometricCNPMod, only : cnp_allom_prt_vartypes 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_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_pefflux, acnp_bc_in_id_cdamage use PRTAllometricCNPMod, only : acnp_bc_out_id_nneed use PRTAllometricCNPMod, only : acnp_bc_out_id_pneed - + use DamageMainMod, only : undamaged_class use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) @@ -125,7 +129,8 @@ module EDCohortDynamicsMod public :: UpdateCohortBioPhysRates public :: DeallocateCohort public :: EvaluateAndCorrectDBH - + public :: DamageRecovery + logical, parameter :: debug = .false. ! local debug flag character(len=*), parameter, private :: sourcefile = & @@ -143,11 +148,9 @@ module EDCohortDynamicsMod contains !-------------------------------------------------------------------------------------! - - - subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & - prt, status, recruitstatus,ctrim, carea, clayer, spread, bc_in) + prt, status, recruitstatus,ctrim, carea, clayer, crowndamage, spread, bc_in) + ! ! !DESCRIPTION: ! create new cohort @@ -167,7 +170,8 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & 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) :: crowndamage ! Cohort damage class + integer, intent(in) :: clayer ! canopy status of cohort ! (1 = canopy, 2 = understorey, etc.) integer, intent(in) :: status ! growth status of plant ! (2 = leaves on , 1 = leaves off) @@ -196,7 +200,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & 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) @@ -222,6 +226,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & new_cohort%patchptr => patchptr new_cohort%pft = pft + new_cohort%crowndamage = crowndamage new_cohort%status_coh = status new_cohort%n = nn new_cohort%hite = hite @@ -259,22 +264,23 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & ! Assign canopy extent and depth if(hlm_use_sp.eq.ifalse)then - call carea_allom(new_cohort%dbh,new_cohort%n,spread,new_cohort%pft,new_cohort%c_area) + call carea_allom(new_cohort%dbh,new_cohort%n,spread,new_cohort%pft, & + new_cohort%crowndamage,new_cohort%c_area) else 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) - 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 ) 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 ) + new_cohort%treesai = tree_sai(new_cohort%pft, new_cohort%dbh, & + new_cohort%crowndamage, 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 @@ -298,7 +304,6 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & call InitPRTBoundaryConditions(new_cohort) - ! Allocate running mean functions ! (Keeping as an example) @@ -397,10 +402,11 @@ subroutine InitPRTBoundaryConditions(new_cohort) 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_cdamage,bc_ival = new_cohort%crowndamage) call new_cohort%prt%RegisterBCIn(ac_bc_in_id_pft,bc_ival = new_cohort%pft) call new_cohort%prt%RegisterBCIn(ac_bc_in_id_ctrim,bc_rval = new_cohort%canopy_trim) call new_cohort%prt%RegisterBCIn(ac_bc_in_id_lstat,bc_ival = new_cohort%status_coh) - + case (prt_cnp_flex_allom_hyp) call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_pft,bc_ival = new_cohort%pft) @@ -410,7 +416,8 @@ 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%RegisterBCIn(acnp_bc_in_id_cdamage,bc_ival = new_cohort%crowndamage) + 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) @@ -517,6 +524,7 @@ subroutine nan_cohort(cc_p) ! VEGETATION STRUCTURE currentCohort%pft = fates_unset_int ! pft number + currentCohort%crowndamage = fates_unset_int ! Crown damage class 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.) @@ -703,6 +711,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ ! terminates all cohorts when they get too small ! ! !USES: + ! ! !ARGUMENTS type (ed_site_type) , intent(inout), target :: currentSite @@ -802,8 +811,8 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_ deallocate(currentCohort) endif currentCohort => tallerCohort - enddo - + enddo + end subroutine terminate_cohorts !-------------------------------------------------------------------------------------! @@ -936,6 +945,7 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) integer :: el ! loop index for elements integer :: c ! loop index for CWD integer :: pft ! pft index of the cohort + integer :: crowndamage ! the crown damage class of the cohort integer :: sl ! loop index for soil layers integer :: dcmpy ! loop index for decomposability @@ -1045,7 +1055,6 @@ subroutine DeallocateCohort(currentCohort) return end subroutine DeallocateCohort - subroutine fuse_cohorts(currentSite, currentPatch, bc_in) ! @@ -1058,6 +1067,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking use FatesConstantsMod , only : itrue use FatesConstantsMod, only : days_per_year + ! ! !ARGUMENTS @@ -1093,6 +1103,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) real(r8) :: larger_n, smaller_n integer :: oldercacls, youngercacls, cacls_i ! indices for tracking the age flux caused by fusion real(r8) :: older_n, younger_n + real(r8) :: crown_reduction logical, parameter :: fuse_debug = .false. ! This debug is over-verbose ! and gets its own flag @@ -1118,7 +1129,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) !---------------------------------------------------------------------! ! Keep doing this until nocohorts <= maxcohorts ! !---------------------------------------------------------------------! - + if (associated(currentPatch%shortest)) then do while(iterate == 1) @@ -1159,6 +1170,9 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) if (currentCohort%pft == nextc%pft) then + ! check cohorts have same damage class before fusing + if (currentCohort%crowndamage == nextc%crowndamage) then + ! check cohorts in same c. layer. before fusing if (currentCohort%canopy_layer == nextc%canopy_layer) then @@ -1185,6 +1199,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) write(fates_log(),*) 'coage:',currentCohort%coage,nextc%coage write(fates_log(),*) 'dbh:',currentCohort%dbh,nextc%dbh write(fates_log(),*) 'pft:',currentCohort%pft,nextc%pft + write(fates_log(),*) 'crowndamage:',currentCohort%crowndamage,nextc%crowndamage write(fates_log(),*) 'canopy_trim:',currentCohort%canopy_trim,nextc%canopy_trim write(fates_log(),*) 'canopy_layer_yesterday:', & currentCohort%canopy_layer_yesterday,nextc%canopy_layer_yesterday @@ -1258,10 +1273,12 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) call carea_allom(currentCohort%dbh,currentCohort%n, & currentSite%spread,currentCohort%pft,& + currentCohort%crowndamage, & currentCohort%c_area,inverse=.false.) call carea_allom(nextc%dbh,nextc%n, & currentSite%spread,nextc%pft,& + nextc%crowndamage, & nextc%c_area,inverse=.false.) currentCohort%c_area = currentCohort%c_area + nextc%c_area @@ -1269,7 +1286,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) ! dbh = currentCohort%dbh call carea_allom(dbh,newn,currentSite%spread,currentCohort%pft,& - currentCohort%c_area,inverse=.true.) + currentCohort%crowndamage,currentCohort%c_area,inverse=.true.) ! if (abs(dbh-fates_unset_r8) calloc_abs_error ) then - call ForceDBH( ipft, canopy_trim, dbh, hite_out, bdead=struct_c ) - delta_dbh = dbh - currentCohort%dbh + + call ForceDBH( ipft,icrowndamage,canopy_trim, dbh, hite_out, bdead=struct_c) + + delta_dbh = dbh - currentCohort%dbh delta_hite = hite_out - currentCohort%hite currentCohort%dbh = dbh currentCohort%hite = hite_out @@ -2096,10 +2122,10 @@ subroutine EvaluateAndCorrectDBH(currentCohort,delta_dbh,delta_hite) leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) ! Target leaf biomass according to allometry and trimming - call bleaf(dbh,ipft,canopy_trim,target_leaf_c) + call bleaf(dbh,ipft,icrowndamage, canopy_trim,target_leaf_c) if( ( leaf_c - target_leaf_c ) > calloc_abs_error ) then - call ForceDBH( ipft, canopy_trim, dbh, hite_out, bl=leaf_c ) + call ForceDBH( ipft, icrowndamage, canopy_trim, dbh, hite_out, bl=leaf_c ) delta_dbh = dbh - currentCohort%dbh delta_hite = hite_out - currentCohort%hite currentCohort%dbh = dbh @@ -2110,5 +2136,232 @@ subroutine EvaluateAndCorrectDBH(currentCohort,delta_dbh,delta_hite) return end subroutine EvaluateAndCorrectDBH + !------------------------------------------------------------------------------------ + + subroutine DamageRecovery(csite,cpatch,ccohort,newly_recovered) + + !--------------------------------------------------------------------------- + ! JN March 2021 + ! At this point it is possible that damaged cohorts have reached their + ! target allometries. There is a choice now - if they have excess carbon, + ! they can use it to grow along their reduced allometric targets - i.e. + ! dbh and all carbon pools grow out together. OR they can use excess carbon to + ! jump to a lower damage class by changing their target allometry and growing + ! to meet new C pools for same dbh. + ! + ! d = damage class + ! -------------------------------------------------------------------------- + + type(ed_site_type) :: csite ! Site of the current cohort + type(ed_patch_type) :: cpatch ! patch of the current cohort + type(ed_cohort_type),pointer :: ccohort ! Current (damaged) cohort + logical :: newly_recovered ! true if we create a new cohort + + ! locals + type(ed_cohort_type), pointer :: rcohort ! New cohort that recovers by + ! having a lower damage class + real(r8) :: sapw_area ! sapwood area + real(r8) :: target_sapw_c,target_sapw_m ! sapwood mass, C and N/P + real(r8) :: target_agw_c ! target above ground wood + real(r8) :: target_bgw_c ! target below ground wood + real(r8) :: target_struct_c,target_struct_m ! target structural C and N/P + real(r8) :: target_fnrt_c,target_fnrt_m ! target fine-root C and N/P + real(r8) :: target_leaf_c,target_leaf_m ! target leaf C and N/P + real(r8) :: target_store_c,target_store_m ! target storage C and N/P + real(r8) :: target_repro_m ! target reproductive C/N/P + real(r8) :: leaf_m,fnrt_m,sapw_m ! actual masses in organs C/N/P + real(r8) :: struct_m,store_m,repro_m ! actual masses in organs C/N/P + real(r8) :: mass_d ! intermediate term for nplant_recover + real(r8) :: mass_dminus1 ! intermediate term for nplant_recover + real(r8) :: available_m ! available mass that can be used to + ! improve damage class + real(r8) :: recovery_demand ! amount of mass needed to get to + ! the target of the next damage class + real(r8) :: max_recover_nplant ! max number of plants that could get to + ! target of next class + real(r8) :: nplant_recover ! number of plants in cohort that will + ! recover to the next class + integer :: el ! element loop counter + + associate(dbh => ccohort%dbh, & + ipft => ccohort%pft, & + canopy_trim => ccohort%canopy_trim) + + ! If we are currently undamaged, no recovery + ! necessary, do nothing and return a null pointer + ! If the damage_recovery_scalar is zero, which + ! would be an unusual testing case, but possible, + ! then no recovery is possible, do nothing and + ! return a null pointer + if ((ccohort%crowndamage == undamaged_class) .or. & + (EDPftvarcon_inst%damage_recovery_scalar(ipft) < nearzero) ) then + newly_recovered = .false. + return + end if + + + ! If we have not returned, then this cohort both has + ! a damaged status, and the ability to recover from that damage + ! ----------------------------------------------------------------- + + ! To determine recovery, the first priority is to determine how much + ! resources (C,N,P) are required to recover the plant to the target + ! pool sizes of the next (less) damage class + + ! Target sapwood biomass according to allometry and trimming [kgC] + call bsap_allom(dbh,ipft, ccohort%crowndamage-1, canopy_trim,sapw_area,target_sapw_c) + ! Target total above ground biomass in woody/fibrous tissues [kgC] + call bagw_allom(dbh,ipft, ccohort%crowndamage-1, target_agw_c) + ! 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) + ! Target fine-root biomass and deriv. according to allometry and trimming [kgC, kgC/cm] + call bfineroot(dbh,ipft,canopy_trim,target_fnrt_c) + ! Target storage carbon [kgC,kgC/cm] + call bstore_allom(dbh,ipft,ccohort%crowndamage-1, canopy_trim,target_store_c) + ! Target leaf biomass according to allometry and trimming + if(ccohort%status_coh==leaves_on) then + call bleaf(dbh,ipft,ccohort%crowndamage-1, canopy_trim,target_leaf_c) + else + target_leaf_c = 0._r8 + end if + + ! We will be taking the number of recovering plants + ! based on minimum of available resources for C/N/P (initialize high) + nplant_recover = 1.e10_r8 + + do el=1,num_elements + + ! Actual mass of chemical species in the organs + 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)) + + ! Target mass of chemical species in organs, based on stature, + ! allometry and stoichiometry parameters + select case (element_list(el)) + case (carbon12_element) + target_store_m = target_store_c + target_leaf_m = target_leaf_c + target_fnrt_m = target_fnrt_c + target_struct_m = target_struct_c + target_sapw_m = target_sapw_c + target_repro_m = 0._r8 + available_m = ccohort%npp_acc + case (nitrogen_element) + target_struct_m = target_struct_c * & + prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(struct_organ)) + target_leaf_m = target_leaf_c * & + prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(leaf_organ)) + target_fnrt_m = target_fnrt_c * & + prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(fnrt_organ)) + target_sapw_m = target_sapw_c * & + prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(sapw_organ)) + target_repro_m = 0._r8 + target_store_m = StorageNutrientTarget(ipft, element_list(el), & + target_leaf_m, target_fnrt_m, target_sapw_m, target_struct_m) + ! For nutrients, all uptake is immediately put into storage, so just swap + ! them and assume storage is what is available, but needs to be filled up + available_m = store_m + store_m = 0._r8 + case (phosphorus_element) + target_struct_m = target_struct_c * & + prt_params%phos_stoich_p1(ipft,prt_params%organ_param_id(struct_organ)) + target_leaf_m = target_leaf_c * & + prt_params%phos_stoich_p1(ipft,prt_params%organ_param_id(leaf_organ)) + target_fnrt_m = target_fnrt_c * & + prt_params%phos_stoich_p1(ipft,prt_params%organ_param_id(fnrt_organ)) + target_sapw_m = target_sapw_c * & + prt_params%phos_stoich_p1(ipft,prt_params%organ_param_id(sapw_organ)) + target_repro_m = 0._r8 + target_store_m = StorageNutrientTarget(ipft, element_list(el), & + target_leaf_m, target_fnrt_m, target_sapw_m, target_struct_m) + ! For nutrients, all uptake is immediately put into storage, so just swap + ! them and assume storage is what is available, but needs to be filled up + available_m = store_m + store_m = 0._r8 + end select + + ! 1. What is excess carbon? + ! carbon_balance + + ! 2. What is biomass required to go from current + ! damage level to next damage level? + + ! mass of this damage class + mass_d = leaf_m + store_m + sapw_m + fnrt_m + struct_m + repro_m + + mass_dminus1 = max(leaf_m, target_leaf_m) + max(fnrt_m, target_fnrt_m) + & + max(store_m, target_store_m) + max(sapw_m, target_sapw_m) + & + max(struct_m, target_struct_m) + + ! Mass needed to get from current mass to allometric + ! target mass of next damage class up + recovery_demand = mass_dminus1 - mass_d + + ! 3. How many trees can get there with excess carbon? + max_recover_nplant = available_m * ccohort%n / recovery_demand + + ! 4. Use the scalar to decide how many to recover + nplant_recover = min(nplant_recover,min(ccohort%n,max(0._r8,max_recover_nplant * & + EDPftvarcon_inst%damage_recovery_scalar(ipft) ))) + + end do + + if(nplant_recover < nearzero) then + + newly_recovered = .false. + return + + else + newly_recovered = .true. + allocate(rcohort) + if(hlm_use_planthydro .eq. itrue) call InitHydrCohort(csite,rcohort) + ! Initialize the PARTEH object and point to the + ! correct boundary condition fields + rcohort%prt => null() + call InitPRTObject(rcohort%prt) + call InitPRTBoundaryConditions(rcohort) + call copy_cohort(ccohort, rcohort) + + rcohort%n = nplant_recover + + rcohort%crowndamage = ccohort%crowndamage - 1 + + ! Need to adjust the crown area which is NOT on a per individual basis + call carea_allom(dbh,rcohort%n,csite%spread,ipft,rcohort%crowndamage,rcohort%c_area) + + ! Update properties of the un-recovered (donor) cohort + ccohort%n = ccohort%n - rcohort%n + ccohort%c_area = ccohort%c_area * ccohort%n / (ccohort%n+rcohort%n) + + !----------- Insert copy into linked list ----------------------! + ! This subroutine is called within a loop in EDMain that + ! proceeds short to tall. We want the newly created cohort + ! to have an opportunity to experience the list, so we add + ! it in the list in a position taller than the current cohort + ! --------------------------------------------------------------! + + rcohort%shorter => ccohort + if(associated(ccohort%taller))then + rcohort%taller => ccohort%taller + ccohort%taller%shorter => rcohort + else + cpatch%tallest => rcohort + rcohort%taller => null() + endif + ccohort%taller => rcohort + + end if ! end if greater than nearzero + + end associate + + return + end subroutine DamageRecovery + end module EDCohortDynamicsMod diff --git a/biogeochem/EDLoggingMortalityMod.F90 b/biogeochem/EDLoggingMortalityMod.F90 index b03e9485f5..5a72811707 100644 --- a/biogeochem/EDLoggingMortalityMod.F90 +++ b/biogeochem/EDLoggingMortalityMod.F90 @@ -812,7 +812,7 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site currentCohort => newPatch%shortest do while(associated(currentCohort)) call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) + currentCohort%pft,currentCohort%crowndamage,currentCohort%c_area) currentCohort => currentCohort%taller enddo diff --git a/biogeochem/EDMortalityFunctionsMod.F90 b/biogeochem/EDMortalityFunctionsMod.F90 index 22e34e1abc..2d2061bd17 100644 --- a/biogeochem/EDMortalityFunctionsMod.F90 +++ b/biogeochem/EDMortalityFunctionsMod.F90 @@ -19,6 +19,7 @@ module EDMortalityFunctionsMod use FatesInterfaceTypesMod , only : hlm_use_ed_prescribed_phys use FatesInterfaceTypesMod , only : hlm_freq_day use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_use_tree_damage use EDLoggingMortalityMod , only : LoggingMortality_frac use EDParamsMod , only : fates_mortality_disturbance_fraction @@ -49,7 +50,7 @@ module EDMortalityFunctionsMod - subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort,smort,asmort ) + subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort,smort,asmort,dgmort ) ! ============================================================================ ! Calculate mortality rates from carbon storage, hydraulic cavitation, @@ -59,6 +60,7 @@ subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort,smort,asmor use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm use FatesInterfaceTypesMod , only : hlm_hio_ignore_val use FatesConstantsMod, only : fates_check_param_set + use DamageMainMod, only : GetDamageMortality type (ed_cohort_type), intent(in) :: cohort_in type (bc_in_type), intent(in) :: bc_in @@ -67,10 +69,12 @@ subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort,smort,asmor real(r8),intent(out) :: hmort ! hydraulic failure mortality real(r8),intent(out) :: frmort ! freezing stress mortality real(r8),intent(out) :: smort ! size dependent senescence term - real(r8),intent(out) :: asmort ! age dependent senescence term + real(r8),intent(out) :: asmort ! age dependent senescence term + real(r8),intent(out) :: dgmort ! damage dependent mortality real(r8) :: frac ! relativised stored carbohydrate - real(r8) :: leaf_c_target ! target leaf biomass kgC + real(r8) :: target_leaf_c ! target leaf biomass for the current trim status and + ! damage class [kgC] real(r8) :: store_c real(r8) :: hf_sm_threshold ! hydraulic failure soil moisture threshold real(r8) :: hf_flc_threshold ! hydraulic failure fractional loss of conductivity threshold @@ -89,7 +93,9 @@ subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort,smort,asmor logical, parameter :: test_zero_mortality = .false. ! Developer test which ! may help to debug carbon imbalances ! and the like - + + + ! Size Dependent Senescence ! rate (r) and inflection point (ip) define the increase in mortality rate with dbh mort_r_size_senescence = EDPftvarcon_inst%mort_r_size_senescence(cohort_in%pft) @@ -104,9 +110,6 @@ subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort,smort,asmor end if ! if param values have been set then calculate asmort - - - mort_r_age_senescence = EDPftvarcon_inst%mort_r_age_senescence(cohort_in%pft) mort_ip_age_senescence = EDPftvarcon_inst%mort_ip_age_senescence(cohort_in%pft) @@ -120,77 +123,83 @@ subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort,smort,asmor asmort = 0.0_r8 end if + ! Damage dependent mortality + if (hlm_use_tree_damage .eq. itrue) then + call GetDamageMortality(cohort_in%crowndamage, cohort_in%pft, dgmort) + else + dgmort = 0.0_r8 + end if -if (hlm_use_ed_prescribed_phys .eq. ifalse) then + if (hlm_use_ed_prescribed_phys .eq. ifalse) then + + ! 'Background' mortality (can vary as a function of + ! density as in ED1.0 and ED2.0, but doesn't here for tractability) - ! 'Background' mortality (can vary as a function of - ! density as in ED1.0 and ED2.0, but doesn't here for tractability) - bmort = EDPftvarcon_inst%bmort(cohort_in%pft) - ! Proxy for hydraulic failure induced mortality. - hf_sm_threshold = EDPftvarcon_inst%hf_sm_threshold(cohort_in%pft) - hf_flc_threshold = EDPftvarcon_inst%hf_flc_threshold(cohort_in%pft) - if(hlm_use_planthydro.eq.itrue)then - !note the flc is set as the fraction of max conductivity in hydro - min_fmc_ag = minval(cohort_in%co_hydr%ftc_ag(:)) - min_fmc_tr = cohort_in%co_hydr%ftc_troot - min_fmc_ar = minval(cohort_in%co_hydr%ftc_aroot(:)) - min_fmc = min(min_fmc_ag, min_fmc_tr) - min_fmc = min(min_fmc, min_fmc_ar) - flc = 1.0_r8-min_fmc - if(flc >= hf_flc_threshold .and. hf_flc_threshold < 1.0_r8 )then - hmort = (flc-hf_flc_threshold)/(1.0_r8-hf_flc_threshold) * & - EDPftvarcon_inst%mort_scalar_hydrfailure(cohort_in%pft) - else - hmort = 0.0_r8 - endif - else - if(cohort_in%patchptr%btran_ft(cohort_in%pft) <= hf_sm_threshold)then - hmort = EDPftvarcon_inst%mort_scalar_hydrfailure(cohort_in%pft) - else - hmort = 0.0_r8 - endif - endif - - ! Carbon Starvation induced mortality. - if ( cohort_in%dbh > 0._r8 ) then + ! Proxy for hydraulic failure induced mortality. + hf_sm_threshold = EDPftvarcon_inst%hf_sm_threshold(cohort_in%pft) + hf_flc_threshold = EDPftvarcon_inst%hf_flc_threshold(cohort_in%pft) + if(hlm_use_planthydro.eq.itrue)then + !note the flc is set as the fraction of max conductivity in hydro + min_fmc_ag = minval(cohort_in%co_hydr%ftc_ag(:)) + min_fmc_tr = cohort_in%co_hydr%ftc_troot + min_fmc_ar = minval(cohort_in%co_hydr%ftc_aroot(:)) + min_fmc = min(min_fmc_ag, min_fmc_tr) + min_fmc = min(min_fmc, min_fmc_ar) + flc = 1.0_r8-min_fmc + if(flc >= hf_flc_threshold .and. hf_flc_threshold < 1.0_r8 )then + hmort = (flc-hf_flc_threshold)/(1.0_r8-hf_flc_threshold) * & + EDPftvarcon_inst%mort_scalar_hydrfailure(cohort_in%pft) + else + hmort = 0.0_r8 + endif + else + if(cohort_in%patchptr%btran_ft(cohort_in%pft) <= hf_sm_threshold)then + hmort = EDPftvarcon_inst%mort_scalar_hydrfailure(cohort_in%pft) + else + hmort = 0.0_r8 + endif + endif + + ! Carbon Starvation induced mortality. + if ( cohort_in%dbh > 0._r8 ) then + + call bleaf(cohort_in%dbh,cohort_in%pft,cohort_in%crowndamage,cohort_in%canopy_trim,target_leaf_c) + store_c = cohort_in%prt%GetState(store_organ,all_carbon_elements) - call bleaf(cohort_in%dbh,cohort_in%pft,cohort_in%canopy_trim,leaf_c_target) - store_c = cohort_in%prt%GetState(store_organ,all_carbon_elements) + call storage_fraction_of_target(target_leaf_c, store_c, frac) + if( frac .lt. 1._r8) then + cmort = max(0.0_r8,EDPftvarcon_inst%mort_scalar_cstarvation(cohort_in%pft) * & + (1.0_r8 - frac)) + else + cmort = 0.0_r8 + endif - call storage_fraction_of_target(leaf_c_target, store_c, frac) - if( frac .lt. 1._r8) then - cmort = max(0.0_r8,EDPftvarcon_inst%mort_scalar_cstarvation(cohort_in%pft) * & - (1.0_r8 - frac)) + else - cmort = 0.0_r8 + write(fates_log(),*) 'dbh problem in mortality_rates', & + cohort_in%dbh,cohort_in%pft,cohort_in%n,cohort_in%canopy_layer + call endrun(msg=errMsg(sourcefile, __LINE__)) endif - - else - write(fates_log(),*) 'dbh problem in mortality_rates', & - cohort_in%dbh,cohort_in%pft,cohort_in%n,cohort_in%canopy_layer - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - !-------------------------------------------------------------------------------- - ! Mortality due to cold and freezing stress (frmort), based on ED2 and: - ! Albani, M.; D. Medvigy; G. C. Hurtt; P. R. Moorcroft, 2006: The contributions - ! of land-use change, CO2 fertilization, and climate variability to the - ! Eastern US carbon sink. Glob. Change Biol., 12, 2370-2390, - ! doi: 10.1111/j.1365-2486.2006.01254.x + !-------------------------------------------------------------------------------- + ! Mortality due to cold and freezing stress (frmort), based on ED2 and: + ! Albani, M.; D. Medvigy; G. C. Hurtt; P. R. Moorcroft, 2006: The contributions + ! of land-use change, CO2 fertilization, and climate variability to the + ! Eastern US carbon sink. Glob. Change Biol., 12, 2370-2390, + ! doi: 10.1111/j.1365-2486.2006.01254.x temp_in_C = cohort_in%patchptr%tveg24%GetMean() - tfrz - temp_dep_fraction = max(0.0_r8, min(1.0_r8, 1.0_r8 - (temp_in_C - & - EDPftvarcon_inst%freezetol(cohort_in%pft))/frost_mort_buffer) ) - frmort = EDPftvarcon_inst%mort_scalar_coldstress(cohort_in%pft) * temp_dep_fraction + temp_dep_fraction = max(0.0_r8, min(1.0_r8, 1.0_r8 - (temp_in_C - & + EDPftvarcon_inst%freezetol(cohort_in%pft))/frost_mort_buffer) ) + frmort = EDPftvarcon_inst%mort_scalar_coldstress(cohort_in%pft) * temp_dep_fraction + !mortality_rates = bmort + hmort + cmort - !mortality_rates = bmort + hmort + cmort + else ! i.e. hlm_use_ed_prescribed_phys is true - else ! i.e. hlm_use_ed_prescribed_phys is true - if ( cohort_in%canopy_layer .eq. 1) then bmort = EDPftvarcon_inst%prescribed_mortality_canopy(cohort_in%pft) else @@ -208,8 +217,9 @@ subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort,smort,asmor bmort = 0.0_r8 smort = 0.0_r8 asmort = 0.0_r8 + dgmort = 0.0_r8 end if - + return end subroutine mortality_rates @@ -240,15 +250,17 @@ subroutine Mortality_Derivative( currentSite, currentCohort, bc_in, frac_site_pr real(r8) :: frmort ! freezing mortality rate (fraction per year) real(r8) :: smort ! size dependent senescence mortality rate (fraction per year) real(r8) :: asmort ! age dependent senescence mortality rate (fraction per year) + real(r8) :: dgmort ! damage mortality (fraction per year) real(r8) :: dndt_logging ! Mortality rate (per day) associated with the a logging event integer :: ipft ! local copy of the pft index - !---------------------------------------------------------------------- + + !---------------------------------------------------------------------- ipft = currentCohort%pft ! Mortality for trees in the understorey. !if trees are in the canopy, then their death is 'disturbance'. This probably needs a different terminology - call mortality_rates(currentCohort,bc_in,cmort,hmort,bmort,frmort,smort, asmort) + call mortality_rates(currentCohort,bc_in,cmort,hmort,bmort,frmort,smort, asmort, dgmort) call LoggingMortality_frac(ipft, currentCohort%dbh, currentCohort%canopy_layer, & currentCohort%lmort_direct, & currentCohort%lmort_collateral, & @@ -272,18 +284,17 @@ subroutine Mortality_Derivative( currentSite, currentCohort, bc_in, frac_site_pr currentCohort%dndt = -1.0_r8 * & - (cmort+hmort+bmort+frmort+smort+asmort + dndt_logging) & + (cmort+hmort+bmort+frmort+smort+asmort+dgmort + dndt_logging) & * currentCohort%n else ! Mortality from logging in the canopy is ONLY disturbance generating, don't ! update number densities via non-disturbance inducing death - ! for plants whose death is not considered disturbance (i.e. grasses), ! need to include all of their mortality here rather than part of it here ! and part in disturbance routine. - currentCohort%dndt= -(cmort+hmort+bmort+frmort+smort+asmort) * currentCohort%n + currentCohort%dndt= -(cmort+hmort+bmort+frmort+smort+asmort+dgmort) * currentCohort%n if ( .not. ExemptTreefallDist(currentCohort)) then currentCohort%dndt = (1.0_r8-fates_mortality_disturbance_fraction) * currentCohort%dndt endif diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index 141aaad52e..833ca3d07d 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -42,7 +42,6 @@ module EDPatchDynamicsMod use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_numSWb use FatesInterfaceTypesMod , only : bc_in_type - use FatesInterfaceTypesMod , only : hlm_days_per_year use FatesInterfaceTypesMod , only : numpft use FatesInterfaceTypesMod , only : hlm_stepsize use FatesInterfaceTypesMod , only : hlm_use_sp @@ -177,7 +176,8 @@ subroutine disturbance_rates( site_in, bc_in) real(r8) :: frmort real(r8) :: smort real(r8) :: asmort - + real(r8) :: dgmort + real(r8) :: lmort_direct real(r8) :: lmort_collateral real(r8) :: lmort_infra @@ -207,10 +207,10 @@ subroutine disturbance_rates( site_in, bc_in) ! Mortality for trees in the understorey. currentCohort%patchptr => currentPatch - call mortality_rates(currentCohort,bc_in,cmort,hmort,bmort,frmort,smort,asmort) - currentCohort%dmort = cmort+hmort+bmort+frmort+smort+asmort + call mortality_rates(currentCohort,bc_in,cmort,hmort,bmort,frmort,smort,asmort,dgmort) + currentCohort%dmort = cmort+hmort+bmort+frmort+smort+asmort+dgmort call carea_allom(currentCohort%dbh,currentCohort%n,site_in%spread,currentCohort%pft, & - currentCohort%c_area) + currentCohort%crowndamage,currentCohort%c_area) ! Initialize diagnostic mortality rates currentCohort%cmort = cmort @@ -219,7 +219,8 @@ subroutine disturbance_rates( site_in, bc_in) currentCohort%frmort = frmort currentCohort%smort = smort currentCohort%asmort = asmort - + currentCohort%dgmort = dgmort + call LoggingMortality_frac(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_layer, & lmort_direct,lmort_collateral,lmort_infra,l_degrad,& bc_in%hlm_harvest_rates, & @@ -476,6 +477,7 @@ subroutine spawn_patches( currentSite, bc_in) currentSite%disturbance_rates_secondary_to_secondary(i_disturbance_type) = & currentSite%disturbance_rates_secondary_to_secondary(i_disturbance_type) + & currentPatch%area * disturbance_rate * AREA_INV + else currentSite%disturbance_rates_primary_to_secondary(i_disturbance_type) = & currentSite%disturbance_rates_primary_to_secondary(i_disturbance_type) + & @@ -686,6 +688,7 @@ subroutine spawn_patches( currentSite, bc_in) nc%frmort = nan nc%smort = nan nc%asmort = nan + nc%dgmort = nan nc%lmort_direct = nan nc%lmort_collateral = nan nc%lmort_infra = nan @@ -741,6 +744,7 @@ subroutine spawn_patches( currentSite, bc_in) nc%frmort = currentCohort%frmort nc%smort = currentCohort%smort nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort nc%dmort = currentCohort%dmort nc%lmort_direct = currentCohort%lmort_direct nc%lmort_collateral = currentCohort%lmort_collateral @@ -767,6 +771,7 @@ subroutine spawn_patches( currentSite, bc_in) nc%frmort = currentCohort%frmort nc%smort = currentCohort%smort nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort nc%dmort = currentCohort%dmort nc%lmort_direct = currentCohort%lmort_direct nc%lmort_collateral = currentCohort%lmort_collateral @@ -826,6 +831,7 @@ subroutine spawn_patches( currentSite, bc_in) nc%frmort = currentCohort%frmort nc%smort = currentCohort%smort nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort nc%dmort = currentCohort%dmort nc%lmort_direct = currentCohort%lmort_direct nc%lmort_collateral = currentCohort%lmort_collateral @@ -901,6 +907,7 @@ subroutine spawn_patches( currentSite, bc_in) nc%frmort = currentCohort%frmort nc%smort = currentCohort%smort nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort nc%dmort = currentCohort%dmort ! since these are the ones that weren't logged, @@ -963,6 +970,7 @@ subroutine spawn_patches( currentSite, bc_in) nc%frmort = currentCohort%frmort nc%smort = currentCohort%smort nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort nc%dmort = currentCohort%dmort nc%lmort_direct = currentCohort%lmort_direct nc%lmort_collateral = currentCohort%lmort_collateral @@ -985,6 +993,7 @@ subroutine spawn_patches( currentSite, bc_in) nc%frmort = currentCohort%frmort nc%smort = currentCohort%smort nc%asmort = currentCohort%asmort + nc%dgmort = currentCohort%dgmort nc%dmort = currentCohort%dmort nc%lmort_direct = currentCohort%lmort_direct nc%lmort_collateral = currentCohort%lmort_collateral diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 95ea3f8cfb..d86a4fe2e6 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -13,12 +13,14 @@ module EDPhysiologyMod use FatesInterfaceTypesMod, only : hlm_day_of_year use FatesInterfaceTypesMod, only : numpft use FatesInterfaceTypesMod, only : nleafage + use FatesInterfaceTypesMod, only : nlevdamage use FatesInterfaceTypesMod, only : hlm_use_planthydro use FatesInterfaceTypesMod, only : hlm_parteh_mode use FatesInterfaceTypesMod, only : hlm_use_fixed_biogeog use FatesInterfaceTypesMod, only : hlm_use_nocomp use FatesInterfaceTypesMod, only : hlm_nitrogen_spec use FatesInterfaceTypesMod, only : hlm_phosphorus_spec + use FatesInterfaceTypesMod, only : hlm_use_tree_damage use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : nearzero use EDPftvarcon , only : EDPftvarcon_inst @@ -29,6 +31,8 @@ module EDPhysiologyMod use EDCohortDynamicsMod , only : zero_cohort use EDCohortDynamicsMod , only : create_cohort, sort_cohorts use EDCohortDynamicsMod , only : InitPRTObject + use EDCohortDynamicsMod , only : InitPRTBoundaryConditions + use EDCohortDynamicsMod , only : copy_cohort use FatesAllometryMod , only : tree_lai use FatesAllometryMod , only : tree_sai use FatesAllometryMod , only : leafc_from_treelai @@ -103,11 +107,19 @@ module EDPhysiologyMod use PRTGenericMod, only : repro_organ use PRTGenericMod, only : struct_organ use PRTGenericMod, only : SetState - use PRTLossFluxesMod, only : PRTPhenologyFlush - use PRTLossFluxesMod, only : PRTDeciduousTurnover - use PRTLossFluxesMod, only : PRTReproRelease - use PRTGenericMod, only : StorageNutrientTarget - + use PRTLossFluxesMod, only : PRTPhenologyFlush + use PRTLossFluxesMod, only : PRTDeciduousTurnover + use PRTLossFluxesMod, only : PRTReproRelease + use PRTLossFluxesMod, only : PRTDamageLosses + use PRTGenericMod, only : StorageNutrientTarget + use DamageMainMod, only : damage_time + use DamageMainMod, only : GetCrownReduction + use DamageMainMod, only : GetDamageFrac + use SFParamsMod, only : SF_val_CWD_frac + use FatesParameterDerivedMod, only : param_derived + use FatesPlantHydraulicsMod, only : InitHydrCohort + + implicit none private @@ -121,6 +133,7 @@ module EDPhysiologyMod public :: ZeroAllocationRates public :: PreDisturbanceLitterFluxes public :: PreDisturbanceIntegrateLitter + public :: GenerateDamageAndLitterFluxes public :: SeedIn logical, parameter :: debug = .false. ! local debug flag @@ -186,6 +199,175 @@ subroutine ZeroAllocationRates( currentSite ) return end subroutine ZeroAllocationRates + ! ============================================================================ + + subroutine GenerateDamageAndLitterFluxes( csite, cpatch, bc_in ) + + ! Arguments + type(ed_site_type) :: csite + type(ed_patch_type) :: cpatch + type(bc_in_type), intent(in) :: bc_in + + + ! Locals + type(ed_cohort_type), pointer :: ccohort ! Current cohort + type(ed_cohort_type), pointer :: ndcohort ! New damage-class cohort + type(litter_type), pointer :: litt ! Points to the litter object + type(site_fluxdiags_type), pointer :: flux_diags ! pointer to site level flux diagnostics object + integer :: cd ! Damage class index + integer :: el ! Element index + integer :: dcmpy ! Decomposition pool index + integer :: c ! CWD pool index + real(r8) :: cd_frac ! Fraction of trees damaged in this class transition + real(r8) :: num_trees_cd ! Number of trees to spawn into the new damage class cohort + real(r8) :: crown_loss_frac ! Fraction of crown lost from one damage class to next + real(r8) :: branch_loss_frac ! Fraction of sap, structure and storage lost in branch + ! fall during damage + real(r8) :: leaf_loss ! Mass lost to each organ during damage [kg] + real(r8) :: repro_loss ! "" [kg] + real(r8) :: sapw_loss ! "" [kg] + real(r8) :: store_loss ! "" [kg] + real(r8) :: struct_loss ! "" [kg] + real(r8) :: dcmpy_frac ! fraction of mass going to each decomposition pool + + + if(hlm_use_tree_damage .ne. itrue) return + + if(.not.damage_time) return + + ccohort => cpatch%tallest + do while (associated(ccohort)) + + ! Ignore damage to new plants and non-woody plants + if(prt_params%woody(ccohort%pft)==ifalse ) cycle + if(ccohort%isnew ) cycle + + associate( ipft => ccohort%pft, & + agb_frac => prt_params%allom_agb_frac(ccohort%pft), & + branch_frac => param_derived%branch_frac(ccohort%pft)) + + do_dclass: do cd = ccohort%crowndamage+1, nlevdamage + + call GetDamageFrac(ccohort%crowndamage, cd, ipft, cd_frac) + + ! now to get the number of damaged trees we multiply by damage frac + num_trees_cd = ccohort%n * cd_frac + + ! if non negligable lets create a new cohort and generate some litter + if_numtrees: if (num_trees_cd > nearzero ) then + + ! Create a new damaged cohort + allocate(ndcohort) ! new cohort surviving but damaged + if(hlm_use_planthydro.eq.itrue) call InitHydrCohort(csite,ndcohort) + + ! Initialize the PARTEH object and point to the + ! correct boundary condition fields + ndcohort%prt => null() + + call InitPRTObject(ndcohort%prt) + call InitPRTBoundaryConditions(ndcohort) + call zero_cohort(ndcohort) + + ! nc_canopy_d is the new cohort that gets damaged + call copy_cohort(ccohort, ndcohort) + + ! new number densities - we just do damaged cohort here - + ! undamaged at the end of the cohort loop once we know how many damaged to + ! subtract + + ndcohort%n = num_trees_cd + ndcohort%crowndamage = cd + + ! Remove these trees from the donor cohort + ccohort%n = ccohort%n - num_trees_cd + + ! update crown area here - for cohort fusion and canopy organisation below + call carea_allom(ndcohort%dbh, ndcohort%n, csite%spread, & + ipft, ndcohort%crowndamage, ndcohort%c_area) + + call GetCrownReduction(cd-ccohort%crowndamage, crown_loss_frac) + + do_element: do el = 1, num_elements + + litt => cpatch%litter(el) + flux_diags => csite%flux_diags(el) + + ! Reduce the mass of the newly damaged cohort + ! Fine-roots are not damaged as of yet + ! only above-ground sapwood,structure and storage in + ! branches is damaged/removed + branch_loss_frac = crown_loss_frac * branch_frac * agb_frac + + leaf_loss = ndcohort%prt%GetState(leaf_organ,element_list(el))*crown_loss_frac + repro_loss = ndcohort%prt%GetState(repro_organ,element_list(el))*crown_loss_frac + sapw_loss = ndcohort%prt%GetState(sapw_organ,element_list(el))*branch_loss_frac + store_loss = ndcohort%prt%GetState(store_organ,element_list(el))*branch_loss_frac + struct_loss = ndcohort%prt%GetState(struct_organ,element_list(el))*branch_loss_frac + + ! ------------------------------------------------------ + ! Transfer the biomass from the cohort's + ! damage to the litter input fluxes + ! ------------------------------------------------------ + + do dcmpy=1,ndcmpy + dcmpy_frac = GetDecompyFrac(ipft,leaf_organ,dcmpy) + litt%leaf_fines_in(dcmpy) = litt%leaf_fines_in(dcmpy) + & + (store_loss+leaf_loss+repro_loss) * & + ndcohort%n * dcmpy_frac / cpatch%area + end do + + flux_diags%leaf_litter_input(ipft) = & + flux_diags%leaf_litter_input(ipft) + & + (store_loss+leaf_loss+repro_loss) * ndcohort%n + + do c = 1,ncwd + litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + & + (sapw_loss + struct_loss) * & + SF_val_CWD_frac(c) * ndcohort%n / & + cpatch%area + + flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & + (struct_loss + sapw_loss) * & + SF_val_CWD_frac(c) * ndcohort%n + end do + + end do do_element + + ! Applying the damage to the cohort, does not need to happen + ! in the element loop, it will loop inside that call + call PRTDamageLosses(ndcohort%prt, leaf_organ, crown_loss_frac) + call PRTDamageLosses(ndcohort%prt, repro_organ, crown_loss_frac) + call PRTDamageLosses(ndcohort%prt, sapw_organ, branch_loss_frac) + call PRTDamageLosses(ndcohort%prt, store_organ, branch_loss_frac) + call PRTDamageLosses(ndcohort%prt, struct_organ, branch_loss_frac) + + + !----------- Insert new cohort into the linked list + ! This list is going tall to short, lets add this new + ! cohort into a taller position so we don't hit it again + ! as the loop traverses + ! --------------------------------------------------------------! + + ndcohort%shorter => ccohort + if(associated(ccohort%taller))then + ndcohort%taller => ccohort%taller + ccohort%taller%shorter => ndcohort + else + cpatch%tallest => ndcohort + ndcohort%taller => null() + endif + ccohort%taller => ndcohort + + end if if_numtrees + + end do do_dclass + + end associate + ccohort => ccohort%shorter + enddo + + return + end subroutine GenerateDamageAndLitterFluxes ! ============================================================================ @@ -426,6 +608,7 @@ subroutine trim_canopy( currentSite ) real(r8) :: initial_trim ! Initial trim real(r8) :: optimum_trim ! Optimum trim value + real(r8) :: target_c_area !---------------------------------------------------------------------- ipatch = 1 ! Start counting patches @@ -455,8 +638,10 @@ subroutine trim_canopy( currentSite ) trimmed = .false. ipft = currentCohort%pft - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread,currentCohort%pft,currentCohort%c_area) + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread,currentCohort%pft,& + currentCohort%crowndamage, currentCohort%c_area) + leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & @@ -464,10 +649,12 @@ subroutine trim_canopy( currentSite ) currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) ! We don't need check on sp mode here since we don't trim_canopy with sp mode - currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & - currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & + currentCohort%treesai = tree_sai(currentCohort%pft, & + currentCohort%dbh, currentCohort%crowndamage, & + 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 = count((currentCohort%treelai+currentCohort%treesai) .gt. dlower_vai(:)) + 1 @@ -478,7 +665,8 @@ subroutine trim_canopy( currentSite ) call endrun(msg=errMsg(sourcefile, __LINE__)) endif - call bleaf(currentcohort%dbh,ipft,currentcohort%canopy_trim,tar_bl) + call bleaf(currentcohort%dbh,ipft,& + currentCohort%crowndamage, currentcohort%canopy_trim,tar_bl) if ( int(prt_params%allom_fmode(ipft)) .eq. 1 ) then ! only query fine root biomass if using a fine root allometric model that takes leaf trim into account @@ -1108,10 +1296,12 @@ subroutine phenology_leafonoff(currentSite) currentCohort%status_coh = leaves_on ! Leaves are on, so change status to ! stop flow of carbon out of bstore. - call bleaf(currentCohort%dbh,currentCohort%pft,currentCohort%canopy_trim,target_leaf_c) - call bsap_allom(currentCohort%dbh,currentCohort%pft, & + call bleaf(currentCohort%dbh,currentCohort%pft,currentCohort%crowndamage, & + currentCohort%canopy_trim,target_leaf_c) + call bsap_allom(currentCohort%dbh,currentCohort%pft,currentCohort%crowndamage, & currentCohort%canopy_trim,sapw_area,target_sapw_c) - call bagw_allom(currentCohort%dbh,currentCohort%pft,target_agw_c) + call bagw_allom(currentCohort%dbh,currentCohort%pft,currentCohort%crowndamage,& + target_agw_c) call bbgw_allom(currentCohort%dbh,currentCohort%pft,target_bgw_c) call bdead_allom( target_agw_c, target_bgw_c, target_sapw_c, & currentCohort%pft, target_struct_c) @@ -1212,11 +1402,12 @@ subroutine phenology_leafonoff(currentSite) currentCohort%status_coh = leaves_on ! Leaves are on, so change status to ! stop flow of carbon out of bstore. - call bleaf(currentCohort%dbh,currentCohort%pft,& + call bleaf(currentCohort%dbh,currentCohort%pft,currentCohort%crowndamage,& currentCohort%canopy_trim,target_leaf_c) - call bsap_allom(currentCohort%dbh,currentCohort%pft, & + call bsap_allom(currentCohort%dbh,currentCohort%pft,currentCohort%crowndamage,& currentCohort%canopy_trim,sapw_area,target_sapw_c) - call bagw_allom(currentCohort%dbh,currentCohort%pft,target_agw_c) + call bagw_allom(currentCohort%dbh,currentCohort%pft,currentCohort%crowndamage,& + target_agw_c) call bbgw_allom(currentCohort%dbh,currentCohort%pft,target_bgw_c) call bdead_allom( target_agw_c, target_bgw_c, target_sapw_c, & currentCohort%pft, target_struct_c) @@ -1470,7 +1661,8 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l 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) + call carea_allom(currentCohort%dbh,dummy_n,spread,currentCohort%pft,& + currentCohort%crowndamage,currentCohort%c_area) !------------------------------------------ ! Calculate canopy N assuming patch area is full @@ -1478,7 +1670,8 @@ subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,l 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) + call carea_allom(currentCohort%dbh,currentCohort%n,spread,currentCohort%pft,& + currentCohort%crowndamage,currentCohort%c_area) ! ------------------------------------------ ! Calculate leaf carbon from target treelai @@ -1782,6 +1975,8 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) ! ! !USES: use FatesInterfaceTypesMod, only : hlm_use_ed_prescribed_phys + use FatesLitterMod , only : ncwd + ! ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite @@ -1791,6 +1986,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) ! !LOCAL VARIABLES: class(prt_vartypes), pointer :: prt integer :: ft + integer :: c type (ed_cohort_type) , pointer :: temp_cohort type (litter_type), pointer :: litt ! The litter object (carbon right now) type(site_massbal_type), pointer :: site_mass ! For accounting total in-out mass fluxes @@ -1798,6 +1994,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) integer :: el ! loop counter for element integer :: element_id ! element index consistent with definitions in PRTGenericMod integer :: iage ! age loop counter for leaf age bins + integer :: crowndamage integer,parameter :: recruitstatus = 1 !weather it the new created cohorts is recruited or initialized real(r8) :: c_leaf ! target leaf biomass [kgC] real(r8) :: c_fnrt ! target fine root biomass [kgC] @@ -1841,17 +2038,22 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) temp_cohort%hite = EDPftvarcon_inst%hgt_min(ft) temp_cohort%coage = 0.0_r8 stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(ft) - + temp_cohort%crowndamage = 1 ! new recruits are undamaged + 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 bleaf(temp_cohort%dbh,ft,temp_cohort%crowndamage,& + 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 bsap_allom(temp_cohort%dbh,ft,temp_cohort%crowndamage, & + temp_cohort%canopy_trim,a_sapw, c_sapw) + call bagw_allom(temp_cohort%dbh,ft,temp_cohort%crowndamage, 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) + call bstore_allom(temp_cohort%dbh,ft, temp_cohort%crowndamage, & + temp_cohort%canopy_trim,c_store) ! Default assumption is that leaves are on cohortstatus = leaves_on @@ -2057,11 +2259,14 @@ 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, & cohortstatus, recruitstatus, & temp_cohort%canopy_trim,temp_cohort%c_area, & - currentPatch%NCL_p, currentSite%spread, bc_in) + currentPatch%NCL_p, & + temp_cohort%crowndamage, & + currentSite%spread, bc_in) ! Note that if hydraulics is on, the number of cohorts may had ! changed due to hydraulic constraints. @@ -2092,7 +2297,6 @@ subroutine CWDInput( currentSite, currentPatch, litt, bc_in) ! and turnover in dying trees. ! ! !USES: - use SFParamsMod , only : SF_val_CWD_frac ! ! !ARGUMENTS diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index c678fb0dab..43497b5b44 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -98,7 +98,7 @@ module FatesAllometryMod use FatesGlobals , only : FatesWarn,N2S,A2S,I2S use EDTypesMod , only : nlevleaf, dinc_vai use EDTypesMod , only : nclmax - + use DamageMainMod , only : GetCrownReduction implicit none @@ -160,8 +160,8 @@ module FatesAllometryMod ! ============================================================================ - subroutine CheckIntegratedAllometries(dbh,ipft,canopy_trim, & - bl,bfr,bsap,bstore,bdead, & + subroutine CheckIntegratedAllometries(dbh,ipft,crowndamage, & + canopy_trim, bl,bfr,bsap,bstore,bdead, & grow_leaf, grow_fr, grow_sap, grow_store, grow_dead, & max_err, l_pass) @@ -175,6 +175,7 @@ subroutine CheckIntegratedAllometries(dbh,ipft,canopy_trim, & real(r8),intent(in) :: dbh ! diameter of plant [cm] integer,intent(in) :: ipft ! plant functional type index + integer,intent(in) :: crowndamage ! crowndamage [1: undamaged, >1 damaged] real(r8),intent(in) :: canopy_trim ! trimming function real(r8),intent(in) :: bl ! integrated leaf biomass [kgC] real(r8),intent(in) :: bfr ! integrated fine root biomass [kgC] @@ -205,7 +206,7 @@ subroutine CheckIntegratedAllometries(dbh,ipft,canopy_trim, & l_pass = .true. ! Default assumption is that step passed if (grow_leaf) then - call bleaf(dbh,ipft,canopy_trim,bl_diag) + call bleaf(dbh,ipft,crowndamage, canopy_trim,bl_diag) if( abs(bl_diag-bl) > max_err ) then if(verbose_logging) then write(fates_log(),*) 'disparity in integrated/diagnosed leaf carbon' @@ -233,7 +234,7 @@ subroutine CheckIntegratedAllometries(dbh,ipft,canopy_trim, & end if if (grow_sap) then - call bsap_allom(dbh,ipft,canopy_trim,asap_diag,bsap_diag) + call bsap_allom(dbh,ipft,crowndamage, canopy_trim,asap_diag,bsap_diag) if( abs(bsap_diag-bsap) > max_err ) then if(verbose_logging) then write(fates_log(),*) 'disparity in integrated/diagnosed sapwood carbon' @@ -247,7 +248,7 @@ subroutine CheckIntegratedAllometries(dbh,ipft,canopy_trim, & end if if (grow_store) then - call bstore_allom(dbh,ipft,canopy_trim,bstore_diag) + call bstore_allom(dbh,ipft,crowndamage, canopy_trim,bstore_diag) if( abs(bstore_diag-bstore) > max_err ) then if(verbose_logging) then write(fates_log(),*) 'disparity in integrated/diagnosed storage carbon' @@ -261,8 +262,8 @@ subroutine CheckIntegratedAllometries(dbh,ipft,canopy_trim, & end if if (grow_dead) then - call bsap_allom(dbh,ipft,canopy_trim,asap_diag,bsap_diag) - call bagw_allom(dbh,ipft,bagw_diag) + call bsap_allom(dbh,ipft,crowndamage, canopy_trim,asap_diag,bsap_diag) + call bagw_allom(dbh,ipft,crowndamage, bagw_diag) call bbgw_allom(dbh,ipft,bbgw_diag) call bdead_allom( bagw_diag, bbgw_diag, bsap_diag, ipft, bdead_diag ) if( abs(bdead_diag-bdead) > max_err ) then @@ -362,17 +363,22 @@ end subroutine h_allom ! Generic AGB interface ! ============================================================================ - subroutine bagw_allom(d,ipft,bagw,dbagwdd) - + subroutine bagw_allom(d,ipft,crowndamage, bagw,dbagwdd) + use DamageMainMod, only : GetCrownReduction + use FatesParameterDerivedMod, only : param_derived + real(r8),intent(in) :: d ! plant diameter [cm] integer(i4),intent(in) :: ipft ! PFT index + integer(i4),intent(in) :: crowndamage ! crowndamage [1: undamaged, >1: damaged] real(r8),intent(out) :: bagw ! biomass above ground woody tissues real(r8),intent(out),optional :: dbagwdd ! change in agbw per diameter [kgC/cm] real(r8) :: h ! height real(r8) :: dhdd ! change in height wrt d - + real(r8) :: crown_reduction ! crown reduction from damage + real(r8) :: branch_frac ! fraction of aboveground woody biomass in branches + associate( p1 => prt_params%allom_agb1(ipft), & p2 => prt_params%allom_agb2(ipft), & p3 => prt_params%allom_agb3(ipft), & @@ -381,6 +387,8 @@ subroutine bagw_allom(d,ipft,bagw,dbagwdd) c2b => prt_params%c2b(ipft), & agb_frac => prt_params%allom_agb_frac(ipft), & allom_amode => prt_params%allom_amode(ipft)) + + branch_frac = param_derived%branch_frac(ipft) select case(int(allom_amode)) case (1) !"salda") @@ -398,6 +406,15 @@ subroutine bagw_allom(d,ipft,bagw,dbagwdd) call endrun(msg=errMsg(sourcefile, __LINE__)) end select + if(crowndamage > 1) then + call GetCrownReduction(crowndamage, crown_reduction) + bagw = bagw - (bagw * branch_frac * crown_reduction) + if(present(dbagwdd))then + dbagwdd = dbagwdd - (dbagwdd * branch_frac * crown_reduction) + end if + end if + + end associate return end subroutine bagw_allom @@ -442,12 +459,13 @@ end subroutine blmax_allom ! Generic crown area allometry wrapper ! ============================================================================ - subroutine carea_allom(dbh,nplant,site_spread,ipft,c_area,inverse) + subroutine carea_allom(dbh,nplant,site_spread,ipft,crowndamage,c_area,inverse) real(r8),intent(inout) :: dbh ! plant diameter at breast (reference) height [cm] real(r8),intent(in) :: site_spread ! site level spread factor (crowdedness) real(r8),intent(in) :: nplant ! number of plants [1/ha] integer(i4),intent(in) :: ipft ! PFT index + integer(i4),intent(in) :: crowndamage ! crown damage class [1: undamaged, >1: damaged] real(r8),intent(inout) :: c_area ! crown area per cohort (m2) logical,optional,intent(in) :: inverse ! if true, calculate dbh from crown area ! instead of crown area from dbh @@ -478,14 +496,17 @@ subroutine carea_allom(dbh,nplant,site_spread,ipft,c_area,inverse) select case(int(allom_lmode)) case(1) dbh_eff = min(dbh,dbh_maxh) - call carea_2pwr(dbh_eff,site_spread,d2bl_p2,d2bl_ediff,d2ca_min,d2ca_max,c_area,do_inverse) + call carea_2pwr(dbh_eff,site_spread,d2bl_p2,d2bl_ediff,d2ca_min,d2ca_max, & + crowndamage,c_area, do_inverse) capped_allom = .true. case(2) ! "2par_pwr") - call carea_2pwr(dbh,site_spread,d2bl_p2,d2bl_ediff,d2ca_min,d2ca_max,c_area,do_inverse) + call carea_2pwr(dbh,site_spread,d2bl_p2,d2bl_ediff,d2ca_min,d2ca_max, & + crowndamage, c_area, do_inverse) capped_allom = .false. case(3) dbh_eff = min(dbh,dbh_maxh) - call carea_2pwr(dbh_eff,site_spread,d2bl_p2,d2bl_ediff,d2ca_min,d2ca_max,c_area,do_inverse) + call carea_2pwr(dbh_eff,site_spread,d2bl_p2,d2bl_ediff,d2ca_min,d2ca_max, & + crowndamage, c_area, do_inverse) capped_allom = .true. case DEFAULT write(fates_log(),*) 'An undefined leaf allometry was specified: ', & @@ -516,7 +537,7 @@ end subroutine carea_allom ! ===================================================================================== - subroutine bleaf(d,ipft,canopy_trim,bl,dbldd) + subroutine bleaf(d,ipft,crowndamage,canopy_trim,bl,dbldd) ! ------------------------------------------------------------------------- ! This subroutine calculates the actual target bleaf @@ -524,15 +545,19 @@ subroutine bleaf(d,ipft,canopy_trim,bl,dbldd) ! is not allometry and rather an emergent property, ! this routine is not name-spaced with allom_ ! ------------------------------------------------------------------------- + + use DamageMainMod , only : GetCrownReduction real(r8),intent(in) :: d ! plant diameter [cm] integer(i4),intent(in) :: ipft ! PFT index + integer(i4),intent(in) :: crowndamage ! crown damage class [1: undamaged, >1: damaged] real(r8),intent(in) :: canopy_trim ! trimming function real(r8),intent(out) :: bl ! plant leaf biomass [kg] real(r8),intent(out),optional :: dbldd ! change leaf bio per diameter [kgC/cm] real(r8) :: blmax real(r8) :: dblmaxdd + real(r8) :: crown_reduction call blmax_allom(d,ipft,blmax,dblmaxdd) @@ -544,10 +569,19 @@ subroutine bleaf(d,ipft,canopy_trim,bl,dbldd) ! ------------------------------------------------------------------------- bl = blmax * canopy_trim - + if(present(dbldd))then dbldd = dblmaxdd * canopy_trim end if + + if ( crowndamage > 1 ) then + + call GetCrownReduction(crowndamage, crown_reduction) + bl = bl * (1.0_r8 - crown_reduction) + if(present(dbldd))then + dbldd = dblmaxdd * canopy_trim * (1.0_r8 - crown_reduction) + end if + end if return end subroutine bleaf @@ -705,15 +739,16 @@ end function tree_lai ! ============================================================================ - real(r8) function tree_sai( pft, dbh, canopy_trim, c_area, nplant, cl, & + real(r8) function tree_sai(pft, dbh, crowndamage, canopy_trim, c_area, nplant, cl, & canopy_lai, treelai, vcmax25top, call_id ) ! ============================================================================ ! SAI of individual trees is a function of the LAI of individual trees ! ============================================================================ - integer, intent(in) :: pft - real(r8), intent(in) :: dbh + integer, intent(in) :: pft + real(r8), intent(in) :: dbh + integer, intent(in) :: crowndamage real(r8), intent(in) :: canopy_trim ! trimming function (0-1) real(r8), intent(in) :: c_area ! crown area (m2) real(r8), intent(in) :: nplant ! number of plants @@ -725,12 +760,13 @@ real(r8) function tree_sai( pft, dbh, canopy_trim, c_area, nplant, cl, & integer,intent(in) :: call_id ! flag specifying where this is called ! from real(r8) :: h - real(r8) :: target_bleaf real(r8) :: target_lai + real(r8) :: target_bleaf - call bleaf(dbh,pft,canopy_trim,target_bleaf) - - target_lai = tree_lai( target_bleaf, pft, c_area, nplant, cl, canopy_lai, vcmax25top) + call bleaf(dbh, pft, crowndamage, canopy_trim, target_bleaf) + + target_lai = tree_lai(target_bleaf, pft, c_area, nplant, cl,& + canopy_lai, vcmax25top) tree_sai = prt_params%allom_sai_scaler(pft) * target_lai @@ -741,18 +777,18 @@ real(r8) function tree_sai( pft, dbh, canopy_trim, c_area, nplant, cl, & write(fates_log(),*) 'The leaf and stem are predicted for a cohort, maxed out the array size' write(fates_log(),*) 'lai: ',treelai write(fates_log(),*) 'sai: ',tree_sai - write(fates_log(),*) 'target_lai: ',target_lai write(fates_log(),*) 'lai+sai: ',treelai+tree_sai + write(fates_log(),*) 'target_bleaf: ', target_bleaf + write(fates_log(),*) 'area: ', c_area + write(fates_log(),*) 'target_lai: ',target_lai write(fates_log(),*) 'dinc_vai:',dinc_vai write(fates_log(),*) 'nlevleaf,sum(dinc_vai):',nlevleaf,sum(dinc_vai) write(fates_log(),*) 'pft: ',pft write(fates_log(),*) 'call id: ',call_id write(fates_log(),*) 'n: ',nplant - write(fates_log(),*) 'c_area: ',c_area write(fates_log(),*) 'dbh: ',dbh,' dbh_max: ',prt_params%allom_dbh_maxheight(pft) write(fates_log(),*) 'h: ',h write(fates_log(),*) 'canopy_trim: ',canopy_trim - write(fates_log(),*) 'target_bleaf: ',target_bleaf write(fates_log(),*) 'canopy layer: ',cl write(fates_log(),*) 'canopy_tlai: ',canopy_lai(:) write(fates_log(),*) 'vcmax25top: ',vcmax25top @@ -857,10 +893,14 @@ end function leafc_from_treelai ! Generic sapwood biomass interface ! ============================================================================ - subroutine bsap_allom(d,ipft,canopy_trim,sapw_area,bsap,dbsapdd) + subroutine bsap_allom(d,ipft,crowndamage,canopy_trim,sapw_area,bsap,dbsapdd) + + use DamageMainMod , only : GetCrownReduction + use FatesParameterDerivedMod, only : param_derived real(r8),intent(in) :: d ! plant diameter [cm] integer(i4),intent(in) :: ipft ! PFT index + integer(i4),intent(in) :: crowndamage ! Crown damage class [1: undamaged, >1: damaged] real(r8),intent(in) :: canopy_trim real(r8),intent(out) :: sapw_area ! cross section area of ! plant sapwood at reference [m2] @@ -880,10 +920,18 @@ subroutine bsap_allom(d,ipft,canopy_trim,sapw_area,bsap,dbsapdd) ! than some specified proportion of woody biomass ! should not trip, and only in small plants + real(r8) :: crown_reduction ! amount that crown is damage by + real(r8) :: agb_frac ! aboveground biomass fraction + real(r8) :: branch_frac ! fraction of aboveground woody biomass in branches + ! Constrain sapwood so that its above ground portion be no larger than ! X% of total woody/fibrous (ie non leaf/fineroot) tissues real(r8),parameter :: max_frac = 0.95_r8 + agb_frac = prt_params%allom_agb_frac(ipft) + branch_frac = param_derived%branch_frac(ipft) + + select case(int(prt_params%allom_smode(ipft))) ! --------------------------------------------------------------------- ! Currently only one sapwood allometry model. the slope @@ -893,11 +941,23 @@ subroutine bsap_allom(d,ipft,canopy_trim,sapw_area,bsap,dbsapdd) ! and slatop (no provisions for slamax) call h_allom(d,ipft,h,dhdd) - call bleaf(d,ipft,canopy_trim,bl,dbldd) + call bleaf(d,ipft,1,canopy_trim,bl,dbldd) call bsap_ltarg_slatop(d,h,dhdd,bl,dbldd,ipft,sapw_area,bsap,dbsapdd) + ! if trees are damaged reduce bsap by percent crown loss * + ! fraction of biomass that would be in branches (pft specific) + if(crowndamage > 1)then + + call GetCrownReduction(crowndamage, crown_reduction) + bsap = bsap - (bsap * agb_frac * branch_frac * crown_reduction) + if(present(dbsapdd))then + dbsapdd = dbsapdd - (dbsapdd * agb_frac * branch_frac * crown_reduction) + end if + end if + + ! Perform a capping/check on total woody biomass - call bagw_allom(d,ipft,bagw,dbagwdd) + call bagw_allom(d,ipft,crowndamage, bagw,dbagwdd) call bbgw_allom(d,ipft,bbgw,dbbgwdd) ! Force sapwood to be less than a maximum fraction of total biomass @@ -939,7 +999,8 @@ subroutine bbgw_allom(d,ipft,bbgw,dbbgwdd) select case(int(prt_params%allom_cmode(ipft))) case(1) !"constant") - call bagw_allom(d,ipft,bagw,dbagwdd) + ! bbgw not affected by damage so use target allometry no damage + call bagw_allom(d,ipft,1, bagw,dbagwdd) call bbgw_const(d,bagw,dbagwdd,ipft,bbgw,dbbgwdd) case DEFAULT write(fates_log(),*) 'An undefined coarse root allometry was specified: ', & @@ -1006,10 +1067,11 @@ end subroutine bfineroot ! Storage biomass interface ! ============================================================================ - subroutine bstore_allom(d,ipft,canopy_trim,bstore,dbstoredd) + subroutine bstore_allom(d,ipft,crowndamage, canopy_trim,bstore,dbstoredd) real(r8),intent(in) :: d ! plant diameter [cm] integer(i4),intent(in) :: ipft ! PFT index + integer(i4),intent(in) :: crowndamage ! Crowndamage class [1: undamaged, >1: damaged] real(r8),intent(in) :: canopy_trim ! Crown trimming function [0-1] real(r8),intent(out) :: bstore ! allometric target storage [kgC] real(r8),intent(out),optional :: dbstoredd ! change storage per cm [kgC/cm] @@ -1027,7 +1089,7 @@ subroutine bstore_allom(d,ipft,canopy_trim,bstore,dbstoredd) case(1) ! Storage is constant proportionality of trimmed maximum leaf ! biomass (ie cushion * bleaf) - call bleaf(d,ipft,canopy_trim,bl,dbldd) + call bleaf(d,ipft, crowndamage, canopy_trim, bl, dbldd) call bstore_blcushion(d,bl,dbldd,cushion,ipft,bstore,dbstoredd) case DEFAULT @@ -2021,7 +2083,8 @@ end subroutine CrownDepth ! ============================================================================= - subroutine carea_2pwr(dbh,spread,d2bl_p2,d2bl_ediff,d2ca_min,d2ca_max,c_area,inverse) + subroutine carea_2pwr(dbh,spread,d2bl_p2,d2bl_ediff,d2ca_min, & + d2ca_max,crowndamage,c_area,inverse) ! ============================================================================ ! Calculate area of ground covered by entire cohort. (m2) @@ -2034,11 +2097,13 @@ subroutine carea_2pwr(dbh,spread,d2bl_p2,d2bl_ediff,d2ca_min,d2ca_max,c_area,inv real(r8),intent(in) :: d2bl_ediff ! area difference factor in the diameter-bleaf allometry (exponent) real(r8),intent(in) :: d2ca_min ! minimum diameter to crown area scaling factor real(r8),intent(in) :: d2ca_max ! maximum diameter to crown area scaling factor + integer,intent(in) :: crowndamage ! crowndamage class [1: undamaged, >1: damaged] real(r8),intent(inout) :: c_area ! crown area for one plant [m2] logical,intent(in) :: inverse ! if true, calculate dbh from crown area rather than its reverse real(r8) :: crown_area_to_dbh_exponent real(r8) :: spreadterm ! Effective 2bh to crown area scaling factor + real(r8) :: crown_reduction ! default is to use the same exponent as the dbh to bleaf exponent so that per-plant ! canopy depth remains invariant during growth, but allowed to vary via the @@ -2061,7 +2126,17 @@ subroutine carea_2pwr(dbh,spread,d2bl_p2,d2bl_ediff,d2ca_min,d2ca_max,c_area,inv if ( .not. inverse) then c_area = spreadterm * dbh ** crown_area_to_dbh_exponent + + if(crowndamage > 1) then + call GetCrownReduction(crowndamage, crown_reduction) + c_area = c_area * (1.0_r8 - crown_reduction) + end if + else + if(crowndamage > 1) then + call GetCrownReduction(crowndamage, crown_reduction) + c_area = c_area/(1.0_r8 - crown_reduction) + end if dbh = (c_area / spreadterm) ** (1./crown_area_to_dbh_exponent) endif @@ -2329,9 +2404,7 @@ real(r8) function decay_coeff_kn(pft,vcmax25top) end function decay_coeff_kn ! ===================================================================================== - - - subroutine ForceDBH( ipft, canopy_trim, d, h, bdead, bl ) +subroutine ForceDBH( ipft, crowndamage, canopy_trim, d, h, bdead, bl ) ! ========================================================================= ! This subroutine estimates the diameter based on either the structural biomass @@ -2341,18 +2414,18 @@ subroutine ForceDBH( ipft, canopy_trim, d, h, bdead, bl ) ! Here, we keep searching until the difference between actual structure and ! the predicted structure based on the searched diameter is within a tolerance. ! ============================================================================ - - use FatesConstantsMod , only : calloc_abs_error + use FatesConstantsMod , only : calloc_abs_error ! Arguments integer(i4),intent(in) :: ipft ! PFT index + integer(i4),intent(in) :: crowndamage ! crowndamage [1: undamaged, >1: damaged] real(r8),intent(in) :: canopy_trim real(r8),intent(inout) :: d ! plant diameter [cm] real(r8),intent(out) :: h ! plant height real(r8),intent(in),optional :: bdead ! Structural biomass real(r8),intent(in),optional :: bl ! Leaf biomass - + ! Locals real(r8) :: bt_sap,dbt_sap_dd ! target sap wood at current d @@ -2371,6 +2444,7 @@ subroutine ForceDBH( ipft, canopy_trim, d, h, bdead, bl ) integer :: counter real(r8), parameter :: step_frac0 = 0.9_r8 integer, parameter :: max_counter = 200 + ! Do reduce "if" calls, we break this call into two parts if ( prt_params%woody(ipft) == itrue ) then @@ -2380,9 +2454,10 @@ subroutine ForceDBH( ipft, canopy_trim, d, h, bdead, bl ) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - call bsap_allom(d,ipft,canopy_trim,at_sap,bt_sap,dbt_sap_dd) - call bagw_allom(d,ipft,bt_agw,dbt_agw_dd) + call bsap_allom(d,ipft,crowndamage, canopy_trim,at_sap,bt_sap,dbt_sap_dd) + call bagw_allom(d,ipft,crowndamage, bt_agw,dbt_agw_dd) call bbgw_allom(d,ipft,bt_bgw,dbt_bgw_dd) + call bdead_allom(bt_agw,bt_bgw, bt_sap, ipft, bt_dead, dbt_agw_dd, & dbt_bgw_dd, dbt_sap_dd, dbt_dead_dd) @@ -2397,13 +2472,15 @@ subroutine ForceDBH( ipft, canopy_trim, d, h, bdead, bl ) dd = step_frac*(bdead-bt_dead)/dbt_dead_dd d_try = d + dd - call bsap_allom(d_try,ipft,canopy_trim,at_sap,bt_sap,dbt_sap_dd) - call bagw_allom(d_try,ipft,bt_agw,dbt_agw_dd) - call bbgw_allom(d_try,ipft,bt_bgw,dbt_bgw_dd) + call bsap_allom(d_try,ipft,crowndamage, canopy_trim,at_sap,bt_sap,dbt_sap_dd) + call bagw_allom(d_try,ipft,crowndamage, bt_agw,dbt_agw_dd) + call bbgw_allom(d_try,ipft, bt_bgw,dbt_bgw_dd) + + call bdead_allom(bt_agw,bt_bgw, bt_sap, ipft, bt_dead_try, dbt_agw_dd, & dbt_bgw_dd, dbt_sap_dd, dbt_dead_dd_try) - ! Prevent overshooting + ! Prevent overshooting if(bt_dead_try > (bdead+calloc_abs_error)) then step_frac = step_frac*0.5_r8 else @@ -2427,7 +2504,7 @@ subroutine ForceDBH( ipft, canopy_trim, d, h, bdead, bl ) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - call bleaf(d,ipft,canopy_trim,bt_leaf,dbt_leaf_dd) + call bleaf(d,ipft,crowndamage,canopy_trim,bt_leaf,dbt_leaf_dd) counter = 0 step_frac = step_frac0 @@ -2436,7 +2513,7 @@ subroutine ForceDBH( ipft, canopy_trim, d, h, bdead, bl ) dd = step_frac*(bl-bt_leaf)/dbt_leaf_dd d_try = d + dd - call bleaf(d_try,ipft,canopy_trim,bt_leaf_try,dbt_leaf_dd_try) + call bleaf(d_try,ipft,crowndamage,canopy_trim,bt_leaf_try,dbt_leaf_dd_try) ! Prevent overshooting if(bt_leaf_try > (bl+calloc_abs_error)) then @@ -2515,4 +2592,6 @@ subroutine cspline(x1,x2,y1,y2,dydx1,dydx2,x,y,dydx) return end subroutine cspline + + end module FatesAllometryMod diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index 04c30a2c9d..60af4e8f1a 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -1283,7 +1283,6 @@ function ECACScalar(ccohort, element_id) result(c_scalar) 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 @@ -1326,7 +1325,7 @@ function ECACScalar(ccohort, element_id) result(c_scalar) else store_c = ccohort%prt%GetState(store_organ, carbon12_element) - call bstore_allom(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,store_c_max) + call bstore_allom(ccohort%dbh,ccohort%pft,ccohort%crowndamage, 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 diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 2225022e9f..23f488aa6c 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -979,7 +979,8 @@ subroutine UpdatePlantHydrLenVol(ccohort,csite_hydr) ! Get the target, or rather, maximum leaf carrying capacity of plant ! Lets also avoid super-low targets that have very low trimming functions - call bleaf(ccohort%dbh,ccohort%pft,max(ccohort%canopy_trim,min_trim),leaf_c_target) + call bleaf(ccohort%dbh,ccohort%pft,ccohort%crowndamage, & + max(ccohort%canopy_trim,min_trim),leaf_c_target) if( (ccohort%status_coh == leaves_on) .or. ccohort_hydr%is_newly_recruited ) then ccohort_hydr%v_ag(1:n_hypool_leaf) = max(leaf_c,min_leaf_frac*leaf_c_target) * & @@ -994,7 +995,8 @@ subroutine UpdatePlantHydrLenVol(ccohort,csite_hydr) ! v_stem = c_stem_biom / (prt_params%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) + call bsap_allom(ccohort%dbh,ccohort%pft,ccohort%crowndamage, & + ccohort%canopy_trim,a_sapwood_target,sapw_c_target) ! uncomment this if you want to use ! the actual sapwood, which may be lower than target due to branchfall. @@ -2972,7 +2974,8 @@ subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr) 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) + call bsap_allom(ccohort%dbh,pft,ccohort%crowndamage, & + ccohort%canopy_trim,a_sapwood,c_sap_dummy) ! Leaf Maximum Hydraulic Conductance ! The starting hypothesis is that there is no resistance inside the diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 23722bab33..4b8d34f664 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -136,6 +136,10 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use FatesAllometryMod, only : set_root_fraction use FatesAllometryMod, only : decay_coeff_kn + use DamageMainMod, only : GetCrownReduction + + use FatesInterfaceTypesMod, only : hlm_use_tree_damage + ! ARGUMENTS: ! ----------------------------------------------------------------------------------- integer,intent(in) :: nsites @@ -241,6 +245,17 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) 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 + real(r8) :: agb_frac ! fraction of biomass aboveground + real(r8) :: branch_frac ! fraction of aboveground woody biomass in branches + real(r8) :: crown_reduction ! reduction in crown biomass from damage + real(r8) :: sapw_c_bgw ! belowground sapwood + real(r8) :: sapw_c_agw ! aboveground sapwood + real(r8) :: sapw_c_undamaged ! the target sapwood of an undamaged tree + real(r8) :: sapw_n ! sapwood nitrogen + real(r8) :: sapw_n_bgw ! nitrogen in belowground portion of sapwood + real(r8) :: sapw_n_agw ! nitrogen in aboveground portion of sapwood + real(r8) :: sapw_n_undamaged ! nitrogen in sapwood of undamaged tree + ! ----------------------------------------------------------------------------------- ! Keeping these two definitions in case they need to be added later ! @@ -269,6 +284,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! Photosynthesis and stomatal conductance parameters, from: ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 ! ----------------------------------------------------------------------------------- + + associate( & c3psn => EDPftvarcon_inst%c3psn , & @@ -387,7 +404,8 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ft = currentCohort%pft cl = currentCohort%canopy_layer - call bleaf(currentCohort%dbh,currentCohort%pft,currentCohort%canopy_trim,store_c_target) + call bleaf(currentCohort%dbh,currentCohort%pft,& + currentCohort%crowndamage,currentCohort%canopy_trim,store_c_target) ! call bstore_allom(currentCohort%dbh,currentCohort%pft, & ! currentCohort%canopy_trim,store_c_target) @@ -640,17 +658,39 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) sapw_c = currentCohort%prt%GetState(sapw_organ, all_carbon_elements) fnrt_c = currentCohort%prt%GetState(fnrt_organ, all_carbon_elements) - + + + if (hlm_use_tree_damage .eq. itrue) then + + ! Crown damage currenly only reduces the aboveground portion of + ! sapwood. Therefore we calculate the aboveground and the belowground portion + ! sapwood for use in stem respiration. + call GetCrownReduction(currentCohort%crowndamage, crown_reduction) + + else + crown_reduction = 0.0_r8 + end if + + ! If crown reduction is zero, undamaged sapwood target will equal sapwood carbon + agb_frac = prt_params%allom_agb_frac(currentCohort%pft) + branch_frac = param_derived%branch_frac(currentCohort%pft) + sapw_c_undamaged = sapw_c / (1.0_r8 - (agb_frac * branch_frac * crown_reduction)) + + ! Undamaged below ground portion + sapw_c_bgw = sapw_c_undamaged * (1.0_r8 - agb_frac) + + ! Damaged aboveground portion + sapw_c_agw = sapw_c - sapw_c_bgw + + 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,prt_params%organ_param_id(sapw_organ)) + live_stem_n = sapw_c_agw * 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,prt_params%organ_param_id(sapw_organ)) + live_croot_n = sapw_c_bgw * 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)) + fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(fnrt_organ)) case(prt_cnp_flex_allom_hyp) @@ -660,16 +700,33 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) 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 (hlm_use_tree_damage .eq. itrue) then + + sapw_n = currentCohort%prt%GetState(sapw_organ, nitrogen_element) + + sapw_n_undamaged = sapw_n / & + (1.0_r8 - (agb_frac * branch_frac * crown_reduction)) + + sapw_n_bgw = sapw_n_undamaged * (1.0_r8 - agb_frac) + sapw_n_agw = sapw_n - sapw_n_bgw + + live_croot_n = sapw_n_bgw + + live_stem_n = sapw_n_agw + + end if + ! 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,prt_params%organ_param_id(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,prt_params%organ_param_id(sapw_organ)) - ! fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(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/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 7f2c037846..d5cf38d004 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -427,8 +427,6 @@ subroutine rate_of_spread ( currentSite ) SF_val_miner_damp, & SF_val_fuel_energy - use FatesInterfaceTypesMod, only : hlm_current_day, hlm_current_month - type(ed_site_type), intent(in), target :: currentSite type(ed_patch_type), pointer :: currentPatch diff --git a/functional_unit_testing/parteh/f90src/FatesCohortWrapMod.F90 b/functional_unit_testing/parteh/f90src/FatesCohortWrapMod.F90 index 75575d3df9..6238111e30 100644 --- a/functional_unit_testing/parteh/f90src/FatesCohortWrapMod.F90 +++ b/functional_unit_testing/parteh/f90src/FatesCohortWrapMod.F90 @@ -230,7 +230,7 @@ subroutine CohortPySet(ipft,hgt_min,canopy_trim) ! Use allometry to compute initial values ! Leaf biomass (carbon) - call bleaf(ccohort%dbh, ipft, canopy_trim, leaf_c) + call bleaf(ccohort%dbh, ipft,canopy_trim, leaf_c) ! Fine-root biomass (carbon) call bfineroot(ccohort%dbh, ipft, canopy_trim, fnrt_c) @@ -431,7 +431,7 @@ end subroutine WrapDailyPRT ! ===================================================================================== - subroutine WrapQueryVars(ipft,leaf_area,crown_area,agb,store_c,target_leaf_c) + subroutine WrapQueryVars(ipft,crowndamage, leaf_area,crown_area,agb,store_c,target_leaf_c) implicit none ! Arguments @@ -444,12 +444,13 @@ subroutine WrapQueryVars(ipft,leaf_area,crown_area,agb,store_c,target_leaf_c) real(r8) :: leaf_c type(ed_cohort_type), pointer :: ccohort - + real(r8),parameter :: nplant = 1.0_r8 real(r8),parameter :: site_spread = 1.0_r8 real(r8), dimension(nclmax) :: canopy_lai integer, parameter :: cl1 = 1 + ccohort => cohort_array(ipft) @@ -466,18 +467,19 @@ subroutine WrapQueryVars(ipft,leaf_area,crown_area,agb,store_c,target_leaf_c) leaf_c = ccohort%prt%GetState(leaf_organ, carbon12_element ) store_c = ccohort%prt%GetState(store_organ, carbon12_element ) - call carea_allom(ccohort%dbh,nplant,site_spread,ipft,crown_area) + call carea_allom(ccohort%dbh,nplant,site_spread,ipft,ccohort%crowndamage,crown_area) leaf_area = crown_area*tree_lai(leaf_c, ipft, crown_area, nplant, cl1, canopy_lai,ccohort%vcmax25top) - call bagw_allom(ccohort%dbh,ipft,agb) + call bagw_allom(ccohort%dbh,ipft, agb) call bleaf(ccohort%dbh,ipft, ccohort%canopy_trim, target_leaf_c) return end subroutine WrapQueryVars - + + ! ========================================================================================== subroutine WrapQueryDiagnostics(ipft, dbh, & leaf_c, fnrt_c, sapw_c, store_c, struct_c, repro_c, & diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index d3177ca72a..77d75f86b3 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -44,11 +44,13 @@ 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_tree_damage use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : numpft use FatesInterfaceTypesMod , only : nleafage use FatesInterfaceTypesMod , only : nlevsclass use FatesInterfaceTypesMod , only : nlevcoage + use FatesInterfaceTypesMod , only : nlevdamage use FatesInterfaceTypesMod , only : hlm_use_nocomp use FatesInterfaceTypesMod , only : nlevage @@ -76,6 +78,7 @@ module EDInitMod use PRTGenericMod, only : phosphorus_element use PRTGenericMod, only : SetState use FatesSizeAgeTypeIndicesMod,only : get_age_class_index + use DamageMainMod, only : undamaged_class ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg @@ -128,7 +131,31 @@ subroutine init_site_vars( site_in, bc_in, bc_out ) 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)) - + + if (hlm_use_tree_damage .eq. itrue) then + allocate(site_in%term_nindivs_canopy_damage(1:nlevdamage, 1:nlevsclass, 1:numpft)) + allocate(site_in%term_nindivs_ustory_damage(1:nlevdamage, 1:nlevsclass, 1:numpft)) + allocate(site_in%imort_rate_damage(1:nlevdamage, 1:nlevsclass, 1:numpft)) + allocate(site_in%imort_cflux_damage(1:nlevdamage, 1:nlevsclass)) + allocate(site_in%term_cflux_canopy_damage(1:nlevdamage, 1:nlevsclass)) + allocate(site_in%term_cflux_ustory_damage(1:nlevdamage, 1:nlevsclass)) + allocate(site_in%fmort_rate_canopy_damage(1:nlevdamage, 1:nlevsclass, 1:numpft)) + allocate(site_in%fmort_rate_ustory_damage(1:nlevdamage, 1:nlevsclass, 1:numpft)) + allocate(site_in%fmort_cflux_canopy_damage(1:nlevdamage, 1:nlevsclass)) + allocate(site_in%fmort_cflux_ustory_damage(1:nlevdamage, 1:nlevsclass)) + else + allocate(site_in%term_nindivs_canopy_damage(1,1,1)) + allocate(site_in%term_nindivs_ustory_damage(1,1,1)) + allocate(site_in%imort_rate_damage(1,1,1)) + allocate(site_in%imort_cflux_damage(1,1)) + allocate(site_in%term_cflux_canopy_damage(1,1)) + allocate(site_in%term_cflux_ustory_damage(1,1)) + allocate(site_in%fmort_rate_canopy_damage(1,1,1)) + allocate(site_in%fmort_rate_ustory_damage(1,1,1)) + allocate(site_in%fmort_cflux_canopy_damage(1,1)) + allocate(site_in%fmort_cflux_ustory_damage(1,1)) + end if + allocate(site_in%term_carbonflux_canopy(1:numpft)) allocate(site_in%term_carbonflux_ustory(1:numpft)) allocate(site_in%imort_carbonflux(1:numpft)) @@ -234,6 +261,11 @@ subroutine zero_site( site_in ) ! termination and recruitment info site_in%term_nindivs_canopy(:,:) = 0._r8 site_in%term_nindivs_ustory(:,:) = 0._r8 + site_in%term_crownarea_canopy = 0._r8 + site_in%term_crownarea_ustory = 0._r8 + site_in%imort_crownarea = 0._r8 + site_in%fmort_crownarea_canopy = 0._r8 + site_in%fmort_crownarea_ustory = 0._r8 site_in%term_carbonflux_canopy(:) = 0._r8 site_in%term_carbonflux_ustory(:) = 0._r8 site_in%recruitment_rate(:) = 0._r8 @@ -255,6 +287,20 @@ subroutine zero_site( site_in ) site_in%promotion_rate(:) = 0._r8 site_in%promotion_carbonflux = 0._r8 + ! damage transition info + site_in%imort_rate_damage(:,:,:) = 0._r8 + site_in%term_nindivs_canopy_damage(:,:,:) = 0._r8 + site_in%term_nindivs_ustory_damage(:,:,:) = 0._r8 + site_in%imort_cflux_damage(:,:) = 0._r8 + site_in%term_cflux_canopy_damage(:,:) = 0._r8 + site_in%term_cflux_ustory_damage(:,:) = 0._r8 + site_in%crownarea_canopy_damage = 0._r8 + site_in%crownarea_ustory_damage = 0._r8 + site_in%fmort_rate_canopy_damage(:,:,:) = 0._r8 + site_in%fmort_rate_ustory_damage(:,:,:) = 0._r8 + site_in%fmort_cflux_canopy_damage(:,:) = 0._r8 + site_in%fmort_cflux_ustory_damage(:,:) = 0._r8 + ! Resources management (logging/harvesting, etc) site_in%resources_management%trunk_product_site = 0.0_r8 @@ -669,7 +715,7 @@ subroutine init_patches( nsites, sites, bc_in) return end subroutine init_patches - + ! ============================================================================ subroutine init_cohorts( site_in, patch_in, bc_in) ! @@ -677,6 +723,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) ! initialize new cohorts on bare ground ! ! !USES: + ! ! !ARGUMENTS type(ed_site_type), intent(inout), pointer :: site_in @@ -688,6 +735,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) class(prt_vartypes),pointer :: prt_obj integer :: cstatus integer :: pft + integer :: crowndamage ! which crown damage class integer :: iage ! index for leaf age loop integer :: el ! index for element loop integer :: element_id ! element index consistent with defs in PRTGeneric @@ -771,17 +819,22 @@ subroutine init_cohorts( site_in, patch_in, bc_in) else temp_cohort%hite = EDPftvarcon_inst%hgt_min(pft) + + ! Assume no damage to begin with - since we assume no damage + ! we do not need to initialise branch frac just yet. + temp_cohort%crowndamage = 1 ! 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) + call bleaf(temp_cohort%dbh,pft,temp_cohort%crowndamage, & + 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) + call bagw_allom(temp_cohort%dbh,pft,temp_cohort%crowndamage,c_agw) ! Calculate coarse root biomass from allometry call bbgw_allom(temp_cohort%dbh,pft,c_bgw) @@ -791,11 +844,13 @@ subroutine init_cohorts( site_in, patch_in, bc_in) 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 bsap_allom(temp_cohort%dbh,pft,temp_cohort%crowndamage, & + 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) + call bstore_allom(temp_cohort%dbh, pft, temp_cohort%crowndamage, & + temp_cohort%canopy_trim, c_store) cstatus = leaves_on @@ -892,11 +947,10 @@ subroutine init_cohorts( site_in, patch_in, bc_in) end do 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, cstatus, rstatus, & - temp_cohort%canopy_trim, temp_cohort%c_area,1, site_in%spread, bc_in) - + temp_cohort%canopy_trim, temp_cohort%c_area,1,temp_cohort%crowndamage, site_in%spread, bc_in) deallocate(temp_cohort) ! get rid of temporary cohort diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 7b9d623413..681645a71b 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -19,6 +19,7 @@ module EDMainMod 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_tree_damage use FatesInterfaceTypesMod , only : hlm_use_ed_st3 use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : bc_in_type @@ -35,6 +36,7 @@ module EDMainMod use EDCohortDynamicsMod , only : sort_cohorts use EDCohortDynamicsMod , only : count_cohorts use EDCohortDynamicsMod , only : EvaluateAndCorrectDBH + use EDCohortDynamicsMod , only : DamageRecovery use EDPatchDynamicsMod , only : disturbance_rates use EDPatchDynamicsMod , only : fuse_patches use EDPatchDynamicsMod , only : spawn_patches @@ -48,6 +50,7 @@ module EDMainMod use EDPhysiologyMod , only : ZeroLitterFluxes use EDPhysiologyMod , only : PreDisturbanceLitterFluxes use EDPhysiologyMod , only : PreDisturbanceIntegrateLitter + use EDPhysiologyMod , only : GenerateDamageAndLitterFluxes use FatesSoilBGCFluxMod , only : FluxIntoLitterPools use EDCohortDynamicsMod , only : UpdateCohortBioPhysRates use FatesSoilBGCFluxMod , only : PrepNutrientAquisitionBCs @@ -80,6 +83,7 @@ module EDMainMod use FatesPlantHydraulicsMod , only : AccumulateMortalityWaterStorage use FatesAllometryMod , only : h_allom,tree_sai,tree_lai use EDLoggingMortalityMod , only : IsItLoggingTime + use DamageMainMod , only : IsItDamageTime use EDPatchDynamicsMod , only : get_frac_site_primary use FatesGlobals , only : endrun => fates_endrun use ChecksBalancesMod , only : SiteMassStock @@ -144,9 +148,9 @@ 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 variables integer :: do_patch_dynamics ! for some modes, we turn off patch dynamics - + !----------------------------------------------------------------------- if (debug .and.( hlm_masterproc==itrue)) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& @@ -168,6 +172,9 @@ 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) + ! Call a routine that identifies if damage should occur + call IsItDamageTime(hlm_masterproc, currentSite) + !************************************************************************** ! Fire, growth, biogeochemistry. !************************************************************************** @@ -292,7 +299,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) end if call TotalBalanceCheck(currentSite,5) - + end subroutine ed_ecosystem_dynamics !-------------------------------------------------------------------------------! @@ -303,8 +310,29 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! FIX(SPM,032414) refactor so everything goes through interface ! ! !USES: + use FatesInterfaceTypesMod, only : nlevdamage + use FatesAllometryMod , only : bleaf + use FatesAllometryMod , only : carea_allom + use PRTGenericMod , only : leaf_organ + use PRTGenericMod , only : repro_organ + use PRTGenericMod , only : sapw_organ + use PRTGenericMod , only : struct_organ + use PRTGenericMod , only : store_organ + use PRTGenericMod , only : fnrt_organ use FatesInterfaceTypesMod, only : hlm_use_cohort_age_tracking use FatesConstantsMod, only : itrue + use PRTGenericMod , only : all_carbon_elements + use EDCohortDynamicsMod , only : zero_cohort, copy_cohort, insert_cohort + use EDCohortDynamicsMod , only : DeallocateCohort + use FatesPlantHydraulicsMod, only : InitHydrCohort + use EDCohortDynamicsMod , only : InitPRTObject + use EDCohortDynamicsMod , only : InitPRTBoundaryConditions + use FatesConstantsMod , only : nearzero + use EDCanopyStructureMod , only : canopy_structure + use PRTLossFluxesMod , only : PRTDamageRecoveryFluxes + use PRTGenericMod , only : max_nleafage + use PRTGenericMod , only : prt_global + ! !ARGUMENTS: type(ed_site_type) , intent(inout) :: currentSite @@ -316,6 +344,12 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) type(site_massbal_type), pointer :: site_cmass type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type) , pointer :: currentCohort + type(ed_cohort_type) , pointer :: nc + type(ed_cohort_type) , pointer :: storesmallcohort + type(ed_cohort_type) , pointer :: storebigcohort + + integer :: snull + integer :: tnull integer :: c ! Counter for litter size class integer :: ft ! Counter for PFT @@ -328,12 +362,48 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) logical :: is_drought ! logical for if the plant (site) is in a drought state real(r8) :: delta_dbh ! correction for dbh real(r8) :: delta_hite ! correction for hite - real(r8) :: current_npp ! place holder for calculating npp each year in prescribed physiology mode - !----------------------------------------------------------------------- + logical :: newly_recovered ! If the current loop is dealing with a newly created cohort, which + ! was created because it is a clone of the previous cohort in + ! a lowered damage state. This cohort should bypass several calculations + ! because it inherited them (such as daily carbon balance) + real(r8) :: target_leaf_c real(r8) :: frac_site_primary + real(r8) :: n_old + real(r8) :: n_recover + integer :: nleafage + real(r8) :: sapw_c + real(r8) :: leaf_c + real(r8) :: fnrt_c + real(r8) :: struct_c + real(r8) :: repro_c + real(r8) :: total_c + real(r8) :: store_c + + real(r8) :: cc_leaf_c + real(r8) :: cc_fnrt_c + real(r8) :: cc_struct_c + real(r8) :: cc_repro_c + real(r8) :: cc_store_c + real(r8) :: cc_sapw_c + + real(r8) :: sapw_c0 + real(r8) :: leaf_c0 + real(r8) :: fnrt_c0 + real(r8) :: struct_c0 + real(r8) :: repro_c0 + real(r8) :: store_c0 + real(r8) :: total_c0 + real(r8) :: nc_carbon + real(r8) :: cc_carbon + + integer,parameter :: leaf_c_id = 1 + + !----------------------------------------------------------------------- + nleafage = prt_global%state_descriptor(leaf_c_id)%num_pos + call get_frac_site_primary(currentSite, frac_site_primary) ! Set a pointer to this sites carbon12 mass balance @@ -361,84 +431,138 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! check to see if the patch has moved to the next age class currentPatch%age_class = get_age_class_index(currentPatch%age) - ! Update Canopy Biomass Pools + + ! Within this loop, we may be creating new cohorts, which + ! are copies of pre-existing cohorts with reduced damage classes. + ! If that is true, we want to bypass some of the things in + ! this loop (such as calculation of npp, etc) because they + ! are derived from the donor and have been modified accordingly + newly_recovered = .false. + currentCohort => currentPatch%shortest do while(associated(currentCohort)) - ft = currentCohort%pft - - ! Calculate the mortality derivatives - call Mortality_Derivative( currentSite, currentCohort, bc_in, frac_site_primary ) - - ! ----------------------------------------------------------------------------- - ! Apply Plant Allocation and Reactive Transport - ! ----------------------------------------------------------------------------- - ! ----------------------------------------------------------------------------- - ! Identify the net carbon gain for this dynamics interval - ! 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 + + ! Some cohorts are created and inserted to the list while + ! the loop is going. These are pointed to the "taller" position + ! of current, and then inherit properties of their donor (current) + ! we don't need to repeat things before allocation for these + ! newly_recovered cohorts + + if_not_newlyrecovered: if(.not.newly_recovered) then + + ! Calculate the mortality derivatives + call Mortality_Derivative( currentSite, currentCohort, bc_in, frac_site_primary ) + + ! ----------------------------------------------------------------------------- + ! Apply Plant Allocation and Reactive Transport + ! ----------------------------------------------------------------------------- + ! ----------------------------------------------------------------------------- + ! Identify the net carbon gain for this dynamics interval + ! 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 + 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 + currentCohort%resp_acc = 0._r8 + + end if + + ! ----------------------------------------------------------------------------- + ! Save NPP/GPP/R in these "hold" style variables. These variables + ! persist after this routine is complete, and used in I/O diagnostics. + ! Whereas the _acc style variables are zero'd because they are key + ! accumulation state variables. + ! + ! 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 + ! 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 + is_drought = .false. 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 - currentCohort%resp_acc = 0._r8 - - end if - - ! ----------------------------------------------------------------------------- - ! Save NPP/GPP/R in these "hold" style variables. These variables - ! persist after this routine is complete, and used in I/O diagnostics. - ! Whereas the _acc style variables are zero'd because they are key - ! accumulation state variables. - ! - ! 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 - ! 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 - is_drought = .false. - else - is_drought = .true. - end if - call PRTMaintTurnover(currentCohort%prt,ft,is_drought) - + is_drought = .true. + end if + + call PRTMaintTurnover(currentCohort%prt,ft,is_drought) + + + ! ----------------------------------------------------------------------------------- + ! Call the routine that advances leaves in age. + ! This will move a portion of the leaf mass in each + ! age bin, to the next bin. This will not handle movement + ! of mass from the oldest bin into the litter pool, that is something else. + ! ----------------------------------------------------------------------------------- + call currentCohort%prt%AgeLeaves(ft,sec_per_day) + + end if if_not_newlyrecovered + ! If the current diameter of a plant is somehow less than what is consistent ! with what is allometrically consistent with the stuctural biomass, then ! correct the dbh to match. - call EvaluateAndCorrectDBH(currentCohort,delta_dbh,delta_hite) - + + ! We want to save these values for the newly recovered cohort as well hite_old = currentCohort%hite dbh_old = currentCohort%dbh - + + ! ----------------------------------------------------------------------------- ! Growth and Allocation (PARTEH) ! ----------------------------------------------------------------------------- - call currentCohort%prt%DailyPRT() + ! We split the allocation into phases (currently for all hypotheses) + ! In phase 1, allocation, we address prioritized allocation that should + ! only happen once per day, this is only allocation that does not grow stature. + ! In phase 2, allocation , we address allocation that can be performed + ! as many times as necessary. This is allocation that does not contain stature + ! growth. This is separate from phase 1, because some recovering plants + ! will have new allocation targets that need to be updated after they change status. + ! In Phase 3, we assume that the plant has reached its targets, and any + ! left-over resources are used to grow the stature of the plant + + if(.not.newly_recovered)then + call currentCohort%prt%DailyPRT(phase=1) + end if + call currentCohort%prt%DailyPRT(phase=2) + + if((.not.newly_recovered) .and. (hlm_use_tree_damage .eq. itrue) ) then + ! The loop order is shortest to tallest + ! The recovered cohort (ie one with larger targets) + ! is newly created in DamageRecovery(), and + ! is inserted into the next position, following the + ! original and current (unrecovered) cohort. + ! we pass it back here in case the pointer is + ! needed for diagnostics + call DamageRecovery(currentSite,currentPatch,currentCohort,newly_recovered) + + else + newly_recovered = .false. + end if + call currentCohort%prt%DailyPRT(phase=3) + ! Update the mass balance tracking for the daily nutrient uptake flux ! Then zero out the daily uptakes, they have been used ! ----------------------------------------------------------------------------- @@ -574,16 +698,14 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) call coagetype_class_index(currentCohort%coage, currentCohort%pft, & currentCohort%coage_class,currentCohort%coage_by_pft_class) end if - - + currentCohort => currentCohort%taller - end do + end do currentPatch => currentPatch%older end do - - ! When plants die, the water goes with them. This effects + ! When plants die, the water goes with them. This effects ! the water balance. if( hlm_use_planthydro == itrue ) then @@ -611,10 +733,11 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) + + call GenerateDamageAndLitterFluxes( currentSite, currentPatch, bc_in) call PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in) - call PreDisturbanceIntegrateLitter(currentPatch ) currentPatch => currentPatch%older @@ -944,6 +1067,7 @@ subroutine bypass_dynamics(currentSite) currentCohort%frmort = 0.0_r8 currentCohort%smort = 0.0_r8 currentCohort%asmort = 0.0_r8 + currentCohort%dgmort = 0.0_r8 currentCohort%dndt = 0.0_r8 currentCohort%dhdt = 0.0_r8 diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index e381ab8bc7..05a20ec59d 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -131,6 +131,14 @@ module EDPftvarcon real(r8), allocatable :: prescribed_recruitment(:) ! this is only for the ! prescribed_physiology_mode + + ! Damage Parameters + + real(r8), allocatable :: damage_frac(:) ! Fraction of each cohort damaged per year + real(r8), allocatable :: damage_mort_p1(:) ! Inflection point for damage mortality function + real(r8), allocatable :: damage_mort_p2(:) ! Rate parameter for damage mortality function + real(r8), allocatable :: damage_recovery_scalar(:) ! what fraction of cohort gets to recover + ! Nutrient Aquisition (ECA & RD) @@ -430,6 +438,22 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_damage_frac' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_damage_mort_p1' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_damage_mort_p2' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_damage_recovery_scalar' + 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) @@ -763,6 +787,22 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetrieveParameterAllocate(name=name, & data=this%prescribed_recruitment) + name = 'fates_damage_frac' + call fates_params%RetrieveParameterAllocate(name=name, & + data=this%damage_frac) + + name = 'fates_damage_mort_p1' + call fates_params%RetrieveParameterAllocate(name=name, & + data=this%damage_mort_p1) + + name = 'fates_damage_mort_p2' + call fates_params%RetrieveParameterAllocate(name=name, & + data=this%damage_mort_p2) + + name = 'fates_damage_recovery_scalar' + call fates_params%RetrieveParameterAllocate(name=name, & + data=this%damage_recovery_scalar) + name = 'fates_fire_alpha_SH' call fates_params%RetrieveParameterAllocate(name=name, & data=this%fire_alpha_SH) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 86bb36e31e..071b54f424 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -22,7 +22,6 @@ module EDTypesMod use FatesRunningMeanMod, only : rmean_type use FatesInterfaceTypesMod,only : bc_in_type use FatesInterfaceTypesMod,only : bc_out_type - implicit none private ! By default everything is private @@ -39,7 +38,6 @@ module EDTypesMod ! are used, but this helps allocate scratch ! 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 @@ -215,6 +213,7 @@ module EDTypesMod real(r8) :: hite ! height: meters integer :: indexnumber ! unique number for each cohort. (within clump?) integer :: canopy_layer ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) + integer :: crowndamage ! crown damage class of the cohort [1: undamaged, >1: damaged] real(r8) :: canopy_layer_yesterday ! recent canopy status of cohort ! (1 = canopy, 2 = understorey, etc.) ! real to be conservative during fusion @@ -317,6 +316,7 @@ module EDTypesMod real(r8) :: ts_net_uptake(nlevleaf) ! Net uptake of leaf layers: kgC/m2/timestep real(r8) :: year_net_uptake(nlevleaf) ! Net uptake of leaf layers: kgC/m2/year + ! RESPIRATION COMPONENTS real(r8) :: rdark ! Dark respiration: kgC/indiv/s @@ -332,6 +332,9 @@ module EDTypesMod ! (below ground) real(r8) :: froot_mr ! Live fine root maintenance respiration: kgC/indiv/s + !DAMAGE + real(r8) :: branch_frac ! Fraction of aboveground woody biomass in branches + !MORTALITY real(r8) :: dmort ! proportional mortality rate. (year-1) @@ -342,6 +345,7 @@ module EDTypesMod real(r8) :: frmort ! freezing mortality n/year real(r8) :: smort ! senesence mortality n/year real(r8) :: asmort ! age senescence mortality n/year + real(r8) :: dgmort ! damage mortality n/year ! Logging Mortality Rate ! Yi Xu & M. Huang @@ -783,10 +787,18 @@ module EDTypesMod ! TERMINATION, RECRUITMENT, DEMOTION, and DISTURBANCE - real(r8), allocatable :: term_nindivs_canopy(:,:) ! number of canopy individuals that were in cohorts which - ! were terminated this timestep, on size x pft - real(r8), allocatable :: term_nindivs_ustory(:,:) ! number of understory individuals that were in cohorts which - ! were terminated this timestep, on size x pft + real(r8) :: term_crownarea_canopy ! crownarea from termination mortality, per canopy level + real(r8) :: term_crownarea_ustory ! crownarea from termination mortality, per canopy level + + real(r8) :: imort_crownarea ! crownarea of individuals killed due to impact mortality per year. [m2 day] + + real(r8) :: fmort_crownarea_canopy ! crownarea of canopy indivs killed due to fire per year. [m2/sec] + real(r8) :: fmort_crownarea_ustory ! crownarea of understory indivs killed due to fire per year [m2/sec] + + real(r8), allocatable :: term_nindivs_canopy(:,:) ! number of canopy individuals that were in cohorts which + ! were terminated this timestep, on size x pft + real(r8), allocatable :: term_nindivs_ustory(:,:) ! number of understory individuals that were in cohorts which + ! were terminated this timestep, on size x pft real(r8), allocatable :: term_carbonflux_canopy(:) ! carbon flux from live to dead pools associated ! with termination mortality, per canopy level @@ -814,11 +826,24 @@ module EDTypesMod real(r8), allocatable :: fmort_rate_crown(:,:) ! rate of individuals killed due to fire mortality ! from crown damage per year. on size x pft array + real(r8), allocatable :: imort_rate_damage(:,:,:) ! number of individuals per damage class that die from impact mortality + real(r8), allocatable :: term_nindivs_canopy_damage(:,:,:) ! number of individuals per damage class that die from termination mortality - canopy + real(r8), allocatable :: term_nindivs_ustory_damage(:,:,:) ! number of individuals per damage class that die from termination mortality - canopy + real(r8), allocatable :: fmort_rate_canopy_damage(:,:,:) ! number of individuals per damage class that die from fire - canopy + real(r8), allocatable :: fmort_rate_ustory_damage(:,:,:) ! number of individuals per damage class that die from fire - ustory + real(r8), allocatable :: fmort_cflux_canopy_damage(:,:) ! cflux per damage class that die from fire - canopy + real(r8), allocatable :: fmort_cflux_ustory_damage(:,:) ! cflux per damage class that die from fire - ustory + real(r8), allocatable :: imort_cflux_damage(:,:) ! carbon flux from impact mortality by damage class + real(r8), allocatable :: term_cflux_canopy_damage(:,:) ! carbon flux from termination mortality by damage class + real(r8), allocatable :: term_cflux_ustory_damage(:,:) ! carbon flux from termination mortality by damage class + real(r8), allocatable :: growthflux_fusion(:,:) ! rate of individuals moving into a given size class bin ! due to fusion in a given day. on size x pft array - + real(r8) :: crownarea_canopy_damage ! crown area of canopy that is damaged annually + real(r8) :: crownarea_ustory_damage ! crown area of understory that is damaged annually + ! Canopy Spread real(r8) :: spread ! dynamic canopy allometric term [unitless] @@ -1035,6 +1060,7 @@ subroutine dump_cohort(ccohort) write(fates_log(),*) 'co%n = ', ccohort%n write(fates_log(),*) 'co%dbh = ', ccohort%dbh write(fates_log(),*) 'co%hite = ', ccohort%hite + write(fates_log(),*) 'co%crowndamage = ', ccohort%crowndamage write(fates_log(),*) 'co%coage = ', ccohort%coage write(fates_log(),*) 'leaf carbon = ', ccohort%prt%GetState(leaf_organ,all_carbon_elements) @@ -1072,7 +1098,7 @@ subroutine dump_cohort(ccohort) write(fates_log(),*) 'co%livestem_mr = ', ccohort%livestem_mr write(fates_log(),*) 'co%livecroot_mr = ', ccohort%livecroot_mr write(fates_log(),*) 'co%froot_mr = ', ccohort%froot_mr - write(fates_log(),*) 'co%dmort = ', ccohort%dmort + write(fates_log(),*) 'co%dgmort = ', ccohort%dgmort write(fates_log(),*) 'co%treelai = ', ccohort%treelai write(fates_log(),*) 'co%treesai = ', ccohort%treesai write(fates_log(),*) 'co%c_area = ', ccohort%c_area @@ -1080,9 +1106,9 @@ subroutine dump_cohort(ccohort) write(fates_log(),*) 'co%bmort = ', ccohort%bmort write(fates_log(),*) 'co%smort = ', ccohort%smort write(fates_log(),*) 'co%asmort = ', ccohort%asmort + write(fates_log(),*) 'co%dgmort = ', ccohort%dgmort write(fates_log(),*) 'co%hmort = ', ccohort%hmort write(fates_log(),*) 'co%frmort = ', ccohort%frmort - write(fates_log(),*) 'co%asmort = ', ccohort%asmort write(fates_log(),*) 'co%isnew = ', ccohort%isnew write(fates_log(),*) 'co%dndt = ', ccohort%dndt write(fates_log(),*) 'co%dhdt = ', ccohort%dhdt diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 391d5f87d9..836c532a02 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -38,6 +38,8 @@ module FatesHistoryInterfaceMod use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_use_ed_st3 use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking + use FatesInterfaceTypesMod , only : hlm_use_tree_damage + use FatesInterfaceTypesMod , only : nlevdamage use FatesInterfaceTypesMod , only : numpft use FatesInterfaceTypesMod , only : hlm_freq_day use FatesInterfaceTypesMod , only : hlm_parteh_mode @@ -57,7 +59,8 @@ module FatesHistoryInterfaceMod ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg use shr_infnan_mod , only : isnan => shr_infnan_isnan - use FatesConstantsMod , only : g_per_kg,kg_per_g + use FatesConstantsMod , only : g_per_kg + use FatesConstantsMod , only : kg_per_g use FatesConstantsMod , only : ha_per_m2 use FatesConstantsMod , only : days_per_sec use FatesConstantsMod , only : sec_per_day @@ -328,6 +331,8 @@ module FatesHistoryInterfaceMod integer :: ih_promotion_carbonflux_si integer :: ih_canopy_mortality_carbonflux_si integer :: ih_understory_mortality_carbonflux_si + integer :: ih_canopy_mortality_crownarea_si + integer :: ih_understory_mortality_crownarea_si integer :: ih_canopy_spread_si integer :: ih_npp_leaf_si integer :: ih_npp_seed_si @@ -390,6 +395,8 @@ module FatesHistoryInterfaceMod integer :: ih_mortality_canopy_si_scpf integer :: ih_mortality_understory_si_scpf + integer :: ih_m3_mortality_canopy_si_scpf + integer :: ih_m3_mortality_understory_si_scpf integer :: ih_nplant_canopy_si_scpf integer :: ih_nplant_understory_si_scpf integer :: ih_ddbh_canopy_si_scpf @@ -414,6 +421,8 @@ module FatesHistoryInterfaceMod integer :: ih_m8_si_scpf integer :: ih_m9_si_scpf integer :: ih_m10_si_scpf + integer :: ih_m11_si_scpf + integer :: ih_crownfiremort_si_scpf integer :: ih_cambialfiremort_si_scpf @@ -441,6 +450,9 @@ module FatesHistoryInterfaceMod integer :: ih_sai_understory_si_scls integer :: ih_mortality_canopy_si_scls integer :: ih_mortality_understory_si_scls + integer :: ih_m3_mortality_canopy_si_scls + integer :: ih_m3_mortality_understory_si_scls + integer :: ih_demotion_rate_si_scls integer :: ih_promotion_rate_si_scls integer :: ih_trimming_canopy_si_scls @@ -636,6 +648,29 @@ module FatesHistoryInterfaceMod integer :: ih_parprof_dir_si_cnlfpft integer :: ih_parprof_dif_si_cnlfpft + ! indices to site x crown damage variables + ! site x crown damage x pft x sizeclass + ! site x crown damage x size class + integer :: ih_nplant_si_cdpf + integer :: ih_nplant_canopy_si_cdpf + integer :: ih_nplant_understory_si_cdpf + integer :: ih_mortality_si_cdpf + integer :: ih_mortality_canopy_si_cdpf + integer :: ih_mortality_understory_si_cdpf + integer :: ih_m3_si_cdpf + integer :: ih_m11_si_cdpf + integer :: ih_m3_mortality_canopy_si_cdpf + integer :: ih_m3_mortality_understory_si_cdpf + integer :: ih_m11_mortality_canopy_si_cdpf + integer :: ih_m11_mortality_understory_si_cdpf + integer :: ih_ddbh_si_cdpf + integer :: ih_ddbh_canopy_si_cdpf + integer :: ih_ddbh_understory_si_cdpf + + ! crownarea damaged + integer :: ih_crownarea_canopy_damage_si + integer :: ih_crownarea_ustory_damage_si + ! indices to (site x canopy layer) variables integer :: ih_parsun_top_si_can integer :: ih_parsha_top_si_can @@ -676,6 +711,7 @@ module FatesHistoryInterfaceMod integer, private :: levscls_index_, levpft_index_, levage_index_ integer, private :: levfuel_index_, levcwdsc_index_, levscag_index_ integer, private :: levcan_index_, levcnlf_index_, levcnlfpft_index_ + integer, private :: levcdpf_index_, levcdsc_index_, levcdam_index_ integer, private :: levscagpft_index_, levagepft_index_ integer, private :: levheight_index_, levagefuel_index_ integer, private :: levelem_index_, levelpft_index_ @@ -710,6 +746,9 @@ module FatesHistoryInterfaceMod procedure :: levcan_index procedure :: levcnlf_index procedure :: levcnlfpft_index + procedure :: levcdpf_index + procedure :: levcdsc_index + procedure :: levcdam_index procedure :: levscag_index procedure :: levscagpft_index procedure :: levagepft_index @@ -738,6 +777,9 @@ module FatesHistoryInterfaceMod procedure, private :: set_levcan_index procedure, private :: set_levcnlf_index procedure, private :: set_levcnlfpft_index + procedure, private :: set_levcdpf_index + procedure, private :: set_levcdsc_index + procedure, private :: set_levcdam_index procedure, private :: set_levscag_index procedure, private :: set_levscagpft_index procedure, private :: set_levagepft_index @@ -779,7 +821,8 @@ subroutine Init(this, num_threads, fates_bounds) use FatesIODimensionsMod, only : levheight, levagefuel use FatesIODimensionsMod, only : levelem, levelpft use FatesIODimensionsMod, only : levelcwd, levelage - + use FatesIODimensionsMod, only : levcdpf, levcdsc, levcdam + implicit none class(fates_history_interface_type), intent(inout) :: this @@ -853,6 +896,21 @@ subroutine Init(this, num_threads, fates_bounds) call this%dim_bounds(dim_count)%Init(levcnlfpft, num_threads, & fates_bounds%cnlfpft_begin, fates_bounds%cnlfpft_end) + dim_count = dim_count + 1 + call this%set_levcdpf_index(dim_count) + call this%dim_bounds(dim_count)%Init(levcdpf, num_threads, & + fates_bounds%cdpf_begin, fates_bounds%cdpf_end) + + dim_count = dim_count + 1 + call this%set_levcdsc_index(dim_count) + call this%dim_bounds(dim_count)%Init(levcdsc, num_threads, & + fates_bounds%cdsc_begin, fates_bounds%cdsc_end) + + dim_count = dim_count + 1 + call this%set_levcdam_index(dim_count) + call this%dim_bounds(dim_count)%Init(levcdam, num_threads, & + fates_bounds%cdam_begin, fates_bounds%cdam_end) + dim_count = dim_count + 1 call this%set_levscag_index(dim_count) call this%dim_bounds(dim_count)%Init(levscag, num_threads, & @@ -966,6 +1024,18 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%cnlfpft_begin, thread_bounds%cnlfpft_end) + index = this%levcdpf_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%cdpf_begin, thread_bounds%cdpf_end) + + index = this%levcdsc_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%cdsc_begin, thread_bounds%cdsc_end) + + index = this%levcdam_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%cdam_begin, thread_bounds%cdam_end) + index = this%levscag_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%sizeage_class_begin, thread_bounds%sizeage_class_end) @@ -1020,7 +1090,8 @@ subroutine assemble_history_output_types(this) use FatesIOVariableKindMod, only : site_height_r8, site_agefuel_r8 use FatesIOVariableKindMod, only : site_elem_r8, site_elpft_r8 use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8 - + use FatesIOVariableKindMod, only : site_cdpf_r8, site_cdsc_r8, site_cdam_r8 + implicit none class(fates_history_interface_type), intent(inout) :: this @@ -1065,6 +1136,15 @@ subroutine assemble_history_output_types(this) call this%set_dim_indices(site_cnlfpft_r8, 1, this%column_index()) call this%set_dim_indices(site_cnlfpft_r8, 2, this%levcnlfpft_index()) + call this%set_dim_indices(site_cdpf_r8, 1, this%column_index()) + call this%set_dim_indices(site_cdpf_r8, 2, this%levcdpf_index()) + + call this%set_dim_indices(site_cdsc_r8, 1, this%column_index()) + call this%set_dim_indices(site_cdsc_r8, 2, this%levcdsc_index()) + + call this%set_dim_indices(site_cdam_r8, 1, this%column_index()) + call this%set_dim_indices(site_cdam_r8, 2, this%levcdam_index()) + call this%set_dim_indices(site_scag_r8, 1, this%column_index()) call this%set_dim_indices(site_scag_r8, 2, this%levscag_index()) @@ -1317,6 +1397,48 @@ integer function levcnlfpft_index(this) levcnlfpft_index = this%levcnlfpft_index_ end function levcnlfpft_index + ! ======================================================================= + subroutine set_levcdpf_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levcdpf_index_ = index + end subroutine set_levcdpf_index + + integer function levcdpf_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levcdpf_index = this%levcdpf_index_ + end function levcdpf_index + + ! ======================================================================= + subroutine set_levcdsc_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levcdsc_index_ = index + end subroutine set_levcdsc_index + + integer function levcdsc_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levcdsc_index = this%levcdsc_index_ + end function levcdsc_index + + ! ======================================================================= + subroutine set_levcdam_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levcdam_index_ = index + end subroutine set_levcdam_index + + integer function levcdam_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levcdam_index = this%levcdam_index_ + end function levcdam_index + ! ====================================================================================== subroutine set_levscag_index(this, index) implicit none @@ -1595,7 +1717,8 @@ subroutine init_dim_kinds_maps(this) use FatesIOVariableKindMod, only : site_height_r8, site_agefuel_r8 use FatesIOVariableKindMod, only : site_elem_r8, site_elpft_r8 use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8 - + use FatesIOVariableKindMod, only : site_cdpf_r8, site_cdsc_r8, site_cdam_r8 + implicit none ! Arguments @@ -1656,6 +1779,18 @@ subroutine init_dim_kinds_maps(this) index = index + 1 call this%dim_kinds(index)%Init(site_cnlfpft_r8, 2) + ! site x crown damage x pft x size class + index = index + 1 + call this%dim_kinds(index)%Init(site_cdpf_r8, 2) + + ! site x crown damage x size class + index = index + 1 + call this%dim_kinds(index)%Init(site_cdsc_r8, 2) + + ! site x crown damage + index = index + 1 + call this%dim_kinds(index)%Init(site_cdam_r8, 2) + ! site x size-class x age class index = index + 1 call this%dim_kinds(index)%Init(site_scag_r8, 2) @@ -1721,10 +1856,13 @@ subroutine update_history_dyn(this,nc,nsites,sites) use FatesSizeAgeTypeIndicesMod, only : get_age_class_index use FatesSizeAgeTypeIndicesMod, only : get_height_index use FatesSizeAgeTypeIndicesMod, only : sizetype_class_index + use FatesSizeAgeTypeIndicesMod, only : get_cdamagesize_class_index + use FatesSizeAgeTypeIndicesMod, only : get_cdamagesizepft_class_index use FatesSizeAgeTypeIndicesMod, only : coagetype_class_index use EDTypesMod , only : nlevleaf use EDParamsMod , only : ED_val_history_height_bin_edges - + use FatesInterfaceTypesMod , only : nlevdamage + ! Arguments class(fates_history_interface_type) :: this integer , intent(in) :: nc ! clump index @@ -1755,6 +1893,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) integer :: iagepft ! age x pft index integer :: i_agefuel ! age x fuel size class index integer :: ican, ileaf, cnlf_indx ! iterators for leaf and canopy level + integer :: icdpf, icdsc, icdam, cdpf, cdsc ! iterators for the crown damage level integer :: height_bin_max, height_bin_min ! which height bin a given cohort's canopy is in integer :: i_heightbin ! iterator for height bins integer :: el ! Loop index for elements @@ -1890,6 +2029,12 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_lai_understory_si_scpf => this%hvars(ih_lai_understory_si_scpf)%r82d, & hio_mortality_canopy_si_scpf => this%hvars(ih_mortality_canopy_si_scpf)%r82d, & hio_mortality_understory_si_scpf => this%hvars(ih_mortality_understory_si_scpf)%r82d, & + hio_m3_mortality_canopy_si_scpf => this%hvars(ih_m3_mortality_canopy_si_scpf)%r82d, & + hio_m3_mortality_understory_si_scpf => this%hvars(ih_m3_mortality_understory_si_scpf)%r82d, & + hio_m3_mortality_canopy_si_scls => this%hvars(ih_m3_mortality_canopy_si_scls)%r82d, & + hio_m3_mortality_understory_si_scls => this%hvars(ih_m3_mortality_understory_si_scls)%r82d, & + hio_canopy_mortality_crownarea_si => this%hvars(ih_canopy_mortality_crownarea_si)%r81d, & + hio_understory_mortality_crownarea_si => this%hvars(ih_understory_mortality_crownarea_si)%r81d, & hio_nplant_canopy_si_scpf => this%hvars(ih_nplant_canopy_si_scpf)%r82d, & hio_nplant_understory_si_scpf => this%hvars(ih_nplant_understory_si_scpf)%r82d, & hio_ddbh_canopy_si_scpf => this%hvars(ih_ddbh_canopy_si_scpf)%r82d, & @@ -2089,6 +2234,20 @@ subroutine update_history_dyn(this,nc,nsites,sites) end do + ! damage variables - site level - this needs to be OUT of the patch loop + if(hlm_use_tree_damage .eq. itrue) then + + this%hvars(ih_crownarea_canopy_damage_si)%r81d(io_si) = & + this%hvars(ih_crownarea_canopy_damage_si)%r81d(io_si) + & + sites(s)%crownarea_canopy_damage * days_per_year * 1 / m2_per_ha + + this%hvars(ih_crownarea_ustory_damage_si)%r81d(io_si) = & + this%hvars(ih_crownarea_ustory_damage_si)%r81d(io_si) + & + sites(s)%crownarea_ustory_damage * days_per_year * 1 / m2_per_ha + + end if + + ! Canopy spread index (0-1) hio_canopy_spread_si(io_si) = sites(s)%spread @@ -2502,7 +2661,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) associate( scpf => ccohort%size_by_pft_class, & scls => ccohort%size_class, & cacls => ccohort%coage_class, & - capf => ccohort%coage_by_pft_class) + capf => ccohort%coage_by_pft_class, & + cdam => ccohort%crowndamage) gpp_cached = (hio_gpp_si_scpf(io_si,scpf)) * & days_per_year * sec_per_day @@ -2611,6 +2771,39 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_nplant_si_cacls(io_si,cacls) = hio_nplant_si_cacls(io_si,cacls)+ccohort%n / m2_per_ha end if + ! damage variables - cohort level + if(hlm_use_tree_damage .eq. itrue) then + + cdpf = get_cdamagesizepft_class_index(ccohort%dbh, ccohort%crowndamage, ccohort%pft) + + this%hvars(ih_mortality_si_cdpf)%r82d(io_si,cdpf) = & + this%hvars(ih_mortality_si_cdpf)%r82d(io_si,cdpf) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%frmort + & + ccohort%smort + ccohort%asmort + ccohort%dgmort) * ccohort%n / m2_per_ha + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & + ccohort%n * sec_per_day * days_per_year / m2_per_ha + + ! crown damage by size by pft + this%hvars(ih_nplant_si_cdpf)%r82d(io_si, cdpf) = & + this%hvars(ih_nplant_si_cdpf)%r82d(io_si, cdpf) + ccohort%n / m2_per_ha + this%hvars(ih_m3_si_cdpf)%r82d(io_si, cdpf) = & + this%hvars(ih_m3_si_cdpf)%r82d(io_si, cdpf) + & + ccohort%cmort * ccohort%n / m2_per_ha + + ! mortality + this%hvars(ih_m11_si_scpf)%r82d(io_si,scpf) = & + this%hvars(ih_m11_si_scpf)%r82d(io_si,scpf) + & + ccohort%dgmort*ccohort%n / m2_per_ha + this%hvars(ih_m11_si_cdpf)%r82d(io_si,cdpf) = & + this%hvars(ih_m11_si_cdpf)%r82d(io_si,cdpf) + & + ccohort%dgmort*ccohort%n / m2_per_ha + + this%hvars(ih_ddbh_si_cdpf)%r82d(io_si,cdpf) = & + this%hvars(ih_ddbh_si_cdpf)%r82d(io_si,cdpf) + & + ccohort%ddbhdt*ccohort%n / m2_per_ha * m_per_cm + + end if + ! Carbon only metrics sapw_m = ccohort%prt%GetState(sapw_organ, carbon12_element) struct_m = ccohort%prt%GetState(struct_organ, carbon12_element) @@ -2623,7 +2816,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_mortality_carbonflux_si_pft(io_si,ccohort%pft) = hio_mortality_carbonflux_si_pft(io_si,ccohort%pft) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * & + ccohort%frmort + ccohort%smort + ccohort%asmort + ccohort%dgmort) * & total_m * ccohort%n * days_per_sec * years_per_day * ha_per_m2 + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_m * & ccohort%n * ha_per_m2 @@ -2672,7 +2865,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_nplant_canopy_si_scag(io_si,iscag) = hio_nplant_canopy_si_scag(io_si,iscag) + ccohort%n / m2_per_ha hio_mortality_canopy_si_scag(io_si,iscag) = hio_mortality_canopy_si_scag(io_si,iscag) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + ccohort%frmort + ccohort%smort + ccohort%asmort + ccohort%dgmort) * ccohort%n / m2_per_ha hio_ddbh_canopy_si_scag(io_si,iscag) = hio_ddbh_canopy_si_scag(io_si,iscag) + & ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha hio_bstor_canopy_si_scpf(io_si,scpf) = hio_bstor_canopy_si_scpf(io_si,scpf) + & @@ -2690,7 +2883,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%frmort + & - ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & + ccohort%smort + ccohort%asmort + ccohort%dgmort) * ccohort%n / m2_per_ha + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & ccohort%n * sec_per_day * days_per_year / m2_per_ha @@ -2717,21 +2910,63 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! sum of all mortality hio_mortality_canopy_si_scls(io_si,scls) = hio_mortality_canopy_si_scls(io_si,scls) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & + ccohort%frmort + ccohort%smort + ccohort%asmort + ccohort%dgmort) * ccohort%n / m2_per_ha + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & ccohort%n * sec_per_day * days_per_year / m2_per_ha hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * & + ccohort%frmort + ccohort%smort + ccohort%asmort + ccohort%dgmort) * & total_m * ccohort%n * days_per_sec * years_per_day * ha_per_m2 + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_m * & ccohort%n * ha_per_m2 + hio_canopy_mortality_crownarea_si(io_si) = hio_canopy_mortality_crownarea_si(io_si) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + ccohort%frmort + ccohort%smort + ccohort%asmort + ccohort%dgmort) * & + ccohort%c_area + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & + ccohort%c_area * sec_per_day * days_per_year - hio_carbon_balance_canopy_si_scls(io_si,scls) = hio_carbon_balance_canopy_si_scls(io_si,scls) + & - ccohort%n * ccohort%npp_acc_hold / m2_per_ha / days_per_year / sec_per_day + hio_m3_mortality_canopy_si_scls(io_si,scls) = hio_m3_mortality_canopy_si_scls(io_si,scls) + & + ccohort%cmort * ccohort%n + hio_carbon_balance_canopy_si_scls(io_si,scls) = hio_carbon_balance_canopy_si_scls(io_si,scls) + & + ccohort%n * ccohort%npp_acc_hold / m2_per_ha / days_per_year / sec_per_day + + ! damage variables - canopy + if(hlm_use_tree_damage .eq. itrue) then + + ! carbon starvation mortality in the canopy by size x damage x pft + this%hvars(ih_m3_mortality_canopy_si_cdpf)%r82d(io_si,cdpf) = & + this%hvars(ih_m3_mortality_canopy_si_cdpf)%r82d(io_si,cdpf)+& + ccohort%cmort * ccohort%n / m2_per_ha + + ! damage mortality in the canopy by size x damage x pft + this%hvars(ih_m11_mortality_canopy_si_cdpf)%r82d(io_si,cdpf) = & + this%hvars(ih_m11_mortality_canopy_si_cdpf)%r82d(io_si,cdpf)+& + ccohort%dgmort * ccohort%n / m2_per_ha + + this%hvars(ih_mortality_canopy_si_cdpf)%r82d(io_si,cdpf) = & + this%hvars(ih_mortality_canopy_si_cdpf)%r82d(io_si,cdpf)+ & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%frmort + ccohort%smort + & + ccohort%asmort + ccohort%dgmort) * ccohort%n / m2_per_ha + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & + ccohort%n * sec_per_day * days_per_year / m2_per_ha + + ! nplants by damage + this%hvars(ih_nplant_canopy_si_cdpf)%r82d(io_si,cdpf) = & + this%hvars(ih_nplant_canopy_si_cdpf)%r82d(io_si,cdpf) + & + ccohort%n / m2_per_ha + + ! growth rate by damage x size x pft in the canopy + this%hvars(ih_ddbh_canopy_si_cdpf)%r82d(io_si,cdpf) = & + this%hvars(ih_ddbh_canopy_si_cdpf)%r82d(io_si,cdpf) + & + ccohort%ddbhdt*ccohort%n / m2_per_ha * m_per_cm + + end if ! end if damage + + hio_leaf_md_canopy_si_scls(io_si,scls) = hio_leaf_md_canopy_si_scls(io_si,scls) + & leaf_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day hio_root_md_canopy_si_scls(io_si,scls) = hio_root_md_canopy_si_scls(io_si,scls) + & @@ -2768,7 +3003,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_nplant_understory_si_scag(io_si,iscag) = hio_nplant_understory_si_scag(io_si,iscag) + ccohort%n / m2_per_ha hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + ccohort%frmort + ccohort%smort + ccohort%asmort + ccohort%dgmort) * ccohort%n / m2_per_ha hio_ddbh_understory_si_scag(io_si,iscag) = hio_ddbh_understory_si_scag(io_si,iscag) + & ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & @@ -2786,7 +3021,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & + ccohort%frmort + ccohort%smort + ccohort%asmort + ccohort%dgmort) * ccohort%n / m2_per_ha + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & ccohort%n * sec_per_day * days_per_year / m2_per_ha @@ -2814,19 +3049,58 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! sum of all mortality hio_mortality_understory_si_scls(io_si,scls) = hio_mortality_understory_si_scls(io_si,scls) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & + ccohort%frmort + ccohort%smort + ccohort%asmort + ccohort%dgmort) * ccohort%n / m2_per_ha + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & ccohort%n * sec_per_day * days_per_year / m2_per_ha hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * & - total_m * ccohort%n * days_per_sec * years_per_day * ha_per_m2 + & + ccohort%frmort + ccohort%smort + ccohort%asmort + ccohort%dgmort) * & + total_m * ccohort%n * days_per_sec * years_per_day * ha_per_m2 + & (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_m * & ccohort%n * ha_per_m2 + hio_understory_mortality_crownarea_si(io_si) = hio_understory_mortality_crownarea_si(io_si) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + ccohort%frmort + ccohort%smort + ccohort%asmort + ccohort%dgmort) * & + ccohort%c_area + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & + ccohort%c_area * sec_per_day * days_per_year + hio_carbon_balance_understory_si_scls(io_si,scls) = hio_carbon_balance_understory_si_scls(io_si,scls) + & - ccohort%npp_acc_hold * ccohort%n / m2_per_ha / days_per_year / sec_per_day + ccohort%npp_acc_hold * ccohort%n / m2_per_ha / days_per_year / sec_per_day + + ! damage variables - understory + if(hlm_use_tree_damage .eq. itrue) then + + ! carbon mortality in the understory by damage x size x pft + this%hvars(ih_m3_mortality_understory_si_cdpf)%r82d(io_si,cdpf) = & + this%hvars(ih_m3_mortality_understory_si_cdpf)%r82d(io_si,cdpf) + & + ccohort%cmort * ccohort%n / m2_per_ha + + ! damage in the understory by damage x size x pft + this%hvars(ih_m11_mortality_understory_si_cdpf)%r82d(io_si,cdpf) = & + this%hvars(ih_m11_mortality_understory_si_cdpf)%r82d(io_si,cdpf) + & + ccohort%dgmort * ccohort%n / m2_per_ha + + ! total mortality of understory cohorts by damage x size x pft + this%hvars(ih_mortality_understory_si_cdpf)%r82d(io_si,cdpf) = & + this%hvars(ih_mortality_understory_si_cdpf)%r82d(io_si,cdpf) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%frmort + & + ccohort%smort + ccohort%asmort + ccohort%dgmort) * ccohort%n / m2_per_ha + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & + ccohort%n * sec_per_day * days_per_year / m2_per_ha + + this%hvars(ih_nplant_understory_si_cdpf)%r82d(io_si,cdpf) = & + this%hvars(ih_nplant_understory_si_cdpf)%r82d(io_si,cdpf) + & + ccohort%n / m2_per_ha + + ! growth rate by size x damage x pft - understory + this%hvars(ih_ddbh_understory_si_cdpf)%r82d(io_si,cdpf) = & + this%hvars(ih_ddbh_understory_si_cdpf)%r82d(io_si,cdpf) + & + ccohort%ddbhdt*ccohort%n / m2_per_ha * m_per_cm + + end if ! end if damage hio_leaf_md_understory_si_scls(io_si,scls) = hio_leaf_md_understory_si_scls(io_si,scls) + & leaf_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day @@ -3094,6 +3368,40 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_firemortality_carbonflux_si_pft(io_si,i_pft) = sites(s)%fmort_carbonflux_canopy(i_pft) / g_per_kg end do + if(hlm_use_tree_damage .eq. itrue) then + + do i_pft = 1, numpft + do icdam = 1, nlevdamage + do i_scls = 1,nlevsclass + + icdsc = (icdam-1)*nlevsclass + i_scls + icdpf = (icdam-1)*nlevsclass + i_scls + & + (i_pft-1) * nlevsclass * nlevdamage + + this%hvars(ih_mortality_si_cdpf)%r82d(io_si, icdpf) = & + this%hvars(ih_mortality_si_cdpf)%r82d(io_si, icdpf) + & + ( (sites(s)%term_nindivs_canopy_damage(icdam, i_scls, i_pft) * days_per_year) + & + (sites(s)%term_nindivs_ustory_damage(icdam, i_scls, i_pft) * days_per_year) + & + sites(s)%imort_rate_damage(icdam, i_scls, i_pft) + & + sites(s)%fmort_rate_canopy_damage(icdam, i_scls, i_pft) + & + sites(s)%fmort_rate_ustory_damage(icdam, i_scls, i_pft) ) / m2_per_ha + + this%hvars(ih_mortality_canopy_si_cdpf)%r82d(io_si,icdpf) = & + this%hvars(ih_mortality_canopy_si_cdpf)%r82d(io_si,icdpf) + & + ( sites(s)%term_nindivs_canopy_damage(icdam,i_scls,i_pft) * days_per_year + & + sites(s)%fmort_rate_canopy_damage(icdam, i_scls, i_pft) )/ m2_per_ha + + this%hvars(ih_mortality_understory_si_cdpf)%r82d(io_si,icdpf) = & + this%hvars(ih_mortality_understory_si_cdpf)%r82d(io_si,icdpf) + & + ( sites(s)%term_nindivs_ustory_damage(icdam, i_scls,i_pft) * days_per_year + & + sites(s)%imort_rate_damage(icdam, i_scls, i_pft) + & + sites(s)%fmort_rate_ustory_damage(icdam, i_scls, i_pft) )/ m2_per_ha + + end do + end do + end do + end if + sites(s)%term_nindivs_canopy(:,:) = 0._r8 sites(s)%term_nindivs_ustory(:,:) = 0._r8 sites(s)%imort_carbonflux(:) = 0._r8 @@ -3106,6 +3414,19 @@ subroutine update_history_dyn(this,nc,nsites,sites) sites(s)%fmort_rate_crown(:,:) = 0._r8 sites(s)%growthflux_fusion(:,:) = 0._r8 + sites(s)%imort_rate_damage(:,:,:) = 0.0_r8 + sites(s)%term_nindivs_canopy_damage(:,:,:) = 0.0_r8 + sites(s)%term_nindivs_ustory_damage(:,:,:) = 0.0_r8 + sites(s)%imort_cflux_damage(:,:) = 0._r8 + sites(s)%term_cflux_canopy_damage(:,:) = 0._r8 + sites(s)%term_cflux_ustory_damage(:,:) = 0._r8 + sites(s)%fmort_rate_canopy_damage(:,:,:) = 0._r8 + sites(s)%fmort_rate_ustory_damage(:,:,:) = 0._r8 + sites(s)%fmort_cflux_canopy_damage(:,:) = 0._r8 + sites(s)%fmort_cflux_ustory_damage(:,:) = 0._r8 + sites(s)%crownarea_canopy_damage = 0._r8 + sites(s)%crownarea_ustory_damage = 0._r8 + ! pass the recruitment rate as a flux to the history, and then reset the recruitment buffer do i_pft = 1, numpft hio_recruitment_si_pft(io_si,i_pft) = sites(s)%recruitment_rate(i_pft) * days_per_year / m2_per_ha @@ -3128,7 +3449,12 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m8_si_scpf(io_si,i_scpf) + & hio_m9_si_scpf(io_si,i_scpf) + & hio_m10_si_scpf(io_si,i_scpf) - + + if(hlm_use_tree_damage .eq. itrue) then + hio_mortality_si_pft(io_si, i_pft) = hio_mortality_si_pft(io_si,i_pft) + & + this%hvars(ih_m11_si_scpf)%r82d(io_si,i_scpf) + end if + end do end do @@ -3506,6 +3832,16 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & sum(sites(s)%term_carbonflux_ustory(:)) * days_per_sec * ha_per_m2 + ! add site level mortality counting to crownarea diagnostic + hio_canopy_mortality_crownarea_si(io_si) = hio_canopy_mortality_crownarea_si(io_si) + & + sites(s)%fmort_crownarea_canopy + & + sites(s)%term_crownarea_canopy * days_per_year + + hio_understory_mortality_crownarea_si(io_si) = hio_understory_mortality_crownarea_si(io_si) + & + sites(s)%fmort_crownarea_ustory + & + sites(s)%term_crownarea_ustory * days_per_year + & + sites(s)%imort_crownarea + ! and zero the site-level termination carbon flux variable sites(s)%term_carbonflux_canopy(:) = 0._r8 sites(s)%term_carbonflux_ustory(:) = 0._r8 @@ -4395,6 +4731,7 @@ subroutine define_history_vars(this, initialize_variables) use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 + use FatesIOVariableKindMod, only : site_cdsc_r8, site_cdpf_r8, site_cdam_r8 use FatesIOVariableKindMod, only : site_scagpft_r8, site_agepft_r8 use FatesIOVariableKindMod, only : site_elem_r8, site_elpft_r8 use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8 @@ -4424,7 +4761,8 @@ subroutine define_history_vars(this, initialize_variables) ! plant functional type (site_pft_r8) : PF ! soil layer (site_soil_r8) : SL ! cohort size (site_size_r8) : SZ - + ! cohort crown damage (site_cd_r8) : CD + ! Multiple dimensions should have multiple two-code suffixes: ! cohort age x pft (site_cooage_r8) : ACPF ! patch age x fuel class (site_agefuel_r8) : APFC @@ -4435,7 +4773,8 @@ subroutine define_history_vars(this, initialize_variables) ! cohort size x patch age (site_scag_r8) : SZAP ! cohort size x patch age x pft (site_scagpft_r8) : SZAPPF ! cohort size x pft (site_size_pft_r8) : SZPF - + ! cohort size x crown damage (site_cdsc_r8) : SZCD + ! cohort size x crown damage x pft (site_cdpf_r8) : CDPF ! Site level counting variables @@ -5563,6 +5902,20 @@ subroutine define_history_vars(this, initialize_variables) upfreq=1, ivar=ivar, initialize=initialize_variables, & index=ih_cstarvmortality_carbonflux_si_pft) + call this%set_history_var(vname='MORTALITY_CROWNAREA_CANOPY', & + units = 'm2/ha/year', & + long='Crown area of canopy trees that died', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_canopy_mortality_crownarea_si ) + + call this%set_history_var(vname='MORTALITY_CROWNAREA_UNDERSTORY', & + units = 'm2/ha/year', & + long='Crown aera of understory trees that died', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_understory_mortality_crownarea_si ) + ! size class by age dimensioned variables call this%set_history_var(vname='FATES_NPLANT_SZAP', units = 'm-2', & @@ -5893,6 +6246,21 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_mortality_canopy_si_scpf) + call this%set_history_var(vname='FATES_M3_MORTALITY_CANOPY_SZPF', & + units = 'N/ha/yr', & + long='C starvation mortality of canopy plants by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m3_mortality_canopy_si_scpf ) + + call this%set_history_var(vname='FATES_M3_MORTALITY_USTORY_SZPF', & + units = 'N/ha/yr', & + long='C starvation mortality of understory plants by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m3_mortality_understory_si_scpf ) + + call this%set_history_var(vname='FATES_C13DISC_SZPF', units = 'per mil', & long='C13 discrimination by pft/size',use_default='inactive', & avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & @@ -6149,6 +6517,20 @@ subroutine define_history_vars(this, initialize_variables) hlms='CLM:ALM', upfreq=1, ivar=ivar, & initialize=initialize_variables, index = ih_nplant_understory_si_scls) + call this%set_history_var(vname='FATES_M3_MORTALITY_CANOPY_SZ', & + units = 'N/ha/yr', & + long='C starvation mortality of canopy plants by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m3_mortality_canopy_si_scls ) + + call this%set_history_var(vname='FATES_M3_MORTALITY_USTORY_SZ', & + units = 'N/ha/yr', & + long='C starvation mortality of understory plants by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m3_mortality_understory_si_scls ) + call this%set_history_var(vname='FATES_LAI_USTORY_SZ', & units = 'm2 m-2', & long='leaf area index (LAI) of understory plants by size class', & @@ -6591,6 +6973,101 @@ subroutine define_history_vars(this, initialize_variables) index = ih_resp_m_understory_si_scls) + ! CROWN DAMAGE VARIABLES + if_crowndamage: if(hlm_use_tree_damage .eq. itrue) then + + call this%set_history_var(vname='FATES_CROWNAREA_CANOPY_CD', units = 'm2 m-2 yr-1', & + long='crownarea lost to damage each year', use_default='inactive', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_crownarea_canopy_damage_si ) + + call this%set_history_var(vname='FATES_CROWNAREA_USTORY_CD', units = 'm2 m-2 yr-1', & + long='crownarea lost to damage each year', use_default='inactive', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_crownarea_ustory_damage_si ) + + call this%set_history_var(vname='FATES_NPLANT_CDPF', units = 'm-2', & + long='N. plants per damage x size x pft class', use_default='inactive', & + avgflag='A', vtype=site_cdpf_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_cdpf ) + + call this%set_history_var(vname='FATES_NPLANT_CANOPY_CDPF', units = 'm-2', & + long='N. plants per damage x size x pft class', use_default='inactive', & + avgflag='A', vtype=site_cdpf_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_canopy_si_cdpf ) + + call this%set_history_var(vname='FATES_NPLANT_USTORY_CDPF', units = 'm-2', & + long='N. plants in the understory per damage x size x pft class', use_default='inactive', & + avgflag='A', vtype=site_cdpf_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_understory_si_cdpf ) + + call this%set_history_var(vname='FATES_M3_CDPF', units = 'm-2 yr-1', & + long='carbon starvation mortality by damaage/pft/size', use_default='inactive', & + avgflag='A', vtype=site_cdpf_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m3_si_cdpf ) + + call this%set_history_var(vname='FATES_M11_SZPF', units = 'm-2 yr-1', & + long='damage mortality by pft/size',use_default='inactive', & + avgflag='A', vtype =site_size_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m11_si_scpf ) + + call this%set_history_var(vname='FATES_M11_CDPF', units = 'm-2 yr-1', & + long='damage mortality by damaage/pft/size', use_default='inactive', & + avgflag='A', vtype=site_cdpf_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m11_si_cdpf ) + + call this%set_history_var(vname='FATES_MORTALITY_CDPF', units = 'm-2 yr-1', & + long='mortality by damage class by size by pft', use_default='inactive', & + avgflag='A', vtype=site_cdpf_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_si_cdpf ) + + call this%set_history_var(vname='FATES_M3_MORTALITY_CANOPY_CDPF', units = 'm-2 yr-1', & + long='C starvation mortality of canopy plants by damage/pft/size', use_default='inactive', & + avgflag='A', vtype=site_cdpf_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m3_mortality_canopy_si_cdpf ) + + call this%set_history_var(vname='FATES_M3_MORTALITY_USTORY_CDPF', units = 'm-2 yr-1', & + long='C starvation mortality of understory plants by pft/size', use_default='inactive', & + avgflag='A', vtype=site_cdpf_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m3_mortality_understory_si_cdpf ) + + call this%set_history_var(vname='FATES_M11_MORTALITY_CANOPY_CDPF', units = 'm-2 yr-1', & + long='damage mortality of canopy plants by damage/pft/size', use_default='inactive', & + avgflag='A', vtype=site_cdpf_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m11_mortality_canopy_si_cdpf ) + + call this%set_history_var(vname='FATES_M11_MORTALITY_USTORY_CDPF', units = 'm-2 yr-1', & + long='damage mortality of understory plants by pft/size', use_default='inactive', & + avgflag='A', vtype=site_cdpf_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m11_mortality_understory_si_cdpf ) + + call this%set_history_var(vname='FATES_MORTALITY_CANOPY_CDPF', units = 'm-2 yr-1', & + long='mortality of canopy plants by damage/pft/size', use_default='inactive', & + avgflag='A', vtype=site_cdpf_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_canopy_si_cdpf ) + + call this%set_history_var(vname='FATES_MORTALITY_USTORY_CDPF', units = 'm-2 yr-1', & + long='mortality of understory plants by pft/size', use_default='inactive', & + avgflag='A', vtype=site_cdpf_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_understory_si_cdpf ) + + call this%set_history_var(vname='FATES_DDBH_CDPF', units = 'm m-2 yr-1', & + long='ddbh annual increment growth by damage x size pft', use_default='inactive', & + avgflag='A', vtype=site_cdpf_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_si_cdpf ) + + call this%set_history_var(vname='FATES_DDBH_CANOPY_CDPF', units = 'm m-2 yr-1', & + long='ddbh annual canopy increment growth by damage x size pft', use_default='inactive', & + avgflag='A', vtype=site_cdpf_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_canopy_si_cdpf ) + + call this%set_history_var(vname='FATES_DDBH_USTORY_CDPF', units = 'm m-2 yr-1', & + long='ddbh annual understory increment growth by damage x size pft', use_default='inactive', & + avgflag='A', vtype=site_cdpf_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_understory_si_cdpf ) + + end if if_crowndamage + ! CARBON BALANCE VARIABLES THAT DEPEND ON HLM BGC INPUTS call this%set_history_var(vname='FATES_NEP', units='kg m-2 s-1', & diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 index b7bcc52176..c30d6882e2 100644 --- a/main/FatesHistoryVariableType.F90 +++ b/main/FatesHistoryVariableType.F90 @@ -12,6 +12,7 @@ module FatesHistoryVariableType use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 use FatesIOVariableKindMod, only : site_scagpft_r8, site_agepft_r8 use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 + use FatesIOVariableKindMod, only : site_cdsc_r8, site_cdpf_r8 use FatesIOVariableKindMod, only : site_elem_r8, site_elpft_r8 use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8 use FatesIOVariableKindMod, only : iotype_index, site_agefuel_r8 @@ -166,6 +167,14 @@ subroutine Init(this, vname, units, long, use_default, & allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval + case(site_cdsc_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_cdpf_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + case(site_scag_r8) allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval @@ -302,6 +311,10 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_cnlfpft_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_cdsc_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_cdpf_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_scag_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_scagpft_r8) diff --git a/main/FatesIODimensionsMod.F90 b/main/FatesIODimensionsMod.F90 index c8d4c17b85..97ff3ec49d 100644 --- a/main/FatesIODimensionsMod.F90 +++ b/main/FatesIODimensionsMod.F90 @@ -26,11 +26,10 @@ module FatesIODimensionsMod character(*), parameter, public :: levcan = 'fates_levcan' ! matches histFileMod character(*), parameter, public :: levcnlf = 'fates_levcnlf' ! matches histFileMod character(*), parameter, public :: levcnlfpft = 'fates_levcnlfpf' ! matches histFileMod - character(*), parameter, public :: levagefuel = 'fates_levagefuel' ! matches histFileMod character(*), parameter, public :: levcdsc = 'fates_levcdsc' ! matches histFileMod character(*), parameter, public :: levcdpf = 'fates_levcdpf' ! matches histFileMod character(*), parameter, public :: levcdam = 'fates_levcdam' ! matches histFileMod - + character(*), parameter, public :: levagefuel = 'fates_levagefuel' ! matches histFileMod character(*), parameter, public :: levelem = 'fates_levelem' character(*), parameter, public :: levelpft = 'fates_levelpft' character(*), parameter, public :: levelcwd = 'fates_levelcwd' @@ -79,6 +78,15 @@ module FatesIODimensionsMod ! levcnlfpft = This is a structure that records the boundaries for the ! number of canopy layer x leaf layer x pft dimension + ! levcdsc = This is a structure that records the boundaries for the + ! number of crown damage x size classes dimension + + ! levcdpf = This is a structure that records the boundaries for the + ! number of crown damage x size classes x pft dimension + + ! levcdam = This is the structure that records the boundaries for the + ! number of crown damage classes dimension + ! levscag = This is a strcture that records the boundaries for the ! number of size-classes x patch age diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 9308c18390..ccdaf7c86a 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -1533,16 +1533,20 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(hlm_use_tree_damage .eq. unset_int .or. hlm_use_tree_damage .eq. itrue) then + if(hlm_use_tree_damage .eq. unset_int) then write(fates_log(),*) 'FATES dimension/parameter unset: hlm_use_tree_damage, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) + else + if((hlm_use_tree_damage .eq. itrue) .and. & + (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp))then + write(fates_log(),*) 'FATES tree damage (use_fates_tree_damage = .true.) is not' + write(fates_log(),*) '(yet) compatible with CNP allocation (fates_parteh_mode = 2)' + call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(hlm_use_tree_damage .eq. itrue) then - write(fates_log(),*) 'hlm_use_tree_damage is not available yet, value: ',hlm_use_tree_damage,' ,set to false' - call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - + if(hlm_nitrogen_spec .eq. unset_int) then write(fates_log(),*) 'FATES parameters unset: hlm_nitrogen_spec, exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index f08fba4ce8..5df7fd7abf 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -531,7 +531,7 @@ module FatesInterfaceTypesMod character(len=64), allocatable :: hlm_harvest_catnames(:) ! names of hlm_harvest d1 integer :: hlm_harvest_units ! what units are the harvest rates specified in? [area vs carbon] - + ! Fixed biogeography mode real(r8), allocatable :: pft_areafrac(:) ! Fractional area of the FATES column occupied by each PFT @@ -722,6 +722,7 @@ module FatesInterfaceTypesMod ! small fluxes for various reasons ! [mm H2O/s] + ! FATES LULCC real(r8) :: hrv_deadstemc_to_prod10c ! Harvested C flux to 10-yr wood product pool [Site-Level, gC m-2 s-1] real(r8) :: hrv_deadstemc_to_prod100c ! Harvested C flux to 100-yr wood product pool [Site-Level, gC m-2 s-1] diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index a76ae9df4f..03e04df6c9 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -917,7 +917,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & real(r8) :: m_repro ! Generic mass for reproductive tissues [kg] real(r8) :: stem_drop_fraction integer :: i_pft, ncohorts_to_create - + character(len=128),parameter :: wr_fmt = & '(F7.1,2X,A20,2X,A20,2X,F5.2,2X,F5.2,2X,I4,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2)' @@ -925,6 +925,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & real(r8), parameter :: abnormal_large_dbh = 500.0_r8 ! I've never heard of a tree > 3m integer, parameter :: recruitstatus = 0 + read(css_file_unit,fmt=*,iostat=ios) c_time, p_name, c_name, c_dbh, c_height, & c_pft, c_nplant, c_bdead, c_balive, c_avgRG @@ -1018,28 +1019,30 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & temp_cohort%n = c_nplant * cpatch%area / real(ncohorts_to_create,r8) temp_cohort%dbh = c_dbh + temp_cohort%crowndamage = 1 ! assume undamaged call h_allom(c_dbh,temp_cohort%pft,temp_cohort%hite) temp_cohort%canopy_trim = 1.0_r8 - - call bagw_allom(temp_cohort%dbh,temp_cohort%pft,c_agw) + call bagw_allom(temp_cohort%dbh,temp_cohort%pft, & + temp_cohort%crowndamage, c_agw) ! Calculate coarse root biomass from allometry call bbgw_allom(temp_cohort%dbh,temp_cohort%pft,c_bgw) ! Calculate the leaf biomass (calculates a maximum first, then applies canopy trim ! and sla scaling factors) - call bleaf(temp_cohort%dbh,temp_cohort%pft,temp_cohort%canopy_trim,c_leaf) - + call bleaf(temp_cohort%dbh,temp_cohort%pft,temp_cohort%crowndamage,& + temp_cohort%canopy_trim,c_leaf) + ! Calculate fine root biomass call bfineroot(temp_cohort%dbh,temp_cohort%pft,temp_cohort%canopy_trim,c_fnrt) ! Calculate sapwood biomass - call bsap_allom(temp_cohort%dbh,temp_cohort%pft,temp_cohort%canopy_trim, a_sapw, c_sapw) - + call bsap_allom(temp_cohort%dbh,temp_cohort%pft,temp_cohort%crowndamage, & + temp_cohort%canopy_trim, a_sapw, c_sapw) + call bdead_allom( c_agw, c_bgw, c_sapw, temp_cohort%pft, c_struct ) - - call bstore_allom(temp_cohort%dbh, temp_cohort%pft, temp_cohort%canopy_trim, c_store) + call bstore_allom(temp_cohort%dbh, temp_cohort%pft, temp_cohort%crowndamage,temp_cohort%canopy_trim, c_store) cstatus = leaves_on stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) @@ -1146,13 +1149,10 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & call prt_obj%CheckInitialConditions() - - ! Since spread is a canopy level calculation, we need to provide an initial guess here. - call create_cohort(csite, cpatch, temp_cohort%pft, temp_cohort%n, temp_cohort%hite, & temp_cohort%coage, temp_cohort%dbh, & prt_obj, cstatus, rstatus, temp_cohort%canopy_trim,temp_cohort%c_area, & - 1, csite%spread, bc_in) + 1, temp_cohort%crowndamage, csite%spread, bc_in) deallocate(temp_cohort) ! get rid of temporary cohort diff --git a/main/FatesParameterDerivedMod.F90 b/main/FatesParameterDerivedMod.F90 index 66445c1906..aa1584feb0 100644 --- a/main/FatesParameterDerivedMod.F90 +++ b/main/FatesParameterDerivedMod.F90 @@ -13,7 +13,10 @@ module FatesParameterDerivedMod use FatesConstantsMod, only : umolC_to_kgC use FatesConstantsMod, only : g_per_kg use FatesInterfaceTypesMod, only : nleafage - + use FatesInterfaceTypesMod, only : nlevdamage + use FatesGlobals , only : fates_log + use EDParamsMod , only : ED_val_history_damage_bin_edges + implicit none private @@ -25,17 +28,29 @@ module FatesParameterDerivedMod ! rate at 25C (umol CO2/m**2/s) real(r8), allocatable :: kp25top(:,:) ! canopy top: initial slope of CO2 response ! curve (C4 plants) at 25C + + real(r8), allocatable :: branch_frac(:) ! fraction of aboveground woody biomass in branches (as + ! oppose to stems) - for use in damage allometries + + real(r8), allocatable :: damage_transitions(:,:,:) ! matrix of transition probabilities between + ! damage classes - one per PFT + contains procedure :: Init + procedure :: InitDamageTransitions procedure :: InitAllocate + procedure :: InitAllocateDamageTransitions end type param_derived_type type(param_derived_type), public :: param_derived -contains + logical :: debug = .false. ! for module level debugging +contains + + ! =================================================================================== subroutine InitAllocate(this,numpft) class(param_derived_type), intent(inout) :: this @@ -44,26 +59,46 @@ subroutine InitAllocate(this,numpft) allocate(this%jmax25top(numpft,nleafage)) allocate(this%tpu25top(numpft,nleafage)) allocate(this%kp25top(numpft,nleafage)) + + allocate(this%branch_frac(numpft)) + return end subroutine InitAllocate ! ===================================================================================== - + + ! =================================================================================== + subroutine InitAllocateDamageTransitions(this,numpft) + + class(param_derived_type), intent(inout) :: this + integer, intent(in) :: numpft + + allocate(this%damage_transitions(nlevdamage,nlevdamage, numpft)) + + return + end subroutine InitAllocateDamageTransitions + + ! ===================================================================================== + subroutine Init(this,numpft) use EDPftvarcon, only: EDPftvarcon_inst - + use SFParamsMod, only: SF_val_CWD_frac + use FatesLitterMod, only : ncwd + class(param_derived_type), intent(inout) :: this integer, intent(in) :: numpft ! local variables integer :: ft ! pft index integer :: iage ! leaf age class index - + integer :: c ! cwd index + associate( vcmax25top => EDPftvarcon_inst%vcmax25top ) call this%InitAllocate(numpft) + call this%InitDamageTransitions(numpft) do ft = 1,numpft @@ -85,11 +120,78 @@ subroutine Init(this,numpft) this%kp25top(ft,iage) = 20000._r8 * vcmax25top(ft,iage) end do + + ! Allocate fraction of aboveground woody biomass in branches + this%branch_frac(ft) = sum(SF_val_CWD_frac(1:3)) - end do !ft + end do !ft end associate return end subroutine Init +!========================================================================= + + subroutine InitDamageTransitions(this, numpft) + + use EDPftvarcon, only: EDPftvarcon_inst + + + class(param_derived_type), intent(inout) :: this + integer, intent(in) :: numpft + + ! local variables + integer :: ft ! pft index + integer :: i ! crowndamage index + integer :: j ! damage bin index + real(r8) :: damage_frac ! damage fraction + real(r8), allocatable :: damage_bin_edges_ex(:) ! including the upper bound of 100 + real(r8), allocatable :: class_widths(:) ! widths of each damage class + + call this%InitAllocateDamageTransitions(numpft) + + allocate(class_widths(1:nlevdamage)) + allocate(damage_bin_edges_ex(1:(nlevdamage+1))) + + ! class widths + ! append 100 to ED_val_history_damage_bin_edges + do j = 1,nlevdamage + damage_bin_edges_ex(j) = ED_val_history_damage_bin_edges(j) + end do + damage_bin_edges_ex(j) = 100.0_r8 + + ! gets class widths (something like below) + class_widths = damage_bin_edges_ex(2:(nlevdamage+1)) - & + damage_bin_edges_ex(1:nlevdamage) + + do ft = 1, numpft + + damage_frac = EDPftvarcon_inst%damage_frac(ft) + + do i = 1, nlevdamage + + ! zero the column + this%damage_transitions(i,:,ft) = 0._r8 + ! damage rate stays the same + this%damage_transitions(i,i,ft) = 1.0_r8 - damage_frac + + + if(i < nlevdamage) then + ! fraction damaged get split according to class width + this%damage_transitions(i,i+1:nlevdamage,ft) = damage_frac * & + class_widths(i+1:nlevdamage)/ SUM(class_widths(i+1:nlevdamage)) + end if + ! Make sure it sums to one - they have to go somewhere + this%damage_transitions(i, :, ft) = this%damage_transitions(i, :, ft)/SUM(this%damage_transitions(i, :, ft)) + end do + + if (debug) write(fates_log(),'(a/,5(F12.6,1x))') 'annual transition matrix : ', this%damage_transitions(:,:,ft) + end do + + + + + return + end subroutine InitDamageTransitions + end module FatesParameterDerivedMod diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index d17759220a..5089e09da6 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -22,6 +22,7 @@ module FatesRestartInterfaceMod use FatesInterfaceTypesMod, only : hlm_use_sp use FatesInterfaceTypesMod, only : hlm_use_nocomp, hlm_use_fixed_biogeog use FatesInterfaceTypesMod, only : fates_maxElementsPerSite + use FatesInterfaceTypesMod, only : hlm_use_tree_damage use EDCohortDynamicsMod, only : UpdateCohortBioPhysRates use FatesHydraulicsMemMod, only : nshell use FatesHydraulicsMemMod, only : n_hypool_ag @@ -35,6 +36,7 @@ module FatesRestartInterfaceMod use EDCohortDynamicsMod, only : InitPRTBoundaryConditions use FatesPlantHydraulicsMod, only : InitHydrCohort use FatesInterfaceTypesMod, only : nlevsclass + use FatesInterfaceTypesMod, only : nlevdamage use FatesLitterMod, only : litter_type use FatesLitterMod, only : ncwd use FatesLitterMod, only : ndcmpy @@ -97,6 +99,7 @@ module FatesRestartInterfaceMod integer :: ir_ncohort_pa integer :: ir_canopy_layer_co integer :: ir_canopy_layer_yesterday_co + integer :: ir_crowndamage_co integer :: ir_canopy_trim_co integer :: ir_size_class_lasttimestep_co integer :: ir_dbh_co @@ -117,6 +120,7 @@ module FatesRestartInterfaceMod integer :: ir_frmort_co integer :: ir_smort_co integer :: ir_asmort_co + integer :: ir_dgmort_co integer :: ir_c_area_co integer :: ir_treelai_co integer :: ir_treesai_co @@ -204,6 +208,12 @@ module FatesRestartInterfaceMod integer :: ir_growflx_fusion_siscpf integer :: ir_demorate_sisc integer :: ir_promrate_sisc + integer :: ir_termcarea_cano_si + integer :: ir_termcarea_usto_si + + integer :: ir_imortcarea_si + integer :: ir_fmortcarea_cano_si + integer :: ir_fmortcarea_usto_si integer :: ir_termcflux_cano_sipft integer :: ir_termcflux_usto_sipft integer :: ir_democflux_si @@ -211,6 +221,7 @@ module FatesRestartInterfaceMod integer :: ir_imortcflux_sipft integer :: ir_fmortcflux_cano_sipft integer :: ir_fmortcflux_usto_sipft + integer :: ir_cwdagin_flxdg integer :: ir_cwdbgin_flxdg integer :: ir_leaflittin_flxdg @@ -222,6 +233,21 @@ module FatesRestartInterfaceMod integer :: ir_woodprod_mbal integer :: ir_prt_base ! Base index for all PRT variables + ! Damage x damage or damage x size + integer :: ir_imortrate_sicdpf + integer :: ir_termnindiv_cano_sicdpf + integer :: ir_termnindiv_usto_sicdpf + integer :: ir_fmortrate_cano_sicdpf + integer :: ir_fmortrate_usto_sicdpf + integer :: ir_imortcflux_sicdsc + integer :: ir_termcflux_cano_sicdsc + integer :: ir_termcflux_usto_sicdsc + integer :: ir_fmortcflux_cano_sicdsc + integer :: ir_fmortcflux_usto_sicdsc + integer :: ir_crownarea_cano_si + integer :: ir_crownarea_usto_si + + ! Hydraulic indices integer :: ir_hydro_th_ag_covec integer :: ir_hydro_th_troot @@ -689,7 +715,6 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates cohort - seed production', units='kgC/plant', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seed_prod_co ) - call this%set_restart_var(vname='fates_canopy_layer', vtype=cohort_int, & long_name='ed cohort - canopy_layer', units='unitless', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_layer_co ) @@ -698,6 +723,10 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - canopy_layer_yesterday', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_layer_yesterday_co ) + call this%set_restart_var(vname='fates_crowndamage', vtype=cohort_int, & + long_name='ed cohort - crowndamage class', units='unitless', flushval = flushinvalid, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_crowndamage_co ) + call this%set_restart_var(vname='fates_canopy_trim', vtype=cohort_r8, & long_name='ed cohort - canopy_trim', units='fraction', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_trim_co ) @@ -838,6 +867,11 @@ subroutine define_restart_vars(this, initialize_variables) units = '/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_asmort_co ) + call this%set_restart_var(vname='fates_dgmort', vtype=cohort_r8, & + long_name='ed cohort - damage mortality rate', & + units = '/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dgmort_co ) + call this%set_restart_var(vname='fates_lmort_direct', vtype=cohort_r8, & long_name='ed cohort - directly logging mortality rate', & units='%/event', flushval = flushzero, & @@ -1172,7 +1206,6 @@ subroutine define_restart_vars(this, initialize_variables) units='0/1', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_area_pft_sift) - call this%set_restart_var(vname='fates_fmortrate_canopy', vtype=cohort_r8, & long_name='fates diagnostics on fire mortality canopy', & units='indiv/ha/year', flushval = flushzero, & @@ -1187,7 +1220,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates diagnostics on impact mortality', & units='indiv/ha/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_imortrate_siscpf) - + call this%set_restart_var(vname='fates_fmortrate_crown', vtype=cohort_r8, & long_name='fates diagnostics on crown fire mortality', & units='indiv/ha/year', flushval = flushzero, & @@ -1228,6 +1261,11 @@ subroutine define_restart_vars(this, initialize_variables) units='kgC/ha/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_imortcflux_sipft) + call this%set_restart_var(vname='fates_imortcarea', vtype=site_r8, & + long_name='crownarea of indivs killed due to impact mort', & + units='m2/ha/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_imortcarea_si) + call this%set_restart_var(vname='fates_fmortcflux_canopy', vtype=cohort_r8, & long_name='fates diagnostic biomass of canopy fire', & units='gC/m2/sec', flushval = flushzero, & @@ -1258,6 +1296,86 @@ subroutine define_restart_vars(this, initialize_variables) units='', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_promcflux_si ) + call this%set_restart_var(vname='fates_fmortcarea_canopy', vtype=site_r8, & + long_name='fates diagnostic crownarea of canopy fire', & + units='m2/sec', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fmortcarea_cano_si) + + call this%set_restart_var(vname='fates_fmortcarea_ustory', vtype=site_r8, & + long_name='fates diagnostic crownarea of understory fire', & + units='m2/sec', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fmortcarea_usto_si) + + call this%set_restart_var(vname='fates_termcarea_canopy', vtype=site_r8, & + long_name='fates diagnostic term crownarea canopy', & + units='', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_termcarea_cano_si ) + + call this%set_restart_var(vname='fates_termcarea_ustory', vtype=site_r8, & + long_name='fates diagnostic term crownarea understory', & + units='', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_termcarea_usto_si ) + + ! Damage variables + call this%set_restart_var(vname='fates_imortrate_dam', vtype=cohort_r8, & + long_name='fates diagnostics on impact mortality by damage class', & + units='indiv/ha/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_imortrate_sicdpf) + + call this%set_restart_var(vname='fates_termn_cano_dam', vtype=cohort_r8, & + long_name='fates diagnostics on termination mortality by damage class -canopy', & + units='indiv/ha/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_termnindiv_cano_sicdpf) + + call this%set_restart_var(vname='fates_termn_usto_dam', vtype=cohort_r8, & + long_name='fates diagnostics on termination mortality by damage class -understory', & + units='indiv/ha/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_termnindiv_usto_sicdpf) + + call this%set_restart_var(vname='fates_fmortrate_cano_dam', vtype=cohort_r8, & + long_name='fates diagnostics on fire mortality by damage class', & + units='indiv/ha/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fmortrate_cano_sicdpf) + + call this%set_restart_var(vname='fates_fmortrate_usto_dam', vtype=cohort_r8, & + long_name='fates diagnostics on fire mortality by damage class', & + units='indiv/ha/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fmortrate_usto_sicdpf) + + call this%set_restart_var(vname='fates_imortcflux_dam', vtype=cohort_r8, & + long_name='biomass of indivs killed due to impact mort by damage class', & + units='kgC/ha/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_imortcflux_sicdsc) + + call this%set_restart_var(vname='fates_termcflux_cano_dam', vtype=cohort_r8, & + long_name='biomass of indivs killed due to termination mort by damage class', & + units='kgC/ha/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_termcflux_cano_sicdsc) + + call this%set_restart_var(vname='fates_termcflux_usto_dam', vtype=cohort_r8, & + long_name='biomass of indivs killed due to termination mort by damage class', & + units='kgC/ha/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_termcflux_usto_sicdsc) + + call this%set_restart_var(vname='fates_fmortcflux_cano_dam', vtype=cohort_r8, & + long_name='biomass of indivs killed due to fire mort by damage class', & + units='kgC/ha/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fmortcflux_cano_sicdsc) + + call this%set_restart_var(vname='fates_fmortcflux_usto_dam', vtype=cohort_r8, & + long_name='biomass of indivs killed due to fire mort by damage class', & + units='kgC/ha/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fmortcflux_usto_sicdsc) + + call this%set_restart_var(vname='fates_crownarea_canopy_damage', vtype=site_r8, & + long_name='fates area lost from damage each year', & + units='m2/ha/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_crownarea_cano_si) + + call this%set_restart_var(vname='fates_crownarea_understory_damage', vtype=site_r8, & + long_name='fates area lost from damage each year', & + units='m2/ha/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_crownarea_usto_si) call this%DefineRMeanRestartVar(vname='fates_tveg24patch',vtype=cohort_r8, & long_name='24-hour patch veg temp', & @@ -1673,6 +1791,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) use EDTypesMod, only : nclmax use EDTypesMod, only : numWaterMem use EDTypesMod, only : num_vegtemp_mem + use FatesInterfaceTypesMod, only : nlevdamage ! Arguments class(fates_restart_interface_type) :: this @@ -1707,6 +1826,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) integer :: io_idx_si_sc ! each size-class index within site integer :: io_idx_si_capf ! each cohort age-class x pft index within site integer :: io_idx_si_cacls ! each cohort age class index within site + integer :: io_idx_si_cdsc ! each damage-class x size class within site + integer :: io_idx_si_cdpf ! each damage-class x size x pft within site 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 @@ -1730,7 +1851,10 @@ subroutine set_restart_vectors(this,nc,nsites,sites) integer :: i_cacls ! loop counter for cohort age class integer :: i_cwd ! loop counter for cwd integer :: i_pft ! loop counter for pft - + integer :: i_cdam ! loop counter for damage + integer :: icdi ! loop counter for damage + integer :: icdj ! loop counter for damage + type(fates_restart_variable_type) :: rvar type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort @@ -1756,6 +1880,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_solar_zenith_angle_pa => this%rvars(ir_solar_zenith_angle_pa)%r81d, & rio_canopy_layer_co => this%rvars(ir_canopy_layer_co)%int1d, & rio_canopy_layer_yesterday_co => this%rvars(ir_canopy_layer_yesterday_co)%r81d, & + rio_crowndamage_co => this%rvars(ir_crowndamage_co)%int1d, & rio_canopy_trim_co => this%rvars(ir_canopy_trim_co)%r81d, & rio_seed_prod_co => this%rvars(ir_seed_prod_co)%r81d, & rio_size_class_lasttimestep => this%rvars(ir_size_class_lasttimestep_co)%int1d, & @@ -1786,6 +1911,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_daily_p_need_co => this%rvars(ir_daily_p_need_co)%r81d, & rio_smort_co => this%rvars(ir_smort_co)%r81d, & rio_asmort_co => this%rvars(ir_asmort_co)%r81d, & + rio_dgmort_co => this%rvars(ir_dgmort_co)%r81d, & rio_frmort_co => this%rvars(ir_frmort_co)%r81d, & rio_lmort_direct_co => this%rvars(ir_lmort_direct_co)%r81d, & rio_lmort_collateral_co => this%rvars(ir_lmort_collateral_co)%r81d, & @@ -1819,15 +1945,32 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_growflx_fusion_siscpf => this%rvars(ir_growflx_fusion_siscpf)%r81d, & rio_demorate_sisc => this%rvars(ir_demorate_sisc)%r81d, & rio_promrate_sisc => this%rvars(ir_promrate_sisc)%r81d, & + rio_termcarea_cano_si => this%rvars(ir_termcarea_cano_si)%r81d, & + rio_termcarea_usto_si => this%rvars(ir_termcarea_usto_si)%r81d, & + + rio_imortcarea_si => this%rvars(ir_imortcarea_si)%r81d, & + rio_fmortcarea_cano_si => this%rvars(ir_fmortcarea_cano_si)%r81d, & + rio_fmortcarea_usto_si => this%rvars(ir_fmortcarea_usto_si)%r81d, & rio_termcflux_cano_sipft => this%rvars(ir_termcflux_cano_sipft)%r81d, & rio_termcflux_usto_sipft => this%rvars(ir_termcflux_usto_sipft)%r81d, & rio_democflux_si => this%rvars(ir_democflux_si)%r81d, & rio_promcflux_si => this%rvars(ir_promcflux_si)%r81d, & rio_imortcflux_sipft => this%rvars(ir_imortcflux_sipft)%r81d, & rio_fmortcflux_cano_sipft => this%rvars(ir_fmortcflux_cano_sipft)%r81d, & - rio_fmortcflux_usto_sipft => this%rvars(ir_fmortcflux_usto_sipft)%r81d) - - + rio_fmortcflux_usto_sipft => this%rvars(ir_fmortcflux_usto_sipft)%r81d, & + rio_imortrate_sicdpf => this%rvars(ir_imortrate_sicdpf)%r81d, & + rio_imortcflux_sicdsc => this%rvars(ir_imortcflux_sicdsc)%r81d, & + rio_termcflux_cano_sicdsc => this%rvars(ir_termcflux_cano_sicdsc)%r81d, & + rio_termnindiv_cano_sicdpf => this%rvars(ir_termnindiv_cano_sicdpf)%r81d, & + rio_termcflux_usto_sicdsc => this%rvars(ir_termcflux_usto_sicdsc)%r81d, & + rio_termnindiv_usto_sicdpf => this%rvars(ir_termnindiv_usto_sicdpf)%r81d, & + rio_fmortrate_cano_sicdpf => this%rvars(ir_fmortrate_cano_sicdpf)%r81d, & + rio_fmortrate_usto_sicdpf => this%rvars(ir_fmortrate_usto_sicdpf)%r81d, & + rio_fmortcflux_cano_sicdsc => this%rvars(ir_fmortcflux_cano_sicdsc)%r81d, & + rio_fmortcflux_usto_sicdsc => this%rvars(ir_fmortcflux_usto_sicdsc)%r81d, & + rio_crownarea_cano_damage_si=> this%rvars(ir_crownarea_cano_si)%r81d, & + rio_crownarea_usto_damage_si=> this%rvars(ir_crownarea_usto_si)%r81d) + totalCohorts = 0 ! --------------------------------------------------------------------------------- @@ -1857,6 +2000,8 @@ 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 + io_idx_si_cdsc = io_idx_co_1st + io_idx_si_cdpf = io_idx_co_1st ! recruitment rate do i_pft = 1,numpft @@ -1983,6 +2128,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_canopy_layer_co(io_idx_co) = ccohort%canopy_layer rio_canopy_layer_yesterday_co(io_idx_co) = ccohort%canopy_layer_yesterday + rio_crowndamage_co(io_idx_co) = ccohort%crowndamage rio_canopy_trim_co(io_idx_co) = ccohort%canopy_trim rio_seed_prod_co(io_idx_co) = ccohort%seed_prod rio_size_class_lasttimestep(io_idx_co) = ccohort%size_class_lasttimestep @@ -2005,7 +2151,8 @@ 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_dgmort_co(io_idx_co) = ccohort%dgmort + rio_frmort_co(io_idx_co) = ccohort%frmort ! Nutrient uptake/efflux rio_daily_no3_uptake_co(io_idx_co) = ccohort%daily_no3_uptake @@ -2207,7 +2354,39 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_sc = io_idx_si_sc + 1 end do + rio_termcarea_cano_si(io_idx_si) = sites(s)%term_crownarea_canopy + rio_termcarea_usto_si(io_idx_si) = sites(s)%term_crownarea_ustory + + ! this only copies live portions of transitions - but that's ok because the mortality + ! bit only needs to be added for history outputs + if(hlm_use_tree_damage .eq. itrue) then + + do i_scls = 1, nlevsclass + do i_cdam = 1, nlevdamage + do i_pft = 1, numpft + rio_imortrate_sicdpf(io_idx_si_cdpf) = sites(s)%imort_rate_damage(i_cdam, i_scls, i_pft) + rio_termnindiv_cano_sicdpf(io_idx_si_cdpf) = sites(s)%term_nindivs_canopy_damage(i_cdam,i_scls,i_pft) + rio_termnindiv_usto_sicdpf(io_idx_si_cdpf) = sites(s)%term_nindivs_ustory_damage(i_cdam,i_scls,i_pft) + rio_imortcflux_sicdsc(io_idx_si_cdsc) = sites(s)%imort_cflux_damage(i_cdam, i_scls) + rio_termcflux_cano_sicdsc(io_idx_si_cdsc) = sites(s)%term_cflux_canopy_damage(i_cdam, i_scls) + rio_termcflux_usto_sicdsc(io_idx_si_cdsc) = sites(s)%term_cflux_ustory_damage(i_cdam, i_scls) + rio_fmortrate_cano_sicdpf(io_idx_si_cdpf) = sites(s)%fmort_rate_canopy_damage(i_cdam, i_scls, i_pft) + rio_fmortrate_usto_sicdpf(io_idx_si_cdpf) = sites(s)%fmort_rate_ustory_damage(i_cdam, i_scls, i_pft) + rio_fmortcflux_cano_sicdsc(io_idx_si_cdsc) = sites(s)%fmort_cflux_canopy_damage(i_cdam, i_scls) + rio_fmortcflux_usto_sicdsc(io_idx_si_cdsc) = sites(s)%fmort_cflux_ustory_damage(i_cdam, i_scls) + io_idx_si_cdsc = io_idx_si_cdsc + 1 + io_idx_si_cdpf = io_idx_si_cdpf + 1 + end do + end do + end do + + rio_crownarea_cano_damage_si(io_idx_si) = sites(s)%crownarea_canopy_damage + rio_crownarea_usto_damage_si(io_idx_si) = sites(s)%crownarea_ustory_damage + + end if + + rio_democflux_si(io_idx_si) = sites(s)%demotion_carbonflux rio_promcflux_si(io_idx_si) = sites(s)%promotion_carbonflux @@ -2217,12 +2396,14 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_termcflux_usto_sipft(io_idx_si_pft) = sites(s)%term_carbonflux_ustory(i_pft) rio_fmortcflux_cano_sipft(io_idx_si_pft) = sites(s)%fmort_carbonflux_canopy(i_pft) rio_fmortcflux_usto_sipft(io_idx_si_pft) = sites(s)%fmort_carbonflux_ustory(i_pft) - rio_imortcflux_sipft(io_idx_si_pft) = sites(s)%imort_carbonflux(i_pft) - io_idx_si_pft = io_idx_si_pft + 1 end do + rio_imortcarea_si(io_idx_si) = sites(s)%imort_crownarea + rio_fmortcarea_cano_si(io_idx_si) = sites(s)%fmort_crownarea_canopy + rio_fmortcarea_usto_si(io_idx_si) = sites(s)%fmort_crownarea_ustory + rio_cd_status_si(io_idx_si) = sites(s)%cstatus rio_dd_status_si(io_idx_si) = sites(s)%dstatus rio_nchill_days_si(io_idx_si) = sites(s)%nchilldays @@ -2508,7 +2689,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) use EDTypesMod, only : numWaterMem use EDTypesMod, only : num_vegtemp_mem use FatesSizeAgeTypeIndicesMod, only : get_age_class_index - + ! !ARGUMENTS: class(fates_restart_interface_type) , intent(inout) :: this integer , intent(in) :: nc @@ -2551,6 +2732,9 @@ 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_si_cdsc ! each damage x size class within site + integer :: io_idx_si_cdpf ! damage x size x pft within site + integer :: io_idx_pa_ncl ! each canopy layer within each patch ! Some counters (for checking mostly) @@ -2568,6 +2752,9 @@ subroutine get_restart_vectors(this, nc, nsites, sites) integer :: i_pft ! loop counter for pft integer :: i_scls ! loop counter for size-clas integer :: i_cacls ! loop counter for cohort age class + integer :: i_cdam ! loop counter for damage class + integer :: icdj ! loop counter for damage class + integer :: icdi ! loop counter for damage class associate( rio_npatch_si => this%rvars(ir_npatch_si)%int1d, & rio_cd_status_si => this%rvars(ir_cd_status_si)%int1d, & @@ -2589,6 +2776,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_solar_zenith_angle_pa => this%rvars(ir_solar_zenith_angle_pa)%r81d, & rio_canopy_layer_co => this%rvars(ir_canopy_layer_co)%int1d, & rio_canopy_layer_yesterday_co => this%rvars(ir_canopy_layer_yesterday_co)%r81d, & + rio_crowndamage_co => this%rvars(ir_crowndamage_co)%int1d, & rio_canopy_trim_co => this%rvars(ir_canopy_trim_co)%r81d, & rio_seed_prod_co => this%rvars(ir_seed_prod_co)%r81d, & rio_size_class_lasttimestep => this%rvars(ir_size_class_lasttimestep_co)%int1d, & @@ -2619,6 +2807,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_daily_p_need_co => this%rvars(ir_daily_p_need_co)%r81d, & rio_smort_co => this%rvars(ir_smort_co)%r81d, & rio_asmort_co => this%rvars(ir_asmort_co)%r81d, & + rio_dgmort_co => this%rvars(ir_dgmort_co)%r81d, & rio_frmort_co => this%rvars(ir_frmort_co)%r81d, & rio_lmort_direct_co => this%rvars(ir_lmort_direct_co)%r81d, & rio_lmort_collateral_co => this%rvars(ir_lmort_collateral_co)%r81d, & @@ -2656,6 +2845,23 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_termcflux_usto_sipft => this%rvars(ir_termcflux_usto_sipft)%r81d, & rio_democflux_si => this%rvars(ir_democflux_si)%r81d, & rio_promcflux_si => this%rvars(ir_promcflux_si)%r81d, & + rio_termcarea_cano_si => this%rvars(ir_termcarea_cano_si)%r81d, & + rio_termcarea_usto_si => this%rvars(ir_termcarea_usto_si)%r81d, & + rio_imortcarea_si => this%rvars(ir_imortcarea_si)%r81d, & + rio_fmortcarea_cano_si => this%rvars(ir_fmortcarea_cano_si)%r81d, & + rio_fmortcarea_usto_si => this%rvars(ir_fmortcarea_usto_si)%r81d, & + rio_imortrate_sicdpf => this%rvars(ir_imortrate_sicdpf)%r81d, & + rio_termnindiv_cano_sicdpf => this%rvars(ir_termnindiv_cano_sicdpf)%r81d, & + rio_termnindiv_usto_sicdpf => this%rvars(ir_termnindiv_usto_sicdpf)%r81d, & + rio_imortcflux_sicdsc => this%rvars(ir_imortcflux_sicdsc)%r81d, & + rio_termcflux_cano_sicdsc => this%rvars(ir_termcflux_cano_sicdsc)%r81d, & + rio_termcflux_usto_sicdsc => this%rvars(ir_termcflux_usto_sicdsc)%r81d, & + rio_fmortrate_cano_sicdpf => this%rvars(ir_fmortrate_cano_sicdpf)%r81d, & + rio_fmortrate_usto_sicdpf => this%rvars(ir_fmortrate_usto_sicdpf)%r81d, & + rio_fmortcflux_cano_sicdsc => this%rvars(ir_fmortcflux_cano_sicdsc)%r81d, & + rio_fmortcflux_usto_sicdsc => this%rvars(ir_fmortcflux_usto_sicdsc)%r81d, & + rio_crownarea_cano_damage_si=> this%rvars(ir_crownarea_cano_si)%r81d, & + rio_crownarea_usto_damage_si=> this%rvars(ir_crownarea_usto_si)%r81d, & rio_imortcflux_sipft => this%rvars(ir_imortcflux_sipft)%r81d, & rio_fmortcflux_cano_sipft => this%rvars(ir_fmortcflux_cano_sipft)%r81d, & rio_fmortcflux_usto_sipft => this%rvars(ir_fmortcflux_usto_sipft)%r81d) @@ -2681,7 +2887,9 @@ 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 - + io_idx_si_cdsc = io_idx_co_1st + io_idx_si_cdpf = io_idx_co_1st + ! read seed_bank info(site-level, but PFT-resolved) do i_pft = 1,numpft sites(s)%recruitment_rate(i_pft) = rio_recrate_sift(io_idx_co_1st+i_pft-1) @@ -2797,6 +3005,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%canopy_layer = rio_canopy_layer_co(io_idx_co) ccohort%canopy_layer_yesterday = rio_canopy_layer_yesterday_co(io_idx_co) + ccohort%crowndamage = rio_crowndamage_co(io_idx_co) ccohort%canopy_trim = rio_canopy_trim_co(io_idx_co) ccohort%seed_prod = rio_seed_prod_co(io_idx_co) ccohort%size_class_lasttimestep = rio_size_class_lasttimestep(io_idx_co) @@ -2818,6 +3027,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%cmort = rio_cmort_co(io_idx_co) ccohort%smort = rio_smort_co(io_idx_co) ccohort%asmort = rio_asmort_co(io_idx_co) + ccohort%dgmort = rio_dgmort_co(io_idx_co) ccohort%frmort = rio_frmort_co(io_idx_co) ! Nutrient uptake / efflux @@ -3076,7 +3286,38 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_sc = io_idx_si_sc + 1 end do + + if (hlm_use_tree_damage .eq. itrue) then + do i_cdam = 1, nlevdamage + do i_pft = 1, numpft + do i_scls = 1, nlevsclass + sites(s)%imort_rate_damage(i_cdam, i_scls, i_pft) = rio_imortrate_sicdpf(io_idx_si_cdpf) + sites(s)%term_nindivs_canopy_damage(i_cdam,i_scls,i_pft) = rio_termnindiv_cano_sicdpf(io_idx_si_cdpf) + sites(s)%term_nindivs_ustory_damage(i_cdam,i_scls,i_pft) = rio_termnindiv_usto_sicdpf(io_idx_si_cdpf) + sites(s)%imort_cflux_damage(i_cdam, i_scls) = rio_imortcflux_sicdsc(io_idx_si_cdsc) + sites(s)%term_cflux_canopy_damage(i_cdam, i_scls) = rio_termcflux_cano_sicdsc(io_idx_si_cdsc) + sites(s)%term_cflux_ustory_damage(i_cdam, i_scls) = rio_termcflux_usto_sicdsc(io_idx_si_cdsc) + sites(s)%fmort_rate_canopy_damage(i_cdam, i_scls, i_pft) = rio_fmortrate_cano_sicdpf(io_idx_si_cdpf) + sites(s)%fmort_rate_ustory_damage(i_cdam, i_scls, i_pft) = rio_fmortrate_usto_sicdpf(io_idx_si_cdpf) + sites(s)%fmort_cflux_canopy_damage(i_cdam, i_scls) = rio_fmortcflux_cano_sicdsc(io_idx_si_cdsc) + sites(s)%fmort_cflux_ustory_damage(i_cdam, i_scls) = rio_fmortcflux_usto_sicdsc(io_idx_si_cdsc) + io_idx_si_cdsc = io_idx_si_cdsc + 1 + io_idx_si_cdpf = io_idx_si_cdpf + 1 + end do + end do + end do + + sites(s)%crownarea_canopy_damage = rio_crownarea_cano_damage_si(io_idx_si) + sites(s)%crownarea_ustory_damage = rio_crownarea_usto_damage_si(io_idx_si) + + end if + + sites(s)%term_crownarea_canopy = rio_termcarea_cano_si(io_idx_si) + sites(s)%term_crownarea_ustory = rio_termcarea_usto_si(io_idx_si) + sites(s)%imort_crownarea = rio_imortcarea_si(io_idx_si) + sites(s)%fmort_crownarea_canopy = rio_fmortcarea_cano_si(io_idx_si) + sites(s)%fmort_crownarea_ustory = rio_fmortcarea_usto_si(io_idx_si) sites(s)%demotion_carbonflux = rio_democflux_si(io_idx_si) sites(s)%promotion_carbonflux = rio_promcflux_si(io_idx_si) diff --git a/main/FatesSizeAgeTypeIndicesMod.F90 b/main/FatesSizeAgeTypeIndicesMod.F90 index d624db1e24..66e3edab28 100644 --- a/main/FatesSizeAgeTypeIndicesMod.F90 +++ b/main/FatesSizeAgeTypeIndicesMod.F90 @@ -1,15 +1,18 @@ module FatesSizeAgeTypeIndicesMod use FatesConstantsMod, only : r8 => fates_r8 + use FatesInterfaceTypesMod, only : nlevsclass use FatesInterfaceTypesMod, only : nlevage use FatesInterfaceTypesMod, only : nlevheight use FatesInterfaceTypesMod, only : nlevcoage + use FatesInterfaceTypesMod, only : nlevdamage use EDParamsMod, only : ED_val_history_sizeclass_bin_edges use EDParamsMod, only : ED_val_history_ageclass_bin_edges use EDParamsMod, only : ED_val_history_height_bin_edges use EDParamsMod, only : ED_val_history_coageclass_bin_edges - + use EDParamsMod, only : ED_val_history_damage_bin_edges + implicit none private ! Modules are private by default @@ -21,6 +24,8 @@ module FatesSizeAgeTypeIndicesMod public :: get_height_index public :: get_sizeagepft_class_index public :: get_agepft_class_index + public :: get_cdamagesize_class_index + public :: get_cdamagesizepft_class_index public :: coagetype_class_index public :: get_coage_class_index public :: get_agefuel_class_index @@ -39,7 +44,8 @@ function get_age_class_index(age) result( patch_age_class ) end function get_age_class_index - ! ===================================================================================== + ! ===================================================================================== + function get_sizeage_class_index(dbh,age) result(size_by_age_class) @@ -59,6 +65,25 @@ function get_sizeage_class_index(dbh,age) result(size_by_age_class) end function get_sizeage_class_index + !====================================================================================== + + + function get_cdamagesize_class_index(dbh,cdamage) result(cdamage_by_size_class) + + ! Arguments + real(r8),intent(in) :: dbh + integer,intent(in) :: cdamage + + integer :: size_class + integer :: cdamage_by_size_class + + size_class = get_size_class_index(dbh) + + cdamage_by_size_class = (cdamage-1)*nlevsclass + size_class + + end function get_cdamagesize_class_index + + ! ===================================================================================== subroutine sizetype_class_index(dbh,pft,size_class,size_by_pft_class) @@ -153,6 +178,25 @@ function get_sizeagepft_class_index(dbh,age,pft) result(size_by_age_by_pft_class end function get_sizeagepft_class_index + ! ===================================================================================== + + function get_cdamagesizepft_class_index(dbh,cdamage,pft) result(cdamage_by_size_by_pft_class) + + ! Arguments + real(r8),intent(in) :: dbh + integer,intent(in) :: cdamage + integer,intent(in) :: pft + + integer :: size_class + integer :: cdamage_by_size_by_pft_class + + size_class = get_size_class_index(dbh) + + cdamage_by_size_by_pft_class = (cdamage-1)*nlevsclass + size_class + & + (pft-1) * nlevsclass * nlevdamage + + end function get_cdamagesizepft_class_index + ! ===================================================================================== function get_agepft_class_index(age,pft) result(age_by_pft_class) diff --git a/parameter_files/patch_default_bciopt224.xml b/parameter_files/patch_default_bciopt224.xml index bfcc288efa..635f634d11 100644 --- a/parameter_files/patch_default_bciopt224.xml +++ b/parameter_files/patch_default_bciopt224.xml @@ -5,48 +5,46 @@ 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 + 0 + 0 + 1,1,3,4 + 0.03347526,0.024,1e-08,0.0047 + 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/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 index 2a18d6d370..d640797e6f 100644 --- a/parteh/PRTAllometricCNPMod.F90 +++ b/parteh/PRTAllometricCNPMod.F90 @@ -139,6 +139,7 @@ module PRTAllometricCNPMod integer, public, parameter :: acnp_bc_inout_id_dbh = 1 ! Plant DBH integer, public, parameter :: acnp_bc_inout_id_rmaint_def = 2 ! Index for any accumulated ! maintenance respiration deficit + integer, public, parameter :: num_bc_inout = 2 ! ------------------------------------------------------------------------------------- @@ -152,9 +153,10 @@ module PRTAllometricCNPMod 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 + integer, public, parameter :: acnp_bc_in_id_cdamage = 8 ! Index for the crowndamage input BC ! 0=leaf off, 1=leaf on - integer, parameter :: num_bc_in = 7 + integer, parameter :: num_bc_in = 8 ! ------------------------------------------------------------------------------------- ! Output Boundary Indices (These are public) @@ -245,98 +247,100 @@ module PRTAllometricCNPMod subroutine InitPRTGlobalAllometricCNP() - ! ---------------------------------------------------------------------------------- - ! Initialize and populate the general mapping table that - ! organizes the specific variables in this module to - ! pre-ordained groups, so they can be used to inform - ! the rest of the model - ! - ! This routine is not part of the sp_pool_vartypes class - ! because it is the same for all plants and we need not - ! waste memory on it. - ! ----------------------------------------------------------------------------------- + ! ---------------------------------------------------------------------------------- + ! Initialize and populate the general mapping table that + ! organizes the specific variables in this module to + ! pre-ordained groups, so they can be used to inform + ! the rest of the model + ! + ! This routine is not part of the sp_pool_vartypes class + ! because it is the same for all plants and we need not + ! waste memory on it. + ! ----------------------------------------------------------------------------------- - integer :: nleafage + integer :: nleafage - allocate(prt_global_acnp) - allocate(prt_global_acnp%state_descriptor(num_vars)) + allocate(prt_global_acnp) + allocate(prt_global_acnp%state_descriptor(num_vars)) - prt_global_acnp%hyp_name = 'Allometric Flexible C+N+P' + prt_global_acnp%hyp_name = 'Allometric Flexible C+N+P' - prt_global_acnp%hyp_id = prt_cnp_flex_allom_hyp + prt_global_acnp%hyp_id = prt_cnp_flex_allom_hyp - call prt_global_acnp%ZeroGlobal() + call prt_global_acnp%ZeroGlobal() - ! The number of leaf age classes can be determined from the parameter file, - ! notably the size of the leaf-longevity parameter's second dimension. - ! This is the same value in FatesInterfaceMod.F90 + ! The number of leaf age classes can be determined from the parameter file, + ! notably the size of the leaf-longevity parameter's second dimension. + ! This is the same value in FatesInterfaceMod.F90 - nleafage = size(prt_params%leaf_long,dim=2) + nleafage = size(prt_params%leaf_long,dim=2) - if(nleafage>max_nleafage) then - write(fates_log(),*) 'The allometric carbon PARTEH hypothesis' - write(fates_log(),*) 'sets a maximum number of leaf age classes' - write(fates_log(),*) 'used for scratch space. The model wants' - write(fates_log(),*) 'exceed that. Simply increase max_nleafage' - write(fates_log(),*) 'found in parteh/PRTAllometricCarbonMod.F90' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + if(nleafage>max_nleafage) then + write(fates_log(),*) 'The allometric carbon PARTEH hypothesis' + write(fates_log(),*) 'sets a maximum number of leaf age classes' + write(fates_log(),*) 'used for scratch space. The model wants' + write(fates_log(),*) 'exceed that. Simply increase max_nleafage' + write(fates_log(),*) 'found in parteh/PRTAllometricCarbonMod.F90' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - call prt_global_acnp%RegisterVarInGlobal(leaf_c_id,'Leaf Carbon','leaf_c',leaf_organ,carbon12_element,nleafage) - call prt_global_acnp%RegisterVarInGlobal(fnrt_c_id,'Fine Root Carbon','fnrt_c',fnrt_organ,carbon12_element,icd) - call prt_global_acnp%RegisterVarInGlobal(sapw_c_id,'Sapwood Carbon','sapw_c',sapw_organ,carbon12_element,icd) - call prt_global_acnp%RegisterVarInGlobal(store_c_id,'Storage Carbon','store_c',store_organ,carbon12_element,icd) - call prt_global_acnp%RegisterVarInGlobal(struct_c_id,'Structural Carbon','struct_c',struct_organ,carbon12_element,icd) - call prt_global_acnp%RegisterVarInGlobal(repro_c_id,'Reproductive Carbon','repro_c',repro_organ,carbon12_element,icd) + call prt_global_acnp%RegisterVarInGlobal(leaf_c_id,'Leaf Carbon','leaf_c',leaf_organ,carbon12_element,nleafage) + call prt_global_acnp%RegisterVarInGlobal(fnrt_c_id,'Fine Root Carbon','fnrt_c',fnrt_organ,carbon12_element,icd) + call prt_global_acnp%RegisterVarInGlobal(sapw_c_id,'Sapwood Carbon','sapw_c',sapw_organ,carbon12_element,icd) + call prt_global_acnp%RegisterVarInGlobal(store_c_id,'Storage Carbon','store_c',store_organ,carbon12_element,icd) + call prt_global_acnp%RegisterVarInGlobal(struct_c_id,'Structural Carbon','struct_c',struct_organ,carbon12_element,icd) + call prt_global_acnp%RegisterVarInGlobal(repro_c_id,'Reproductive Carbon','repro_c',repro_organ,carbon12_element,icd) - call prt_global_acnp%RegisterVarInGlobal(leaf_n_id,'Leaf Nitrogen','leaf_n',leaf_organ,nitrogen_element,nleafage) - call prt_global_acnp%RegisterVarInGlobal(fnrt_n_id,'Fine Root Nitrogen','fnrt_n',fnrt_organ,nitrogen_element,icd) - call prt_global_acnp%RegisterVarInGlobal(sapw_n_id,'Sapwood Nitrogen','sapw_n',sapw_organ,nitrogen_element,icd) - call prt_global_acnp%RegisterVarInGlobal(store_n_id,'Storage Nitrogen','store_n',store_organ,nitrogen_element,icd) - call prt_global_acnp%RegisterVarInGlobal(struct_n_id,'Structural Nitrogen','struct_n',struct_organ,nitrogen_element,icd) - call prt_global_acnp%RegisterVarInGlobal(repro_n_id,'Reproductive Nitrogen','repro_n',repro_organ,nitrogen_element,icd) + call prt_global_acnp%RegisterVarInGlobal(leaf_n_id,'Leaf Nitrogen','leaf_n',leaf_organ,nitrogen_element,nleafage) + call prt_global_acnp%RegisterVarInGlobal(fnrt_n_id,'Fine Root Nitrogen','fnrt_n',fnrt_organ,nitrogen_element,icd) + call prt_global_acnp%RegisterVarInGlobal(sapw_n_id,'Sapwood Nitrogen','sapw_n',sapw_organ,nitrogen_element,icd) + call prt_global_acnp%RegisterVarInGlobal(store_n_id,'Storage Nitrogen','store_n',store_organ,nitrogen_element,icd) + call prt_global_acnp%RegisterVarInGlobal(struct_n_id,'Structural Nitrogen','struct_n',struct_organ,nitrogen_element,icd) + call prt_global_acnp%RegisterVarInGlobal(repro_n_id,'Reproductive Nitrogen','repro_n',repro_organ,nitrogen_element,icd) - call prt_global_acnp%RegisterVarInGlobal(leaf_p_id,'Leaf Phosphorus','leaf_p',leaf_organ,phosphorus_element,nleafage) - call prt_global_acnp%RegisterVarInGlobal(fnrt_p_id,'Fine Root Phosphorus','fnrt_p',fnrt_organ,phosphorus_element,icd) - call prt_global_acnp%RegisterVarInGlobal(sapw_p_id,'Sapwood Phosphorus','sapw_p',sapw_organ,phosphorus_element,icd) - call prt_global_acnp%RegisterVarInGlobal(store_p_id,'Storage Phosphorus','store_p',store_organ,phosphorus_element,icd) - call prt_global_acnp%RegisterVarInGlobal(struct_p_id,'Structural Phosphorus','struct_p',struct_organ,phosphorus_element,icd) - call prt_global_acnp%RegisterVarInGlobal(repro_p_id,'Reproductive Phosphorus','repro_p',repro_organ,phosphorus_element,icd) + call prt_global_acnp%RegisterVarInGlobal(leaf_p_id,'Leaf Phosphorus','leaf_p',leaf_organ,phosphorus_element,nleafage) + call prt_global_acnp%RegisterVarInGlobal(fnrt_p_id,'Fine Root Phosphorus','fnrt_p',fnrt_organ,phosphorus_element,icd) + call prt_global_acnp%RegisterVarInGlobal(sapw_p_id,'Sapwood Phosphorus','sapw_p',sapw_organ,phosphorus_element,icd) + call prt_global_acnp%RegisterVarInGlobal(store_p_id,'Storage Phosphorus','store_p',store_organ,phosphorus_element,icd) + call prt_global_acnp%RegisterVarInGlobal(struct_p_id,'Structural Phosphorus','struct_p',struct_organ,phosphorus_element,icd) + call prt_global_acnp%RegisterVarInGlobal(repro_p_id,'Reproductive Phosphorus','repro_p',repro_organ,phosphorus_element,icd) - ! Set some of the array sizes for input and output boundary conditions - prt_global_acnp%num_bc_in = num_bc_in - prt_global_acnp%num_bc_out = num_bc_out - prt_global_acnp%num_bc_inout = num_bc_inout - prt_global_acnp%num_vars = num_vars + ! Set some of the array sizes for input and output boundary conditions + prt_global_acnp%num_bc_in = num_bc_in + prt_global_acnp%num_bc_out = num_bc_out + prt_global_acnp%num_bc_inout = num_bc_inout + prt_global_acnp%num_vars = num_vars - ! Have the global generic pointer, point to this hypothesis' object - prt_global => prt_global_acnp + ! Have the global generic pointer, point to this hypothesis' object + prt_global => prt_global_acnp - return + return end subroutine InitPRTGlobalAllometricCNP ! ===================================================================================== - subroutine DailyPRTAllometricCNP(this) + subroutine DailyPRTAllometricCNP(this,phase) class(cnp_allom_prt_vartypes) :: this - + integer,intent(in) :: phase + ! Pointers to in-out bcs real(r8),pointer :: dbh ! Diameter at breast height [cm] real(r8),pointer :: maint_r_def ! Current maintenance respiration deficit [kgC] - + ! Input only bcs integer :: ipft ! Plant Functional Type index real(r8) :: c_gain ! Daily carbon balance for this cohort [kgC] real(r8) :: n_gain ! Daily nitrogen uptake through fine-roots [kgN] real(r8) :: p_gain ! Daily phosphorus uptake through fine-roots [kgN] real(r8) :: canopy_trim ! The canopy trimming function [0-1] - + integer :: crown_damage ! which crown damage clas + ! Pointers to output bcs real(r8),pointer :: c_efflux ! Total plant efflux of carbon (kgC) real(r8),pointer :: n_efflux ! Total plant efflux of nitrogen (kgN) @@ -384,6 +388,14 @@ subroutine DailyPRTAllometricCNP(this) real(r8) :: target_n,target_p real(r8) :: sum_c ! error checking sum + + ! Right now FATES CNP is not compatable with tree damage + ! only simulate calls for phase 1 (ie call this once) + ! Compatability will be enabled with PR #880 + + if(phase>1)return + + ! integrator variables ! Copy the input only boundary conditions into readable local variables @@ -393,11 +405,12 @@ subroutine DailyPRTAllometricCNP(this) ! ----------------------------------------------------------------------------------- c_gain = this%bc_in(acnp_bc_in_id_netdc)%rval; c_gain0 = c_gain n_gain = this%bc_in(acnp_bc_in_id_netdnh4)%rval + & - this%bc_in(acnp_bc_in_id_netdno3)%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 + crown_damage = this%bc_in(acnp_bc_in_id_cdamage)%ival ! Output only boundary conditions c_efflux => this%bc_out(acnp_bc_out_id_cefflux)%rval; c_efflux = 0._r8 @@ -406,40 +419,39 @@ subroutine DailyPRTAllometricCNP(this) 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 dbh => this%bc_inout(acnp_bc_inout_id_dbh)%rval; dbh0 = dbh - - - - ! If more than 1 leaf age bin is present, this - ! call advances leaves in their age, but does - ! not actually remove any biomass from the plant - - call this%AgeLeaves(ipft,sec_per_day) - + + if(crown_damage>1)then + write(fates_log(),*) 'The crown damage model is incompatible with' + write(fates_log(),*) 'dynamic nutrients, ie parteh_mode=2' + write(fates_log(),*) 'This feature will be brought in in with CNP v2' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + ! Set all of the per-organ pointer arrays ! Note: Since growth only happens in the 1st leaf bin, we only ! point to that bin. However, we need to account for all bins ! when we calculate the deficit - + allocate(state_c(num_organs)) allocate(state_n(num_organs)) allocate(state_p(num_organs)) - + ! Set carbon targets based on the plant's current stature target_c(:) = fates_unset_r8 target_dcdd(:) = fates_unset_r8 - call bsap_allom(dbh,ipft,canopy_trim,sapw_area,target_c(sapw_id),target_dcdd(sapw_id) ) - call bagw_allom(dbh,ipft,agw_c_target,agw_dcdd_target) + call bsap_allom(dbh,ipft,crown_damage,canopy_trim,sapw_area,target_c(sapw_id),target_dcdd(sapw_id) ) + call bagw_allom(dbh,ipft,crown_damage,agw_c_target,agw_dcdd_target) call bbgw_allom(dbh,ipft,bgw_c_target,bgw_dcdd_target) call bdead_allom(agw_c_target,bgw_c_target, target_c(sapw_id), ipft, target_c(struct_id), & - agw_dcdd_target, bgw_dcdd_target, target_dcdd(sapw_id), target_dcdd(struct_id)) - call bleaf(dbh,ipft,canopy_trim, target_c(leaf_id), target_dcdd(leaf_id)) + agw_dcdd_target, bgw_dcdd_target, target_dcdd(sapw_id), target_dcdd(struct_id)) + call bleaf(dbh,ipft,crown_damage,canopy_trim, target_c(leaf_id), target_dcdd(leaf_id)) call bfineroot(dbh,ipft,canopy_trim, target_c(fnrt_id), target_dcdd(fnrt_id)) - call bstore_allom(dbh,ipft,canopy_trim, target_c(store_id), target_dcdd(store_id)) + call bstore_allom(dbh,ipft,crown_damage,canopy_trim, target_c(store_id), target_dcdd(store_id)) target_c(repro_id) = 0._r8 target_dcdd(repro_id) = 0._r8 @@ -460,7 +472,7 @@ subroutine DailyPRTAllometricCNP(this) i_var = prt_global%sp_organ_map(organ_list(i_org),phosphorus_element) state_p(i_org)%ptr => this%variables(i_var)%val(1) state_p0(i_org) = this%variables(i_var)%val(1) - + end do ! =================================================================================== @@ -477,21 +489,21 @@ subroutine DailyPRTAllometricCNP(this) i_var = prt_global%sp_organ_map(store_organ,phosphorus_element) 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. ! =================================================================================== - + call this%CNPPrioritizedReplacement(maint_r_def, c_gain, n_gain, p_gain, & - state_c, state_n, state_p, target_c) + state_c, state_n, state_p, target_c) sum_c = 0._r8 do i_org = 1,num_organs sum_c = sum_c+state_c(i_org)%ptr end do if( abs((c_gain0-c_gain) - & - (sum_c-sum(state_c0(:),dim=1)+(maint_r_def0-maint_r_def))) >calloc_abs_error ) then + (sum_c-sum(state_c0(:),dim=1)+(maint_r_def0-maint_r_def))) >calloc_abs_error ) then write(fates_log(),*) 'Carbon not balancing I' do i_org = 1,num_organs write(fates_log(),*) 'state_c: ',state_c(i_org)%ptr,state_c0(i_org) @@ -499,23 +511,24 @@ subroutine DailyPRTAllometricCNP(this) write(fates_log(),*) maint_r_def0-maint_r_def call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + + ! =================================================================================== ! 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, n_gain, p_gain, & state_c, state_n, state_p, target_c, target_dcdd, cnp_limiter) - + sum_c = 0._r8 do i_org = 1,num_organs sum_c = sum_c+state_c(i_org)%ptr end do if( abs((c_gain0-c_gain) - & - (sum_c-sum(state_c0(:),dim=1)+(maint_r_def0-maint_r_def))) >calloc_abs_error ) then + (sum_c-sum(state_c0(:),dim=1)+(maint_r_def0-maint_r_def))) >calloc_abs_error ) then write(fates_log(),*) 'Carbon not balanceing II' do i_org = 1,num_organs write(fates_log(),*) 'state_c: ',state_c(i_org)%ptr,state_c0(i_org) @@ -529,14 +542,14 @@ subroutine DailyPRTAllometricCNP(this) ! At this point, at least 1 of the 3 resources have been used up. ! Allocate the remaining resources, or as a last resort, efflux them. ! =================================================================================== - + call this%CNPAllocateRemainder(c_gain, n_gain, p_gain, & state_c, state_n, state_p, c_efflux, n_efflux, p_efflux) ! Error Check: Make sure that the mass gains are completely used up if( abs(c_gain) > calloc_abs_error .or. & - abs(n_gain) > 0.1_r8*calloc_abs_error .or. & - abs(p_gain) > 0.02_r8*calloc_abs_error ) then + abs(n_gain) > 0.1_r8*calloc_abs_error .or. & + abs(p_gain) > 0.02_r8*calloc_abs_error ) then write(fates_log(),*) 'Allocation scheme should had used up all mass gain pools' write(fates_log(),*) 'Any mass that cannot be allocated should be effluxed' write(fates_log(),*) 'c_gain: ',c_gain @@ -550,39 +563,40 @@ subroutine DailyPRTAllometricCNP(this) ! Since this is also a check against what was available ! we include maintenance pay-back and efflux to the "allocated" ! pool to make sure everything balances. - + allocated_c = (maint_r_def0-maint_r_def) + c_efflux allocated_n = n_efflux allocated_p = p_efflux - + + ! Update the allocation flux diagnostic arrays for each 3 elements do i_org = 1,num_organs - + i_var = prt_global%sp_organ_map(organ_list(i_org),carbon12_element) this%variables(i_var)%net_alloc(1) = & this%variables(i_var)%net_alloc(1) + (state_c(i_org)%ptr - state_c0(i_org)) allocated_c = allocated_c + (state_c(i_org)%ptr - state_c0(i_org)) - + i_var = prt_global%sp_organ_map(organ_list(i_org),nitrogen_element) this%variables(i_var)%net_alloc(1) = & this%variables(i_var)%net_alloc(1) + (state_n(i_org)%ptr - state_n0(i_org)) allocated_n = allocated_n + (state_n(i_org)%ptr - state_n0(i_org)) - + i_var = prt_global%sp_organ_map(organ_list(i_org),phosphorus_element) this%variables(i_var)%net_alloc(1) = & this%variables(i_var)%net_alloc(1) + (state_p(i_org)%ptr - state_p0(i_org)) allocated_p = allocated_p + (state_p(i_org)%ptr - state_p0(i_org)) - + end do - + if(debug) then ! Error Check: Do a final balance between how much mass ! we had to work with, and how much was allocated - + if ( abs(allocated_c - c_gain0) > calloc_abs_error .or. & abs(allocated_n - n_gain0) > calloc_abs_error .or. & abs(allocated_p - p_gain0) > calloc_abs_error ) then @@ -601,20 +615,20 @@ subroutine DailyPRTAllometricCNP(this) target_n = this%GetNutrientTarget(nitrogen_element,store_organ) target_p = this%GetNutrientTarget(phosphorus_element,store_organ) - + n_need = target_n - state_n(store_id)%ptr p_need = target_p - state_p(store_id)%ptr - + deallocate(state_c) deallocate(state_n) deallocate(state_p) - + return end subroutine DailyPRTAllometricCNP ! ===================================================================================== - subroutine CNPPrioritizedReplacement(this, & + subroutine CNPPrioritizedReplacement(this, & maint_r_deficit, c_gain, n_gain, p_gain, & state_c, state_n, state_p, target_c) @@ -686,8 +700,11 @@ 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 @@ -831,9 +848,8 @@ subroutine CNPPrioritizedReplacement(this, & state_c(store_id)%ptr = state_c(store_id)%ptr + store_c_flux - end if + end if - ! ----------------------------------------------------------------------------------- ! If carbon is still available, allocate to remaining high ! carbon balance is guaranteed to be >=0 beyond this point @@ -1012,6 +1028,7 @@ subroutine CNPStatureGrowth(this,c_gain, n_gain, p_gain, & integer :: ipft real(r8) :: canopy_trim real(r8) :: leaf_status + integer :: crown_damage ! which crown damage clas integer :: i, ii ! organ index loops (masked and unmasked) integer :: istep ! outer step iteration loop @@ -1092,6 +1109,7 @@ subroutine CNPStatureGrowth(this,c_gain, n_gain, p_gain, & leaf_status = this%bc_in(acnp_bc_in_id_lstat)%ival dbh => this%bc_inout(acnp_bc_inout_id_dbh)%rval ipft = this%bc_in(acnp_bc_in_id_pft)%ival + crown_damage = this%bc_in(acnp_bc_in_id_cdamage)%ival canopy_trim = this%bc_in(acnp_bc_in_id_ctrim)%rval cnp_limiter = 0 @@ -1115,7 +1133,7 @@ subroutine CNPStatureGrowth(this,c_gain, n_gain, p_gain, & intgr_params(:) = fates_unset_r8 intgr_params(acnp_bc_in_id_ctrim) = this%bc_in(acnp_bc_in_id_ctrim)%rval intgr_params(acnp_bc_in_id_pft) = real(this%bc_in(acnp_bc_in_id_pft)%ival) - + intgr_params(acnp_bc_in_id_cdamage) = real(this%bc_in(acnp_bc_in_id_cdamage)%ival) state_mask(:) = .false. mask_organs(:) = fates_unset_int @@ -1359,7 +1377,7 @@ subroutine CNPStatureGrowth(this,c_gain, n_gain, p_gain, & leafc_tp1 = leafc_tp1 + this%variables(i_var)%val(i) end do - call CheckIntegratedAllometries(state_array_out(dbh_id),ipft,canopy_trim, & + call CheckIntegratedAllometries(state_array_out(dbh_id),ipft,crown_damage,canopy_trim, & leafc_tp1, state_array_out(fnrt_id), state_array_out(sapw_id), & state_array_out(store_id), state_array_out(struct_id), & state_mask(leaf_id), state_mask(fnrt_id), state_mask(sapw_id), & @@ -1449,13 +1467,13 @@ subroutine CNPStatureGrowth(this,c_gain, n_gain, p_gain, & storec_tp1 = state_array_out(store_id) structc_tp1 = state_array_out(struct_id) - call bleaf(dbh_tp1,ipft,canopy_trim,leaf_c_target_tp1) + call bleaf(dbh_tp1,ipft,crown_damage,canopy_trim,leaf_c_target_tp1) call bfineroot(dbh_tp1,ipft,canopy_trim,fnrt_c_target_tp1) - call bsap_allom(dbh_tp1,ipft,canopy_trim,sapw_area,sapw_c_target_tp1) - call bagw_allom(dbh_tp1,ipft,agw_c_target_tp1) + call bsap_allom(dbh_tp1,ipft,crown_damage,canopy_trim,sapw_area,sapw_c_target_tp1) + call bagw_allom(dbh_tp1,ipft,crown_damage,agw_c_target_tp1) call bbgw_allom(dbh_tp1,ipft,bgw_c_target_tp1) call bdead_allom(agw_c_target_tp1,bgw_c_target_tp1, sapw_c_target_tp1, ipft, struct_c_target_tp1) - call bstore_allom(dbh_tp1,ipft,canopy_trim,store_c_target_tp1) + call bstore_allom(dbh_tp1,ipft,crown_damage,canopy_trim,store_c_target_tp1) write(fates_log(),*) 'leaf_c: ',leafc_tp1, leaf_c_target_tp1,leafc_tp1-leaf_c_target_tp1 write(fates_log(),*) 'fnrt_c: ',fnrtc_tp1, fnrt_c_target_tp1,fnrtc_tp1- fnrt_c_target_tp1 @@ -1563,11 +1581,12 @@ subroutine CNPAllocateRemainder(this,c_gain, n_gain, p_gain, & real(r8), pointer :: dbh integer :: ipft real(r8) :: canopy_trim - + integer :: crown_damage dbh => this%bc_inout(acnp_bc_inout_id_dbh)%rval canopy_trim = this%bc_in(acnp_bc_in_id_ctrim)%rval ipft = this%bc_in(acnp_bc_in_id_pft)%ival + crown_damage = this%bc_in(acnp_bc_in_id_cdamage)%ival ! ----------------------------------------------------------------------------------- ! If nutrients are still available, then we can bump up the values in the pools @@ -1619,7 +1638,7 @@ subroutine CNPAllocateRemainder(this,c_gain, n_gain, p_gain, & if(c_gain>calloc_abs_error) then ! Update carbon based allometric targets - call bstore_allom(dbh,ipft,canopy_trim, store_c_target) + call bstore_allom(dbh,ipft,crown_damage,canopy_trim, store_c_target) ! Estimate the overflow store_c_target = store_c_target * (1.0_r8 + store_overflow_frac) @@ -1708,6 +1727,7 @@ function GetNutrientTargetCNP(this,element_id,organ_id,stoich_mode) result(targe real(r8) :: canopy_trim integer :: ipft integer :: i_cvar + integer :: crown_damage real(r8) :: sapw_area real(r8) :: leaf_c_target,fnrt_c_target real(r8) :: sapw_c_target,agw_c_target @@ -1720,7 +1740,8 @@ function GetNutrientTargetCNP(this,element_id,organ_id,stoich_mode) result(targe canopy_trim = this%bc_in(acnp_bc_in_id_ctrim)%rval ipft = this%bc_in(acnp_bc_in_id_pft)%ival i_cvar = prt_global%sp_organ_map(organ_id,carbon12_element) - + crown_damage = this%bc_in(acnp_bc_in_id_cdamage)%ival + ! Storage of nutrients are assumed to have different compartments than ! 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 @@ -1728,10 +1749,10 @@ function GetNutrientTargetCNP(this,element_id,organ_id,stoich_mode) result(targe if(organ_id == store_organ) then - call bleaf(dbh,ipft,canopy_trim,leaf_c_target) + call bleaf(dbh,ipft,crown_damage,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 bsap_allom(dbh,ipft,crown_damage,canopy_trim,sapw_area,sapw_c_target) + call bagw_allom(dbh,ipft,crown_damage,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) @@ -2089,6 +2110,7 @@ function AllomCNPGrowthDeriv(l_state_array,l_state_mask,cbalance,intgr_params) r ! locals integer :: ipft ! PFT index + integer :: crown_damage ! Damage class real(r8) :: canopy_trim ! Canopy trimming function (boundary condition [0-1] real(r8) :: leaf_c_target ! target leaf biomass, dummy var (kgC) real(r8) :: fnrt_c_target ! target fine-root biomass, dummy var (kgC) @@ -2128,15 +2150,16 @@ function AllomCNPGrowthDeriv(l_state_array,l_state_mask,cbalance,intgr_params) r canopy_trim = intgr_params(acnp_bc_in_id_ctrim) ipft = int(intgr_params(acnp_bc_in_id_pft)) - - call bleaf(dbh,ipft,canopy_trim,leaf_c_target,leaf_dcdd_target) + crown_damage = int(intgr_params(acnp_bc_in_id_cdamage)) + + call bleaf(dbh,ipft,crown_damage,canopy_trim,leaf_c_target,leaf_dcdd_target) call bfineroot(dbh,ipft,canopy_trim,fnrt_c_target,fnrt_dcdd_target) - call bsap_allom(dbh,ipft,canopy_trim,sapw_area,sapw_c_target,sapw_dcdd_target) - call bagw_allom(dbh,ipft,agw_c_target,agw_dcdd_target) + call bsap_allom(dbh,ipft,crown_damage,canopy_trim,sapw_area,sapw_c_target,sapw_dcdd_target) + call bagw_allom(dbh,ipft,crown_damage,agw_c_target,agw_dcdd_target) call bbgw_allom(dbh,ipft,bgw_c_target,bgw_dcdd_target) call bdead_allom(agw_c_target,bgw_c_target, sapw_c_target, ipft, struct_c_target, & agw_dcdd_target, bgw_dcdd_target, sapw_dcdd_target, struct_dcdd_target) - call bstore_allom(dbh,ipft,canopy_trim,store_c_target,store_dcdd_target) + call bstore_allom(dbh,ipft,crown_damage,canopy_trim,store_c_target,store_dcdd_target) if (mask_repro) then ! fraction of carbon going towards reproduction diff --git a/parteh/PRTAllometricCarbonMod.F90 b/parteh/PRTAllometricCarbonMod.F90 index b5db420b43..be4b2bbdff 100644 --- a/parteh/PRTAllometricCarbonMod.F90 +++ b/parteh/PRTAllometricCarbonMod.F90 @@ -90,14 +90,17 @@ module PRTAllometricCarbonMod integer, public, parameter :: ac_bc_inout_id_dbh = 1 ! Plant DBH integer, public, parameter :: ac_bc_inout_id_netdc = 2 ! Index for the net daily C input BC + integer, parameter :: num_bc_inout = 2 ! Number of in & output boundary conditions integer, public, parameter :: ac_bc_in_id_pft = 1 ! Index for the PFT input BC integer, public, parameter :: ac_bc_in_id_ctrim = 2 ! Index for the canopy trim function integer, public, parameter :: ac_bc_in_id_lstat = 3 ! Leaf status (on or off) - integer, parameter :: num_bc_in = 3 ! Number of input boundary conditions + integer, public, parameter :: ac_bc_in_id_cdamage = 4 ! Index for the crowndamage input BC + integer, parameter :: num_bc_in = 4 ! Number of input boundary conditions + ! THere are no purely output boundary conditions integer, parameter :: num_bc_out = 0 ! Number of purely output boundary condtions @@ -241,7 +244,7 @@ end subroutine InitPRTGlobalAllometricCarbon ! ===================================================================================== - subroutine DailyPRTAllometricCarbon(this) + subroutine DailyPRTAllometricCarbon(this,phase) ! ----------------------------------------------------------------------------------- ! @@ -283,22 +286,25 @@ subroutine DailyPRTAllometricCarbon(this) ! ! ---------------------------------------------------------------------------------- - - ! The class is the only argument + class(callom_prt_vartypes) :: this ! this class + integer,intent(in) :: phase ! the phase splits the routine into parts + ! ----------------------------------------------------------------------------------- ! These are local copies of the in/out boundary condition structure ! ----------------------------------------------------------------------------------- real(r8),pointer :: dbh ! Diameter at breast height [cm] - ! this local will point to both in and out bc's + ! this local will point to both in and out bc's real(r8),pointer :: carbon_balance ! Daily carbon balance for this cohort [kgC] + integer :: crowndamage ! which crown damage class + + real(r8) :: canopy_trim ! The canopy trimming function [0-1] integer :: ipft ! Plant Functional Type index - real(r8) :: target_leaf_c ! target leaf carbon [kgC] real(r8) :: target_fnrt_c ! target fine-root carbon [kgC] real(r8) :: target_sapw_c ! target sapwood carbon [kgC] @@ -317,14 +323,14 @@ subroutine DailyPRTAllometricCarbon(this) real(r8) :: total_below_target ! total biomass below the allometric target [kgC] real(r8) :: allocation_factor ! allocation factor (relative to demand) to - ! reconstruct tissues + ! reconstruct tissues real(r8) :: flux_adj ! adjustment made to growth flux term to minimize error [kgC] real(r8) :: store_target_fraction ! ratio between storage and leaf biomass when on allometry [kgC] real(r8) :: leaf_c_demand ! leaf carbon that is demanded to replace maintenance turnover [kgC] real(r8) :: fnrt_c_demand ! fineroot carbon that is demanded to replace - ! maintenance turnover [kgC] + ! maintenance turnover [kgC] real(r8) :: total_c_demand ! total carbon that is demanded to replace maintenance turnover [kgC] logical :: step_pass ! Did the integration step pass? @@ -337,7 +343,7 @@ subroutine DailyPRTAllometricCarbon(this) real(r8),dimension(max_nleafage) :: leaf_c0 - ! Initial value of carbon used to determine net flux + ! Initial value of carbon used to determine net flux real(r8) :: fnrt_c0 ! during this routine real(r8) :: sapw_c0 ! "" real(r8) :: store_c0 ! "" @@ -350,7 +356,7 @@ subroutine DailyPRTAllometricCarbon(this) logical :: grow_sapw ! Is sapwood at allometric target and should be grown? logical :: grow_store ! Is storage at allometric target and should be grown? - ! integrator variables + ! integrator variables real(r8) :: deltaC ! trial value for substep integer :: ierr ! error flag for allometric growth step integer :: nsteps ! number of sub-steps @@ -364,7 +370,6 @@ subroutine DailyPRTAllometricCarbon(this) integer :: leaf_status ! are leaves on (2) or off (1) real(r8) :: leaf_age_flux ! carbon mass flux between leaf age classification pools - ! Integegrator variables c_pool is "mostly" carbon variables, it also includes ! dbh... ! ----------------------------------------------------------------------------------- @@ -380,495 +385,505 @@ subroutine DailyPRTAllometricCarbon(this) integer, parameter :: ODESolve = 2 ! 1=RKF45, 2=Euler integer, parameter :: iexp_leaf = 1 ! index 1 is the expanding (i.e. youngest) - ! leaf age class, and therefore - ! all new allocation goes into that pool + ! leaf age class, and therefore + ! all new allocation goes into that pool character(len= 9), parameter :: fmti = '(a,1x,i5)' character(len=13), parameter :: fmt0 = '(a,1x,es12.5)' character(len=19), parameter :: fmth = '(a,1x,a5,3(1x,a12))' character(len=22), parameter :: fmtg = '(a,5x,l1,3(1x,es12.5))' - real(r8) :: intgr_params(num_bc_in) ! The boundary conditions to this routine, - ! are pressed into an array that is also - ! passed to the integrators + ! The boundary conditions to this routine, + ! are pressed into an array that is also + ! passed to the integrators + ! add one because we pass crown damage also + ! which is not a bc_in + + real(r8) :: intgr_params(num_bc_in) associate( & - leaf_c => this%variables(leaf_c_id)%val, & - fnrt_c => this%variables(fnrt_c_id)%val(icd), & - sapw_c => this%variables(sapw_c_id)%val(icd), & - store_c => this%variables(store_c_id)%val(icd), & - repro_c => this%variables(repro_c_id)%val(icd), & - struct_c => this%variables(struct_c_id)%val(icd)) - + + leaf_c => this%variables(leaf_c_id)%val, & + fnrt_c => this%variables(fnrt_c_id)%val(icd), & + sapw_c => this%variables(sapw_c_id)%val(icd), & + store_c => this%variables(store_c_id)%val(icd), & + repro_c => this%variables(repro_c_id)%val(icd), & + struct_c => this%variables(struct_c_id)%val(icd)) + + + ! ----------------------------------------------------------------------------------- + ! 0. + ! Copy the boundary conditions into readable local variables. + ! We don't use pointers for bc's that ar "in" only, only "in-out" and "out" + ! ----------------------------------------------------------------------------------- + + dbh => this%bc_inout(ac_bc_inout_id_dbh)%rval + carbon_balance => this%bc_inout(ac_bc_inout_id_netdc)%rval + - ! ----------------------------------------------------------------------------------- - ! 0. - ! Copy the boundary conditions into readable local variables. - ! We don't use pointers for bc's that ar "in" only, only "in-out" and "out" - ! ----------------------------------------------------------------------------------- + canopy_trim = this%bc_in(ac_bc_in_id_ctrim)%rval + ipft = this%bc_in(ac_bc_in_id_pft)%ival + leaf_status = this%bc_in(ac_bc_in_id_lstat)%ival + crowndamage = this%bc_in(ac_bc_in_id_cdamage)%ival + + nleafage = prt_global%state_descriptor(leaf_c_id)%num_pos ! Number of leaf age class - dbh => this%bc_inout(ac_bc_inout_id_dbh)%rval - carbon_balance => this%bc_inout(ac_bc_inout_id_netdc)%rval + ! ----------------------------------------------------------------------------------- + ! I. Remember the values for the state variables at the beginning of this + ! routines. We will then use that to determine their net allocation and reactive + ! transport flux "%net_alloc" at the end. + ! ----------------------------------------------------------------------------------- + + leaf_c0(1:nleafage) = leaf_c(1:nleafage) ! Set initial leaf carbon + fnrt_c0 = fnrt_c ! Set initial fine-root carbon + sapw_c0 = sapw_c ! Set initial sapwood carbon + store_c0 = store_c ! Set initial storage carbon + repro_c0 = repro_c ! Set initial reproductive carbon + struct_c0 = struct_c ! Set initial structural carbon - canopy_trim = this%bc_in(ac_bc_in_id_ctrim)%rval - ipft = this%bc_in(ac_bc_in_id_pft)%ival - leaf_status = this%bc_in(ac_bc_in_id_lstat)%ival + ! ----------------------------------------------------------------------------------- + ! II. Calculate target size of the biomass compartment for a given dbh. + ! ----------------------------------------------------------------------------------- - intgr_params(:) = un_initialized - intgr_params(ac_bc_in_id_ctrim) = this%bc_in(ac_bc_in_id_ctrim)%rval - intgr_params(ac_bc_in_id_pft) = real(this%bc_in(ac_bc_in_id_pft)%ival) - - + ! Target sapwood biomass according to allometry and trimming [kgC] + call bsap_allom(dbh,ipft, crowndamage, canopy_trim,sapw_area,target_sapw_c) - nleafage = prt_global%state_descriptor(leaf_c_id)%num_pos ! Number of leaf age class + ! Target total above ground biomass in woody/fibrous tissues [kgC] + call bagw_allom(dbh,ipft, crowndamage, target_agw_c) - ! ----------------------------------------------------------------------------------- - ! Call the routine that advances leaves in age. - ! This will move a portion of the leaf mass in each - ! age bin, to the next bin. This will not handle movement - ! of mass from the oldest bin into the litter pool, that is something else. - ! ----------------------------------------------------------------------------------- + ! Target total below ground biomass in woody/fibrous tissues [kgC] + call bbgw_allom(dbh,ipft,target_bgw_c) - call this%AgeLeaves(ipft,sec_per_day) + ! Target total dead (structrual) biomass [kgC] + call bdead_allom( target_agw_c, target_bgw_c, target_sapw_c, ipft, target_struct_c) - ! ----------------------------------------------------------------------------------- - ! I. Remember the values for the state variables at the beginning of this - ! routines. We will then use that to determine their net allocation and reactive - ! transport flux "%net_alloc" at the end. - ! ----------------------------------------------------------------------------------- - - leaf_c0(1:nleafage) = leaf_c(1:nleafage) ! Set initial leaf carbon - fnrt_c0 = fnrt_c ! Set initial fine-root carbon - sapw_c0 = sapw_c ! Set initial sapwood carbon - store_c0 = store_c ! Set initial storage carbon - repro_c0 = repro_c ! Set initial reproductive carbon - struct_c0 = struct_c ! Set initial structural carbon - + ! Target leaf biomass according to allometry and trimming + select case (leaf_status) + case (leaves_on) + call bleaf(dbh,ipft,crowndamage,canopy_trim,target_leaf_c) + case (leaves_off) + target_leaf_c = 0._r8 + end select - ! ----------------------------------------------------------------------------------- - ! II. Calculate target size of the biomass compartment for a given dbh. - ! ----------------------------------------------------------------------------------- - - ! 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] - 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) - - ! Target leaf biomass according to allometry and trimming - select case (leaf_status) - case (leaves_on) - call bleaf(dbh,ipft,canopy_trim,target_leaf_c) - case (leaves_off) - target_leaf_c = 0._r8 - end select - - ! Target fine-root biomass and deriv. according to allometry and trimming [kgC, kgC/cm] - call bfineroot(dbh,ipft,canopy_trim,target_fnrt_c) - - ! Target storage carbon [kgC,kgC/cm] - call bstore_allom(dbh,ipft,canopy_trim,target_store_c) + ! Target fine-root biomass and deriv. according to allometry and trimming [kgC, kgC/cm] + call bfineroot(dbh,ipft,canopy_trim,target_fnrt_c) + ! Target storage carbon [kgC,kgC/cm] + call bstore_allom(dbh,ipft,crowndamage,canopy_trim,target_store_c) - ! ----------------------------------------------------------------------------------- - ! III. Prioritize some amount of carbon to replace leaf/root turnover - ! Make sure it isn't a negative payment, and either pay what is available - ! or forcefully pay from storage. - ! ----------------------------------------------------------------------------------- - - if( prt_params%evergreen(ipft) == itrue ) then - leaf_c_demand = max(0.0_r8, & - prt_params%leaf_stor_priority(ipft)*sum(this%variables(leaf_c_id)%turnover(:))) - else - leaf_c_demand = 0.0_r8 - end if - - fnrt_c_demand = max(0.0_r8, & - prt_params%leaf_stor_priority(ipft)*this%variables(fnrt_c_id)%turnover(icd)) + ! ----------------------------------------------------------------------------------- + ! Phase 1: Replace losses, push pools towards targets + ! ----------------------------------------------------------------------------------- - total_c_demand = leaf_c_demand + fnrt_c_demand + if_phase1: if(phase.eq.1) then - if (total_c_demand > nearzero) then + ! III. Prioritize some amount of carbon to replace leaf/root turnover + ! Make sure it isn't a negative payment, and either pay what is available + ! or forcefully pay from storage. + ! ----------------------------------------------------------------------------------- - ! We pay this even if we don't have the carbon - ! Just don't pay so much carbon that storage+carbon_balance can't pay for it - allocation_factor = max(0.0_r8,min(1.0_r8,(store_c+carbon_balance)/total_c_demand)) + if( prt_params%evergreen(ipft) == itrue ) then + leaf_c_demand = max(0.0_r8, & + prt_params%leaf_stor_priority(ipft)*sum(this%variables(leaf_c_id)%turnover(:))) + else + leaf_c_demand = 0.0_r8 + end if - ! MLO. Edited the code to switch the order of operations. The previous code would - ! subtract leaf flux from carbon balance before estimating the fine root flux, - ! potentially allowing less fluxes to fine roots than possible. - leaf_c_flux = leaf_c_demand * allocation_factor - fnrt_c_flux = fnrt_c_demand * allocation_factor + fnrt_c_demand = max(0.0_r8, & + prt_params%leaf_stor_priority(ipft)*this%variables(fnrt_c_id)%turnover(icd)) - ! Add carbon to the youngest age pool (i.e iexp_leaf = index 1) and fine roots - leaf_c(iexp_leaf) = leaf_c(iexp_leaf) + leaf_c_flux - fnrt_c = fnrt_c + fnrt_c_flux + total_c_demand = leaf_c_demand + fnrt_c_demand - ! Remove fluxes from carbon balance. In case we may have drawn carbon from storage, - ! carbon_balance will become negative, in which case we will deplete carbon from - ! storage in the next step. - carbon_balance = carbon_balance - ( leaf_c_flux + fnrt_c_flux ) - end if + if (total_c_demand > nearzero) then - ! ----------------------------------------------------------------------------------- - ! IV. if carbon balance is negative, re-coup the losses from storage - ! if it is positive, give some love to storage carbon - ! ----------------------------------------------------------------------------------- + ! We pay this even if we don't have the carbon + ! Just don't pay so much carbon that storage+carbon_balance can't pay for it + allocation_factor = max(0.0_r8,min(1.0_r8,(store_c+carbon_balance)/total_c_demand)) - if( carbon_balance < 0.0_r8 ) then + ! MLO. Edited the code to switch the order of operations. The previous code would + ! subtract leaf flux from carbon balance before estimating the fine root flux, + ! potentially allowing less fluxes to fine roots than possible. + leaf_c_flux = leaf_c_demand * allocation_factor + fnrt_c_flux = fnrt_c_demand * allocation_factor - ! Store_c_flux will be negative, so store_c will be depleted - store_c_flux = carbon_balance - carbon_balance = carbon_balance - store_c_flux - store_c = store_c + store_c_flux + ! Add carbon to the youngest age pool (i.e iexp_leaf = index 1) and fine roots + leaf_c(iexp_leaf) = leaf_c(iexp_leaf) + leaf_c_flux + fnrt_c = fnrt_c + fnrt_c_flux - else + ! Remove fluxes from carbon balance. In case we may have drawn carbon from storage, + ! carbon_balance will become negative, in which case we will deplete carbon from + ! storage in the next step. + carbon_balance = carbon_balance - ( leaf_c_flux + fnrt_c_flux ) + end if - ! Accumulate some carbon in storage. If storage is completely depleted, aim to - ! increase storage, but not to replenish completely so we can still use some - ! carbon for growth. - store_below_target = max(0.0_r8,target_store_c - store_c) - store_target_fraction = max(0.0_r8, store_c/target_store_c ) + ! ----------------------------------------------------------------------------------- + ! IV. if carbon balance is negative, re-coup the losses from storage + ! if it is positive, give some love to storage carbon + ! ----------------------------------------------------------------------------------- - store_c_flux = min(store_below_target,carbon_balance * & - max(exp(-1.*store_target_fraction**4._r8) - exp( -1.0_r8 ),0.0_r8)) + if( carbon_balance < 0.0_r8 ) then - ! Move carbon from carbon balance to storage - carbon_balance = carbon_balance - store_c_flux - store_c = store_c + store_c_flux + ! Store_c_flux will be negative, so store_c will be depleted + store_c_flux = carbon_balance + carbon_balance = carbon_balance - store_c_flux + store_c = store_c + store_c_flux - end if + else - ! ----------------------------------------------------------------------------------- - ! V. If carbon is still available, prioritize some allocation to replace - ! the rest of the leaf/fineroot deficit - ! carbon balance is guaranteed to be >=0 beyond this point - ! MLO. Renamed demand with below target to make it consistent with the - ! definitions at the variable declaration part. - ! ----------------------------------------------------------------------------------- + ! Accumulate some carbon in storage. If storage is completely depleted, aim to + ! increase storage, but not to replenish completely so we can still use some + ! carbon for growth. + store_below_target = max(0.0_r8,target_store_c - store_c) + store_target_fraction = max(0.0_r8, store_c/target_store_c ) - leaf_below_target = max(0.0_r8,target_leaf_c - sum(leaf_c(1:nleafage))) - fnrt_below_target = max(0.0_r8,target_fnrt_c - fnrt_c) + store_c_flux = min(store_below_target,carbon_balance * & + max(exp(-1.*store_target_fraction**4._r8) - exp( -1.0_r8 ),0.0_r8)) - total_below_target = leaf_below_target + fnrt_below_target + ! Move carbon from carbon balance to storage + carbon_balance = carbon_balance - store_c_flux + store_c = store_c + store_c_flux - if ( (carbon_balance > nearzero) .and. (total_below_target > nearzero) ) then - ! Find fraction of carbon to be allocated to leaves and fine roots - allocation_factor = min(1.0_r8, carbon_balance / total_below_target) + end if - ! MLO. Edited the code to switch the order of operations. The previous code would - ! subtract leaf flux from carbon balance before estimating the fine root flux, - ! potentially allowing less fluxes to fine roots than possible. - leaf_c_flux = leaf_below_target * allocation_factor - fnrt_c_flux = fnrt_below_target * allocation_factor + end if if_phase1 - leaf_c(iexp_leaf) = leaf_c(iexp_leaf) + leaf_c_flux - fnrt_c = fnrt_c + fnrt_c_flux + + if_phase2: if(phase.eq.2)then + + ! ----------------------------------------------------------------------------------- + ! V. If carbon is still available, prioritize some allocation to replace + ! the rest of the leaf/fineroot deficit + ! carbon balance is guaranteed to be >=0 beyond this point + ! MLO. Renamed demand with below target to make it consistent with the + ! definitions at the variable declaration part. + ! ----------------------------------------------------------------------------------- + + leaf_below_target = max(0.0_r8,target_leaf_c - sum(leaf_c(1:nleafage))) + fnrt_below_target = max(0.0_r8,target_fnrt_c - fnrt_c) + + total_below_target = leaf_below_target + fnrt_below_target + + if ( (carbon_balance > nearzero) .and. (total_below_target > nearzero) ) then + ! Find fraction of carbon to be allocated to leaves and fine roots + allocation_factor = min(1.0_r8, carbon_balance / total_below_target) + + ! MLO. Edited the code to switch the order of operations. The previous code would + ! subtract leaf flux from carbon balance before estimating the fine root flux, + ! potentially allowing less fluxes to fine roots than possible. + leaf_c_flux = leaf_below_target * allocation_factor + fnrt_c_flux = fnrt_below_target * allocation_factor + + leaf_c(iexp_leaf) = leaf_c(iexp_leaf) + leaf_c_flux + fnrt_c = fnrt_c + fnrt_c_flux + + carbon_balance = carbon_balance - ( leaf_c_flux + fnrt_c_flux ) + + end if + + ! ----------------------------------------------------------------------------------- + ! VI. If carbon is still available, we try to push all live + ! pools back towards allometry. But only upwards, if fusion happened + ! to generate some pools above allometric target, don't reduce the pool, + ! just ignore it until the rest of the plant grows to meet it. + ! ----------------------------------------------------------------------------------- + if( carbon_balance > nearzero ) then + + leaf_below_target = max(target_leaf_c - sum(leaf_c(1:nleafage)),0.0_r8) + fnrt_below_target = max(target_fnrt_c - fnrt_c,0.0_r8) + sapw_below_target = max(target_sapw_c - sapw_c,0.0_r8) + store_below_target = max(target_store_c - store_c,0.0_r8) + + total_below_target = leaf_below_target + fnrt_below_target + & + sapw_below_target + store_below_target + + if ( total_below_target > nearzero ) then + ! Find allocation factor based on available carbon and total demand to meet target. + allocation_factor = min(1.0_r8, carbon_balance / total_below_target) + + ! Find fluxes to individual pools + leaf_c_flux = leaf_below_target * allocation_factor + fnrt_c_flux = fnrt_below_target * allocation_factor + sapw_c_flux = sapw_below_target * allocation_factor + store_c_flux = store_below_target * allocation_factor + + leaf_c(iexp_leaf) = leaf_c(iexp_leaf) + leaf_c_flux + fnrt_c = fnrt_c + fnrt_c_flux + sapw_c = sapw_c + sapw_c_flux + store_c = store_c + store_c_flux + + carbon_balance = carbon_balance - & + ( leaf_c_flux + fnrt_c_flux + sapw_c_flux + store_c_flux ) + end if + end if + + ! ----------------------------------------------------------------------------------- + ! VII. If carbon is still available, replenish the structural pool to get + ! back on allometry + ! ----------------------------------------------------------------------------------- + + if( carbon_balance > nearzero ) then + + struct_below_target = max(target_struct_c - struct_c ,0.0_r8) + + if ( struct_below_target > 0.0_r8) then + + struct_c_flux = min(carbon_balance,struct_below_target) + carbon_balance = carbon_balance - struct_c_flux + struct_c = struct_c + struct_c_flux + + end if + + end if + end if if_phase2 + + if_phase3: if( (phase.eq.3) .and. ( carbon_balance > calloc_abs_error )) then + + ! ----------------------------------------------------------------------------------- + ! VIII. If carbon is yet still available ... + ! Our pools are now either on allometry or above (from fusion). + ! We we can increment those pools at or below, + ! including structure and reproduction according to their rates + ! Use an adaptive euler integration. If the error is not nominal, + ! the carbon balance sub-step (deltaC) will be halved and tried again + ! + ! Note that we compare against calloc_abs_error here because it is possible + ! that all the carbon was effectively used up, but a miniscule amount + ! remains due to numerical precision (ie -20 or so), so even though + ! the plant has not been brought to be "on allometry", it thinks it has carbon + ! left to allocate, and thus it must be on allometry when its not. + ! ----------------------------------------------------------------------------------- + + intgr_params(:) = un_initialized + intgr_params(ac_bc_in_id_ctrim) = this%bc_in(ac_bc_in_id_ctrim)%rval + intgr_params(ac_bc_in_id_pft) = real(this%bc_in(ac_bc_in_id_pft)%ival) + intgr_params(ac_bc_in_id_cdamage) = real(this%bc_in(ac_bc_in_id_cdamage)%ival) + + + + ! This routine checks that actual carbon is not below that targets. It does + ! allow actual pools to be above the target, and in these cases, it sends + ! a false on the "grow_<>" flag, allowing the plant to grow into these pools. + ! It also checks to make sure that structural biomass is not above the target. + ! ( MLO. Removed the check for storage because the same test is done inside + ! sub-routine TargetAllometryCheck.) + + call TargetAllometryCheck(sum(leaf_c0(1:nleafage)),fnrt_c0,sapw_c0,store_c0,struct_c0, & + sum(leaf_c(1:nleafage)), fnrt_c, sapw_c,store_c, struct_c, & + target_leaf_c, target_fnrt_c, target_sapw_c, & + target_store_c, target_struct_c, & + carbon_balance,ipft,leaf_status, & + grow_leaf, grow_fnrt, grow_sapw, grow_store, grow_struct) + + ! -------------------------------------------------------------------------------- + ! The numerical integration of growth requires that the instantaneous state + ! variables are passed in as an array. We call it "c_pool". + ! + ! Initialize the adaptive integrator arrays and flags + ! -------------------------------------------------------------------------------- + + ierr = 1 + totalC = carbon_balance + nsteps = 0 + + c_pool(:) = 0.0_r8 ! Zero state variable array + c_mask(:) = .false. ! This mask tells the integrator + ! which indices are active. Its possible + ! that due to fusion, or previous numerical + ! truncation errors, that one of these pools + ! may be larger than its target! We check + ! this, and if true, then we flag that + ! pool to be ignored. c_mask(i) = .false. + ! For grasses, since they don't grow very + ! large and thus won't accumulate such large + ! errors, we always mask as true. + + c_pool(leaf_c_id) = sum(leaf_c(1:nleafage)) + c_pool(fnrt_c_id) = fnrt_c + c_pool(sapw_c_id) = sapw_c + c_pool(store_c_id) = store_c + c_pool(struct_c_id) = struct_c + c_pool(repro_c_id) = repro_c + c_pool(dbh_id) = dbh + + ! Only grow leaves if we are in a "leaf-on" status + select case (leaf_status) + case (leaves_on) + c_mask(leaf_c_id) = grow_leaf + case default + c_mask(leaf_c_id) = .false. + end select + c_mask(fnrt_c_id) = grow_fnrt + c_mask(sapw_c_id) = grow_sapw + c_mask(struct_c_id) = grow_struct + c_mask(store_c_id) = grow_store + c_mask(repro_c_id) = .true. ! Always calculate reproduction on growth + c_mask(dbh_id) = .true. ! Always increment dbh on growth step + + + ! When using the Euler method, we keep things simple. We always try + ! to make the first integration step to span the entirety of the integration + ! window for the independent variable (available carbon) + + select case (ODESolve) + case (2) + this%ode_opt_step = totalC + end select + + do_solve_check: do while( ierr .ne. 0 ) + + deltaC = min(totalC,this%ode_opt_step) + select_ODESolve: select case (ODESolve) + case (1) + call RKF45(AllomCGrowthDeriv,c_pool,c_mask,deltaC,totalC, & + max_trunc_error,intgr_params,c_pool_out,this%ode_opt_step,step_pass) + + case (2) + call Euler(AllomCGrowthDeriv,c_pool,c_mask,deltaC,totalC,intgr_params,c_pool_out) + ! step_pass = .true. + + ! When integrating along the allometric curve, we have the luxury of perfect + ! hindsite. Ie, after we have made our step, we can see if the amount + ! of each carbon we have matches the target associated with the new dbh. + ! The following call evaluates how close we are to the allometically defined + ! targets. If we are too far (governed by max_trunc_error), then we + ! pass back the pass/fail flag (step_pass) as false. If false, then + ! we halve the step-size, and then retry. If that step was fine, then + ! we remember the current step size as a good next guess. + + call CheckIntegratedAllometries(c_pool_out(dbh_id),ipft,& + crowndamage, canopy_trim, & + c_pool_out(leaf_c_id), c_pool_out(fnrt_c_id), c_pool_out(sapw_c_id), & + c_pool_out(store_c_id), c_pool_out(struct_c_id), & + c_mask(leaf_c_id), c_mask(fnrt_c_id), c_mask(sapw_c_id), & + c_mask(store_c_id), c_mask(struct_c_id), max_trunc_error, step_pass) + if(step_pass) then + this%ode_opt_step = deltaC + else + this%ode_opt_step = 0.5*deltaC + end if + case default + write(fates_log(),*) 'An integrator was chosen that does not exist' + write(fates_log(),*) 'ODESolve = ',ODESolve + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select select_ODESolve + + nsteps = nsteps + 1 + + if (step_pass) then ! If true, then step is accepted + totalC = totalC - deltaC + c_pool(:) = c_pool_out(:) + end if + + if(nsteps > max_substeps ) then + write(fates_log(),fmt=*) '---~---' + write(fates_log(),fmt=*) 'Plant Growth Integrator could not find' + write(fates_log(),fmt=*) 'a solution in less than ',max_substeps,' tries.' + write(fates_log(),fmt=*) 'Aborting!' + write(fates_log(),fmt=*) '---~---' + write(fates_log(),fmt=fmti) 'Leaf status =',leaf_status + write(fates_log(),fmt=fmt0) 'Carbon_balance =',carbon_balance + write(fates_log(),fmt=fmt0) 'deltaC =',deltaC + write(fates_log(),fmt=fmt0) 'totalC =',totalC + write(fates_log(),fmt=*) 'crowndamage : ', crowndamage + write(fates_log(),fmt=fmth) ' Tissue |', ' Grow',' Current',' Target' ,' Deficit' + write(fates_log(),fmt=fmtg) ' Leaf |', grow_leaf , sum(leaf_c(:)),target_leaf_c , target_leaf_c - sum(leaf_c(:)) + write(fates_log(),fmt=fmtg) ' Fine root |', grow_fnrt , fnrt_c,target_fnrt_c , target_fnrt_c - fnrt_c + write(fates_log(),fmt=fmtg) ' Sapwood |', grow_sapw , sapw_c,target_sapw_c , target_sapw_c - sapw_c + write(fates_log(),fmt=fmtg) ' Storage |', grow_store , store_c,target_store_c , target_store_c - store_c + write(fates_log(),fmt=fmtg) ' Structural |', grow_struct , struct_c,target_struct_c, target_struct_c - struct_c + write(fates_log(),fmt=*) '---~---' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! + ! TotalC should eventually be whittled down to near zero. + ! The solvers are not perfect, so we can't expect it to be perfectly zero. + ! Note that calloc_abs_error is 1e-9, which is really small (1 microgram of carbon) + ! yet also six orders of magnitude greater than typical rounding errors (~1e-15). + + ! At that point, update the actual states + ! -------------------------------------------------------------------------------- + if_step_pass: if( (totalC < calloc_abs_error) .and. (step_pass) )then + + ierr = 0 + leaf_c_flux = c_pool(leaf_c_id) - sum(leaf_c(1:nleafage)) + fnrt_c_flux = c_pool(fnrt_c_id) - fnrt_c + sapw_c_flux = c_pool(sapw_c_id) - sapw_c + store_c_flux = c_pool(store_c_id) - store_c + struct_c_flux = c_pool(struct_c_id) - struct_c + repro_c_flux = c_pool(repro_c_id) - repro_c + + ! Make an adjustment to flux partitions to make it match remaining c balance + flux_adj = carbon_balance/(leaf_c_flux+fnrt_c_flux+sapw_c_flux + & + store_c_flux+struct_c_flux+repro_c_flux) + + + leaf_c_flux = leaf_c_flux*flux_adj + fnrt_c_flux = fnrt_c_flux*flux_adj + sapw_c_flux = sapw_c_flux*flux_adj + store_c_flux = store_c_flux*flux_adj + struct_c_flux = struct_c_flux*flux_adj + repro_c_flux = repro_c_flux*flux_adj + + carbon_balance = carbon_balance - leaf_c_flux + leaf_c(iexp_leaf) = leaf_c(iexp_leaf) + leaf_c_flux + + carbon_balance = carbon_balance - fnrt_c_flux + fnrt_c = fnrt_c + fnrt_c_flux + + carbon_balance = carbon_balance - sapw_c_flux + sapw_c = sapw_c + sapw_c_flux + + carbon_balance = carbon_balance - store_c_flux + store_c = store_c + store_c_flux + + carbon_balance = carbon_balance - struct_c_flux + struct_c = struct_c + struct_c_flux + + carbon_balance = carbon_balance - repro_c_flux + repro_c = repro_c + repro_c_flux + + dbh = c_pool(dbh_id) + + if( abs(carbon_balance)>calloc_abs_error ) then + write(fates_log(),*) 'carbon conservation error while integrating pools' + write(fates_log(),*) 'along alometric curve' + write(fates_log(),*) 'carbon_balance = ',carbon_balance,totalC + write(fates_log(),*) 'exiting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end if if_step_pass + + end do do_solve_check + + end if if_phase3 - carbon_balance = carbon_balance - ( leaf_c_flux + fnrt_c_flux ) + ! Track the net allocations and transport from this routine + ! (the AgeLeaves() routine handled tracking allocation through aging) - end if + this%variables(leaf_c_id)%net_alloc(icd) = & + this%variables(leaf_c_id)%net_alloc(icd) + (leaf_c(icd) - leaf_c0(icd)) - ! ----------------------------------------------------------------------------------- - ! VI. If carbon is still available, we try to push all live - ! pools back towards allometry. But only upwards, if fusion happened - ! to generate some pools above allometric target, don't reduce the pool, - ! just ignore it until the rest of the plant grows to meet it. - ! ----------------------------------------------------------------------------------- - if( carbon_balance > nearzero ) then + this%variables(fnrt_c_id)%net_alloc(icd) = & + this%variables(fnrt_c_id)%net_alloc(icd) + (fnrt_c - fnrt_c0) - leaf_below_target = max(target_leaf_c - sum(leaf_c(1:nleafage)),0.0_r8) - fnrt_below_target = max(target_fnrt_c - fnrt_c,0.0_r8) - sapw_below_target = max(target_sapw_c - sapw_c,0.0_r8) - store_below_target = max(target_store_c - store_c,0.0_r8) - - total_below_target = leaf_below_target + fnrt_below_target + & - sapw_below_target + store_below_target - - if ( total_below_target > nearzero ) then - ! Find allocation factor based on available carbon and total demand to meet target. - allocation_factor = min(1.0_r8, carbon_balance / total_below_target) - - ! Find fluxes to individual pools - leaf_c_flux = leaf_below_target * allocation_factor - fnrt_c_flux = fnrt_below_target * allocation_factor - sapw_c_flux = sapw_below_target * allocation_factor - store_c_flux = store_below_target * allocation_factor - - leaf_c(iexp_leaf) = leaf_c(iexp_leaf) + leaf_c_flux - fnrt_c = fnrt_c + fnrt_c_flux - sapw_c = sapw_c + sapw_c_flux - store_c = store_c + store_c_flux - - carbon_balance = carbon_balance - & - ( leaf_c_flux + fnrt_c_flux + sapw_c_flux + store_c_flux ) - end if - end if - - ! ----------------------------------------------------------------------------------- - ! VII. If carbon is still available, replenish the structural pool to get - ! back on allometry - ! ----------------------------------------------------------------------------------- + this%variables(sapw_c_id)%net_alloc(icd) = & + this%variables(sapw_c_id)%net_alloc(icd) + (sapw_c - sapw_c0) - if( carbon_balance > nearzero ) then - - struct_below_target = max(target_struct_c - struct_c ,0.0_r8) - - if ( struct_below_target > 0.0_r8) then - - struct_c_flux = min(carbon_balance,struct_below_target) - carbon_balance = carbon_balance - struct_c_flux - struct_c = struct_c + struct_c_flux - - end if + this%variables(store_c_id)%net_alloc(icd) = & + this%variables(store_c_id)%net_alloc(icd) + (store_c - store_c0) - end if - - ! ----------------------------------------------------------------------------------- - ! VIII. If carbon is yet still available ... - ! Our pools are now either on allometry or above (from fusion). - ! We we can increment those pools at or below, - ! including structure and reproduction according to their rates - ! Use an adaptive euler integration. If the error is not nominal, - ! the carbon balance sub-step (deltaC) will be halved and tried again - ! - ! Note that we compare against calloc_abs_error here because it is possible - ! that all the carbon was effectively used up, but a miniscule amount - ! remains due to numerical precision (ie -20 or so), so even though - ! the plant has not been brought to be "on allometry", it thinks it has carbon - ! left to allocate, and thus it must be on allometry when its not. - ! ----------------------------------------------------------------------------------- - - if_stature_growth: if( carbon_balance > calloc_abs_error ) then - - ! This routine checks that actual carbon is not below that targets. It does - ! allow actual pools to be above the target, and in these cases, it sends - ! a false on the "grow_<>" flag, allowing the plant to grow into these pools. - ! It also checks to make sure that structural biomass is not above the target. - ! ( MLO. Removed the check for storage because the same test is done inside - ! sub-routine TargetAllometryCheck.) - - call TargetAllometryCheck(sum(leaf_c0(1:nleafage)),fnrt_c0,sapw_c0,store_c0,struct_c0, & - sum(leaf_c(1:nleafage)), fnrt_c, sapw_c,store_c, struct_c, & - target_leaf_c, target_fnrt_c, target_sapw_c, & - target_store_c, target_struct_c, & - carbon_balance,ipft,leaf_status, & - grow_leaf, grow_fnrt, grow_sapw, grow_store, grow_struct) - - ! -------------------------------------------------------------------------------- - ! The numerical integration of growth requires that the instantaneous state - ! variables are passed in as an array. We call it "c_pool". - ! - ! Initialize the adaptive integrator arrays and flags - ! -------------------------------------------------------------------------------- - - ierr = 1 - totalC = carbon_balance - nsteps = 0 - - c_pool(:) = 0.0_r8 ! Zero state variable array - c_mask(:) = .false. ! This mask tells the integrator - ! which indices are active. Its possible - ! that due to fusion, or previous numerical - ! truncation errors, that one of these pools - ! may be larger than its target! We check - ! this, and if true, then we flag that - ! pool to be ignored. c_mask(i) = .false. - ! For grasses, since they don't grow very - ! large and thus won't accumulate such large - ! errors, we always mask as true. - - c_pool(leaf_c_id) = sum(leaf_c(1:nleafage)) - c_pool(fnrt_c_id) = fnrt_c - c_pool(sapw_c_id) = sapw_c - c_pool(store_c_id) = store_c - c_pool(struct_c_id) = struct_c - c_pool(repro_c_id) = repro_c - c_pool(dbh_id) = dbh - - ! Only grow leaves if we are in a "leaf-on" status - select case (leaf_status) - case (leaves_on) - c_mask(leaf_c_id) = grow_leaf - case default - c_mask(leaf_c_id) = .false. - end select - c_mask(fnrt_c_id) = grow_fnrt - c_mask(sapw_c_id) = grow_sapw - c_mask(struct_c_id) = grow_struct - c_mask(store_c_id) = grow_store - c_mask(repro_c_id) = .true. ! Always calculate reproduction on growth - c_mask(dbh_id) = .true. ! Always increment dbh on growth step - - - ! When using the Euler method, we keep things simple. We always try - ! to make the first integration step to span the entirety of the integration - ! window for the independent variable (available carbon) - - select case (ODESolve) - case (2) - this%ode_opt_step = totalC - end select - - do_solve_check: do while( ierr .ne. 0 ) - - deltaC = min(totalC,this%ode_opt_step) - select_ODESolve: select case (ODESolve) - case (1) - call RKF45(AllomCGrowthDeriv,c_pool,c_mask,deltaC,totalC, & - max_trunc_error,intgr_params,c_pool_out,this%ode_opt_step,step_pass) - - case (2) - call Euler(AllomCGrowthDeriv,c_pool,c_mask,deltaC,totalC,intgr_params,c_pool_out) - ! step_pass = .true. - - ! When integrating along the allometric curve, we have the luxury of perfect - ! hindsite. Ie, after we have made our step, we can see if the amount - ! of each carbon we have matches the target associated with the new dbh. - ! The following call evaluates how close we are to the allometically defined - ! targets. If we are too far (governed by max_trunc_error), then we - ! pass back the pass/fail flag (step_pass) as false. If false, then - ! we halve the step-size, and then retry. If that step was fine, then - ! we remember the current step size as a good next guess. - - call CheckIntegratedAllometries(c_pool_out(dbh_id),ipft,canopy_trim, & - c_pool_out(leaf_c_id), c_pool_out(fnrt_c_id), c_pool_out(sapw_c_id), & - c_pool_out(store_c_id), c_pool_out(struct_c_id), & - c_mask(leaf_c_id), c_mask(fnrt_c_id), c_mask(sapw_c_id), & - c_mask(store_c_id),c_mask(struct_c_id), max_trunc_error, step_pass) - if(step_pass) then - this%ode_opt_step = deltaC - else - this%ode_opt_step = 0.5*deltaC - end if - case default - write(fates_log(),*) 'An integrator was chosen that does not exist' - write(fates_log(),*) 'ODESolve = ',ODESolve - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select select_ODESolve - - nsteps = nsteps + 1 - - if (step_pass) then ! If true, then step is accepted - totalC = totalC - deltaC - c_pool(:) = c_pool_out(:) - end if - - if(nsteps > max_substeps ) then - write(fates_log(),fmt=*) '---~---' - write(fates_log(),fmt=*) 'Plant Growth Integrator could not find' - write(fates_log(),fmt=*) 'a solution in less than ',max_substeps,' tries.' - write(fates_log(),fmt=*) 'Aborting!' - write(fates_log(),fmt=*) '---~---' - write(fates_log(),fmt=fmti) 'Leaf status =',leaf_status - write(fates_log(),fmt=fmt0) 'Carbon_balance =',carbon_balance - write(fates_log(),fmt=fmt0) 'deltaC =',deltaC - write(fates_log(),fmt=fmt0) 'totalC =',totalC - write(fates_log(),fmt=fmth) ' Tissue |', ' Grow',' Current',' Target' ,' Deficit' - write(fates_log(),fmt=fmtg) ' Leaf |', grow_leaf , sum(leaf_c(:)),target_leaf_c , target_leaf_c - sum(leaf_c(:)) - write(fates_log(),fmt=fmtg) ' Fine root |', grow_fnrt , fnrt_c,target_fnrt_c , target_fnrt_c - fnrt_c - write(fates_log(),fmt=fmtg) ' Sapwood |', grow_sapw , sapw_c,target_sapw_c , target_sapw_c - sapw_c - write(fates_log(),fmt=fmtg) ' Storage |', grow_store , store_c,target_store_c , target_store_c - store_c - write(fates_log(),fmt=fmtg) ' Structural |', grow_struct , struct_c,target_struct_c, target_struct_c - struct_c - write(fates_log(),fmt=*) '---~---' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! - ! TotalC should eventually be whittled down to near zero. - ! The solvers are not perfect, so we can't expect it to be perfectly zero. - ! Note that calloc_abs_error is 1e-9, which is really small (1 microgram of carbon) - ! yet also six orders of magnitude greater than typical rounding errors (~1e-15). - - ! At that point, update the actual states - ! -------------------------------------------------------------------------------- - if_step_pass: if( (totalC < calloc_abs_error) .and. (step_pass) )then - - ierr = 0 - leaf_c_flux = c_pool(leaf_c_id) - sum(leaf_c(1:nleafage)) - fnrt_c_flux = c_pool(fnrt_c_id) - fnrt_c - sapw_c_flux = c_pool(sapw_c_id) - sapw_c - store_c_flux = c_pool(store_c_id) - store_c - struct_c_flux = c_pool(struct_c_id) - struct_c - repro_c_flux = c_pool(repro_c_id) - repro_c - - ! Make an adjustment to flux partitions to make it match remaining c balance - flux_adj = carbon_balance/(leaf_c_flux+fnrt_c_flux+sapw_c_flux + & - store_c_flux+struct_c_flux+repro_c_flux) - - - leaf_c_flux = leaf_c_flux*flux_adj - fnrt_c_flux = fnrt_c_flux*flux_adj - sapw_c_flux = sapw_c_flux*flux_adj - store_c_flux = store_c_flux*flux_adj - struct_c_flux = struct_c_flux*flux_adj - repro_c_flux = repro_c_flux*flux_adj - - carbon_balance = carbon_balance - leaf_c_flux - leaf_c(iexp_leaf) = leaf_c(iexp_leaf) + leaf_c_flux - - carbon_balance = carbon_balance - fnrt_c_flux - fnrt_c = fnrt_c + fnrt_c_flux - - carbon_balance = carbon_balance - sapw_c_flux - sapw_c = sapw_c + sapw_c_flux - - carbon_balance = carbon_balance - store_c_flux - store_c = store_c + store_c_flux - - carbon_balance = carbon_balance - struct_c_flux - struct_c = struct_c + struct_c_flux - - carbon_balance = carbon_balance - repro_c_flux - repro_c = repro_c + repro_c_flux - - dbh = c_pool(dbh_id) - - if( abs(carbon_balance)>calloc_abs_error ) then - write(fates_log(),*) 'carbon conservation error while integrating pools' - write(fates_log(),*) 'along alometric curve' - write(fates_log(),*) 'carbon_balance = ',carbon_balance,totalC - write(fates_log(),*) 'exiting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - end if if_step_pass - - end do do_solve_check - - end if if_stature_growth + this%variables(repro_c_id)%net_alloc(icd) = & + this%variables(repro_c_id)%net_alloc(icd) + (repro_c - repro_c0) - ! Track the net allocations and transport from this routine - ! (the AgeLeaves() routine handled tracking allocation through aging) + this%variables(struct_c_id)%net_alloc(icd) = & + this%variables(struct_c_id)%net_alloc(icd) + (struct_c - struct_c0) - this%variables(leaf_c_id)%net_alloc(icd) = & - this%variables(leaf_c_id)%net_alloc(icd) + (leaf_c(icd) - leaf_c0(icd)) - - this%variables(fnrt_c_id)%net_alloc(icd) = & - this%variables(fnrt_c_id)%net_alloc(icd) + (fnrt_c - fnrt_c0) - - this%variables(sapw_c_id)%net_alloc(icd) = & - this%variables(sapw_c_id)%net_alloc(icd) + (sapw_c - sapw_c0) - - this%variables(store_c_id)%net_alloc(icd) = & - this%variables(store_c_id)%net_alloc(icd) + (store_c - store_c0) - - this%variables(repro_c_id)%net_alloc(icd) = & - this%variables(repro_c_id)%net_alloc(icd) + (repro_c - repro_c0) - - this%variables(struct_c_id)%net_alloc(icd) = & - this%variables(struct_c_id)%net_alloc(icd) + (struct_c - struct_c0) + end associate - end associate - - return + return end subroutine DailyPRTAllometricCarbon ! ===================================================================================== @@ -899,15 +914,16 @@ function AllomCGrowthDeriv(c_pools,c_mask,cbalance,intgr_params) result(dCdx) real(r8),dimension(lbound(c_pools,dim=1):ubound(c_pools,dim=1)) :: dCdx ! locals - integer :: ipft ! PFT index + integer :: ipft ! PFT index + integer :: crowndamage ! Damage class real(r8) :: canopy_trim ! Canopy trimming function (boundary condition [0-1] - real(r8) :: ct_leaf ! target leaf biomass, dummy var (kgC) - real(r8) :: ct_fnrt ! target fine-root biomass, dummy var (kgC) - real(r8) :: ct_sap ! target sapwood biomass, dummy var (kgC) - real(r8) :: ct_agw ! target aboveground wood, dummy var (kgC) - real(r8) :: ct_bgw ! target belowground wood, dummy var (kgC) - real(r8) :: ct_store ! target storage, dummy var (kgC) - real(r8) :: ct_dead ! target structural biomas, dummy var (kgC) + real(r8) :: ct_leaf ! target leaf biomass, dummy var (kgC) + real(r8) :: ct_fnrt ! target fine-root biomass, dummy var (kgC) + real(r8) :: ct_sap ! target sapwood biomass, dummy var (kgC) + real(r8) :: ct_agw ! target aboveground wood, dummy var (kgC) + real(r8) :: ct_bgw ! target belowground wood, dummy var (kgC) + real(r8) :: ct_store ! target storage, dummy var (kgC) + real(r8) :: ct_dead ! target structural biomas, dummy var (kgC) real(r8) :: sapw_area ! dummy sapwood area real(r8) :: ct_dleafdd ! target leaf biomass derivative wrt diameter, (kgC/cm) real(r8) :: ct_dfnrtdd ! target fine-root biomass derivative wrt diameter, (kgC/cm) @@ -937,17 +953,16 @@ function AllomCGrowthDeriv(c_pools,c_mask,cbalance,intgr_params) result(dCdx) canopy_trim = intgr_params(ac_bc_in_id_ctrim) ipft = int(intgr_params(ac_bc_in_id_pft)) - - - call bleaf(dbh,ipft,canopy_trim,ct_leaf,ct_dleafdd) + crowndamage = int(intgr_params(ac_bc_in_id_cdamage)) + + call bleaf(dbh,ipft,crowndamage,canopy_trim,ct_leaf, dbldd=ct_dleafdd) call bfineroot(dbh,ipft,canopy_trim,ct_fnrt,ct_dfnrtdd) - call bsap_allom(dbh,ipft,canopy_trim,sapw_area,ct_sap,ct_dsapdd) - - call bagw_allom(dbh,ipft,ct_agw,ct_dagwdd) - call bbgw_allom(dbh,ipft,ct_bgw,ct_dbgwdd) + call bsap_allom(dbh,ipft, crowndamage, canopy_trim,sapw_area,ct_sap,ct_dsapdd) + call bagw_allom(dbh,ipft,crowndamage, ct_agw,ct_dagwdd) + call bbgw_allom(dbh,ipft,ct_bgw, ct_dbgwdd) call bdead_allom(ct_agw,ct_bgw, ct_sap, ipft, ct_dead, & ct_dagwdd, ct_dbgwdd, ct_dsapdd, ct_ddeaddd) - call bstore_allom(dbh,ipft,canopy_trim,ct_store,ct_dstoredd) + call bstore_allom(dbh,ipft,crowndamage, canopy_trim,ct_store,ct_dstoredd) ! fraction of carbon going towards reproduction if (dbh <= prt_params%dbh_repro_threshold(ipft)) then ! cap on leaf biomass @@ -1121,8 +1136,8 @@ subroutine FastPRTAllometricCarbon(this) return - end subroutine FastPRTAllometricCarbon - + end subroutine FastPRTAllometricCarbon + end module PRTAllometricCarbonMod diff --git a/parteh/PRTGenericMod.F90 b/parteh/PRTGenericMod.F90 index 35488bd8cc..001c617912 100644 --- a/parteh/PRTGenericMod.F90 +++ b/parteh/PRTGenericMod.F90 @@ -185,8 +185,9 @@ module PRTGenericMod ! over the control period real(r8),allocatable :: burned(:) ! Losses due to burn [kg] + real(r8),allocatable :: damaged(:) ! Losses due to damage [kg] -! real(r8),allocatable :: herbiv(:) ! Losses due to herbivory [kg] + ! real(r8),allocatable :: herbiv(:) ! Losses due to herbivory [kg] ! Placeholder ! To save on memory, keep this commented out, or simply @@ -241,6 +242,7 @@ module PRTGenericMod procedure :: DailyPRT => DailyPRTBase procedure :: FastPRT => FastPRTBase + procedure :: DamageRecovery => DamageRecoveryBase procedure :: GetNutrientTarget => GetNutrientTargetBase ! These are generic functions that should work on all hypotheses @@ -262,7 +264,8 @@ module PRTGenericMod procedure, non_overridable :: DeallocatePRTVartypes procedure, non_overridable :: WeightedFusePRTVartypes procedure, non_overridable :: CopyPRTVartypes - + + procedure :: AgeLeaves ! This routine may be used generically ! but also leaving the door open for over-rides @@ -542,7 +545,8 @@ subroutine InitAllocate(this) allocate(this%variables(i_var)%turnover(num_pos)) allocate(this%variables(i_var)%net_alloc(num_pos)) allocate(this%variables(i_var)%burned(num_pos)) - + allocate(this%variables(i_var)%damaged(num_pos)) + end do @@ -567,6 +571,7 @@ subroutine InitializeInitialConditions(this) this%variables(i_var)%val0(:) = un_initialized this%variables(i_var)%turnover(:) = un_initialized this%variables(i_var)%burned(:) = un_initialized + this%variables(i_var)%damaged(:) = un_initialized this%variables(i_var)%net_alloc(:) = un_initialized end do @@ -787,6 +792,7 @@ subroutine CopyPRTVartypes(this, donor_prt_obj) this%variables(i_var)%net_alloc(:) = donor_prt_obj%variables(i_var)%net_alloc(:) this%variables(i_var)%turnover(:) = donor_prt_obj%variables(i_var)%turnover(:) this%variables(i_var)%burned(:) = donor_prt_obj%variables(i_var)%burned(:) + this%variables(i_var)%damaged(:) = donor_prt_obj%variables(i_var)%damaged(:) end do this%ode_opt_step = donor_prt_obj%ode_opt_step @@ -834,6 +840,9 @@ subroutine WeightedFusePRTVartypes(this,donor_prt_obj, recipient_fuse_weight) this%variables(i_var)%burned(pos_id) = recipient_fuse_weight * this%variables(i_var)%burned(pos_id) + & (1.0_r8-recipient_fuse_weight) * donor_prt_obj%variables(i_var)%burned(pos_id) + this%variables(i_var)%damaged(pos_id) = recipient_fuse_weight * this%variables(i_var)%damaged(pos_id) + & + (1.0_r8-recipient_fuse_weight) * donor_prt_obj%variables(i_var)%damaged(pos_id) + end do end do @@ -872,6 +881,7 @@ subroutine DeallocatePRTVartypes(this) deallocate(this%variables(i_var)%net_alloc) deallocate(this%variables(i_var)%turnover) deallocate(this%variables(i_var)%burned) + deallocate(this%variables(i_var)%damaged) end do deallocate(this%variables) @@ -914,6 +924,7 @@ subroutine ZeroRates(this) this%variables(i_var)%net_alloc(:) = 0.0_r8 this%variables(i_var)%turnover(:) = 0.0_r8 this%variables(i_var)%burned(:) = 0.0_r8 + this%variables(i_var)%damaged(:) = 0.0_r8 end do end subroutine ZeroRates @@ -949,14 +960,16 @@ subroutine CheckMassConservation(this,ipft,position_id) err = abs((this%variables(i_var)%val(i_pos) - this%variables(i_var)%val0(i_pos)) - & (this%variables(i_var)%net_alloc(i_pos) & -this%variables(i_var)%turnover(i_pos) & - -this%variables(i_var)%burned(i_pos) )) - + -this%variables(i_var)%burned(i_pos) & + -this%variables(i_var)%damaged(i_pos))) + if(this%variables(i_var)%val(i_pos) > nearzero ) then rel_err = err / this%variables(i_var)%val(i_pos) else rel_err = 0.0_r8 end if + if( abs(err) > calloc_abs_error ) then write(fates_log(),*) 'PARTEH mass conservation check failed' write(fates_log(),*) ' Change in mass over control period should' @@ -973,7 +986,8 @@ subroutine CheckMassConservation(this,ipft,position_id) this%variables(i_var)%val0(i_pos), & this%variables(i_var)%net_alloc(i_pos), & this%variables(i_var)%turnover(i_pos), & - this%variables(i_var)%burned(i_pos) + this%variables(i_var)%burned(i_pos), & + this%variables(i_var)%damaged(i_pos) write(fates_log(),*) ' Exiting.' call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1240,9 +1254,10 @@ end function GetCoordVal ! ==================================================================================== - subroutine DailyPRTBase(this) + subroutine DailyPRTBase(this,phase) - class(prt_vartypes) :: this + class(prt_vartypes) :: this + integer,intent(in) :: phase ! We allow this and its children to be broken into phases write(fates_log(),*)'Daily PRT Allocation must be extended' call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1251,17 +1266,28 @@ end subroutine DailyPRTBase ! ==================================================================================== - subroutine FastPRTBase(this) + subroutine DamageRecoveryBase(this) class(prt_vartypes) :: this - write(fates_log(),*)'FastReactiveTransport must be extended by a child class.' + write(fates_log(),*)'?' call endrun(msg=errMsg(sourcefile, __LINE__)) - end subroutine FastPRTBase + end subroutine DamageRecoveryBase ! ==================================================================================== + ! ==================================================================================== + + subroutine FastPRTBase(this) + + class(prt_vartypes) :: this + + write(fates_log(),*)'FastReactiveTransport must be extended by a child class' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end subroutine FastPRTBase + + !==================================================================================== subroutine SetState(prt,organ_id, element_id, state_val, position_id) ! This routine should only be called for initalizing the state value diff --git a/parteh/PRTLossFluxesMod.F90 b/parteh/PRTLossFluxesMod.F90 index 6f23924d48..7c1a688ebc 100644 --- a/parteh/PRTLossFluxesMod.F90 +++ b/parteh/PRTLossFluxesMod.F90 @@ -1,3 +1,4 @@ + module PRTLossFluxesMod @@ -64,7 +65,9 @@ module PRTLossFluxesMod public :: PRTBurnLosses public :: PRTPhenologyFlush public :: PRTReproRelease - + public :: PRTDamageLosses + public :: PRTDamageRecoveryFluxes + contains @@ -335,7 +338,62 @@ subroutine PRTBurnLosses(prt, organ_id, mass_fraction) end associate end subroutine PRTBurnLosses + ! ===================================================================================== + subroutine PRTDamageLosses(prt, organ_id, mass_fraction) + + ! ---------------------------------------------------------------------------------- + ! This subroutine assumes that there is no re-translocation associated + ! with damage. There is only one destiny for damaged mass within + ! the organ, and that is outside the plant. + ! It is also assumed that non PARTEH parts of the code (ie the damage-model) + ! will decide what to do with the damaged mass (i.e. sent it to the litter + ! pool, or.. other?) + ! ---------------------------------------------------------------------------------- + + class(prt_vartypes) :: prt + integer,intent(in) :: organ_id + real(r8),intent(in) :: mass_fraction + + integer :: i_pos ! position index + integer :: i_var ! index for the variable of interest + integer :: i_var_of_organ ! loop counter for all element in this organ + integer :: element_id ! Element id of the turnover pool + real(r8) :: damaged_mass ! Lost mass of each element, in each + ! position, in the organ of interest + + associate(organ_map => prt_global%organ_map) + + ! This is the total number of state variables associated + ! with this particular organ + + do i_var_of_organ = 1, organ_map(organ_id)%num_vars + + i_var = organ_map(organ_id)%var_id(i_var_of_organ) + + element_id = prt_global%state_descriptor(i_var)%element_id + + ! Loop over all of the coordinate ids + do i_pos = 1,prt_global%state_descriptor(i_var)%num_pos + + ! The mass that is leaving the plant + damaged_mass = mass_fraction * prt%variables(i_var)%val(i_pos) + + ! Track the amount of mass being lost (+ is amount lost) + prt%variables(i_var)%damaged(i_pos) = prt%variables(i_var)%damaged(i_pos) & + + damaged_mass + + ! Update the state of the pool to reflect the mass lost + prt%variables(i_var)%val(i_pos) = prt%variables(i_var)%val(i_pos) & + - damaged_mass + + end do + + end do + + end associate + end subroutine PRTDamageLosses + ! ===================================================================================== @@ -796,6 +854,30 @@ subroutine MaintTurnoverSimpleRetranslocation(prt,ipft,is_drought) return end subroutine MaintTurnoverSimpleRetranslocation + !---------------------------------------------------------------------------------------------- + + subroutine PRTDamageRecoveryFluxes(prt, organ_id, mass_0, mass, cc_mass) + + class(prt_vartypes) :: prt + integer,intent(in) :: organ_id + real(r8),intent(in) :: mass_0 + real(r8),intent(in) :: mass + real(r8),intent(in) :: cc_mass + + integer, parameter :: icd = 1 + + ! Remove the amount that was copied from old cohort + prt%variables(organ_id)%net_alloc(icd) = prt%variables(organ_id)%net_alloc(icd) & + - (cc_mass - mass_0) + + + ! Track the amount of mass being lost (+ is amount lost) + prt%variables(organ_id)%net_alloc(icd) = prt%variables(organ_id)%net_alloc(icd) & + + (mass - mass_0) + + end subroutine PRTDamageRecoveryFluxes + + ! ===================================================================================== diff --git a/parteh/PRTParamsFATESMod.F90 b/parteh/PRTParamsFATESMod.F90 index 66033a3194..76558874b7 100644 --- a/parteh/PRTParamsFATESMod.F90 +++ b/parteh/PRTParamsFATESMod.F90 @@ -1378,14 +1378,16 @@ function NewRecruitTotalStoichiometry(ft,element_id) result(recruit_stoich) real(r8) :: c_total ! total target carbon real(r8) :: nutr_total ! total target nutrient + integer, parameter :: not_damaged = 1 ! this is also in MainDamageMod, here for dependency purposes + call h2d_allom(EDPftvarcon_inst%hgt_min(ft),ft,dbh) - call bleaf(dbh,ft,init_recruit_trim,c_leaf) + call bleaf(dbh,ft,not_damaged,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 bsap_allom(dbh,ft,not_damaged,init_recruit_trim,a_sapw, c_sapw) + call bagw_allom(dbh,ft,not_damaged,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) + call bstore_allom(dbh,ft,not_damaged,init_recruit_trim,c_store) ! Total carbon in a newly recruited plant c_total = c_leaf + c_fnrt + c_sapw + c_struct + c_store