From 47fdb33f7840fcdd4287b476b9ed578dd0c951b1 Mon Sep 17 00:00:00 2001 From: Ben Andre Date: Thu, 11 May 2017 23:41:13 -0600 Subject: [PATCH] Import the fates-clm-v0.3 tag from ed-clm repo and svn. --- biogeochem/EDCanopyStructureMod.F90 | 1456 ++++++++ biogeochem/EDCohortDynamicsMod.F90 | 1271 +++++++ biogeochem/EDGrowthFunctionsMod.F90 | 442 +++ biogeochem/EDPatchDynamicsMod.F90 | 1599 +++++++++ biogeochem/EDPhysiologyMod.F90 | 1701 +++++++++ biogeophys/EDAccumulateFluxesMod.F90 | 116 + biogeophys/EDBtranMod.F90 | 353 ++ biogeophys/EDSurfaceAlbedoMod.F90 | 1104 ++++++ biogeophys/FatesPlantHydraulicsMod.F90 | 351 ++ biogeophys/FatesPlantRespPhotosynthMod.F90 | 1643 +++++++++ fire/SFMainMod.F90 | 990 ++++++ fire/SFParamsMod.F90 | 343 ++ main/CMakeLists.txt | 9 + main/ChecksBalancesMod.F90 | 238 ++ main/EDEcophysConType.F90 | 248 ++ main/EDInitMod.F90 | 330 ++ main/EDMainMod.F90 | 575 ++++ main/EDParamsMod.F90 | 314 ++ main/EDPftvarcon.F90 | 1015 ++++++ main/EDTypesMod.F90 | 740 ++++ main/FatesConstantsMod.F90 | 98 + main/FatesGlobals.F90 | 70 + main/FatesHistoryInterfaceMod.F90 | 3614 ++++++++++++++++++++ main/FatesHistoryVariableType.F90 | 281 ++ main/FatesHydraulicsMemMod.F90 | 214 ++ main/FatesIODimensionsMod.F90 | 155 + main/FatesIOVariableKindMod.F90 | 114 + main/FatesInterfaceMod.F90 | 1122 ++++++ main/FatesParameterDerivedMod.F90 | 117 + main/FatesParametersInterface.F90 | 484 +++ main/FatesRestartInterfaceMod.F90 | 1853 ++++++++++ main/FatesRestartVariableType.F90 | 203 ++ main/FatesSynchronizedParamsMod.F90 | 131 + main/FatesUtilsMod.F90 | 34 + 34 files changed, 23328 insertions(+) create mode 100644 biogeochem/EDCanopyStructureMod.F90 create mode 100644 biogeochem/EDCohortDynamicsMod.F90 create mode 100644 biogeochem/EDGrowthFunctionsMod.F90 create mode 100644 biogeochem/EDPatchDynamicsMod.F90 create mode 100644 biogeochem/EDPhysiologyMod.F90 create mode 100644 biogeophys/EDAccumulateFluxesMod.F90 create mode 100644 biogeophys/EDBtranMod.F90 create mode 100644 biogeophys/EDSurfaceAlbedoMod.F90 create mode 100644 biogeophys/FatesPlantHydraulicsMod.F90 create mode 100644 biogeophys/FatesPlantRespPhotosynthMod.F90 create mode 100644 fire/SFMainMod.F90 create mode 100644 fire/SFParamsMod.F90 create mode 100644 main/CMakeLists.txt create mode 100644 main/ChecksBalancesMod.F90 create mode 100644 main/EDEcophysConType.F90 create mode 100644 main/EDInitMod.F90 create mode 100644 main/EDMainMod.F90 create mode 100644 main/EDParamsMod.F90 create mode 100644 main/EDPftvarcon.F90 create mode 100644 main/EDTypesMod.F90 create mode 100644 main/FatesConstantsMod.F90 create mode 100644 main/FatesGlobals.F90 create mode 100644 main/FatesHistoryInterfaceMod.F90 create mode 100644 main/FatesHistoryVariableType.F90 create mode 100644 main/FatesHydraulicsMemMod.F90 create mode 100644 main/FatesIODimensionsMod.F90 create mode 100644 main/FatesIOVariableKindMod.F90 create mode 100644 main/FatesInterfaceMod.F90 create mode 100644 main/FatesParameterDerivedMod.F90 create mode 100644 main/FatesParametersInterface.F90 create mode 100644 main/FatesRestartInterfaceMod.F90 create mode 100644 main/FatesRestartVariableType.F90 create mode 100644 main/FatesSynchronizedParamsMod.F90 create mode 100644 main/FatesUtilsMod.F90 diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 new file mode 100644 index 00000000..e4453a62 --- /dev/null +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -0,0 +1,1456 @@ +module EDCanopyStructureMod + + ! ============================================================================ + ! Code to determine whether the canopy is closed, and which plants are either in the understorey or overstorey + ! This is obviosuly far too complicated for it's own good and needs re-writing. + ! ============================================================================ + + use FatesConstantsMod , only : r8 => fates_r8 + use FatesGlobals , only : fates_log + use EDPftvarcon , only : EDPftvarcon_inst + use EDGrowthFunctionsMod , only : c_area + use EDCohortDynamicsMod , only : copy_cohort, terminate_cohorts, fuse_cohorts + use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, ncwd + use EDTypesMod , only : nclmax + use EDTypesMod , only : nlevleaf + use EDTypesMod , only : numpft_ed + use EDtypesMod , only : AREA + use FatesGlobals , only : endrun => fates_endrun + use FatesInterfaceMod , only : hlm_days_per_year + + ! CIME Globals + use shr_log_mod , only : errMsg => shr_log_errMsg + + implicit none + private + + public :: canopy_structure + public :: canopy_spread + public :: calc_areaindex + public :: canopy_summarization + public :: update_hlm_dynamics + + logical, parameter :: DEBUG=.false. + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + ! 10/30/09: Created by Rosie Fisher + ! ============================================================================ + +contains + + ! ============================================================================ + subroutine canopy_structure( currentSite , bc_in ) + ! + ! !DESCRIPTION: + ! create cohort instance + ! + ! This routine allocates the 'canopy_layer' attribute to each cohort + ! All top leaves in the same canopy layer get the same light resources. + ! The first canopy layer is the 'canopy' or 'overstorey'. The second is the 'understorey'. + ! More than two layers is not permitted at the moment + ! Seeds germinating into the 3rd or higher layers are automatically removed. + ! + ! ------Perfect Plasticity----- + ! The idea of these canopy layers derives originally from Purves et al. 2009 + ! Their concept is that, given enoughplasticity in canopy position, size, shape and depth + ! all of the gound area will be filled perfectly by leaves, and additional leaves will have + ! to exist in the understorey. + ! Purves et al. use the concept of 'Z*' to assume that the height required to attain a place in the + ! canopy is spatially uniform. In this implementation, described in Fisher et al. (2010, New Phyt) we + ! extent that concept to assume that position in the canopy has some random element, and that BOTH height + ! and chance combine to determine whether trees get into the canopy. + ! Thus, when the canopy is closed and there is excess area, some of it must be demoted + ! If we demote -all- the trees less than a given height, there is a massive advantage in being the cohort that is + ! the biggest when the canopy is closed. + ! In this implementation, the amount demoted, ('weight') is a function of the height weighted by the competitive exclusion + ! parameter (ED_val_comp_excln). + + ! Complexity in this routine results from a few things. + ! Firstly, the complication of the demotion amount sometimes being larger than the cohort area (for a very small, short cohort) + ! Second, occasionaly, disturbance (specifically fire) can cause the canopy layer to become less than closed, + ! without changing the area of the patch. If this happens, then some of the plants in the lower layer need to be 'promoted' so + ! all of the routine has to happen in both the downwards and upwards directions. + ! + ! The order of events here is therefore: + ! (The entire subroutine has a single outer 'patch' loop. + ! Section 1: figure out the total area, and whether there are >1 canopy layers at all. + ! + ! Sorts out cohorts into canopy and understorey layers... + ! + ! !USES: + + use EDParamsMod, only : ED_val_comp_excln, ED_val_ag_biomass + use SFParamsMod, only : SF_val_cwd_frac + use EDtypesMod , only : ncwd, min_patch_area + use FatesInterfaceMod, only : bc_in_type + ! + ! !ARGUMENTS + type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type), intent(in) :: bc_in + + ! + ! !LOCAL VARIABLES: + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort,copyc + integer :: i,j + integer :: c ! index for CWD + integer :: z ! Current number of canopy layers. (1= canopy, 2 = understorey) + real(r8) :: checkarea + real(r8) :: cc_loss + real(r8) :: lossarea + real(r8) :: newarea + real(r8) :: arealayer(nlevleaf) ! Amount of plant area currently in each canopy layer + real(r8) :: sumdiff(nlevleaf) ! The total of the exclusion weights for all cohorts in layer z + real(r8) :: weight ! The amount of the total lost area that comes from this cohort + real(r8) :: sum_weights(nlevleaf) + real(r8) :: new_total_area_check + real(r8) :: missing_area, promarea,cc_gain,sumgain + integer :: promswitch,lower_cohort_switch + real(r8) :: sumloss,excess_area + integer :: count_mi + !---------------------------------------------------------------------- + + currentPatch => currentSite%oldest_patch + ! + ! zero site-level demotion / promotion tracking info + currentSite%demotion_rate(:) = 0._r8 + currentSite%promotion_rate(:) = 0._r8 + currentSite%demotion_carbonflux = 0._r8 + currentSite%promotion_carbonflux = 0._r8 + ! + ! Section 1: Check total canopy area. + ! + new_total_area_check = 0._r8 + do while (associated(currentPatch)) ! Patch loop + + if (currentPatch%area .gt. min_patch_area) then ! avoid numerical weirdness that shouldn't be happening anyway + + excess_area = 1.0_r8 + + ! Does any layer have excess area in it? Keep going until it does not... + + do while(excess_area > 0.000001_r8) + + ! Calculate the area currently in each canopy layer. + z = 1 + arealayer = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + currentCohort%c_area = c_area(currentCohort) ! Reassess cohort area. + arealayer(currentCohort%canopy_layer) = arealayer(currentCohort%canopy_layer) + currentCohort%c_area + z = max(z,currentCohort%canopy_layer) ! What is the current number of canopy layers? + currentCohort => currentCohort%shorter + enddo + + ! Does the bottom layer have more than a full canopy? If so we need to make another layer. + + if(arealayer(z) > currentPatch%area)then ! Do we have too much area in either layer? + !write(fates_log(),*) 'CANOPY CLOSURE', z + z = z + 1 + endif + + currentPatch%NCL_p = min(nclmax,z) ! Set current canopy layer occupancy indicator. + + do i = 1,z ! Loop around the currently occupied canopy layers. + + do while((arealayer(i)-currentPatch%area) > 0.000001_r8) + ! Is this layer currently over-occupied? + ! In that case, we need to work out which cohorts to demote. + + sumloss = 0.0_r8 + new_total_area_check = 0.0_r8 + sumdiff(i) = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + currentCohort%c_area = c_area(currentCohort) + if(arealayer(i) > currentPatch%area.and.currentCohort%canopy_layer == i)then + currentCohort%excl_weight = 1.0_r8/(currentCohort%dbh**ED_val_comp_excln) + sumdiff(i) = sumdiff(i) + currentCohort%excl_weight + endif + currentCohort => currentCohort%shorter + enddo !currentCohort + + lossarea = arealayer(i) - currentPatch%area !how much do we have to lose? + sum_weights(i) = 0.0_r8 + currentCohort => currentPatch%tallest !start from the tallest cohort + + ! Correct the demoted cohorts for + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i) then + weight = currentCohort%excl_weight/sumdiff(i) + currentCohort%excl_weight = min(currentCohort%c_area/lossarea, weight) + sum_weights(i) = sum_weights(i) + currentCohort%excl_weight + endif + currentCohort => currentCohort%shorter + enddo + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i)then !All the trees in this layer need to lose some area... + weight = currentCohort%excl_weight/sum_weights(i) + cc_loss = lossarea*weight !what this cohort has to lose. + !-----------Split and copy boundary cohort-----------------! + if(cc_loss < currentCohort%c_area)then + allocate(copyc) + + call copy_cohort(currentCohort, copyc) !makes an identical copy... + ! n.b this needs to happen BEFORE the cohort goes into the new layer, + ! otherwise currentPatch%spread(i+1) will be higher and the area will change...!!! + sumloss = sumloss + cc_loss + + newarea = currentCohort%c_area - cc_loss + copyc%n = currentCohort%n*newarea/currentCohort%c_area ! + currentCohort%n = currentCohort%n - (currentCohort%n*newarea/currentCohort%c_area) ! + + copyc%canopy_layer = i !the taller cohort is the copy + currentCohort%canopy_layer = i + 1 !demote the current cohort to the understory. + ! seperate cohorts. + ! - 0.000000000001_r8 !needs to be a very small number to avoid + ! causing non-linearity issues with c_area. is this really required? + currentCohort%dbh = currentCohort%dbh + copyc%dbh = copyc%dbh !+ 0.000000000001_r8 + + ! keep track of number and biomass of demoted cohort + currentSite%demotion_rate(currentCohort%size_class) = & + currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & + currentCohort%b * currentCohort%n + + !kill the ones which go into canopy layers that are not allowed... (default nclmax=2) + if(i+1 > nclmax)then + !put the litter from the terminated cohorts into the fragmenting pools + ! write(fates_log(),*) '3rd canopy layer' + do c=1,ncwd + + currentPatch%CWD_AG(c) = currentPatch%CWD_AG(c) + (currentCohort%bdead+currentCohort%bsw) * & + ED_val_ag_biomass * & + SF_val_CWD_frac(c)*currentCohort%n/currentPatch%area + + currentPatch%CWD_BG(c) = currentPatch%CWD_BG(c) + (currentCohort%bdead+currentCohort%bsw) * & + (1.0_r8-ED_val_ag_biomass) * & + SF_val_CWD_frac(c)*currentCohort%n/currentPatch%area !litter flux per m2. + + enddo + + currentPatch%leaf_litter(currentCohort%pft) = & + currentPatch%leaf_litter(currentCohort%pft) + (currentCohort%bl)* & + currentCohort%n/currentPatch%area ! leaf litter flux per m2. + + currentPatch%root_litter(currentCohort%pft) = & + currentPatch%root_litter(currentCohort%pft) + & + (currentCohort%br+currentCohort%bstore)*currentCohort%n/currentPatch%area + + ! keep track of the above fluxes at the site level as a CWD/litter input flux (in kg / site-m2 / yr) + do c=1,ncwd + currentSite%CWD_AG_diagnostic_input_carbonflux(c) = & + currentSite%CWD_AG_diagnostic_input_carbonflux(c) & + + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & + SF_val_CWD_frac(c) * ED_val_ag_biomass * hlm_days_per_year / AREA + currentSite%CWD_BG_diagnostic_input_carbonflux(c) = & + currentSite%CWD_BG_diagnostic_input_carbonflux(c) & + + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & + SF_val_CWD_frac(c) * (1.0_r8 - ED_val_ag_biomass) * hlm_days_per_year / AREA + enddo + + currentSite%leaf_litter_diagnostic_input_carbonflux(currentCohort%pft) = & + currentSite%leaf_litter_diagnostic_input_carbonflux(currentCohort%pft) + & + currentCohort%n * (currentCohort%bl) * hlm_days_per_year / AREA + currentSite%root_litter_diagnostic_input_carbonflux(currentCohort%pft) = & + currentSite%root_litter_diagnostic_input_carbonflux(currentCohort%pft) + & + currentCohort%n * (currentCohort%br+currentCohort%bstore) * hlm_days_per_year / AREA + + currentCohort%n = 0.0_r8 + currentCohort%c_area = 0._r8 + else + currentCohort%c_area = c_area(currentCohort) + endif + copyc%c_area = c_area(copyc) + new_total_area_check = new_total_area_check+copyc%c_area + + !----------- Insert copy into linked list ------------------------! + copyc%shorter => currentCohort + if(associated(currentCohort%taller))then + copyc%taller => currentCohort%taller + currentCohort%taller%shorter => copyc + else + currentPatch%tallest => copyc + copyc%taller => null() + endif + currentCohort%taller => copyc + else + currentCohort%canopy_layer = i + 1 !the whole cohort becomes demoted + sumloss = sumloss + currentCohort%c_area + + ! keep track of number and biomass of demoted cohort + currentSite%demotion_rate(currentCohort%size_class) = & + currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & + currentCohort%b * currentCohort%n + + !kill the ones which go into canopy layers that are not allowed... (default nclmax=2) + if(i+1 > nclmax)then + + !put the litter from the terminated cohorts into the fragmenting pools + do c=1,ncwd + + currentPatch%CWD_AG(c) = currentPatch%CWD_AG(c) + (currentCohort%bdead+currentCohort%bsw) * & + ED_val_ag_biomass * & + SF_val_CWD_frac(c)*currentCohort%n/currentPatch%area + currentPatch%CWD_BG(c) = currentPatch%CWD_BG(c) + (currentCohort%bdead+currentCohort%bsw) * & + (1.0_r8-ED_val_ag_biomass) * & + SF_val_CWD_frac(c)*currentCohort%n/currentPatch%area !litter flux per m2. + + enddo + + currentPatch%leaf_litter(currentCohort%pft) = & + currentPatch%leaf_litter(currentCohort%pft) + currentCohort%bl* & + currentCohort%n/currentPatch%area ! leaf litter flux per m2. + + currentPatch%root_litter(currentCohort%pft) = & + currentPatch%root_litter(currentCohort%pft) + & + (currentCohort%br+currentCohort%bstore)*currentCohort%n/currentPatch%area + + ! keep track of the above fluxes at the site level as a CWD/litter input flux (in kg / site-m2 / yr) + do c=1,ncwd + currentSite%CWD_AG_diagnostic_input_carbonflux(c) = & + currentSite%CWD_AG_diagnostic_input_carbonflux(c) & + + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & + SF_val_CWD_frac(c) * ED_val_ag_biomass * hlm_days_per_year / AREA + currentSite%CWD_BG_diagnostic_input_carbonflux(c) = & + currentSite%CWD_BG_diagnostic_input_carbonflux(c) & + + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & + SF_val_CWD_frac(c) * (1.0_r8 - ED_val_ag_biomass) * hlm_days_per_year / AREA + enddo + + currentSite%leaf_litter_diagnostic_input_carbonflux(currentCohort%pft) = & + currentSite%leaf_litter_diagnostic_input_carbonflux(currentCohort%pft) + & + currentCohort%n * (currentCohort%bl) * hlm_days_per_year / AREA + currentSite%root_litter_diagnostic_input_carbonflux(currentCohort%pft) = & + currentSite%root_litter_diagnostic_input_carbonflux(currentCohort%pft) + & + currentCohort%n * (currentCohort%br+currentCohort%bstore) * hlm_days_per_year / AREA + + currentCohort%n = 0.0_r8 + currentCohort%c_area = 0._r8 + + else + currentCohort%c_area = c_area(currentCohort) + endif + + !write(fates_log(),*) 'demoting whole cohort', currentCohort%c_area,cc_loss, & + !currentCohort%canopy_layer,currentCohort%dbh + + endif + + !----------- End of cohort splitting ------------------------------! + endif !canopy layer = i + + currentCohort => currentCohort%shorter + + enddo !currentCohort + + arealayer(i) = arealayer(i) - sumloss + !Update arealayer for diff calculations of layer below. + arealayer(i + 1) = arealayer(i + 1) + sumloss + + enddo !arealayer loop + if(arealayer(i)-currentPatch%area > 0.00001_r8)then + write(fates_log(),*) 'lossarea problem', lossarea,sumloss,z,currentPatch%patchno + endif + + enddo !z + + z = 1 + arealayer = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + currentCohort%c_area = c_area(currentCohort) + arealayer(currentCohort%canopy_layer) = arealayer(currentCohort%canopy_layer) + currentCohort%c_area + z = max(z,currentCohort%canopy_layer) + currentCohort => currentCohort%shorter + enddo + + !does the bottom layer have more than a full canopy? If so we need to make another layer. + if(arealayer(z) > currentPatch%area)then + z = z + 1 + endif + excess_area = 0.0_r8 + do j=1,z + if(arealayer(j) > currentPatch%area)then + excess_area = arealayer(j)-currentPatch%area + endif + enddo + currentPatch%ncl_p = min(z,nclmax) + + enddo !is there still excess area in any layer? + + call fuse_cohorts(currentPatch, bc_in) + call terminate_cohorts(currentSite, currentPatch) + + ! ----------- Check cohort area ------------------------------! + do i = 1,z + checkarea = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i)then + checkarea = checkarea + c_area(currentCohort) + endif + + currentCohort=>currentCohort%shorter + + enddo + + enddo ! + + + ! ----------- Check whether the intended 'full' layers are actually filling all the space. + ! If not, promote some fraction of cohorts upwards ------------------------------! + ! THIS SECTION MIGHT BE TRIGGERED BY A FIRE OR MORTALITY EVENT, FOLLOWED BY A PATCH FUSION, + ! SO THE TOP LAYER IS NO LONGER FULL... + + promswitch = 0 + + missing_area=1.0_r8 + count_mi = 0 + !does any layer have excess area in it? keep going until it does not... + do while(missing_area > 0.000001_r8.and.z > 1) + count_mi = count_mi +1 + do i = 1,z-1 ! if z is greater than one, there is a possibility of too many plants in the understorey. + lower_cohort_switch = 1 + ! is the area of the layer less than the area of the patch, if it is supposed to be closed (z>1) + do while((arealayer(i)-currentPatch%area) < -0.000001_r8.and.lower_cohort_switch == 1) + + if(arealayer(i+1) <= 0.000001_r8)then + currentCohort => currentPatch%tallest + arealayer = 0._r8 + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i+1)then !look at the cohorts in the canopy layer below... + currentCohort%canopy_layer = i + currentCohort%c_area = c_area(currentCohort) + + ! keep track of number and biomass of promoted cohort + currentSite%promotion_rate(currentCohort%size_class) = & + currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & + currentCohort%b * currentCohort%n + + ! write(fates_log(),*) 'promoting very small cohort', currentCohort%c_area,currentCohort%canopy_layer + endif + arealayer(currentCohort%canopy_layer) = arealayer(currentCohort%canopy_layer)+currentCohort%c_area + currentCohort => currentCohort%shorter + enddo + + endif !promoting all of the small amount of area in the lower layers. + + + lower_cohort_switch = 0 + sumgain = 0.0_r8 + sumdiff(i) = 0.0_r8 + ! figure out with what weighting we need to promote cohorts. + ! This is the opposite of the demotion weighting... + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + currentCohort%c_area = c_area(currentCohort) + if(currentCohort%canopy_layer == i+1)then !look at the cohorts in the canopy layer below... + currentCohort%prom_weight = currentCohort%dbh**ED_val_comp_excln !as opposed to 1/(dbh^C_e) + sumdiff(i) = sumdiff(i) + currentCohort%prom_weight + endif + currentCohort => currentCohort%shorter + enddo !currentCohort + + promarea = currentPatch%area -arealayer(i) !how much do we need to gain? + sum_weights(i) = 0.0_r8 + currentCohort => currentPatch%tallest !start from the tallest cohort + + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i+1) then !still looking at the layer beneath. + weight = currentCohort%prom_weight/sumdiff(i) + if(promarea > 0._r8)then + currentCohort%prom_weight = min(currentCohort%c_area/promarea, weight) + else + currentCohort%prom_weight = 0._r8 + endif + sum_weights(i) = sum_weights(i) + currentCohort%prom_weight + endif + currentCohort => currentCohort%shorter + enddo + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i+1)then !All the trees in this layer need to promote some area upwards... + lower_cohort_switch = 1 + weight = currentCohort%prom_weight/sum_weights(i) + cc_gain = promarea*weight !what this cohort has to promote. + !-----------Split and copy boundary cohort-----------------! + if(cc_gain < currentCohort%c_area)then + allocate(copyc) + + call copy_cohort(currentCohort, copyc) !makes an identical copy... + ! n.b this needs to happen BEFORE the cohort goes into the new layer, otherwise currentPatch + ! %spread(+1) will be higher and the area will change...!!! + sumgain = sumgain + cc_gain + + + newarea = currentCohort%c_area - cc_gain !new area of existing cohort + copyc%n = currentCohort%n*cc_gain/currentCohort%c_area !number of individuals in promoted cohort. + ! number of individuals in cohort remaining in understorey + currentCohort%n = currentCohort%n - (currentCohort%n*cc_gain/currentCohort%c_area) + + currentCohort%canopy_layer = i+1 !keep current cohort in the understory. + copyc%canopy_layer = i ! promote copy to the higher canopy layer. + + ! keep track of number and biomass of promoted cohort + currentSite%promotion_rate(copyc%size_class) = & + currentSite%promotion_rate(copyc%size_class) + copyc%n + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & + copyc%b * copyc%n + + ! seperate cohorts. + ! needs to be a very small number to avoid causing non-linearity issues with c_area. + ! is this really required? + currentCohort%dbh = currentCohort%dbh - 0.000000000001_r8 + copyc%dbh = copyc%dbh + 0.000000000001_r8 + + currentCohort%c_area = c_area(currentCohort) + copyc%c_area = c_area(copyc) + + !----------- Insert copy into linked list ------------------------! + copyc%shorter => currentCohort + if(associated(currentCohort%taller))then + copyc%taller => currentCohort%taller + currentCohort%taller%shorter => copyc + else + currentPatch%tallest => copyc + copyc%taller => null() + endif + currentCohort%taller => copyc + else + currentCohort%canopy_layer = i !the whole cohort becomes promoted + sumgain = sumgain + currentCohort%c_area !inserting deliberate mistake to see how far we make it... + ! update area AFTER we sum up the losses. the cohort may shrink at this point, + ! if the upper canopy spread is smaller. this shold be dealt with by the 'excess area' loop. + currentCohort%c_area = c_area(currentCohort) + + ! keep track of number and biomass of promoted cohort + currentSite%promotion_rate(currentCohort%size_class) = & + currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & + currentCohort%b * currentCohort%n + + promswitch = 1 + + ! write(fates_log(),*) 'promoting whole cohort', currentCohort%c_area,cc_gain,currentCohort%canopy_layer, & + !currentCohort%pft,currentPatch%patchno + + endif + if(promswitch == 1)then + ! write(fates_log(),*) 'cohort loop',currentCohort%pft,currentPatch%patchno + endif + !----------- End of cohort splitting ------------------------------! + else + if(promswitch == 1)then + ! write(fates_log(),*) 'cohort list',currentCohort%pft, & + ! currentCohort%canopy_layer,currentCohort%c_area + endif + endif + + currentCohort => currentCohort%shorter + enddo !currentCohort + arealayer(i) = arealayer(i) + sumgain + arealayer(i + 1) = arealayer(i + 1) - sumgain !Update arealayer for diff calculations of layer below. + + if(promswitch == 1)then + ! write(fates_log(),*) 'arealayer loop',arealayer(1:3),currentPatch%area,promarea,sumgain, & + !currentPatch%patchno,z,i,lower_cohort_switch + endif + if(promswitch == 1.and.associated(currentPatch%tallest))then + ! write(fates_log(),*) 'cohorts',currentCohort%pft,currentPatch%patchno, & + !currentCohort%c_area + endif + enddo !arealayer loop + + if(currentPatch%area-arealayer(i) < 0.000001_r8)then + !write(fates_log(),*) 'gainarea problem',sumgain,arealayer(i),currentPatch%area,z, & + !currentPatch%patchno,currentPatch%area - arealayer(i),i,missing_area,count_mi + endif + if(promswitch == 1)then + ! write(fates_log(),*) 'z loop',arealayer(1:3),currentPatch%patchno,z + endif + enddo !z + + z = 1 + arealayer = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + currentCohort%c_area = c_area(currentCohort) + arealayer(currentCohort%canopy_layer) = arealayer(currentCohort%canopy_layer) + currentCohort%c_area + z = max(z,currentCohort%canopy_layer) + currentCohort => currentCohort%shorter + enddo + + missing_area = 0.0_r8 + do j=1,z-1 + if(arealayer(j) < currentPatch%area)then !this is the amount of area that we still have spare in this layer. + missing_area = currentPatch%area - arealayer(j) + if(missing_area <= 0.000001_r8.and.missing_area > 0._r8)then + missing_area = 0.0_r8 + ! write(fates_log(),*) 'correcting MI',j,currentPatch%area - arealayer(j) + endif + endif + enddo + currentPatch%ncl_p = min(z,nclmax) + if(promswitch == 1)then + ! write(fates_log(),*) 'missingarea loop',arealayer(1:3),currentPatch%patchno,missing_area,z + endif + enddo !is there still not enough canopy area in any layer? + + call fuse_cohorts(currentPatch, bc_in) + call terminate_cohorts(currentSite, currentPatch) + + if(promswitch == 1)then + !write(fates_log(),*) 'going into cohort check' + endif + ! ----------- Check cohort area ------------------------------! + do i = 1,z + checkarea = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i)then + checkarea = checkarea + c_area(currentCohort) + endif + + currentCohort => currentCohort%shorter + + enddo + + if(((checkarea-currentPatch%area)) > 0.0001)then + write(fates_log(),*) 'problem with canopy area', checkarea, currentPatch%area, checkarea - currentPatch%area, & + i, z, missing_area + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i)then + write(fates_log(),*) 'c_areas in top layer', c_area(currentCohort) + endif + currentCohort => currentCohort%shorter + + enddo + + endif + + if ( i > 1) then + if ( (arealayer(i) - arealayer(i-1) )>1e-11 ) then + write(fates_log(),*) 'smaller top layer than bottom layer ',arealayer(i),arealayer(i-1), & + currentPatch%area,currentPatch%spread(i-1:i) + endif + endif + enddo ! + + if(promswitch == 1)then + ! write(fates_log(),*) 'end patch loop',currentSite%clmgcell + endif + + else !terminate logic to only do if patch_area_sufficiently large + write(fates_log(),*) 'canopy_structure: patch area too small.', currentPatch%area + end if + + + currentPatch => currentPatch%younger + enddo !patch + + if(promswitch == 1)then + ! write(fates_log(),*) 'end canopy structure',currentSite%clmgcell + endif + + end subroutine canopy_structure + + ! ============================================================================ + subroutine canopy_spread( currentSite ) + ! + ! !DESCRIPTION: + ! Calculates the spatial spread of tree canopies based on canopy closure. + ! + ! !USES: + use EDParamsMod , only : ED_val_maxspread, ED_val_minspread + ! + ! !ARGUMENTS + type (ed_site_type), intent(inout), target :: currentSite + ! + ! !LOCAL VARIABLES: + type (ed_cohort_type), pointer :: currentCohort + type (ed_patch_type) , pointer :: currentPatch + real(r8) :: arealayer(nlevleaf) ! Amount of canopy in each layer. + real(r8) :: inc ! Arbitrary daily incremental change in canopy area + integer :: z + !---------------------------------------------------------------------- + + inc = 0.005_r8 + + currentPatch => currentSite%oldest_patch + + do while (associated(currentPatch)) + + !calculate canopy area in each canopy storey... + arealayer = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + currentCohort%c_area = c_area(currentCohort) + if(EDPftvarcon_inst%woody(currentCohort%pft) == 1)then + arealayer(currentCohort%canopy_layer) = arealayer(currentCohort%canopy_layer) + currentCohort%c_area + endif + currentCohort => currentCohort%shorter + enddo + + !If the canopy area is approaching closure, squash the tree canopies and make them taller and thinner + do z = 1,nclmax + + if(arealayer(z)/currentPatch%area > 0.9_r8)then + currentPatch%spread(z) = currentPatch%spread(z) - inc + else + currentPatch%spread(z) = currentPatch%spread(z) + inc + endif + if(currentPatch%spread(z) >= ED_val_maxspread)then + currentPatch%spread(z) = ED_val_maxspread + endif + if(currentPatch%spread(z) <= ED_val_minspread)then + currentPatch%spread(z) = ED_val_minspread + endif + enddo !z + !write(fates_log(),*) 'spread',currentPatch%spread(1:2) + !currentPatch%spread(:) = ED_val_maxspread + !FIX(RF,033114) spread is off + !write(fates_log(),*) 'canopy_spread',currentPatch%area,currentPatch%spread(1:2) + currentPatch => currentPatch%younger + + enddo !currentPatch + + end subroutine canopy_spread + + + ! ===================================================================================== + + subroutine canopy_summarization( nsites, sites, bc_in ) + + ! ---------------------------------------------------------------------------------- + ! Much of this routine was once ed_clm_link minus all the IO and history stuff + ! --------------------------------------------------------------------------------- + + use FatesInterfaceMod , only : bc_in_type + use EDPatchDynamicsMod , only : set_patchno + use EDPatchDynamicsMod , only : set_root_fraction + use EDTypesMod , only : sizetype_class_index + use EDGrowthFunctionsMod , only : tree_lai, c_area + use EDEcophysConType , only : EDecophyscon + use EDtypesMod , only : area + use EDPftvarcon , only : EDPftvarcon_inst + + ! !ARGUMENTS + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type) , intent(in) :: bc_in(nsites) + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort + integer :: s + integer :: ft ! plant functional type + integer :: ifp + integer :: patchn ! identification number for each patch. + real(r8) :: canopy_leaf_area ! total amount of leaf area in the vegetated area. m2. + + !---------------------------------------------------------------------- + + if ( DEBUG ) then + write(fates_log(),*) 'in canopy_summarization' + endif + + do s = 1,nsites + + ! -------------------------------------------------------------------------------- + ! Set the patch indices (this is usefull mostly for communicating with a host or + ! driving model. Loops through all patches and sets cpatch%patchno to the integer + ! order of oldest to youngest where the oldest is 1. + ! -------------------------------------------------------------------------------- + call set_patchno( sites(s) ) + + currentPatch => sites(s)%oldest_patch + + do while(associated(currentPatch)) + + call set_root_fraction(currentPatch,bc_in(s)%zi_sisl) + + !zero cohort-summed variables. + currentPatch%total_canopy_area = 0.0_r8 + currentPatch%total_tree_area = 0.0_r8 + currentPatch%lai = 0.0_r8 + canopy_leaf_area = 0.0_r8 + + !update cohort quantitie s + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + + ft = currentCohort%pft + + + ! Update the cohort's index within the size bin classes + ! Update the cohort's index within the SCPF classification system + call sizetype_class_index(currentCohort%dbh,currentCohort%pft, & + currentCohort%size_class,currentCohort%size_by_pft_class) + + + currentCohort%b = currentCohort%balive+currentCohort%bdead+currentCohort%bstore + currentCohort%treelai = tree_lai(currentCohort) + + currentCohort%c_area = c_area(currentCohort) + canopy_leaf_area = canopy_leaf_area + currentCohort%treelai *currentCohort%c_area + + if(currentCohort%canopy_layer==1)then + currentPatch%total_canopy_area = currentPatch%total_canopy_area + currentCohort%c_area + if(EDPftvarcon_inst%woody(ft)==1)then + currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area + endif + endif + + ! Check for erroneous zero values. + if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then + write(fates_log(),*) 'ED: dbh or n is zero in canopy_summarization', & + currentCohort%dbh,currentCohort%n + endif + if(currentCohort%pft == 0.or.currentCohort%canopy_trim <= 0._r8)then + write(fates_log(),*) 'ED: PFT or trim is zero in canopy_summarization', & + currentCohort%pft,currentCohort%canopy_trim + endif + if(currentCohort%balive <= 0._r8)then + write(fates_log(),*) 'ED: balive is zero in canopy_summarization', & + currentCohort%balive + endif + + currentCohort => currentCohort%taller + + enddo ! ends 'do while(associated(currentCohort)) + + if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then + write(fates_log(),*) 'ED: canopy area bigger than area', & + currentPatch%total_canopy_area ,currentPatch%area + currentPatch%total_canopy_area = currentPatch%area + endif + + + currentPatch => currentPatch%younger + end do !patch loop + + call leaf_area_profile(sites(s),bc_in(s)%snow_depth_si,bc_in(s)%frac_sno_eff_si) + + end do ! site loop + + return + end subroutine canopy_summarization + + ! ===================================================================================== + + subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) + ! + ! !DESCRIPTION: + ! + ! !USES: + + use EDGrowthFunctionsMod , only : tree_lai, tree_sai, c_area + use EDtypesMod , only : area, dinc_ed, hitemax, n_hite_bins + use EDEcophysConType , only : EDecophyscon + + ! + ! !ARGUMENTS + type(ed_site_type) , intent(inout) :: currentSite + real(r8) , intent(in) :: snow_depth_si + real(r8) , intent(in) :: frac_sno_eff_si + + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort + real(r8) :: remainder !Thickness of layer at bottom of canopy. + real(r8) :: fleaf ! fraction of cohort incepting area that is leaves. + integer :: ft ! Plant functional type index. + integer :: iv ! Vertical leaf layer index + integer :: L ! Canopy layer index + integer :: p ! clm patch index + real(r8) :: fraction_exposed ! how much of this layer is not covered by snow? + real(r8) :: layer_top_hite ! notional top height of this canopy layer (m) + real(r8) :: layer_bottom_hite ! notional bottom height of this canopy layer (m) + integer :: smooth_leaf_distribution ! is the leaf distribution this option (1) or not (0) + real(r8) :: frac_canopy(N_HITE_BINS) ! amount of canopy in each height class + real(r8) :: minh(N_HITE_BINS) ! minimum height in height class (m) + real(r8) :: maxh(N_HITE_BINS) ! maximum height in height class (m) + real(r8) :: dh ! vertical detph of height class (m) + real(r8) :: min_chite ! bottom of cohort canopy (m) + real(r8) :: max_chite ! top of cohort canopy (m) + real(r8) :: lai ! summed lai for checking m2 m-2 + real(r8) :: snow_depth_avg ! avg snow over whole site + integer :: NC ! number of cohorts, for bug fixing. + + !---------------------------------------------------------------------- + + smooth_leaf_distribution = 0 + + ! Here we are trying to generate a profile of leaf area, indexed by 'z' and by pft + ! We assume that each point in the canopy recieved the light attenuated by the average + ! leaf area index above it, irrespective of PFT identity... + ! Each leaf is defined by how deep in the canopy it is, in terms of LAI units. (FIX(RF,032414), GB) + + currentPatch => currentSite%oldest_patch ! ed patch + do while(associated(currentPatch)) + + !Calculate tree and canopy areas. + currentPatch%canopy_area = 0._r8 + currentPatch%canopy_layer_lai(:) = 0._r8 + NC = 0 + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + currentCohort%c_area = c_area(currentCohort) + currentPatch%canopy_area = currentPatch%canopy_area + currentCohort%c_area + NC = NC+1 + currentCohort => currentCohort%taller + enddo + ! if plants take up all the tile, then so does the canopy. + currentPatch%canopy_area = min(currentPatch%canopy_area,currentPatch%area) + + !calculate tree lai and sai. + currentPatch%ncan(:,:) = 0 + currentPatch%nrad(:,:) = 0 + currentPatch%lai = 0._r8 + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + currentCohort%treelai = tree_lai(currentCohort) + currentCohort%treesai = tree_sai(currentCohort) + currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%canopy_area + currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%canopy_area + !Calculate the LAI plus SAI in each canopy storey. + currentCohort%NV = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) + + currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft) = & + max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft),currentCohort%NV) + currentPatch%lai = currentPatch%lai +currentCohort%lai + + do L = 1,nclmax-1 + if(currentCohort%canopy_layer == L)then + currentPatch%canopy_layer_lai(L) = currentPatch%canopy_layer_lai(L) + currentCohort%lai + & + currentCohort%sai + endif + enddo + + currentCohort => currentCohort%taller + + enddo !currentCohort + currentPatch%nrad = currentPatch%ncan + + if(smooth_leaf_distribution == 1)then + ! we are going to ignore the concept of canopy layers, and put all of the leaf area into height banded bins. + ! using the same domains as we had before, except that CL always = 1 + currentPatch%tlai_profile = 0._r8 + currentPatch%tsai_profile = 0._r8 + currentPatch%elai_profile = 0._r8 + currentPatch%esai_profile = 0._r8 + + ! this is a crude way of dividing up the bins. Should it be a function of actual maximum height? + dh = 1.0_r8*(HITEMAX/N_HITE_BINS) + do iv = 1,N_HITE_BINS + if (iv == 1) then + minh(iv) = 0.0_r8 + maxh(iv) = dh + else + minh(iv) = (iv-1)*dh + maxh(iv) = (iv)*dh + endif + enddo + + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + ft = currentCohort%pft + min_chite = currentCohort%hite - currentCohort%hite * EDecophyscon%crown(ft) + max_chite = currentCohort%hite + do iv = 1,N_HITE_BINS + frac_canopy(iv) = 0.0_r8 + ! this layer is in the middle of the canopy + if(max_chite > maxh(iv).and.min_chite < minh(iv))then + frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*EDecophyscon%crown(ft))) + ! this is the layer with the bottom of the canopy in it. + elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then + frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*EDecophyscon%crown(ft)) + ! this is the layer with the top of the canopy in it. + elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then + frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*EDecophyscon%crown(ft)) + elseif(max_chite < maxh(iv).and.min_chite > minh(iv))then !the whole cohort is within this layer. + frac_canopy(iv) = 1.0_r8 + endif + + ! no m2 of leaf per m2 of ground in each height class + currentPatch%tlai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) + frac_canopy(iv) * & + currentCohort%lai + currentPatch%tsai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) + frac_canopy(iv) * & + currentCohort%sai + + !snow burial + !write(fates_log(), *) 'calc snow' + snow_depth_avg = snow_depth_si * frac_sno_eff_si + if(snow_depth_avg > maxh(iv))then + fraction_exposed = 0._r8 + endif + if(snow_depth_avg < minh(iv))then + fraction_exposed = 1._r8 + endif + if(snow_depth_avg>= minh(iv).and.snow_depth_avg <= maxh(iv))then !only partly hidden... + fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_avg-minh(iv))/dh))) + endif + fraction_exposed = 1.0_r8 + ! no m2 of leaf per m2 of ground in each height class + ! FIX(SPM,032414) these should be uncommented this and double check + + if ( DEBUG ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) + + currentPatch%elai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) * fraction_exposed + currentPatch%esai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) * fraction_exposed + + if ( DEBUG ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) + + enddo ! (iv) hite bins + + currentCohort => currentCohort%taller + + enddo !currentCohort + + !check + currentPatch%lai = 0._r8 + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + currentPatch%lai = currentPatch%lai +currentCohort%lai + currentCohort => currentCohort%taller + enddo !currentCohort + lai = 0.0_r8 + do ft = 1,numpft_ed + lai = lai+ sum(currentPatch%tlai_profile(1,ft,:)) + enddo + + if(lai > currentPatch%lai)then + write(fates_log(), *) 'ED: problem with lai assignments' + endif + + + else ! smooth leaf distribution + !Go through all cohorts and add their leaf area and canopy area to the accumulators. + currentPatch%tlai_profile = 0._r8 + currentPatch%tsai_profile = 0._r8 + currentPatch%elai_profile = 0._r8 + currentPatch%esai_profile = 0._r8 + currentPatch%layer_height_profile = 0._r8 + currentPatch%canopy_area_profile(:,:,:) = 0._r8 + currentPatch%ncan(:,:) = 0 + currentPatch%nrad(:,:) = 0 + currentCohort => currentPatch%shortest + + do while(associated(currentCohort)) + L = currentCohort%canopy_layer + ft = currentCohort%pft + !Calculate the number of layers of thickness dlai, including the last one. + currentCohort%NV = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) + !how much of each tree is stem area index? Assuming that there is + if(currentCohort%treelai+currentCohort%treesai > 0._r8)then + fleaf = currentCohort%lai / (currentCohort%lai + currentCohort%sai) + else + fleaf = 0._r8 + write(fates_log(), *) 'ED: no stem or leaf area' ,currentCohort%pft,currentCohort%bl, & + currentCohort%balive,currentCohort%treelai,currentCohort%treesai,currentCohort%dbh, & + currentCohort%n,currentCohort%status_coh + endif + currentPatch%ncan(L,ft) = max(currentPatch%ncan(L,ft),currentCohort%NV) + currentPatch%nrad(L,ft) = currentPatch%ncan(L,ft) !fudge - this needs to be altered for snow burial + if(currentCohort%NV > currentPatch%nrad(L,ft))then + write(fates_log(), *) 'ED: issue with NV',currentCohort%NV,currentCohort%pft,currentCohort%canopy_layer + endif + + !Whole layers. Make a weighted average of the leaf area in each layer before dividing it by the total area. + !fill up layer for whole layers. FIX(RF,032414)- for debugging jan 2012 + do iv = 1,currentCohort%NV-1 + + ! what is the height of this layer? (for snow burial purposes...) + ! EDPftvarcon_inst%vertical_canopy_frac(ft))! fudge - this should be pft specific but i cant get it to compile. + layer_top_hite = currentCohort%hite-((iv/currentCohort%NV) * currentCohort%hite * & + EDecophyscon%crown(currentCohort%pft) ) + layer_bottom_hite = currentCohort%hite-(((iv+1)/currentCohort%NV) * currentCohort%hite * & + EDecophyscon%crown(currentCohort%pft)) ! EDPftvarcon_inst%vertical_canopy_frac(ft)) + + fraction_exposed =1.0_r8 + + currentPatch%tlai_profile(L,ft,iv) = currentPatch%tlai_profile(L,ft,iv)+ dinc_ed * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%elai_profile(L,ft,iv) = currentPatch%elai_profile(L,ft,iv)+ dinc_ed * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area * fraction_exposed + + currentPatch%tsai_profile(L,ft,iv) = currentPatch%tsai_profile(L,ft,iv)+ dinc_ed * (1._r8 - fleaf) * & + currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%esai_profile(L,ft,iv) = currentPatch%esai_profile(L,ft,iv)+ dinc_ed * (1._r8 - fleaf) * & + currentCohort%c_area/currentPatch%total_canopy_area * fraction_exposed + + currentPatch%canopy_area_profile(L,ft,iv) = min(1.0_r8,currentPatch%canopy_area_profile(L,ft,iv) + & + currentCohort%c_area/currentPatch%total_canopy_area) + currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) + (dinc_ed * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area *(layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. + + if ( DEBUG ) then + write(fates_log(), *) 'calc snow 2', snow_depth_si , frac_sno_eff_si + write(fates_log(), *) 'LHP', currentPatch%layer_height_profile(L,ft,iv) + write(fates_log(), *) 'EDCLMLink 1246 ', currentPatch%elai_profile(1,ft,iv) + end if + + end do + + !Bottom layer + iv = currentCohort%NV + ! EDPftvarcon_inst%vertical_canopy_frac(ft))! fudge - this should be pft specific but i cant get it to compile. + layer_top_hite = currentCohort%hite-((iv/currentCohort%NV) * currentCohort%hite * & + EDecophyscon%crown(currentCohort%pft) ) + ! EDPftvarcon_inst%vertical_canopy_frac(ft)) + layer_bottom_hite = currentCohort%hite-(((iv+1)/currentCohort%NV) * currentCohort%hite * & + EDecophyscon%crown(currentCohort%pft)) + + fraction_exposed = 1.0_r8 !default. + snow_depth_avg = snow_depth_si * frac_sno_eff_si + if(snow_depth_avg > layer_top_hite)then + fraction_exposed = 0._r8 + endif + if(snow_depth_avg < layer_bottom_hite)then + fraction_exposed = 1._r8 + + endif + if(snow_depth_avg>= layer_bottom_hite.and.snow_depth_avg <= layer_top_hite)then !only partly hidden... + fraction_exposed = max(0._r8,(min(1.0_r8,(snow_depth_avg-layer_bottom_hite)/ & + (layer_top_hite-layer_bottom_hite )))) + endif + fraction_exposed= 1.0_r8 + + + remainder = (currentCohort%treelai + currentCohort%treesai) - (dinc_ed*(currentCohort%NV-1)) + if(remainder > 1.0_r8)then + write(fates_log(), *)'ED: issue with remainder',currentCohort%treelai,currentCohort%treesai,dinc_ed, & + currentCohort%NV + endif + !assumes that fleaf is unchanging FIX(RF,032414) + + currentPatch%tlai_profile(L,ft,iv) = currentPatch%tlai_profile(L,ft,iv)+ remainder * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%elai_profile(L,ft,iv) = currentPatch%elai_profile(L,ft,iv) + remainder * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area * fraction_exposed + !assumes that fleaf is unchanging FIX(RF,032414) + + currentPatch%tsai_profile(L,ft,iv) = currentPatch%tsai_profile(L,ft,iv)+ remainder * & + (1.0_r8-fleaf) * currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%esai_profile(L,ft,iv) = currentPatch%esai_profile(L,ft,iv)+ remainder * & + (1.0_r8-fleaf) * currentCohort%c_area/currentPatch%total_canopy_area * fraction_exposed + + currentPatch%canopy_area_profile(L,ft,iv) = min(1.0_r8,currentPatch%canopy_area_profile(L,ft,iv) + & + currentCohort%c_area/currentPatch%total_canopy_area) + currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) + (remainder * fleaf * & + currentCohort%c_area/currentPatch%total_canopy_area*(layer_top_hite+layer_bottom_hite)/2.0_r8) + if ( DEBUG ) write(fates_log(), *) 'LHP', currentPatch%layer_height_profile(L,ft,iv) + if(currentCohort%dbh <= 0._r8.or.currentCohort%n == 0._r8)then + write(fates_log(), *) 'ED: dbh or n is zero in clmedlink', currentCohort%dbh,currentCohort%n + endif + if(currentCohort%pft == 0.or.currentCohort%canopy_trim <= 0._r8)then + write(fates_log(), *) 'ED: PFT or trim is zero in clmedlink',currentCohort%pft,currentCohort%canopy_trim + endif + if(currentCohort%balive <= 0._r8.or.currentCohort%bl < 0._r8)then + write(fates_log(), *) 'ED: balive is zero in clmedlink',currentCohort%balive,currentCohort%bl + endif + + currentCohort => currentCohort%taller + + enddo !cohort + + do L = 1,currentPatch%NCL_p + do ft = 1,numpft_ed + do iv = 1,currentPatch%nrad(L,ft) + !account for total canopy area + currentPatch%tlai_profile(L,ft,iv) = currentPatch%tlai_profile(L,ft,iv) / & + currentPatch%canopy_area_profile(L,ft,iv) + currentPatch%tsai_profile(L,ft,iv) = currentPatch%tsai_profile(L,ft,iv) / & + currentPatch%canopy_area_profile(L,ft,iv) + + if ( DEBUG ) write(fates_log(), *) 'EDCLMLink 1293 ', currentPatch%elai_profile(L,ft,iv) + + currentPatch%elai_profile(L,ft,iv) = currentPatch%elai_profile(L,ft,iv) / & + currentPatch%canopy_area_profile(L,ft,iv) + currentPatch%esai_profile(L,ft,iv) = currentPatch%esai_profile(L,ft,iv) / & + currentPatch%canopy_area_profile(L,ft,iv) + currentPatch%layer_height_profile(L,ft,iv) = currentPatch%layer_height_profile(L,ft,iv) & + /currentPatch%tlai_profile(L,ft,iv) + enddo + + currentPatch%tlai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevleaf) = 0._r8 + currentPatch%tsai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevleaf) = 0._r8 + currentPatch%elai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevleaf) = 0._r8 + currentPatch%esai_profile(L,ft,currentPatch%nrad(L,ft)+1: nlevleaf) = 0._r8 + + enddo + enddo + + currentPatch%nrad = currentPatch%ncan + do L = 1,currentPatch%NCL_p + do ft = 1,numpft_ed + if(currentPatch%nrad(L,ft) > 30)then + write(fates_log(), *) 'ED: issue w/ nrad' + endif + currentPatch%present(L,ft) = 0 + do iv = 1, currentPatch%nrad(L,ft); + if(currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then + currentPatch%present(L,ft) = 1 + endif + end do !iv + enddo !ft + + if ( L == 1 .and. abs(sum(currentPatch%canopy_area_profile(1,1:numpft_ed,1))) < 0.99999 & + .and. currentPatch%NCL_p > 1 ) then + write(fates_log(), *) 'ED: canopy area too small',sum(currentPatch%canopy_area_profile(1,1:numpft_ed,1)) + write(fates_log(), *) 'ED: cohort areas', currentPatch%canopy_area_profile(1,1:numpft_ed,:) + endif + + if (L == 1 .and. currentPatch%NCL_p > 1 .and. & + abs(sum(currentPatch%canopy_area_profile(1,1:numpft_ed,1))) < 0.99999) then + write(fates_log(), *) 'ED: not enough area in the top canopy', & + sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1)), & + currentPatch%canopy_area_profile(L,1:numpft_ed,1) + endif + + if(abs(sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1))) > 1.00001)then + write(fates_log(), *) 'ED: canopy-area-profile wrong', & + sum(currentPatch%canopy_area_profile(L,1:numpft_ed,1)), & + currentPatch%patchno, L + write(fates_log(), *) 'ED: areas',currentPatch%canopy_area_profile(L,1:2,1),currentPatch%patchno + + currentCohort => currentPatch%shortest + + do while(associated(currentCohort)) + + if(currentCohort%canopy_layer==1)then + write(fates_log(), *) 'ED: cohorts',currentCohort%dbh,currentCohort%c_area, & + currentPatch%total_canopy_area,currentPatch%area,currentPatch%canopy_area + write(fates_log(), *) 'ED: fracarea', currentCohort%pft, & + currentCohort%c_area/currentPatch%total_canopy_area + endif + + currentCohort => currentCohort%taller + + enddo !currentCohort + endif + enddo ! loop over L + + do L = 1,currentPatch%NCL_p + do ft = 1,numpft_ed + if(currentPatch%present(L,FT) > 1)then + write(fates_log(), *) 'ED: present issue',L,ft,currentPatch%present(L,FT) + currentPatch%present(L,ft) = 1 + endif + enddo + enddo + + endif !leaf distribution + + currentPatch => currentPatch%younger + + enddo !patch + + return + end subroutine leaf_area_profile + + ! ====================================================================================== + + subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) + + ! ---------------------------------------------------------------------------------- + ! The purpose of this routine is to package output boundary conditions related + ! to vegetation coverage to the host land model. + ! ---------------------------------------------------------------------------------- + + use EDTypesMod , only : ed_patch_type, ed_cohort_type, & + ed_site_type, AREA + use FatesInterfaceMod , only : bc_out_type + use EDPftvarcon , only : EDPftvarcon_inst + + + ! + ! !ARGUMENTS + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + integer, intent(in) :: fcolumn(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + ! Locals + type (ed_cohort_type) , pointer :: currentCohort + integer :: s, ifp, c, p + type (ed_patch_type) , pointer :: currentPatch + real(r8) :: bare_frac_area + real(r8) :: total_patch_area + real(r8) :: weight ! Weighting for cohort variables in patch + + + do s = 1,nsites + + ifp = 0 + total_patch_area = 0._r8 + currentPatch => sites(s)%oldest_patch + c = fcolumn(s) + do while(associated(currentPatch)) + ifp = ifp+1 + + if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then + write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area + currentPatch%total_canopy_area = currentPatch%area + endif + + + if (associated(currentPatch%tallest)) then + bc_out(s)%htop_pa(ifp) = currentPatch%tallest%hite + else + ! FIX(RF,040113) - should this be a parameter for the minimum possible vegetation height? + bc_out(s)%htop_pa(ifp) = 0.1_r8 + endif + + bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) + + ! Use leaf area weighting for all cohorts in the patch to define the characteristic + ! leaf width used by the HLM + ! ---------------------------------------------------------------------------- +! bc_out(s)%dleaf_pa(ifp) = 0.0_r8 +! if(currentPatch%lai>1.0e-9_r8) then +! currentCohort => currentPatch%shortest +! do while(associated(currentCohort)) +! weight = min(1.0_r8,currentCohort%lai/currentPatch%lai) +! bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & +! EDPftvarcon_inst%dleaf(currentCohort%pft)*weight +! currentCohort => currentCohort%taller +! enddo +! end if + + ! Roughness length and displacement height are not PFT properties, they are + ! properties of the canopy assemblage. Defining this needs an appropriate model. + ! Right now z0 and d are pft level parameters. For the time being we will just + ! use the 1st index until a suitable model is defined. (RGK 04-2017) + ! ----------------------------------------------------------------------------- + bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) + + + ! We are assuming here that grass is all located underneath tree canopies. + ! The alternative is to assume it is all spatial distinct from tree canopies. + ! In which case, the bare area would have to be reduced by the grass area... + ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants + ! currentPatch%area/AREA is the fraction of the soil covered by this patch. + + bc_out(s)%canopy_fraction_pa(ifp) = min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area) * & + (currentPatch%area/AREA) + + bare_frac_area = (1.0_r8-min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area))* & + (currentPatch%area/AREA) + + total_patch_area = total_patch_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area + + ! Calculate area indices for output boundary to HLM + ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles + ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) + + bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') + bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') + bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') + bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') + + ! Fraction of vegetation free of snow. This is used to flag those + ! patches which shall under-go photosynthesis + ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let + ! FATES internal variables decide if photosynthesis is possible + ! we are essentially calculating it inside FATES to tell the + ! host to tell itself when to do things (circuitous). Just have + ! to determine where else it is used + + if ((bc_out(s)%elai_pa(ifp) + bc_out(s)%esai_pa(ifp)) > 0._r8) then + bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 1.0_r8 + else + bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 0.0_r8 + end if + + currentPatch => currentPatch%younger + end do + + if(abs(total_patch_area-1.0_r8)>1e-9)then + write(fates_log(),*) 'total area is wrong in update_hlm_dynamics',total_patch_area + endif + + + end do + + + end subroutine update_hlm_dynamics + + ! ===================================================================================== + + function calc_areaindex(cpatch,ai_type) result(ai) + + ! ---------------------------------------------------------------------------------- + ! This subroutine calculates the exposed leaf area index of a patch + ! this is the square meters of leaf per square meter of ground area + ! It does so by integrating over the depth and functional type profile of leaf area + ! which are per area of crown. This value has to be scaled by crown area to convert + ! to ground area. + ! ---------------------------------------------------------------------------------- + + ! Arguments + type(ed_patch_type),intent(in), target :: cpatch + character(len=*),intent(in) :: ai_type + + integer :: cl,ft + real(r8) :: ai + ! TODO: THIS MIN LAI IS AN ARTIFACT FROM TESTING LONG-AGO AND SHOULD BE REMOVED + ! THIS HAS BEEN KEPT THUS FAR TO MAINTAIN B4B IN TESTING OTHER COMMITS + real(r8),parameter :: ai_min = 0.1_r8 + real(r8),pointer :: ai_profile + + ai = 0._r8 + if (trim(ai_type) == 'elai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft_ed + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + elseif (trim(ai_type) == 'tlai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft_ed + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%tlai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + elseif (trim(ai_type) == 'esai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft_ed + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%esai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + elseif (trim(ai_type) == 'tsai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft_ed + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%tsai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + else + + write(fates_log(),*) 'Unsupported area index sent to calc_areaindex' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ai = max(ai_min,ai) + + return + + end function calc_areaindex + +end module EDCanopyStructureMod diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 new file mode 100644 index 00000000..0c6aaca1 --- /dev/null +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -0,0 +1,1271 @@ +module EDCohortDynamicsMod + ! + ! !DESCRIPTION: + ! Cohort stuctures in ED. + ! + ! !USES: + use FatesGlobals , only : endrun => fates_endrun + use FatesGlobals , only : fates_log + use FatesInterfaceMod , only : hlm_freq_day + use FatesInterfaceMod , only : bc_in_type + use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : fates_unset_int + use FatesInterfaceMod , only : hlm_days_per_year + use EDPftvarcon , only : EDPftvarcon_inst + use EDEcophysContype , only : EDecophyscon + use EDGrowthFunctionsMod , only : c_area, tree_lai + use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type + use EDTypesMod , only : nclmax + use EDTypesMod , only : ncwd + use EDTypesMod , only : maxCohortsPerPatch + use EDTypesMod , only : sclass_ed,nlevsclass_ed,AREA + use EDTypesMod , only : min_npm2, min_nppatch + use EDTypesMod , only : min_n_safemath + use EDTypesMod , only : use_fates_plant_hydro + use FatesPlantHydraulicsMod, only : FuseCohortHydraulics + use FatesPlantHydraulicsMod, only : CopyCohortHydraulics + use FatesPlantHydraulicsMod, only : updateSizeDepTreeHydProps + use FatesPlantHydraulicsMod, only : initTreeHydStates + use FatesPlantHydraulicsMod, only : InitHydrCohort + use FatesPlantHydraulicsMod, only : DeallocateHydrCohort + use EDTypesMod , only : sizetype_class_index + + ! CIME globals + use shr_log_mod , only : errMsg => shr_log_errMsg + ! + implicit none + private + ! + public :: create_cohort + public :: zero_cohort + public :: nan_cohort + public :: terminate_cohorts + public :: fuse_cohorts + public :: insert_cohort + public :: sort_cohorts + public :: copy_cohort + public :: count_cohorts + public :: allocate_live_biomass + + logical, parameter :: DEBUG = .false. ! local debug flag + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + ! 10/30/09: Created by Rosie Fisher + !-------------------------------------------------------------------------------------! + +contains + + !-------------------------------------------------------------------------------------! + subroutine create_cohort(patchptr, pft, nn, hite, dbh, & + balive, bdead, bstore, laimemory, status, ctrim, clayer, bc_in) + ! + ! !DESCRIPTION: + ! create new cohort + ! + ! !USES: + ! + ! !ARGUMENTS + type(ed_patch_type), intent(inout), pointer :: patchptr + integer, intent(in) :: pft ! Cohort Plant Functional Type + 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) + real(r8), intent(in) :: nn ! number of individuals in cohort per 'area' (10000m2 default) + real(r8), intent(in) :: hite ! height: meters + real(r8), intent(in) :: dbh ! dbh: cm + real(r8), intent(in) :: balive ! total living biomass: kGC per indiv + real(r8), intent(in) :: bdead ! total dead biomass: kGC per indiv + real(r8), intent(in) :: bstore ! stored carbon: kGC per indiv + real(r8), intent(in) :: laimemory ! target leaf biomass- set from previous year: kGC per indiv + real(r8), intent(in) :: ctrim ! What is the fraction of the maximum leaf biomass that we are targeting? :- + type(bc_in_type), intent(in) :: bc_in ! External boundary conditions + ! + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer :: new_cohort ! Pointer to New Cohort structure. + type(ed_cohort_type), pointer :: storesmallcohort + type(ed_cohort_type), pointer :: storebigcohort + integer :: tnull,snull ! are the tallest and shortest cohorts allocate + !---------------------------------------------------------------------- + + allocate(new_cohort) + + call nan_cohort(new_cohort) ! Make everything in the cohort not-a-number + call zero_cohort(new_cohort) ! Zero things that need to be zeroed. + + !**********************/ + ! Define cohort state variable + !**********************/ + + new_cohort%indexnumber = fates_unset_int ! Cohort indexing was not thread-safe, setting + ! bogus value for the time being (RGK-012017) + new_cohort%siteptr => patchptr%siteptr + new_cohort%patchptr => patchptr + new_cohort%pft = pft + new_cohort%status_coh = status + new_cohort%n = nn + new_cohort%hite = hite + new_cohort%dbh = dbh + new_cohort%canopy_trim = ctrim + new_cohort%canopy_layer = clayer + new_cohort%canopy_layer_yesterday = real(clayer, r8) + new_cohort%laimemory = laimemory + new_cohort%bdead = bdead + new_cohort%balive = balive + new_cohort%bstore = bstore + + call sizetype_class_index(new_cohort%dbh,new_cohort%pft, & + new_cohort%size_class,new_cohort%size_by_pft_class) + + if ( DEBUG ) write(fates_log(),*) 'EDCohortDyn I ',bstore + + ! This routine may be called during restarts, and at this point in the call sequence + ! the actual cohort data is unknown, as this is really only used for allocation + ! In these cases, testing if things like biomass are reasonable is pre-mature + ! However, in this part of the code, we will pass in nominal values for size, number and type + + if (new_cohort%dbh <= 0.0_r8 .or. new_cohort%n == 0._r8 .or. new_cohort%pft == 0 ) then + write(fates_log(),*) 'ED: something is zero in create_cohort', & + new_cohort%dbh,new_cohort%n, & + new_cohort%pft + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + if (new_cohort%siteptr%status==2 .and. EDPftvarcon_inst%season_decid(pft) == 1) then + new_cohort%laimemory = 0.0_r8 + endif + + if (new_cohort%siteptr%dstatus==2 .and. EDPftvarcon_inst%stress_decid(pft) == 1) then + new_cohort%laimemory = 0.0_r8 + endif + + ! Calculate live biomass allocation + call allocate_live_biomass(new_cohort,0) + + ! Assign canopy extent and depth + new_cohort%c_area = c_area(new_cohort) + new_cohort%treelai = tree_lai(new_cohort) + new_cohort%lai = new_cohort%treelai * new_cohort%c_area/patchptr%area + new_cohort%treesai = 0.0_r8 !FIX(RF,032414) + + ! Put cohort at the right place in the linked list + storebigcohort => patchptr%tallest + storesmallcohort => patchptr%shortest + + if (associated(patchptr%tallest)) then + tnull = 0 + else + tnull = 1 + patchptr%tallest => new_cohort + endif + + if (associated(patchptr%shortest)) then + snull = 0 + else + snull = 1 + patchptr%shortest => new_cohort + endif + + ! Recuits do not have mortality rates, nor have they moved any + ! carbon when they are created. They will bias our statistics + ! until they have experienced a full day. We need a newly recruited flag. + ! This flag will be set to false after it has experienced + ! growth, disturbance and mortality. + new_cohort%isnew = .true. + + if( use_fates_plant_hydro ) then + call InitHydrCohort(new_cohort) + call updateSizeDepTreeHydProps(new_cohort, bc_in) + call initTreeHydStates(new_cohort, bc_in) + endif + + call insert_cohort(new_cohort, patchptr%tallest, patchptr%shortest, tnull, snull, & + storebigcohort, storesmallcohort) + + patchptr%tallest => storebigcohort + patchptr%shortest => storesmallcohort + + end subroutine create_cohort + + !-------------------------------------------------------------------------------------! + subroutine allocate_live_biomass(cc_p,mode) + ! + ! !DESCRIPTION: + ! Divide alive biomass between leaf, root and sapwood parts. + ! Needs to be called whenver balive changes. + ! + ! !USES: + ! + ! !ARGUMENTS + type (ed_cohort_type), intent(inout), target :: cc_p ! current cohort pointer + integer , intent(in) :: mode + ! + ! !LOCAL VARIABLES: + type (ed_cohort_type), pointer :: currentCohort + real(r8) :: leaf_frac ! fraction of live biomass in leaves + real(r8) :: ideal_balive ! theoretical ideal (root and stem) biomass for deciduous trees with leaves off. + ! accounts for the fact that live biomass may decline in the off-season, + ! making leaf_memory unrealistic. + real(r8) :: ratio_balive ! ratio between root+shoot biomass now and root+shoot biomass when leaves fell off. + real(r8) :: new_bl + real(r8) :: new_br + real(r8) :: new_bsw + + integer :: ft ! functional type + integer :: leaves_off_switch + !---------------------------------------------------------------------- + + currentCohort => cc_p + ft = currentcohort%pft + leaf_frac = 1.0_r8/(1.0_r8 + EDecophyscon%sapwood_ratio(ft) * currentcohort%hite + EDPftvarcon_inst%froot_leaf(ft)) + + !currentcohort%bl = currentcohort%balive*leaf_frac + !for deciduous trees, there are no leaves + + if (EDPftvarcon_inst%evergreen(ft) == 1) then + currentcohort%laimemory = 0._r8 + currentcohort%status_coh = 2 + endif + + ! iagnore the root and stem biomass from the functional balance hypothesis. This is used when the leaves are + !fully on. + !currentcohort%br = EDPftvarcon_inst%froot_leaf(ft) * (currentcohort%balive + currentcohort%laimemory) * leaf_frac + !currentcohort%bsw = EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(currentcohort%balive + & + ! currentcohort%laimemory)*leaf_frac + + leaves_off_switch = 0 + if (currentcohort%status_coh == 1.and.EDPftvarcon_inst%stress_decid(ft) == 1.and.currentcohort%siteptr%dstatus==1) then !no leaves + leaves_off_switch = 1 !drought decid + endif + if (currentcohort%status_coh == 1.and.EDPftvarcon_inst%season_decid(ft) == 1.and.currentcohort%siteptr%status==1) then !no leaves + leaves_off_switch = 1 !cold decid + endif + + ! Use different proportions if the leaves are on vs off + if(leaves_off_switch==0)then + + new_bl = currentcohort%balive*leaf_frac + + new_br = EDpftvarcon_inst%froot_leaf(ft) * (currentcohort%balive + currentcohort%laimemory) * leaf_frac + + new_bsw = EDecophyscon%sapwood_ratio(ft) * currentcohort%hite *(currentcohort%balive + & + currentcohort%laimemory)*leaf_frac + + !diagnose the root and stem biomass from the functional balance hypothesis. This is used when the leaves are + !fully on. + if(mode==1)then + + currentcohort%npp_leaf = currentcohort%npp_leaf + & + max(0.0_r8,new_bl - currentcohort%bl) / hlm_freq_day + + currentcohort%npp_froot = currentcohort%npp_froot + & + max(0._r8,new_br - currentcohort%br) / hlm_freq_day + + currentcohort%npp_bsw = max(0.0_r8, new_bsw - currentcohort%bsw)/hlm_freq_day + + currentcohort%npp_bdead = currentCohort%dbdeaddt + + end if + + currentcohort%bl = new_bl + currentcohort%br = new_br + currentcohort%bsw = new_bsw + + else ! Leaves are off (leaves_off_switch==1) + + !the purpose of this section is to figure out the root and stem biomass when the leaves are off + !at this point, we know the former leaf mass (laimemory) and the current alive mass + !because balive may decline in the off-season, we need to adjust the + !root and stem biomass that are predicted from the laimemory, for the fact that we now might + !not have enough live biomass to support the hypothesized root mass + !thus, we use 'ratio_balive' to adjust br and bsw. Apologies that this is so complicated! RF + + ideal_balive = currentcohort%laimemory * EDPftvarcon_inst%froot_leaf(ft) + & + currentcohort%laimemory* EDecophyscon%sapwood_ratio(ft) * currentcohort%hite + ratio_balive = currentcohort%balive / ideal_balive + + new_br = EDpftvarcon_inst%froot_leaf(ft) * (ideal_balive + currentcohort%laimemory) * & + leaf_frac * ratio_balive + new_bsw = EDecophyscon%sapwood_ratio(ft) * currentcohort%hite * & + (ideal_balive + currentcohort%laimemory) * leaf_frac * ratio_balive + + ! Diagnostics + if(mode==1)then + + currentcohort%npp_froot = currentcohort%npp_froot + & + max(0.0_r8,new_br-currentcohort%br)/hlm_freq_day + + currentcohort%npp_bsw = max(0.0_r8, new_bsw-currentcohort%bsw)/hlm_freq_day + + currentcohort%npp_bdead = currentCohort%dbdeaddt + + end if + + currentcohort%bl = 0.0_r8 + currentcohort%br = new_br + currentcohort%bsw = new_bsw + + endif + + if (abs(currentcohort%balive -currentcohort%bl- currentcohort%br - currentcohort%bsw)>1e-12) then + write(fates_log(),*) 'issue with carbon allocation in create_cohort,allocate_live_biomass',& + currentcohort%balive -currentcohort%bl- currentcohort%br - currentcohort%bsw, & + currentcohort%status_coh,currentcohort%balive + write(fates_log(),*) 'actual vs predicted balive',ideal_balive,currentcohort%balive ,ratio_balive,leaf_frac + write(fates_log(),*) 'leaf,root,stem',currentcohort%bl,currentcohort%br,currentcohort%bsw + write(fates_log(),*) 'pft',ft,EDPftvarcon_inst%evergreen(ft),EDPftvarcon_inst%season_decid(ft),leaves_off_switch + endif + currentCohort%b = currentCohort%bdead + currentCohort%balive + + end subroutine allocate_live_biomass + + !-------------------------------------------------------------------------------------! + subroutine nan_cohort(cc_p) + ! + ! !DESCRIPTION: + ! Make all the cohort variables NaN so they aren't used before defined. + ! + ! !USES: + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + use FatesConstantsMod, only : fates_unset_int + + ! + ! !ARGUMENTS + type (ed_cohort_type), intent(inout), target :: cc_p + ! + ! !LOCAL VARIABLES: + type (ed_cohort_type) , pointer :: currentCohort + !---------------------------------------------------------------------- + + currentCohort => cc_p + + currentCohort%taller => null() ! pointer to next tallest cohort + currentCohort%shorter => null() ! pointer to next shorter cohort + currentCohort%patchptr => null() ! pointer to patch that cohort is in + currentCohort%siteptr => null() ! pointer to site that cohort is in + + nullify(currentCohort%taller) + nullify(currentCohort%shorter) + nullify(currentCohort%patchptr) + nullify(currentCohort%siteptr) + + ! VEGETATION STRUCTURE + currentCohort%pft = fates_unset_int ! pft number + currentCohort%indexnumber = fates_unset_int ! unique number for each cohort. (within clump?) + currentCohort%canopy_layer = fates_unset_int ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) + currentCohort%canopy_layer_yesterday = nan ! recent canopy status of cohort (1 = canopy, 2 = understorey, etc.) + currentCohort%NV = fates_unset_int ! Number of leaf layers: - + currentCohort%status_coh = fates_unset_int ! growth status of plant (2 = leaves on , 1 = leaves off) + currentCohort%size_class = fates_unset_int ! size class index + currentCohort%size_by_pft_class = fates_unset_int ! size by pft classification index + + currentCohort%n = nan ! number of individuals in cohort per 'area' (10000m2 default) + currentCohort%dbh = nan ! 'diameter at breast height' in cm + currentCohort%hite = nan ! height: meters + currentCohort%balive = nan ! total living biomass: kGC per indiv + currentCohort%bdead = nan ! dead biomass: kGC per indiv + currentCohort%bstore = nan ! stored carbon: kGC per indiv + currentCohort%laimemory = nan ! target leaf biomass- set from previous year: kGC per indiv + currentCohort%b = nan ! total biomass: kGC per indiv + currentCohort%bsw = nan ! sapwood in stem and roots: kGC per indiv + currentCohort%bl = nan ! leaf biomass: kGC per indiv + currentCohort%br = nan ! fine root biomass: kGC per indiv + currentCohort%lai = nan ! leaf area index of cohort m2/m2 + currentCohort%sai = nan ! stem area index of cohort m2/m2 + currentCohort%gscan = nan ! Stomatal resistance of cohort. + currentCohort%canopy_trim = nan ! What is the fraction of the maximum leaf biomass that we are targeting? :- + currentCohort%leaf_cost = nan ! How much does it cost to maintain leaves: kgC/m2/year-1 + currentCohort%excl_weight = nan ! How much of this cohort is demoted each year, as a proportion of all cohorts:- + currentCohort%prom_weight = nan ! How much of this cohort is promoted each year, as a proportion of all cohorts:- + currentCohort%c_area = nan ! areal extent of canopy (m2) + currentCohort%treelai = nan ! lai of tree (total leaf area (m2) / canopy area (m2) + currentCohort%treesai = nan ! stem area index of tree (total stem area (m2) / canopy area (m2) + + ! CARBON FLUXES + currentCohort%gpp_acc_hold = nan ! GPP: kgC/indiv/year + currentCohort%gpp_tstep = nan ! GPP: kgC/indiv/timestep + currentCohort%gpp_acc = nan ! GPP: kgC/indiv/day + currentCohort%npp_acc_hold = nan ! NPP: kgC/indiv/year + currentCohort%npp_tstep = nan ! NPP: kGC/indiv/timestep + currentCohort%npp_acc = nan ! NPP: kgC/indiv/day + currentCohort%year_net_uptake(:) = nan ! Net uptake of individual leaf layers kgC/m2/year + currentCohort%ts_net_uptake(:) = nan ! Net uptake of individual leaf layers kgC/m2/s + currentCohort%resp_acc_hold = nan ! RESP: kgC/indiv/year + currentCohort%resp_tstep = nan ! RESP: kgC/indiv/timestep + currentCohort%resp_acc = nan ! RESP: kGC/cohort/day + + currentCohort%npp_leaf = nan + currentCohort%npp_froot = nan + currentCohort%npp_bsw = nan + currentCohort%npp_bdead = nan + currentCohort%npp_bseed = nan + currentCohort%npp_store = nan + + + !RESPIRATION + currentCohort%rdark = nan + currentCohort%resp_m = nan ! Maintenance respiration. kGC/cohort/year + currentCohort%resp_g = nan ! Growth respiration. kGC/cohort/year + currentCohort%livestem_mr = nan ! Live stem maintenance respiration. kgC/indiv/s-1 + currentCohort%livecroot_mr = nan ! Coarse root maintenance respiration. kgC/indiv/s-1 + currentCohort%froot_mr = nan ! Fine root maintenance respiration. kgC/indiv/s-1 + + ! ALLOCATION + currentCohort%md = nan ! plant maintenance demand: kgC/indiv/year + currentCohort%leaf_md = nan ! leaf maintenance demand: kgC/indiv/year + currentCohort%root_md = nan ! root maintenance demand: kgC/indiv/year + currentCohort%carbon_balance = nan ! carbon remaining for growth and storage: kg/indiv/year + currentCohort%dmort = nan ! proportional mortality rate. (year-1) + currentCohort%seed_prod = nan ! reproduction seed and clonal: KgC/indiv/year + currentCohort%c_area = nan ! areal extent of canopy (m2) + currentCohort%treelai = nan ! lai of tree (total leaf area (m2) / canopy area (m2) + currentCohort%treesai = nan ! stem area index of tree (total stem area (m2) / canopy area (m2) + currentCohort%leaf_litter = nan ! leaf litter from phenology: KgC/m2 + currentCohort%woody_turnover = nan ! amount of wood lost each day: kgC/indiv/year. Currently set to zero. + + ! VARIABLES NEEDED FOR INTEGRATION + currentCohort%dndt = nan ! time derivative of cohort size + currentCohort%dhdt = nan ! time derivative of height + currentCohort%ddbhdt = nan ! time derivative of dbh + currentCohort%dbalivedt = nan ! time derivative of total living biomass + currentCohort%dbdeaddt = nan ! time derivative of dead biomass + currentCohort%dbstoredt = nan ! time derivative of stored biomass + currentCohort%storage_flux = nan ! flux from npp into bstore + + ! FIRE + currentCohort%cfa = nan ! proportion of crown affected by fire + currentCohort%cambial_mort = nan ! probability that trees dies due to cambial char P&R (1986) + currentCohort%crownfire_mort = nan ! probability of tree post-fire mortality due to crown scorch + currentCohort%fire_mort = nan ! post-fire mortality from cambial and crown damage assuming two are independent + + end subroutine nan_cohort + + !-------------------------------------------------------------------------------------! + subroutine zero_cohort(cc_p) + ! + ! !DESCRIPTION: + ! Zero variables that need to be accounted for if + ! this cohort is altered before they are defined. + ! + ! !USES: + ! + ! !ARGUMENTS + type (ed_cohort_type), intent(inout), target :: cc_p + ! + ! !LOCAL VARIABLES: + type (ed_cohort_type) , pointer :: currentCohort + !---------------------------------------------------------------------- + + currentCohort => cc_p + + currentCohort%NV = 0 + currentCohort%status_coh = 0 + currentCohort%rdark = 0._r8 + currentCohort%resp_m = 0._r8 + currentCohort%resp_g = 0._r8 + currentCohort%livestem_mr = 0._r8 + currentCohort%livecroot_mr = 0._r8 + currentCohort%froot_mr = 0._r8 + currentCohort%fire_mort = 0._r8 + currentcohort%npp_acc = 0._r8 + currentcohort%gpp_acc = 0._r8 + currentcohort%resp_acc = 0._r8 + currentcohort%npp_tstep = 0._r8 + currentcohort%gpp_tstep = 0._r8 + currentcohort%resp_tstep = 0._r8 + currentcohort%resp_acc_hold = 0._r8 + currentcohort%carbon_balance = 0._r8 + currentcohort%leaf_litter = 0._r8 + currentcohort%year_net_uptake(:) = 999 ! this needs to be 999, or trimming of new cohorts will break. + currentcohort%ts_net_uptake(:) = 0._r8 + currentcohort%seed_prod = 0._r8 + currentcohort%cfa = 0._r8 + currentcohort%md = 0._r8 + currentcohort%root_md = 0._r8 + currentcohort%leaf_md = 0._r8 + currentcohort%npp_acc_hold = 0._r8 + currentcohort%gpp_acc_hold = 0._r8 + currentcohort%storage_flux = 0._r8 + currentcohort%dmort = 0._r8 + currentcohort%gscan = 0._r8 + currentcohort%treesai = 0._r8 + + ! currentCohort%npp_leaf = 0._r8 + ! currentCohort%npp_froot = 0._r8 + ! currentCohort%npp_bsw = 0._r8 + ! currentCohort%npp_bdead = 0._r8 + ! currentCohort%npp_bseed = 0._r8 + ! currentCohort%npp_store = 0._r8 + + end subroutine zero_cohort + + !-------------------------------------------------------------------------------------! + subroutine terminate_cohorts( currentSite, patchptr ) + ! + ! !DESCRIPTION: + ! terminates cohorts when they get too small + ! + ! !USES: + use EDParamsMod, only : ED_val_ag_biomass + use SFParamsMod, only : SF_val_CWD_frac + ! + ! !ARGUMENTS + type (ed_site_type) , intent(inout), target :: currentSite + type (ed_patch_type), intent(inout), target :: patchptr + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort + type (ed_cohort_type) , pointer :: nextc + integer :: terminate ! do we terminate (1) or not (0) + integer :: c ! counter for litter size class. + integer :: levcan ! canopy level + !---------------------------------------------------------------------- + + currentPatch => patchptr + currentCohort => currentPatch%tallest + + do while (associated(currentCohort)) + nextc => currentCohort%shorter + terminate = 0 + + ! Check if number density is so low is breaks math + if (currentcohort%n < min_n_safemath) then + terminate = 1 + if ( DEBUG ) then + write(fates_log(),*) 'terminating cohorts 0',currentCohort%n/currentPatch%area,currentCohort%dbh + endif + endif + + ! The rest of these are only allowed if we are not dealing with a recruit + if (.not.currentCohort%isnew) then + + ! Not enough n or dbh + if (currentCohort%n/currentPatch%area <= min_npm2 .or. & ! + currentCohort%n <= min_nppatch .or. & + (currentCohort%dbh < 0.00001_r8.and.currentCohort%bstore < 0._r8) ) then + terminate = 1 + + if ( DEBUG ) then + write(fates_log(),*) 'terminating cohorts 1',currentCohort%n/currentPatch%area,currentCohort%dbh + endif + endif + + ! In the third canopy layer + if (currentCohort%canopy_layer > nclmax ) then + terminate = 1 + if ( DEBUG ) then + write(fates_log(),*) 'terminating cohorts 2', currentCohort%canopy_layer + endif + endif + + ! live biomass pools are terminally depleted + if (currentCohort%balive < 1e-10_r8 .or. currentCohort%bstore < 1e-10_r8) then + terminate = 1 + if ( DEBUG ) then + write(fates_log(),*) 'terminating cohorts 3', currentCohort%balive,currentCohort%bstore + endif + endif + + ! Total cohort biomass is negative + if (currentCohort%balive+currentCohort%bdead+currentCohort%bstore < 0._r8) then + terminate = 1 + if ( DEBUG ) then + write(fates_log(),*) 'terminating cohorts 4', currentCohort%balive, & + currentCohort%bstore, currentCohort%bdead, & + currentCohort%balive+currentCohort%bdead+& + currentCohort%bstore, currentCohort%n + endif + + endif + endif + + if (terminate == 1) then + ! preserve a record of the to-be-terminated cohort for mortality accounting + if (currentCohort%canopy_layer .eq. 1) then + levcan = 1 + else + levcan = 2 + endif + currentSite%terminated_nindivs(currentCohort%size_class,currentCohort%pft,levcan) = & + currentSite%terminated_nindivs(currentCohort%size_class,currentCohort%pft,levcan) + currentCohort%n + ! + currentSite%termination_carbonflux(levcan) = currentSite%termination_carbonflux(levcan) + & + currentCohort%n * currentCohort%b + if (.not. associated(currentCohort%taller)) then + currentPatch%tallest => currentCohort%shorter + else + currentCohort%taller%shorter => currentCohort%shorter + endif + if (.not. associated(currentCohort%shorter)) then + currentPatch%shortest => currentCohort%taller + else + currentCohort%shorter%taller => currentCohort%taller + endif + + !put the litter from the terminated cohorts straight into the fragmenting pools + if (currentCohort%n.gt.0.0_r8) then + do c=1,ncwd + + currentPatch%CWD_AG(c) = currentPatch%CWD_AG(c) + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) / & + currentPatch%area & + * SF_val_CWD_frac(c) * ED_val_ag_biomass + currentPatch%CWD_BG(c) = currentPatch%CWD_BG(c) + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) / & + currentPatch%area & + * SF_val_CWD_frac(c) * (1.0_r8 - ED_val_ag_biomass) + enddo + + currentPatch%leaf_litter(currentCohort%pft) = currentPatch%leaf_litter(currentCohort%pft) + currentCohort%n* & + (currentCohort%bl)/currentPatch%area + currentPatch%root_litter(currentCohort%pft) = currentPatch%root_litter(currentCohort%pft) + currentCohort%n* & + (currentCohort%br+currentCohort%bstore)/currentPatch%area + + ! keep track of the above fluxes at the site level as a CWD/litter input flux (in kg / site-m2 / yr) + do c=1,ncwd + currentSite%CWD_AG_diagnostic_input_carbonflux(c) = currentSite%CWD_AG_diagnostic_input_carbonflux(c) & + + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & + SF_val_CWD_frac(c) * ED_val_ag_biomass * hlm_days_per_year / AREA + currentSite%CWD_BG_diagnostic_input_carbonflux(c) = currentSite%CWD_BG_diagnostic_input_carbonflux(c) & + + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & + SF_val_CWD_frac(c) * (1.0_r8 - ED_val_ag_biomass) * hlm_days_per_year / AREA + enddo + + currentSite%leaf_litter_diagnostic_input_carbonflux(currentCohort%pft) = & + currentSite%leaf_litter_diagnostic_input_carbonflux(currentCohort%pft) + & + currentCohort%n * (currentCohort%bl) * hlm_days_per_year / AREA + currentSite%root_litter_diagnostic_input_carbonflux(currentCohort%pft) = & + currentSite%root_litter_diagnostic_input_carbonflux(currentCohort%pft) + & + currentCohort%n * (currentCohort%br+currentCohort%bstore) * hlm_days_per_year / AREA + + if (use_fates_plant_hydro) call DeallocateHydrCohort(currentCohort) + + deallocate(currentCohort) + endif + endif + currentCohort => nextc + enddo + + end subroutine terminate_cohorts + + !-------------------------------------------------------------------------------------! + subroutine fuse_cohorts(patchptr, bc_in) + ! + ! !DESCRIPTION: + ! Join similar cohorts to reduce total number + ! + ! !USES: + use EDTypesMod , only : nlevleaf + use EDParamsMod , only : ED_val_cohort_fusion_tol + ! + ! !ARGUMENTS + type (ed_patch_type), intent(inout), target :: patchptr + type (bc_in_type), intent(in) :: bc_in + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort, nextc, nextnextc + integer :: i + integer :: fusion_took_place + integer :: maxcohorts !maximum total no of cohorts. Needs to be >numpft_edx2 + integer :: iterate !do we need to keep fusing to get below maxcohorts? + integer :: nocohorts + real(r8) :: newn + real(r8) :: diff + real(r8) :: dynamic_fusion_tolerance + !---------------------------------------------------------------------- + + !set initial fusion tolerance + dynamic_fusion_tolerance = ED_val_cohort_fusion_tol + + !This needs to be a function of the canopy layer, because otherwise, at canopy closure + !the number of cohorts doubles and very dissimilar cohorts are fused together + !because c_area and biomass are non-linear with dbh, this causes several mass inconsistancies + !in theory, all of this routine therefore causes minor losses of C and area, but these are below + !detection limit normally. + iterate = 1 + fusion_took_place = 0 + currentPatch => patchptr + maxcohorts = maxCohortsPerPatch + + !---------------------------------------------------------------------! + ! Keep doing this until nocohorts <= maxcohorts ! + !---------------------------------------------------------------------! + if (associated(currentPatch%shortest)) then + do while(iterate == 1) + + currentCohort => currentPatch%tallest + + ! The following logic continues the loop while the current cohort is not the shortest cohort + ! if they point to the same target (ie equivalence), then the loop ends. + ! This loop is different than the simple "continue while associated" loop in that + ! it omits the last cohort (because it has already been compared by that point) + + do while ( .not.associated(currentCohort,currentPatch%shortest) ) + + nextc => currentPatch%tallest + + do while (associated(nextc)) + nextnextc => nextc%shorter + diff = abs((currentCohort%dbh - nextc%dbh)/(0.5*(currentCohort%dbh + nextc%dbh))) + + !Criteria used to divide up the height continuum into different cohorts. + + if (diff < dynamic_fusion_tolerance) then + + ! Don't fuse a cohort with itself! + if (.not.associated(currentCohort,nextc) ) then + + if (currentCohort%pft == nextc%pft) then + + ! check cohorts in same c. layer. before fusing + + if (currentCohort%canopy_layer == nextc%canopy_layer) then + + ! Note: because newly recruited cohorts that have not experienced + ! a day yet will have un-known flux quantities or change rates + ! we don't want them fusing with non-new cohorts. We allow them + ! to fuse with other new cohorts to keep the total number of cohorts + ! down. + + if( .not.(currentCohort%isnew) .and. .not.(nextc%isnew) ) then + + newn = currentCohort%n + nextc%n + fusion_took_place = 1 + + + currentCohort%balive = (currentCohort%n*currentCohort%balive + nextc%n*nextc%balive)/newn + currentCohort%bdead = (currentCohort%n*currentCohort%bdead + nextc%n*nextc%bdead)/newn + + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn I ',currentCohort%bstore + + currentCohort%bstore = (currentCohort%n*currentCohort%bstore + nextc%n*nextc%bstore)/newn + + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn II ',currentCohort%bstore + + currentCohort%seed_prod = (currentCohort%n*currentCohort%seed_prod + nextc%n*nextc%seed_prod)/newn + currentCohort%root_md = (currentCohort%n*currentCohort%root_md + nextc%n*nextc%root_md)/newn + currentCohort%leaf_md = (currentCohort%n*currentCohort%leaf_md + nextc%n*nextc%leaf_md)/newn + currentCohort%laimemory = (currentCohort%n*currentCohort%laimemory + nextc%n*nextc%laimemory)/newn + currentCohort%md = (currentCohort%n*currentCohort%md + nextc%n*nextc%md)/newn + + currentCohort%carbon_balance = (currentCohort%n*currentCohort%carbon_balance + & + nextc%n*nextc%carbon_balance)/newn + + currentCohort%storage_flux = (currentCohort%n*currentCohort%storage_flux + & + nextc%n*nextc%storage_flux)/newn + + currentCohort%b = (currentCohort%n*currentCohort%b + nextc%n*nextc%b)/newn + currentCohort%bsw = (currentCohort%n*currentCohort%bsw + nextc%n*nextc%bsw)/newn + currentCohort%bl = (currentCohort%n*currentCohort%bl + nextc%n*nextc%bl)/newn + + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn 569 ',currentCohort%br + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn 570 ',currentCohort%n + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn 571 ',nextc%br + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn 572 ',nextc%n + + currentCohort%br = (currentCohort%n*currentCohort%br + nextc%n*nextc%br)/newn + currentCohort%hite = (currentCohort%n*currentCohort%hite + nextc%n*nextc%hite)/newn + currentCohort%dbh = (currentCohort%n*currentCohort%dbh + nextc%n*nextc%dbh)/newn + + currentCohort%gpp_acc = (currentCohort%n*currentCohort%gpp_acc + nextc%n*nextc%gpp_acc)/newn + + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn III ',currentCohort%npp_acc + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn IV ',currentCohort%resp_acc + + currentCohort%npp_acc = (currentCohort%n*currentCohort%npp_acc + nextc%n*nextc%npp_acc)/newn + currentCohort%resp_acc = (currentCohort%n*currentCohort%resp_acc + nextc%n*nextc%resp_acc)/newn + + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn V ',currentCohort%npp_acc + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn VI ',currentCohort%resp_acc + + currentCohort%resp_acc_hold = & + (currentCohort%n*currentCohort%resp_acc_hold + & + nextc%n*nextc%resp_acc_hold)/newn + currentCohort%npp_acc_hold = & + (currentCohort%n*currentCohort%npp_acc_hold + & + nextc%n*nextc%npp_acc_hold)/newn + currentCohort%gpp_acc_hold = & + (currentCohort%n*currentCohort%gpp_acc_hold + & + nextc%n*nextc%gpp_acc_hold)/newn + + currentCohort%canopy_trim = (currentCohort%n*currentCohort%canopy_trim + nextc%n*nextc%canopy_trim)/newn + currentCohort%dmort = (currentCohort%n*currentCohort%dmort + nextc%n*nextc%dmort)/newn + currentCohort%fire_mort = (currentCohort%n*currentCohort%fire_mort + nextc%n*nextc%fire_mort)/newn + currentCohort%leaf_litter = (currentCohort%n*currentCohort%leaf_litter + nextc%n*nextc%leaf_litter)/newn + + ! mortality diagnostics + currentCohort%cmort = (currentCohort%n*currentCohort%cmort + nextc%n*nextc%cmort)/newn + currentCohort%hmort = (currentCohort%n*currentCohort%hmort + nextc%n*nextc%hmort)/newn + currentCohort%bmort = (currentCohort%n*currentCohort%bmort + nextc%n*nextc%bmort)/newn + currentCohort%imort = (currentCohort%n*currentCohort%imort + nextc%n*nextc%imort)/newn + currentCohort%fmort = (currentCohort%n*currentCohort%fmort + nextc%n*nextc%fmort)/newn + + ! npp diagnostics + currentCohort%npp_leaf = (currentCohort%n*currentCohort%npp_leaf + nextc%n*nextc%npp_leaf)/newn + currentCohort%npp_froot = (currentCohort%n*currentCohort%npp_froot + nextc%n*nextc%npp_froot)/newn + currentCohort%npp_bsw = (currentCohort%n*currentCohort%npp_bsw + nextc%n*nextc%npp_bsw)/newn + currentCohort%npp_bdead = (currentCohort%n*currentCohort%npp_bdead + nextc%n*nextc%npp_bdead)/newn + currentCohort%npp_bseed = (currentCohort%n*currentCohort%npp_bseed + nextc%n*nextc%npp_bseed)/newn + currentCohort%npp_store = (currentCohort%n*currentCohort%npp_store + nextc%n*nextc%npp_store)/newn + + ! recent canopy history + currentCohort%canopy_layer_yesterday = (currentCohort%n*currentCohort%canopy_layer_yesterday + & + nextc%n*nextc%canopy_layer_yesterday)/newn + + do i=1, nlevleaf + if (currentCohort%year_net_uptake(i) == 999._r8 .or. nextc%year_net_uptake(i) == 999._r8) then + currentCohort%year_net_uptake(i) = min(nextc%year_net_uptake(i),currentCohort%year_net_uptake(i)) + else + currentCohort%year_net_uptake(i) = (currentCohort%n*currentCohort%year_net_uptake(i) + & + nextc%n*nextc%year_net_uptake(i))/newn + endif + enddo + + if(use_fates_plant_hydro) call FuseCohortHydraulics(currentCohort,nextc,bc_in,newn) + + currentCohort%n = newn + !remove fused cohort from the list + nextc%taller%shorter => nextnextc + if (.not. associated(nextc%shorter)) then !this is the shortest cohort. + currentPatch%shortest => nextc%taller + else + nextnextc%taller => nextc%taller + endif + + if (associated(nextc)) then + if(use_fates_plant_hydro) call DeallocateHydrCohort(nextc) + deallocate(nextc) + endif + + endif ! Not a recruit + + endif !canopy layer + endif !pft + endif !index no. + endif !diff + + if (associated(nextc)) then + nextc => nextc%shorter + else + nextc => nextnextc !if we have removed next + endif + + enddo !end checking nextc cohort loop + + if (associated (currentCohort%shorter)) then + currentCohort => currentCohort%shorter + endif + enddo !end currentCohort cohort loop + + !---------------------------------------------------------------------! + ! Is the number of cohorts larger than the maximum? ! + !---------------------------------------------------------------------! + nocohorts = 0 + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + nocohorts = nocohorts + 1 + currentCohort => currentCohort%shorter + enddo + + if (nocohorts > maxcohorts) then + iterate = 1 + !---------------------------------------------------------------------! + ! Making profile tolerance larger means that more fusion will happen ! + !---------------------------------------------------------------------! + dynamic_fusion_tolerance = dynamic_fusion_tolerance * 1.1_r8 + + write(fates_log(),*) 'maxcohorts exceeded',dynamic_fusion_tolerance + + else + iterate = 0 + endif + + enddo !do while nocohorts>maxcohorts + + endif ! patch. + + if (fusion_took_place == 1) then ! if fusion(s) occured sort cohorts + call sort_cohorts(currentPatch) + endif + + end subroutine fuse_cohorts + +!-------------------------------------------------------------------------------------! + + subroutine sort_cohorts(patchptr) + ! ============================================================================ + ! sort cohorts into the correct order DO NOT CHANGE THIS IT WILL BREAK + ! ============================================================================ + + type(ed_patch_type) , intent(inout), target :: patchptr + + type(ed_patch_type) , pointer :: current_patch + type(ed_cohort_type), pointer :: current_c, next_c + type(ed_cohort_type), pointer :: shortestc, tallestc + type(ed_cohort_type), pointer :: storesmallcohort + type(ed_cohort_type), pointer :: storebigcohort + integer :: snull,tnull + + current_patch => patchptr + tallestc => NULL() + shortestc => NULL() + storebigcohort => null() + storesmallcohort => null() + current_c => current_patch%tallest + + do while (associated(current_c)) + next_c => current_c%shorter + tallestc => storebigcohort + shortestc => storesmallcohort + if (associated(tallestc)) then + tnull = 0 + else + tnull = 1 + tallestc => current_c + endif + + if (associated(shortestc)) then + snull = 0 + else + snull = 1 + shortestc => current_c + endif + + call insert_cohort(current_c, tallestc, shortestc, tnull, snull, storebigcohort, storesmallcohort) + + current_patch%tallest => storebigcohort + current_patch%shortest => storesmallcohort + current_c => next_c + + enddo + + end subroutine sort_cohorts + + !-------------------------------------------------------------------------------------! + subroutine insert_cohort(pcc, ptall, pshort, tnull, snull, storebigcohort, storesmallcohort) + ! + ! !DESCRIPTION: + ! Insert cohort into linked list + ! + ! !USES: + ! + ! !ARGUMENTS + type(ed_cohort_type) , intent(inout), target :: pcc + type(ed_cohort_type) , intent(inout), target :: ptall + type(ed_cohort_type) , intent(inout), target :: pshort + integer , intent(in) :: tnull + integer , intent(in) :: snull + type(ed_cohort_type) , intent(inout),pointer,optional :: storesmallcohort ! storage of the smallest cohort for insertion routine + type(ed_cohort_type) , intent(inout),pointer,optional :: storebigcohort ! storage of the largest cohort for insertion routine + ! + ! !LOCAL VARIABLES: + type(ed_patch_type), pointer :: currentPatch + type(ed_cohort_type), pointer :: current + type(ed_cohort_type), pointer :: tallptr, shortptr, icohort + type(ed_cohort_type), pointer :: ptallest, pshortest + real(r8) :: tsp + integer :: tallptrnull,exitloop + !---------------------------------------------------------------------- + + currentPatch => pcc%patchptr + ptallest => ptall + pshortest => pshort + + if (tnull == 1) then + ptallest => null() + endif + if (snull == 1) then + pshortest => null() + endif + + icohort => pcc ! assign address to icohort local name + !place in the correct place in the linked list of heights + !begin by finding cohort that is just taller than the new cohort + tsp = icohort%dbh + + current => pshortest + exitloop = 0 + !starting with shortest tree on the grid, find tree just + !taller than tree being considered and return its pointer + if (associated(current)) then + do while (associated(current).and.exitloop == 0) + if (current%dbh < tsp) then + current => current%taller + else + exitloop = 1 + endif + enddo + endif + + if (associated(current)) then + tallptr => current + tallptrnull = 0 + else + tallptr => null() + tallptrnull = 1 + endif + + !new cohort is tallest + if (.not.associated(tallptr)) then + !new shorter cohort to the new cohort is the old tallest cohort + shortptr => ptallest + + !new cohort is tallest cohort and next taller remains null + ptallest => icohort + if (present(storebigcohort)) then + storebigcohort => icohort + end if + currentPatch%tallest => icohort + icohort%patchptr%tallest => icohort + !new cohort is not tallest + else + !next shorter cohort to new cohort is the next shorter cohort + !to the cohort just taller than the new cohort + shortptr => tallptr%shorter + + !new cohort becomes the next shorter cohort to the cohort + !just taller than the new cohort + tallptr%shorter => icohort + endif + + !new cohort is shortest + if (.not.associated(shortptr)) then + !next shorter reamins null + !cohort is placed at the bottom of the list + pshortest => icohort + if (present(storesmallcohort)) then + storesmallcohort => icohort + end if + currentPatch%shortest => icohort + icohort%patchptr%shortest => icohort + else + !new cohort is not shortest and becomes next taller cohort + !to the cohort just below it as defined in the previous block + shortptr%taller => icohort + endif + + ! assign taller and shorter links for the new cohort + icohort%taller => tallptr + if (tallptrnull == 1) then + icohort%taller=> null() + endif + icohort%shorter => shortptr + + end subroutine insert_cohort + + !-------------------------------------------------------------------------------------! + subroutine copy_cohort( currentCohort,copyc ) + ! + ! !DESCRIPTION: + ! Copies all the variables in one cohort into another empty cohort + ! + ! !USES: + ! + ! !ARGUMENTS + type(ed_cohort_type), intent(inout) , target :: copyc ! New cohort argument. + type(ed_cohort_type), intent(in) , target :: currentCohort ! Old cohort argument. + ! + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer :: n,o ! New and old cohort pointers + !---------------------------------------------------------------------- + + o => currentCohort + n => copyc + + n%indexnumber = fates_unset_int + + ! VEGETATION STRUCTURE + n%pft = o%pft + n%n = o%n + n%dbh = o%dbh + n%hite = o%hite + n%b = o%b + n%balive = o%balive + n%bdead = o%bdead + n%bstore = o%bstore + n%laimemory = o%laimemory + n%bsw = o%bsw + n%bl = o%bl + n%br = o%br + n%lai = o%lai + n%sai = o%sai + n%gscan = o%gscan + n%leaf_cost = o%leaf_cost + n%canopy_layer = o%canopy_layer + n%canopy_layer_yesterday = o%canopy_layer_yesterday + n%nv = o%nv + n%status_coh = o%status_coh + n%canopy_trim = o%canopy_trim + n%status_coh = o%status_coh + n%excl_weight = o%excl_weight + n%prom_weight = o%prom_weight + + ! CARBON FLUXES + n%gpp_acc_hold = o%gpp_acc_hold + n%gpp_acc = o%gpp_acc + n%gpp_tstep = o%gpp_tstep + + n%npp_acc_hold = o%npp_acc_hold + n%npp_tstep = o%npp_tstep + n%npp_acc = o%npp_acc + + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn Ia ',o%npp_acc + if ( DEBUG ) write(fates_log(),*) 'EDcohortDyn Ib ',o%resp_acc + + n%resp_tstep = o%resp_tstep + n%resp_acc = o%resp_acc + n%resp_acc_hold = o%resp_acc_hold + n%year_net_uptake = o%year_net_uptake + n%ts_net_uptake = o%ts_net_uptake + + n%npp_leaf = o%npp_leaf + n%npp_froot = o%npp_froot + n%npp_bsw = o%npp_bsw + n%npp_bdead = o%npp_bdead + n%npp_bseed = o%npp_bseed + n%npp_store = o%npp_store + + !RESPIRATION + n%rdark = o%rdark + n%resp_m = o%resp_m + n%resp_g = o%resp_g + n%livestem_mr = o%livestem_mr + n%livecroot_mr = o%livecroot_mr + n%froot_mr = o%froot_mr + + ! ALLOCATION + n%md = o%md + n%leaf_md = o%leaf_md + n%root_md = o%root_md + n%carbon_balance = o%carbon_balance + n%dmort = o%dmort + n%seed_prod = o%seed_prod + n%treelai = o%treelai + n%treesai = o%treesai + n%leaf_litter = o%leaf_litter + n%c_area = o%c_area + n%woody_turnover = o%woody_turnover + + ! Mortality diagnostics + n%cmort = o%cmort + n%bmort = o%bmort + n%imort = o%imort + n%fmort = o%fmort + n%hmort = o%hmort + + ! Flags + n%isnew = o%isnew + + ! VARIABLES NEEDED FOR INTEGRATION + n%dndt = o%dndt + n%dhdt = o%dhdt + n%ddbhdt = o%ddbhdt + n%dbalivedt = o%dbalivedt + n%dbdeaddt = o%dbdeaddt + n%dbstoredt = o%dbstoredt + + if ( DEBUG ) write(fates_log(),*) 'EDCohortDyn dpstoredt ',o%dbstoredt + + n%storage_flux = o%storage_flux + + ! FIRE + n%cfa = o%cfa + n%fire_mort = o%fire_mort + n%crownfire_mort = o%crownfire_mort + n%cambial_mort = o%cambial_mort + + ! Plant Hydraulics + + if( use_fates_plant_hydro ) call CopyCohortHydraulics(n,o) + + !Pointers + n%taller => NULL() ! pointer to next tallest cohort + n%shorter => NULL() ! pointer to next shorter cohort + n%patchptr => o%patchptr ! pointer to patch that cohort is in + n%siteptr => o%siteptr ! pointer to site that cohort is in + + end subroutine copy_cohort + + !-------------------------------------------------------------------------------------! + function count_cohorts( currentPatch ) result ( backcount ) + ! + ! !DESCRIPTION: + ! + ! !USES: + ! + ! !ARGUMENTS + type(ed_patch_type), intent(inout), target :: currentPatch !new site + ! + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer ::currentCohort !new patch + integer backcount + !---------------------------------------------------------------------- + + currentCohort => currentPatch%shortest + + currentPatch%countcohorts = 0 + do while (associated(currentCohort)) + currentPatch%countcohorts = currentPatch%countcohorts + 1 + currentCohort => currentCohort%taller + enddo + + backcount = 0 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + backcount = backcount + 1 + currentCohort => currentCohort%shorter + enddo + + if (backcount /= currentPatch%countcohorts) then + write(fates_log(),*) 'problem with linked list, not symmetrical' + endif + + end function count_cohorts + + + + + !-------------------------------------------------------------------------------------! +! function countCohorts( bounds, ed_allsites_inst ) result ( totNumCohorts ) + ! + ! !DESCRIPTION: + ! counts the total number of cohorts over all p levels (ed_patch_type) so we + ! can allocate vectors, copy from LL -> vector and read/write restarts. + ! + ! !USES: +! use decompMod, only : bounds_type + ! + ! !ARGUMENTS +! type(bounds_type) , intent(in) :: bounds +! type(ed_site_type) , intent(inout), target :: ed_allsites_inst( bounds%begg: ) + ! + ! !LOCAL VARIABLES: +! type (ed_patch_type) , pointer :: currentPatch +! type (ed_cohort_type) , pointer :: currentCohort +! integer :: g, totNumCohorts +! logical :: error + !---------------------------------------------------------------------- + +! totNumCohorts = 0 + +! do g = bounds%begg,bounds%endg + +! if (ed_allsites_inst(g)%istheresoil) then + +! currentPatch => ed_allsites_inst(g)%oldest_patch +! do while(associated(currentPatch)) + +! currentCohort => currentPatch%shortest +! do while(associated(currentCohort)) +! totNumCohorts = totNumCohorts + 1 +! currentCohort => currentCohort%taller +! enddo !currentCohort +! currentPatch => currentPatch%younger +! end do + +! end if +! end do + +! end function countCohorts + +end module EDCohortDynamicsMod diff --git a/biogeochem/EDGrowthFunctionsMod.F90 b/biogeochem/EDGrowthFunctionsMod.F90 new file mode 100644 index 00000000..f0c081c8 --- /dev/null +++ b/biogeochem/EDGrowthFunctionsMod.F90 @@ -0,0 +1,442 @@ +module EDGrowthFunctionsMod + + ! ============================================================================ + ! Functions that control the trajectory of plant growth. + ! Ideally these would all use parameters that are fed in from the parameter file. + ! At present, there is only a single allocation trajectory. + ! ============================================================================ + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesGlobals , only : fates_log + use EDPftvarcon , only : EDPftvarcon_inst + use EDTypesMod , only : ed_cohort_type, nlevleaf, dinc_ed + + implicit none + private + + public :: bleaf + public :: hite + public :: ddbhdbd + public :: ddbhdbl + public :: dhdbd + public :: dbh + public :: bdead + public :: tree_lai + public :: tree_sai + public :: c_area + public :: mortality_rates + + logical :: DEBUG_growth = .false. + + ! ============================================================================ + ! 10/30/09: Created by Rosie Fisher + ! ============================================================================ + +contains + + real(r8) function Dbh( cohort_in ) + + ! ============================================================================ + ! Creates diameter in cm as a function of height in m + ! Height(m) diameter(cm) relationships. O'Brien et al - for 56 patch at BCI + ! ============================================================================ + + type(ed_cohort_type), intent(in) :: cohort_in + + !FIX(SPM,040214) - move to param file + real(r8) :: m !parameter of allometric equation (needs to not be hardwired... + real(r8) :: c !parameter of allometric equation (needs to not be hardwired... + + m = EDPftvarcon_inst%dbh2h_m(cohort_in%pft) + c = EDPftvarcon_inst%dbh2h_c(cohort_in%pft) + + dbh = (10.0_r8**((log10(cohort_in%hite) - c)/m)) + + return + + end function dbh + +! ============================================================================ + + real(r8) function Hite( cohort_in ) + + ! ============================================================================ + ! Creates height in m as a function of diameter in cm. + ! Height(m) diameter(cm) relationships. O'Brien et al - for 56 pft at BCI + ! ============================================================================ + + type(ed_cohort_type), intent(inout) :: cohort_in + + real(r8) :: m + real(r8) :: c + real(r8) :: h + + m = EDPftvarcon_inst%dbh2h_m(cohort_in%pft) + c = EDPftvarcon_inst%dbh2h_c(cohort_in%pft) + + if(cohort_in%dbh <= 0._r8)then + write(fates_log(),*) 'ED: dbh less than zero problem!' + cohort_in%dbh = 0.1_r8 + endif + + ! if the hite is larger than the maximum allowable height (set by dbhmax) then + ! set the height to the maximum value. + ! this could do with at least re-factoring and probably re-thinking. RF + if(cohort_in%dbh <= EDPftvarcon_inst%max_dbh(cohort_in%pft)) then + h = (10.0_r8**(log10(cohort_in%dbh) * m + c)) + else + h = (10.0_r8**(log10(EDPftvarcon_inst%max_dbh(cohort_in%pft))*m + c)) + endif + Hite = h + + return + + end function Hite + +! ============================================================================ + + real(r8) function Bleaf( cohort_in ) + + ! ============================================================================ + ! Creates leaf biomass (kGC) as a function of tree diameter. + ! ============================================================================ + + type(ed_cohort_type), intent(in) :: cohort_in + + real(r8) :: dbh2bl_a + real(r8) :: dbh2bl_b + real(r8) :: dbh2bl_c + real(r8) :: slascaler ! changes the target biomass according to the SLA + + dbh2bl_a = EDPftvarcon_inst%dbh2bl_a(cohort_in%pft) + dbh2bl_b = EDPftvarcon_inst%dbh2bl_b(cohort_in%pft) + dbh2bl_c = EDPftvarcon_inst%dbh2bl_c(cohort_in%pft) + slascaler = EDPftvarcon_inst%dbh2bl_slascaler(cohort_in%pft)/EDPftvarcon_inst%slatop(cohort_in%pft) + + if(cohort_in%dbh < 0._r8.or.cohort_in%pft == 0.or.cohort_in%dbh > 1000.0_r8)then + write(fates_log(),*) 'problems in bleaf',cohort_in%dbh,cohort_in%pft + endif + + if(cohort_in%dbh <= EDPftvarcon_inst%max_dbh(cohort_in%pft))then + bleaf = dbh2bl_a * (cohort_in%dbh**dbh2bl_b) * EDPftvarcon_inst%wood_density(cohort_in%pft)**dbh2bl_c + else + bleaf = dbh2bl_a * (EDPftvarcon_inst%max_dbh(cohort_in%pft)**dbh2bl_b) * & + EDPftvarcon_inst%wood_density(cohort_in%pft)**dbh2bl_c + endif + + bleaf = bleaf * slascaler + + !write(fates_log(),*) 'bleaf',bleaf, slascaler,cohort_in%pft + + !Adjust for canopies that have become so deep that their bottom layer is not producing any carbon... + !nb this will change the allometry and the effects of this remain untested. RF. April 2014 + + bleaf = bleaf * cohort_in%canopy_trim + + return + end function Bleaf + +! ============================================================================ + + real(r8) function tree_lai( cohort_in ) + + ! ============================================================================ + ! LAI of individual trees is a function of the total leaf area and the total canopy area. + ! ============================================================================ + + type(ed_cohort_type), intent(inout) :: cohort_in + + real(r8) :: leafc_per_unitarea ! KgC of leaf per m2 area of ground. + real(r8) :: slat ! the sla of the top leaf layer. m2/kgC + + if( cohort_in%bl < 0._r8 .or. cohort_in%pft == 0 ) then + write(fates_log(),*) 'problem in treelai',cohort_in%bl,cohort_in%pft + endif + + if( cohort_in%status_coh == 2 ) then ! are the leaves on? + slat = 1000.0_r8 * EDPftvarcon_inst%slatop(cohort_in%pft) ! m2/g to m2/kg + cohort_in%c_area = c_area(cohort_in) ! call the tree area + leafc_per_unitarea = cohort_in%bl/(cohort_in%c_area/cohort_in%n) !KgC/m2 + if(leafc_per_unitarea > 0.0_r8)then + tree_lai = leafc_per_unitarea * slat !kg/m2 * m2/kg = unitless LAI + else + tree_lai = 0.0_r8 + endif + else + tree_lai = 0.0_r8 + endif !status + cohort_in%treelai = tree_lai + + ! here, if the LAI exceeeds the maximum size of the possible array, then we have no way of accomodating it + ! at the moments nlevleaf default is 40, which is very large, so exceeding this would clearly illustrate a + ! huge error + if(cohort_in%treelai > nlevleaf*dinc_ed)then + write(fates_log(),*) 'too much lai' , cohort_in%treelai , cohort_in%pft , nlevleaf * dinc_ed + endif + + return + + end function tree_lai + + ! ============================================================================ + + real(r8) function tree_sai( cohort_in ) + + ! ============================================================================ + ! SAI of individual trees is a function of the total dead biomass per unit canopy area. + ! ============================================================================ + + type(ed_cohort_type), intent(inout) :: cohort_in + + real(r8) :: bdead_per_unitarea ! KgC of leaf per m2 area of ground. + real(r8) :: sai_scaler + + sai_scaler = EDPftvarcon_inst%sai_scaler(cohort_in%pft) + + if( cohort_in%bdead < 0._r8 .or. cohort_in%pft == 0 ) then + write(fates_log(),*) 'problem in treesai',cohort_in%bdead,cohort_in%pft + endif + + cohort_in%c_area = c_area(cohort_in) ! call the tree area + bdead_per_unitarea = cohort_in%bdead/(cohort_in%c_area/cohort_in%n) !KgC/m2 + tree_sai = bdead_per_unitarea * sai_scaler !kg/m2 * m2/kg = unitless LAI + + cohort_in%treesai = tree_sai + + ! here, if the LAI exceeeds the maximum size of the possible array, then we have no way of accomodating it + ! at the moments nlevleaf default is 40, which is very large, so exceeding this would clearly illustrate a + ! huge error + if(cohort_in%treesai > nlevleaf*dinc_ed)then + write(fates_log(),*) 'too much sai' , cohort_in%treesai , cohort_in%pft , nlevleaf * dinc_ed + endif + + return + + end function tree_sai + + +! ============================================================================ + + real(r8) function c_area( cohort_in ) + + ! ============================================================================ + ! Calculate area of ground covered by entire cohort. (m2) + ! Function of DBH (cm) canopy spread (m/cm) and number of individuals. + ! ============================================================================ + + use EDParamsMod , only : ED_val_grass_spread + + type(ed_cohort_type), intent(in) :: cohort_in + + real(r8) :: dbh ! Tree diameter at breat height. cm. + real(r8) :: crown_area_to_dbh_exponent + + ! 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 dbh2bl_dbh2carea_expnt_diff term (which has default value of zero) + crown_area_to_dbh_exponent = EDPftvarcon_inst%dbh2bl_b(cohort_in%pft) + & + EDPftvarcon_inst%dbh2bl_dbh2carea_expnt_diff(cohort_in%pft) + + if (DEBUG_growth) then + write(fates_log(),*) 'z_area 1',cohort_in%dbh,cohort_in%pft + write(fates_log(),*) 'z_area 2',EDPftvarcon_inst%max_dbh + write(fates_log(),*) 'z_area 3',EDPftvarcon_inst%woody + write(fates_log(),*) 'z_area 4',cohort_in%n + write(fates_log(),*) 'z_area 5',cohort_in%patchptr%spread + write(fates_log(),*) 'z_area 6',cohort_in%canopy_layer + write(fates_log(),*) 'z_area 7',ED_val_grass_spread + end if + + dbh = min(cohort_in%dbh,EDPftvarcon_inst%max_dbh(cohort_in%pft)) + if(EDPftvarcon_inst%woody(cohort_in%pft) == 1)then + c_area = 3.142_r8 * cohort_in%n * & + (cohort_in%patchptr%spread(cohort_in%canopy_layer)*dbh)**crown_area_to_dbh_exponent + else + c_area = 3.142_r8 * cohort_in%n * (ED_val_grass_spread*dbh)**crown_area_to_dbh_exponent + end if + + end function c_area + +! ============================================================================ + + real(r8) function Bdead( cohort_in ) + + ! ============================================================================ + ! Calculate stem biomass from height(m) dbh(cm) and wood density(g/cm3) + ! default params using allometry of J.G. Saldarriaga et al 1988 - Rio Negro + ! Journal of Ecology vol 76 p938-958 + ! ============================================================================ + + type(ed_cohort_type), intent(in) :: cohort_in + + real(r8) :: dbh2bd_a + real(r8) :: dbh2bd_b + real(r8) :: dbh2bd_c + real(r8) :: dbh2bd_d + + dbh2bd_a = EDPftvarcon_inst%dbh2bd_a(cohort_in%pft) + dbh2bd_b = EDPftvarcon_inst%dbh2bd_b(cohort_in%pft) + dbh2bd_c = EDPftvarcon_inst%dbh2bd_c(cohort_in%pft) + dbh2bd_d = EDPftvarcon_inst%dbh2bd_d(cohort_in%pft) + + bdead = dbh2bd_a*(cohort_in%hite**dbh2bd_b)*(cohort_in%dbh**dbh2bd_c)* & + (EDPftvarcon_inst%wood_density(cohort_in%pft)** dbh2bd_d) + + end function Bdead + +! ============================================================================ + + real(r8) function dHdBd( cohort_in ) + + ! ============================================================================ + ! convert changes in structural biomass to changes in height + ! consistent with Bstem and h-dbh allometries + ! ============================================================================ + + type(ed_cohort_type), intent(in) :: cohort_in + + real(r8) :: dbddh ! rate of change of dead biomass (KgC) per unit change of height (m) + real(r8) :: dbh2bd_a + real(r8) :: dbh2bd_b + real(r8) :: dbh2bd_c + real(r8) :: dbh2bd_d + + dbh2bd_a = EDPftvarcon_inst%dbh2bd_a(cohort_in%pft) + dbh2bd_b = EDPftvarcon_inst%dbh2bd_b(cohort_in%pft) + dbh2bd_c = EDPftvarcon_inst%dbh2bd_c(cohort_in%pft) + dbh2bd_d = EDPftvarcon_inst%dbh2bd_d(cohort_in%pft) + + dbddh = dbh2bd_a*dbh2bd_b*(cohort_in%hite**(dbh2bd_b-1.0_r8))*(cohort_in%dbh**dbh2bd_c)* & + (EDPftvarcon_inst%wood_density(cohort_in%pft)**dbh2bd_d) + dHdBd = 1.0_r8/dbddh !m/KgC + + return + + end function dHdBd + +! ============================================================================ + real(r8) function dDbhdBd( cohort_in ) + + ! ============================================================================ + ! convert changes in structural biomass to changes in diameter + ! consistent with Bstem and h-dbh allometries + ! ============================================================================ + + type(ed_cohort_type), intent(in) :: cohort_in + + real(r8) :: dBD_dDBH !Rate of change of dead biomass (KgC) with change in DBH (cm) + real(r8) :: dH_dDBH !Rate of change of height (m) with change in DBH (cm) + real(r8) :: m + real(r8) :: c + real(r8) :: h + real(r8) :: dbh2bd_a + real(r8) :: dbh2bd_b + real(r8) :: dbh2bd_c + real(r8) :: dbh2bd_d + + m = EDPftvarcon_inst%dbh2h_m(cohort_in%pft) + c = EDPftvarcon_inst%dbh2h_c(cohort_in%pft) + + dbh2bd_a = EDPftvarcon_inst%dbh2bd_a(cohort_in%pft) + dbh2bd_b = EDPftvarcon_inst%dbh2bd_b(cohort_in%pft) + dbh2bd_c = EDPftvarcon_inst%dbh2bd_c(cohort_in%pft) + dbh2bd_d = EDPftvarcon_inst%dbh2bd_d(cohort_in%pft) + + dBD_dDBH = dbh2bd_c*dbh2bd_a*(cohort_in%hite**dbh2bd_b)*(cohort_in%dbh**(dbh2bd_c-1.0_r8))* & + (EDPftvarcon_inst%wood_density(cohort_in%pft)**dbh2bd_d) + + if(cohort_in%dbh < EDPftvarcon_inst%max_dbh(cohort_in%pft))then + dH_dDBH = (10.0_r8**c)*m*(cohort_in%dbh**(m-1.0_r8)) + + dBD_dDBH = dBD_dDBH + dbh2bd_b*dbh2bd_a*(cohort_in%hite**(dbh2bd_b - 1.0_r8))* & + (cohort_in%dbh**dbh2bd_c)*(EDPftvarcon_inst%wood_density(cohort_in%pft)**dbh2bd_d)*dH_dDBH + endif + + dDbhdBd = 1.0_r8/dBD_dDBH + + return + + end function dDbhdBd + +! ============================================================================ + + real(r8) function dDbhdBl( cohort_in ) + + ! ============================================================================ + ! convert changes in leaf biomass (KgC) to changes in DBH (cm) + ! ============================================================================ + + type(ed_cohort_type), intent(in) :: cohort_in + + real(r8) :: dblddbh ! Rate of change of leaf biomass with change in DBH + real(r8) :: dbh2bl_a + real(r8) :: dbh2bl_b + real(r8) :: dbh2bl_c + + dbh2bl_a = EDPftvarcon_inst%dbh2bl_a(cohort_in%pft) + dbh2bl_b = EDPftvarcon_inst%dbh2bl_b(cohort_in%pft) + dbh2bl_c = EDPftvarcon_inst%dbh2bl_c(cohort_in%pft) + dblddbh = dbh2bl_b*dbh2bl_a*(cohort_in%dbh**dbh2bl_b)*(EDPftvarcon_inst%wood_density(cohort_in%pft)**dbh2bl_c) + dblddbh = dblddbh*cohort_in%canopy_trim + + if( cohort_in%dbh 0._r8 ) then + if(Bleaf(cohort_in) > 0._r8 .and. cohort_in%bstore <= Bleaf(cohort_in))then + frac = cohort_in%bstore/(Bleaf(cohort_in)) + cmort = max(0.0_r8,ED_val_stress_mort*(1.0_r8 - frac)) + else + cmort = 0.0_r8 + endif + + else + write(fates_log(),*) 'dbh problem in mortality_rates', & + cohort_in%dbh,cohort_in%pft,cohort_in%n,cohort_in%canopy_layer + endif + + !mortality_rates = bmort + hmort + cmort + + end subroutine mortality_rates + +! ============================================================================ + +end module EDGrowthFunctionsMod diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 new file mode 100644 index 00000000..f9896ba1 --- /dev/null +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -0,0 +1,1599 @@ +module EDPatchDynamicsMod + + ! ============================================================================ + ! Controls formation, creation, fusing and termination of patch level processes. + ! ============================================================================ + use FatesGlobals , only : fates_log + use FatesInterfaceMod , only : hlm_freq_day + use EDPftvarcon , only : EDPftvarcon_inst + use EDCohortDynamicsMod , only : fuse_cohorts, sort_cohorts, insert_cohort + use EDtypesMod , only : ncwd, n_dbh_bins, ntol, area, dbhmax + use EDTypesMod , only : numpft_ed + use EDTypesMod , only : maxPatchesPerSite + use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type + use EDTypesMod , only : min_patch_area + use EDTypesMod , only : nclmax + use EDTypesMod , only : use_fates_plant_hydro + use FatesInterfaceMod , only : hlm_numlevgrnd + use FatesInterfaceMod , only : hlm_numlevsoil + use FatesInterfaceMod , only : hlm_numSWb + use FatesInterfaceMod , only : bc_in_type + use FatesInterfaceMod , only : hlm_days_per_year + use FatesGlobals , only : endrun => fates_endrun + use FatesConstantsMod , only : r8 => fates_r8 + use FatesPlantHydraulicsMod, only : InitHydrCohort + use FatesPlantHydraulicsMod, only : DeallocateHydrCohort + + ! CIME globals + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + + ! + implicit none + private + ! + public :: create_patch + public :: spawn_patches + public :: zero_patch + public :: fuse_patches + public :: terminate_patches + public :: patch_pft_size_profile + public :: disturbance_rates + public :: check_patch_area + public :: set_patchno + public :: set_root_fraction + private:: fuse_2_patches + + + ! 10/30/09: Created by Rosie Fisher + ! ============================================================================ + +contains + + ! ============================================================================ + subroutine disturbance_rates( site_in) + ! + ! !DESCRIPTION: + ! Calculates the fire and mortality related disturbance rates for each patch, + ! and then determines which is the larger at the patch scale (for now, there an only + ! be one disturbance type for each timestep. + ! all disturbance rates here are per daily timestep. + ! + ! !USES: + use EDGrowthFunctionsMod , only : c_area, mortality_rates + ! + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: site_in + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type), pointer :: currentCohort + real(r8) :: cmort + real(r8) :: bmort + real(r8) :: hmort + !--------------------------------------------------------------------- + + !MORTALITY + site_in%disturbance_mortality = 0.0_r8 + + currentPatch => site_in%oldest_patch + + do while (associated(currentPatch)) + + currentCohort => currentPatch%shortest + + do while(associated(currentCohort)) + ! Mortality for trees in the understorey. + currentCohort%patchptr => currentPatch + + call mortality_rates(currentCohort,cmort,hmort,bmort) + currentCohort%dmort = cmort+hmort+bmort + currentCohort%c_area = c_area(currentCohort) + + ! Initialize diagnostic mortality rates + currentCohort%cmort = cmort + currentCohort%bmort = bmort + currentCohort%hmort = hmort + currentCohort%imort = 0.0_r8 ! Impact mortality is always zero except in new patches + currentCohort%fmort = 0.0_r8 ! Fire mortality is initialized as zero, but may be changed + + if(currentCohort%canopy_layer == 1)then + + currentPatch%disturbance_rates(1) = currentPatch%disturbance_rates(1) + & + min(1.0_r8,currentCohort%dmort)*hlm_freq_day*currentCohort%c_area/currentPatch%area + + endif + + currentCohort => currentCohort%taller + + enddo !currentCohort + + ! if fires occur at site + ! Fudge - fires can't burn the whole patch, as this causes /0 errors. + ! This is accumulating the daily fires over the whole 30 day patch generation phase. + currentPatch%disturbance_rates(2) = min(0.99_r8,currentPatch%disturbance_rates(2) + currentPatch%frac_burnt) + + if (currentPatch%disturbance_rates(2) > 0.98_r8)then + write(fates_log(),*) 'very high fire areas',currentPatch%disturbance_rates(2),currentPatch%frac_burnt + endif + + !Only use larger of two natural disturbance modes WHY? + if(currentPatch%disturbance_rates(2) > currentPatch%disturbance_rates(1))then ! DISTURBANCE IS FIRE + currentPatch%disturbance_rate = currentPatch%disturbance_rates(2) + + ! RGK 02-18-2014 + ! Since treefall mortality is not actually being applied + ! Go through and zero the diagnostic rates + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + if(currentCohort%canopy_layer == 1)then + currentCohort%cmort=0.0_r8 + currentCohort%hmort=0.0_r8 + currentCohort%bmort=0.0_r8 + end if + + ! This may be counter-intuitive, but the diagnostic fire-mortality rate + ! will stay zero in the patch that undergoes fire, this is because + ! the actual cohorts who experience the fire are only those in the + ! newly created patch so currentCohort%fmort = 0.0_r8 + ! Don't worry, the cohorts in the newly created patch will reflect burn + + currentCohort => currentCohort%taller + enddo !currentCohort + + else + currentPatch%disturbance_rate = currentPatch%disturbance_rates(1) ! DISTURBANCE IS MORTALITY + endif + + site_in%disturbance_mortality = site_in%disturbance_mortality + & + currentPatch%disturbance_rates(1)*currentPatch%area/area + currentPatch => currentPatch%younger + + enddo !patch loop + + ! FIRE + site_in%disturbance_fire = site_in%frac_burnt/AREA + + ! Use largest disturbance mode and ignore the other... This is necessary to + ! have a single type of disturbance and to calculate the survival rates etc... + if (site_in%disturbance_fire > site_in%disturbance_mortality) then + site_in%disturbance_rate = site_in%disturbance_fire + site_in%dist_type = 2 + else + site_in%disturbance_rate = site_in%disturbance_mortality + site_in%dist_type = 1 + endif + + end subroutine disturbance_rates + + ! ============================================================================ + subroutine spawn_patches( currentSite, bc_in) + ! + ! !DESCRIPTION: + ! In this subroutine, the following happens + ! 1) the total area disturbed is calculated + ! 2) a new patch is created + ! 3) properties are averaged + ! 4) litter fluxes from fire and mortality are added + ! 5) For mortality, plants in existing patch canopy are killed. + ! 6) For mortality, Plants in new and existing understorey are killed + ! 7) For fire, burned plants are killed, and unburned plants are added to new patch. + ! 8) New cohorts are added to new patch and sorted. + ! 9) New patch is added into linked list + ! 10) Area checked, and patchno recalculated. + ! + ! !USES: + + use EDParamsMod , only : ED_val_maxspread, ED_val_understorey_death + use EDCohortDynamicsMod , only : zero_cohort, copy_cohort, terminate_cohorts + + ! + ! !ARGUMENTS: + type (ed_site_type), intent(inout), target :: currentSite + type (bc_in_type), intent(in) :: bc_in + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: new_patch + 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 + real(r8) :: site_areadis ! total area disturbed in m2 per site per day + real(r8) :: patch_site_areadis ! total area disturbed in m2 per patch per day + real(r8) :: age ! notional age of this patch in years + integer :: tnull ! is there a tallest cohort? + integer :: snull ! is there a shortest cohort? + real(r8) :: root_litter_local(numpft_ed) ! initial value of root litter. KgC/m2 + real(r8) :: leaf_litter_local(numpft_ed) ! initial value of leaf litter. KgC/m2 + real(r8) :: cwd_ag_local(ncwd) ! initial value of above ground coarse woody debris. KgC/m2 + real(r8) :: cwd_bg_local(ncwd) ! initial value of below ground coarse woody debris. KgC/m2 + real(r8) :: spread_local(nclmax) ! initial value of canopy spread parameter.no units + !--------------------------------------------------------------------- + + storesmallcohort => null() ! storage of the smallest cohort for insertion routine + storebigcohort => null() ! storage of the largest cohort for insertion routine + + ! calculate area of disturbed land, in this timestep, by summing contributions from each existing patch. + currentPatch => currentSite%youngest_patch + + ! zero site-level fire fluxes + currentSite%cwd_ag_burned = 0.0_r8 + currentSite%leaf_litter_burned = 0.0_r8 + currentSite%total_burn_flux_to_atm = 0.0_r8 + + site_areadis = 0.0_r8 + do while(associated(currentPatch)) + + !FIX(RF,032414) Does using the max(fire,mort) actually make sense here? + site_areadis = site_areadis + currentPatch%area * min(1.0_r8,currentPatch%disturbance_rate) + currentPatch => currentPatch%older + + enddo ! end loop over patches. sum area disturbed for all patches. + + if (site_areadis > 0.0_r8) then + cwd_ag_local = 0.0_r8 + cwd_bg_local = 0.0_r8 + leaf_litter_local = 0.0_r8 + root_litter_local = 0.0_r8 + spread_local(1:nclmax) = ED_val_maxspread + age = 0.0_r8 + + allocate(new_patch) + +! This is called inside "create_patch" +! create_patch must first allocate some vector spaces before +! zero'ing can occur (RGK) +! call zero_patch(new_patch) + + call create_patch(currentSite, new_patch, age, site_areadis, & + spread_local, cwd_ag_local, cwd_bg_local, leaf_litter_local, & + root_litter_local) + + new_patch%tallest => null() + new_patch%shortest => null() + + currentPatch => currentSite%oldest_patch + ! loop round all the patches that contribute surviving indivduals and litter pools to the new patch. + do while(associated(currentPatch)) + patch_site_areadis = currentPatch%area * currentPatch%disturbance_rate ! how much land is disturbed in this donor patch? + + call average_patch_properties(currentPatch, new_patch, patch_site_areadis) ! MAY BE REDUNDANT CALL + if (currentSite%disturbance_mortality > currentSite%disturbance_fire) then !mortality is dominant disturbance + call mortality_litter_fluxes(currentSite, currentPatch, new_patch, patch_site_areadis) + else + call fire_litter_fluxes(currentSite, currentPatch, new_patch, patch_site_areadis) + endif + + !INSERT SURVIVORS FROM DISTURBANCE INTO NEW PATCH + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + + allocate(nc) + if(use_fates_plant_hydro) call InitHydrCohort(nc) + call zero_cohort(nc) + + ! nc is the new cohort that goes in the disturbed patch (new_patch)... currentCohort + ! is the curent cohort that stays in the donor patch (currentPatch) + call copy_cohort(currentCohort, nc) + + !this is the case as the new patch probably doesn't have a closed canopy, and + ! even if it does, that will be sorted out in canopy_structure. + nc%canopy_layer = 1 + nc%canopy_layer_yesterday = 1._r8 + + !mortality is dominant disturbance + if(currentPatch%disturbance_rates(1) > currentPatch%disturbance_rates(2))then + if(currentCohort%canopy_layer == 1)then + ! In the donor patch we are left with fewer trees because the area has decreased + ! the plant density for large trees does not actually decrease in the donor patch + ! because this is the part of the original patch where no trees have actually fallen + ! The diagnostic cmort,bmort and hmort rates have already been saved + + currentCohort%n = currentCohort%n * (1.0_r8 - min(1.0_r8,currentCohort%dmort * hlm_freq_day)) + + nc%n = 0.0_r8 ! kill all of the trees who caused the disturbance. + nc%cmort = nan ! The mortality diagnostics are set to nan because the cohort should dissappear + nc%hmort = nan + nc%bmort = nan + nc%fmort = nan + nc%imort = nan + else + ! small trees + if(EDPftvarcon_inst%woody(currentCohort%pft) == 1)then + + ! Number of trees in the understory of new patch, before we impose impact mortality and survivorship + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + + ! remaining of understory plants of those that are knocked over by the overstorey trees dying... + nc%n = (1.0_r8 - ED_val_understorey_death) * currentCohort%n * patch_site_areadis/currentPatch%area + + ! since the donor patch split and sent a fraction of its members + ! to the new patch and a fraction to be preserved in itself, + ! when reporting diagnostic rates, we must carry over the mortality rates from + ! the donor that were applied before the patch split. Remember this is only + ! for diagnostics. But think of it this way, the rates are weighted by + ! number density in EDCLMLink, and the number density of this new patch is donated + ! so with the number density must come the effective mortality rates. + + nc%fmort = 0.0_r8 ! Should had also been zero in the donor + nc%imort = ED_val_understorey_death/hlm_freq_day ! This was zero in the donor + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + + ! understory trees that might potentially be knocked over in the disturbance. + ! The existing (donor) patch should not have any impact mortality, it should + ! only lose cohorts due to the decrease in area. This is not mortality. + ! Besides, the current and newly created patch sum to unity + + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + else + ! grass is not killed by mortality disturbance events. Just move it into the new patch area. + ! Just split the grass into the existing and new patch structures + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + + ! Those remaining in the existing + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + + nc%fmort = nan ! These should not make it to the diagnostics + nc%imort = nan ! If they do.. they should invalidate it + nc%cmort = nan ! + nc%hmort = nan ! + nc%bmort = nan ! + + endif + endif + else !fire + + ! Number of members in the new patch, before we impose fire survivorship + nc%n = currentCohort%n * patch_site_areadis/currentPatch%area + + ! loss of individuals from source patch due to area shrinking + currentCohort%n = currentCohort%n * (1._r8 - patch_site_areadis/currentPatch%area) + + ! loss of individual from fire in new patch. + nc%n = nc%n * (1.0_r8 - currentCohort%fire_mort) + + nc%fmort = currentCohort%fire_mort/hlm_freq_day + nc%imort = 0.0_r8 + nc%cmort = currentCohort%cmort + nc%hmort = currentCohort%hmort + nc%bmort = currentCohort%bmort + + endif + + if (nc%n > 0.0_r8) then + storebigcohort => new_patch%tallest + storesmallcohort => new_patch%shortest + if(associated(new_patch%tallest))then + tnull = 0 + else + tnull = 1 + new_patch%tallest => nc + nc%taller => null() + endif + + if(associated(new_patch%shortest))then + snull = 0 + else + snull = 1 + new_patch%shortest => nc + nc%shorter => null() + endif + nc%patchptr => new_patch + call insert_cohort(nc, new_patch%tallest, new_patch%shortest, tnull, snull, storebigcohort, storesmallcohort) + + new_patch%tallest => storebigcohort + new_patch%shortest => storesmallcohort + else + if(use_fates_plant_hydro) call DeallocateHydrCohort(nc) + deallocate(nc) !get rid of the new memory. + endif + + currentCohort => currentCohort%taller + enddo ! currentCohort + call sort_cohorts(currentPatch) + + !zero disturbance accumulators + currentPatch%disturbance_rate = 0._r8 + currentPatch%disturbance_rates = 0._r8 + + !update area of donor patch + currentPatch%area = currentPatch%area - patch_site_areadis + + !sort out the cohorts, since some of them may be so small as to need removing. + + call fuse_cohorts(currentPatch, bc_in) + call terminate_cohorts(currentSite, currentPatch) + call sort_cohorts(currentPatch) + + currentPatch => currentPatch%younger + + enddo ! currentPatch patch loop. + + !*************************/ + !** INSERT NEW PATCH INTO LINKED LIST + !**********`***************/ + currentPatch => currentSite%youngest_patch + new_patch%older => currentPatch + new_patch%younger => NULL() + currentPatch%younger => new_patch + currentSite%youngest_patch => new_patch + + call fuse_cohorts(new_patch, bc_in) + call terminate_cohorts(currentSite, new_patch) + call sort_cohorts(new_patch) + + endif !end new_patch area + + call check_patch_area(currentSite) + call set_patchno(currentSite) + + end subroutine spawn_patches + + ! ============================================================================ + subroutine check_patch_area( currentSite ) + ! + ! !DESCRIPTION: + ! Check to see that total area is not exceeded. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_site_type), intent(in), target :: currentSite + ! + ! !LOCAL VARIABLES: + real(r8) :: areatot + type(ed_patch_type), pointer :: currentPatch + !--------------------------------------------------------------------- + + areatot = 0._r8 + currentPatch => currentSite%oldest_patch + do while(associated(currentPatch)) + areatot = areatot + currentPatch%area + currentPatch => currentPatch%younger + if (( areatot - area ) > 0._r8 ) then + write(fates_log(),*) 'trimming patch area - is too big' , areatot-area + currentSite%oldest_patch%area = currentSite%oldest_patch%area - (areatot - area) + endif + enddo + + end subroutine check_patch_area + + ! ============================================================================ + subroutine set_patchno( currentSite ) + ! + ! !DESCRIPTION: + ! Give patches an order number from the oldest to youngest. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_site_type),intent(in), target :: currentSite + ! + ! !LOCAL VARIABLES: + type(ed_patch_type), pointer :: currentPatch + integer patchno + !--------------------------------------------------------------------- + + patchno = 1 + currentPatch => currentSite%oldest_patch + do while(associated(currentPatch)) + currentPatch%patchno = patchno + patchno = patchno + 1 + currentPatch => currentPatch%younger + enddo + + end subroutine set_patchno + + ! ============================================================================ + subroutine average_patch_properties( currentPatch, newPatch, patch_site_areadis ) + ! + ! !DESCRIPTION: + ! Average together the state properties of all of the donor patches that + ! make up the new patch. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_patch_type) , intent(in), target :: currentPatch + type(ed_patch_type) , intent(inout) :: newPatch + real(r8) , intent(out) :: patch_site_areadis ! amount of land disturbed in this patch. m2 + ! + ! !LOCAL VARIABLES: + integer :: c,p ! counters for PFT and litter size class. + !--------------------------------------------------------------------- + + patch_site_areadis = currentPatch%area * currentPatch%disturbance_rate ! how much land is disturbed in this donor patch? + + do c = 1,ncwd !move litter pool en mass into the new patch. + newPatch%cwd_ag(c) = newPatch%cwd_ag(c) + currentPatch%cwd_ag(c) * patch_site_areadis/newPatch%area + newPatch%cwd_bg(c) = newPatch%cwd_bg(c) + currentPatch%cwd_bg(c) * patch_site_areadis/newPatch%area + enddo + + do p = 1,numpft_ed !move litter pool en mass into the new patch + newPatch%root_litter(p) = newPatch%root_litter(p) + currentPatch%root_litter(p) * patch_site_areadis/newPatch%area + newPatch%leaf_litter(p) = newPatch%leaf_litter(p) + currentPatch%leaf_litter(p) * patch_site_areadis/newPatch%area + enddo + + newPatch%spread = newPatch%spread + currentPatch%spread * patch_site_areadis/newPatch%area + + end subroutine average_patch_properties + + ! ============================================================================ + subroutine fire_litter_fluxes(currentSite, cp_target, new_patch_target, patch_site_areadis) + ! + ! !DESCRIPTION: + ! CWD pool burned by a fire. + ! Carbon going from burned trees into CWD pool + ! Burn parts of trees that don't die in fire + ! Burn live grasses and kill them. + ! + ! !USES: + use EDParamsMod, only : ED_val_ag_biomass + use SFParamsMod, only : SF_VAL_CWD_FRAC + use EDGrowthFunctionsMod, only : c_area + use EDtypesMod , only : dl_sf + ! + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + type(ed_patch_type) , intent(inout), target :: cp_target + type(ed_patch_type) , intent(inout), target :: new_patch_target + real(r8) , intent(inout) :: patch_site_areadis + ! + ! !LOCAL VARIABLES: + type(ed_patch_type) , pointer :: currentPatch + type(ed_patch_type) , pointer :: new_patch + type(ed_cohort_type), pointer :: currentCohort + real(r8) :: bcroot ! amount of below ground coarse root per cohort kgC. (goes into CWD_BG) + real(r8) :: bstem ! amount of above ground stem biomass per cohort kgC.(goes into CWG_AG) + real(r8) :: dead_tree_density ! no trees killed by fire per m2 + reaL(r8) :: burned_litter ! amount of each litter pool burned by fire. kgC/m2/day + real(r8) :: burned_leaves ! amount of tissue consumed by fire for grass. KgC/individual/day + integer :: c, p + !--------------------------------------------------------------------- + + !check that total area is not exceeded. + currentPatch => cp_target + new_patch => new_patch_target + + if ( currentPatch%fire == 1 ) then !only do this if there was a fire in this actual patch. + patch_site_areadis = currentPatch%area * currentPatch%disturbance_rate ! how much land is disturbed in this donor patch? + + !************************************/ + !PART 1) Burn the fractions of existing litter in the new patch that were consumed by the fire. + !************************************/ + do c = 1,ncwd + burned_litter = new_patch%cwd_ag(c) * patch_site_areadis/new_patch%area * currentPatch%burnt_frac_litter(c+1) !kG/m2/day + new_patch%cwd_ag(c) = new_patch%cwd_ag(c) - burned_litter + currentSite%flux_out = currentSite%flux_out + burned_litter * new_patch%area !kG/site/day + currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm + burned_litter * new_patch%area !kG/site/day + enddo + + do p = 1,numpft_ed + burned_litter = new_patch%leaf_litter(p) * patch_site_areadis/new_patch%area * currentPatch%burnt_frac_litter(dl_sf) + new_patch%leaf_litter(p) = new_patch%leaf_litter(p) - burned_litter + currentSite%flux_out = currentSite%flux_out + burned_litter * new_patch%area !kG/site/day + currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm + burned_litter * new_patch%area !kG/site/day + enddo + + !************************************/ + !PART 2) Put unburned parts of plants that died in the fire into the litter pool of new and old patches + ! This happens BEFORE the plant numbers have been updated. So we are working with the + ! pre-fire population of plants, which is the right way round. + !************************************/ + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + p = currentCohort%pft + if(EDPftvarcon_inst%woody(p) == 1)then !DEAD (FROM FIRE) TREES + !************************************/ + ! Number of trees that died because of the fire, per m2 of ground. + ! Divide their litter into the four litter streams, and spread evenly across ground surface. + !************************************/ + ! stem biomass per tree + bstem = (currentCohort%bsw + currentCohort%bdead) * ED_val_ag_biomass + ! coarse root biomass per tree + bcroot = (currentCohort%bsw + currentCohort%bdead) * (1.0_r8 - ED_val_ag_biomass) + ! density of dead trees per m2. + dead_tree_density = (currentCohort%fire_mort * currentCohort%n*patch_site_areadis/currentPatch%area) / AREA + + ! Unburned parts of dead tree pool. + ! Unburned leaves and roots + + new_patch%leaf_litter(p) = new_patch%leaf_litter(p) + dead_tree_density * (currentCohort%bl) & + * (1.0_r8-currentCohort%cfa) + new_patch%root_litter(p) = new_patch%root_litter(p) + dead_tree_density * (currentCohort%br+currentCohort%bstore) + currentPatch%leaf_litter(p) = currentPatch%leaf_litter(p) + dead_tree_density * & + (currentCohort%bl) * (1.0_r8-currentCohort%cfa) + currentPatch%root_litter(p) = currentPatch%root_litter(p) + dead_tree_density * & + (currentCohort%br+currentCohort%bstore) + + ! track as diagnostic fluxes + currentSite%leaf_litter_diagnostic_input_carbonflux(p) = currentSite%leaf_litter_diagnostic_input_carbonflux(p) + & + (currentCohort%bl) * (1.0_r8-currentCohort%cfa) * currentCohort%fire_mort * currentCohort%n * & + hlm_days_per_year / AREA + currentSite%root_litter_diagnostic_input_carbonflux(p) = currentSite%root_litter_diagnostic_input_carbonflux(p) + & + (currentCohort%br+currentCohort%bstore) * (1.0_r8-currentCohort%cfa) * currentCohort%fire_mort * & + currentCohort%n * hlm_days_per_year / AREA + + ! below ground coarse woody debris from burned trees + do c = 1,ncwd + new_patch%cwd_bg(c) = new_patch%cwd_bg(c) + dead_tree_density * SF_val_CWD_frac(c) * bcroot + currentPatch%cwd_bg(c) = currentPatch%cwd_bg(c) + dead_tree_density * SF_val_CWD_frac(c) * bcroot + + ! track as diagnostic fluxes + currentSite%CWD_BG_diagnostic_input_carbonflux(c) = currentSite%CWD_BG_diagnostic_input_carbonflux(c) + & + SF_val_CWD_frac(c) * bcroot * currentCohort%fire_mort * currentCohort%n * & + hlm_days_per_year / AREA + enddo + + ! above ground coarse woody debris from unburned twigs and small branches + do c = 1,2 + new_patch%cwd_ag(c) = new_patch%cwd_ag(c) + dead_tree_density * SF_val_CWD_frac(c) * bstem & + * (1.0_r8-currentCohort%cfa) + currentPatch%cwd_ag(c) = currentPatch%cwd_ag(c) + dead_tree_density * SF_val_CWD_frac(c) * & + bstem * (1.0_r8-currentCohort%cfa) + + ! track as diagnostic fluxes + currentSite%CWD_AG_diagnostic_input_carbonflux(c) = currentSite%CWD_AG_diagnostic_input_carbonflux(c) + & + SF_val_CWD_frac(c) * bstem * (1.0_r8-currentCohort%cfa) * currentCohort%fire_mort * currentCohort%n * & + hlm_days_per_year / AREA + enddo + + ! above ground coarse woody debris from large branches and stems: these do not burn in crown fires. + do c = 3,4 + new_patch%cwd_ag(c) = new_patch%cwd_ag(c) + dead_tree_density * SF_val_CWD_frac(c) * bstem + currentPatch%cwd_ag(c) = currentPatch%cwd_ag(c) + dead_tree_density * SF_val_CWD_frac(c) * bstem + + ! track as diagnostic fluxes + currentSite%CWD_AG_diagnostic_input_carbonflux(c) = currentSite%CWD_AG_diagnostic_input_carbonflux(c) + & + SF_val_CWD_frac(c) * bstem * currentCohort%fire_mort * currentCohort%n * & + hlm_days_per_year / AREA + enddo + + ! Burned parts of dead tree pool. + ! Burned twigs and small branches. + do c = 1,2 + + currentSite%cwd_ag_burned(c) = currentSite%cwd_ag_burned(c) + dead_tree_density * & + SF_val_CWD_frac(c) * bstem * currentCohort%cfa + currentSite%flux_out = currentSite%flux_out + dead_tree_density * & + AREA * SF_val_CWD_frac(c) * bstem * currentCohort%cfa + currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm + dead_tree_density * & + AREA * SF_val_CWD_frac(c) * bstem * currentCohort%cfa + + enddo + + !burned leaves. + do p = 1,numpft_ed + + currentSite%leaf_litter_burned(p) = currentSite%leaf_litter_burned(p) + & + dead_tree_density * currentCohort%bl * currentCohort%cfa + currentSite%flux_out = currentSite%flux_out + & + dead_tree_density * AREA * currentCohort%bl * currentCohort%cfa + currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm + & + dead_tree_density * AREA * currentCohort%bl * currentCohort%cfa + + enddo + + endif + + currentCohort => currentCohort%taller + + enddo ! currentCohort + + !************************************/ + ! PART 3) Burn parts of trees that did *not* die in the fire. + ! PART 4) Burn parts of grass that are consumed by the fire. + ! grasses are not killed directly by fire. They die by losing all of their leaves and starving. + !************************************/ + currentCohort => new_patch%shortest + do while(associated(currentCohort)) + + currentCohort%c_area = c_area(currentCohort) + if(EDPftvarcon_inst%woody(currentCohort%pft) == 1)then + burned_leaves = (currentCohort%bl+currentCohort%bsw) * currentCohort%cfa + else + burned_leaves = (currentCohort%bl+currentCohort%bsw) * currentPatch%burnt_frac_litter(6) + endif + if (burned_leaves > 0.0_r8) then + + currentCohort%balive = max(currentCohort%br,currentCohort%balive - burned_leaves) + currentCohort%bl = max(0.00001_r8, currentCohort%bl - burned_leaves) + !KgC/gridcell/day + currentSite%flux_out = currentSite%flux_out + burned_leaves * currentCohort%n * & + patch_site_areadis/currentPatch%area * AREA + currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm+ burned_leaves * currentCohort%n * & + patch_site_areadis/currentPatch%area * AREA + + endif + currentCohort%cfa = 0.0_r8 + + currentCohort => currentCohort%taller + + enddo + + endif !currentPatch%fire. + + end subroutine fire_litter_fluxes + + ! ============================================================================ + subroutine mortality_litter_fluxes(currentSite, cp_target, new_patch_target, patch_site_areadis) + ! + ! !DESCRIPTION: + ! Carbon going from ongoing mortality into CWD pools. + ! + ! !USES: + use EDParamsMod, only : ED_val_ag_biomass, ED_val_understorey_death + use SFParamsMod, only : SF_val_cwd_frac + ! + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + type(ed_patch_type) , intent(inout), target :: cp_target + type(ed_patch_type) , intent(inout), target :: new_patch_target + real(r8) , intent(in) :: patch_site_areadis + ! + ! !LOCAL VARIABLES: + real(r8) :: cwd_litter_density + real(r8) :: litter_area ! area over which to distribute this litter. + type(ed_cohort_type), pointer :: currentCohort + type(ed_patch_type) , pointer :: currentPatch + type(ed_patch_type) , pointer :: new_patch + real(r8) :: understorey_dead !Number of individual dead from the canopy layer /day + real(r8) :: canopy_dead !Number of individual dead from the understorey layer /day + real(r8) :: np_mult !Fraction of the new patch which came from the current patch (and so needs the same litter) + integer :: p,c + real(r8) :: canopy_mortality_woody_litter ! flux of wood litter in to litter pool: KgC/m2/day + real(r8) :: canopy_mortality_leaf_litter(numpft_ed) ! flux in to leaf litter from tree death: KgC/m2/day + real(r8) :: canopy_mortality_root_litter(numpft_ed) ! flux in to froot litter from tree death: KgC/m2/day + !--------------------------------------------------------------------- + + currentPatch => cp_target + new_patch => new_patch_target + canopy_mortality_woody_litter = 0.0_r8 ! mortality generated litter. KgC/m2/day + canopy_mortality_leaf_litter(:) = 0.0_r8 + canopy_mortality_root_litter(:) = 0.0_r8 + + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + p = currentCohort%pft + if(currentPatch%disturbance_rates(1) > currentPatch%disturbance_rates(2))then !mortality is dominant disturbance + if(currentCohort%canopy_layer == 1)then + !currentCohort%dmort = mortality_rates(currentCohort) + !the disturbance calculations are done with the previous n, c_area and d_mort. So it's probably & + !not right to recalcualte dmort here. + canopy_dead = currentCohort%n * min(1.0_r8,currentCohort%dmort * hlm_freq_day) + + canopy_mortality_woody_litter = canopy_mortality_woody_litter + & + canopy_dead*(currentCohort%bdead+currentCohort%bsw) + canopy_mortality_leaf_litter(p) = canopy_mortality_leaf_litter(p)+ & + canopy_dead*(currentCohort%bl) + canopy_mortality_root_litter(p) = canopy_mortality_root_litter(p)+ & + canopy_dead*(currentCohort%br+currentCohort%bstore) + + else + if(EDPftvarcon_inst%woody(currentCohort%pft) == 1)then + + understorey_dead = ED_val_understorey_death * currentCohort%n * (patch_site_areadis/currentPatch%area) !kgC/site/day + canopy_mortality_woody_litter = canopy_mortality_woody_litter + & + understorey_dead*(currentCohort%bdead+currentCohort%bsw) + canopy_mortality_leaf_litter(p)= canopy_mortality_leaf_litter(p)+ & + understorey_dead* currentCohort%bl + canopy_mortality_root_litter(p)= canopy_mortality_root_litter(p)+ & + understorey_dead*(currentCohort%br+currentCohort%bstore) + + ! FIX(SPM,040114) - clarify this comment + ! grass is not killed by canopy mortality disturbance events. + ! Just move it into the new patch area. + else + ! no-op + endif + endif + endif + + currentCohort => currentCohort%taller + + enddo !currentCohort + + !************************************/ + !Evenly distribute the litter from the trees that died across the new and old patches + !************************************/ + !************************************/ + !Evenly distribute the litter from the trees that died across the new and old patches + !'litter' fluxes here are in KgC + !************************************/ + litter_area = currentPatch%area + np_mult = patch_site_areadis/new_patch%area + ! This litter is distributed between the current and new patches, & + ! not to any other patches. This is really the eventually area of the current patch & + ! (currentPatch%area-patch_site_areadis) +patch_site_areadis... + ! For the new patch, only some fraction of its land area (patch_areadis/np%area) is derived from the current patch + ! so we need to multiply by patch_areadis/np%area + do c = 1,ncwd + + cwd_litter_density = SF_val_CWD_frac(c) * canopy_mortality_woody_litter / litter_area + + new_patch%cwd_ag(c) = new_patch%cwd_ag(c) + ED_val_ag_biomass * cwd_litter_density * np_mult + currentPatch%cwd_ag(c) = currentPatch%cwd_ag(c) + ED_val_ag_biomass * cwd_litter_density + new_patch%cwd_bg(c) = new_patch%cwd_bg(c) + (1._r8-ED_val_ag_biomass) * cwd_litter_density * np_mult + currentPatch%cwd_bg(c) = currentPatch%cwd_bg(c) + (1._r8-ED_val_ag_biomass) * cwd_litter_density + + ! track as diagnostic fluxes + currentSite%CWD_AG_diagnostic_input_carbonflux(c) = currentSite%CWD_AG_diagnostic_input_carbonflux(c) + & + SF_val_CWD_frac(c) * canopy_mortality_woody_litter * hlm_days_per_year * ED_val_ag_biomass/ AREA + currentSite%CWD_BG_diagnostic_input_carbonflux(c) = currentSite%CWD_BG_diagnostic_input_carbonflux(c) + & + SF_val_CWD_frac(c) * canopy_mortality_woody_litter * hlm_days_per_year * (1.0_r8 - ED_val_ag_biomass) / AREA + enddo + + do p = 1,numpft_ed + + new_patch%leaf_litter(p) = new_patch%leaf_litter(p) + canopy_mortality_leaf_litter(p) / litter_area * np_mult + new_patch%root_litter(p) = new_patch%root_litter(p) + canopy_mortality_root_litter(p) / litter_area * np_mult + currentPatch%leaf_litter(p) = currentPatch%leaf_litter(p) + canopy_mortality_leaf_litter(p) / litter_area + currentPatch%root_litter(p) = currentPatch%root_litter(p) + canopy_mortality_root_litter(p) / litter_area + + ! track as diagnostic fluxes + currentSite%leaf_litter_diagnostic_input_carbonflux(p) = currentSite%leaf_litter_diagnostic_input_carbonflux(p) + & + canopy_mortality_leaf_litter(p) * hlm_days_per_year / AREA + + currentSite%root_litter_diagnostic_input_carbonflux(p) = currentSite%root_litter_diagnostic_input_carbonflux(p) + & + canopy_mortality_root_litter(p) * hlm_days_per_year / AREA + enddo + + end subroutine mortality_litter_fluxes + + ! ============================================================================ + subroutine create_patch(currentSite, new_patch, age, areap, spread_local,cwd_ag_local,cwd_bg_local, & + leaf_litter_local,root_litter_local) + ! + ! !DESCRIPTION: + ! Set default values for creating a new patch + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + type(ed_patch_type), intent(inout), target :: new_patch + real(r8), intent(in) :: age ! notional age of this patch in years + real(r8), intent(in) :: areap ! initial area of this patch in m2. + real(r8), intent(in) :: cwd_ag_local(:) ! initial value of above ground coarse woody debris. KgC/m2 + real(r8), intent(in) :: cwd_bg_local(:) ! initial value of below ground coarse woody debris. KgC/m2 + real(r8), intent(in) :: root_litter_local(:)! initial value of root litter. KgC/m2 + real(r8), intent(in) :: leaf_litter_local(:)! initial value of leaf litter. KgC/m2 + real(r8), intent(in) :: spread_local(:) ! initial value of canopy spread parameter.no units + ! + ! !LOCAL VARIABLES: + !--------------------------------------------------------------------- + + allocate(new_patch%tr_soil_dir(hlm_numSWb)) + allocate(new_patch%tr_soil_dif(hlm_numSWb)) + allocate(new_patch%tr_soil_dir_dif(hlm_numSWb)) + allocate(new_patch%fab(hlm_numSWb)) + allocate(new_patch%fabd(hlm_numSWb)) + allocate(new_patch%fabi(hlm_numSWb)) + allocate(new_patch%sabs_dir(hlm_numSWb)) + allocate(new_patch%sabs_dif(hlm_numSWb)) + allocate(new_patch%rootfr_ft(numpft_ed,hlm_numlevgrnd)) + allocate(new_patch%rootr_ft(numpft_ed,hlm_numlevgrnd)) + + call zero_patch(new_patch) !The nan value in here is not working?? + + new_patch%tallest => null() ! pointer to patch's tallest cohort + new_patch%shortest => null() ! pointer to patch's shortest cohort + new_patch%older => null() ! pointer to next older patch + new_patch%younger => null() ! pointer to next shorter patch + new_patch%siteptr => null() ! pointer to the site that the patch is in + + ! assign known patch attributes + + new_patch%siteptr => currentSite + new_patch%age = age + new_patch%age_class = 1 + new_patch%area = areap + new_patch%spread = spread_local + new_patch%cwd_ag = cwd_ag_local + new_patch%cwd_bg = cwd_bg_local + new_patch%leaf_litter = leaf_litter_local + new_patch%root_litter = root_litter_local + + !zeroing things because of the surfacealbedo problem... shouldnt really be necesary + new_patch%cwd_ag_in(:) = 0._r8 + new_patch%cwd_bg_in(:) = 0._r8 + + new_patch%cwd_ag_out(:) = 0._r8 + new_patch%cwd_bg_out(:) = 0._r8 + + new_patch%f_sun = 0._r8 + new_patch%ed_laisun_z(:,:,:) = 0._r8 + new_patch%ed_laisha_z(:,:,:) = 0._r8 + new_patch%ed_parsun_z(:,:,:) = 0._r8 + new_patch%ed_parsha_z(:,:,:) = 0._r8 + new_patch%fabi = 0._r8 + new_patch%fabd = 0._r8 + new_patch%tr_soil_dir(:) = 1._r8 + new_patch%tr_soil_dif(:) = 1._r8 + new_patch%tr_soil_dir_dif(:) = 0._r8 + new_patch%fabd_sun_z(:,:,:) = 0._r8 + new_patch%fabd_sha_z(:,:,:) = 0._r8 + new_patch%fabi_sun_z(:,:,:) = 0._r8 + new_patch%fabi_sha_z(:,:,:) = 0._r8 + new_patch%frac_burnt = 0._r8 + new_patch%total_tree_area = 0.0_r8 + new_patch%NCL_p = 1 + + new_patch%leaf_litter_in(:) = 0._r8 + new_patch%leaf_litter_out(:) = 0._r8 + + new_patch%root_litter_in(:) = 0._r8 + new_patch%root_litter_out(:) = 0._r8 + + + end subroutine create_patch + + ! ============================================================================ + subroutine zero_patch(cp_p) + ! + ! !DESCRIPTION: + ! Sets all the variables in the patch to nan or zero + ! (this needs to be two seperate routines, one for nan & one for zero + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_patch_type), intent(inout), target :: cp_p + ! + ! !LOCAL VARIABLES: + type(ed_patch_type), pointer :: currentPatch + !--------------------------------------------------------------------- + + currentPatch => cp_p + + currentPatch%tallest => null() + currentPatch%shortest => null() + currentPatch%older => null() + currentPatch%younger => null() + currentPatch%siteptr => null() + + currentPatch%patchno = 999 + + currentPatch%age = nan + currentPatch%age_class = 1 + currentPatch%area = nan + currentPatch%canopy_layer_lai(:) = nan + currentPatch%total_canopy_area = nan + currentPatch%canopy_area = nan + currentPatch%bare_frac_area = nan + + currentPatch%tlai_profile(:,:,:) = nan + currentPatch%elai_profile(:,:,:) = 0._r8 + currentPatch%tsai_profile(:,:,:) = nan + currentPatch%esai_profile(:,:,:) = nan + currentPatch%canopy_area_profile(:,:,:) = nan + + currentPatch%fabd_sun_z(:,:,:) = nan + currentPatch%fabd_sha_z(:,:,:) = nan + currentPatch%fabi_sun_z(:,:,:) = nan + currentPatch%fabi_sha_z(:,:,:) = nan + + currentPatch%ed_laisun_z(:,:,:) = nan + currentPatch%ed_laisha_z(:,:,:) = nan + currentPatch%ed_parsun_z(:,:,:) = nan + currentPatch%ed_parsha_z(:,:,:) = nan + currentPatch%psn_z(:,:,:) = 0._r8 + + currentPatch%f_sun(:,:,:) = nan + currentPatch%tr_soil_dir(:) = nan ! fraction of incoming direct radiation that is transmitted to the soil as direct + currentPatch%tr_soil_dif(:) = nan ! fraction of incoming diffuse radiation that is transmitted to the soil as diffuse + currentPatch%tr_soil_dir_dif(:) = nan ! fraction of incoming direct radiation that is transmitted to the soil as diffuse + currentPatch%fabd(:) = nan ! fraction of incoming direct radiation that is absorbed by the canopy + currentPatch%fabi(:) = nan ! fraction of incoming diffuse radiation that is absorbed by the canopy + + currentPatch%present(:,:) = 999 ! is there any of this pft in this layer? + currentPatch%nrad(:,:) = 999 ! number of exposed leaf layers for each canopy layer and pft + currentPatch%ncan(:,:) = 999 ! number of total leaf layers for each canopy layer and pft + currentPatch%lai = nan ! leaf area index of patch + currentPatch%spread(:) = nan ! dynamic ratio of dbh to canopy area. + currentPatch%pft_agb_profile(:,:) = nan + + ! DISTURBANCE + currentPatch%disturbance_rates = 0._r8 + currentPatch%disturbance_rate = 0._r8 + + ! LITTER + currentPatch%cwd_ag(:) = 0.0_r8 ! above ground coarse woody debris gc/m2. + currentPatch%cwd_bg(:) = 0.0_r8 ! below ground coarse woody debris + currentPatch%root_litter(:) = 0.0_r8 + currentPatch%leaf_litter(:) = 0.0_r8 + + currentPatch%leaf_litter_in(:) = 0.0_r8 + currentPatch%leaf_litter_out(:) = 0.0_r8 + + ! FIRE + currentPatch%fuel_eff_moist = 0.0_r8 ! average fuel moisture content of the ground fuel + ! (incl. live grasses. omits 1000hr fuels) + currentPatch%livegrass = 0.0_r8 ! total ag grass biomass in patch. 1=c3 grass, 2=c4 grass. gc/m2 + currentPatch%sum_fuel = 0.0_r8 ! total ground fuel related to ros (omits 1000hr fuels). gc/m2 + currentPatch%fuel_bulkd = 0.0_r8 ! average fuel bulk density of the ground fuel + ! (incl. live grasses. omits 1000hr fuels). kgc/m3 + currentPatch%fuel_sav = 0.0_r8 ! average surface area to volume ratio of the ground fuel + ! (incl. live grasses. omits 1000hr fuels). + currentPatch%fuel_mef = 0.0_r8 ! average moisture of extinction factor of the ground fuel + ! (incl. live grasses. omits 1000hr fuels). + currentPatch%ros_front = 0.0_r8 ! average rate of forward spread of each fire in the patch. m/min. + currentPatch%effect_wspeed = 0.0_r8 ! dailywind modified by fraction of relative grass and tree cover. m/min. + currentPatch%tau_l = 0.0_r8 ! mins p&r(1986) + currentPatch%fuel_frac(:) = 0.0_r8 ! fraction of each litter class in the sum_fuel + !- for purposes of calculating weighted averages. + currentPatch%tfc_ros = 0.0_r8 ! used in fi calc + currentPatch%fi = 0._r8 ! average fire intensity of flaming front during day. + ! backward ros plays no role. kj/m/s or kw/m. + currentPatch%fire = 999 ! sr decide_fire.1=fire hot enough to proceed. 0=stop everything- no fires today + currentPatch%fd = 0.0_r8 ! fire duration (mins) + currentPatch%ros_back = 0.0_r8 ! backward ros (m/min) + currentPatch%ab = 0.0_r8 ! area burnt daily m2 + currentPatch%nf = 0.0_r8 ! number of fires initiated daily + currentPatch%sh = 0.0_r8 ! average scorch height for the patch(m) + currentPatch%frac_burnt = 0.0_r8 ! fraction burnt in each timestep. + currentPatch%burnt_frac_litter(:) = 0.0_r8 + currentPatch%btran_ft(:) = 0.0_r8 + + currentPatch%canopy_layer_lai(:) = 0.0_r8 + + currentPatch%seeds_in(:) = 0.0_r8 + currentPatch%seed_decay(:) = 0.0_r8 + currentPatch%seed_germination(:) = 0.0_r8 + + currentPatch%fab(:) = 0.0_r8 + currentPatch%sabs_dir(:) = 0.0_r8 + currentPatch%sabs_dif(:) = 0.0_r8 + + + end subroutine zero_patch + + ! ============================================================================ + subroutine fuse_patches( csite, bc_in ) + ! + ! !DESCRIPTION: + ! Decide to fuse patches if their cohort structures are similar + ! + ! !USES: + use EDParamsMod , only : ED_val_patch_fusion_tol + ! + ! !ARGUMENTS: + type(ed_site_type), intent(inout), target :: csite + type(bc_in_type), intent(in) :: bc_in + ! + ! !LOCAL VARIABLES: + type(ed_site_type) , pointer :: currentSite + type(ed_patch_type), pointer :: currentPatch,tpp,tmpptr + integer :: ft,z !counters for pft and height class + real(r8) :: norm !normalized difference between biomass profiles + real(r8) :: profiletol !tolerance of patch fusion routine. Starts off high and is reduced if there are too many patches. + integer :: maxpatch !maximum number of allowed patches. FIX-RF. These should be namelist variables. + integer :: nopatches !number of patches presently in gridcell + integer :: iterate !switch of patch reduction iteration scheme. 1 to keep going, 0 to stop + integer :: fuse_flag !do patches get fused (1) or not (0). + !--------------------------------------------------------------------- + + !maxpatch = 4 + maxpatch = maxPatchesPerSite + + currentSite => csite + + profiletol = ED_val_patch_fusion_tol + + nopatches = 0 + currentPatch => currentSite%youngest_patch + do while(associated(currentPatch)) + nopatches = nopatches +1 + currentPatch => currentPatch%older + enddo + !---------------------------------------------------------------------! + ! We only really care about fusing patches if nopatches > 1 ! + !---------------------------------------------------------------------! + iterate = 1 + + !---------------------------------------------------------------------! + ! Keep doing this until nopatches >= maxpatch ! + !---------------------------------------------------------------------! + + do while(iterate == 1) + !---------------------------------------------------------------------! + ! Calculate the biomass profile of each patch ! + !---------------------------------------------------------------------! + currentPatch => currentSite%youngest_patch + do while(associated(currentPatch)) + call patch_pft_size_profile(currentPatch) + currentPatch => currentPatch%older + enddo + + !---------------------------------------------------------------------! + ! Loop round current & target (currentPatch,tpp) patches to assess combinations ! + !---------------------------------------------------------------------! + currentPatch => currentSite%youngest_patch + do while(associated(currentPatch)) + tpp => currentSite%youngest_patch + do while(associated(tpp)) + + if(.not.associated(currentPatch))then + write(fates_log(),*) 'ED: issue with currentPatch' + endif + + if(associated(tpp).and.associated(currentPatch))then + fuse_flag = 1 !the default is to fuse the patches + if(currentPatch%patchno /= tpp%patchno) then !these should be the same patch + + !---------------------------------------------------------------------! + ! Calculate the difference criteria for each pft and dbh class ! + !---------------------------------------------------------------------! + do ft = 1,numpft_ed ! loop over pfts + do z = 1,n_dbh_bins ! loop over hgt bins + !is there biomass in this category? + if(currentPatch%pft_agb_profile(ft,z) > 0.0_r8.or.tpp%pft_agb_profile(ft,z) > 0.0_r8)then + norm = abs(currentPatch%pft_agb_profile(ft,z) - tpp%pft_agb_profile(ft,z))/(0.5_r8*& + &(currentPatch%pft_agb_profile(ft,z) + tpp%pft_agb_profile(ft,z))) + !---------------------------------------------------------------------! + ! Look for differences in profile biomass, above the minimum biomass ! + !---------------------------------------------------------------------! + + if(norm > profiletol)then + !looking for differences between profile density. + if(currentPatch%pft_agb_profile(ft,z) > NTOL.or.tpp%pft_agb_profile(ft,z) > NTOL)then + fuse_flag = 0 !do not fuse - keep apart. + endif + endif ! profile tol + endif ! NTOL + enddo !ht bins + enddo ! PFT + + !---------------------------------------------------------------------! + ! Call the patch fusion routine if there is a meaningful difference ! + ! any of the pft x height categories ! + !---------------------------------------------------------------------! + + if(fuse_flag == 1)then + tmpptr => currentPatch%older + call fuse_2_patches(currentPatch, tpp) + call fuse_cohorts(tpp, bc_in) + call sort_cohorts(tpp) + currentPatch => tmpptr + else + ! write(fates_log(),*) 'patches not fused' + endif + endif !are both patches associated? + endif !are these different patches? + tpp => tpp%older + enddo !tpp loop + + if(associated(currentPatch))then + currentPatch => currentPatch%older + else + currentPatch => null() + endif !associated currentPatch + + enddo ! currentPatch loop + + !---------------------------------------------------------------------! + ! Is the number of patches larger than the maximum? ! + !---------------------------------------------------------------------! + nopatches = 0 + currentPatch => currentSite%youngest_patch + do while(associated(currentPatch)) + nopatches = nopatches +1 + currentPatch => currentPatch%older + enddo + + if(nopatches > maxpatch)then + iterate = 1 + profiletol = profiletol * 1.1_r8 + + !---------------------------------------------------------------------! + ! Making profile tolerance larger means that more fusion will happen ! + !---------------------------------------------------------------------! + else + iterate = 0 + endif + + enddo !do while nopatches>maxpatch + + end subroutine fuse_patches + + ! ============================================================================ + subroutine fuse_2_patches(dp, rp) + ! + ! !DESCRIPTION: + ! This function fuses the two patches specified in the argument. + ! It fuses the first patch in the argument (the "donor") into the second + ! patch in the argument (the "recipient"), and frees the memory + ! associated with the secnd patch + ! + ! !USES: + use EDTypesMod, only: get_age_class_index + ! + ! !ARGUMENTS: + type (ed_patch_type) , intent(inout), pointer :: dp ! Donor Patch + type (ed_patch_type) , intent(inout), pointer :: rp ! Recipient Patch + ! + ! !LOCAL VARIABLES: + type (ed_cohort_type), pointer :: currentCohort ! Current Cohort + type (ed_cohort_type), pointer :: nextc ! Remembers next cohort in list + type (ed_cohort_type), pointer :: storesmallcohort + type (ed_cohort_type), pointer :: storebigcohort + integer :: c,p !counters for pft and litter size class. + integer :: tnull,snull ! are the tallest and shortest cohorts associated? + type(ed_patch_type), pointer :: youngerp ! pointer to the patch younger than donor + type(ed_patch_type), pointer :: olderp ! pointer to the patch older than donor + type(ed_site_type), pointer :: csite ! pointer to the donor patch's site + !--------------------------------------------------------------------- + + !area weighted average of ages & litter + rp%age = (dp%age * dp%area + rp%age * rp%area)/(dp%area + rp%area) + rp%age_class = get_age_class_index(rp%age) + + do p = 1,numpft_ed + rp%seeds_in(p) = (rp%seeds_in(p)*rp%area + dp%seeds_in(p)*dp%area)/(rp%area + dp%area) + rp%seed_decay(p) = (rp%seed_decay(p)*rp%area + dp%seed_decay(p)*dp%area)/(rp%area + dp%area) + rp%seed_germination(p) = (rp%seed_germination(p)*rp%area + dp%seed_germination(p)*dp%area)/(rp%area + dp%area) + enddo + + do c = 1,ncwd + rp%cwd_ag(c) = (dp%cwd_ag(c)*dp%area + rp%cwd_ag(c)*rp%area)/(dp%area + rp%area) + rp%cwd_bg(c) = (dp%cwd_bg(c)*dp%area + rp%cwd_bg(c)*rp%area)/(dp%area + rp%area) + enddo + + do p = 1,numpft_ed + rp%leaf_litter(p) = (dp%leaf_litter(p)*dp%area + rp%leaf_litter(p)*rp%area)/(dp%area + rp%area) + rp%root_litter(p) = (dp%root_litter(p)*dp%area + rp%root_litter(p)*rp%area)/(dp%area + rp%area) + enddo + + rp%fuel_eff_moist = (dp%fuel_eff_moist*dp%area + rp%fuel_eff_moist*rp%area)/(dp%area + rp%area) + rp%livegrass = (dp%livegrass*dp%area + rp%livegrass*rp%area)/(dp%area + rp%area) + rp%sum_fuel = (dp%sum_fuel*dp%area + rp%sum_fuel*rp%area)/(dp%area + rp%area) + rp%fuel_bulkd = (dp%fuel_bulkd*dp%area + rp%fuel_bulkd*rp%area)/(dp%area + rp%area) + rp%fuel_sav = (dp%fuel_sav*dp%area + rp%fuel_sav*rp%area)/(dp%area + rp%area) + rp%fuel_mef = (dp%fuel_mef*dp%area + rp%fuel_mef*rp%area)/(dp%area + rp%area) + rp%ros_front = (dp%ros_front*dp%area + rp%ros_front*rp%area)/(dp%area + rp%area) + rp%effect_wspeed = (dp%effect_wspeed*dp%area + rp%effect_wspeed*rp%area)/(dp%area + rp%area) + rp%tau_l = (dp%tau_l*dp%area + rp%tau_l*rp%area)/(dp%area + rp%area) + rp%fuel_frac(:) = (dp%fuel_frac(:)*dp%area + rp%fuel_frac(:)*rp%area)/(dp%area + rp%area) + rp%tfc_ros = (dp%tfc_ros*dp%area + rp%tfc_ros*rp%area)/(dp%area + rp%area) + rp%fi = (dp%fi*dp%area + rp%fi*rp%area)/(dp%area + rp%area) + rp%fd = (dp%fd*dp%area + rp%fd*rp%area)/(dp%area + rp%area) + rp%ros_back = (dp%ros_back*dp%area + rp%ros_back*rp%area)/(dp%area + rp%area) + rp%ab = (dp%ab*dp%area + rp%ab*rp%area)/(dp%area + rp%area) + rp%nf = (dp%nf*dp%area + rp%nf*rp%area)/(dp%area + rp%area) + rp%sh = (dp%sh*dp%area + rp%sh*rp%area)/(dp%area + rp%area) + rp%frac_burnt = (dp%frac_burnt*dp%area + rp%frac_burnt*rp%area)/(dp%area + rp%area) + rp%burnt_frac_litter(:) = (dp%burnt_frac_litter(:)*dp%area + rp%burnt_frac_litter(:)*rp%area)/(dp%area + rp%area) + rp%btran_ft(:) = (dp%btran_ft(:)*dp%area + rp%btran_ft(:)*rp%area)/(dp%area + rp%area) + rp%dleaf_litter_dt(:) = (dp%dleaf_litter_dt(:)*dp%area + rp%dleaf_litter_dt(:)*rp%area)/(dp%area+rp%area) + rp%leaf_litter_in(:) = (dp%leaf_litter_in(:)*dp%area + rp%leaf_litter_in(:)*rp%area)/(dp%area+rp%area) + rp%leaf_litter_out(:) = (dp%leaf_litter_out(:)*dp%area + rp%leaf_litter_out(:)*rp%area)/(dp%area+rp%area) + + + rp%area = rp%area + dp%area !THIS MUST COME AT THE END! + + !insert donor cohorts into recipient patch + if(associated(dp%shortest))then + + currentCohort => dp%shortest + if(associated(currentCohort)) then + nextc => currentCohort%taller + endif + + do while(associated(dp%shortest)) + + storebigcohort => rp%tallest + storesmallcohort => rp%shortest + + if(associated(rp%tallest))then + tnull = 0 + else + tnull = 1 + rp%tallest => currentCohort + endif + + if(associated(rp%shortest))then + snull = 0 + else + snull = 1 + rp%shortest => currentCohort + endif + + call insert_cohort(currentCohort, rp%tallest, rp%shortest, tnull, snull, storebigcohort, storesmallcohort) + + rp%tallest => storebigcohort + rp%shortest => storesmallcohort + + currentCohort%patchptr => rp + currentCohort%siteptr => rp%siteptr + + currentCohort => nextc + + dp%shortest => currentCohort + + if(associated(currentCohort)) then + nextc => currentCohort%taller + endif + + enddo !cohort + endif !are there any cohorts? + + call patch_pft_size_profile(rp) ! Recalculate the patch size profile for the resulting patch + + ! Define some aliases for the donor patches younger and older neighbors + ! which may or may not exist. After we set them, we will remove the donor + ! And then we will go about re-setting the map. + csite => dp%siteptr + if(associated(dp%older))then + olderp => dp%older + else + olderp => null() + end if + if(associated(dp%younger))then + youngerp => dp%younger + else + youngerp => null() + end if + + ! We have no need for the dp pointer anymore, we have passed on it's legacy + call dealloc_patch(dp) + deallocate(dp) + + + if(associated(youngerp))then + ! Update the younger patch's new older patch (because it isn't dp anymore) + youngerp%older => olderp + else + ! There was no younger patch than dp, so the head of the young order needs + ! to be set, and it is set as the patch older than dp. That patch + ! already knows it's older patch (so no need to set or change it) + csite%youngest_patch => olderp + end if + + + if(associated(olderp))then + ! Update the older patch's new younger patch (becuase it isn't dp anymore) + olderp%younger => youngerp + else + ! There was no patch older than dp, so the head of the old patch order needs + ! to be set, and it is set as the patch younger than dp. That patch already + ! knows it's younger patch, no need to set + csite%oldest_patch => youngerp + end if + + + end subroutine fuse_2_patches + + ! ============================================================================ + subroutine terminate_patches(cs_pnt) + ! + ! !DESCRIPTION: + ! Terminate Patches if they are too small + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_site_type), target, intent(in) :: cs_pnt + ! + ! !LOCAL VARIABLES: + type(ed_site_type), pointer :: currentSite + type(ed_patch_type), pointer :: currentPatch, tmpptr + real(r8) areatot ! variable for checking whether the total patch area is wrong. + !--------------------------------------------------------------------- + + currentSite => cs_pnt + + currentPatch => currentSite%oldest_patch + + !fuse patches if one of them is very small.... + currentPatch => currentSite%youngest_patch + do while(associated(currentPatch)) + if(currentPatch%area <= min_patch_area)then + if ( currentPatch%patchno /= currentSite%youngest_patch%patchno) then + ! Do not force the fusion of the youngest patch to its neighbour. + ! This is only really meant for very old patches. + if(associated(currentPatch%older) )then + write(fates_log(),*) 'fusing to older patch because this one is too small',& + currentPatch%area, currentPatch%lai, & + currentPatch%older%area,currentPatch%older%lai + call fuse_2_patches(currentPatch%older, currentPatch) + write(fates_log(),*) 'after fusion to older patch',currentPatch%area + else + write(fates_log(),*) 'fusing to younger patch because oldest one is too small',& + currentPatch%area, currentPatch%lai + tmpptr => currentPatch%younger + call fuse_2_patches(currentPatch, currentPatch%younger) + write(fates_log(),*) 'after fusion to younger patch' + currentPatch => tmpptr + endif + endif + endif + + currentPatch => currentPatch%older + + enddo + + !check area is not exceeded + areatot = 0._r8 + currentPatch => currentSite%oldest_patch + do while(associated(currentPatch)) + areatot = areatot + currentPatch%area + currentPatch => currentPatch%younger + if((areatot-area) > 0.0000001_r8)then + write(fates_log(),*) 'ED: areatot too large. end terminate', areatot + endif + enddo + + end subroutine terminate_patches + + ! ===================================================================================== + + subroutine dealloc_patch(cpatch) + + ! This Subroutine is intended to de-allocate the allocatable memory that is pointed + ! to via the patch structure. This subroutine DOES NOT deallocate the patch + ! structure itself. + + type(ed_patch_type), target :: cpatch + type(ed_cohort_type), pointer :: ccohort ! current + type(ed_cohort_type), pointer :: ncohort ! next + + ! First Deallocate the cohort space + ! ----------------------------------------------------------------------------------- + ccohort => cpatch%shortest + do while(associated(ccohort)) + + ncohort => ccohort%taller + if(use_fates_plant_hydro) call DeallocateHydrCohort(ccohort) + deallocate(ccohort) + ccohort => ncohort + + end do + + ! Secondly, and lastly, deallocate the allocatable vector spaces in the patch + if(allocated(cpatch%tr_soil_dir))then + deallocate(cpatch%tr_soil_dir) + deallocate(cpatch%tr_soil_dif) + deallocate(cpatch%tr_soil_dir_dif) + deallocate(cpatch%fab) + deallocate(cpatch%fabd) + deallocate(cpatch%fabi) + deallocate(cpatch%sabs_dir) + deallocate(cpatch%sabs_dif) + deallocate(cpatch%rootfr_ft) + deallocate(cpatch%rootr_ft) + end if + + return + end subroutine dealloc_patch + + ! ============================================================================ + subroutine patch_pft_size_profile(cp_pnt) + ! + ! !DESCRIPTION: + ! Binned patch size profiles generated for patch fusion routine + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_patch_type), target, intent(inout) :: cp_pnt + ! + ! !LOCAL VARIABLES: + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + real(r8) :: mind(N_DBH_BINS) ! Bottom of DBH bin + real(r8) :: maxd(N_DBH_BINS) ! Top of DBH bin + real(r8) :: delta_dbh ! Size of DBH bin + integer :: p ! Counter for PFT + integer :: j ! Counter for DBH bins + real(r8), parameter :: gigantictrees = 1.e8_r8 + !--------------------------------------------------------------------- + + currentPatch => cp_pnt + + delta_dbh = (DBHMAX/N_DBH_BINS) + + do p = 1,numpft_ed + do j = 1,N_DBH_BINS + currentPatch%pft_agb_profile(p,j) = 0.0_r8 + enddo + enddo + + do j = 1,N_DBH_BINS + if (j == 1) then + mind(j) = 0.0_r8 + maxd(j) = delta_dbh + else if (j == N_DBH_BINS) then + mind(j) = (j-1) * delta_dbh + maxd(j) = gigantictrees + else + mind(j) = (j-1) * delta_dbh + maxd(j) = (j)*delta_dbh + endif + enddo + + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + do j = 1,N_DBH_BINS + if((currentCohort%dbh > mind(j)) .AND. (currentCohort%dbh <= maxd(j)))then + + currentPatch%pft_agb_profile(currentCohort%pft,j) = & + currentPatch%pft_agb_profile(currentCohort%pft,j) + & + currentCohort%bdead*currentCohort%n/currentPatch%area + + endif + enddo ! dbh bins + + currentCohort => currentCohort%taller + + enddo !currentCohort + + end subroutine patch_pft_size_profile + + ! ===================================================================================== + function countPatches( nsites, sites ) result ( totNumPatches ) + ! + ! !DESCRIPTION: + ! Loop over all Patches to count how many there are + ! + ! !USES: + use EDTypesMod , only : ed_site_type + ! + ! !ARGUMENTS: + integer, intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + ! + ! !LOCAL VARIABLES: + type (ed_patch_type), pointer :: currentPatch + integer :: totNumPatches ! total number of patches. + integer :: s + !--------------------------------------------------------------------- + + totNumPatches = 0 + + do s = 1,nsites + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + totNumPatches = totNumPatches + 1 + currentPatch => currentPatch%younger + enddo + enddo + + end function countPatches + + ! ==================================================================================== + + subroutine set_root_fraction( cpatch , zi ) + ! + ! !DESCRIPTION: + ! Calculates the fractions of the root biomass in each layer for each pft. + ! + ! !USES: + + ! + ! !ARGUMENTS + type(ed_patch_type),intent(inout), target :: cpatch + real(r8),intent(in) :: zi(0:hlm_numlevsoil) + ! + ! !LOCAL VARIABLES: + integer :: lev,p,c,ft + !---------------------------------------------------------------------- + + do ft = 1,numpft_ed + do lev = 1, hlm_numlevgrnd + cpatch%rootfr_ft(ft,lev) = 0._r8 + enddo + + do lev = 1, hlm_numlevsoil-1 + cpatch%rootfr_ft(ft,lev) = .5_r8*( & + exp(-EDPftvarcon_inst%roota_par(ft) * zi(lev-1)) & + + exp(-EDPftvarcon_inst%rootb_par(ft) * zi(lev-1)) & + - exp(-EDPftvarcon_inst%roota_par(ft) * zi(lev)) & + - exp(-EDPftvarcon_inst%rootb_par(ft) * zi(lev))) + end do + end do + + end subroutine set_root_fraction + + end module EDPatchDynamicsMod diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 new file mode 100644 index 00000000..fefcc4cb --- /dev/null +++ b/biogeochem/EDPhysiologyMod.F90 @@ -0,0 +1,1701 @@ +module EDPhysiologyMod + +#include "shr_assert.h" + + ! ============================================================================ + ! Miscellaneous physiology routines from ED. + ! ============================================================================ + + use FatesGlobals, only : fates_log + use FatesInterfaceMod, only : hlm_days_per_year + use FatesInterfaceMod, only : hlm_model_day + use FatesInterfaceMod, only : hlm_freq_day + use FatesInterfaceMod, only : hlm_day_of_year + use FatesConstantsMod, only : r8 => fates_r8 + use EDEcophysContype , only : EDecophyscon + use EDPftvarcon , only : EDPftvarcon_inst + use EDEcophysContype , only : EDecophyscon + use FatesInterfaceMod, only : bc_in_type + use EDCohortDynamicsMod , only : allocate_live_biomass, zero_cohort + use EDCohortDynamicsMod , only : create_cohort, sort_cohorts + + use EDTypesMod , only : numWaterMem + use EDTypesMod , only : dl_sf, dinc_ed + use EDTypesMod , only : external_recruitment + use EDTypesMod , only : ncwd + use EDTypesMod , only : nlevleaf + use EDTypesMod , only : numpft_ed + use EDTypesMod , only : senes + use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type + + use shr_log_mod , only : errMsg => shr_log_errMsg + use FatesGlobals , only : fates_log + use FatesGlobals , only : endrun => fates_endrun + + + implicit none + private + + public :: canopy_derivs + public :: non_canopy_derivs + public :: trim_canopy + public :: phenology + private :: phenology_leafonoff + private :: Growth_Derivatives + public :: recruitment + private :: cwd_input + private :: cwd_out + private :: fragmentation_scaler + private :: seeds_in + private :: seed_decay + private :: seed_germination + public :: flux_into_litter_pools + + logical, parameter :: DEBUG = .false. ! local debug flag + character(len=*), parameter, private :: sourcefile = & + __FILE__ + ! ============================================================================ + +contains + + ! ============================================================================ + subroutine canopy_derivs( currentSite, currentPatch, bc_in ) + ! + ! !DESCRIPTION: + ! spawn new cohorts of juveniles of each PFT + ! + ! !USES: + ! + ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite + type(ed_patch_type) , intent(inout), target :: currentPatch + type(bc_in_type), intent(in) :: bc_in + ! + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer ::currentCohort + !---------------------------------------------------------------------- + + ! call plant growth functions + + currentCohort => currentPatch%shortest + + do while(associated(currentCohort)) + call Growth_Derivatives(currentSite, currentCohort, bc_in ) + currentCohort => currentCohort%taller + enddo + + end subroutine canopy_derivs + + ! ============================================================================ + subroutine non_canopy_derivs( currentSite, currentPatch, bc_in ) + ! + ! !DESCRIPTION: + ! Returns time differentials of the state vector + ! + ! !USES: + use EDTypesMod, only : AREA + ! + ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite + type(ed_patch_type), intent(inout) :: currentPatch + type(bc_in_type), intent(in) :: bc_in + + ! + ! !LOCAL VARIABLES: + integer c,p + !---------------------------------------------------------------------- + + currentPatch%leaf_litter_in(:) = 0.0_r8 + currentPatch%root_litter_in(:) = 0.0_r8 + currentPatch%dleaf_litter_dt(:) = 0.0_r8 + currentPatch%droot_litter_dt(:) = 0.0_r8 + currentPatch%leaf_litter_out(:) = 0.0_r8 + currentPatch%root_litter_out(:) = 0.0_r8 + currentPatch%cwd_AG_in(:) = 0.0_r8 + currentPatch%cwd_BG_in(:) = 0.0_r8 + currentPatch%cwd_AG_out(:) = 0.0_r8 + currentPatch%cwd_BG_out(:) = 0.0_r8 + currentPatch%seeds_in(:) = 0.0_r8 + currentPatch%seed_decay(:) = 0.0_r8 + currentPatch%seed_germination(:) = 0.0_r8 + + ! update seed fluxes + call seeds_in(currentSite, currentPatch) + call seed_decay(currentSite, currentPatch) + call seed_germination(currentSite, currentPatch) + + ! update fragmenting pool fluxes + call cwd_input(currentPatch) + call cwd_out( currentSite, currentPatch, bc_in) + + do p = 1,numpft_ed + currentSite%dseed_dt(p) = currentSite%dseed_dt(p) + & + (currentPatch%seeds_in(p) - currentPatch%seed_decay(p) - & + currentPatch%seed_germination(p)) * currentPatch%area/AREA + enddo + + do c = 1,ncwd + currentPatch%dcwd_AG_dt(c) = currentPatch%cwd_AG_in(c) - currentPatch%cwd_AG_out(c) + currentPatch%dcwd_BG_dt(c) = currentPatch%cwd_BG_in(c) - currentPatch%cwd_BG_out(c) + enddo + + do p = 1,numpft_ed + currentPatch%dleaf_litter_dt(p) = currentPatch%leaf_litter_in(p) - & + currentPatch%leaf_litter_out(p) + currentPatch%droot_litter_dt(p) = currentPatch%root_litter_in(p) - & + currentPatch%root_litter_out(p) + enddo + + end subroutine non_canopy_derivs + + ! ============================================================================ + subroutine trim_canopy( currentSite ) + ! + ! !DESCRIPTION: + ! Canopy trimming / leaf optimisation. Removes leaves in negative annual carbon balance. + ! + ! !USES: + ! + use EDGrowthFunctionsMod, only : tree_lai + ! + ! !ARGUMENTS + type (ed_site_type),intent(inout), target :: currentSite + ! + ! !LOCAL VARIABLES: + type (ed_cohort_type) , pointer :: currentCohort + type (ed_patch_type) , pointer :: currentPatch + + real(r8) :: inc ! rate at which canopy acclimates to uptake + real(r8) :: trim_limit ! this is the limit of the canopy trimming routine, so that trees + ! can't just lose all their leaves and have no reproductive costs. + integer :: z ! leaf layer + integer :: trimmed ! was this layer trimmed in this year? If not expand the canopy. + + trim_limit = 0.3_r8 ! Arbitrary limit to reductions in leaf area with stress. Without this nothing ever dies. + inc = 0.03_r8 ! Arbitrary incremental change in trimming function. Controls + ! rate at which leaves are optimised to their environment. + !---------------------------------------------------------------------- + + currentPatch => currentSite%youngest_patch + + do while(associated(currentPatch)) + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + trimmed = 0 + currentCohort%treelai = tree_lai(currentCohort) + currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) + if (currentCohort%nv > nlevleaf)then + write(fates_log(),*) 'nv > nlevleaf',currentCohort%nv,currentCohort%treelai,currentCohort%treesai, & + currentCohort%c_area,currentCohort%n,currentCohort%bl + endif + + !Leaf cost vs netuptake for each leaf layer. + do z = 1,nlevleaf + if (currentCohort%year_net_uptake(z) /= 999._r8)then !there was activity this year in this leaf layer. + !Leaf Cost kgC/m2/year-1 + !decidous costs. + if (EDPftvarcon_inst%season_decid(currentCohort%pft) == 1.or. & + EDPftvarcon_inst%stress_decid(currentCohort%pft) == 1)then + currentCohort%leaf_cost = 1._r8/(EDPftvarcon_inst%slatop(currentCohort%pft)*1000.0_r8) + currentCohort%leaf_cost = currentCohort%leaf_cost + & + 1.0_r8/(EDPftvarcon_inst%slatop(currentCohort%pft)*1000.0_r8) * & + EDPftvarcon_inst%froot_leaf(currentCohort%pft) / EDecophyscon%root_long(currentCohort%pft) + currentCohort%leaf_cost = currentCohort%leaf_cost * (EDPftvarcon_inst%grperc(currentCohort%pft) + 1._r8) + else !evergreen costs + currentCohort%leaf_cost = 1.0_r8/(EDPftvarcon_inst%slatop(currentCohort%pft)* & + EDPftvarcon_inst%leaf_long(currentCohort%pft)*1000.0_r8) !convert from sla in m2g-1 to m2kg-1 + currentCohort%leaf_cost = currentCohort%leaf_cost + & + 1.0_r8/(EDPftvarcon_inst%slatop(currentCohort%pft)*1000.0_r8) * & + EDPftvarcon_inst%froot_leaf(currentCohort%pft) / EDecophyscon%root_long(currentCohort%pft) + currentCohort%leaf_cost = currentCohort%leaf_cost * (EDPftvarcon_inst%grperc(currentCohort%pft) + 1._r8) + endif + if (currentCohort%year_net_uptake(z) < currentCohort%leaf_cost)then + if (currentCohort%canopy_trim > trim_limit)then + + if ( DEBUG ) then + write(fates_log(),*) 'trimming leaves',currentCohort%canopy_trim,currentCohort%leaf_cost + endif + + ! keep trimming until none of the canopy is in negative carbon balance. + if (currentCohort%hite > EDecophyscon%hgt_min(currentCohort%pft))then + currentCohort%canopy_trim = currentCohort%canopy_trim - inc + if (EDPftvarcon_inst%evergreen(currentCohort%pft) /= 1)then + currentCohort%laimemory = currentCohort%laimemory*(1.0_r8 - inc) + endif + trimmed = 1 + endif + endif + endif + endif !leaf activity? + enddo !z + if (currentCohort%NV.gt.2)then + ! leaf_cost may be uninitialized, removing its diagnostic from the log + ! to allow checking with fpe_traps (RGK) + write(fates_log(),*) 'nv>4',currentCohort%year_net_uptake(1:6),currentCohort%canopy_trim + endif + + currentCohort%year_net_uptake(:) = 999.0_r8 + if (trimmed == 0.and.currentCohort%canopy_trim < 1.0_r8)then + currentCohort%canopy_trim = currentCohort%canopy_trim + inc + endif + + if ( DEBUG ) then + write(fates_log(),*) 'trimming',currentCohort%canopy_trim + endif + + ! currentCohort%canopy_trim = 1.0_r8 !FIX(RF,032414) this turns off ctrim for now. + currentCohort => currentCohort%shorter + enddo + currentPatch => currentPatch%older + enddo + + end subroutine trim_canopy + + ! ============================================================================ + subroutine phenology( currentSite, bc_in ) + ! + ! !DESCRIPTION: + ! Phenology. + ! + ! !USES: + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + use EDParamsMod, only : ED_val_phen_drought_threshold, ED_val_phen_doff_time + use EDParamsMod, only : ED_val_phen_a, ED_val_phen_b, ED_val_phen_c, ED_val_phen_chiltemp + use EDParamsMod, only : ED_val_phen_mindayson, ED_val_phen_ncolddayslim, ED_val_phen_coldtemp + + + ! + ! !ARGUMENTS: + type(ed_site_type), intent(inout), target :: currentSite + type(bc_in_type), intent(in) :: bc_in + + ! + ! !LOCAL VARIABLES: + + integer :: t ! day of year + integer :: ncolddays ! no days underneath the threshold for leaf drop + integer :: i + integer :: timesincedleafon,timesincedleafoff,timesinceleafon,timesinceleafoff + integer :: refdate + integer :: curdate + + integer :: yr ! year (0, ...) + integer :: mon ! month (1, ..., 12) + integer :: day ! day of month (1, ..., 31) + integer :: sec ! seconds of the day + + real(r8) :: gdd_threshold + integer :: ncdstart ! beginning of counting period for chilling degree days. + integer :: gddstart ! beginning of counting period for growing degree days. + real(r8) :: temp_in_C ! daily averaged temperature in celcius + + ! Parameter of drought decid leaf loss in mm in top layer...FIX(RF,032414) + ! - this is arbitrary and poorly understood. Needs work. ED_ + + !Parameters: defaults from Botta et al. 2000 GCB,6 709-725 + !Parameters, default from from SDGVM model of senesence + + t = hlm_day_of_year + temp_in_C = bc_in%t_veg24_si - tfrz + + !-----------------Cold Phenology--------------------! + + !Zero growing degree and chilling day counters + if (currentSite%lat > 0)then + ncdstart = 270 !Northern Hemisphere begining November + gddstart = 1 !Northern Hemisphere begining January + else + ncdstart = 120 !Southern Hemisphere beginning May + gddstart = 181 !Northern Hemisphere begining July + endif + + ! FIX(SPM,032414) - this will only work for the first year, no? + if (t == ncdstart)then + currentSite%ncd = 0._r8 + endif + + !Accumulate growing/chilling days after start of counting period + if (temp_in_C < ED_val_phen_chiltemp)then + currentSite%ncd = currentSite%ncd + 1.0_r8 + endif + + !GDD accumulation function, which also depends on chilling days. + gdd_threshold = ED_val_phen_a + ED_val_phen_b*exp(ED_val_phen_c*currentSite%ncd) + + !Accumulate temperature of last 10 days. + currentSite%last_n_days(2:senes) = currentSite%last_n_days(1:senes-1) + currentSite%last_n_days(1) = temp_in_C + !count number of days for leaves off + ncolddays = 0 + do i = 1,senes + if (currentSite%last_n_days(i) < ED_val_phen_coldtemp)then + ncolddays = ncolddays + 1 + endif + enddo + + ! Here is where we do the GDD accumulation calculation + ! + ! reset GDD on set dates + if (t == gddstart)then + currentSite%ED_GDD_site = 0._r8 + endif + ! + ! accumulate the GDD using daily mean temperatures + if (bc_in%t_veg24_si .gt. tfrz) then + currentSite%ED_GDD_site = currentSite%ED_GDD_site + bc_in%t_veg24_si - tfrz + endif + + + timesinceleafoff = hlm_model_day - currentSite%leafoffdate + !LEAF ON: COLD DECIDUOUS. Needs to + !1) have exceeded the growing degree day threshold + !2) The leaves should not be on already + !3) There should have been at least on chilling day in the counting period. + if (currentSite%ED_GDD_site > gdd_threshold)then + if (currentSite%status == 1) then + if (currentSite%ncd >= 1) then + currentSite%status = 2 !alter status of site to 'leaves on' + ! NOTE(bja, 2015-01) should leafondate = model_day to be consistent with leaf off? + currentSite%leafondate = t !record leaf on date + if ( DEBUG ) write(fates_log(),*) 'leaves on' + endif !ncd + endif !status + endif !GDD + + timesinceleafon = hlm_model_day - currentSite%leafondate + + + !LEAF OFF: COLD THRESHOLD + !Needs to: + !1) have exceeded the number of cold days threshold + !2) have exceeded the minimum leafon time. + !3) The leaves should not be off already + !4) The day of the year should be larger than the counting period. (not sure if we need this/if it will break the restarting) + + if (ncolddays > ED_val_phen_ncolddayslim)then + if (timesinceleafon > ED_val_phen_mindayson)then + if (currentSite%status == 2)then + currentSite%status = 1 !alter status of site to 'leaves on' + currentSite%leafoffdate = hlm_model_day !record leaf off date + if ( DEBUG ) write(fates_log(),*) 'leaves off' + endif + endif + endif + + !LEAF OFF: COLD LIFESPAN THRESHOLD + if(timesinceleafoff > 400)then !remove leaves after a whole year when there is no 'off' period. + if(currentSite%status == 2)then + currentSite%status = 1 !alter status of site to 'leaves on' + currentSite%leafoffdate = hlm_model_day !record leaf off date + if ( DEBUG ) write(fates_log(),*) 'leaves off' + endif + endif + + !-----------------Drought Phenology--------------------! + ! Principles of drought-deciduos phenology model... + ! The 'dstatus' flag is 2 when leaves are on, and 1 when leaves area off. + ! The following sets those site-level flags, which are acted on in phenology_deciduos. + ! A* The leaves live for either the length of time the soil moisture is over the threshold + ! or the lifetime of the leaves, whichever is shorter. + ! B*: If the soil is only wet for a very short time, then the leaves stay on for 100 days + ! C*: The leaves are only permitted to come ON for a 60 day window around when they last came on, + ! to prevent 'flickering' on in response to wet season storms + ! D*: We don't allow anything to happen in the first ten days to allow the water memory window to come into equlibirum. + ! E*: If the soil is always wet, the leaves come on at the beginning of the window, and then last for their lifespan. + ! ISSUES + ! 1. It's not clear what water content we should track. Here we are tracking the top layer, + ! but we probably should track something like BTRAN, + ! but BTRAN is defined for each PFT, and there could potentially be more than one stress-dec PFT.... ? + ! 2. In the beginning, the window is set at an arbitrary time of the year, so the leaves might come on + ! in the dry season, using up stored reserves + ! for the stress-dec plants, and potentially killing them. To get around this, we need to read in the + ! 'leaf on' date from some kind of start-up file + ! but we would need that to happen for every resolution, etc. + ! 3. Will this methodology properly kill off the stress-dec trees where there is no water stress? + ! What about where the wet period coincides with the + ! warm period? We would just get them overlapping with the cold-dec trees, even though that isn't appropriate.... + ! Why don't the drought deciduous trees grow + ! in the North? Is cold decidousness maybe even the same as drought deciduosness there (and so does this + ! distinction actually matter??).... + + !Accumulate surface water memory of last 10 days. + + do i = 1,numWaterMem-1 !shift memory along one + currentSite%water_memory(numWaterMem+1-i) = currentSite%water_memory(numWaterMem-i) + enddo + currentSite%water_memory(1) = bc_in%h2o_liqvol_gl(1) !waterstate_inst%h2osoi_vol_col(coli,1) + + !In drought phenology, we often need to force the leaves to stay on or off as moisture fluctuates... + timesincedleafoff = 0 + if (currentSite%dstatus == 1)then !the leaves are off. How long have they been off? + !leaves have come on, but last year, so at a later date than now. + if (currentSite%dleafoffdate > 0.and.currentSite%dleafoffdate > t)then + timesincedleafoff = t + (360 - currentSite%dleafoffdate) + else + timesincedleafoff = t - currentSite%dleafoffdate + endif + endif + + timesincedleafon = 0 + !the leaves are on. How long have they been on? + if (currentSite%dstatus == 2)then + !leaves have come on, but last year, so at a later date than now. + if (currentSite%dleafondate > 0.and.currentSite%dleafondate > t)then + timesincedleafon = t + (360 - currentSite%dleafondate) + else + timesincedleafon = t - currentSite%dleafondate + endif + endif + + !LEAF ON: DROUGHT DECIDUOUS WETNESS + !Here, we used a window of oppurtunity to determine if we are close to the time when then leaves came on last year + if ((t >= currentSite%dleafondate - 30.and.t <= currentSite%dleafondate + 30).or.(t > 360 - 15.and. & + currentSite%dleafondate < 15))then ! are we in the window? + ! TODO: CHANGE THIS MATH, MOVE THE DENOMENATOR OUTSIDE OF THE SUM (rgk 01-2017) + if (sum(currentSite%water_memory(1:numWaterMem)/dble(numWaterMem)) & + >= ED_val_phen_drought_threshold.and.currentSite%dstatus == 1.and.t >= 10)then + ! leave some minimum time between leaf off and leaf on to prevent 'flickering'. + if (timesincedleafoff > ED_val_phen_doff_time)then + currentSite%dstatus = 2 !alter status of site to 'leaves on' + currentSite%dleafondate = t !record leaf on date + endif + endif + endif + + !we still haven't done budburst by end of window + if (t == currentSite%dleafondate+30.and.currentSite%dstatus == 1)then + currentSite%dstatus = 2 ! force budburst! + currentSite%dleafondate = t ! record leaf on date + endif + + !LEAF OFF: DROUGHT DECIDUOUS LIFESPAN - if the leaf gets to the end of its useful life. A*, E* + if (currentSite%dstatus == 2.and.t >= 10)then !D* + !Are the leaves at the end of their lives? !FIX(RF,0401014)- this is hardwiring.... + if (timesincedleafon > 365.0*EDPftvarcon_inst%leaf_long(7))then + currentSite%dstatus = 1 !alter status of site to 'leaves on' + currentSite%dleafoffdate = t !record leaf on date + endif + endif + + !LEAF OFF: DROUGHT DECIDUOUS DRYNESS - if the soil gets too dry, and the leaves have already been on a while... + if (currentSite%dstatus == 2.and.t >= 10)then !D* + if (sum(currentSite%water_memory(1:10)/10._r8) <= ED_val_phen_drought_threshold)then + if (timesincedleafon > 100)then !B* Have the leaves been on for some reasonable length of time? To prevent flickering. + currentSite%dstatus = 1 !alter status of site to 'leaves on' + currentSite%dleafoffdate = t !record leaf on date + endif + endif + endif + + call phenology_leafonoff(currentSite) + + end subroutine phenology + + ! ============================================================================ + subroutine phenology_leafonoff(currentSite) + ! + ! !DESCRIPTION: + ! Controls the leaf on and off economics + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_site_type), intent(inout), target :: currentSite + ! + ! !LOCAL VARIABLES: + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + real(r8) :: store_output ! the amount of the store to put into leaves - + ! is a barrier against negative storage and C starvation. + + !------------------------------------------------------------------------ + + currentPatch => CurrentSite%oldest_patch + + store_output = 0.5_r8 + + do while(associated(currentPatch)) + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + + !COLD LEAF ON + if (EDPftvarcon_inst%season_decid(currentCohort%pft) == 1)then + if (currentSite%status == 2)then !we have just moved to leaves being on . + if (currentCohort%status_coh == 1)then !Are the leaves currently off? + currentCohort%status_coh = 2 !Leaves are on, so change status to stop flow of carbon out of bstore. + if (currentCohort%laimemory <= currentCohort%bstore)then + currentCohort%bl = currentCohort%laimemory !extract stored carbon to make new leaves. + else + ! we can only put on as much carbon as there is in the store... + ! nb. Putting all of bstore into leaves is C-starvation suicidal. + ! The tendency for this could be parameterized + currentCohort%bl = currentCohort%bstore * store_output + endif + + ! Add deployed carbon to alive biomass pool + currentCohort%balive = currentCohort%balive + currentCohort%bl + + if ( DEBUG ) write(fates_log(),*) 'EDPhysMod 1 ',currentCohort%bstore + + currentCohort%bstore = currentCohort%bstore - currentCohort%bl ! Drain store + + if ( DEBUG ) write(fates_log(),*) 'EDPhysMod 2 ',currentCohort%bstore + + currentCohort%laimemory = 0.0_r8 + + endif !pft phenology + endif ! growing season + + !COLD LEAF OFF + currentCohort%leaf_litter = 0.0_r8 !zero leaf litter for today. + if (currentSite%status == 1)then !past leaf drop day? Leaves still on tree? + if (currentCohort%status_coh == 2)then ! leaves have not dropped + currentCohort%status_coh = 1 + !remember what the lai was this year to put the same amount back on in the spring... + currentCohort%laimemory = currentCohort%bl + ! decrement balive for leaf litterfall + currentCohort%balive = currentCohort%balive - currentCohort%bl + ! add lost carbon to litter + currentCohort%leaf_litter = currentCohort%bl + currentCohort%bl = 0.0_r8 + endif !leaf status + endif !currentSite status + endif !season_decid + + !DROUGHT LEAF ON + if (EDPftvarcon_inst%stress_decid(currentCohort%pft) == 1)then + if (currentSite%dstatus == 2)then !we have just moved to leaves being on . + if (currentCohort%status_coh == 1)then !is it the leaf-on day? Are the leaves currently off? + currentCohort%status_coh = 2 !Leaves are on, so change status to stop flow of carbon out of bstore. + if (currentCohort%laimemory <= currentCohort%bstore)then + currentCohort%bl = currentCohort%laimemory !extract stored carbon to make new leaves. + else + currentCohort%bl = currentCohort%bstore * store_output !we can only put on as much carbon as there is in the store... + endif + currentCohort%balive = currentCohort%balive + currentCohort%bl + + if ( DEBUG ) write(fates_log(),*) 'EDPhysMod 3 ',currentCohort%bstore + + currentCohort%bstore = currentCohort%bstore - currentCohort%bl ! empty store + + if ( DEBUG ) write(fates_log(),*) 'EDPhysMod 4 ',currentCohort%bstore + + currentCohort%laimemory = 0.0_r8 + + endif !currentCohort status again? + endif !currentSite status + + !DROUGHT LEAF OFF + if (currentSite%dstatus == 1)then + if (currentCohort%status_coh == 2)then ! leaves have not dropped + currentCohort%status_coh = 1 + currentCohort%laimemory = currentCohort%bl + ! decrement balive for leaf litterfall + currentCohort%balive = currentCohort%balive - currentCohort%bl + ! add retranslocated carbon (very small) to store. + currentCohort%bstore = currentCohort%bstore + ! add falling leaves to litter pools . convert to KgC/m2 + currentCohort%leaf_litter = currentCohort%bl + currentCohort%bl = 0.0_r8 + endif + endif !status + endif !drought dec. + currentCohort => currentCohort%shorter + enddo !currentCohort + + currentPatch => currentPatch%younger + + enddo !currentPatch + + end subroutine phenology_leafonoff + + + ! ============================================================================ + subroutine seeds_in( currentSite, cp_pnt ) + ! + ! !DESCRIPTION: + ! Flux from plants into seed pool. + ! + ! !USES: + use EDTypesMod, only : AREA + use EDTypesMod, only : homogenize_seed_pfts + ! + ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite + type(ed_patch_type), intent(inout), target :: cp_pnt ! seeds go to these patches. + ! + ! !LOCAL VARIABLES: + type(ed_patch_type), pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + integer :: p + logical :: pft_present(numpft_ed) + real(r8) :: npfts_present + !---------------------------------------------------------------------- + + currentPatch => cp_pnt + + currentPatch%seeds_in(:) = 0.0_r8 + + if ( homogenize_seed_pfts ) then + ! special mode to remove intergenerational filters on PFT existence: each PFT seeds all PFTs + ! first loop over all patches and cohorts to see what and how many PFTs are present on this site + pft_present(:) = .false. + npfts_present = 0._r8 + currentPatch => currentSite%oldest_patch + do while(associated(currentPatch)) + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + p = currentCohort%pft + if (.not. pft_present(p)) then + pft_present(p) = .true. + npfts_present = npfts_present + 1._r8 + endif + currentCohort => currentCohort%shorter + enddo !cohort loop + currentPatch => currentPatch%younger + enddo ! patch loop + + ! now calculate the homogenized seed flux into each PFT pool + currentPatch => cp_pnt + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + do p = 1, numpft_ed + if (pft_present(p)) then + currentPatch%seeds_in(p) = currentPatch%seeds_in(p) + currentCohort%seed_prod * currentCohort%n / & + (currentPatch%area * npfts_present) + endif + end do + currentCohort => currentCohort%shorter + enddo !cohort loop + else + + ! normal case: each PFT seeds its own type + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + p = currentCohort%pft + currentPatch%seeds_in(p) = currentPatch%seeds_in(p) + & + currentCohort%seed_prod * currentCohort%n/currentPatch%area + currentCohort => currentCohort%shorter + enddo !cohort loop + + endif + + currentPatch => currentSite%oldest_patch + + do while(associated(currentPatch)) + if (external_recruitment == 1) then !external seed rain - needed to prevent extinction + do p = 1,numpft_ed + currentPatch%seeds_in(p) = currentPatch%seeds_in(p) + & + EDecophyscon%seed_rain(p) !KgC/m2/year + currentSite%seed_rain_flux(p) = currentSite%seed_rain_flux(p) + & + EDecophyscon%seed_rain(p) * currentPatch%area/AREA !KgC/m2/year + enddo + endif + currentPatch => currentPatch%younger + enddo + + end subroutine seeds_in + + ! ============================================================================ + subroutine seed_decay( currentSite, currentPatch ) + ! + ! !DESCRIPTION: + ! Flux from seed pool into leaf litter pool + ! + ! !USES: + use EDPftvarcon , only : EDPftvarcon_inst + ! + ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite + type(ed_patch_type),intent(inout) :: currentPatch ! seeds go to these patches. + ! + ! !LOCAL VARIABLES: + integer :: p + !---------------------------------------------------------------------- + + ! default value from Liscke and Loffler 2006 ; making this a PFT-specific parameter + ! decays the seed pool according to exponential model + ! seed_decay_turnover is in yr-1 + do p = 1,numpft_ed + currentPatch%seed_decay(p) = currentSite%seed_bank(p) * EDPftvarcon_inst%seed_decay_turnover(p) + enddo + + end subroutine seed_decay + + ! ============================================================================ + subroutine seed_germination( currentSite, currentPatch ) + ! + ! !DESCRIPTION: + ! Flux from seed pool into sapling pool + ! + ! !USES: + use EDPftvarcon , only : EDPftvarcon_inst + ! + ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite + type(ed_patch_type),intent(inout) :: currentPatch ! seeds go to these patches. + ! + ! !LOCAL VARIABLES: + integer :: p + real(r8) max_germination !cap on germination rates. KgC/m2/yr Lishcke et al. 2009 + !---------------------------------------------------------------------- + + max_germination = 1.0_r8 !this is arbitrary + + ! germination_timescale is being pulled to PFT parameter; units are 1/yr + ! thus the mortality rate of seed -> recruit (in units of carbon) is seed_decay_turnover(p)/germination_timescale(p) + ! and thus the mortlaity rate (in units of individuals) is the product of that times the ratio of (hypothetical) seed mass to recruit biomass + do p = 1,numpft_ed + currentPatch%seed_germination(p) = min(currentSite%seed_bank(p) * & + EDPftvarcon_inst%germination_timescale(p),max_germination) + enddo + + end subroutine seed_germination + + ! ============================================================================ + subroutine Growth_Derivatives( currentSite, currentCohort, bc_in) + ! + ! !DESCRIPTION: + ! Main subroutine controlling growth and allocation derivatives + ! + ! !USES: + use EDGrowthFunctionsMod , only : Bleaf, dDbhdBd, dhdbd, hite, mortality_rates,dDbhdBl + + ! + ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite + type(ed_cohort_type),intent(inout), target :: currentCohort + type(bc_in_type), intent(in) :: bc_in + ! + ! !LOCAL VARIABLES: + real(r8) :: dbldbd !rate of change of dead biomass per unit dbh + real(r8) :: dbrdbd !rate of change of root biomass per unit dbh + real(r8) :: dbswdbd !rate of change of sapwood biomass per unit dbh + real(r8) :: dhdbd_fn !rate of change of height per unit dbh + real(r8) :: va !fraction of growth going to alive biomass + real(r8) :: vs !fraction of growth going to structural biomass + real(r8) :: u,h !intermediates + real(r8) :: frac !fraction the stored carbon is of target store amount + real(r8) :: f_store !fraction of NPP allocated to storage in this timestep (functionf of stored pool) + real(r8) :: gr_fract !fraction of carbon balance that is allocated to growth (not reproduction) + real(r8) :: target_balive !target leaf biomass under allometric optimum. + real(r8) :: cmort ! starvation mortality rate (fraction per year) + real(r8) :: bmort ! background mortality rate (fraction per year) + real(r8) :: hmort ! hydraulic failure mortality rate (fraction per year) + real(r8) :: balive_loss + !---------------------------------------------------------------------- + + ! Mortality for trees in the understorey. + !if trees are in the canopy, then their death is 'disturbance'. This probably needs a different terminology + if (currentCohort%canopy_layer > 1)then + call mortality_rates(currentCohort,cmort,hmort,bmort) + currentCohort%dndt = -1.0_r8 * (cmort+hmort+bmort) * currentCohort%n + else + currentCohort%dndt = 0._r8 + endif + + ! Height + currentCohort%hite = Hite(currentCohort) + h = currentCohort%hite + + call allocate_live_biomass(currentCohort,0) + + ! calculate target size of living biomass compartment for a given dbh. + target_balive = Bleaf(currentCohort) * (1.0_r8 + EDPftvarcon_inst%froot_leaf(currentCohort%pft) + & + EDecophyscon%sapwood_ratio(currentCohort%pft)*h) + !target balive without leaves. + if (currentCohort%status_coh == 1)then + target_balive = Bleaf(currentCohort) * (EDPftvarcon_inst%froot_leaf(currentCohort%pft) + & + EDecophyscon%sapwood_ratio(currentCohort%pft) * h) + endif + + ! NPP + if ( DEBUG ) write(fates_log(),*) 'EDphys 716 ',currentCohort%npp_acc + + ! convert from kgC/indiv/day into kgC/indiv/year + ! TODO: CONVERT DAYS_PER_YEAR TO DBLE (HOLDING FOR B4B COMPARISONS, RGK-01-2017) + currentCohort%npp_acc_hold = currentCohort%npp_acc * hlm_days_per_year + currentCohort%gpp_acc_hold = currentCohort%gpp_acc * hlm_days_per_year + currentCohort%resp_acc_hold = currentCohort%resp_acc * hlm_days_per_year + + currentSite%flux_in = currentSite%flux_in + currentCohort%npp_acc * currentCohort%n + + ! Maintenance demands + if (EDPftvarcon_inst%evergreen(currentCohort%pft) == 1)then !grass and EBT + currentCohort%leaf_md = currentCohort%bl / EDPftvarcon_inst%leaf_long(currentCohort%pft) + currentCohort%root_md = currentCohort%br / EDecophyscon%root_long(currentCohort%pft) + currentCohort%md = currentCohort%root_md + currentCohort%leaf_md + endif + + !FIX(RF,032414) - I took out the stem turnover demand as it seemed excesively high and caused odd size-reated + ! decline affect + !with which I am not especially comfortable, particularly as the concept of sapwood turnover is unclear for trees that + !are still in an expansion phase. + + if (EDPftvarcon_inst%season_decid(currentCohort%pft) == 1)then + currentCohort%root_md = currentCohort%br /EDecophyscon%root_long(currentCohort%pft) + currentCohort%leaf_md = 0._r8 + currentCohort%md = currentCohort%root_md + currentCohort%leaf_md + endif + + if (EDPftvarcon_inst%stress_decid(currentCohort%pft) == 1)then + currentCohort%root_md = currentCohort%br /EDecophyscon%root_long(currentCohort%pft) + currentCohort%leaf_md = 0._r8 + currentCohort%md = currentCohort%root_md + currentCohort%leaf_md + endif + + if (EDPftvarcon_inst%stress_decid(currentCohort%pft) /= 1 & + .and.EDPftvarcon_inst%season_decid(currentCohort%pft) /= 1.and. & + EDPftvarcon_inst%evergreen(currentCohort%pft) /= 1)then + write(fates_log(),*) 'problem with phenology definitions',currentCohort%pft, & + EDPftvarcon_inst%stress_decid(currentCohort%pft), & + EDPftvarcon_inst%season_decid(currentCohort%pft),EDPftvarcon_inst%evergreen(currentCohort%pft) + endif + + ! FIX(RF,032414) -turned off for now as it makes balive go negative.... + ! FIX(RF,032414) jan2012 0.01_r8 * currentCohort%bdead + currentCohort%woody_turnover = 0.0_r8 + currentCohort%md = currentCohort%md + currentCohort%woody_turnover + + ! Calculate carbon balance + ! this is the fraction of maintenance demand we -have- to do... + + if ( DEBUG ) write(fates_log(),*) 'EDphys 760 ',currentCohort%npp_acc_hold, currentCohort%md, & + EDecophyscon%leaf_stor_priority(currentCohort%pft) + + currentCohort%carbon_balance = currentCohort%npp_acc_hold - & + currentCohort%md * EDecophyscon%leaf_stor_priority(currentCohort%pft) + + ! Allowing only carbon from NPP pool to account for npp flux into the maintenance turnover pools + ! ie this does not include any use of storage carbon or balive to make up for missing carbon balance in the transfer + currentCohort%npp_leaf = max(0.0_r8,min(currentCohort%npp_acc_hold*currentCohort%leaf_md/currentCohort%md, & + currentCohort%leaf_md*EDecophyscon%leaf_stor_priority(currentCohort%pft))) + currentCohort%npp_froot = max(0.0_r8,min(currentCohort%npp_acc_hold*currentCohort%root_md/currentCohort%md, & + currentCohort%root_md*EDecophyscon%leaf_stor_priority(currentCohort%pft))) + + + if (Bleaf(currentCohort) > 0._r8)then + + if ( DEBUG ) write(fates_log(),*) 'EDphys A ',currentCohort%carbon_balance + + if (currentCohort%carbon_balance > 0._r8)then !spend C on growing and storing + + !what fraction of the target storage do we have? + frac = max(0.0_r8,currentCohort%bstore/(Bleaf(currentCohort) * EDecophyscon%cushion(currentCohort%pft))) + ! FIX(SPM,080514,fstore never used ) + f_store = max(exp(-1.*frac**4._r8) - exp( -1.0_r8 ),0.0_r8) + !what fraction of allocation do we divert to storage? + !what is the flux into the store? + currentCohort%storage_flux = currentCohort%carbon_balance * f_store + + currentCohort%npp_store = currentCohort%carbon_balance * f_store + if ( DEBUG ) write(fates_log(),*) 'EDphys B ',f_store + + !what is the tax on the carbon available for growth? + currentCohort%carbon_balance = currentCohort%carbon_balance * (1.0_r8 - f_store) + else !cbalance is negative. Take C out of store to pay for maintenance respn. + + currentCohort%storage_flux = currentCohort%carbon_balance + + ! Note that npp_store only tracks the flux between NPP and storage. Storage can + ! also be drawn down to support some turnover demand. + currentCohort%npp_store = min(0.0_r8,currentCohort%npp_acc_hold) + + currentCohort%carbon_balance = 0._r8 + endif + + else + + write(fates_log(),*) 'No target leaf area in GrowthDerivs? Bleaf(cohort) <= 0?' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + endif + + !Do we have enough carbon left over to make up the rest of the turnover demand? + balive_loss = 0._r8 + if (currentCohort%carbon_balance > currentCohort%md*(1.0_r8- EDecophyscon%leaf_stor_priority(currentCohort%pft)))then ! Yes... + currentCohort%carbon_balance = currentCohort%carbon_balance - currentCohort%md * (1.0_r8 - & + EDecophyscon%leaf_stor_priority(currentCohort%pft)) + + currentCohort%npp_leaf = currentCohort%npp_leaf + & + currentCohort%leaf_md * (1.0_r8-EDecophyscon%leaf_stor_priority(currentCohort%pft)) + currentCohort%npp_froot = currentCohort%npp_froot + & + currentCohort%root_md * (1.0_r8-EDecophyscon%leaf_stor_priority(currentCohort%pft)) + + else ! we can't maintain constant leaf area and root area. Balive is reduced + + currentCohort%npp_leaf = currentCohort%npp_leaf + & + max(0.0_r8,currentCohort%carbon_balance*(currentCohort%leaf_md/currentCohort%md)) + currentCohort%npp_froot = currentCohort%npp_froot + & + max(0.0_r8,currentCohort%carbon_balance*(currentCohort%root_md/currentCohort%md)) + + balive_loss = currentCohort%md *(1.0_r8- EDecophyscon%leaf_stor_priority(currentCohort%pft))- currentCohort%carbon_balance + currentCohort%carbon_balance = 0._r8 + endif + + !********************************************/ + ! Allometry & allocation of remaining carbon*/ + !********************************************/ + !Use remaining carbon to refill balive or to get larger. + + !only if carbon balance is +ve + if ((currentCohort%balive >= target_balive).AND.(currentCohort%carbon_balance > 0._r8))then + ! fraction of carbon going into active vs structural carbon + if (currentCohort%dbh <= EDecophyscon%max_dbh(currentCohort%pft))then ! cap on leaf biomass + dbldbd = dDbhdBd(currentCohort)/dDbhdBl(currentCohort) + dbrdbd = EDPftvarcon_inst%froot_leaf(currentCohort%pft) * dbldbd + dhdbd_fn = dhdbd(currentCohort) + dbswdbd = EDecophyscon%sapwood_ratio(currentCohort%pft) * (h*dbldbd + currentCohort%bl*dhdbd_fn) + u = 1.0_r8 / (dbldbd + dbrdbd + dbswdbd) + va = 1.0_r8 / (1.0_r8 + u) + vs = u / (1.0_r8 + u) + gr_fract = 1.0_r8 - EDecophyscon%seed_alloc(currentCohort%pft) + else + dbldbd = 0._r8; dbrdbd = 0._r8 ;dbswdbd = 0._r8 + va = 0.0_r8 + vs = 1.0_r8 + gr_fract = 1.0_r8 - (EDecophyscon%seed_alloc(currentCohort%pft) + EDecophyscon%clone_alloc(currentCohort%pft)) + endif + + !FIX(RF,032414) - to fix high bl's. needed to prevent numerical errors without the ODEINT. + if (currentCohort%balive > target_balive*1.1_r8)then + va = 0.0_r8; vs = 1._r8 + write(fates_log(),*) 'using high bl cap',target_balive,currentCohort%balive + endif + + else + dbldbd = 0._r8; dbrdbd = 0._r8; dbswdbd = 0._r8 + va = 1.0_r8; vs = 0._r8 + gr_fract = 1.0_r8 + endif + + ! calculate derivatives of living and dead carbon pools + currentCohort%dbalivedt = gr_fract * va * currentCohort%carbon_balance - balive_loss + currentCohort%dbdeaddt = gr_fract * vs * currentCohort%carbon_balance + currentCohort%dbstoredt = currentCohort%storage_flux + + if ( DEBUG ) write(fates_log(),*) 'EDPhys dbstoredt I ',currentCohort%dbstoredt + + currentCohort%seed_prod = (1.0_r8 - gr_fract) * currentCohort%carbon_balance + if (abs(currentCohort%npp_acc_hold-(currentCohort%dbalivedt+currentCohort%dbdeaddt+currentCohort%dbstoredt+ & + currentCohort%seed_prod+currentCohort%md)) > 0.0000000001_r8)then + write(fates_log(),*) 'error in carbon check growth derivs',currentCohort%npp_acc_hold- & + (currentCohort%dbalivedt+currentCohort%dbdeaddt+currentCohort%dbstoredt+currentCohort%seed_prod+currentCohort%md) + write(fates_log(),*) 'cohort fluxes',currentCohort%pft,currentCohort%canopy_layer,currentCohort%n, & + currentCohort%npp_acc_hold,currentCohort%dbalivedt,balive_loss, & + currentCohort%dbdeaddt,currentCohort%dbstoredt,currentCohort%seed_prod,currentCohort%md * & + EDecophyscon%leaf_stor_priority(currentCohort%pft) + write(fates_log(),*) 'proxies' ,target_balive,currentCohort%balive,currentCohort%dbh,va,vs,gr_fract + endif + + ! prevent negative leaf pool (but not negative store pool). This is also a numerical error prevention, + ! but it shouldn't happen actually... + if (-1.0_r8*currentCohort%dbalivedt * hlm_freq_day > currentCohort%balive*0.99)then + write(fates_log(),*) 'using non-neg leaf mass cap',currentCohort%balive , currentCohort%dbalivedt,currentCohort%dbstoredt, & + currentCohort%carbon_balance + currentCohort%dbstoredt = currentCohort%dbstoredt + currentCohort%dbalivedt + + if ( DEBUG ) write(fates_log(),*) 'EDPhys dbstoredt II ',currentCohort%dbstoredt + + currentCohort%dbalivedt = 0._r8 + endif + + currentCohort%npp_bseed = currentCohort%seed_prod + + ! calculate change in diameter and height + currentCohort%ddbhdt = currentCohort%dbdeaddt * dDbhdBd(currentCohort) + currentCohort%dhdt = currentCohort%dbdeaddt * dHdBd(currentCohort) + + ! If the cohort has grown, it is not new + currentCohort%isnew=.false. + + end subroutine Growth_Derivatives + + ! ============================================================================ + subroutine recruitment( t, currentSite, currentPatch, bc_in ) + ! + ! !DESCRIPTION: + ! spawn new cohorts of juveniles of each PFT + ! + ! !USES: + use EDGrowthFunctionsMod, only : bdead,dbh, Bleaf + ! + ! !ARGUMENTS + integer, intent(in) :: t + type(ed_site_type), intent(inout), target :: currentSite + type(ed_patch_type), intent(inout), pointer :: currentPatch + type(bc_in_type), intent(in) :: bc_in + ! + ! !LOCAL VARIABLES: + integer :: ft + type (ed_cohort_type) , pointer :: temp_cohort + integer :: cohortstatus + !---------------------------------------------------------------------- + + allocate(temp_cohort) ! create temporary cohort + call zero_cohort(temp_cohort) + + do ft = 1,numpft_ed + + temp_cohort%canopy_trim = 0.8_r8 !starting with the canopy not fully expanded + temp_cohort%pft = ft + temp_cohort%hite = EDecophyscon%hgt_min(ft) + temp_cohort%dbh = Dbh(temp_cohort) + temp_cohort%bdead = Bdead(temp_cohort) + temp_cohort%balive = Bleaf(temp_cohort)*(1.0_r8 + EDPftvarcon_inst%froot_leaf(ft) & + + EDecophyscon%sapwood_ratio(ft)*temp_cohort%hite) + temp_cohort%bstore = EDecophyscon%cushion(ft)*(temp_cohort%balive/ (1.0_r8 + EDPftvarcon_inst%froot_leaf(ft) & + + EDecophyscon%sapwood_ratio(ft)*temp_cohort%hite)) + temp_cohort%n = currentPatch%area * currentPatch%seed_germination(ft)*hlm_freq_day & + / (temp_cohort%bdead+temp_cohort%balive+temp_cohort%bstore) + + if (t == 1)then + write(fates_log(),*) 'filling in cohorts where there are none left; this will break carbon balance', & + currentPatch%patchno,currentPatch%area + temp_cohort%n = 0.1_r8*currentPatch%area + write(fates_log(),*) 'cohort n',ft,temp_cohort%n + endif + + temp_cohort%laimemory = 0.0_r8 + if (EDPftvarcon_inst%season_decid(temp_cohort%pft) == 1.and.currentSite%status == 1)then + temp_cohort%laimemory = (1.0_r8/(1.0_r8 + EDPftvarcon_inst%froot_leaf(ft) + & + EDecophyscon%sapwood_ratio(ft)*temp_cohort%hite))*temp_cohort%balive + endif + if (EDPftvarcon_inst%stress_decid(temp_cohort%pft) == 1.and.currentSite%dstatus == 1)then + temp_cohort%laimemory = (1.0_r8/(1.0_r8 + EDPftvarcon_inst%froot_leaf(ft) + & + EDecophyscon%sapwood_ratio(ft)*temp_cohort%hite))*temp_cohort%balive + endif + + cohortstatus = currentSite%status + if (EDPftvarcon_inst%stress_decid(ft) == 1)then !drought decidous, override status. + cohortstatus = currentSite%dstatus + endif + + if (temp_cohort%n > 0.0_r8 )then + if ( DEBUG ) write(fates_log(),*) 'EDPhysiologyMod.F90 call create_cohort ' + call create_cohort(currentPatch, temp_cohort%pft, temp_cohort%n, temp_cohort%hite, temp_cohort%dbh, & + temp_cohort%balive, temp_cohort%bdead, temp_cohort%bstore, & + temp_cohort%laimemory, cohortstatus, temp_cohort%canopy_trim, currentPatch%NCL_p, & + bc_in) + + ! keep track of how many individuals were recruited for passing to history + currentSite%recruitment_rate(ft) = currentSite%recruitment_rate(ft) + temp_cohort%n + + endif + + enddo !pft loop + + deallocate(temp_cohort) ! delete temporary cohort + + end subroutine recruitment + + ! ============================================================================ + subroutine CWD_Input( currentPatch) + ! + ! !DESCRIPTION: + ! Generate litter fields from turnover. + ! + ! !USES: + use SFParamsMod , only : SF_val_CWD_frac + use EDParamsMod , only : ED_val_ag_biomass + + ! + ! !ARGUMENTS + type(ed_patch_type),intent(inout), target :: currentPatch + ! + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer :: currentCohort + integer :: c,p + real(r8) :: not_dead_n !projected remaining number of trees in understorey cohort after turnover + real(r8) :: dead_n !understorey dead tree density + integer :: pft + !---------------------------------------------------------------------- + + ! ================================================ + ! Other direct litter fluxes happen in phenology and in spawn_patches. + ! ================================================ + + currentCohort => currentPatch%shortest + + do while(associated(currentCohort)) + pft = currentCohort%pft + ! ================================================ + ! Litter from tissue turnover. KgC/m2/year + ! ================================================ + currentPatch%leaf_litter_in(pft) = currentPatch%leaf_litter_in(pft) + & + currentCohort%leaf_md * currentCohort%n/currentPatch%area !turnover + + currentPatch%root_litter_in(pft) = currentPatch%root_litter_in(pft) + & + currentCohort%root_md * currentCohort%n/currentPatch%area !turnover + currentPatch%leaf_litter_in(pft) = currentPatch%leaf_litter_in(pft) + & + currentCohort%leaf_litter * currentCohort%n/currentPatch%area/hlm_freq_day + + !daily leaf loss needs to be scaled up to the annual scale here. + + do c = 1,ncwd + currentPatch%cwd_AG_in(c) = currentPatch%cwd_AG_in(c) + currentCohort%woody_turnover * & + SF_val_CWD_frac(c) * currentCohort%n/currentPatch%area *ED_val_ag_biomass + currentPatch%cwd_BG_in(c) = currentPatch%cwd_BG_in(c) + currentCohort%woody_turnover * & + SF_val_CWD_frac(c) * currentCohort%n/currentPatch%area *(1.0_r8-ED_val_ag_biomass) + enddo + + if (currentCohort%canopy_layer > 1)then + + ! ================================================ + ! Litter fluxes for understorey mortality. KgC/m2/year + ! ================================================ + dead_n = -1.0_r8 * currentCohort%dndt / currentPatch%area + + currentPatch%leaf_litter_in(pft) = currentPatch%leaf_litter_in(pft) + & + (currentCohort%bl+currentCohort%leaf_litter/hlm_freq_day)* dead_n + currentPatch%root_litter_in(pft) = currentPatch%root_litter_in(pft) + & + (currentCohort%br+currentCohort%bstore) * dead_n + + do c = 1,ncwd + currentPatch%cwd_AG_in(c) = currentPatch%cwd_AG_in(c) + (currentCohort%bdead+currentCohort%bsw) * & + SF_val_CWD_frac(c) * dead_n * ED_val_ag_biomass + currentPatch%cwd_BG_in(c) = currentPatch%cwd_BG_in(c) + (currentCohort%bdead+currentCohort%bsw) * & + SF_val_CWD_frac(c) * dead_n * (1.0_r8-ED_val_ag_biomass) + + if (currentPatch%cwd_AG_in(c) < 0.0_r8)then + write(fates_log(),*) 'negative CWD in flux',currentPatch%cwd_AG_in(c), & + (currentCohort%bdead+currentCohort%bsw), dead_n + endif + enddo + + endif !canopy layer + + currentCohort => currentCohort%taller + + enddo ! end loop over cohorts + + do p = 1,numpft_ed + currentPatch%leaf_litter_in(p) = currentPatch%leaf_litter_in(p) + currentPatch%seed_decay(p) !KgC/m2/yr + enddo + + end subroutine CWD_Input + + ! ============================================================================ + subroutine fragmentation_scaler( currentPatch, bc_in) + ! + ! !DESCRIPTION: + ! Simple CWD fragmentation Model + ! FIX(SPM, 091914) this should be a function as it returns a value in + ! currentPatch%fragmentation_scaler + ! + ! !USES: + + use FatesSynchronizedParamsMod , only : FatesSynchronizedParamsInst + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + use FatesConstantsMod, only : pi => pi_const + ! + ! !ARGUMENTS + type(ed_patch_type), intent(inout) :: currentPatch + type(bc_in_type), intent(in) :: bc_in + + ! + ! !LOCAL VARIABLES: + logical :: use_century_tfunc = .false. + integer :: j + integer :: ifp ! Index of a FATES Patch "ifp" + real(r8) :: t_scalar + real(r8) :: w_scalar + real(r8) :: catanf ! hyperbolic temperature function from CENTURY + real(r8) :: catanf_30 ! hyperbolic temperature function from CENTURY + real(r8) :: t1 ! temperature argument + real(r8) :: Q10 ! temperature dependence + real(r8) :: froz_q10 ! separate q10 for frozen soil respiration rates. + ! default to same as above zero rates + !---------------------------------------------------------------------- + + catanf(t1) = 11.75_r8 +(29.7_r8 / pi) * atan( pi * 0.031_r8 * ( t1 - 15.4_r8 )) + catanf_30 = catanf(30._r8) + + ifp = currentPatch%patchno + + ! set "froz_q10" parameter + froz_q10 = FatesSynchronizedParamsInst%froz_q10 + Q10 = FatesSynchronizedParamsInst%Q10 + + if ( .not. use_century_tfunc ) then + !calculate rate constant scalar for soil temperature,assuming that the base rate constants + !are assigned for non-moisture limiting conditions at 25C. + if (bc_in%t_veg24_pa(ifp) >= tfrz) then + t_scalar = Q10**((bc_in%t_veg24_pa(ifp)-(tfrz+25._r8))/10._r8) + ! Q10**((t_soisno(c,j)-(tfrz+25._r8))/10._r8) + else + t_scalar = (Q10**(-25._r8/10._r8))*(froz_q10**((bc_in%t_veg24_pa(ifp)-tfrz)/10._r8)) + !Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-tfrz)/10._r8) + endif + else + ! original century uses an arctangent function to calculate the + ! temperature dependence of decomposition + t_scalar = max(catanf(bc_in%t_veg24_pa(ifp)-tfrz)/catanf_30,0.01_r8) + endif + + !Moisture Limitations + !BTRAN APPROACH - is quite simple, but max's out decomp at all unstressed + !soil moisture values, which is not realistic. + !litter decomp is proportional to water limitation on average... + w_scalar = sum(currentPatch%btran_ft(1:numpft_ed))/numpft_ed + + currentPatch%fragmentation_scaler = min(1.0_r8,max(0.0_r8,t_scalar * w_scalar)) + + end subroutine fragmentation_scaler + + ! ============================================================================ + subroutine cwd_out( currentSite, currentPatch, bc_in ) + ! + ! !DESCRIPTION: + ! Simple CWD fragmentation Model + ! spawn new cohorts of juveniles of each PFT + ! + ! !USES: + use SFParamsMod, only : SF_val_max_decomp + + ! + ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite + type(ed_patch_type), intent(inout), target :: currentPatch + type(bc_in_type), intent(in) :: bc_in + + ! + ! !LOCAL VARIABLES: + integer :: c,ft + !---------------------------------------------------------------------- + + currentPatch%root_litter_out(:) = 0.0_r8 + currentPatch%leaf_litter_out(:) = 0.0_r8 + + call fragmentation_scaler(currentPatch, bc_in) + + !Flux of coarse woody debris into decomposing litter pool. + + currentPatch%cwd_ag_out(1:ncwd) = 0.0_r8 + currentPatch%cwd_bg_out(1:ncwd) = 0.0_r8 + currentPatch%leaf_litter_out(1:numpft_ed) = 0.0_r8 + currentPatch%root_litter_out(1:numpft_ed) = 0.0_r8 + + do c = 1,ncwd + currentPatch%cwd_ag_out(c) = max(0.0_r8, currentPatch%cwd_ag(c) * & + SF_val_max_decomp(c+1) * currentPatch%fragmentation_scaler ) + currentPatch%cwd_bg_out(c) = max(0.0_r8, currentPatch%cwd_bg(c) * & + SF_val_max_decomp(c+1) * currentPatch%fragmentation_scaler ) + enddo + + ! this is the rate at which dropped leaves stop being part of the burnable pool and begin to be part of the + ! decomposing pool. This should probably be highly sensitive to moisture, but also to the type of leaf + ! thick leaves can dry out before they are decomposed, for example. + ! this section needs further scientific input. + + do ft = 1,numpft_ed + currentPatch%leaf_litter_out(ft) = max(0.0_r8,currentPatch%leaf_litter(ft)* SF_val_max_decomp(dl_sf) * & + currentPatch%fragmentation_scaler ) + currentPatch%root_litter_out(ft) = max(0.0_r8,currentPatch%root_litter(ft)* SF_val_max_decomp(dl_sf) * & + currentPatch%fragmentation_scaler ) + if ( currentPatch%leaf_litter_out(ft)<0.0_r8.or.currentPatch%root_litter_out(ft)<0.0_r8)then + write(fates_log(),*) 'root or leaf out is negative?',SF_val_max_decomp(dl_sf),currentPatch%fragmentation_scaler + endif + enddo + + !add up carbon going into fragmenting pools + currentSite%flux_out = currentSite%flux_out + sum(currentPatch%leaf_litter_out) * & + currentPatch%area *hlm_freq_day!kgC/site/day + currentSite%flux_out = currentSite%flux_out + sum(currentPatch%root_litter_out) * & + currentPatch%area *hlm_freq_day!kgC/site/day + currentSite%flux_out = currentSite%flux_out + sum(currentPatch%cwd_ag_out) * & + currentPatch%area *hlm_freq_day!kgC/site/day + currentSite%flux_out = currentSite%flux_out + sum(currentPatch%cwd_bg_out) * & + currentPatch%area *hlm_freq_day!kgC/site/day + + end subroutine cwd_out + + + + subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) + ! Created by Charlie Koven and Rosie Fisher, 2014-2015 + ! take the flux out of the fragmenting litter pools and port into the decomposing litter pools. + ! in this implementation, decomposing pools are assumed to be humus and non-flammable, whereas fragmenting pools + ! are assumed to be physically fragmenting but not respiring. This is a simplification, but allows us to + ! a) reconcile the need to track both chemical fractions (lignin, cellulose, labile) and size fractions (trunk, branch, etc.) + ! b) to impose a realistic delay on the surge of nutrients into the litter pools when large CWD is added to the system via mortality + + ! because of the different subgrid structure, this subroutine includes the functionality that in the big-leaf BGC model, is calculated in SoilBiogeochemVerticalProfileMod + + ! The ED code is resolved at a daily timestep, but all of the CN-BGC fluxes are passed in as derivatives per second, + ! and then accumulated in the CNStateUpdate routines. One way of doing this is to pass back the CN fluxes per second, + ! and keep them constant for the whole day (making sure they are not overwritten. + ! This means that the carbon gets passed back and forth between the photosynthesis code (fast timestepping) to the ED code (slow timestepping), back to the BGC code (fast timestepping). + ! This means that the state update for the litter pools and for the CWD pools occurs at different timescales. + + + use EDTypesMod, only : AREA + use EDTypesMod, only : numpft_ed + use FatesInterfaceMod, only : hlm_numlevdecomp_full + use FatesInterfaceMod, only : hlm_numlevdecomp + use SoilBiogeochemVerticalProfileMod, only: surfprof_exp + use EDPftvarcon, only : EDPftvarcon_inst + use FatesConstantsMod, only : sec_per_day + use EDParamsMod, only : ED_val_ag_biomass + use FatesInterfaceMod, only : bc_in_type, bc_out_type + use FatesInterfaceMod, only : hlm_use_vertsoilc + use FatesConstantsMod, only : itrue + use FatesGlobals, only : endrun => fates_endrun + use EDParamsMod , only : ED_val_cwd_flig, ED_val_cwd_fcel + + + ! INTERF-TODO: remove the control parameters: exponential_rooting_profile, + ! pftspecific_rootingprofile, rootprof_exp, surfprof_exp + ! + implicit none + ! + ! !ARGUMENTS + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type) , intent(in) :: bc_in(:) + type(bc_out_type) , intent(inout) :: bc_out(:) + ! + ! !LOCAL VARIABLES: + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort + type(ed_site_type), pointer :: cs + integer p,ci,j,s + real(r8) time_convert ! from year to seconds + real(r8) mass_convert ! ED uses kg, CLM uses g + integer :: begp,endp + integer :: begc,endc !bounds + !------------------------------------------------------------------------ + real(r8) :: cinput_rootfr(1:numpft_ed, 1:hlm_numlevdecomp_full) ! column by pft root fraction used for calculating inputs + real(r8) :: croot_prof_perpatch(1:hlm_numlevdecomp_full) + real(r8) :: surface_prof(1:hlm_numlevdecomp_full) + integer :: ft + real(r8) :: rootfr_tot(1:numpft_ed), biomass_bg_ft(1:numpft_ed) + real(r8) :: surface_prof_tot, leaf_prof_sum, stem_prof_sum, froot_prof_sum, biomass_bg_tot + real(r8) :: delta + + ! NOTE(bja, 201608) these were removed from clm in clm4_5_10_r187 + logical, parameter :: exponential_rooting_profile = .true. + logical, parameter :: pftspecific_rootingprofile = .true. + + ! NOTE(bja, 201608) as of clm4_5_10_r187 rootprof_exp is now a + ! private function level parameter in RootBiophysMod.F90::exponential_rootfr() + real(r8), parameter :: rootprof_exp = 3. ! how steep profile is + ! for root C inputs (1/ e-folding depth) (1/m) + + ! NOTE(bja, 201608) as of clm4_5_10_r187 rootprof_beta is now a + ! two dimensional array with the second dimension being water,1, + ! or carbon,2,. These are currently hard coded, but may be + ! overwritten by the namelist. + + ! Note cdk 2016/08 we actually want to use the carbon index here rather than the water index. + ! Doing so will be answer changing though so perhaps easiest to do this in steps. + integer, parameter :: rooting_profile_varindex_water = 1 + + real(r8) :: leaf_prof(1:nsites, 1:hlm_numlevdecomp) + real(r8) :: froot_prof(1:nsites, 1:numpft_ed, 1:hlm_numlevdecomp) + real(r8) :: croot_prof(1:nsites, 1:hlm_numlevdecomp) + real(r8) :: stem_prof(1:nsites, 1:hlm_numlevdecomp) + + delta = 0.001_r8 + !no of seconds in a year. + time_convert = 365.0_r8*sec_per_day + + ! number of grams in a kilogram + mass_convert = 1000._r8 + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! first calculate vertical profiles + ! define two types of profiles: + ! (1) a surface profile, for leaves and stem inputs, which is the same for each + ! pft but differs from one site to the next to avoid inputting any C into permafrost or bedrock + ! (2) a fine root profile, which is indexed by both site and pft, differs for + ! each pft and also from one site to the next to avoid inputting any C into permafrost or bedrock + ! (3) a coarse root profile, which is the root-biomass=weighted average of the fine root profiles + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (hlm_use_vertsoilc == itrue) then + + ! initialize profiles to zero + leaf_prof(1:nsites, :) = 0._r8 + froot_prof(1:nsites, 1:numpft_ed, :) = 0._r8 + stem_prof(1:nsites, :) = 0._r8 + + do s = 1,nsites + ! define a single shallow surface profile for surface additions (leaves, stems, and N deposition) + surface_prof(:) = 0._r8 + do j = 1, hlm_numlevdecomp + surface_prof(j) = exp(-surfprof_exp * bc_in(s)%z_sisl(j)) / bc_in(s)%dz_decomp_sisl(j) + end do + + cinput_rootfr(1:numpft_ed, :) = 0._r8 + + ! calculate pft-specific rooting profiles in the absence of permafrost or bedrock limitations + if ( exponential_rooting_profile ) then + if ( .not. pftspecific_rootingprofile ) then + ! define rooting profile from exponential parameters + do ft = 1, numpft_ed + do j = 1, hlm_numlevdecomp + cinput_rootfr(ft,j) = exp(-rootprof_exp * bc_in(s)%z_sisl(j)) / bc_in(s)%dz_decomp_sisl(j) + end do + end do + else + ! use beta distribution parameter from Jackson et al., 1996 + do ft = 1, numpft_ed + do j = 1, hlm_numlevdecomp + cinput_rootfr(ft,j) = & + ( EDPftvarcon_inst%rootprof_beta(ft, rooting_profile_varindex_water) ** & + (bc_in(s)%zi_sisl(j-1)*100._r8) - & + EDPftvarcon_inst%rootprof_beta(ft, rooting_profile_varindex_water) ** & + (bc_in(s)%zi_sisl(j)*100._r8) ) & + / bc_in(s)%dz_decomp_sisl(j) + end do + end do + endif + else + do ft = 1,numpft_ed + do j = 1, hlm_numlevdecomp + ! use standard CLM root fraction profiles; + cinput_rootfr(ft,j) = ( .5_r8*( & + exp(-EDPftvarcon_inst%roota_par(ft) * bc_in(s)%zi_sisl(j-1)) & + + exp(-EDPftvarcon_inst%rootb_par(ft) * bc_in(s)%zi_sisl(j-1)) & + - exp(-EDPftvarcon_inst%roota_par(ft) * bc_in(s)%zi_sisl(j)) & + - exp(-EDPftvarcon_inst%rootb_par(ft) * bc_in(s)%zi_sisl(j)))) & + / bc_in(s)%dz_decomp_sisl(j) + end do + end do + endif + + ! + ! now add permafrost constraint: integrate rootfr over active layer of soil site, + ! truncate below permafrost or bedrock table where present, and rescale so that integral = 1 + do ft = 1,numpft_ed + rootfr_tot(ft) = 0._r8 + end do + surface_prof_tot = 0._r8 + ! + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) + surface_prof_tot = surface_prof_tot + surface_prof(j) * bc_in(s)%dz_decomp_sisl(j) + end do + do ft = 1,numpft_ed + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) + rootfr_tot(ft) = rootfr_tot(ft) + cinput_rootfr(ft,j) * bc_in(s)%dz_decomp_sisl(j) + end do + end do + ! + ! rescale the fine root profile + do ft = 1,numpft_ed + if ( (bc_in(s)%max_rooting_depth_index_col > 0) .and. (rootfr_tot(ft) > 0._r8) ) then + ! where there is not permafrost extending to the surface, integrate the profiles over the active layer + ! this is equivalent to integrating over all soil layers outside of permafrost regions + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) + froot_prof(s,ft,j) = cinput_rootfr(ft,j) / rootfr_tot(ft) + end do + else + ! if fully frozen, or no roots, put everything in the top layer + froot_prof(s,ft,1) = 1._r8/bc_in(s)%dz_decomp_sisl(1) + endif + end do + ! + ! rescale the shallow profiles + if ( (bc_in(s)%max_rooting_depth_index_col > 0) .and. (surface_prof_tot > 0._r8) ) then + ! where there is not permafrost extending to the surface, integrate the profiles over the active layer + ! this is equivalent to integrating over all soil layers outside of permafrost regions + do j = 1, min(max(bc_in(s)%max_rooting_depth_index_col, 1), hlm_numlevdecomp) + ! set all surface processes to shallower profile + leaf_prof(s,j) = surface_prof(j)/ surface_prof_tot + stem_prof(s,j) = surface_prof(j)/ surface_prof_tot + end do + else + ! if fully frozen, or no roots, put everything in the top layer + leaf_prof(s,1) = 1._r8/bc_in(s)%dz_decomp_sisl(1) + stem_prof(s,1) = 1._r8/bc_in(s)%dz_decomp_sisl(1) + do j = 2, hlm_numlevdecomp + leaf_prof(s,j) = 0._r8 + stem_prof(s,j) = 0._r8 + end do + endif + end do + + else + + ! for one layer decomposition model, set profiles to unity + leaf_prof(1:nsites, :) = 1._r8 + froot_prof(1:nsites, 1:numpft_ed, :) = 1._r8 + stem_prof(1:nsites, :) = 1._r8 + + end if + + ! sanity check to ensure they integrate to 1 + do s = 1, nsites + ! check the leaf and stem profiles + leaf_prof_sum = 0._r8 + stem_prof_sum = 0._r8 + do j = 1, hlm_numlevdecomp + leaf_prof_sum = leaf_prof_sum + leaf_prof(s,j) * bc_in(s)%dz_decomp_sisl(j) + stem_prof_sum = stem_prof_sum + stem_prof(s,j) * bc_in(s)%dz_decomp_sisl(j) + end do + if ( ( abs(stem_prof_sum - 1._r8) > delta ) .or. ( abs(leaf_prof_sum - 1._r8) > delta ) ) then + write(fates_log(), *) 'profile sums: ', leaf_prof_sum, stem_prof_sum + write(fates_log(), *) 'surface_prof: ', surface_prof + write(fates_log(), *) 'surface_prof_tot: ', surface_prof_tot + write(fates_log(), *) 'leaf_prof: ', leaf_prof(s,:) + write(fates_log(), *) 'stem_prof: ', stem_prof(s,:) + write(fates_log(), *) 'max_rooting_depth_index_col: ', bc_in(s)%max_rooting_depth_index_col + write(fates_log(), *) 'bc_in(s)%dz_decomp_sisl: ', bc_in(s)%dz_decomp_sisl + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + ! now check each fine root profile + do ft = 1,numpft_ed + froot_prof_sum = 0._r8 + do j = 1, hlm_numlevdecomp + froot_prof_sum = froot_prof_sum + froot_prof(s,ft,j) * bc_in(s)%dz_decomp_sisl(j) + end do + if ( ( abs(froot_prof_sum - 1._r8) > delta ) ) then + write(fates_log(), *) 'profile sums: ', froot_prof_sum + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + end do + end do + + ! zero the site-level C input variables + do s = 1, nsites + do j = 1, hlm_numlevdecomp + bc_out(s)%FATES_c_to_litr_lab_c_col(j) = 0._r8 + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = 0._r8 + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = 0._r8 + croot_prof(s,j) = 0._r8 + end do + end do + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! now disaggregate the inputs vertically, using the vertical profiles + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + do s = 1,nsites + + ! do g = bounds%begg,bounds%endg + ! if (firstsoilpatch(g) >= 0 .and. ed_allsites_inst(g)%istheresoil) then + currentPatch => sites(s)%oldest_patch + + do while(associated(currentPatch)) + + ! the CWD pools lose information about which PFT they came from; for the stems this doesn't matter as they all have the same profile, + ! however for the coarse roots they may have different profiles. to approximately recover this information, loop over all cohorts in patch + ! to calculate the total root biomass in that patch of each pft, and then rescale the croot_prof as the weighted average of the froot_prof + biomass_bg_ft(1:numpft_ed) = 0._r8 + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + biomass_bg_ft(currentCohort%pft) = biomass_bg_ft(currentCohort%pft) + & + currentCohort%b * (currentCohort%n / currentPatch%area) * (1.0_r8-ED_val_ag_biomass) + currentCohort => currentCohort%shorter + enddo !currentCohort + ! + biomass_bg_tot = 0._r8 + do ft = 1,numpft_ed + biomass_bg_tot = biomass_bg_tot + biomass_bg_ft(ft) + end do + ! + do j = 1, hlm_numlevdecomp + ! zero this for each patch + croot_prof_perpatch(j) = 0._r8 + end do + ! + if ( biomass_bg_tot .gt. 0._r8) then + do ft = 1,numpft_ed + do j = 1, hlm_numlevdecomp + croot_prof_perpatch(j) = croot_prof_perpatch(j) + froot_prof(s,ft,j) * biomass_bg_ft(ft) / biomass_bg_tot + end do + end do + else ! no biomass + croot_prof_perpatch(1) = 1./bc_in(s)%dz_decomp_sisl(1) + end if + + ! + ! add croot_prof as weighted average (weighted by patch area) of croot_prof_perpatch + do j = 1, hlm_numlevdecomp + croot_prof(s, j) = croot_prof(s, j) + croot_prof_perpatch(j) * currentPatch%area / AREA + end do + ! + ! now disaggregate, vertically and by decomposition substrate type, the actual fluxes from CWD and litter pools + ! + ! do c = 1, ncwd + ! write(fates_log(),*)'cdk CWD_AG_out', c, currentpatch%CWD_AG_out(c), ED_val_cwd_fcel, currentpatch%area/AREA + ! write(fates_log(),*)'cdk CWD_BG_out', c, currentpatch%CWD_BG_out(c), ED_val_cwd_fcel, currentpatch%area/AREA + ! end do + ! do ft = 1,numpft_ed + ! write(fates_log(),*)'cdk leaf_litter_out', ft, currentpatch%leaf_litter_out(ft), ED_val_cwd_fcel, currentpatch%area/AREA + ! write(fates_log(),*)'cdk root_litter_out', ft, currentpatch%root_litter_out(ft), ED_val_cwd_fcel, currentpatch%area/AREA + ! end do + ! ! + ! CWD pools fragmenting into decomposing litter pools. + do ci = 1, ncwd + do j = 1, hlm_numlevdecomp + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & + currentpatch%CWD_AG_out(ci) * ED_val_cwd_fcel * currentpatch%area/AREA * stem_prof(s,j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & + currentpatch%CWD_AG_out(ci) * ED_val_cwd_flig * currentpatch%area/AREA * stem_prof(s,j) + ! + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & + currentpatch%CWD_BG_out(ci) * ED_val_cwd_fcel * currentpatch%area/AREA * croot_prof_perpatch(j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & + currentpatch%CWD_BG_out(ci) * ED_val_cwd_flig * currentpatch%area/AREA * croot_prof_perpatch(j) + end do + end do + + ! leaf and fine root pools. + do ft = 1,numpft_ed + do j = 1, hlm_numlevdecomp + bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + & + currentpatch%leaf_litter_out(ft) * EDPftvarcon_inst%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & + currentpatch%leaf_litter_out(ft) * EDPftvarcon_inst%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & + currentpatch%leaf_litter_out(ft) * EDPftvarcon_inst%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) + ! + bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + & + currentpatch%root_litter_out(ft) * EDPftvarcon_inst%fr_flab(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & + currentpatch%root_litter_out(ft) * EDPftvarcon_inst%fr_fcel(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & + currentpatch%root_litter_out(ft) * EDPftvarcon_inst%fr_flig(ft) * currentpatch%area/AREA * froot_prof(s,ft,j) + ! + !! and seed_decay too. for now, use the same lability fractions as for leaf litter + bc_out(s)%FATES_c_to_litr_lab_c_col(j) = bc_out(s)%FATES_c_to_litr_lab_c_col(j) + & + currentpatch%seed_decay(ft) * EDPftvarcon_inst%lf_flab(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_cel_c_col(j) = bc_out(s)%FATES_c_to_litr_cel_c_col(j) + & + currentpatch%seed_decay(ft) * EDPftvarcon_inst%lf_fcel(ft) * currentpatch%area/AREA * leaf_prof(s,j) + bc_out(s)%FATES_c_to_litr_lig_c_col(j) = bc_out(s)%FATES_c_to_litr_lig_c_col(j) + & + currentpatch%seed_decay(ft) * EDPftvarcon_inst%lf_flig(ft) * currentpatch%area/AREA * leaf_prof(s,j) + ! + enddo + end do + + currentPatch => currentPatch%younger + end do !currentPatch + + end do ! do sites(s) + + do s = 1, nsites + do j = 1, hlm_numlevdecomp + ! time unit conversion + bc_out(s)%FATES_c_to_litr_lab_c_col(j)=bc_out(s)%FATES_c_to_litr_lab_c_col(j) * mass_convert / time_convert + bc_out(s)%FATES_c_to_litr_cel_c_col(j)=bc_out(s)%FATES_c_to_litr_cel_c_col(j) * mass_convert / time_convert + bc_out(s)%FATES_c_to_litr_lig_c_col(j)=bc_out(s)%FATES_c_to_litr_lig_c_col(j) * mass_convert / time_convert + end do + end do + + ! write(fates_log(),*)'cdk FATES_c_to_litr_lab_c: ', FATES_c_to_litr_lab_c + ! write_col(fates_log(),*)'cdk FATES_c_to_litr_cel_c: ', FATES_c_to_litr_cel_c + ! write_col(fates_log(),*)'cdk FATES_c_to_litr_lig_c: ', FATES_c_to_litr_lig_c + ! write_col(fates_log(),*)'cdk hlm_numlevdecomp_full, bounds%begc, bounds%endc: ', hlm_numlevdecomp_full, bounds%begc, bounds%endc + ! write(fates_log(),*)'cdk leaf_prof: ', leaf_prof + ! write(fates_log(),*)'cdk stem_prof: ', stem_prof + ! write(fates_log(),*)'cdk froot_prof: ', froot_prof + ! write(fates_log(),*)'cdk croot_prof_perpatch: ', croot_prof_perpatch + ! write(fates_log(),*)'cdk croot_prof: ', croot_prof + + end subroutine flux_into_litter_pools + +end module EDPhysiologyMod diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 new file mode 100644 index 00000000..f782a219 --- /dev/null +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -0,0 +1,116 @@ +module EDAccumulateFluxesMod + + !------------------------------------------------------------------------------ + ! !DESCRIPTION: + ! This routine accumulates NPP, GPP and respiration of each cohort over the course of each 24 hour period. + ! The fluxes are stored per cohort, and the npp_tstep (etc) fluxes are calcualted in EDPhotosynthesis + ! This routine cannot be in EDPhotosynthesis because EDPhotosynthesis is a loop and therefore would + ! erroneously add these things up multiple times. + ! Rosie Fisher. March 2014. + ! + ! !USES: + use FatesGlobals, only : fates_endrun + use FatesGlobals, only : fates_log + use shr_log_mod , only : errMsg => shr_log_errMsg + use FatesConstantsMod , only : r8 => fates_r8 + implicit none + private + ! + public :: AccumulateFluxes_ED + + logical :: DEBUG = .false. ! for debugging this module + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + !------------------------------------------------------------------------------ + + subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) + + ! + ! !DESCRIPTION: + ! see above + ! + ! !USES: + + use EDTypesMod , only : ed_patch_type, ed_cohort_type, & + ed_site_type, AREA + use FatesInterfaceMod , only : bc_in_type,bc_out_type + + ! + ! !ARGUMENTS + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + type(bc_in_type), intent(in) :: bc_in(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + real(r8), intent(in) :: dt_time ! timestep interval + ! + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer :: ccohort ! current cohort + type(ed_patch_type) , pointer :: cpatch ! current patch + integer :: iv !leaf layer + integer :: c ! clm/alm column + integer :: s ! ed site + integer :: ifp ! index fates patch + real(r8):: n_perm2 + !---------------------------------------------------------------------- + + do s = 1, nsites + + ifp = 0 + sites(s)%npp = 0.0_r8 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ifp = ifp+1 + + if( bc_in(s)%filter_photo_pa(ifp) == 3 ) then + ccohort => cpatch%shortest + do while(associated(ccohort)) + + ! Accumulate fluxes from hourly to daily values. + ! _tstep fluxes are KgC/indiv/timestep _acc are KgC/indiv/day + + if ( DEBUG ) then + + write(fates_log(),*) 'EDAccumFlux 64 ',ccohort%npp_tstep + write(fates_log(),*) 'EDAccumFlux 66 ',ccohort%gpp_tstep + write(fates_log(),*) 'EDAccumFlux 67 ',ccohort%resp_tstep + + endif + + ccohort%npp_acc = ccohort%npp_acc + ccohort%npp_tstep + ccohort%gpp_acc = ccohort%gpp_acc + ccohort%gpp_tstep + ccohort%resp_acc = ccohort%resp_acc + ccohort%resp_tstep + + !----- THE FOLLOWING IS ONLY IMPLEMENTED TEMPORARILY FOR B4B reproducibility + !----- ALSO, THERE IS NO REASON TO USE THE ISNEW FLAG HERE + if ((cpatch%area .gt. 0._r8) .and. (cpatch%total_canopy_area .gt. 0._r8)) then + n_perm2 = ccohort%n/AREA + else + n_perm2 = 0.0_r8 + endif + if ( .not. ccohort%isnew ) then + sites(s)%npp = sites(s)%npp + ccohort%npp_tstep * n_perm2 * 1.e3_r8 / dt_time + endif + + do iv=1,ccohort%nv + if(ccohort%year_net_uptake(iv) == 999._r8)then ! note that there were leaves in this layer this year. + ccohort%year_net_uptake(iv) = 0._r8 + end if + ccohort%year_net_uptake(iv) = ccohort%year_net_uptake(iv) + ccohort%ts_net_uptake(iv) + enddo + + ccohort => ccohort%taller + enddo ! while(associated(ccohort)) + end if + cpatch => cpatch%younger + end do ! while(associated(cpatch)) + end do + return + + end subroutine AccumulateFluxes_ED + +end module EDAccumulateFluxesMod + diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 new file mode 100644 index 00000000..229008b6 --- /dev/null +++ b/biogeophys/EDBtranMod.F90 @@ -0,0 +1,353 @@ +module EDBtranMod + + !------------------------------------------------------------------------------------- + ! Description: + ! + ! ------------------------------------------------------------------------------------ + + use EDPftvarcon , only : EDPftvarcon_inst + use FatesConstantsMod , only : tfrz => t_water_freeze_k_1atm + use EDTypesMod , only : ed_site_type, & + ed_patch_type, & + ed_cohort_type, & + numpft_ed + use FatesInterfaceMod , only : hlm_numlevgrnd + use shr_kind_mod , only : r8 => shr_kind_r8 + use FatesInterfaceMod , only : bc_in_type, & + bc_out_type + use EDTypesMod , only : use_fates_plant_hydro + use FatesGlobals , only : fates_log + + ! + implicit none + private + + public :: btran_ed + public :: get_active_suction_layers + +contains + + ! ==================================================================================== + + logical function check_layer_water(h2o_liq_vol, tempk) + + implicit none + ! Arguments + real(r8),intent(in) :: h2o_liq_vol + real(r8),intent(in) :: tempk + + check_layer_water = .false. + + if ( h2o_liq_vol .gt. 0._r8 ) then + if ( tempk .gt. tfrz-2._r8) then + check_layer_water = .true. + end if + end if + return + end function check_layer_water + + ! ===================================================================================== + + subroutine get_active_suction_layers(nsites, sites, bc_in, bc_out) + + ! Arguments + + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + + ! !LOCAL VARIABLES: + integer :: s ! site + integer :: j ! soil layer + !------------------------------------------------------------------------------ + + do s = 1,nsites + if (bc_in(s)%filter_btran) then + do j = 1,hlm_numlevgrnd + bc_out(s)%active_suction_gl(j) = check_layer_water( bc_in(s)%h2o_liqvol_gl(j),bc_in(s)%tempk_gl(j) ) + end do + else + bc_out(s)%active_suction_gl(:) = .false. + end if + end do + + end subroutine get_active_suction_layers + + ! ===================================================================================== + + subroutine btran_ed( nsites, sites, bc_in, bc_out) + + use FatesPlantHydraulicsMod, only : BTranForHLMDiagnosticsFromCohortHydr + + + ! --------------------------------------------------------------------------------- + ! Calculate the transpiration wetness function (BTRAN) and the root uptake + ! distribution (ROOTR). + ! Boundary conditions in: bc_in(s)%eff_porosity_gl(j) unfrozen porosity + ! bc_in(s)%watsat_gl(j) porosity + ! bc_in(s)%active_uptake_gl(j) frozen/not frozen + ! bc_in(s)%smp_gl(j) suction + ! Boundary conditions out: bc_out(s)%rootr_pagl root uptake distribution + ! bc_out(s)%btran_pa wetness factor + ! --------------------------------------------------------------------------------- + + ! Arguments + + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + + ! + ! !LOCAL VARIABLES: + type(ed_patch_type),pointer :: cpatch ! Current Patch Pointer + type(ed_cohort_type),pointer :: ccohort ! Current cohort pointer + integer :: s ! site + integer :: j ! soil layer + integer :: ifp ! patch vector index for the site + integer :: ft ! plant functional type index + real(r8) :: smp_node ! matrix potential + real(r8) :: rresis ! suction limitation to transpiration independent + ! of root density + real(r8) :: pftgs(numpft_ed) ! pft weighted stomatal conductance s/m + real(r8) :: temprootr + real(r8) :: balive_patch + !------------------------------------------------------------------------------ + + associate( & + smpsc => EDPftvarcon_inst%smpsc , & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS + smpso => EDPftvarcon_inst%smpso & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS + ) + + do s = 1,nsites + + bc_out(s)%rootr_pagl(:,:) = 0._r8 + + ifp = 0 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ifp=ifp+1 + + ! THIS SHOULD REALLY BE A COHORT LOOP ONCE WE HAVE rootfr_ft FOR COHORTS (RGK) + + do ft = 1,numpft_ed + cpatch%btran_ft(ft) = 0.0_r8 + do j = 1,hlm_numlevgrnd + + ! Calculations are only relevant where liquid water exists + ! see clm_fates%wrap_btran for calculation with CLM/ALM + + if ( check_layer_water(bc_in(s)%h2o_liqvol_gl(j),bc_in(s)%tempk_gl(j)) ) then + + smp_node = max(smpsc(ft), bc_in(s)%smp_gl(j)) + + rresis = min( (bc_in(s)%eff_porosity_gl(j)/bc_in(s)%watsat_gl(j))* & + (smp_node - smpsc(ft)) / (smpso(ft) - smpsc(ft)), 1._r8) + + cpatch%rootr_ft(ft,j) = cpatch%rootfr_ft(ft,j)*rresis + + ! root water uptake is not linearly proportional to root density, + ! to allow proper deep root funciton. Replace with equations from SPA/Newman. FIX(RF,032414) + ! cpatch%rootr_ft(ft,j) = cpatch%rootfr_ft(ft,j)**0.3*rresis_ft(ft,j)/ & + ! sum(cpatch%rootfr_ft(ft,1:nlevgrnd)**0.3) + cpatch%btran_ft(ft) = cpatch%btran_ft(ft) + cpatch%rootr_ft(ft,j) + + else + cpatch%rootr_ft(ft,j) = 0._r8 + end if + + end do !j + + ! Normalize root resistances to get layer contribution to ET + do j = 1,hlm_numlevgrnd + if (cpatch%btran_ft(ft) > 0.0_r8) then + cpatch%rootr_ft(ft,j) = cpatch%rootr_ft(ft,j)/cpatch%btran_ft(ft) + else + cpatch%rootr_ft(ft,j) = 0._r8 + end if + end do + + end do !PFT + + ! PFT-averaged point level root fraction for extraction purposese. + ! This probably needs to be weighted by actual transpiration from each pft. FIX(RF,032414). + pftgs(:) = 0._r8 + ccohort => cpatch%tallest + do while(associated(ccohort)) + pftgs(ccohort%pft) = pftgs(ccohort%pft) + ccohort%gscan * ccohort%n + ccohort => ccohort%shorter + enddo + + ! Process the boundary output, this is necessary for calculating the soil-moisture + ! sink term across the different layers in driver/host. Photosynthesis will + ! pass the host a total transpiration for the patch. This needs rootr to be + ! distributed over the soil layers. + + do j = 1,hlm_numlevgrnd + bc_out(s)%rootr_pagl(ifp,j) = 0._r8 + do ft = 1,numpft_ed + if(sum(pftgs) > 0._r8)then !prevent problem with the first timestep - might fail + !bit-retart test as a result? FIX(RF,032414) + bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j) + & + cpatch%rootr_ft(ft,j) * pftgs(ft)/sum(pftgs) + else + bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j) + & + cpatch%rootr_ft(ft,j) * 1./numpft_ed + end if + enddo + enddo + + ! Calculate the BTRAN that is passed back to the HLM + ! used only for diagnostics. If plant hydraulics is turned off + ! we are using the patchxpft level btran calculation + + if(.not.use_fates_plant_hydro) then + !weight patch level output BTRAN for the + bc_out(s)%btran_pa(ifp) = 0.0_r8 + do ft = 1,numpft_ed + if(sum(pftgs) > 0._r8)then !prevent problem with the first timestep - might fail + !bit-retart test as a result? FIX(RF,032414) + bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * pftgs(ft)/sum(pftgs) + else + bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * 1./numpft_ed + end if + enddo + end if + + temprootr = sum(bc_out(s)%rootr_pagl(ifp,1:hlm_numlevgrnd)) + + if(abs(1.0_r8-temprootr) > 1.0e-10_r8 .and. temprootr > 1.0e-10_r8)then + write(fates_log(),*) 'error with rootr in canopy fluxes',temprootr,sum(pftgs) + do j = 1,hlm_numlevgrnd + bc_out(s)%rootr_pagl(ifp,j) = bc_out(s)%rootr_pagl(ifp,j)/temprootr + enddo + end if + + cpatch => cpatch%younger + end do + + end do + + if(use_fates_plant_hydro) then + call BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) + end if + + end associate + + end subroutine btran_ed + + ! ========================================================================================= + + !--------------------------------------------------------------------------------------- + ! SPA based recalculation of BTRAN and water uptake. + !--------------------------------------------------------------------------------------- + +! if (SPA_soil) then ! normal case don't run this. +! rootr(p,:) = 0._r8 +! do FT = 1,numpft_ed + +! ! Soil Physics +! do j = 1,nlevgrnd +! ! CLM water retention curve. Clapp and Hornberger equation. +! s1 = max(h2osoi_vol(c,j)/watsat(c,j), 0.01_r8) +! s1 = min(1.0_r8,s1) +! smp_node = -sucsat(c,j)*s1**(-bsw(c,j)) +! swp_mpa(j) = smp_node *10.0_r8/1000000.0_r8 !convert from mm to Mpa + +! ! CLM hydraulic conductivity curve. +! ! As opposed to the Richard's equation solution in SoilHydrology.Mod +! ! the conductivity here is defined in the middle of the layer in question, not at the edge... +! xksat = 0.0070556_r8 * (10._r8**(-0.884_r8+0.0153_r8*sand(p)) ) +! hk(j) = xksat*s1**(2._r8*bsw(c,j)+2._r8) !removed the ice from here to avoid 1st ts crashing +! enddo + +! ! Root resistance +! rootxsecarea=3.14159*rootrad**2 +! do j = 1,nlevgrnd +! rootmass(j) = EDecophyscon%soilbeta(FT) * cpatch%rootfr_ft(FT,j) +! rootlength(j) = rootmass(j)/(rootdens*rootxsecarea) !m m-3 soil +! Lsoil(j) = hk(j)/1000/head !converts from mms-1 to ms-1 and then to m2 s-1 MPa-1 +! if(Lsoil(j) < 1e-35_r8.or.cpatch%rootfr_ft(ft,j) <= 0.0_r8)then !prevent floating point error +! soilr_z(j) = 1e35_r8 +! soilr2(j) = 1e35_r8 +! else +! ! Soil-to-root water uptake from Newman (1969). +! rs = sqrt (1._r8 / (rootlength(j) * pi)) +! soilr1(j) = log(rs/rootrad) / (2.0_r8 * pi * rootlength(j) * Lsoil(j) * dz(c,j)) +! ! convert from MPa s m2 m-3 to MPa s m2 mmol-1 +! soilr1(j) = soilr1(j) * 1E-6_r8 * 18_r8 * 0.001_r8 +! ! second component of below ground resistance is related to root hydraulics +! soilr2(j) = EDecophyscon%rootresist(FT)/(rootmass(j)*dz(c,j)) +! soilr_z(j) = soilr1(j)+soilr2(j) +! end if +! enddo + + ! Aggregate soil layers +! totestevap=0._r8 +! weighted_SWP=0._r8 +! estevap=0._r8 +! fraction_uptake=0._r8 +! canopy_soil_resistance=0._r8 !Reset Counters +! totmaxevap = 0._r8 + + ! Estimated max transpiration from LWP gradient / soil resistance +! do j = 1,nlevgrnd +! estevap(j) = (swp_mpa(j) - minlwp)/(soilr_z(j)) +! estevap(j) = max(0._r8,estevap(j)) ! no negative uptake +! maxevap(j) = (0.0_r8 - minlwp)/(soilr2(j)) +! enddo +! totestevap = sum(estevap) +! totmaxevap = sum(maxevap) + + ! Weighted soil water potential +! do j = 1,nlevgrnd +! if(totestevap > 0._r8)then +! fraction_uptake(j) = estevap(j)/totestevap !Fraction of total ET taken from this soil layer +! else +! estevap(j) = 0._r8 +! fraction_uptake(j)=1._r8/nlevgrnd +! end if +! weighted_SWP = weighted_SWP + swp_mpa(j) * estevap(j) +! enddo + +! if(totestevap > 0._r8)then +! weighted_swp = weighted_swp/totestevap +! ! weight SWP for the total evaporation +! else +! write(fates_log(),*) 'empty soil', totestevap +! ! error check +! weighted_swp = minlwp +! end if + + ! Weighted soil-root resistance. Aggregate the conductances (1/soilR) for each soil layer +! do iv = 1,nv !leaf layers +! fleaf = 1.0_r8/nv +! do j = 1,nlevgrnd !root layers +! ! Soil resistance for each canopy layer is related to leaf area +! ! The conductance of the root system to the +! ! whole canopy is reduced by the fraction of leaves in this layer... +! canopy_soil_resistance(iv) = canopy_soil_resistance(iv)+fleaf * 1.0_r8/(soilr_z(j)) +! enddo +! ! Turn aggregated conductance back into resistance. mmol MPa-1 s-1 m-2 to MPa s m2 mmol-1 +! canopy_soil_resistance(iv) = 1./canopy_soil_resistance(iv) +! enddo +! +! cpatch%btran_ft(FT) = totestevap/totmaxevap +! do j = 1,nlevgrnd +! if(sum(pftgs) > 0._r8)then !prevent problem with the first timestep - might fail +! !bit-retart test as a result? FIX(RF,032414) +! rootr(p,j) = rootr(p,j) + fraction_uptake(j) * pftgs(ft)/sum(pftgs) +! else +! rootr(p,j) = rootr(p,j) + fraction_uptake(j) * 1./numpft_ed +! end if +! enddo +! enddo !pft loop +! end if ! + !--------------------------------------------------------------------------------------- + ! end of SPA based recalculation of BTRAN and water uptake. + !--------------------------------------------------------------------------------------- + + + +end module EDBtranMod diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 new file mode 100644 index 00000000..9ab4392c --- /dev/null +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -0,0 +1,1104 @@ +module EDSurfaceRadiationMod + + !------------------------------------------------------------------------------------- + ! EDSurfaceRadiation + ! + ! This module contains function and type definitions for all things related + ! to radiative transfer in ED modules at the land surface. + ! + !------------------------------------------------------------------------------------- + +#include "shr_assert.h" + + use EDTypesMod , only : ed_patch_type, ed_site_type + use EDTypesMod , only : numpft_ed + use EDTypesMod , only : maxPatchesPerSite + use FatesConstantsMod , only : r8 => fates_r8 + use FatesInterfaceMod , only : bc_in_type + use FatesInterfaceMod , only : bc_out_type + use FatesInterfaceMod , only : hlm_numSWb + use EDTypesMod , only : maxSWb + use EDTypesMod , only : nclmax + use EDTypesMod , only : numpft_ed + use EDTypesMod , only : nlevleaf + use EDCanopyStructureMod, only: calc_areaindex + use FatesGlobals , only : fates_log + + ! CIME globals + use shr_log_mod , only : errMsg => shr_log_errMsg + + implicit none + + private + public :: ED_Norman_Radiation ! Surface albedo and two-stream fluxes + public :: ED_SunShadeFracs + + logical :: DEBUG = .false. ! for debugging this module + + + real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + (/ 0.80_r8, 0.55_r8 /) + + ! INTERF-TODO: THIS NEEDS SOME CONSISTENCY AND SHOULD BE SET IN THE INTERFACE + ! WITH OTHER DIMENSIONS + integer, parameter :: ipar = 1 ! The band index for PAR + +contains + + subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) + ! + + ! + ! !USES: + use EDPftvarcon , only : EDPftvarcon_inst + use EDtypesMod , only : ed_patch_type + use EDTypesMod , only : ed_site_type + + + ! !ARGUMENTS: + + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) ! FATES site vector + type(bc_in_type), intent(in) :: bc_in(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + + ! !LOCAL VARIABLES: + ! ============================================================================ + ! ED/NORMAN RADIATION DECS + ! ============================================================================ + type (ed_patch_type) , pointer :: currentPatch + integer :: radtype, L, ft, j, ifp + integer :: iter ! Iteration index + integer :: irep ! Flag to exit iteration loop + real(r8) :: sb + real(r8) :: error ! Error check + real(r8) :: down_rad, up_rad ! Iterative solution do Dif_dn and Dif_up + real(r8) :: ftweight(nclmax,numpft_ed,nlevleaf) + real(r8) :: k_dir(numpft_ed) ! Direct beam extinction coefficient + real(r8) :: tr_dir_z(nclmax,numpft_ed,nlevleaf) ! Exponential transmittance of direct beam radiation through a single layer + real(r8) :: tr_dif_z(nclmax,numpft_ed,nlevleaf) ! Exponential transmittance of diffuse radiation through a single layer + real(r8) :: forc_dir(maxPatchesPerSite,maxSWb) + real(r8) :: forc_dif(maxPatchesPerSite,maxSWb) + real(r8) :: weighted_dir_tr(nclmax) + real(r8) :: weighted_fsun(nclmax) + real(r8) :: weighted_dif_ratio(nclmax,maxSWb) + real(r8) :: weighted_dif_down(nclmax) + real(r8) :: weighted_dif_up(nclmax) + real(r8) :: refl_dif(nclmax,numpft_ed,nlevleaf,maxSWb) ! Term for diffuse radiation reflected by laye + real(r8) :: tran_dif(nclmax,numpft_ed,nlevleaf,maxSWb) ! Term for diffuse radiation transmitted by layer + real(r8) :: dif_ratio(nclmax,numpft_ed,nlevleaf,maxSWb) ! Ratio of upward to forward diffuse fluxes + real(r8) :: Dif_dn(nclmax,numpft_ed,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) + real(r8) :: Dif_up(nclmax,numpft_ed,nlevleaf) ! Upward diffuse flux above canopy layer J (W/m**2 ground area) + real(r8) :: lai_change(nclmax,numpft_ed,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) + real(r8) :: f_not_abs(numpft_ed,maxSWb) ! Fraction reflected + transmitted. 1-absorbtion. + real(r8) :: Abs_dir_z(numpft_ed,nlevleaf) + real(r8) :: Abs_dif_z(numpft_ed,nlevleaf) + real(r8) :: abs_rad(maxSWb) !radiation absorbed by soil + real(r8) :: tr_soili ! Radiation transmitted to the soil surface. + real(r8) :: tr_soild ! Radiation transmitted to the soil surface. + real(r8) :: phi1b(maxPatchesPerSite,numpft_ed) ! Radiation transmitted to the soil surface. + real(r8) :: phi2b(maxPatchesPerSite,numpft_ed) + real(r8) :: laisum ! cumulative lai+sai for canopy layer (at middle of layer) + real(r8) :: angle + + real(r8),parameter :: tolerance = 0.000000001_r8 + real(r8), parameter :: pi = 3.141592654 ! PI + + real(r8) :: denom + real(r8) :: lai_reduction(2) + + integer :: fp,iv,s ! array indices + integer :: ib ! waveband number + real(r8) :: cosz ! 0.001 <= coszen <= 1.000 + real(r8) :: chil(maxPatchesPerSite) ! -0.4 <= xl <= 0.6 + real(r8) :: gdir(maxPatchesPerSite) ! leaf projection in solar direction (0 to 1) + + !----------------------------------------------------------------------- + + associate(& + rhol => EDPftvarcon_inst%rhol , & ! Input: [real(r8) (:) ] leaf reflectance: 1=vis, 2=nir + rhos => EDPftvarcon_inst%rhos , & ! Input: [real(r8) (:) ] stem reflectance: 1=vis, 2=nir + taul => EDPftvarcon_inst%taul , & ! Input: [real(r8) (:) ] leaf transmittance: 1=vis, 2=nir + taus => EDPftvarcon_inst%taus , & ! Input: [real(r8) (:) ] stem transmittance: 1=vis, 2=nir + xl => EDPftvarcon_inst%xl) ! Input: [real(r8) (:) ] ecophys const - leaf/stem orientation index + +! albd => surfalb_inst%albd_patch , & ! Output: [real(r8) (:,:) ] surface albedo (direct) (USED IN LND2ATM,BALANCE_CHECK) +! albi => surfalb_inst%albi_patch , & ! Output: [real(r8) (:,:) ] surface albedo (diffuse) (LND2ATM,BALANCE_CHECK) +! fabd => surfalb_inst%fabd_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by canopy per unit direct flux (BALANCE_CHECK) +! fabi => surfalb_inst%fabi_patch , & ! Output: [real(r8) (:,:) ] flux absorbed by canopy per unit diffuse flux (BALANCE_CHECK) +! ftdd => surfalb_inst%ftdd_patch , & ! Output: [real(r8) (:,:) ] down direct flux below canopy per unit direct flx (BALANCE_CHECK) +! ftid => surfalb_inst%ftid_patch , & ! Output: [real(r8) (:,:) ] down diffuse flux below canopy per unit direct flx (BALANCE_CHECK) +! ftii => surfalb_inst%ftii_patch , & ! Output: [real(r8) (:,:) ] down diffuse flux below canopy per unit diffuse flx (BALANCE_CHECK) + + ! ------------------------------------------------------------------------------- + ! TODO (mv, 2014-10-29) the filter here is different than below + ! this is needed to have the VOC's be bfb - this needs to be + ! re-examined int he future + ! RGK,2016-08-06: FATES is still incompatible with VOC emission module + ! ------------------------------------------------------------------------------- + + + do s = 1, nsites + + ifp = 0 + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + ifp = ifp+1 + + currentPatch%f_sun (:,:,:) = 0._r8 + currentPatch%fabd_sun_z (:,:,:) = 0._r8 + currentPatch%fabd_sha_z (:,:,:) = 0._r8 + currentPatch%fabi_sun_z (:,:,:) = 0._r8 + currentPatch%fabi_sha_z (:,:,:) = 0._r8 + currentPatch%fabd (:) = 0._r8 + currentPatch%fabi (:) = 0._r8 + + if(bc_in(s)%filter_vegzen_pa(ifp))then + + weighted_dir_tr(:) = 0._r8 + weighted_dif_down(:) = 0._r8 + weighted_dif_up(:) = 0._r8 + bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%fabd_parb(ifp,:) = 0._r8 ! output HLM + tr_dir_z(:,:,:) = 0._r8 + tr_dif_z(:,:,:) = 0._r8 + ftweight(:,:,:) = 0._r8 + lai_change(:,:,:) = 0._r8 + Dif_up(:,:,:) = 0._r8 + Dif_dn(:,:,:) = 0._r8 + refl_dif(:,:,:,:) = 0.0_r8 + tran_dif(:,:,:,:) = 0.0_r8 + dif_ratio(:,:,:,:) = 0.0_r8 + bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM + + if (maxval(currentPatch%nrad(1,:))==0)then + !there are no leaf layers in this patch. it is effectively bare ground. + ! no radiation is absorbed + bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 + bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 + do ib = 1,hlm_numSWb + bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) + bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) + bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 + bc_out(s)%ftid_parb(ifp,ib)= 1.0_r8 + bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 + enddo + else + + ! Is this pft/canopy layer combination present in this patch? + do L = 1,nclmax + do ft = 1,numpft_ed + currentPatch%present(L,ft) = 0 + do iv = 1, currentPatch%nrad(L,ft) + if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then + currentPatch%present(L,ft) = 1 + !I think 'present' is only used here... + endif + end do !iv + end do !ft + end do !L + + do radtype = 1,2 !do this once for one unit of diffuse, and once for one unit of direct radiation + do ib = 1,hlm_numSWb + if (radtype == 1) then + ! Set the hypothetical driving radiation. We do this once for a single unit of direct and + ! once for a single unit of diffuse radiation. + forc_dir(ifp,ib) = 1.00_r8 + forc_dif(ifp,ib) = 0.00_r8 + else !dif + forc_dir(ifp,ib) = 0.00_r8 + forc_dif(ifp,ib) = 1.00_r8 + end if + end do !ib + + !Extract information that needs to be provided by ED into local array. + ftweight(:,:,:) = 0._r8 + do L = 1,currentPatch%NCL_p + do ft = 1,numpft_ed + do iv = 1, currentPatch%nrad(L,ft) + !this is already corrected for area in CLAP + ftweight(L,ft,iv) = currentPatch%canopy_area_profile(L,ft,iv) + end do !iv + end do !ft1 + end do !L + if (sum(ftweight(1,:,1))<0.999_r8)then + write(fates_log(),*) 'canopy not full',ftweight(1,:,1) + endif + if (sum(ftweight(1,:,1))>1.0001_r8)then + write(fates_log(),*) 'canopy too full',ftweight(1,:,1) + endif + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Direct beam extinction coefficient, k_dir. PFT specific. + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + cosz = max(0.001_r8, bc_in(s)%coszen_pa(ifp)) !copied from previous radiation code... + do ft = 1,numpft_ed + sb = (90._r8 - (acos(cosz)*180/pi)) * (pi / 180._r8) + chil(ifp) = xl(ft) !min(max(xl(ft), -0.4_r8), 0.6_r8 ) + if (abs(chil(ifp)) <= 0.01_r8) then + chil(ifp) = 0.01_r8 + end if + phi1b(ifp,ft) = 0.5_r8 - 0.633_r8*chil(ifp) - 0.330_r8*chil(ifp)*chil(ifp) + phi2b(ifp,ft) = 0.877_r8 * (1._r8 - 2._r8*phi1b(ifp,ft)) !0 = horiz leaves, 1 - vert leaves. + gdir(ifp) = phi1b(ifp,ft) + phi2b(ifp,ft) * sin(sb) + !how much direct light penetrates a singleunit of lai? + k_dir(ft) = gdir(ifp) / sin(sb) + end do !FT + + do L = 1,currentPatch%NCL_p !start at the top canopy layer (1 is the top layer.) + weighted_dir_tr(L) = 0.0_r8 + weighted_fsun(L) = 0._r8 + weighted_dif_ratio(L,1:hlm_numSWb) = 0._r8 + !Each canopy layer (canopy, understorey) has multiple 'parallel' pft's + do ft =1,numpft_ed + if (currentPatch%present(L,ft) == 1)then !only do calculation if there are the appropriate leaves. + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Diffuse transmittance, tr_dif, do each layer with thickness elai_z. + ! Estimated do nine sky angles in increments of 10 degrees + ! PFT specific... + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + tr_dif_z(L,ft,:) = 0._r8 + do iv = 1,currentPatch%nrad(L,ft) + do j = 1,9 + angle = (5._r8 + (j - 1) * 10._r8) * 3.142 / 180._r8 + gdir(ifp) = phi1b(ifp,ft) + phi2b(ifp,ft) * sin(angle) !This line is redundant FIX(RF,032414). + tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-gdir(ifp) / sin(angle) * & + (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))) * & + sin(angle)*cos(angle) + end do + + tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) * 2._r8 * (10.00*pi/180._r8) + + end do + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Direct beam transmittance, tr_dir_z, uses cumulative LAI above layer J to give + ! unscattered direct beam onto layer J. do each PFT section. + ! This is just an decay curve based on k_dir. (leaf & sun angle) + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + if (L==1)then + tr_dir_z(L,ft,1) = 1._r8 + else + tr_dir_z(L,ft,1) = weighted_dir_tr(L-1) + endif + laisum = 0.00_r8 + !total direct beam getting to the bottom of the top canopy. + do iv = 1,currentPatch%nrad(L,ft) + laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) + lai_change(L,ft,iv) = 0.0_r8 + if (( ftweight(L,ft,iv+1) > 0.0_r8 ) .and. ( ftweight(L,ft,iv+1) < ftweight(L,ft,iv) ))then + !where there is a partly empty leaf layer, some fluxes go straight through. + lai_change(L,ft,iv) = ftweight(L,ft,iv)-ftweight(L,ft,iv+1) + endif + if (ftweight(L,ft,iv+1) - ftweight(L,ft,iv) > 1.e-10_r8)then + write(fates_log(),*) 'lower layer has more coverage. This is wrong' , & + ftweight(L,ft,iv),ftweight(L,ft,iv+1),ftweight(L,ft,iv+1)-ftweight(L,ft,iv) + endif + + !n.b. in theory lai_change could be calculated daily in the ED code. + !This is light coming striaght through the canopy. + if (L==1)then + tr_dir_z(L,ft,iv+1) = exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + else + tr_dir_z(L,ft,iv+1) = weighted_dir_tr(L-1)*exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + endif + + if (iv == 1)then + !this is the top layer. + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & + ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) + else + !the lai_change(iv) affects the light incident on layer iv+2 not iv+1 + ! light coming from the layer above (iv-1) goes through iv and onto iv+1. + if (lai_change(L,ft,iv-1) > 0.0_r8)then + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv)* & + lai_change(L,ft,iv-1) / ftweight(L,ft,1) + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv-1)* & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) + else + !account fot the light that comes striaght down from unfilled layers above. + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & + ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) + endif + endif + end do + + !add up all the weighted contributions from the different PFT columns. + weighted_dir_tr(L) = weighted_dir_tr(L) + tr_dir_z(L,ft,currentPatch%nrad(L,ft)+1)*ftweight(L,ft,1) + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Sunlit and shaded fraction of leaf layer + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + + !laisum = 0._r8 + do iv = 1,currentPatch%nrad(L,ft) + ! Cumulative leaf area. Original code uses cumulative lai do layer. + ! Now use cumulative lai at center of layer. + ! Same as tr_dir_z calcualtions, but in the middle of the layer? FIX(RF,032414)-WHY? + if (iv == 1) then + laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) + else + laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) + end if + + + if (L == 1)then !top canopy layer + currentPatch%f_sun(L,ft,iv) = exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + else + currentPatch%f_sun(L,ft,iv) = weighted_fsun(L-1)* exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + endif + + if ( iv > 1 ) then ! becasue we are looking at this layer (not the next) + ! we only ever add fluxes if iv>1 + if (lai_change(L,ft,iv-1) > 0.0_r8)then + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv) * & + lai_change(L,ft,iv-1)/ftweight(L,ft,1) + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv-1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) + else + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv-1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + endif + + end do !iv + weighted_fsun(L) = weighted_fsun(L) + currentPatch%f_sun(L,ft,currentPatch%nrad(L,ft))* & + ftweight(L,ft,1) + + ! instance where the first layer ftweight is used a proxy for the whole column. FTWA + ! this is possibly a source of slight error. If we use the ftweight at the top of the PFT column, + ! then we willl underestimate fsun, but if we use ftweight at the bottom of the column, we will + ! underestimate it. Really, we should be tracking the release of direct light from the column as it tapers + ! towards the ground. Is that necessary to get energy closure? It would be quite hard... + endif !present. + end do!pft loop + end do !L + + do L = currentPatch%NCL_p,1, -1 !start at the bottom and work up. + do ft = 1,numpft_ed + if (currentPatch%present(L,ft) == 1)then + !==============================================================================! + ! Iterative solution do scattering + !==============================================================================! + + do ib = 1,hlm_numSWb !vis, nir + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Leaf scattering coefficient and terms do diffuse radiation reflected + ! and transmitted by a layer + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + f_not_abs(ft,ib) = rhol(ft,ib) + taul(ft,ib) !leaf level fraction NOT absorbed. + !tr_dif_z is a term that uses the LAI in each layer, whereas rhol and taul do not, + !because they are properties of leaf surfaces and not of the leaf matrix. + do iv = 1,currentPatch%nrad(L,ft) + !How much diffuse light is intercepted and then reflected? + refl_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * rhol(ft,ib) + !How much diffuse light in this layer is transmitted? + tran_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * & + taul(ft,ib) + tr_dif_z(L,ft,iv) + end do + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Ratio of upward to forward diffuse fluxes, dif_ratio + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Soil diffuse reflectance (ratio of down to up radiation). + iv = currentPatch%nrad(L,ft) + 1 + if (L == currentPatch%NCL_p)then !nearest the soil + dif_ratio(L,ft,iv,ib) = bc_in(s)%albgr_dif_rb(ib) + else + dif_ratio(L,ft,iv,ib) = weighted_dif_ratio(L+1,ib) + end if + ! Canopy layers, working upwardfrom soil with dif_ratio(iv+1) known + ! FIX(RF,032414) ray tracing eqution - need to find derivation of this... + ! for each unit going down, there are x units going up. + do iv = currentPatch%nrad(L,ft),1, -1 + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv+1,ib) * & + tran_dif(L,ft,iv,ib)*tran_dif(L,ft,iv,ib) / & + (1._r8 - dif_ratio(L,ft,iv+1,ib) * refl_dif(L,ft,iv,ib)) & + + refl_dif(L,ft,iv,ib) + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) * & + ftweight(L,ft,iv)/ftweight(L,ft,1) + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) + dif_ratio(L,ft,iv+1,ib) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + end do + weighted_dif_ratio(L,ib) = weighted_dif_ratio(L,ib) + & + dif_ratio(L,ft,1,ib) * ftweight(L,ft,1) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + end do!hlm_numSWb + endif ! currentPatch%present + end do!ft + end do!L + + do ib = 1,hlm_numSWb + Dif_dn(:,:,:) = 0.00_r8 + Dif_up(:,:,:) = 0.00_r8 + do L = 1, currentPatch%NCL_p !work down from the top of the canopy. + weighted_dif_down(L) = 0._r8 + do ft = 1, numpft_ed + if (currentPatch%present(L,ft) == 1)then + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! First estimates do downward and upward diffuse flux + ! + ! Dif_dn = forward diffuse flux onto layer J + ! Dif_up = Upward diffuse flux above layer J + ! + ! Solved here without direct beam radiation and using dif_ratio = Dif_up / Dif_dn + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! downward diffuse flux onto the top surface of the canopy + + if (L == 1)then + Dif_dn(L,ft,1) = forc_dif(ifp,ib) + else + Dif_dn(L,ft,1) = weighted_dif_down(L-1) + end if + ! forward diffuse flux within the canopy and at soil, working forward through canopy + do iv = 1,currentPatch%nrad(L,ft) + denom = refl_dif(L,ft,iv,ib) * dif_ratio(L,ft,iv,ib) + denom = 1._r8 - denom + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) / & + denom *ftweight(L,ft,iv)/ftweight(L,ft,1) + if (iv > 1)then + if (lai_change(L,ft,iv-1) > 0.0_r8)then + !here we are thinking about whether the layer above had an laichange, + !but calculating the flux onto the layer below. + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv)* & + lai_change(L,ft,iv-1)/ftweight(L,ft,1) + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv-1)* & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1)/ftweight(L,ft,1)) + else + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + else + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + end do + + weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & + ftweight(L,ft,1) + + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif !present + end do !ft + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is the the (incomplete) understorey? + !Add on the radiation going through the canopy gaps. + weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1)*(1.0-sum(ftweight(L,:,1))) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif + end do !L + + do L = currentPatch%NCL_p,1 ,-1 !work up from the bottom. + weighted_dif_up(L) = 0._r8 + do ft = 1, numpft_ed + if (currentPatch%present(L,ft) == 1)then + !Bounce diffuse radiation off soil surface. + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then !is this the bottom layer ? + Dif_up(L,ft,iv) =bc_in(s)%albgr_dif_rb(ib) * Dif_dn(L,ft,iv) + else + Dif_up(L,ft,iv) = weighted_dif_up(L+1) + end if + ! Upward diffuse flux within the canopy and above the canopy, working upward through canopy + + do iv = currentPatch%nrad(L,ft), 1, -1 + if (lai_change(L,ft,iv) > 0.0_r8)then + Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * & + ftweight(L,ft,iv) / ftweight(L,ft,1) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & + tran_dif(L,ft,iv,ib) * lai_change(L,ft,iv)/ftweight(L,ft,1) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + !nb is this the right constuction? + ! the radiation that hits the empty space is not reflected. + else + Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * ftweight(L,ft,iv) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * (1.0_r8-ftweight(L,ft,iv)) + endif + end do + + weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif !present + end do !ft + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? + !Add on the radiation coming up through the canopy gaps. + !diffuse to diffuse + weighted_dif_up(L) = weighted_dif_up(L) +(1.0-sum(ftweight(L,:,1))) * & + weighted_dif_down(L-1) * bc_in(s)%albgr_dif_rb(ib) + !direct to diffuse + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(ifp,ib) * & + weighted_dir_tr(L-1) * (1.0-sum(ftweight(L,:,1)))*bc_in(s)%albgr_dir_rb(ib) + endif + end do !L + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! 3. Iterative calculation of forward and upward diffuse fluxes, iNCL_puding + ! scattered direct beam + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + + ! Flag to exit iteration loop: 0 = exit and 1 = iterate + irep = 1 + ! Iteration loop + iter = 0 + do while(irep ==1 .and. iter<50) + + iter = iter + 1 + irep = 0 + do L = 1,currentPatch%NCL_p !working from the top down + weighted_dif_down(L) = 0._r8 + do ft =1,numpft_ed + if (currentPatch%present(L,ft) == 1)then + ! forward diffuse flux within the canopy and at soil, working forward through canopy + ! with Dif_up -from previous iteration-. Dif_dn(1) is the forward diffuse flux onto the canopy. + ! Note: down = forward flux onto next layer + if (L == 1)then !is this the top layer? + Dif_dn(L,ft,1) = forc_dif(ifp,ib) + else + Dif_dn(L,ft,1) = weighted_dif_down(L-1) + end if + down_rad = 0._r8 + + do iv = 1, currentPatch%nrad(L,ft) + + down_rad = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) + & + Dif_up(L,ft,iv+1) * refl_dif(L,ft,iv,ib) + & + forc_dir(ifp,ib) * tr_dir_z(L,ft,iv) * (1.00_r8 - & + exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv)))) * taul(ft,ib) + down_rad = down_rad *(ftweight(L,ft,iv)/ftweight(L,ft,1)) + + if (iv > 1)then + if (lai_change(L,ft,iv-1) > 0.0_r8)then + down_rad = down_rad + Dif_dn(L,ft,iv) * lai_change(L,ft,iv-1)/ftweight(L,ft,1) + down_rad = down_rad + Dif_dn(L,ft,iv-1) * (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ & + ftweight(L,ft,1) + else + down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & + ftweight(L,ft,1) + endif + else + down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & + ftweight(L,ft,1) + endif + + !this is just Dif down, plus refl up, plus dir intercepted and turned into dif... , + if (abs(down_rad - Dif_dn(L,ft,iv+1)) > tolerance)then + irep = 1 + end if + Dif_dn(L,ft,iv+1) = down_rad + + end do !iv + + weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & + ftweight(L,ft,1) + + endif !present + end do!ft + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? + weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1)*(1.0-sum(ftweight(L,:,1))) + end if + end do ! do L loop + + do L = 1, currentPatch%NCL_p ! working from the top down. + weighted_dif_up(L) = 0._r8 + do ft =1,numpft_ed + if (currentPatch%present(L,ft) == 1)then + ! Upward diffuse flux at soil or from lower canopy (forward diffuse and unscattered direct beam) + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then !In the bottom canopy layer, reflect off the soil + Dif_up(L,ft,iv) = Dif_dn(L,ft,iv) *bc_in(s)%albgr_dif_rb(ib) + & + forc_dir(ifp,ib) * tr_dir_z(L,ft,iv) *bc_in(s)%albgr_dir_rb(ib) + else !In the other canopy layers, reflect off the underlying vegetation. + Dif_up(L,ft,iv) = weighted_dif_up(L+1) + end if + + ! Upward diffuse flux within and above the canopy, working upward through canopy + ! with Dif_dn from previous interation. Note: up = upward flux above current layer + do iv = currentPatch%nrad(L,ft),1,-1 + !this is radiation up, by layer transmittance, by + + !reflection of the lower layer, + up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) + up_rad = up_rad + forc_dir(ifp,ib) * tr_dir_z(L,ft,iv) * (1.00_r8 - exp(-k_dir(ft) * & + (currentPatch%elai_profile(L,ft,iv) + currentPatch%esai_profile(L,ft,iv)))) * & + rhol(ft,ib) + up_rad = up_rad + Dif_up(L,ft,iv+1) * tran_dif(L,ft,iv,ib) + up_rad = up_rad * ftweight(L,ft,iv)/ftweight(L,ft,1) + up_rad = up_rad + Dif_up(L,ft,iv+1) *(ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + ! THE LOWER LAYER FLUX IS HOMOGENIZED, SO WE DON"T CONSIDER THE LAI_CHANGE HERE... + + if (abs(up_rad - Dif_up(L,ft,iv)) > tolerance) then !are we close to the tolerance level? + irep = 1 + end if + Dif_up(L,ft,iv) = up_rad + + end do !iv + weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) + end if !present + end do!ft + + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? + !Add on the radiation coming up through the canopy gaps. + weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,:,1))) * & + weighted_dif_down(L-1) * bc_in(s)%albgr_dif_rb(ib) + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(ifp,ib) * & + weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,:,1)))*bc_in(s)%albgr_dir_rb(ib) + end if + end do!L + end do ! do while over iter + + abs_rad(ib) = 0._r8 + tr_soili = 0._r8 + tr_soild = 0._r8 + do L = 1, currentPatch%NCL_p !working from the top down. + abs_dir_z(:,:) = 0._r8 + abs_dif_z(:,:) = 0._r8 + do ft =1,numpft_ed + if (currentPatch%present(L,ft) == 1)then + !==============================================================================! + ! Compute absorbed flux densities + !==============================================================================! + + ! Absorbed direct beam and diffuse do leaf layers + do iv = 1, currentPatch%nrad(L,ft) + Abs_dir_z(ft,iv) = ftweight(L,ft,iv)* forc_dir(ifp,ib) * tr_dir_z(L,ft,iv) * & + (1.00_r8 - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv)))) * (1.00_r8 - f_not_abs(ft,ib)) + Abs_dif_z(ft,iv) = ftweight(L,ft,iv)* ((Dif_dn(L,ft,iv) + & + Dif_up(L,ft,iv+1)) * (1.00_r8 - tr_dif_z(L,ft,iv)) * & + (1.00_r8 - f_not_abs(ft,ib))) + end do + + ! Absorbed direct beam and diffuse do soil + if (L == currentPatch%NCL_p)then + iv = currentPatch%nrad(L,ft) + 1 + Abs_dif_z(ft,iv) = ftweight(L,ft,1)*Dif_dn(L,ft,iv) * (1.0_r8 -bc_in(s)%albgr_dif_rb(ib)) + Abs_dir_z(ft,iv) = ftweight(L,ft,1)*forc_dir(ifp,ib) * & + tr_dir_z(L,ft,iv) * (1.0_r8 -bc_in(s)%albgr_dir_rb(ib)) + tr_soild = tr_soild + ftweight(L,ft,1)*forc_dir(ifp,ib) * tr_dir_z(L,ft,iv) + tr_soili = tr_soili + ftweight(L,ft,1)*Dif_dn(L,ft,iv) + end if + ! Absorbed radiation, shaded and sunlit portions of leaf layers + !here we get one unit of diffuse radiation... how much of + !it is absorbed? + if (ib == 1) then ! only set the absorbed PAR for the visible light band. + do iv = 1, currentPatch%nrad(L,ft) + if (radtype==1) then + if ( DEBUG ) then + write(fates_log(),*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) + write(fates_log(),*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & + currentPatch%fabd_sun_z(L,ft,iv) + endif + currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv)) + currentPatch%fabd_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + currentPatch%f_sun(L,ft,iv) + & + Abs_dir_z(ft,iv) + else + currentPatch%fabi_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv)) + currentPatch%fabi_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + currentPatch%f_sun(L,ft,iv) + endif + if ( DEBUG ) then + write(fates_log(),*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & + currentPatch%fabd_sun_z(L,ft,iv) + endif + end do + endif ! ib + + !==============================================================================! + ! Sum fluxes + !==============================================================================! + ! Solar radiation absorbed by ground + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then + abs_rad(ib) = abs_rad(ib) + (Abs_dir_z(ft,iv) + Abs_dif_z(ft,iv)) + end if + ! Solar radiation absorbed by vegetation and sunlit/shaded leaves + do iv = 1,currentPatch%nrad(L,ft) + if (radtype == 1)then + currentPatch%fabd(ib) = currentPatch%fabd(ib) + Abs_dir_z(ft,iv)+Abs_dif_z(ft,iv) + ! bc_out(s)%fabd_parb(ifp,ib) = currentPatch%fabd(ib) + else + currentPatch%fabi(ib) = currentPatch%fabi(ib) + Abs_dif_z(ft,iv) + ! bc_out(s)%fabi_parb(ifp,ib) = currentPatch%fabi(ib) + endif + end do + ! Albefor + if (L==1)then !top canopy layer. + if (radtype == 1)then + bc_out(s)%albd_parb(ifp,ib) = bc_out(s)%albd_parb(ifp,ib) + & + Dif_up(L,ft,1) * ftweight(L,ft,1) + else + bc_out(s)%albi_parb(ifp,ib) = bc_out(s)%albi_parb(ifp,ib) + & + Dif_up(L,ft,1) * ftweight(L,ft,1) + end if + end if + end if ! present + end do !ft + if (radtype == 1)then + bc_out(s)%fabd_parb(ifp,ib) = currentPatch%fabd(ib) + else + bc_out(s)%fabi_parb(ifp,ib) = currentPatch%fabi(ib) + endif + + + !radiation absorbed from fluxes through unfilled part of lower canopy. + if (currentPatch%NCL_p > 1.and.L == currentPatch%NCL_p)then + abs_rad(ib) = abs_rad(ib) + weighted_dif_down(L-1) * & + (1.0_r8-sum(ftweight(L,:,1)))*(1.0_r8-bc_in(s)%albgr_dif_rb(ib)) + abs_rad(ib) = abs_rad(ib) + forc_dir(ifp,ib) * weighted_dir_tr(L-1) * & + (1.0_r8-sum(ftweight(L,:,1)))*(1.0_r8-bc_in(s)%albgr_dir_rb(ib)) + tr_soili = tr_soili + weighted_dif_down(L-1) * (1.0_r8-sum(ftweight(L,:,1))) + tr_soild = tr_soild + forc_dir(ifp,ib) * weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,:,1))) + endif + + if (radtype == 1)then + currentPatch%tr_soil_dir(ib) = tr_soild + currentPatch%tr_soil_dir_dif(ib) = tr_soili + currentPatch%sabs_dir(ib) = abs_rad(ib) + bc_out(s)%ftdd_parb(ifp,ib) = tr_soild + bc_out(s)%ftid_parb(ifp,ib) = tr_soili + else + currentPatch%tr_soil_dif(ib) = tr_soili + currentPatch%sabs_dif(ib) = abs_rad(ib) + bc_out(s)%ftii_parb(ifp,ib) = tr_soili + end if + + end do!l + + + !==============================================================================! + ! Conservation check + !==============================================================================! + ! Total radiation balance: absorbed = incoming - outgoing + + if (radtype == 1)then + error = abs(currentPatch%sabs_dir(ib) - (currentPatch%tr_soil_dir(ib) * & + (1.0_r8-bc_in(s)%albgr_dir_rb(ib)) + & + currentPatch%tr_soil_dir_dif(ib) * (1.0_r8-bc_in(s)%albgr_dif_rb(ib)))) + if ( abs(error) > 0.0001)then + write(fates_log(),*)'dir ground absorption error',ifp,s,error,currentPatch%sabs_dir(ib), & + currentPatch%tr_soil_dir(ib)* & + (1.0_r8-bc_in(s)%albgr_dir_rb(ib)),currentPatch%NCL_p,ib,sum(ftweight(1,:,1)) + write(fates_log(),*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & + (1.0_r8-bc_in(s)%albgr_dir_rb(ib)),currentPatch%lai + + do ft =1,3 + iv = currentPatch%nrad(1,ft) + 1 + write(fates_log(),*) 'abs soil fluxes', Abs_dir_z(ft,iv),Abs_dif_z(ft,iv) + end do + + end if + else + if ( abs(currentPatch%sabs_dif(ib)-(currentPatch%tr_soil_dif(ib) * & + (1.0_r8-bc_in(s)%albgr_dif_rb(ib)))) > 0.0001)then + write(fates_log(),*)'dif ground absorption error',ifp,s,currentPatch%sabs_dif(ib) , & + (currentPatch%tr_soil_dif(ib)* & + (1.0_r8-bc_in(s)%albgr_dif_rb(ib))),currentPatch%NCL_p,ib,sum(ftweight(1,:,1)) + endif + endif + + if (radtype == 1)then + error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - & + (bc_out(s)%fabd_parb(ifp,ib) + bc_out(s)%albd_parb(ifp,ib) + currentPatch%sabs_dir(ib)) + else + error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - & + (bc_out(s)%fabi_parb(ifp,ib) + bc_out(s)%albi_parb(ifp,ib) + currentPatch%sabs_dif(ib)) + endif + lai_reduction(:) = 0.0_r8 + do L = 1, currentPatch%NCL_p + do ft =1,numpft_ed + if (currentPatch%present(L,ft) == 1)then + do iv = 1, currentPatch%nrad(L,ft) + if (lai_change(L,ft,iv) > 0.0_r8)then + lai_reduction(L) = max(lai_reduction(L),lai_change(L,ft,iv)) + endif + enddo + endif + enddo + enddo + if (lai_change(1,2,1).gt.0.0.and.lai_change(1,2,2).gt.0.0)then + ! write(fates_log(),*) 'lai_change(1,2,12)',lai_change(1,2,1:4) + endif + if (lai_change(1,2,2).gt.0.0.and.lai_change(1,2,3).gt.0.0)then + ! write(fates_log(),*) ' lai_change (1,2,23)',lai_change(1,2,1:4) + endif + if (lai_change(1,1,3).gt.0.0.and.lai_change(1,1,2).gt.0.0)then + ! NO-OP + ! write(fates_log(),*) 'first layer of lai_change 2 3',lai_change(1,1,1:3) + endif + if (lai_change(1,1,3).gt.0.0.and.lai_change(1,1,4).gt.0.0)then + ! NO-OP + ! write(fates_log(),*) 'first layer of lai_change 3 4',lai_change(1,1,1:4) + endif + if (lai_change(1,1,4).gt.0.0.and.lai_change(1,1,5).gt.0.0)then + ! NO-OP + ! write(fates_log(),*) 'first layer of lai_change 4 5',lai_change(1,1,1:5) + endif + + if (radtype == 1)then + !here we are adding a within-ED radiation scheme tolerance, and then adding the diffrence onto the albedo + !it is important that the lower boundary for this is ~1000 times smaller than the tolerance in surface albedo. + if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then + bc_out(s)%albd_parb(ifp,ib) = bc_out(s)%albd_parb(ifp,ib) + error + !this terms adds the error back on to the albedo. While this is partly inexcusable, it is + ! in the medium term a solution that + ! prevents the model from crashing with small and occasional energy balances issues. + ! These are extremely difficult to debug, many have been solved already, leading + ! to the complexity of this code, but where the system generates occasional errors, we + ! will deal with them for now. + end if + if (abs(error) > 0.15_r8)then + write(fates_log(),*) 'Large Dir Radn consvn error',error ,ifp,ib + write(fates_log(),*) 'diags', bc_out(s)%albd_parb(ifp,ib), bc_out(s)%ftdd_parb(ifp,ib), & + bc_out(s)%ftid_parb(ifp,ib), bc_out(s)%fabd_parb(ifp,ib) + write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'ftweight',ftweight(1,1:2,1:4) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'bc_in(s)%albgr_dir_rb(ib)',bc_in(s)%albgr_dir_rb(ib) + + bc_out(s)%albd_parb(ifp,ib) = bc_out(s)%albd_parb(ifp,ib) + error + end if + else + + if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then + bc_out(s)%albi_parb(ifp,ib) = bc_out(s)%albi_parb(ifp,ib) + error + end if + + if (abs(error) > 0.15_r8)then + write(fates_log(),*) '>5% Dif Radn consvn error',error ,ifp,ib + write(fates_log(),*) 'diags', bc_out(s)%albi_parb(ifp,ib), bc_out(s)%ftii_parb(ifp,ib), & + bc_out(s)%fabi_parb(ifp,ib) + write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:2,1:4) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'bc_in(s)%albgr_dif_rb(ib)',bc_in(s)%albgr_dif_rb(ib) + write(fates_log(),*) 'rhol',rhol(1:2,:) + write(fates_log(),*) 'ftw',sum(ftweight(1,:,1)),ftweight(1,1:2,1) + write(fates_log(),*) 'present',currentPatch%present(1,1:2) + write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:2,1) + + bc_out(s)%albi_parb(ifp,ib) = bc_out(s)%albi_parb(ifp,ib) + error + end if + + if (radtype == 1)then + error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - & + (bc_out(s)%fabd_parb(ifp,ib) + bc_out(s)%albd_parb(ifp,ib) + currentPatch%sabs_dir(ib)) + else + error = (forc_dir(ifp,ib) + forc_dif(ifp,ib)) - & + (bc_out(s)%fabi_parb(ifp,ib) + bc_out(s)%albi_parb(ifp,ib) + currentPatch%sabs_dif(ib)) + endif + + if (abs(error) > 0.00000001_r8)then + write(fates_log(),*) 'there is still error after correction',error ,ifp,ib + end if + + end if + + end do !hlm_numSWb + + enddo ! rad-type + endif ! is there vegetation? + + end if ! if the vegetation and zenith filter is active + currentPatch => currentPatch%younger + end do ! Loop linked-list patches + enddo ! Loop Sites + + end associate + return + end subroutine ED_Norman_Radiation + + ! ====================================================================================== + + subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) + + implicit none + + ! Arguments + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + + + ! locals + type (ed_patch_type),pointer :: cpatch ! c"urrent" patch + real(r8) :: sunlai + real(r8) :: shalai + real(r8) :: elai + integer :: CL + integer :: FT + integer :: iv + integer :: s + integer :: ifp + + + do s = 1,nsites + + ifp = 0 + cpatch => sites(s)%oldest_patch + + do while (associated(cpatch)) + + ifp=ifp+1 + + if( DEBUG ) write(fates_log(),*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft_ed + + ! zero out various datas + cpatch%ed_parsun_z(:,:,:) = 0._r8 + cpatch%ed_parsha_z(:,:,:) = 0._r8 + cpatch%ed_laisun_z(:,:,:) = 0._r8 + cpatch%ed_laisha_z(:,:,:) = 0._r8 + + bc_out(s)%fsun_pa(ifp) = 0._r8 + + sunlai = 0._r8 + shalai = 0._r8 + + ! Loop over patches to calculate laisun_z and laisha_z for each layer. + ! Derive canopy laisun, laisha, and fsun from layer sums. + ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from + ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. + + ! cpatch%f_sun is calculated in the surface_albedo routine... + + do CL = 1, cpatch%NCL_p + do FT = 1,numpft_ed + + if( DEBUG ) write(fates_log(),*) 'edsurfRad_5601',CL,FT,cpatch%nrad(CL,ft) + + do iv = 1, cpatch%nrad(CL,ft) !NORMAL CASE. + + ! FIX(SPM,040114) - existing comment + ! ** Should this be elai or tlai? Surely we only do radiation for elai? + + cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + cpatch%f_sun(CL,ft,iv) + + if ( DEBUG ) write(fates_log(),*) 'edsurfRad 570 ',cpatch%elai_profile(CL,ft,iv) + if ( DEBUG ) write(fates_log(),*) 'edsurfRad 571 ',cpatch%f_sun(CL,ft,iv) + + cpatch%ed_laisha_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + (1._r8 - cpatch%f_sun(CL,ft,iv)) + + end do + + !needed for the VOC emissions, etc. + sunlai = sunlai + sum(cpatch%ed_laisun_z(CL,ft,1:cpatch%nrad(CL,ft))) + shalai = shalai + sum(cpatch%ed_laisha_z(CL,ft,1:cpatch%nrad(CL,ft))) + + end do + end do + + if(sunlai+shalai > 0._r8)then + bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) + else + bc_out(s)%fsun_pa(ifp) = 0._r8 + endif + + if(bc_out(s)%fsun_pa(ifp) > 1._r8)then + write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & + cpatch%lai,sunlai,shalai + endif + + elai = calc_areaindex(cpatch,'elai') + + bc_out(s)%laisun_pa(ifp) = elai*bc_out(s)%fsun_pa(ifp) + bc_out(s)%laisha_pa(ifp) = elai*(1.0_r8-bc_out(s)%fsun_pa(ifp)) + + ! Absorbed PAR profile through canopy + ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo + ! are canopy integrated so that layer values equal big leaf values. + + if ( DEBUG ) write(fates_log(),*) 'edsurfRad 645 ',cpatch%NCL_p,numpft_ed + + do CL = 1, cpatch%NCL_p + do FT = 1,numpft_ed + + if ( DEBUG ) write(fates_log(),*) 'edsurfRad 649 ',cpatch%nrad(CL,ft) + + do iv = 1, cpatch%nrad(CL,ft) + + if ( DEBUG ) then + write(fates_log(),*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) + write(fates_log(),*) 'edsurfRad 654 ', bc_in(s)%solad_parb(ifp,ipar) + write(fates_log(),*) 'edsurfRad 655 ', bc_in(s)%solai_parb(ifp,ipar) + write(fates_log(),*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) + write(fates_log(),*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) + endif + + cpatch%ed_parsun_z(CL,ft,iv) = & + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(CL,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(CL,ft,iv) + + if ( DEBUG )write(fates_log(),*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) + + cpatch%ed_parsha_z(CL,ft,iv) = & + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(CL,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(CL,ft,iv) + + if ( DEBUG ) write(fates_log(),*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) + + end do !iv + end do !FT + end do !CL + + cpatch => cpatch%younger + enddo + + + enddo + return + +end subroutine ED_SunShadeFracs + + +! ! MOVE TO THE INTERFACE +! subroutine ED_CheckSolarBalance(g,filter_nourbanp,num_nourbanp,fsa,fsr,forc_solad,forc_solai) + + +! implicit none +! integer,intent(in),dimension(:) :: gridcell ! => gridcell index +! integer,intent(in),dimension(:) :: filter_nourbanp ! => patch filter for non-urban points +! integer, intent(in) :: num_nourbanp ! number of patches in non-urban points in patch filter +! real(r8),intent(in),dimension(:,:) :: forc_solad ! => atm2lnd_inst%forc_solad_grc, direct radiation (W/m**2 +! real(r8),intent(in),dimension(:,:) :: forc_solai ! => atm2lnd_inst%forc_solai_grc, diffuse radiation (W/m**2) +! real(r8),intent(in),dimension(:,:) :: fsa ! => solarabs_inst%fsa_patch, solar radiation absorbed (total) (W/m**2) +! real(r8),intent(in),dimension(:,:) :: fsr ! => solarabs_inst%fsr_patch, solar radiation reflected (W/m**2) + +! integer :: p +! integer :: fp +! integer :: g +! real(r8) :: errsol + +! do fp = 1,num_nourbanp +! p = filter_nourbanp(fp) +! g = gridcell(p) +! errsol = (fsa(p) + fsr(p) - (forc_solad(g,1) + forc_solad(g,2) + forc_solai(g,1) + forc_solai(g,2))) +! if(abs(errsol) > 0.1_r8)then +! write(fates_log(),*) 'sol error in surf rad',p,g, errsol +! endif +! end do +! return +! end subroutine ED_CheckSolarBalance + + +end module EDSurfaceRadiationMod diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 new file mode 100644 index 00000000..688117f2 --- /dev/null +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -0,0 +1,351 @@ +module FatesPlantHydraulicsMod + + + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!99 + ! (TODO: THE ROW WIDTH ON THIS MODULE ARE TOO LARGE. NAG COMPILERS + ! WILL FREAK IF LINES ARE TOO LONG. BEFORE SUBMITTING THIS TO + ! MASTER WE NEED TO GO THROUGH AND GET THESE LINES BELOW + ! 100 spaces (for readability), or 130 (for NAG) + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!99 + + use FatesGlobals, only : endrun => fates_endrun + use FatesGlobals, only : fates_log + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : fates_huge + use FatesConstantsMod, only : denh2o => dens_fresh_liquid_water + use FatesConstantsMod, only : grav => grav_earth + + use EDTypesMod, only : use_fates_plant_hydro + use EDTypesMod , only : ed_site_type + use EDTypesMod , only : ed_patch_type + use EDTypesMod , only : ed_cohort_type + + use FatesInterfaceMod , only : bc_in_type + use FatesInterfaceMod , only : bc_out_type + use FatesInterfaceMod , only : hlm_numlevsoil + + use EDEcophysconType, only : EDecophyscon + + use FatesHydraulicsMemMod, only: ed_site_hydr_type + use FatesHydraulicsMemMod, only: ed_patch_hydr_type + use FatesHydraulicsMemMod, only: ed_cohort_hydr_type + use FatesHydraulicsMemMod, only: npool_leaf + use FatesHydraulicsMemMod, only: npool_tot + use FatesHydraulicsMemMod, only: npool_stem + use FatesHydraulicsMemMod, only: numLWPmem + use FatesHydraulicsMemMod, only: npool_troot + use FatesHydraulicsMemMod, only: npool_aroot + use FatesHydraulicsMemMod, only: n_porous_media + use FatesHydraulicsMemMod, only: nshell + use FatesHydraulicsMemMod, only: npool_ag + use FatesHydraulicsMemMod, only: npool_bg + use FatesHydraulicsMemMod, only: porous_media + use FatesHydraulicsMemMod, only: nlevsoi_hyd + + ! CIME Globals + use shr_log_mod , only : errMsg => shr_log_errMsg + use shr_infnan_mod , only : isnan => shr_infnan_isnan + + + implicit none + + private + integer, parameter :: van_genuchten = 1 + integer, parameter :: campbell = 2 + integer :: iswc = campbell + + ! 1=leaf, 2=stem, 3=troot, 4=aroot + ! Several of these may be better transferred to the parameter file in due time (RGK) + + integer, public :: use_ed_planthydraulics = 1 ! 0 => use vanilla btran + ! 1 => use BC hydraulics; + ! 2 => use CX hydraulics + logical, public :: do_dqtopdth_leaf = .false. ! should a nonzero dqtopdth_leaf + ! term be applied to the plant + ! hydraulics numerical solution? + logical, public :: do_dyn_xylemrefill = .true. ! should the dynamics of xylem refilling + ! (i.e., non-instantaneous) be considered + ! within plant hydraulics? + logical, public :: do_kbound_upstream = .false. ! should the hydraulic conductance at the + ! boundary between nodes be taken to be a + ! function of the upstream loss of + ! conductivity (flc)? + logical, public :: do_growthrecruiteffects = .true. ! should size- or root length-dependent + ! hydraulic properties and states be + ! updated every day when trees grow or + ! when recruitment happens? + logical, public :: do_static_ed = .true. ! should growth, mortality, and patch + ! dynamics be turned off? + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: hydraulics_drive + public :: InitHydrSites + public :: HydrSiteColdStart + public :: BTranForHLMDiagnosticsFromCohortHydr + public :: InitHydrCohort + public :: DeallocateHydrCohort + public :: UpdateH2OVeg + public :: CopyCohortHydraulics + public :: FuseCohortHydraulics + public :: updateSizeDepTreeHydProps + public :: updateSizeDepTreeHydStates + public :: initTreeHydStates + public :: updateSizeDepRhizHydProps + + !------------------------------------------------------------------------------ + ! 01/18/16: Created by Brad Christoffersen + ! 02/xx/17: Refactoring by Ryan Knox and Brad Christoffersen + !------------------------------------------------------------------------------ + +contains + + !------------------------------------------------------------------------------ + subroutine hydraulics_drive( nsites, sites, bc_in,bc_out,dtime ) + + ! ARGUMENTS: + ! ----------------------------------------------------------------------------------- + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + real(r8),intent(in) :: dtime + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine Hydraulics_Drive + + ! ===================================================================================== + + subroutine initTreeHydStates(cc_p, bc_in) + ! + ! !DESCRIPTION: + ! + ! !USES: + use EDEcophysConType , only : EDecophyscon + + ! !ARGUMENTS: + type(ed_cohort_type), intent(inout), target :: cc_p ! current cohort pointer + type(bc_in_type) , intent(in) :: bc_in + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine initTreeHydStates + + ! ===================================================================================== + + subroutine updateSizeDepTreeHydProps(cc_p,bc_in) + ! + ! !DESCRIPTION: Updates absorbing root length (total and its vertical distribution) + ! as well as the consequential change in the size of the 'representative' rhizosphere + ! shell radii, volumes + ! + ! !USES: + use FatesConstantsMod , only : pi_const + use EDEcophysConType , only : EDecophyscon + use shr_sys_mod , only : shr_sys_abort + ! + ! !ARGUMENTS: + type(ed_cohort_type) , intent(inout), target :: cc_p ! current cohort pointer + type(bc_in_type) , intent(in) :: bc_in ! Boundary Conditions + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine updateSizeDepTreeHydProps + + ! ===================================================================================== + + subroutine updateSizeDepTreeHydStates(cc_p) + ! + ! !DESCRIPTION: + ! + ! !USES: + ! !ARGUMENTS: + type(ed_cohort_type) , intent(inout), target :: cc_p ! current cohort pointer + ! + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine updateSizeDepTreeHydStates + + ! ===================================================================================== + + subroutine CopyCohortHydraulics(newCohort, oldCohort) + + ! Arguments + type(ed_cohort_type), intent(inout), target :: newCohort + type(ed_cohort_type), intent(inout), target :: oldCohort + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine CopyCohortHydraulics + + ! ===================================================================================== + + subroutine FuseCohortHydraulics(currentCohort, nextCohort, bc_in, newn) + + + type(ed_cohort_type), intent(inout), target :: currentCohort ! current cohort + type(ed_cohort_type), intent(inout), target :: nextCohort ! next (donor) cohort + type(bc_in_type), intent(in) :: bc_in + real(r8), intent(in) :: newn + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine FuseCohortHydraulics + + + + ! ===================================================================================== + ! Initialization Routines + ! ===================================================================================== + + subroutine InitHydrCohort(currentCohort) + + ! Arguments + type(ed_cohort_type), target :: currentCohort + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine InitHydrCohort + + ! ===================================================================================== + + subroutine DeallocateHydrCohort(currentCohort) + + ! Arguments + type(ed_cohort_type), target :: currentCohort + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine DeallocateHydrCohort + + + ! ===================================================================================== + + subroutine InitHydrSites(sites) + + ! Arguments + type(ed_site_type),intent(inout),target :: sites(:) + + ! Locals + integer :: nsites + integer :: s + type(ed_site_hydr_type),pointer :: csite_hydr + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine InitHydrSites + + ! =================================================================================== + + subroutine HydrSiteColdStart(sites, bc_in) + + + ! Arguments + type(ed_site_type),intent(inout),target :: sites(:) + type(bc_in_type),intent(inout) :: bc_in(:) + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine HydrSiteColdStart + + ! ===================================================================================== + + subroutine UpdateH2OVeg(nsites,sites,bc_out) + + ! ---------------------------------------------------------------------------------- + ! This subroutine is called following dynamics. After growth has been updated + ! there needs to be a re-assesment of the how much liquid water is bound in the + ! plants. This value is necessary for water balancing in the HLM. + ! ---------------------------------------------------------------------------------- + + use EDTypesMod, only : AREA + + ! Arguments + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine UpdateH2OVeg + + ! ===================================================================================== + + subroutine updateSizeDepRhizHydProps(currentSite, bc_in ) + ! + ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. + ! As fine root biomass (and thus absorbing root length) increases, this characteristic + ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains + ! the same. + ! + ! !USES: + use FatesConstantsMod , only : pi_const + use EDTypesMod , only : AREA + + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type) , intent(in) :: bc_in + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end subroutine updateSizeDepRhizHydProps + + ! ================================================================================= + + subroutine updateSizeDepRhizHydStates(currentSite, bc_in) + ! + ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. + ! As fine root biomass (and thus absorbing root length) increases, this characteristic + ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains + ! the same. + ! + ! !USES: + ! + ! !ARGUMENTS: + type(ed_site_type), intent(inout), target :: currentSite + type(bc_in_type), intent(in) :: bc_in + ! + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + +end subroutine updateSizeDepRhizHydStates + + ! ==================================================================================== + + subroutine BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) + + ! Arguments + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + + end subroutine BTranForHLMDiagnosticsFromCohortHydr + + + ! ==================================================================================== + + + + +end module FatesPlantHydraulicsMod diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 new file mode 100644 index 00000000..06ae3d4f --- /dev/null +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -0,0 +1,1643 @@ +module FATESPlantRespPhotosynthMod + + !------------------------------------------------------------------------------------- + ! !DESCRIPTION: + ! Calculates the plant respiration and photosynthetic fluxes for the FATES model + ! This code is similar to and was originally based off of the 'photosynthesis' + ! subroutine in the CLM model. + ! + ! Parameter for activation and deactivation energies were taken from: + ! Activation energy, from: + ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 + ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 + ! High temperature deactivation, from: + ! Leuning (2002) Plant, Cell and Environment 25:1205-1210 + ! The factor "c" scales the deactivation to a value of 1.0 at 25C + ! Photosynthesis and stomatal conductance parameters, from: + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + ! ------------------------------------------------------------------------------------ + + ! !USES: + + use FatesGlobals, only : endrun => fates_endrun + use FatesGlobals, only : fates_log + use FatesConstantsMod, only : r8 => fates_r8 + use EDTypesMod, only : use_fates_plant_hydro + use EDTypesMod, only : numpft_ed + use EDTypesMod, only : nlevleaf + use EDTypesMod, only : nclmax + + ! CIME Globals + use shr_log_mod , only : errMsg => shr_log_errMsg + + implicit none + private + + public :: FatesPlantRespPhotosynthDrive ! Called by the HLM-Fates interface + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------------------- + + ! maximum stomatal resistance [s/m] (used across several procedures) + real(r8),parameter :: rsmax0 = 2.e4_r8 + + logical :: DEBUG = .false. + +contains + + !-------------------------------------------------------------------------------------- + + subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) + + ! ----------------------------------------------------------------------------------- + ! !DESCRIPTION: + ! Leaf photosynthesis and stomatal conductance calculation as described by + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 and extended to + ! a multi-layer canopy + ! ----------------------------------------------------------------------------------- + + + ! !USES: + + use EDPftvarcon , only : EDPftvarcon_inst + + use EDParamsMod , only : ED_val_ag_biomass + use FatesSynchronizedParamsMod , only : FatesSynchronizedParamsInst + use EDTypesMod , only : ed_patch_type + use EDTypesMod , only : ed_cohort_type + use EDTypesMod , only : ed_site_type + use EDTypesMod , only : maxpft + use FatesInterfaceMod , only : hlm_numlevsoil + use FatesInterfaceMod , only : bc_in_type + use FatesInterfaceMod , only : bc_out_type + use EDCanopyStructureMod, only : calc_areaindex + use FatesConstantsMod, only : umolC_to_kgC + use FatesConstantsMod, only : g_per_kg + use FatesConstantsMod, only : umol_per_mmol + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + use FatesParameterDerivedMod, only : param_derived + use EDPatchDynamicsMod, only: set_root_fraction + use EDParamsMod, only : ED_val_bbopt_c3, ED_val_bbopt_c4, ED_val_base_mr_20 + + + ! ARGUMENTS: + ! ----------------------------------------------------------------------------------- + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + real(r8),intent(in) :: dtime + + + ! LOCAL VARIABLES: + ! ----------------------------------------------------------------------------------- + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type), pointer :: currentCohort + + ! ----------------------------------------------------------------------------------- + ! These three arrays hold leaf-level biophysical rates that are calculated + ! in one loop and then sent to the cohorts in another loop. If hydraulics are + ! on, we calculate a unique solution for each level-cohort-layer combination. + ! If we are not using hydraulics, we calculate a unique solution for each + ! level-pft-layer combination. Thus the following three arrays are statically + ! allocated for the maximum space of the two cases (numCohortsPerPatch) + ! The "_z" suffix indicates these variables are discretized at the "leaf_layer" + ! scale. + ! Note: For these temporary arrays, we have the leaf layer dimension first + ! and the canopy layer last. This order is chosen for efficiency. The arrays + ! such as leaf area that are bound to the patch structure DO NOT follow this order + ! as they are used in many other parts of the code with different looping, we + ! are not modifying its order now. + ! ----------------------------------------------------------------------------------- + + ! leaf maintenance (dark) respiration (umol CO2/m**2/s) Double check this + real(r8) :: lmr_z(nlevleaf,maxpft,nclmax) + + ! stomatal resistance s/m + real(r8) :: rs_z(nlevleaf,maxpft,nclmax) + + ! net leaf photosynthesis averaged over sun and shade leaves. (umol CO2/m**2/s) + real(r8) :: anet_av_z(nlevleaf,maxpft,nclmax) + + ! Mask used to determine which leaf-layer biophysical rates have been + ! used already + logical :: rate_mask_z(nlevleaf,maxpft,nclmax) + + real(r8) :: vcmax_z ! leaf layer maximum rate of carboxylation + ! (umol co2/m**2/s) + real(r8) :: jmax_z ! leaf layer maximum electron transport rate + ! (umol electrons/m**2/s) + real(r8) :: tpu_z ! leaf layer triose phosphate utilization rate + ! (umol CO2/m**2/s) + real(r8) :: kp_z ! leaf layer initial slope of CO2 response + ! curve (C4 plants) + + real(r8) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) + real(r8) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) + real(r8) :: co2_cpoint ! CO2 compensation point (Pa) + real(r8) :: btran_eff ! effective transpiration wetness factor (0 to 1) + real(r8) :: bbb ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + real(r8) :: kn(maxpft) ! leaf nitrogen decay coefficient + real(r8) :: cf ! s m**2/umol -> s/m + real(r8) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8) :: ceair ! vapor pressure of air, constrained (Pa) + real(r8) :: nscaler ! leaf nitrogen scaling coefficient + real(r8) :: leaf_frac ! ratio of to leaf biomass to total alive biomass + real(r8) :: laican ! canopy sum of lai_z + real(r8) :: vai ! leaf and steam area in ths layer. + real(r8) :: tcsoi ! Temperature response function for root respiration. + real(r8) :: tcwood ! Temperature response function for wood + real(r8) :: rscanopy ! Canopy resistance [s/m] + real(r8) :: elai ! exposed LAI (patch scale) + real(r8) :: live_stem_n ! Live stem (above-ground sapwood) + ! nitrogen content (kgN/plant) + real(r8) :: live_croot_n ! Live coarse root (below-ground sapwood) + ! nitrogen content (kgN/plant) + real(r8) :: froot_n ! Fine root nitrogen content (kgN/plant) + real(r8) :: gccanopy_pa ! Patch level canopy stomatal conductance [mmol m-2 s-1] + + ! ----------------------------------------------------------------------------------- + ! Keeping these two definitions in case they need to be added later + ! + ! ----------------------------------------------------------------------------------- + !real(r8) :: psncanopy_pa ! patch sunlit leaf photosynthesis (umol CO2 /m**2/ s) + !real(r8) :: lmrcanopy_pa ! patch sunlit leaf maintenance respiration rate (umol CO2/m**2/s) + + integer :: cl,s,iv,j,ps,ft,ifp ! indices + integer :: nv ! number of leaf layers + integer :: NCL_p ! number of canopy layers in patch + + ! Parameters + ! ----------------------------------------------------------------------- + ! Base maintenance respiration rate for plant tissues base_mr_20 + ! M. Ryan, 1991. Effects of climate change on plant respiration. + ! Ecological Applications, 1(2), 157-167. + ! Original expression is br = 0.0106 molC/(molN h) + ! Conversion by molecular weights of C and N gives 2.525e-6 gC/(gN s) + ! + ! Base rate is at 20C. Adjust to 25C using the CN Q10 = 1.5 + ! (gC/gN/s) + ! ------------------------------------------------------------------------ + + ! ----------------------------------------------------------------------------------- + ! Photosynthesis and stomatal conductance parameters, from: + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + ! ----------------------------------------------------------------------------------- + + ! Ball-Berry minimum leaf conductance, unstressed (umol H2O/m**2/s) + ! For C3 and C4 plants + ! ----------------------------------------------------------------------------------- + real(r8), dimension(2) :: bbbopt + + + associate( & + c3psn => EDPftvarcon_inst%c3psn , & + slatop => EDPftvarcon_inst%slatop , & ! specific leaf area at top of canopy, + ! projected area basis [m^2/gC] + flnr => EDPftvarcon_inst%flnr , & ! fraction of leaf N in the Rubisco + ! enzyme (gN Rubisco / gN leaf) + woody => EDPftvarcon_inst%woody , & ! Is vegetation woody or not? + fnitr => EDPftvarcon_inst%fnitr , & ! foliage nitrogen limitation factor (-) + leafcn => EDPftvarcon_inst%leafcn , & ! leaf C:N (gC/gN) + frootcn => EDPftvarcon_inst%frootcn, & ! froot C:N (gc/gN) ! slope of BB relationship + q10 => FatesSynchronizedParamsInst%Q10 ) + + bbbopt(1) = ED_val_bbopt_c3 + bbbopt(2) = ED_val_bbopt_c4 + + do s = 1,nsites + + ! Multi-layer parameters scaled by leaf nitrogen profile. + ! Loop through each canopy layer to calculate nitrogen profile using + ! cumulative lai at the midpoint of the layer + + ifp = 0 + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + + ifp = ifp+1 + NCL_p = currentPatch%NCL_p + + ! Part I. Zero output boundary conditions + ! --------------------------------------------------------------------------- + bc_out(s)%rssun_pa(ifp) = 0._r8 + bc_out(s)%rssha_pa(ifp) = 0._r8 + + gccanopy_pa = 0._r8 + + !psncanopy_pa = 0._r8 + !lmrcanopy_pa = 0._r8 + + ! Part II. Filter out patches + ! Patch level filter flag for photosynthesis calculations + ! has a short memory, flags: + ! 1 = patch has not been called + ! 2 = patch is currently marked for photosynthesis + ! 3 = patch has been called for photosynthesis already + ! --------------------------------------------------------------------------- + if(bc_in(s)%filter_photo_pa(ifp)==2)then + + + ! Part III. Calculate the number of sublayers for each pft and layer. + ! And then identify which layer/pft combinations have things in them. + ! Output: + ! currentPatch%ncan(:,:) + ! currentPatch%present(:,:) + call UpdateCanopyNCanNRadPresent(currentPatch) + + + ! Part IV. Identify some environmentally derived parameters: + ! These quantities are biologically irrelevant + ! Michaelis-Menten constant for CO2 (Pa) + ! Michaelis-Menten constant for O2 (Pa) + ! CO2 compensation point (Pa) + ! CF? I have no idea what cf is (rgk 12-01-2016) + ! leaf boundary layer conductance of h20 + ! constrained vapor pressure + call GetCanopyGasParameters(bc_in(s)%forc_pbot, & ! in + bc_in(s)%oair_pa(ifp), & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + bc_in(s)%tgcm_pa(ifp), & ! in + bc_in(s)%eair_pa(ifp), & ! in + bc_in(s)%esat_tv_pa(ifp), & ! in + bc_in(s)%rb_pa(ifp), & ! in + mm_kco2, & ! out + mm_ko2, & ! out + co2_cpoint, & ! out + cf, & ! out + gb_mol, & ! out + ceair) ! out + + ! Part V. Pre-process some variables that are PFT dependent + ! but not environmentally dependent + ! ------------------------------------------------------------------------ + + do ft = 1,numpft_ed + + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 used + ! kn = 0.11. Here, derive kn from vcmax25 as in Lloyd et al + ! (2010) Biogeosciences, 7, 1833-1859 + ! Remove daylength factor from vcmax25 so that kn is based on maximum vcmax25 + + if (bc_in(s)%dayl_factor_pa(ifp) == 0._r8) then + kn(ft) = 0._r8 + else + kn(ft) = exp(0.00963_r8 * param_derived%vcmax25top(ft) - 2.43_r8) + end if + + end do !ft + + call set_root_fraction(currentPatch,bc_in(s)%zi_sisl) + + ! ------------------------------------------------------------------------ + ! Part VI: Loop over all leaf layers. + ! The concept of leaf layers is a result of the radiative transfer scheme. + ! A leaf layer has uniform radiation environment. Leaf layers are a group + ! of vegetation surfaces (stems and leaves) which inhabit the same + ! canopy-layer "CL", have the same functional type "ft" and within those + ! two partitions are further partitioned into vertical layers where + ! downwelling radiation attenuates in order. + ! In this phase we loop over the leaf layers and calculate the + ! photosynthesis and respiration of the layer (since all biophysical + ! properties are homogeneous). After this step, we can loop through + ! our cohort list, associate each cohort with its list of leaf-layers + ! and transfer these quantities to the cohort. + ! With plant hydraulics, we must realize that photosynthesis and + ! respiration will be different for leaves of each cohort in the leaf + ! layers, as they will have there own hydraulic limitations. + ! NOTE: Only need to flush mask on the number of used pfts, not the whole + ! scratch space. + ! ------------------------------------------------------------------------ + rate_mask_z(:,1:numpft_ed,:) = .false. + + if(currentPatch%countcohorts > 0.0)then ! Ignore empty patches + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) ! Cohort loop + + ! Identify the canopy layer (cl), functional type (ft) + ! and the leaf layer (IV) for this cohort + ft = currentCohort%pft + cl = currentCohort%canopy_layer + + + ! are there any leaves of this pft in this layer? + if(currentPatch%present(cl,ft) == 1)then + + if(cl==NCL_p)then !are we in the top canopy layer or a shaded layer? + laican = 0._r8 + else + laican = sum(currentPatch%canopy_layer_lai(cl+1:NCL_p)) + end if + + ! Loop over leaf-layers + do iv = 1,currentCohort%nv + + ! ------------------------------------------------------------ + ! If we are doing plant hydro-dynamics (or any run-type + ! where cohorts may generate different photosynthetic rates + ! of other cohorts in the same canopy-pft-layer combo), + ! we re-calculate the leaf biophysical rates for the + ! cohort-layer combo of interest. + ! but in the vanilla case, we only re-calculate if it has + ! not been done yet. + ! ------------------------------------------------------------ + + if ( .not.rate_mask_z(iv,ft,cl) .or. use_fates_plant_hydro ) then + + if (use_fates_plant_hydro) then +! write(fates_log(),*) 'use_fates_plant_hydro in EDTypes' +! write(fates_log(),*) 'has been set to true. You have inadvertently' +! write(fates_log(),*) 'turned on a future feature that is not in the' +! write(fates_log(),*) 'FATES codeset yet. Please set this to' +! write(fates_log(),*) 'false and re-compile.' +! call endrun(msg=errMsg(sourcefile, __LINE__)) + + bbb = max (bbbopt(nint(c3psn(ft)))*currentCohort%co_hydr%btran(1), 1._r8) + btran_eff = currentCohort%co_hydr%btran(1) + else + bbb = max (bbbopt(nint(c3psn(ft)))*currentPatch%btran_ft(ft), 1._r8) + btran_eff = currentPatch%btran_ft(ft) + end if + + ! Vegetation area index + vai = (currentPatch%elai_profile(cl,ft,iv)+currentPatch%esai_profile(cl,ft,iv)) + if (iv == 1) then + laican = laican + 0.5_r8 * vai + else + laican = laican + 0.5_r8 * (currentPatch%elai_profile(cl,ft,iv-1)+ & + currentPatch%esai_profile(cl,ft,iv-1))+vai + end if + + ! Scale for leaf nitrogen profile + nscaler = exp(-kn(ft) * laican) + + ! Part VII: Calculate dark respiration (leaf maintenance) for this layer + call LeafLayerMaintenanceRespiration( param_derived%lmr25top(ft),& ! in + nscaler, & ! in + ft, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + lmr_z(iv,ft,cl)) ! out + + ! Part VII: Calculate (1) maximum rate of carboxylation (vcmax), + ! (2) maximum electron transport rate, (3) triose phosphate + ! utilization rate and (4) the initial slope of CO2 response curve + ! (C4 plants). Earlier we calculated their base rates as dictated + ! by their plant functional type and some simple scaling rules for + ! nitrogen limitation baesd on canopy position (not prognostic). + ! These rates are the specific rates used in the actual photosynthesis + ! calculations that take localized environmental effects (temperature) + ! into consideration. + + call LeafLayerBiophysicalRates(currentPatch%ed_parsun_z(cl,ft,iv), & ! in + ft, & ! in + param_derived%vcmax25top(ft), & ! in + param_derived%jmax25top(ft), & ! in + param_derived%tpu25top(ft), & ! in + param_derived%kp25top(ft), & ! in + nscaler, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + btran_eff, & ! in + vcmax_z, & ! out + jmax_z, & ! out + tpu_z, & ! out + kp_z ) ! out + + ! Part IX: This call calculates the actual photosynthesis for the + ! leaf layer, as well as the stomatal resistance and the net assimilated carbon. + + call LeafLayerPhotosynthesis(currentPatch%f_sun(cl,ft,iv), & ! in + currentPatch%ed_parsun_z(cl,ft,iv), & ! in + currentPatch%ed_parsha_z(cl,ft,iv), & ! in + currentPatch%ed_laisun_z(cl,ft,iv), & ! in + currentPatch%ed_laisha_z(cl,ft,iv), & ! in + currentPatch%canopy_area_profile(cl,ft,iv), & ! in + ft, & ! in + vcmax_z, & ! in + jmax_z, & ! in + tpu_z, & ! in + kp_z, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + bc_in(s)%esat_tv_pa(ifp), & ! in + bc_in(s)%forc_pbot, & ! in + bc_in(s)%cair_pa(ifp), & ! in + bc_in(s)%oair_pa(ifp), & ! in + btran_eff, & ! in + bbb, & ! in + cf, & ! in + gb_mol, & ! in + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr_z(iv,ft,cl), & ! in + currentPatch%psn_z(cl,ft,iv), & ! out + rs_z(iv,ft,cl), & ! out + anet_av_z(iv,ft,cl)) ! out + + rate_mask_z(iv,ft,cl) = .true. + end if + end do + + ! Zero cohort flux accumulators. + currentCohort%npp_tstep = 0.0_r8 + currentCohort%resp_tstep = 0.0_r8 + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rdark = 0.0_r8 + currentCohort%resp_m = 0.0_r8 + currentCohort%ts_net_uptake = 0.0_r8 + + ! --------------------------------------------------------------- + ! Part VII: Transfer leaf flux rates (like maintenance respiration, + ! carbon assimilation and conductance) that are defined by the + ! leaf layer (which is area independent, ie /m2) onto each cohort + ! (where the rates become per cohort, ie /individual). Most likely + ! a sum over layers. + ! --------------------------------------------------------------- + nv = currentCohort%nv + call ScaleLeafLayerFluxToCohort(nv, & !in + currentPatch%psn_z(cl,ft,1:nv), & !in + lmr_z(1:nv,ft,cl), & !in + rs_z(1:nv,ft,cl), & !in + anet_av_z(1:nv,ft,cl), & !in + currentPatch%elai_profile(cl,ft,1:nv), & !in + currentCohort%c_area, & !in + currentCohort%n, & !in + currentCohort%treelai, & !in + currentCohort%treesai, & !in + bc_in(s)%rb_pa(ifp), & !in + currentCohort%gscan, & !out + currentCohort%gpp_tstep, & !out + currentCohort%rdark) !out + + ! Net Uptake does not need to be scaled, just transfer directly + currentCohort%ts_net_uptake(1:nv) = anet_av_z(1:nv,ft,cl) * umolC_to_kgC + + else + + ! In this case, the cohort had no leaves, + ! so no productivity,conductance, transpiration uptake + ! or dark respiration + + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rdark = 0.0_r8 + currentCohort%gscan = 0.0_r8 + currentCohort%ts_net_uptake(:) = 0.0_r8 + + end if ! if(currentPatch%present(cl,ft) == 1)then + + + ! ------------------------------------------------------------------ + ! Part VIII: Calculate maintenance respiration in the sapwood and + ! fine root pools. + ! ------------------------------------------------------------------ + + leaf_frac = 1.0_r8/(currentCohort%canopy_trim + & + EDPftvarcon_inst%sapwood_ratio(currentCohort%pft) * & + currentCohort%hite + EDPftvarcon_inst%froot_leaf(currentCohort%pft)) + + + currentCohort%bsw = EDPftvarcon_inst%sapwood_ratio(currentCohort%pft) * & + currentCohort%hite * & + (currentCohort%balive + currentCohort%laimemory)*leaf_frac + + + ! Calculate the amount of nitrogen in the above and below ground + ! stem and root pools, used for maint resp + ! We are using the fine-root C:N ratio as an approximation for + ! the sapwood pools. + ! Units are in (kgN/plant) + ! ------------------------------------------------------------------ + live_stem_n = ED_val_ag_biomass * currentCohort%bsw / & + frootcn(currentCohort%pft) + live_croot_n = (1.0_r8-ED_val_ag_biomass) * currentCohort%bsw / & + frootcn(currentCohort%pft) + froot_n = currentCohort%br / frootcn(currentCohort%pft) + + + !------------------------------------------------------------------------------ + ! Calculate Whole Plant Respiration + ! (this doesn't really need to be in this iteration at all, surely?) + ! Response: (RGK 12-2016): I think the positioning of these calls is + ! appropriate as of now. Maintenance calculations in sapwood and roots + ! vary by cohort and with changing temperature at the minimum, and there are + ! no sub-pools chopping up those pools any finer that need to be dealty with. + !------------------------------------------------------------------------------ + + ! Live stem MR (kgC/plant/s) (above ground sapwood) + ! ------------------------------------------------------------------ + if (woody(ft) == 1) then + tcwood = q10**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) + ! kgC/s = kgN * kgC/kgN/s + currentCohort%livestem_mr = live_stem_n * ED_val_base_mr_20 * tcwood + else + currentCohort%livestem_mr = 0._r8 + end if + + + ! Fine Root MR (kgC/plant/s) + ! ------------------------------------------------------------------ + currentCohort%froot_mr = 0._r8 + do j = 1,hlm_numlevsoil + tcsoi = q10**((bc_in(s)%t_soisno_gl(j)-tfrz - 20.0_r8)/10.0_r8) + currentCohort%froot_mr = currentCohort%froot_mr + & + froot_n * ED_val_base_mr_20 * tcsoi * currentPatch%rootfr_ft(ft,j) + enddo + + ! Coarse Root MR (kgC/plant/s) (below ground sapwood) + ! ------------------------------------------------------------------ + if (woody(ft) == 1) then + currentCohort%livecroot_mr = 0._r8 + do j = 1,hlm_numlevsoil + ! Soil temperature used to adjust base rate of MR + tcsoi = q10**((bc_in(s)%t_soisno_gl(j)-tfrz - 20.0_r8)/10.0_r8) + currentCohort%livecroot_mr = currentCohort%livecroot_mr + & + live_croot_n * ED_val_base_mr_20 * tcsoi * & + currentPatch%rootfr_ft(ft,j) + enddo + else + currentCohort%livecroot_mr = 0._r8 + end if + + + ! ------------------------------------------------------------------ + ! Part IX: Perform some unit conversions (rate to integrated) and + ! calcualate some fluxes that are sums and nets of the base fluxes + ! ------------------------------------------------------------------ + + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 906 ', currentCohort%livestem_mr + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 907 ', currentCohort%livecroot_mr + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 908 ', currentCohort%froot_mr + + + + ! add on whole plant respiration values in kgC/indiv/s-1 + currentCohort%resp_m = currentCohort%livestem_mr + & + currentCohort%livecroot_mr + & + currentCohort%froot_mr + + ! no drought response right now.. something like: + ! resp_m = resp_m * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft) * & + ! EDPftvarcon_inst%resp_drought_response(ft)) + + currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark + + ! convert from kgC/indiv/s to kgC/indiv/timestep + currentCohort%resp_m = currentCohort%resp_m * dtime + currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime + currentCohort%ts_net_uptake = currentCohort%ts_net_uptake * dtime + + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep + if ( DEBUG ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m + + currentCohort%resp_g = EDPftvarcon_inst%grperc(ft) * & + (max(0._r8,currentCohort%gpp_tstep - & + currentCohort%resp_m)) + currentCohort%resp_tstep = currentCohort%resp_m + & + currentCohort%resp_g ! kgC/indiv/ts + currentCohort%npp_tstep = currentCohort%gpp_tstep - & + currentCohort%resp_tstep ! kgC/indiv/ts + + ! Accumulate stomatal conductance over the patch + gccanopy_pa = gccanopy_pa + & + currentCohort%gscan * & + currentCohort%n /currentPatch%total_canopy_area + + !psncanopy_pa = psncanopy_pa + currentCohort%gpp_tstep + !lmrcanopy_pa = lmrcanopy_pa + currentCohort%resp_m + + currentCohort => currentCohort%shorter + + enddo ! end cohort loop. + end if !count_cohorts is more than zero. + + + elai = calc_areaindex(currentPatch,'elai') + + !psncanopy_pa(ifp) = psncanopy_pa(ifp) / currentPatch%area + !lmrcanopy_pa(ifp) = lmrcanopy_pa(ifp) / currentPatch%area + + if(gccanopy_pa > 1._r8/rsmax0 .and. elai > 0.0_r8)then + rscanopy = (1.0_r8/gccanopy_pa)-bc_in(s)%rb_pa(ifp)/elai + else + rscanopy = rsmax0 + end if + + bc_out(s)%rssun_pa(ifp) = rscanopy + bc_out(s)%rssha_pa(ifp) = rscanopy + + + end if + + currentPatch => currentPatch%younger + + end do + + end do !site loop + + end associate + end subroutine FatesPlantRespPhotosynthDrive + + ! ======================================================================================= + + subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in + parsun_lsl, & ! in + parsha_lsl, & ! in + laisun_lsl, & ! in + laisha_lsl, & ! in + canopy_area_lsl, & ! in + ft, & ! in + vcmax, & ! in + jmax, & ! in + tpu, & ! in + co2_rcurve_islope, & ! in + veg_tempk, & ! in + veg_esat, & ! in + can_press, & ! in + can_co2_ppress, & ! in + can_o2_ppress, & ! in + btran, & ! in + bbb, & ! in + cf, & ! in + gb_mol, & ! in + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr, & ! in + psn_out, & ! out + rstoma_out, & ! out + anet_av_out) ! out + + ! ------------------------------------------------------------------------------------ + ! This subroutine calculates photosynthesis and stomatal conductance within each leaf + ! sublayer. + ! A note on naming conventions: As this subroutine is called for every + ! leaf-sublayer, many of the arguments are specific to that "leaf sub layer" + ! (LSL), those variables are given a dimension tag "_lsl" + ! Other arguments or variables may be indicative of scales broader than the LSL. + ! ------------------------------------------------------------------------------------ + + use EDPftvarcon , only : EDPftvarcon_inst + + ! Arguments + ! ------------------------------------------------------------------------------------ + real(r8), intent(in) :: f_sun_lsl ! + real(r8), intent(in) :: parsun_lsl ! Absorbed PAR in sunlist leaves + real(r8), intent(in) :: parsha_lsl ! Absorved PAR in shaded leaves + real(r8), intent(in) :: laisun_lsl ! LAI in sunlit leaves + real(r8), intent(in) :: laisha_lsl ! LAI in shaded leaves + real(r8), intent(in) :: canopy_area_lsl ! + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) + real(r8), intent(in) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) + real(r8), intent(in) :: tpu ! triose phosphate utilization rate (umol CO2/m**2/s) + real(r8), intent(in) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(in) :: veg_esat ! saturation vapor pressure at veg_tempk (Pa) + + ! Important Note on the following gas pressures. This photosynthesis scheme will iteratively + ! solve for the co2 partial pressure at the leaf surface (ie in the stomata). The reference + ! point for these input values are NOT within that boundary layer that separates the stomata from + ! the canopy air space. The reference point for these is on the outside of that boundary + ! layer. This routine, which operates at the leaf scale, makes no assumptions about what the + ! scale of the refernce is, it could be lower atmosphere, it could be within the canopy + ! but most likely it is the closest value one can get to the edge of the leaf's boundary + ! layer. We use the convention "can_" because a reference point of within the canopy + ! ia a best reasonable scenario of where we can get that information from. + + real(r8), intent(in) :: can_press ! Air pressure NEAR the surface of the leaf (Pa) + real(r8), intent(in) :: can_co2_ppress ! Partial pressure of CO2 NEAR the leaf surface (Pa) + real(r8), intent(in) :: can_o2_ppress ! Partial pressure of O2 NEAR the leaf surface (Pa) + real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) + real(r8), intent(in) :: bbb ! Ball-Berry minimum leaf conductance (umol H2O/m**2/s) + real(r8), intent(in) :: cf ! s m**2/umol -> s/m + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(in) :: ceair ! vapor pressure of air, constrained (Pa) + real(r8), intent(in) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) + real(r8), intent(in) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) + real(r8), intent(in) :: co2_cpoint ! CO2 compensation point (Pa) + real(r8), intent(in) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) + + real(r8), intent(out) :: psn_out ! carbon assimilated in this leaf layer umolC/m2/s + real(r8), intent(out) :: rstoma_out ! stomatal resistance (1/gs_lsl) (s/m) + real(r8), intent(out) :: anet_av_out ! net leaf photosynthesis (umol CO2/m**2/s) + ! averaged over sun and shade leaves. + + ! Locals + ! ------------------------------------------------------------------------ + integer :: pp_type ! Index for the different photosynthetic pathways C3,C4 + integer :: sunsha ! Index for differentiating sun and shade + real(r8) :: gstoma ! Stomatal Conductance of this leaf layer (m/s) + real(r8) :: agross ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: anet ! net leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: je ! electron transport rate (umol electrons/m**2/s) + real(r8) :: qabs ! PAR absorbed by PS II (umol photons/m**2/s) + real(r8) :: aquad,bquad,cquad ! terms for quadratic equations + real(r8) :: r1,r2 ! roots of quadratic equation + real(r8) :: co2_intra_c ! intracellular leaf CO2 (Pa) + real(r8) :: co2_intra_c_old ! intracellular leaf CO2 (Pa) (previous iteration) + logical :: loop_continue ! Loop control variable + integer :: niter ! iteration loop index + real(r8) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) + real(r8) :: gs ! leaf stomatal conductance (m/s) + real(r8) :: hs ! fractional humidity at leaf surface (dimensionless) + real(r8) :: gs_mol_err ! gs_mol for error check + real(r8) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + real(r8) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) + real(r8) :: ap ! product-limited (C3) or CO2-limited + ! (C4) gross photosynthesis (umol CO2/m**2/s) + real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) + real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) + real(r8) :: init_co2_intra_c ! First guess intracellular co2 specific to C path + ! Parameters + ! ------------------------------------------------------------------------ + ! Fraction of light absorbed by non-photosynthetic pigments + real(r8),parameter :: fnps = 0.15_r8 + + ! empirical curvature parameter for electron transport rate + real(r8),parameter :: theta_psii = 0.7_r8 + + ! First guess on ratio between intracellular co2 and the atmosphere + ! an iterator converges on actual + real(r8),parameter :: init_a2l_co2_c3 = 0.7_r8 + real(r8),parameter :: init_a2l_co2_c4 = 0.4_r8 + + ! quantum efficiency, used only for C4 (mol CO2 / mol photons) + real(r8),parameter,dimension(2) :: quant_eff = [0.0_r8,0.05_r8] + + ! empirical curvature parameter for ac, aj photosynthesis co-limitation + real(r8),parameter,dimension(2) :: theta_cj = [0.98_r8,0.80_r8] + + ! empirical curvature parameter for ap photosynthesis co-limitation + real(r8),parameter :: theta_ip = 0.95_r8 + + associate( bb_slope => EDPftvarcon_inst%BB_slope ) ! slope of BB relationship + + if (nint(EDPftvarcon_inst%c3psn(ft)) == 1) then! photosynthetic pathway: 0. = c4, 1. = c3 + pp_type = 1 + init_co2_intra_c = init_a2l_co2_c3 * can_co2_ppress + else + pp_type = 2 + init_co2_intra_c = init_a2l_co2_c4 * can_co2_ppress + end if + + ! Part III: Photosynthesis and Conductance + ! ---------------------------------------------------------------------------------- + + if ( parsun_lsl <= 0._r8 ) then ! night time + + anet_av_out = 0._r8 + psn_out = 0._r8 + rstoma_out = min(rsmax0, 1._r8/bbb * cf) + + else ! day time (a little bit more complicated ...) + +! if ( DEBUG ) write(fates_log(),*) 'EDphot 594 ',laisun_lsl +! if ( DEBUG ) write(fates_log(),*) 'EDphot 595 ',laisha_lsl + + !is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) + if ( laisun_lsl + laisha_lsl > 0._r8 ) then + +! if ( DEBUG ) write(fates_log(),*) '600 in laisun, laisha loop ' + + !Loop aroun shaded and unshaded leaves + psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. + rstoma_out = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. + anet_av_out = 0._r8 + gstoma = 0._r8 + + do sunsha = 1,2 + ! Electron transport rate for C3 plants. + ! Convert par from W/m2 to umol photons/m**2/s using the factor 4.6 + ! Convert from units of par absorbed per unit ground area to par + ! absorbed per unit leaf area. + + if(sunsha == 1)then !sunlit + if(( laisun_lsl * canopy_area_lsl) > 0.0000000001_r8)then + + qabs = parsun_lsl / (laisun_lsl * canopy_area_lsl ) + qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 + + else + qabs = 0.0_r8 + end if + else + + qabs = parsha_lsl / (laisha_lsl * canopy_area_lsl) + qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 + + end if + + !convert the absorbed par into absorbed par per m2 of leaf, + ! so it is consistant with the vcmax and lmr numbers. + aquad = theta_psii + bquad = -(qabs + jmax) + cquad = qabs * jmax + call quadratic_f (aquad, bquad, cquad, r1, r2) + je = min(r1,r2) + + ! Initialize intracellular co2 + co2_intra_c = init_co2_intra_c + + niter = 0 + loop_continue = .true. + do while(loop_continue) + ! Increment iteration counter. Stop if too many iterations + niter = niter + 1 + + ! Save old co2_intra_c + co2_intra_c_old = co2_intra_c + + ! Photosynthesis limitation rate calculations + if (pp_type == 1)then + + ! C3: Rubisco-limited photosynthesis + ac = vcmax * max(co2_intra_c-co2_cpoint, 0._r8) / & + (co2_intra_c+mm_kco2 * (1._r8+can_o2_ppress / mm_ko2 )) + + ! C3: RuBP-limited photosynthesis + aj = je * max(co2_intra_c-co2_cpoint, 0._r8) / & + (4._r8*co2_intra_c+8._r8*co2_cpoint) + + ! C3: Product-limited photosynthesis + ap = 3._r8 * tpu + + else + + ! C4: Rubisco-limited photosynthesis + ac = vcmax + + ! C4: RuBP-limited photosynthesis + if(sunsha == 1)then !sunlit + !guard against /0's in the night. + if((laisun_lsl * canopy_area_lsl) > 0.0000000001_r8) then + aj = quant_eff(pp_type) * parsun_lsl * 4.6_r8 + !convert from per cohort to per m2 of leaf) + aj = aj / (laisun_lsl * canopy_area_lsl) + else + aj = 0._r8 + end if + else + aj = quant_eff(pp_type) * parsha_lsl * 4.6_r8 + aj = aj / (laisha_lsl * canopy_area_lsl) + end if + + ! C4: PEP carboxylase-limited (CO2-limited) + ap = co2_rcurve_islope * max(co2_intra_c, 0._r8) / can_press + + end if + + ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap + aquad = theta_cj(pp_type) + bquad = -(ac + aj) + cquad = ac * aj + call quadratic_f (aquad, bquad, cquad, r1, r2) + ai = min(r1,r2) + + aquad = theta_ip + bquad = -(ai + ap) + cquad = ai * ap + call quadratic_f (aquad, bquad, cquad, r1, r2) + agross = min(r1,r2) + + ! Net carbon assimilation. Exit iteration if an < 0 + anet = agross - lmr + if (anet < 0._r8) then + loop_continue = .false. + end if + + ! Quadratic gs_mol calculation with an known. Valid for an >= 0. + ! With an <= 0, then gs_mol = bbb + + leaf_co2_ppress = can_co2_ppress- 1.4_r8/gb_mol * anet * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + aquad = leaf_co2_ppress + bquad = leaf_co2_ppress*(gb_mol - bbb) - bb_slope(ft) * anet * can_press + cquad = -gb_mol*(leaf_co2_ppress*bbb + & + bb_slope(ft)*anet*can_press * ceair/ veg_esat ) + + call quadratic_f (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) + + ! Derive new estimate for co2_intra_c + co2_intra_c = can_co2_ppress - anet * can_press * & + (1.4_r8*gs_mol+1.6_r8*gb_mol) / (gb_mol*gs_mol) + + ! Check for co2_intra_c convergence. Delta co2_intra_c/pair = mol/mol. + ! Multiply by 10**6 to convert to umol/mol (ppm). Exit iteration if + ! convergence criteria of +/- 1 x 10**-6 ppm is met OR if at least ten + ! iterations (niter=10) are completed + + if ((abs(co2_intra_c-co2_intra_c_old)/can_press*1.e06_r8 <= 2.e-06_r8) & + .or. niter == 5) then + loop_continue = .false. + end if + end do !iteration loop + + ! End of co2_intra_c iteration. Check for an < 0, in which case gs_mol = bbb + if (anet < 0._r8) then + gs_mol = bbb + end if + + ! Final estimates for leaf_co2_ppress and co2_intra_c + ! (needed for early exit of co2_intra_c iteration when an < 0) + leaf_co2_ppress = can_co2_ppress - 1.4_r8/gb_mol * anet * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + co2_intra_c = can_co2_ppress - anet * can_press * & + (1.4_r8*gs_mol+1.6_r8*gb_mol) / (gb_mol*gs_mol) + + ! Convert gs_mol (umol H2O/m**2/s) to gs (m/s) and then to rs (s/m) + gs = gs_mol / cf + +! if ( DEBUG ) write(fates_log(),*) 'EDPhoto 737 ', psn_out +! if ( DEBUG ) write(fates_log(),*) 'EDPhoto 738 ', agross +! if ( DEBUG ) write(fates_log(),*) 'EDPhoto 739 ', f_sun_lsl + + ! Accumulate total photosynthesis umol/m2 ground/s-1. + ! weight per unit sun and sha leaves. + if(sunsha == 1)then !sunlit + psn_out = psn_out + agross * f_sun_lsl + anet_av_out = anet_av_out + anet * f_sun_lsl + gstoma = gstoma + 1._r8/(min(1._r8/gs, rsmax0)) * f_sun_lsl + else + psn_out = psn_out + agross * (1.0_r8-f_sun_lsl) + anet_av_out = anet_av_out + anet * (1.0_r8-f_sun_lsl) + gstoma = gstoma + & + 1._r8/(min(1._r8/gs, rsmax0)) * (1.0_r8-f_sun_lsl) + end if + +! if ( DEBUG ) write(fates_log(),*) 'EDPhoto 758 ', psn_out +! if ( DEBUG ) write(fates_log(),*) 'EDPhoto 759 ', agross +! if ( DEBUG ) write(fates_log(),*) 'EDPhoto 760 ', f_sun_lsl + + ! Make sure iterative solution is correct + if (gs_mol < 0._r8) then + write (fates_log(),*)'Negative stomatal conductance:' + write (fates_log(),*)'gs_mol= ',gs_mol + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress p + b + hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) + gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/leaf_co2_ppress*can_press + bbb + + if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then + write (fates_log(),*) 'CF: Ball-Berry error check - stomatal conductance error:' + write (fates_log(),*) gs_mol, gs_mol_err + end if + + enddo !sunsha loop + + !average leaf-level stomatal resistance rate over sun and shade leaves... + rstoma_out = 1._r8/gstoma + + else + !No leaf area. This layer is present only because of stems. + ! (leaves are off, or have reduced to 0) + psn_out = 0._r8 + rstoma_out = min(rsmax0, 1._r8/bbb * cf) + + end if !is there leaf area? + + + end if ! night or day + end associate + return + end subroutine LeafLayerPhotosynthesis + + ! ===================================================================================== + + subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv + psn_llz, & ! in %psn_z(1:currentCohort%nv,ft,cl) + lmr_llz, & ! in lmr_z(1:currentCohort%nv,ft,cl) + rs_llz, & ! in rs_z(1:currentCohort%nv,ft,cl) + anet_av_llz, & ! in anet_av_z(1:currentCohort%nv,ft,cl) + elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) + c_area, & ! in currentCohort%c_area + nplant, & ! in currentCohort%n + treelai, & ! in currentCohort%treelai + treesai, & ! in currentCohort%treesai + rb, & ! in bc_in(s)%rb_pa(ifp) + gscan, & ! out currentCohort%gscan + gpp, & ! out currentCohort%gpp_tstep + rdark) ! out currentCohort%rdark + + ! ------------------------------------------------------------------------------------ + ! This subroutine effectively integrates leaf carbon fluxes over the + ! leaf layers to give cohort totals. + ! Some arguments have the suffix "_llz". This indicates that the vector + ! is stratefied in the leaf-layer (ll) dimension, and is a portion of the calling + ! array which has the "_z" tag, thus "llz". + ! ------------------------------------------------------------------------------------ + + use FatesConstantsMod, only : umolC_to_kgC + use EDTypesMod, only : dinc_ed + + ! Arguments + integer, intent(in) :: nv ! number of active leaf layers + real(r8), intent(in) :: psn_llz(nv) ! umolC/m2leaf/s + real(r8), intent(in) :: lmr_llz(nv) ! umolC/m2leaf/s + real(r8), intent(in) :: rs_llz(nv) ! s/m + real(r8), intent(in) :: anet_av_llz(nv) ! umolC/m2leaf/s + real(r8), intent(in) :: elai_llz(nv) ! exposed LAI per layer + real(r8), intent(in) :: c_area ! crown area m2/m2 + real(r8), intent(in) :: nplant ! indiv/m2 + real(r8), intent(in) :: treelai ! m2/m2 + real(r8), intent(in) :: treesai ! m2/m2 + real(r8), intent(in) :: rb ! boundary layer resistance (s/m) + + real(r8), intent(out) :: gscan ! Canopy conductance of the cohort m/s + real(r8), intent(out) :: gpp ! GPP (kgC/indiv/s) + real(r8), intent(out) :: rdark ! Dark Leaf Respiration (kgC/indiv/s) + + ! GPP IN THIS SUBROUTINE IS A RATE. THE CALLING ARGUMENT IS GPP_TSTEP. AFTER THIS + ! CALL THE RATE WILL BE MULTIPLIED BY THE INTERVAL TO GIVE THE INTEGRATED QUANT. + + ! Locals + real(r8) :: tree_area + real(r8) :: laifrac + + ! Convert from umolC/m2leaf/s to umolC/indiv/s ( x canopy area x 1m2 leaf area). + tree_area = c_area/nplant + + ! The routine is only called if there are leaves. If there are leaves, + ! there is at least 1 layer + + laifrac = (treelai+treesai)-dble(nv-1)*dinc_ed + + ! Canopy Conductance + gscan = 1.0_r8/(rs_llz(nv)+rb)*laifrac*tree_area + + ! GPP + gpp = psn_llz(nv) * elai_llz(nv) * laifrac * tree_area + + ! Dark respiration + rdark = lmr_llz(nv) * elai_llz(nv) * laifrac * tree_area + + ! If there is more than one layer, add the sum over the others + if ( nv>1 ) then + gpp = gpp + sum(psn_llz(1:nv-1) * elai_llz(1:nv-1)) * tree_area + rdark = rdark + sum(lmr_llz(1:nv-1) * elai_llz(1:nv-1)) * tree_area + gscan = gscan + sum((1.0_r8/(rs_llz(1:nv-1) + rb ))) * tree_area + end if + + ! Convert dark respiration and GPP from umol/plant/s to kgC/plant/s + + rdark = rdark * umolC_to_kgC + gpp = gpp * umolC_to_kgC + + if ( DEBUG ) then + write(fates_log(),*) 'EDPhoto 816 ', gpp + write(fates_log(),*) 'EDPhoto 817 ', psn_llz(1:nv) + write(fates_log(),*) 'EDPhoto 820 ', nv + write(fates_log(),*) 'EDPhoto 821 ', elai_llz(1:nv) + write(fates_log(),*) 'EDPhoto 843 ', rdark + write(fates_log(),*) 'EDPhoto 871 ', laifrac + write(fates_log(),*) 'EDPhoto 872 ', tree_area + write(fates_log(),*) 'EDPhoto 873 ', nv + endif + + return + end subroutine ScaleLeafLayerFluxToCohort + + ! ===================================================================================== + + function ft1_f(tl, ha) result(ans) + ! + !!DESCRIPTION: + ! photosynthesis temperature response + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + !!USES + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + ! + ! !ARGUMENTS: + real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) + real(r8), intent(in) :: ha ! activation energy in photosynthesis temperature function (J/mol) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- + + ans = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) + + return + end function ft1_f + + ! ===================================================================================== + + function fth_f(tl,hd,se,scaleFactor) result(ans) + ! + !!DESCRIPTION: + !photosynthesis temperature inhibition + ! + ! !REVISION HISTORY + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + + ! + ! !ARGUMENTS: + real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temp function (K) + real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) + real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) + real(r8), intent(in) :: scaleFactor ! scaling factor for high temp inhibition (25 C = 1.0) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- + + ans = scaleFactor / ( 1._r8 + exp( (-hd+se*tl) / (rgas*1.e-3_r8*tl) ) ) + + return + end function fth_f + + ! ===================================================================================== + + function fth25_f(hd,se)result(ans) + ! + !!DESCRIPTION: + ! scaling factor for photosynthesis temperature inhibition + ! + ! !REVISION HISTORY: + ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + !!USES + + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + + ! + ! !ARGUMENTS: + real(r8), intent(in) :: hd ! deactivation energy in photosynthesis temp function (J/mol) + real(r8), intent(in) :: se ! entropy term in photosynthesis temp function (J/mol/K) + ! + ! !LOCAL VARIABLES: + real(r8) :: ans + !------------------------------------------------------------------------------- + + ans = 1._r8 + exp( (-hd+se*(tfrz+25._r8)) / (rgas*1.e-3_r8*(tfrz+25._r8)) ) + + return + end function fth25_f + + ! ===================================================================================== + + subroutine quadratic_f (a, b, c, r1, r2) + ! + ! !DESCRIPTION: + !==============================================================================! + !----------------- Solve quadratic equation for its two roots -----------------! + !==============================================================================! + ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific + ! Computing (Cambridge University Press, Cambridge), pp. 145. + ! + ! !REVISION HISTORY: + ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: a,b,c ! Terms for quadratic equation + real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation + ! + ! !LOCAL VARIABLES: + real(r8) :: q ! Temporary term for quadratic solution + !------------------------------------------------------------------------------ + + if (a == 0._r8) then + write (fates_log(),*) 'Quadratic solution error: a = ',a + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if (b >= 0._r8) then + q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) + else + q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) + end if + + r1 = q / a + if (q /= 0._r8) then + r2 = c / q + else + r2 = 1.e36_r8 + end if + + end subroutine quadratic_f + + ! ==================================================================================== + + subroutine quadratic_fast (a, b, c, r1, r2) + ! + ! !DESCRIPTION: + !==============================================================================! + !----------------- Solve quadratic equation for its two roots -----------------! + ! THIS METHOD SIMPLY REMOVES THE DIV0 CHECK AND ERROR REPORTING ! + !==============================================================================! + ! Solution from Press et al (1986) Numerical Recipes: The Art of Scientific + ! Computing (Cambridge University Press, Cambridge), pp. 145. + ! + ! !REVISION HISTORY: + ! 4/5/10: Adapted from /home/bonan/ecm/psn/An_gs_iterative.f90 by Keith Oleson + ! 7/23/16: Copied over from CLM by Ryan Knox + ! + ! !USES: + ! + ! !ARGUMENTS: + real(r8), intent(in) :: a,b,c ! Terms for quadratic equation + real(r8), intent(out) :: r1,r2 ! Roots of quadratic equation + ! + ! !LOCAL VARIABLES: + real(r8) :: q ! Temporary term for quadratic solution + !------------------------------------------------------------------------------ + + ! if (a == 0._r8) then + ! write (fates_log(),*) 'Quadratic solution error: a = ',a + ! call endrun(msg=errMsg(sourcefile, __LINE__)) + ! end if + + if (b >= 0._r8) then + q = -0.5_r8 * (b + sqrt(b*b - 4._r8*a*c)) + else + q = -0.5_r8 * (b - sqrt(b*b - 4._r8*a*c)) + end if + + r1 = q / a + ! if (q /= 0._r8) then + r2 = c / q + ! else + ! r2 = 1.e36_r8 + ! end if + + end subroutine quadratic_fast + + + ! ==================================================================================== + + subroutine UpdateCanopyNCanNRadPresent(currentPatch) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates two patch level quanities: + ! currentPatch%ncan and + ! currentPatch%present + ! + ! currentPatch%ncan(:,:) is a two dimensional array that indicates + ! the total number of leaf layers (including those that are not exposed to light) + ! in each canopy layer and for each functional type. + ! + ! currentPatch%nrad(:,:) is a two dimensional array that indicates + ! the total number of EXPOSED leaf layers, but for all intents and purposes + ! in the photosynthesis routine, this appears to be the same as %ncan... + ! + ! currentPatch%present(:,:) has the same dimensions, is binary, and + ! indicates whether or not leaf layers are present (by evaluating the canopy area + ! profile). + ! --------------------------------------------------------------------------------- + + + use EDTypesMod , only : ed_patch_type + use EDTypesMod , only : ed_cohort_type + + ! Arguments + type(ed_patch_type), target :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + ! Locals + integer :: cl ! Canopy Layer Index + integer :: ft ! Function Type Index + integer :: iv ! index of the exposed leaf layer for each canopy layer and pft + + ! Loop through the cohorts in this patch, associate each cohort with a layer and PFT + ! and use the cohort's memory of how many layer's it takes up to assign the maximum + ! of the layer/pft index it is in + ! --------------------------------------------------------------------------------- + + currentPatch%ncan(:,:) = 0 + ! redo the canopy structure algorithm to get round a + ! bug that is happening for site 125, FT13. + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + + currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft) = & + max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft), & + currentCohort%NV) + + currentCohort => currentCohort%shorter + + enddo !cohort + + ! NRAD = NCAN ... + currentPatch%nrad = currentPatch%ncan + + ! Now loop through and identify which layer and pft combo has scattering elements + do cl = 1,nclmax + do ft = 1,numpft_ed + currentPatch%present(cl,ft) = 0 + do iv = 1, currentPatch%nrad(cl,ft); + if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then + currentPatch%present(cl,ft) = 1 + end if + end do !iv + enddo !ft + enddo !cl + + return + end subroutine UpdateCanopyNCanNRadPresent + + ! ==================================================================================== + + subroutine GetCanopyGasParameters(can_press, & + can_o2_partialpress, & + veg_tempk, & + air_tempk, & + air_vpress, & + veg_esat, & + rb, & + mm_kco2, & + mm_ko2, & + co2_cpoint, & + cf, & + gb_mol, & + ceair) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates the specific Michaelis Menten Parameters (pa) for CO2 + ! and O2, as well as the CO2 compentation point. + ! --------------------------------------------------------------------------------- + + use FatesConstantsMod, only: umol_per_mol + use FatesConstantsMod, only: mmol_per_mol + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + + ! Arguments + real(r8), intent(in) :: can_press ! Air pressure within the canopy (Pa) + real(r8), intent(in) :: can_o2_partialpress ! Partial press of o2 in the canopy (Pa) + real(r8), intent(in) :: veg_tempk ! The temperature of the vegetation (K) + real(r8), intent(in) :: air_tempk ! Temperature of canopy air (K) + real(r8), intent(in) :: air_vpress ! Vapor pressure of canopy air (Pa) + real(r8), intent(in) :: veg_esat ! Saturated vapor pressure at veg surf (Pa) + real(r8), intent(in) :: rb ! Leaf Boundary layer resistance (s/m) + + real(r8), intent(out) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) + real(r8), intent(out) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) + real(r8), intent(out) :: co2_cpoint ! CO2 compensation point (Pa) + real(r8), intent(out) :: cf ! s m**2/umol -> s/m + real(r8), intent(out) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(out) :: ceair ! vapor pressure of air, constrained (Pa) + + ! Locals + real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) + real(r8) :: ko25 ! Michaelis-Menten constant for O2 at 25C (Pa) + real(r8) :: sco ! relative specificity of rubisco + real(r8) :: cp25 ! CO2 compensation point at 25C (Pa) + + ! --------------------------------------------------------------------------------- + ! Intensive values (per mol of air) + ! kc, ko, currentPatch, from: Bernacchi et al (2001) + ! Plant, Cell and Environment 24:253-259 + ! --------------------------------------------------------------------------------- + + real(r8), parameter :: mm_kc25_umol_per_mol = 404.9_r8 + real(r8), parameter :: mm_ko25_mmol_per_mol = 278.4_r8 + real(r8), parameter :: co2_cpoint_umol_per_mol = 42.75_r8 + + ! Activation energy, from: + ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 + ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 + + real(r8), parameter :: kcha = 79430._r8 ! activation energy for kc (J/mol) + real(r8), parameter :: koha = 36380._r8 ! activation energy for ko (J/mol) + real(r8), parameter :: cpha = 37830._r8 ! activation energy for cp (J/mol) + + + ! Derive sco from currentPatch and O2 using present-day O2 (0.209 mol/mol) and re-calculate + ! currentPatch to account for variation in O2 using currentPatch = 0.5 O2 / sco + + ! FIXME (RGK 11-30-2016 THere are more constants here, but I don't have enough information + ! about what they are or do, so I can't give them more descriptive names. Someone please + ! fill this in when possible) + + kc25 = ( mm_kc25_umol_per_mol / umol_per_mol ) * can_press + ko25 = ( mm_ko25_mmol_per_mol / mmol_per_mol ) * can_press + sco = 0.5_r8 * 0.209_r8 / (co2_cpoint_umol_per_mol / umol_per_mol ) + cp25 = 0.5_r8 * can_o2_partialpress / sco + + if( veg_tempk.gt.150_r8 .and. veg_tempk.lt.350_r8 )then + mm_kco2 = kc25 * ft1_f(veg_tempk, kcha) + mm_ko2 = ko25 * ft1_f(veg_tempk, koha) + co2_cpoint = cp25 * ft1_f(veg_tempk, cpha) + else + mm_kco2 = 1.0_r8 + mm_ko2 = 1.0_r8 + co2_cpoint = 1.0_r8 + end if + + ! THESE HARD CODED CONVERSIONS NEED TO BE CALLED FROM GLOBAL CONSTANTS + ! (RGK 10-13-201). THE MEANING OF CF IS UNCLEAR, BUT THIS APPEARS TO BE A MOLAR CONVERSION + + cf = can_press/(rgas*1.e-3_r8 * air_tempk )*1.e06_r8 + gb_mol = (1._r8/ rb) * cf + + ! Constrain eair >= 0.05*esat_tv so that solution does not blow up. This ensures + ! that hs does not go to zero. Also eair <= veg_esat so that hs <= 1 + ceair = min( max(air_vpress, 0.05_r8*veg_esat ),veg_esat ) + + + + return + end subroutine GetCanopyGasParameters + + ! ==================================================================================== + + subroutine LeafLayerMaintenanceRespiration(lmr25top_ft, & + nscaler, & + ft, & + veg_tempk, & + lmr) + + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + use EDPftvarcon , only : EDPftvarcon_inst + + ! Arguments + real(r8), intent(in) :: lmr25top_ft ! canopy top leaf maint resp rate at 25C + ! for this pft (umol CO2/m**2/s) + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(out) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) + + ! Locals + real(r8) :: lmr25 ! leaf layer: leaf maintenance respiration rate at 25C (umol CO2/m**2/s) + + ! Parameter + real(r8), parameter :: lmrha = 46390._r8 ! activation energy for lmr (J/mol) + real(r8), parameter :: lmrhd = 150650._r8 ! deactivation energy for lmr (J/mol) + real(r8), parameter :: lmrse = 490._r8 ! entropy term for lmr (J/mol/K) + real(r8), parameter :: lmrc = 1.15912391_r8 ! scaling factor for high + ! temperature inhibition (25 C = 1.0) + + ! Part I: Leaf Maintenance respiration: umol CO2 / m**2 [leaf] / s + ! ---------------------------------------------------------------------------------- + lmr25 = lmr25top_ft * nscaler + + if ( nint(EDpftvarcon_inst%c3psn(ft)) == 1)then + lmr = lmr25 * ft1_f(veg_tempk, lmrha) * & + fth_f(veg_tempk, lmrhd, lmrse, lmrc) + else + lmr = lmr25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + lmr = lmr / (1._r8 + exp( 1.3_r8*(veg_tempk-(tfrz+55._r8)) )) + end if + + ! Any hydrodynamic limitations could go here, currently none + ! lmr = lmr * (nothing) + + end subroutine LeafLayerMaintenanceRespiration + + ! ==================================================================================== + + subroutine LeafLayerBiophysicalRates( parsun_lsl, & + ft, & + vcmax25top_ft, & + jmax25top_ft, & + tpu25top_ft, & + co2_rcurve_islope25top_ft, & + nscaler, & + veg_tempk, & + btran, & + vcmax, & + jmax, & + tpu, & + co2_rcurve_islope ) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates the localized rates of several key photosynthesis + ! rates. By localized, we mean specific to the plant type and leaf layer, + ! which factors in leaf physiology, as well as environmental effects. + ! This procedure should be called prior to iterative solvers, and should + ! have pre-calculated the reference rates for the pfts before this. + ! + ! The output biophysical rates are: + ! vcmax: maximum rate of carboxilation, + ! jmax: maximum electron transport rate, + ! tpu: triose phosphate utilization rate and + ! co2_rcurve_islope: initial slope of CO2 response curve (C4 plants) + ! --------------------------------------------------------------------------------- + + use EDPftvarcon , only : EDPftvarcon_inst + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm + + ! Arguments + ! ------------------------------------------------------------------------------ + + real(r8), intent(in) :: parsun_lsl ! PAR absorbed in sunlit leaves for this layer + integer, intent(in) :: ft ! (plant) Functional Type Index + real(r8), intent(in) :: nscaler ! Scale for leaf nitrogen profile + real(r8), intent(in) :: vcmax25top_ft ! canopy top maximum rate of carboxylation at 25C + ! for this pft (umol CO2/m**2/s) + real(r8), intent(in) :: jmax25top_ft ! canopy top maximum electron transport rate at 25C + ! for this pft (umol electrons/m**2/s) + real(r8), intent(in) :: tpu25top_ft ! canopy top triose phosphate utilization rate at 25C + ! for this pft (umol CO2/m**2/s) + real(r8), intent(in) :: co2_rcurve_islope25top_ft ! initial slope of CO2 response curve + ! (C4 plants) at 25C, canopy top, this pft + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) + + real(r8), intent(out) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) + real(r8), intent(out) :: jmax ! maximum electron transport rate + ! (umol electrons/m**2/s) + real(r8), intent(out) :: tpu ! triose phosphate utilization rate + ! (umol CO2/m**2/s) + real(r8), intent(out) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) + + ! Locals + ! ------------------------------------------------------------------------------- + real(r8) :: vcmax25 ! leaf layer: maximum rate of carboxylation at 25C + ! (umol CO2/m**2/s) + real(r8) :: jmax25 ! leaf layer: maximum electron transport rate at 25C + ! (umol electrons/m**2/s) + real(r8) :: tpu25 ! leaf layer: triose phosphate utilization rate at 25C + ! (umol CO2/m**2/s) + real(r8) :: co2_rcurve_islope25 ! leaf layer: Initial slope of CO2 response curve + ! (C4 plants) at 25C + + + ! Parameters + ! --------------------------------------------------------------------------------- + real(r8) :: vcmaxha ! activation energy for vcmax (J/mol) + real(r8) :: jmaxha ! activation energy for jmax (J/mol) + real(r8) :: tpuha ! activation energy for tpu (J/mol) + real(r8) :: vcmaxhd ! deactivation energy for vcmax (J/mol) + real(r8) :: jmaxhd ! deactivation energy for jmax (J/mol) + real(r8) :: tpuhd ! deactivation energy for tpu (J/mol) + real(r8) :: vcmaxse ! entropy term for vcmax (J/mol/K) + real(r8) :: jmaxse ! entropy term for jmax (J/mol/K) + real(r8) :: tpuse ! entropy term for tpu (J/mol/K) + real(r8) :: vcmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8) :: jmaxc ! scaling factor for high temperature inhibition (25 C = 1.0) + real(r8) :: tpuc ! scaling factor for high temperature inhibition (25 C = 1.0) + + vcmaxha = EDPftvarcon_inst%vcmaxha(FT) + jmaxha = EDPftvarcon_inst%jmaxha(FT) + tpuha = EDPftvarcon_inst%tpuha(FT) + + vcmaxhd = EDPftvarcon_inst%vcmaxhd(FT) + jmaxhd = EDPftvarcon_inst%jmaxhd(FT) + tpuhd = EDPftvarcon_inst%tpuhd(FT) + + vcmaxse = EDPftvarcon_inst%vcmaxse(FT) + jmaxse = EDPftvarcon_inst%jmaxse(FT) + tpuse = EDPftvarcon_inst%tpuse(FT) + + vcmaxc = fth25_f(vcmaxhd, vcmaxse) + jmaxc = fth25_f(jmaxhd, jmaxse) + tpuc = fth25_f(tpuhd, tpuse) + + if ( parsun_lsl <= 0._r8) then ! night time + vcmax = 0._r8 + jmax = 0._r8 + tpu = 0._r8 + co2_rcurve_islope = 0._r8 + else ! day time + vcmax25 = vcmax25top_ft * nscaler + jmax25 = jmax25top_ft * nscaler + tpu25 = tpu25top_ft * nscaler + co2_rcurve_islope25 = co2_rcurve_islope25top_ft * nscaler + + ! Adjust for temperature + vcmax = vcmax25 * ft1_f(veg_tempk, vcmaxha) * fth_f(veg_tempk, vcmaxhd, vcmaxse, vcmaxc) + jmax = jmax25 * ft1_f(veg_tempk, jmaxha) * fth_f(veg_tempk, jmaxhd, jmaxse, jmaxc) + tpu = tpu25 * ft1_f(veg_tempk, tpuha) * fth_f(veg_tempk, tpuhd, tpuse, tpuc) + + if (nint(EDPftvarcon_inst%c3psn(ft)) /= 1) then + vcmax = vcmax25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + vcmax = vcmax / (1._r8 + exp( 0.2_r8*((tfrz+15._r8)-veg_tempk ) )) + vcmax = vcmax / (1._r8 + exp( 0.3_r8*(veg_tempk-(tfrz+40._r8)) )) + end if + !q10 response of product limited psn. + co2_rcurve_islope = co2_rcurve_islope25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + end if + + ! Adjust for water limitations + vcmax = vcmax * btran + + return + end subroutine LeafLayerBiophysicalRates + + end module FATESPlantRespPhotosynthMod diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 new file mode 100644 index 00000000..5d0586a2 --- /dev/null +++ b/fire/SFMainMod.F90 @@ -0,0 +1,990 @@ +module SFMainMod + + ! ============================================================================ + ! All subroutines realted to the SPITFIRE fire routine. + ! Code originally developed by Allan Spessa & Rosie Fisher as part of the NERC-QUEST project. + ! ============================================================================ + + use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : itrue, ifalse + use FatesInterfaceMod , only : hlm_masterproc ! 1= master process, 0=not master process + use EDTypesMod , only : numWaterMem + use FatesGlobals , only : fates_log + + use FatesInterfaceMod , only : bc_in_type + use EDPftvarcon , only : EDPftvarcon_inst + use EDEcophysconType , only : EDecophyscon + + use EDtypesMod , only : ed_site_type + use EDtypesMod , only : ed_patch_type + use EDtypesMod , only : ed_cohort_type + use EDtypesMod , only : AREA + use EDtypesMod , only : DL_SF + use EDtypesMod , only : FIRE_THRESHOLD + use EDTypesMod , only : TW_SF + use EDtypesMod , only : LB_SF + use EDtypesMod , only : LG_SF + use EDtypesMod , only : NCWD + use EDtypesMod , only : NFSC + use EDtypesMod , only : TR_SF + + implicit none + private + + public :: fire_model + public :: fire_danger_index + public :: charecteristics_of_fuel + public :: rate_of_spread + public :: ground_fuel_consumption + public :: fire_intensity + public :: wind_effect + public :: area_burnt + public :: crown_scorching + public :: crown_damage + public :: cambial_damage_kill + public :: post_fire_mortality + + integer :: write_SF = 0 ! for debugging + logical :: DEBUG = .false. ! for debugging + + ! ============================================================================ + ! ============================================================================ + +contains + + ! ============================================================================ + ! Area of site burned by fire + ! ============================================================================ + subroutine fire_model( currentSite, bc_in) + + use FatesInterfaceMod, only : hlm_use_spitfire + + type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type) , intent(in) :: bc_in + + + type (ed_patch_type), pointer :: currentPatch + + !zero fire things + currentPatch => currentSite%youngest_patch + do while(associated(currentPatch)) + currentPatch%frac_burnt = 0.0_r8 + currentPatch%AB = 0.0_r8 + currentPatch%fire = 0 + currentPatch => currentPatch%older + enddo + + if(write_SF==1)then + write(fates_log(),*) 'use_spitfire',hlm_use_spitfire + endif + + if( hlm_use_spitfire == itrue )then + call fire_danger_index(currentSite, bc_in) + call wind_effect(currentSite, bc_in) + call charecteristics_of_fuel(currentSite) + call rate_of_spread(currentSite) + call ground_fuel_consumption(currentSite) + call fire_intensity(currentSite) + call area_burnt(currentSite) + call crown_scorching(currentSite) + call crown_damage(currentSite) + call cambial_damage_kill(currentSite) + call post_fire_mortality(currentSite) + end if + + end subroutine fire_model + + !***************************************************************** + subroutine fire_danger_index ( currentSite, bc_in) + + !***************************************************************** + ! currentSite%acc_NI is the accumulated Nesterov fire danger index + + use SFParamsMod, only : SF_val_fdi_a, SF_val_fdi_b + use FatesConstantsMod , only : tfrz => t_water_freeze_k_1atm + use FatesConstantsMod , only : sec_per_day + + type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type) , intent(in) :: bc_in + + real(r8) :: temp_in_C ! daily averaged temperature in celcius + real(r8) :: rainfall ! daily precip in mm/day + real(r8) :: rh ! daily rh + + real yipsolon; !intermediate varable for dewpoint calculation + real dewpoint; !dewpoint in K + real d_NI; !daily change in Nesterov Index. C^2 + integer :: iofp ! index of oldest the fates patch + + ! NOTE that the boundary conditions of temperature, precipitation and relative humidity + ! are available at the patch level. We are currently using a simplification where the whole site + ! is simply using the values associated with the first patch. + ! which probably won't have much inpact, unless we decide to ever calculated the NI for each patch. + + iofp = currentSite%oldest_patch%patchno + + temp_in_C = bc_in%t_veg24_pa(iofp) - tfrz + rainfall = bc_in%precip24_pa(iofp)*sec_per_day + rh = bc_in%relhumid24_pa(iofp) + + if (rainfall > 3.0_r8) then !rezero NI if it rains... + d_NI = 0.0_r8 + currentSite%acc_NI = 0.0_r8 + else + yipsolon = (SF_val_fdi_a* temp_in_C)/(SF_val_fdi_b+ temp_in_C)+log(rh/100.0_r8) + dewpoint = (SF_val_fdi_b*yipsolon)/(SF_val_fdi_a-yipsolon) !Standard met. formula + d_NI = ( temp_in_C-dewpoint)* temp_in_C !follows Nesterov 1968. Equation 5. Thonicke et al. 2010. + if (d_NI < 0.0_r8) then !Change in NI cannot be negative. + d_NI = 0.0_r8 !check + endif + endif + currentSite%acc_NI = currentSite%acc_NI + d_NI !Accumulate Nesterov index over the fire season. + + end subroutine fire_danger_index + + + !***************************************************************** + subroutine charecteristics_of_fuel ( currentSite ) + !***************************************************************** + + use SFParamsMod, only : SF_val_alpha_FMC, SF_val_SAV, SF_val_FBD + + type(ed_site_type), intent(in), target :: currentSite + + type(ed_patch_type), pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + real(r8) timeav_swc + real(r8) fuel_moisture(nfsc) ! Scaled moisture content of small litter fuels. + real(r8) MEF(nfsc) ! Moisture extinction factor of fuels integer n + + fuel_moisture(:) = 0.0_r8 + + currentPatch => currentSite%oldest_patch; + do while(associated(currentPatch)) + ! How much live grass is there? + currentPatch%livegrass = 0.0_r8 + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + if(EDPftvarcon_inst%woody(currentCohort%pft) == 0)then + currentPatch%livegrass = currentPatch%livegrass + currentCohort%bl*currentCohort%n/currentPatch%area + endif + currentCohort => currentCohort%shorter + enddo + + ! There are SIX fuel classes + ! 1) Leaf litter, 2:5) four CWD_AG pools (twig, s branch, l branch, trunk) and 6) live grass + ! NCWD =4 + ! dl_sf = 1, tw_sf = 2, lb_sf = 4, tr_sf = 5, lg_sf = 6, + + ! zero fire arrays. + currentPatch%fuel_eff_moist = 0.0_r8 + currentPatch%fuel_bulkd = 0.0_r8 !this is kgBiomass/m2 for use in rate of spread equations + currentPatch%fuel_sav = 0.0_r8 + currentPatch%fuel_frac(:) = 0.0_r8 + currentPatch%fuel_mef = 0.0_r8 + currentPatch%sum_fuel = 0.0_r8 + currentPatch%fuel_frac = 0.0_r8 + + if(write_sf == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) ' leaf_litter1 ',currentPatch%leaf_litter + if ( hlm_masterproc == itrue ) write(fates_log(),*) ' leaf_litter2 ',sum(currentPatch%CWD_AG) + if ( hlm_masterproc == itrue ) write(fates_log(),*) ' leaf_litter3 ',currentPatch%livegrass + if ( hlm_masterproc == itrue ) write(fates_log(),*) ' sum fuel', currentPatch%sum_fuel + endif + + currentPatch%sum_fuel = sum(currentPatch%leaf_litter) + sum(currentPatch%CWD_AG) + currentPatch%livegrass + if(write_SF == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'sum fuel', currentPatch%sum_fuel,currentPatch%area + endif + ! =============================================== + ! Average moisture, bulk density, surface area-volume and moisture extinction of fuel + ! ================================================ + + if (currentPatch%sum_fuel > 0.0) then + ! Fraction of fuel in litter classes + currentPatch%fuel_frac(dl_sf) = sum(currentPatch%leaf_litter)/ currentPatch%sum_fuel + currentPatch%fuel_frac(tw_sf:tr_sf) = currentPatch%CWD_AG / currentPatch%sum_fuel + + if(write_sf == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ff1 ',currentPatch%fuel_frac + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ff2 ',currentPatch%fuel_frac + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ff2a ', & + lg_sf,currentPatch%livegrass,currentPatch%sum_fuel + endif + + currentPatch%fuel_frac(lg_sf) = currentPatch%livegrass / currentPatch%sum_fuel + MEF(1:nfsc) = 0.524_r8 - 0.066_r8 * log10(SF_val_SAV(1:nfsc)) + + !--- weighted average of relative moisture content--- + ! Equation 6 in Thonicke et al. 2010. across leaves,twig, small branch, and large branch + ! dead leaves and twigs included in 1hr pool per Thonicke (2010) + ! Calculate fuel moisture for trunks to hold value for fuel consumption + fuel_moisture(dl_sf:tr_sf) = exp(-1.0_r8 * SF_val_alpha_FMC(dl_sf:tr_sf) * currentSite%acc_NI) + + if(write_SF == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ff3 ',currentPatch%fuel_frac + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'fm ',fuel_moisture + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'csa ',currentSite%acc_NI + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'sfv ',SF_val_alpha_FMC + endif + ! FIX(RF,032414): needs refactoring. + ! average water content !is this the correct metric? + timeav_swc = sum(currentSite%water_memory(1:numWaterMem)) / dble(numWaterMem) + ! Equation B2 in Thonicke et al. 2010 + ! live grass moisture content depends on upper soil layer + fuel_moisture(lg_sf) = max(0.0_r8, 10.0_r8/9._r8 * timeav_swc - 1.0_r8/9.0_r8) + + ! Average properties over the first four litter pools (dead leaves, twigs, s branches, l branches) + currentPatch%fuel_bulkd = sum(currentPatch%fuel_frac(dl_sf:lb_sf) * SF_val_FBD(dl_sf:lb_sf)) + currentPatch%fuel_sav = sum(currentPatch%fuel_frac(dl_sf:lb_sf) * SF_val_SAV(dl_sf:lb_sf)) + currentPatch%fuel_mef = sum(currentPatch%fuel_frac(dl_sf:lb_sf) * MEF(dl_sf:lb_sf)) + currentPatch%fuel_eff_moist = sum(currentPatch%fuel_frac(dl_sf:lb_sf) * fuel_moisture(dl_sf:lb_sf)) + if(write_sf == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ff4 ',currentPatch%fuel_eff_moist + endif + ! Add on properties of live grass multiplied by grass fraction. (6) + currentPatch%fuel_bulkd = currentPatch%fuel_bulkd + currentPatch%fuel_frac(lg_sf) * SF_val_FBD(lg_sf) + currentPatch%fuel_sav = currentPatch%fuel_sav + currentPatch%fuel_frac(lg_sf) * SF_val_SAV(lg_sf) + currentPatch%fuel_mef = currentPatch%fuel_mef + currentPatch%fuel_frac(lg_sf) * MEF(lg_sf) + currentPatch%fuel_eff_moist = currentPatch%fuel_eff_moist + currentPatch%fuel_frac(lg_sf) * fuel_moisture(lg_sf) + + ! Correct averaging for the fact that we are not using the trunks pool for fire ROS and intensity (5) + ! Consumption of fuel in trunk pool does not influence fire ROS or intensity (Pyne 1996) + currentPatch%fuel_bulkd = currentPatch%fuel_bulkd * (1.0_r8/(1.0_r8-currentPatch%fuel_frac(tr_sf))) + currentPatch%fuel_sav = currentPatch%fuel_sav * (1.0_r8/(1.0_r8-currentPatch%fuel_frac(tr_sf))) + currentPatch%fuel_mef = currentPatch%fuel_mef * (1.0_r8/(1.0_r8-currentPatch%fuel_frac(tr_sf))) + currentPatch%fuel_eff_moist = currentPatch%fuel_eff_moist * (1.0_r8/(1.0_r8-currentPatch%fuel_frac(tr_sf))) + + ! Pass litter moisture into the fuel burning routine + ! (wo/me term in Thonicke et al. 2010) + currentPatch%litter_moisture(dl_sf:lb_sf) = fuel_moisture(dl_sf:lb_sf)/MEF(dl_sf:lb_sf) + currentPatch%litter_moisture(tr_sf) = fuel_moisture(tr_sf)/MEF(tr_sf) + currentPatch%litter_moisture(lg_sf) = fuel_moisture(lg_sf)/MEF(lg_sf) + + else + + if(write_SF == itrue)then + + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'no litter fuel at all',currentPatch%patchno, & + currentPatch%sum_fuel,sum(currentPatch%cwd_ag), & + sum(currentPatch%cwd_bg),sum(currentPatch%leaf_litter) + + endif + currentPatch%fuel_sav = sum(SF_val_SAV(1:nfsc))/(nfsc) ! make average sav to avoid crashing code. + + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'problem with spitfire fuel averaging' + + ! FIX(SPM,032414) refactor...should not have 0 fuel unless everything is burnt + ! off. + currentPatch%fuel_eff_moist = 0.0000000001_r8 + currentPatch%fuel_bulkd = 0.0000000001_r8 + currentPatch%fuel_frac(:) = 0.0000000001_r8 + currentPatch%fuel_mef = 0.0000000001_r8 + currentPatch%sum_fuel = 0.0000000001_r8 + currentPatch%fuel_frac = 0.0000000001_r8 + + endif + ! check values. + ! FIX(SPM,032414) refactor... + if(write_SF == itrue.and.currentPatch%fuel_sav <= 0.0_r8.or.currentPatch%fuel_bulkd <= & + 0.0_r8.or.currentPatch%fuel_mef <= 0.0_r8.or.currentPatch%fuel_eff_moist <= 0.0_r8)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'problem with spitfire fuel averaging' + endif + + currentPatch => currentPatch%younger + + enddo !end patch loop + + end subroutine charecteristics_of_fuel + + + !***************************************************************** + subroutine wind_effect ( currentSite, bc_in) + !*****************************************************************. + + ! Routine called daily from within ED within a site loop. + ! Calculates the effective windspeed based on vegetation charecteristics. + + use FatesConstantsMod, only : sec_per_min + + type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type) , intent(in) :: bc_in + + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + real(r8) :: wind ! daily wind in m/min + real(r8) :: total_grass_area ! per patch,in m2 + real(r8) :: tree_fraction ! site level. no units + real(r8) :: grass_fraction ! site level. no units + real(r8) :: bare_fraction ! site level. no units + integer :: iofp ! index of oldest fates patch + + ! note - this is a patch level temperature, which probably won't have much inpact, + ! unless we decide to ever calculated the NI for each patch. + + iofp = currentSite%oldest_patch%patchno + wind = bc_in%wind24_pa(iofp) * sec_per_min ! Convert to m/min for SPITFIRE units. + + if(write_SF == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'wind24', wind + endif + ! --- influence of wind speed, corrected for surface roughness---- + ! --- averaged over the whole grid cell to prevent extreme divergence + ! average_wspeed = 0.0_r8 + tree_fraction = 0.0_r8 + grass_fraction = 0.0_r8 + currentPatch=>currentSite%oldest_patch; + do while(associated(currentPatch)) + currentPatch%total_tree_area = 0.0_r8 + total_grass_area = 0.0_r8 + currentCohort => currentPatch%tallest + + do while(associated(currentCohort)) + write(fates_log(),*) 'SF currentCohort%c_area ',currentCohort%c_area + if(EDPftvarcon_inst%woody(currentCohort%pft) == 1)then + currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area + else + total_grass_area = total_grass_area + currentCohort%c_area + endif + currentCohort => currentCohort%shorter + enddo + tree_fraction = tree_fraction + min(currentPatch%area,currentPatch%total_tree_area)/AREA + grass_fraction = grass_fraction + min(currentPatch%area,total_grass_area)/AREA + + if(DEBUG)then + !write(fates_log(),*) 'SF currentPatch%area ',currentPatch%area + !write(fates_log(),*) 'SF currentPatch%total_area ',currentPatch%total_tree_area + !write(fates_log(),*) 'SF total_grass_area ',tree_fraction,grass_fraction + !write(fates_log(),*) 'SF AREA ',AREA + endif + + currentPatch => currentPatch%younger + enddo !currentPatch loop + + !if there is a cover of more than one, then the grasses are under the trees + grass_fraction = min(grass_fraction,1.0_r8-tree_fraction) + bare_fraction = 1.0 - tree_fraction - grass_fraction + if(write_sf == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'grass, trees, bare', & + grass_fraction, tree_fraction, bare_fraction + endif + + currentPatch=>currentSite%oldest_patch; + + do while(associated(currentPatch)) + currentPatch%total_tree_area = min(currentPatch%total_tree_area,currentPatch%area) + ! effect_wspeed in units m/min + currentPatch%effect_wspeed = wind * (tree_fraction*0.4+(grass_fraction+bare_fraction)*0.6) + + currentPatch => currentPatch%younger + enddo !end patch loop + + end subroutine wind_effect + + !***************************************************************** + subroutine rate_of_spread ( currentSite ) + !*****************************************************************. + !Routine called daily from within ED within a site loop. + !Returns the updated currentPatch%ROS_front value for each patch. + + use SFParamsMod, only : SF_val_miner_total, SF_val_part_dens, & + SF_val_miner_damp, SF_val_fuel_energy + + type(ed_site_type), intent(in), target :: currentSite + + type(ed_patch_type), pointer :: currentPatch + + real(r8) dummy + + ! Rothermal fire spread model parameters. + real(r8) beta,beta_op !weighted average of packing ratio (unitless) + real(r8) ir !reaction intensity (kJ/m2/min) + real(r8) xi,eps,phi_wind !all are unitless + real(r8) q_ig !heat of pre-ignition (kJ/kg) + real(r8) reaction_v_opt,reaction_v_max !reaction velocity (per min) + real(r8) moist_damp,mw_weight !moisture dampening coefficient and ratio fuel moisture to extinction + real(r8) bet !ratio of beta/beta_op + real(r8) a,b,c,e !function of fuel sav + + currentPatch=>currentSite%oldest_patch; + + do while(associated(currentPatch)) + + ! ---initialise parameters to zero.--- + bet = 0.0_r8; q_ig = 0.0_r8; eps = 0.0_r8; a = 0.0_r8; b = 0.0_r8; c = 0.0_r8; e = 0.0_r8 + phi_wind = 0.0_r8; xi = 0.0_r8; reaction_v_max = 0.0_r8; reaction_v_opt = 0.0_r8; mw_weight = 0.0_r8 + moist_damp = 0.0_r8; ir = 0.0_r8; dummy = 0.0_r8; + currentPatch%ROS_front = 0.0_r8 + ! remove mineral content from net fuel load per Thonicke 2010 for ir calculation + currentPatch%sum_fuel = currentPatch%sum_fuel * (1.0_r8 - SF_val_miner_total) !net of minerals + + ! ----start spreading--- + + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) & + 'SF - currentPatch%fuel_bulkd ',currentPatch%fuel_bulkd + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) & + 'SF - SF_val_part_dens ',SF_val_part_dens + + ! beta = packing ratio (unitless) + ! fraction of fuel array volume occupied by fuel or compactness of fuel bed + + beta = currentPatch%fuel_bulkd / SF_val_part_dens + + ! Equation A6 in Thonicke et al. 2010 + ! packing ratio (unitless) + beta_op = 0.200395_r8 *(currentPatch%fuel_sav**(-0.8189_r8)) + + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - beta ',beta + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - beta_op ',beta_op + bet = beta/beta_op !unitless + + if(write_sf == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'esf ',currentPatch%fuel_eff_moist + endif + + ! ---heat of pre-ignition--- + ! Equation A4 in Thonicke et al. 2010 + ! conversion of Rohtermal (1972) equation 12 in BTU/lb to current kJ/kg + ! q_ig in kJ/kg + q_ig = 581.0_r8 +2594.0_r8 * currentPatch%fuel_eff_moist + + ! ---effective heating number--- + ! Equation A3 in Thonicke et al. 2010. + eps = exp(-4.528_r8 / currentPatch%fuel_sav) + ! Equation A7 in Thonicke et al. 2010 + b = 0.15988_r8 * (currentPatch%fuel_sav**0.54_r8) + ! Equation A8 in Thonicke et al. 2010 + c = 7.47_r8 * (exp(-0.8711_r8 * (currentPatch%fuel_sav**0.55_r8))) + ! Equation A9 in Thonicke et al. 2010. + e = 0.715_r8 * (exp(-0.01094_r8 * currentPatch%fuel_sav)) + + if (DEBUG) then + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - c ',c + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) & + 'SF - currentPatch%effect_wspeed ',currentPatch%effect_wspeed + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - b ',b + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - bet ',bet + if ( hlm_masterproc == itrue .and.DEBUG) write(fates_log(),*) 'SF - e ',e + endif + + ! Equation A5 in Thonicke et al. 2010 + ! convert effect_wspeed from m/min to ft/min for Rothermel ROS eqn + ! phi_wind (unitless) + phi_wind = c * ((3.281_r8*currentPatch%effect_wspeed)**b)*(bet**(-e)) + + ! ---propagating flux---- + ! Equation A2 in Thonicke et al. + ! xi (unitless) + + xi = (exp((0.792_r8 + 3.7597_r8 * (currentPatch%fuel_sav**0.5_r8)) * (beta+0.1_r8))) / & + (192_r8+7.9095_r8 * currentPatch%fuel_sav) + + ! ---reaction intensity---- + ! Equation in table A1 Thonicke et al. 2010. + a = 8.9033_r8 * (currentPatch%fuel_sav**(-0.7913_r8)) + dummy = exp(a*(1-bet)) + ! Equation in table A1 Thonicke et al. 2010. + ! reaction_v_max and reaction_v_opt = reaction velocity in units of per min + + ! Equation 36 in Rothermal 1972 12 + reaction_v_max = 1.0_r8 / (0.0591_r8 + 2.926_r8* (currentPatch%fuel_sav**(-1.5_r8))) + ! Equation 38 in Rothermal 1972 and Fig 11 + reaction_v_opt = reaction_v_max*(bet**a)*dummy + + ! mw_weight = relative fuel moisture/fuel moisture of extinction + ! average values for litter pools (dead leaves, twigs, small and large branches) plus grass + mw_weight = currentPatch%fuel_eff_moist/currentPatch%fuel_mef + + ! Equation in table A1 Thonicke et al. 2010. + ! moist_damp is unitless + moist_damp = max(0.0_r8,(1.0_r8 - (2.59_r8 * mw_weight) + (5.11_r8 * (mw_weight**2.0_r8)) - & + (3.52_r8*(mw_weight**3.0_r8)))) + + ! FIX(SPM, 040114) ask RF if this should be an endrun + ! if(write_SF == itrue)then + ! write(fates_log(),*) 'moist_damp' ,moist_damp,mw_weight,currentPatch%fuel_eff_moist,currentPatch%fuel_mef + ! endif + + ! ir = reaction intenisty in kJ/m2/min + ! currentPatch%sum_fuel needs to be converted from kgC/m2 to kgBiomass/m2 for ir calculation + ir = reaction_v_opt*(currentPatch%sum_fuel/0.45_r8)*SF_val_fuel_energy*moist_damp*SF_val_miner_damp + + ! write(fates_log(),*) 'ir',gamma_aptr,moist_damp,SF_val_fuel_energy,SF_val_miner_damp + + if (((currentPatch%fuel_bulkd) <= 0.0_r8).or.(eps <= 0.0_r8).or.(q_ig <= 0.0_r8)) then + currentPatch%ROS_front = 0.0_r8 + else ! Equation 9. Thonicke et al. 2010. + ! forward ROS in m/min + currentPatch%ROS_front = (ir*xi*(1.0_r8+phi_wind)) / (currentPatch%fuel_bulkd*eps*q_ig) + ! write(fates_log(),*) 'ROS',currentPatch%ROS_front,phi_wind,currentPatch%effect_wspeed + ! write(fates_log(),*) 'ros calcs',currentPatch%fuel_bulkd,ir,xi,eps,q_ig + endif + ! Equation 10 in Thonicke et al. 2010 + ! backward ROS from Can FBP System (1992) in m/min + currentPatch%ROS_back = currentPatch%ROS_front*exp(-0.012_r8*currentPatch%effect_wspeed) + + currentPatch => currentPatch%younger + + enddo !end patch loop + + end subroutine rate_of_spread + + !***************************************************************** + subroutine ground_fuel_consumption ( currentSite ) + !***************************************************************** + !returns the the hypothetic fuel consumed by the fire + + use SFParamsMod, only : SF_val_miner_total, SF_val_min_moisture, & + SF_val_mid_moisture, SF_val_low_moisture_C, SF_val_low_moisture_S, & + SF_val_mid_moisture_C, SF_val_mid_moisture_S + + type(ed_site_type) , intent(in), target :: currentSite + + type(ed_patch_type), pointer :: currentPatch + + real(r8) :: moist !effective fuel moisture + real(r8) :: tau_b(nfsc) !lethal heating rates for each fuel class (min) + real(r8) :: fc_ground(nfsc) !propn of fuel consumed + + integer :: c + + currentPatch => currentSite%oldest_patch; + + do while(associated(currentPatch)) + currentPatch%burnt_frac_litter = 1.0_r8 + ! Calculate fraction of litter is burnt for all classes. + ! Equation B1 in Thonicke et al. 2010--- + do c = 1, nfsc !work out the burnt fraction for all pools, even if those pools dont exist. + moist = currentPatch%litter_moisture(c) + ! 1. Very dry litter + if (moist <= SF_val_min_moisture(c)) then + currentPatch%burnt_frac_litter(c) = 1.0_r8 + endif + ! 2. Low to medium moistures + if (moist > SF_val_min_moisture(c).and.moist <= SF_val_mid_moisture(c)) then + currentPatch%burnt_frac_litter(c) = max(0.0_r8,min(1.0_r8,SF_val_low_moisture_C(c)- & + SF_val_low_moisture_S(c)*moist)) + else + ! For medium to high moistures. + if (moist > SF_val_mid_moisture(c).and.moist <= 1.0_r8) then + currentPatch%burnt_frac_litter(c) = max(0.0_r8,min(1.0_r8,SF_val_mid_moisture_C(c)- & + SF_val_mid_moisture_S(c)*moist)) + endif + + endif + ! Very wet litter + if (moist >= 1.0_r8) then !this shouldn't happen? + currentPatch%burnt_frac_litter(c) = 0.0_r8 + endif + enddo !c + + ! we can't ever kill -all- of the grass. + currentPatch%burnt_frac_litter(lg_sf) = min(0.8_r8,currentPatch%burnt_frac_litter(lg_sf )) + ! reduce burnt amount for mineral content. + currentPatch%burnt_frac_litter = currentPatch%burnt_frac_litter * (1.0_r8-SF_val_miner_total) + + !---Calculate amount of fuel burnt.--- + FC_ground(dl_sf) = currentPatch%burnt_frac_litter(dl_sf) * sum(currentPatch%leaf_litter) + FC_ground(tw_sf:tr_sf) = currentPatch%burnt_frac_litter(tw_sf:tr_sf) * currentPatch%CWD_AG + FC_ground(lg_sf) = currentPatch%burnt_frac_litter(lg_sf) * currentPatch%livegrass + + ! Following used for determination of cambial kill follows from Peterson & Ryan (1986) scheme + ! less empirical cf current scheme used in SPITFIRE which attempts to mesh Rothermel + ! and P&R, and while solving potential inconsistencies, actually results in BIG values for + ! fire residence time, thus lots of vegetation death! + ! taul is the duration of the lethal heating. + ! The /10 is to convert from kgC/m2 into gC/cm2, as in the Peterson and Ryan paper #Rosie,Jun 2013 + + do c = 1,nfsc + tau_b(c) = 39.4_r8 *(currentPatch%fuel_frac(c)*currentPatch%sum_fuel/0.45_r8/10._r8)* & + (1.0_r8-((1.0_r8-currentPatch%burnt_frac_litter(c))**0.5_r8)) + enddo + tau_b(tr_sf) = 0.0_r8 + ! Cap the residence time to 8mins, as suggested by literature survey by P&R (1986). + currentPatch%tau_l = min(8.0_r8,sum(tau_b)) + + !---calculate overall fuel consumed by spreading fire --- + ! ignore 1000hr fuels. Just interested in fuels affecting ROS + currentPatch%TFC_ROS = sum(FC_ground)-FC_ground(tr_sf) + + currentPatch=>currentPatch%younger; + enddo !end patch loop + + end subroutine ground_fuel_consumption + + !***************************************************************** + subroutine fire_intensity ( currentSite ) + !***************************************************************** + !returns the updated currentPatch%FI value for each patch. + + !currentPatch%FI average fire intensity of flaming front during day. Backward ROS plays no role here. kJ/m/s or kW/m. + !currentPatch%ROS_front forward ROS (m/min) + !currentPatch%TFC_ROS total fuel consumed by flaming front (kgC/m2) + + use FatesInterfaceMod, only : hlm_use_spitfire + use SFParamsMod, only : SF_val_fdi_alpha,SF_val_fuel_energy, & + SF_val_max_durat, SF_val_durat_slope + + type(ed_site_type), intent(in), target :: currentSite + + type(ed_patch_type), pointer :: currentPatch + + real(r8) ROS !m/s + real(r8) W !kgBiomass/m2 + real(r8) :: d_fdi !change in the NI on this day to give fire duration. + + currentPatch => currentSite%oldest_patch; + + do while(associated(currentPatch)) + ROS = currentPatch%ROS_front / 60.0_r8 !m/min to m/sec + W = currentPatch%TFC_ROS / 0.45_r8 !kgC/m2 to kgbiomass/m2 + currentPatch%FI = SF_val_fuel_energy * W * ROS !kj/m/s, or kW/m + if(write_sf == itrue)then + if( hlm_masterproc == itrue ) write(fates_log(),*) 'fire_intensity',currentPatch%fi,W,currentPatch%ROS_front + endif + !'decide_fire' subroutine shortened and put in here... + if (currentPatch%FI >= fire_threshold) then ! 50kW/m is the threshold for a self-sustaining fire + currentPatch%fire = 1 ! Fire... :D + + ! This is like but not identical to equation 7 in Thonicke et al. 2010. WHY? + d_FDI = 1.0_r8 - exp(-SF_val_fdi_alpha*currentSite%acc_NI) !follows Venevsky et al GCB 2002 + ! Equation 14 in Thonicke et al. 2010 + ! fire duration in minutes + currentPatch%FD = SF_val_max_durat / (1.0_r8 + SF_val_max_durat * exp(SF_val_durat_slope*d_FDI)) + if(write_SF == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'fire duration minutes',currentPatch%fd + endif + !equation 15 in Arora and Boer CTEM model.Average fire is 1 day long. + !currentPatch%FD = 60.0_r8 * 24.0_r8 !no minutes in a day + else + currentPatch%fire = 0 ! No fire... :-/ + currentPatch%FD = 0.0_r8 + endif + ! FIX(SPM,032414) needs a refactor + ! FIX(RF,032414) : should happen outside of SF loop - doing all spitfire code is inefficient otherwise. + if( hlm_use_spitfire == ifalse )then + currentPatch%fire = 0 !fudge to turn fire off + endif + + currentPatch => currentPatch%younger; + enddo !end patch loop + + end subroutine fire_intensity + + + !***************************************************************** + subroutine area_burnt ( currentSite ) + !***************************************************************** + !currentPatch%AB !daily area burnt (m2) + !currentPatch%NF !Daily number of ignitions (lightning and human-caused), adjusted for size of patch. + + use EDParamsMod, only : ED_val_nignitions + + type(ed_site_type), intent(inout), target :: currentSite + type(ed_patch_type), pointer :: currentPatch + + real lb !length to breadth ratio of fire ellipse + real df !distance fire has travelled forward + real db !distance fire has travelled backward + real patch_area_in_m2 !'actual' patch area as applied to whole grid cell + real(r8) gridarea + real(r8) size_of_fire !in m2 + real(r8),parameter :: km2_to_m2 = 1000000.0_r8 !area conversion for square km to square m + integer g, p + + currentSite%frac_burnt = 0.0_r8 + + currentPatch => currentSite%oldest_patch; + do while(associated(currentPatch)) + currentPatch%AB = 0.0_r8 + currentPatch%frac_burnt = 0.0_r8 + lb = 0.0_r8; db = 0.0_r8; df = 0.0_r8 + + if (currentPatch%fire == 1) then + ! The feedback between vegetation structure and ellipse size if turned off for now, + ! to reduce the positive feedback in the syste, + ! This will also be investigated by William Hoffmans proposal. + ! if (currentPatch%effect_wspeed < 16.67_r8) then !16.67m/min = 1km/hr + lb = 1.0_r8 + ! else + !FIX(RF,032414) FOR NO GRASS + ! lb = currentPatch%total_canopy_area/currentPatch%area*(1.0_r8)+(8.729_r8 * & + ! ((1.0_r8 -(exp(-0.03_r8 * 0.06_r8 * currentPatch%effect_wspeed)))**2.155_r8)) !& + !& +currentPatch%fpc_grass*(1.1_r8+((0.06_r8*currentPatch%effect_wspeed)**0.0464)) + + ! endif + + ! if (lb > 8.0_r8)then + ! lb = 8.0_r8 !Constraint Canadian Fire Behaviour System + ! endif + ! ---- calculate length of major axis--- + db = currentPatch%ROS_back * currentPatch%FD !m + df = currentPatch%ROS_front * currentPatch%FD !m + + ! --- calculate area burnt--- + if(lb > 0.0_r8) then + + ! INTERF-TODO: + ! THIS SHOULD HAVE THE COLUMN AND LU AREA WEIGHT ALSO, NO? + + gridarea = km2_to_m2 ! 1M m2 in a km2 + currentPatch%NF = ED_val_nignitions * currentPatch%area/area /365 + + ! If there are 15 lightening strickes per year, per km2. (approx from NASA product) + ! then there are 15/365 s/km2 each day. + + ! Equation 1 in Thonicke et al. 2010 + ! To Do: Connect here with the Li & Levis GDP fire suppression algorithm. + ! Equation 16 in arora and boer model. + !currentPatch%AB = currentPatch%AB *3.0_r8 + size_of_fire = ((3.1416_r8/(4.0_r8*lb))*((df+db)**2.0_r8)) + + !AB is daily area burnt = size of fires in m2 * number of ignitions + currentPatch%AB = size_of_fire * currentPatch%NF + + patch_area_in_m2 = gridarea*currentPatch%area/area + if (currentPatch%AB > patch_area_in_m2 ) then !all of patch burnt. + + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'burnt all of patch',currentPatch%patchno, & + currentPatch%area/area,currentPatch%ab,patch_area_in_m2 + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'ros',currentPatch%ROS_front,currentPatch%FD, & + currentPatch%NF,currentPatch%FI,size_of_fire + + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'litter', & + currentPatch%sum_fuel,currentPatch%CWD_AG,currentPatch%leaf_litter + ! turn km2 into m2. work out total area burnt. + currentPatch%AB = patch_area_in_m2 + endif + currentPatch%frac_burnt = currentPatch%AB / patch_area_in_m2 + if(write_SF == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'frac_burnt',currentPatch%frac_burnt + endif + endif + endif! fire + currentSite%frac_burnt = currentSite%frac_burnt + currentPatch%frac_burnt + + currentPatch => currentPatch%younger + + enddo !end patch loop + + end subroutine area_burnt + + !***************************************************************** + subroutine crown_scorching ( currentSite ) + !***************************************************************** + !currentPatch%SH !average scorch height for the patch(m) + !currentPatch%FI average fire intensity of flaming front during day. kW/m. + + use SFParamsMod, only : SF_val_alpha_SH + use EDParamsMod, only : ED_val_ag_biomass + + type(ed_site_type), intent(in), target :: currentSite + + type(ed_patch_type), pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + real f_ag_bmass !fraction of a tree cohort's above-ground biomass as a proportion of total patch ag tree biomass. + real tree_ag_biomass !total amount of above-ground tree biomass in patch. kgC/m2 + + currentPatch => currentSite%oldest_patch; + do while(associated(currentPatch)) + + tree_ag_biomass = 0.0_r8 + f_ag_bmass = 0.0_r8 + if (currentPatch%fire == 1) then + currentCohort => currentPatch%tallest; + do while(associated(currentCohort)) + if (EDPftvarcon_inst%woody(currentCohort%pft) == 1) then !trees only + tree_ag_biomass = tree_ag_biomass+(currentCohort%bl+ED_val_ag_biomass* & + (currentCohort%bsw + currentCohort%bdead))*currentCohort%n + endif !trees only + + currentCohort=>currentCohort%shorter; + + enddo !end cohort loop + + !This loop weights the scorch height for the contribution of each cohort to the overall biomass. + + ! does this do anything? I think it might be redundant? RF. + currentPatch%SH = 0.0_r8 + currentCohort => currentPatch%tallest; + do while(associated(currentCohort)) + if (EDPftvarcon_inst%woody(currentCohort%pft) == 1 & + .and. (tree_ag_biomass > 0.0_r8)) then !trees only + f_ag_bmass = ((currentCohort%bl+ED_val_ag_biomass*(currentCohort%bsw + & + currentCohort%bdead))*currentCohort%n)/tree_ag_biomass + !equation 16 in Thonicke et al. 2010 + if(write_SF == itrue)then + if ( hlm_masterproc == itrue ) write(fates_log(),*) 'currentPatch%SH',currentPatch%SH,f_ag_bmass + endif + !2/3 Byram (1959) + currentPatch%SH = currentPatch%SH + f_ag_bmass * SF_val_alpha_SH * (currentPatch%FI**0.667_r8) + endif !trees only + currentCohort=>currentCohort%shorter; + enddo !end cohort loop + endif !fire + + currentPatch => currentPatch%younger; + enddo !end patch loop + + end subroutine crown_scorching + + !***************************************************************** + subroutine crown_damage ( currentSite ) + !***************************************************************** + + !returns the updated currentCohort%cfa value for each tree cohort within each patch. + !currentCohort%cfa proportion of crown affected by fire + + type(ed_site_type), intent(in), target :: currentSite + + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + currentPatch => currentSite%oldest_patch + + do while(associated(currentPatch)) + if (currentPatch%fire == 1) then + + currentCohort=>currentPatch%tallest + + do while(associated(currentCohort)) + currentCohort%cfa = 0.0_r8 + if (EDPftvarcon_inst%woody(currentCohort%pft) == 1) then !trees only + ! Flames lower than bottom of canopy. + ! c%hite is height of cohort + if (currentPatch%SH < (currentCohort%hite-currentCohort%hite*EDecophyscon%crown(currentCohort%pft))) then + currentCohort%cfa = 0.0_r8 + else + ! Flames part of way up canopy. + ! Equation 17 in Thonicke et al. 2010. + ! flames over bottom of canopy but not over top. + if ((currentCohort%hite > 0.0_r8).and.(currentPatch%SH >= & + (currentCohort%hite-currentCohort%hite*EDecophyscon%crown(currentCohort%pft)))) then + + currentCohort%cfa = (currentPatch%SH-currentCohort%hite* & + EDecophyscon%crown(currentCohort%pft))/(currentCohort%hite-currentCohort%hite* & + EDecophyscon%crown(currentCohort%pft)) + + else + ! Flames over top of canopy. + currentCohort%cfa = 1.0_r8 + endif + + endif + ! Check for strange values. + currentCohort%cfa = min(1.0_r8, max(0.0_r8,currentCohort%cfa)) + endif !trees only + !shrink canopy to account for burnt section. + !currentCohort%canopy_trim = min(currentCohort%canopy_trim,(1.0_r8-currentCohort%cfa)) + + currentCohort => currentCohort%shorter; + + enddo !end cohort loop + endif !fire? + + currentPatch => currentPatch%younger; + + enddo !end patch loop + + end subroutine crown_damage + + !***************************************************************** + subroutine cambial_damage_kill ( currentSite ) + !***************************************************************** + ! routine description. + ! returns the probability that trees dies due to cambial char + ! currentPatch%tau_l = duration of lethal stem heating (min). Calculated at patch level. + + type(ed_site_type), intent(in), target :: currentSite + + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + real(r8) :: tau_c !critical time taken to kill cambium (minutes) + real(r8) :: bt !bark thickness in cm. + + currentPatch => currentSite%oldest_patch; + + do while(associated(currentPatch)) + + if (currentPatch%fire == 1) then + currentCohort => currentPatch%tallest; + do while(associated(currentCohort)) + if (EDPftvarcon_inst%woody(currentCohort%pft) == 1) then !trees only + ! Equation 21 in Thonicke et al 2010 + bt = EDecophyscon%bark_scaler(currentCohort%pft)*currentCohort%dbh ! bark thickness. + ! Equation 20 in Thonicke et al. 2010. + tau_c = 2.9_r8*bt**2.0_r8 !calculate time it takes to kill cambium (min) + ! Equation 19 in Thonicke et al. 2010 + if ((currentPatch%tau_l/tau_c) >= 2.0_r8) then + currentCohort%cambial_mort = 1.0_r8 + else + if ((currentPatch%tau_l/tau_c) > 0.22_r8) then + currentCohort%cambial_mort = (0.563_r8*(currentPatch%tau_l/tau_c)) - 0.125_r8 + else + currentCohort%cambial_mort = 0.0_r8 + endif + endif + endif !trees + + currentCohort => currentCohort%shorter; + + enddo !end cohort loop + endif !fire? + + currentPatch=>currentPatch%younger; + + enddo !end patch loop + + end subroutine cambial_damage_kill + + !***************************************************************** + subroutine post_fire_mortality ( currentSite ) + !***************************************************************** + + ! returns the updated currentCohort%fire_mort value for each tree cohort within each patch. + ! currentCohort%cfa proportion of crown affected by fire + ! currentCohort%crownfire_mort probability of tree post-fire mortality due to crown scorch + ! currentCohort%cambial_mort probability of tree post-fire mortality due to cambial char + ! currentCohort%fire_mort post-fire mortality from cambial and crown damage assuming two are independent. + + type(ed_site_type), intent(in), target :: currentSite + + type(ed_patch_type), pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + currentPatch => currentSite%oldest_patch + + do while(associated(currentPatch)) + + if (currentPatch%fire == 1) then + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + currentCohort%fire_mort = 0.0_r8 + currentCohort%crownfire_mort = 0.0_r8 + if (EDPftvarcon_inst%woody(currentCohort%pft) == 1) then + ! Equation 22 in Thonicke et al. 2010. + currentCohort%crownfire_mort = EDecophyscon%crown_kill(currentCohort%pft)*currentCohort%cfa**3.0_r8 + ! Equation 18 in Thonicke et al. 2010. + currentCohort%fire_mort = currentCohort%crownfire_mort+currentCohort%cambial_mort- & + (currentCohort%crownfire_mort*currentCohort%cambial_mort) !joint prob. + else + currentCohort%fire_mort = 0.0_r8 !I have changed this to zero and made the mode of death removal of leaves... + endif !trees + + currentCohort => currentCohort%shorter + + enddo !end cohort loop + endif !fire? + + currentPatch => currentPatch%younger + + enddo !end patch loop + + end subroutine post_fire_mortality + + ! ============================================================================ +end module SFMainMod diff --git a/fire/SFParamsMod.F90 b/fire/SFParamsMod.F90 new file mode 100644 index 00000000..514c58e1 --- /dev/null +++ b/fire/SFParamsMod.F90 @@ -0,0 +1,343 @@ +module SFParamsMod + ! + ! module that deals with reading the SF parameter file + ! + use FatesConstantsMod , only: r8 => fates_r8 + use EDtypesMod , only: NFSC,NCWD + use FatesParametersInterface, only : param_string_length + + implicit none + save + ! private - if we allow this module to be private, it does not allow the protected values below to be + ! seen outside of this module. + + ! + ! this is what the user can use for the actual values + ! + real(r8),protected :: SF_val_fdi_a + real(r8),protected :: SF_val_fdi_b + real(r8),protected :: SF_val_fdi_alpha + real(r8),protected :: SF_val_miner_total + real(r8),protected :: SF_val_fuel_energy + real(r8),protected :: SF_val_part_dens + real(r8),protected :: SF_val_miner_damp + real(r8),protected :: SF_val_max_durat + real(r8),protected :: SF_val_durat_slope + real(r8),protected :: SF_val_alpha_SH + real(r8),protected :: SF_val_alpha_FMC(NFSC) + real(r8),protected :: SF_val_CWD_frac(NCWD) + real(r8),protected :: SF_val_max_decomp(NFSC) + real(r8),protected :: SF_val_SAV(NFSC) + real(r8),protected :: SF_val_FBD(NFSC) + real(r8),protected :: SF_val_min_moisture(NFSC) + real(r8),protected :: SF_val_mid_moisture(NFSC) + real(r8),protected :: SF_val_low_moisture_C(NFSC) + real(r8),protected :: SF_val_low_moisture_S(NFSC) + real(r8),protected :: SF_val_mid_moisture_C(NFSC) + real(r8),protected :: SF_val_mid_moisture_S(NFSC) + + character(len=param_string_length),parameter :: SF_name_fdi_a = "fates_fdi_a" + character(len=param_string_length),parameter :: SF_name_fdi_b = "fates_fdi_b" + character(len=param_string_length),parameter :: SF_name_fdi_alpha = "fates_fdi_alpha" + character(len=param_string_length),parameter :: SF_name_miner_total = "fates_miner_total" + character(len=param_string_length),parameter :: SF_name_fuel_energy = "fates_fuel_energy" + character(len=param_string_length),parameter :: SF_name_part_dens = "fates_part_dens" + character(len=param_string_length),parameter :: SF_name_miner_damp = "fates_miner_damp" + character(len=param_string_length),parameter :: SF_name_max_durat = "fates_max_durat" + character(len=param_string_length),parameter :: SF_name_durat_slope = "fates_durat_slope" + character(len=param_string_length),parameter :: SF_name_alpha_SH = "fates_alpha_SH" + character(len=param_string_length),parameter :: SF_name_alpha_FMC = "fates_alpha_FMC" + character(len=param_string_length),parameter :: SF_name_CWD_frac = "fates_CWD_frac" + character(len=param_string_length),parameter :: SF_name_max_decomp = "fates_max_decomp" + character(len=param_string_length),parameter :: SF_name_SAV = "fates_SAV" + character(len=param_string_length),parameter :: SF_name_FBD = "fates_FBD" + character(len=param_string_length),parameter :: SF_name_min_moisture = "fates_min_moisture" + character(len=param_string_length),parameter :: SF_name_mid_moisture = "fates_mid_moisture" + character(len=param_string_length),parameter :: SF_name_low_moisture_C = "fates_low_moisture_C" + character(len=param_string_length),parameter :: SF_name_low_moisture_S = "fates_low_moisture_S" + character(len=param_string_length),parameter :: SF_name_mid_moisture_C = "fates_mid_moisture_C" + character(len=param_string_length),parameter :: SF_name_mid_moisture_S = "fates_mid_moisture_S" + + public :: SpitFireRegisterParams + public :: SpitFireReceiveParams + + private :: SpitFireParamsInit + private :: SpitFireRegisterScalars + private :: SpitFireReceiveScalars + + private :: SpitFireRegisterNCWD + private :: SpitFireReceiveNCWD + + private :: SpitFireRegisterNFSC + private :: SpitFireReceiveNFSC + +contains + !----------------------------------------------------------------------- + subroutine SpitFireParamsInit() + ! Initialize all parameters to nan to ensure that we get valid + ! values back from the host. + + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + + implicit none + + SF_val_fdi_a = nan + SF_val_fdi_b = nan + SF_val_fdi_alpha = nan + SF_val_miner_total = nan + SF_val_fuel_energy = nan + SF_val_part_dens = nan + SF_val_miner_damp = nan + SF_val_max_durat = nan + SF_val_durat_slope = nan + SF_val_alpha_SH = nan + + SF_val_CWD_frac(:) = nan + + SF_val_alpha_FMC(:) = nan + SF_val_max_decomp(:) = nan + + SF_val_SAV(:) = nan + SF_val_FBD(:) = nan + SF_val_min_moisture(:) = nan + SF_val_mid_moisture(:) = nan + SF_val_low_moisture_C(:) = nan + SF_val_low_moisture_S(:) = nan + SF_val_mid_moisture_C(:) = nan + SF_val_mid_moisture_S(:) = nan + + end subroutine SpitFireParamsInit + + !----------------------------------------------------------------------- + subroutine SpitFireRegisterParams(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar, dimension_shape_scalar + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + call SpitFireParamsInit() + call SpitFireRegisterScalars(fates_params) + call SpitFireRegisterNCWD(fates_params) + call SpitFireRegisterNFSC(fates_params) + + end subroutine SpitFireRegisterParams + + !----------------------------------------------------------------------- + subroutine SpitFireReceiveParams(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + call SpitFireReceiveScalars(fates_params) + call SpitFireReceiveNCWD(fates_params) + call SpitFireReceiveNFSC(fates_params) + + end subroutine SpitFireReceiveParams + + !----------------------------------------------------------------------- + subroutine SpitFireRegisterScalars(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar, dimension_shape_scalar + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names_scalar(1) = (/dimension_name_scalar/) + + call fates_params%RegisterParameter(name=SF_name_fdi_a, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=SF_name_fdi_b, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=SF_name_fdi_alpha, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=SF_name_miner_total, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=SF_name_fuel_energy, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=SF_name_part_dens, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=SF_name_miner_damp, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=SF_name_max_durat, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=SF_name_durat_slope, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=SF_name_alpha_SH, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + end subroutine SpitFireRegisterScalars + + !----------------------------------------------------------------------- + subroutine SpitFireReceiveScalars(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + call fates_params%RetreiveParameter(name=SF_name_fdi_a, & + data=SF_val_fdi_a) + + call fates_params%RetreiveParameter(name=SF_name_fdi_b, & + data=SF_val_fdi_b) + + call fates_params%RetreiveParameter(name=SF_name_fdi_alpha, & + data=SF_val_fdi_alpha) + + call fates_params%RetreiveParameter(name=SF_name_miner_total, & + data=SF_val_miner_total) + + call fates_params%RetreiveParameter(name=SF_name_fuel_energy, & + data=SF_val_fuel_energy) + + call fates_params%RetreiveParameter(name=SF_name_part_dens, & + data=SF_val_part_dens) + + call fates_params%RetreiveParameter(name=SF_name_miner_damp, & + data=SF_val_miner_damp) + + call fates_params%RetreiveParameter(name=SF_name_max_durat, & + data=SF_val_max_durat) + + call fates_params%RetreiveParameter(name=SF_name_durat_slope, & + data=SF_val_durat_slope) + + call fates_params%RetreiveParameter(name=SF_name_alpha_SH, & + data=SF_val_alpha_SH) + + end subroutine SpitFireReceiveScalars + + !----------------------------------------------------------------------- + subroutine SpitFireRegisterNCWD(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, dimension_name_cwd, dimension_shape_1d + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names_cwd(1) = (/dimension_name_cwd/) + + call fates_params%RegisterParameter(name=SF_name_CWD_frac, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names_cwd) + + end subroutine SpitFireRegisterNCWD + + !----------------------------------------------------------------------- + subroutine SpitFireReceiveNCWD(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + call fates_params%RetreiveParameter(name=SF_name_CWD_frac, & + data=SF_val_CWD_frac) + + end subroutine SpitFireReceiveNCWD + + !----------------------------------------------------------------------- + subroutine SpitFireRegisterNFSC(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, dimension_name_fsc, dimension_shape_1d + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_fsc/) + + call fates_params%RegisterParameter(name=SF_name_SAV, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=SF_name_FBD, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=SF_name_min_moisture, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=SF_name_mid_moisture, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=SF_name_low_moisture_C, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=SF_name_low_moisture_S, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=SF_name_mid_moisture_C, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=SF_name_mid_moisture_S, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=SF_name_alpha_FMC, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=SF_name_max_decomp, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + end subroutine SpitFireRegisterNFSC + + !----------------------------------------------------------------------- + subroutine SpitFireReceiveNFSC(fates_params) + + use FatesParametersInterface, only : fates_parameters_type + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + + call fates_params%RetreiveParameter(name=SF_name_SAV, & + data=SF_val_SAV) + + call fates_params%RetreiveParameter(name=SF_name_FBD, & + data=SF_val_FBD) + + call fates_params%RetreiveParameter(name=SF_name_min_moisture, & + data=SF_val_min_moisture) + + call fates_params%RetreiveParameter(name=SF_name_mid_moisture, & + data=SF_val_mid_moisture) + + call fates_params%RetreiveParameter(name=SF_name_low_moisture_C, & + data=SF_val_low_moisture_C) + + call fates_params%RetreiveParameter(name=SF_name_low_moisture_S, & + data=SF_val_low_moisture_S) + + call fates_params%RetreiveParameter(name=SF_name_mid_moisture_C, & + data=SF_val_mid_moisture_C) + + call fates_params%RetreiveParameter(name=SF_name_mid_moisture_S, & + data=SF_val_mid_moisture_S) + + call fates_params%RetreiveParameter(name=SF_name_alpha_FMC, & + data=SF_val_alpha_FMC) + + call fates_params%RetreiveParameter(name=SF_name_max_decomp, & + data=SF_val_max_decomp) + + end subroutine SpitFireReceiveNFSC + !----------------------------------------------------------------------- + + +end module SFParamsMod diff --git a/main/CMakeLists.txt b/main/CMakeLists.txt new file mode 100644 index 00000000..5f8dbdcf --- /dev/null +++ b/main/CMakeLists.txt @@ -0,0 +1,9 @@ +# Note that this is just used for unit testing; hence, we only need to add +# source files that are currently used in unit tests + +list(APPEND clm_sources + EDPftvarcon.F90 + ) + +sourcelist_to_parent(clm_sources) + diff --git a/main/ChecksBalancesMod.F90 b/main/ChecksBalancesMod.F90 new file mode 100644 index 00000000..7a9e3e74 --- /dev/null +++ b/main/ChecksBalancesMod.F90 @@ -0,0 +1,238 @@ +module ChecksBalancesMod + + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_const_mod, only: SHR_CONST_CDAY + + implicit none + + private + public :: SummarizeNetFluxes + public :: FATES_BGC_Carbon_Balancecheck + +contains + + !------------------------------------------------------------------------ + + subroutine SummarizeNetFluxes( nsites, sites, bc_in, is_beg_day ) + + ! Summarize the combined production and decomposition fluxes into net fluxes + ! This is done on the fast timestep, and to be called after both daily ED calls and + ! fast BGC calls. Does not include summarization of fast-timestsp productivity calls + ! because these must be summarized prior to daily ED calls + ! + ! Written by Charlie Koven, Feb 2016 + ! + ! !USES: + use FatesInterfaceMod , only : bc_in_type + use EDtypesMod , only : ed_site_type,ed_patch_type,ed_cohort_type + use EDtypesMod , only : AREA + ! + implicit none + ! + ! !ARGUMENTS + + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type) , intent(in) :: bc_in(nsites) + logical , intent(in) :: is_beg_day + + ! + ! !LOCAL VARIABLES: + integer :: s + + type (ed_patch_type) , pointer :: currentPatch + type (ed_cohort_type) , pointer :: currentCohort + real(r8) :: n_perm2 ! individuals per m2 of the whole column + + do s = 1,nsites + + sites(s)%fire_c_to_atm = 0._r8 ! REMOVE THIS VARIABLE? + sites(s)%ed_litter_stock = 0._r8 + sites(s)%cwd_stock = 0._r8 + sites(s)%biomass_stock = 0._r8 + + ! map ed site-level fire fluxes to clm column fluxes + sites(s)%fire_c_to_atm = sites(s)%total_burn_flux_to_atm / & + ( AREA * SHR_CONST_CDAY * 1.e3_r8) + + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + + ! map litter, CWD, and seed pools to column level + sites(s)%cwd_stock = sites(s)%cwd_stock + & + (currentPatch%area / AREA) * & + (sum(currentPatch%cwd_ag)+sum(currentPatch%cwd_bg)) * 1.e3_r8 + + sites(s)%ed_litter_stock = sites(s)%ed_litter_stock + & + (currentPatch%area / AREA) * & + (sum(currentPatch%leaf_litter)+sum(currentPatch%root_litter)) * 1.e3_r8 + + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + ! for quantities that are natively at column level or higher, + ! calculate plant density using whole area (for grid cell averages) + n_perm2 = currentCohort%n/AREA + + ! map biomass pools to column level + sites(s)%biomass_stock = sites(s)%biomass_stock + & + (currentCohort%bdead + currentCohort%balive + & + currentCohort%bstore) * n_perm2 * 1.e3_r8 + + currentCohort => currentCohort%shorter + enddo !currentCohort + currentPatch => currentPatch%younger + end do ! patch loop + + ! calculate NEP and NBP fluxes + sites(s)%nep = sites(s)%npp - bc_in(s)%tot_het_resp + sites(s)%nbp = sites(s)%npp - ( bc_in(s)%tot_het_resp + sites(s)%fire_c_to_atm ) + + ! FATES stocks + sites(s)%totfatesc = sites(s)%ed_litter_stock + sites(s)%cwd_stock + & + (sum(sites(s)%seed_bank) * 1.e3_r8) + sites(s)%biomass_stock + + ! BGC stocks (used for error checking, totlitc should be zero?) + sites(s)%totbgcc = bc_in(s)%tot_somc + bc_in(s)%tot_litc + + ! Total Ecosystem Carbon Stocks + sites(s)%totecosysc = sites(s)%totfatesc + sites(s)%totbgcc + + end do + + ! in FATES timesteps, because of offset between when ED and BGC reconcile the gain + ! and loss of litterfall carbon, (i.e. FATES reconciles it instantly, while BGC + ! reconciles it incrementally over the subsequent day) calculate the total + ! ED -> BGC flux and keep track of the last day's info for balance checking purposes + if ( is_beg_day ) then + ! + do s = 1,nsites + ! order of operations in the next to lines is quite important ;) + sites(s)%fates_to_bgc_last_ts = sites(s)%fates_to_bgc_this_ts + sites(s)%fates_to_bgc_this_ts = 0._r8 + sites(s)%tot_seed_rain_flux = 0._r8 + + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + ! + sites(s)%fates_to_bgc_this_ts = sites(s)%fates_to_bgc_this_ts + & + (sum(currentPatch%CWD_AG_out) + sum(currentPatch%CWD_BG_out) + & + sum(currentPatch%seed_decay) + sum(currentPatch%leaf_litter_out) + & + sum(currentPatch%root_litter_out)) * & + ( currentPatch%area/AREA ) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) + ! + sites(s)%tot_seed_rain_flux = sites(s)%tot_seed_rain_flux + & + sum(sites(s)%seed_rain_flux) * 1.e3_r8 / ( 365.0_r8*SHR_CONST_CDAY ) + ! + currentPatch => currentPatch%younger + end do !currentPatch + end do + endif + + return + end subroutine SummarizeNetFluxes + + ! ==================================================================================== + + subroutine FATES_BGC_Carbon_Balancecheck(nsites, sites, bc_in, is_beg_day, dtime, nstep) + + ! Integrate in time the fluxes into and out of the ecosystem, and compare these + ! on a daily timestep to the chagne in carbon stocks of the ecosystem + ! + ! Written by Charlie Koven, Feb 2016 + ! + ! !USES: + use FatesInterfaceMod , only : bc_in_type + use EDtypesMod , only : ed_site_type + ! + implicit none + ! + ! !ARGUMENTS + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type) , intent(in) :: bc_in(nsites) + logical , intent(in) :: is_beg_day + real(r8) , intent(in) :: dtime ! time-step length (s) + integer , intent(in) :: nstep ! time-step index + + ! !LOCAL VARIABLES: + real(r8) :: error_tolerance = 1.e-6_r8 + integer :: s + + ! TODO: THIS INITIALIZATION SHOULD BE IN AN INITIALIZATION PART OF THE CODE + ! COLD-START PORTION, NSTEP IS >1 FOR RESTARTS RIGHT? (RGK) + if (nstep .le. 1) then + ! when starting up the model, initialize the integrator variables + do s = 1,nsites + sites(s)%totecosysc_old = sites(s)%totecosysc + sites(s)%totfatesc_old = sites(s)%totfatesc + sites(s)%totbgcc_old = sites(s)%totbgcc + sites(s)%nep_timeintegrated = 0._r8 + sites(s)%hr_timeintegrated = 0._r8 + sites(s)%npp_timeintegrated = 0._r8 + ! + ! also initialize the ed-BGC flux variables + sites(s)%fates_to_bgc_this_ts = 0._r8 + sites(s)%fates_to_bgc_last_ts = 0._r8 + ! + sites(s)%cbal_err_fates = 0._r8 + sites(s)%cbal_err_bgc = 0._r8 + sites(s)%cbal_err_tot = 0._r8 + end do + endif + + do s = 1,nsites + sites(s)%nep_timeintegrated = sites(s)%nep_timeintegrated + sites(s)%nep * dtime + sites(s)%hr_timeintegrated = sites(s)%hr_timeintegrated + bc_in(s)%tot_het_resp * dtime + sites(s)%npp_timeintegrated = sites(s)%npp_timeintegrated + sites(s)%npp * dtime + end do + + ! If this is on the dynamics time-step, then we calculate the balance checks + + if ( is_beg_day ) then + + do s = 1,nsites + + ! NBP can only be updated when dynamics level information is available + sites(s)%nbp_integrated = sites(s)%nep_timeintegrated - & + sites(s)%fire_c_to_atm * SHR_CONST_CDAY + & + sites(s)%tot_seed_rain_flux * SHR_CONST_CDAY + + + sites(s)%cbal_err_fates = sites(s)%totfatesc - & + sites(s)%totfatesc_old - & + (sites(s)%npp_timeintegrated + & + sites(s)%tot_seed_rain_flux*SHR_CONST_CDAY - & + sites(s)%fates_to_bgc_this_ts*SHR_CONST_CDAY - & + sites(s)%fire_c_to_atm*SHR_CONST_CDAY) + sites(s)%cbal_err_fates = sites(s)%cbal_err_fates / SHR_CONST_CDAY + + sites(s)%cbal_err_bgc = sites(s)%totbgcc - & + sites(s)%totbgcc_old - & + (sites(s)%fates_to_bgc_last_ts*SHR_CONST_CDAY - & + sites(s)%hr_timeintegrated) + sites(s)%cbal_err_bgc = sites(s)%cbal_err_bgc / SHR_CONST_CDAY + + sites(s)%cbal_err_tot = sites(s)%totecosysc - & + sites(s)%totecosysc_old - & + (sites(s)%nbp_integrated + & + sites(s)%fates_to_bgc_last_ts*SHR_CONST_CDAY - & + sites(s)%fates_to_bgc_this_ts*SHR_CONST_CDAY) + sites(s)%cbal_err_tot = sites(s)%cbal_err_tot / SHR_CONST_CDAY + + ! Send the current to the previous/last + sites(s)%totecosysc_old = sites(s)%totecosysc + sites(s)%totfatesc_old = sites(s)%totfatesc + sites(s)%totbgcc_old = sites(s)%totbgcc + sites(s)%nep_timeintegrated = 0._r8 + sites(s)%npp_timeintegrated = 0._r8 + sites(s)%hr_timeintegrated = 0._r8 + + end do + + endif + + return + end subroutine FATES_BGC_Carbon_Balancecheck + + +end module ChecksBalancesMod diff --git a/main/EDEcophysConType.F90 b/main/EDEcophysConType.F90 new file mode 100644 index 00000000..974b7b96 --- /dev/null +++ b/main/EDEcophysConType.F90 @@ -0,0 +1,248 @@ +module EDEcophysConType + + !---------------------------------------------------- + ! ED ecophysiological constants + !---------------------------------------------------- + ! + ! !USES: + use shr_kind_mod , only : r8 => shr_kind_r8 + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + use shr_log_mod , only : errMsg => shr_log_errMsg + use FatesGlobals, only : endrun => fates_endrun + use FatesGlobals, only : fates_log + + use FatesHydraulicsMemMod , only : n_porous_media + use FatesHydraulicsMemMod , only : porous_media + use FatesHydraulicsMemMod , only : npool_tot + use FatesHydraulicsMemMod , only : npool_leaf + use FatesHydraulicsMemMod , only : npool_stem + use FatesHydraulicsMemMod , only : npool_aroot + use FatesHydraulicsMemMod , only : npool_troot + + use EDTypesMod, only : use_fates_plant_hydro + + ! + implicit none + save + private + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: EDecophysconInit + ! + ! !PUBLIC TYPES: + type, public :: EDecophyscon_type + real(r8), pointer :: max_dbh (:) ! maximum dbh at which height growth ceases... + real(r8), pointer :: freezetol (:) ! minimum temperature tolerance... + real(r8), pointer :: wood_density (:) ! wood density g cm^-3 ... + real(r8), pointer :: alpha_stem (:) ! live stem turnover rate. y-1 + real(r8), pointer :: hgt_min (:) ! sapling height m + real(r8), pointer :: cushion (:) ! labile carbon storage target as multiple of leaf pool. + real(r8), pointer :: leaf_stor_priority (:) ! leaf turnover vs labile carbon use prioritisation. ! (1=lose leaves, 0=use store). + real(r8), pointer :: leafwatermax (:) ! amount of water allowed on leaf surfaces + real(r8), pointer :: rootresist (:) + real(r8), pointer :: soilbeta (:) + real(r8), pointer :: crown (:) ! fraction of the height of the plant that is occupied by crown. For fire model. + real(r8), pointer :: bark_scaler (:) ! scaler from dbh to bark thickness. For fire model. + real(r8), pointer :: crown_kill (:) ! scaler on fire death. For fire model. + real(r8), pointer :: initd (:) ! initial seedling density + real(r8), pointer :: sd_mort (:) ! rate of death of seeds produced from reproduction. + real(r8), pointer :: seed_rain (:) ! seeds that come from outside the gridbox. + real(r8), pointer :: BB_slope (:) ! ball berry slope parameter + real(r8), pointer :: root_long (:) ! root longevity (yrs) + real(r8), pointer :: clone_alloc (:) ! fraction of carbon balance allocated to clonal reproduction. + real(r8), pointer :: seed_alloc (:) ! fraction of carbon balance allocated to seeds. + real(r8), pointer :: sapwood_ratio (:) ! amount of sapwood per unit leaf carbon and m height + + + + ! pft parameters for plant hydraulics (PFT) + real(r8), pointer :: wd (:) ! wood density (distinct from wood_density for testing) [g m-3] + real(r8), pointer :: lma (:) ! leaf mass per area [g m-2] + ! ~ 90 for tropical angiosperms, cf Patino et al. 2012 + ! (existing param 'slatop' is biased high) + real(r8), pointer :: n (:) ! leaf nitrogen [mg g-1] + real(r8), pointer :: p (:) ! leaf phosphorus [mg g-1] + real(r8), pointer :: ldmc (:) ! leaf dry matter content [g g-1] + real(r8), pointer :: lmv (:) ! leaf mass per volume [g m-3] + real(r8), pointer :: psi0 (:) ! sapwood water potential at saturation [MPa] + real(r8), pointer :: psicap (:) ! sapwood water potential at rwcft [MPa] + ! BOC...rhoc, rint_petiole, rint_jansenchoat, ccontent and (maybe) + ! rs2 and rfrac_stem should really be global constants, not pft parameters + real(r8), pointer :: rhoc (:) ! dry matter (or cell wall) density of wood [g cm-3] Siau 1984 + real(r8), pointer :: rint_petiole (:) ! radius of xylem conduits in petioles [um] + real(r8), pointer :: rint_jansenchoat (:) ! average radius of xylem conduits where ks mmts were made [um] + ! taken from choat & jansen XFT database for tropical angiosperms only + real(r8), pointer :: Amaxh (:) ! light-saturated photosynthesis rate [umol m-2 s-1] + real(r8), pointer :: rs2 (:) ! mean absorbing fine root radius [m] ~ 0.001 m? + real(r8), pointer :: srl (:) ! specific root length [m kg-1] + ! ~ 15000 for tropical angiosperms, cf Metcalfe et al. 2008 Plant Soil Fig. 2b; + ! rootdens = 500 kg m-3 is biased high by an order of magnitude + ! (cf Comas et al. 2002 Oecologia); SPA rootdens implies a SRL of only 637 m kg-1. + real(r8), pointer :: ccontent (:) ! carbon content (fraction of dry mass) [-] + ! ~ 0.47 for tropical angiosperms, cf Thomas & Martin (2012) Forests + real(r8), pointer :: latosa (:) ! leaf to sapwood area ratio [m2 m-2] + ! ~ 8000 for tropical angiosperms, cf Patino et al. 2012 + real(r8), pointer :: rfrac_stem (:) ! fraction of total tree resistance (under well-watered conditions) + ! from troot to canopy (i.e., aboveground) [-] ~ 0.625 for tropical angiosperms, + ! cf BC re-analysis of Fisher et al. 2006 + real(r8), pointer :: rootshoot (:) ! root:shoot ratio (belowground-to-aboveground biomass) [-] + ! ~ 0.20 for tropical forests (see Houghton et al. 2001 Table 3, + ! Cairns et al. 1997 Table 2, Jackson et al. 1996 Table 3) + real(r8), pointer :: avuln_gs (:) ! stomata PLC: vulnerability curve shape parameter [-] + real(r8), pointer :: p50_gs (:) ! stomata PLC: water potential at 50% loss of conductivity [Pa] + + ! pft parameters for plant hydraulics (PFT x tissue type (leaf, stem, troot, aroot)) + real(r8), pointer :: kmax_node (:,:) ! xylem PLC: maximum xylem hydraulic conductivity [kg m-1 s-1 Pa-1] + real(r8), pointer :: avuln_node (:,:) ! xylem PLC: vulnerability curve shape parameter [-] + real(r8), pointer :: p50_node (:,:) ! xylem PLC: water potential at 50% loss of conductivity [Pa] + real(r8), pointer :: thetas_node (:,:) ! P-V curve: saturated volumetric water content for node [m3 m-3] + real(r8), pointer :: epsil_node (:,:) ! P-V curve: bulk elastic modulus [MPa] + real(r8), pointer :: pinot_node (:,:) ! P-V curve: osmotic potential at full turgor [MPa] + real(r8), pointer :: pitlp_node (:,:) ! P-V curve: osmotic potential at turgor loss [MPa] + real(r8), pointer :: resid_node (:,:) ! P-V curve: residual fraction [-] + real(r8), pointer :: rwctlp_node (:,:) ! P-V curve: total relative water content at turgor loss [g or m3 H2O / g or m3 H2O, sat] + real(r8), pointer :: fcap_node (:,:) ! P-V curve: fraction of (1-resid_node) that is capillary in source [-] + real(r8), pointer :: rwcft_node (:,:) ! P-V curve: total RWC @ which elastic drainage begins [-] + real(r8), pointer :: rwccap_node (:,:) ! P-V curve: total RWC @ which capillary reserves exhausted + real(r8), pointer :: slp_node (:,:) ! P-V curve: slope of capillary region of curve (sapwood only) + real(r8), pointer :: intercept_node (:,:) ! P-V curve: intercept of capillary region of curve (sapwood only) + real(r8), pointer :: corrInt_node (:,:) ! P-V curve: correction for nonzero psi0 + + + + end type EDecophyscon_type + + type(EDecophyscon_type), public :: EDecophyscon ! ED ecophysiological constants structure + !------------------------------------------------------------------------ + + + + + +contains + + !------------------------------------------------------------------------ + subroutine EDecophysconInit(EDpftvarcon_inst, numpft) + ! + ! !USES: + use EDPftvarcon, only : EDPftvarcon_type + ! + ! !ARGUMENTS: + type(EDpftVarCon_type) , intent(in) :: EDpftvarcon_inst + integer , intent(in) :: numpft + ! + ! !LOCAL VARIABLES: + integer :: m, ib, n, k + !------------------------------------------------------------------------ + + allocate( EDecophyscon%max_dbh (0:numpft)); EDecophyscon%max_dbh (:) = nan + allocate( EDecophyscon%freezetol (0:numpft)); EDecophyscon%freezetol (:) = nan + allocate( EDecophyscon%wood_density (0:numpft)); EDecophyscon%wood_density (:) = nan + allocate( EDecophyscon%alpha_stem (0:numpft)); EDecophyscon%alpha_stem (:) = nan + allocate( EDecophyscon%hgt_min (0:numpft)); EDecophyscon%hgt_min (:) = nan + allocate( EDecophyscon%cushion (0:numpft)); EDecophyscon%cushion (:) = nan + allocate( EDecophyscon%leaf_stor_priority (0:numpft)); EDecophyscon%leaf_stor_priority (:) = nan + allocate( EDecophyscon%leafwatermax (0:numpft)); EDecophyscon%leafwatermax (:) = nan + allocate( EDecophyscon%rootresist (0:numpft)); EDecophyscon%rootresist (:) = nan + allocate( EDecophyscon%soilbeta (0:numpft)); EDecophyscon%soilbeta (:) = nan + allocate( EDecophyscon%crown (0:numpft)); EDecophyscon%crown (:) = nan + allocate( EDecophyscon%bark_scaler (0:numpft)); EDecophyscon%bark_scaler (:) = nan + allocate( EDecophyscon%crown_kill (0:numpft)); EDecophyscon%crown_kill (:) = nan + allocate( EDecophyscon%initd (0:numpft)); EDecophyscon%initd (:) = nan + allocate( EDecophyscon%sd_mort (0:numpft)); EDecophyscon%sd_mort (:) = nan + allocate( EDecophyscon%seed_rain (0:numpft)); EDecophyscon%seed_rain (:) = nan + allocate( EDecophyscon%BB_slope (0:numpft)); EDecophyscon%BB_slope (:) = nan + allocate( EDecophyscon%root_long (0:numpft)); EDecophyscon%root_long (:) = nan + allocate( EDecophyscon%seed_alloc (0:numpft)); EDecophyscon%seed_alloc (:) = nan + allocate( EDecophyscon%clone_alloc (0:numpft)); EDecophyscon%clone_alloc (:) = nan + allocate( EDecophyscon%sapwood_ratio (0:numpft)); EDecophyscon%sapwood_ratio (:) = nan + + do m = 0,numpft + EDecophyscon%max_dbh(m) = EDPftvarcon_inst%max_dbh(m) + EDecophyscon%freezetol(m) = EDPftvarcon_inst%freezetol(m) + EDecophyscon%wood_density(m) = EDPftvarcon_inst%wood_density(m) + EDecophyscon%alpha_stem(m) = EDPftvarcon_inst%alpha_stem(m) + EDecophyscon%hgt_min(m) = EDPftvarcon_inst%hgt_min(m) + EDecophyscon%cushion(m) = EDPftvarcon_inst%cushion(m) + EDecophyscon%leaf_stor_priority(m) = EDPftvarcon_inst%leaf_stor_priority(m) + EDecophyscon%leafwatermax(m) = EDPftvarcon_inst%leafwatermax(m) + EDecophyscon%rootresist(m) = EDPftvarcon_inst%rootresist(m) + EDecophyscon%soilbeta(m) = EDPftvarcon_inst%soilbeta(m) + EDecophyscon%crown(m) = EDPftvarcon_inst%crown(m) + EDecophyscon%bark_scaler(m) = EDPftvarcon_inst%bark_scaler(m) + EDecophyscon%crown_kill(m) = EDPftvarcon_inst%crown_kill(m) + EDecophyscon%initd(m) = EDPftvarcon_inst%initd(m) + EDecophyscon%sd_mort(m) = EDPftvarcon_inst%sd_mort(m) + EDecophyscon%seed_rain(m) = EDPftvarcon_inst%seed_rain(m) + EDecophyscon%bb_slope(m) = EDPftvarcon_inst%bb_slope(m) + EDecophyscon%root_long(m) = EDPftvarcon_inst%root_long(m) + EDecophyscon%seed_alloc(m) = EDPftvarcon_inst%seed_alloc(m) + EDecophyscon%clone_alloc(m) = EDPftvarcon_inst%clone_alloc(m) + EDecophyscon%sapwood_ratio(m) = EDPftvarcon_inst%sapwood_ratio(m) + end do + + + if (use_fates_plant_hydro) then + allocate( EDecophyscon%wd (0:numpft) ); EDecophyscon%wd (:) = nan + allocate( EDecophyscon%lma (0:numpft) ); EDecophyscon%lma (:) = nan + allocate( EDecophyscon%n (0:numpft) ); EDecophyscon%n (:) = nan + allocate( EDecophyscon%p (0:numpft) ); EDecophyscon%p (:) = nan + allocate( EDecophyscon%ldmc (0:numpft) ); EDecophyscon%ldmc (:) = nan + allocate( EDecophyscon%lmv (0:numpft) ); EDecophyscon%lmv (:) = nan + allocate( EDecophyscon%psi0 (0:numpft) ); EDecophyscon%psi0 (:) = nan + allocate( EDecophyscon%psicap (0:numpft) ); EDecophyscon%psicap (:) = nan + allocate( EDecophyscon%rhoc (0:numpft) ); EDecophyscon%rhoc (:) = nan + allocate( EDecophyscon%rint_petiole (0:numpft) ); EDecophyscon%rint_petiole (:) = nan + allocate( EDecophyscon%rint_jansenchoat (0:numpft) ); EDecophyscon%rint_jansenchoat (:) = nan + allocate( EDecophyscon%Amaxh (0:numpft) ); EDecophyscon%Amaxh (:) = nan + allocate( EDecophyscon%rs2 (0:numpft) ); EDecophyscon%rs2 (:) = nan + allocate( EDecophyscon%srl (0:numpft) ); EDecophyscon%srl (:) = nan + allocate( EDecophyscon%ccontent (0:numpft) ); EDecophyscon%ccontent (:) = nan + allocate( EDecophyscon%latosa (0:numpft) ); EDecophyscon%latosa (:) = nan + allocate( EDecophyscon%rfrac_stem (0:numpft) ); EDecophyscon%rfrac_stem (:) = nan + allocate( EDecophyscon%rootshoot (0:numpft) ); EDecophyscon%rootshoot (:) = nan + allocate( EDecophyscon%avuln_gs (0:numpft) ); EDecophyscon%avuln_gs (:) = nan + allocate( EDecophyscon%p50_gs (0:numpft) ); EDecophyscon%p50_gs (:) = nan + + allocate( EDecophyscon%kmax_node (0:numpft,1:n_porous_media) ); EDecophyscon%kmax_node (:,:) = nan + allocate( EDecophyscon%avuln_node (0:numpft,1:n_porous_media) ); EDecophyscon%avuln_node (:,:) = nan + allocate( EDecophyscon%p50_node (0:numpft,1:n_porous_media) ); EDecophyscon%p50_node (:,:) = nan + allocate( EDecophyscon%thetas_node (0:numpft,1:n_porous_media) ); EDecophyscon%thetas_node (:,:) = nan + allocate( EDecophyscon%epsil_node (0:numpft,1:n_porous_media) ); EDecophyscon%epsil_node (:,:) = nan + allocate( EDecophyscon%pinot_node (0:numpft,1:n_porous_media) ); EDecophyscon%pinot_node (:,:) = nan + allocate( EDecophyscon%pitlp_node (0:numpft,1:n_porous_media) ); EDecophyscon%pitlp_node (:,:) = nan + allocate( EDecophyscon%resid_node (0:numpft,1:n_porous_media) ); EDecophyscon%resid_node (:,:) = nan + allocate( EDecophyscon%rwctlp_node (0:numpft,1:n_porous_media) ); EDecophyscon%rwctlp_node (:,:) = nan + allocate( EDecophyscon%fcap_node (0:numpft,1:n_porous_media) ); EDecophyscon%fcap_node (:,:) = nan + allocate( EDecophyscon%rwcft_node (0:numpft,1:n_porous_media) ); EDecophyscon%rwcft_node (:,:) = nan + allocate( EDecophyscon%rwccap_node (0:numpft,1:n_porous_media) ); EDecophyscon%rwccap_node (:,:) = nan + allocate( EDecophyscon%slp_node (0:numpft,1:n_porous_media) ); EDecophyscon%slp_node (:,:) = nan + allocate( EDecophyscon%intercept_node (0:numpft,1:n_porous_media) ); EDecophyscon%intercept_node (:,:) = nan + allocate( EDecophyscon%corrInt_node (0:numpft,1:n_porous_media) ); EDecophyscon%corrInt_node (:,:) = nan + + ! ------------------------------------------------------------------------------------------------ + ! Until the hydraulics parameter are added to the parameter file, they need a location to be set. + ! This happens here until further notice. + ! ------------------------------------------------------------------------------------------------ + call SetHydraulicsTestingParams(EDecophyscon) + + end if + + end subroutine EDecophysconInit + + subroutine SetHydraulicsTestingParams(EDEcophyscon) + + ! Arguments + type(EDecophyscon_type), intent(inout) :: EDEcophyscon + + write(fates_log(),*) 'FATES Plant Hydraulics is still under development, ending run.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + + end subroutine SetHydraulicsTestingParams + +end module EDEcophysConType diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 new file mode 100644 index 00000000..f7ada2f3 --- /dev/null +++ b/main/EDInitMod.F90 @@ -0,0 +1,330 @@ +module EDInitMod + + ! ============================================================================ + ! Contains all modules to set up the ED structure. + ! ============================================================================ + + use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : ifalse + use FatesGlobals , only : endrun => fates_endrun + use EDTypesMod , only : nclmax + use FatesGlobals , only : fates_log + use FatesInterfaceMod , only : hlm_is_restart + use EDPftvarcon , only : EDPftvarcon_inst + use EDEcophysConType , only : EDecophyscon + use EDGrowthFunctionsMod , only : bdead, bleaf, dbh + use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts + use EDPatchDynamicsMod , only : create_patch + use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, area + use EDTypesMod , only : ncwd + use EDTypesMod , only : nuMWaterMem + use EDTypesMod , only : numpft_ed + use FatesInterfaceMod , only : bc_in_type + use EDTypesMod , only : use_fates_plant_hydro + + implicit none + private + + logical :: DEBUG = .false. + + public :: zero_site + public :: init_patches + public :: set_site_properties + private :: init_cohorts + + ! ============================================================================ + +contains + + ! ============================================================================ + + subroutine zero_site( site_in ) + ! + ! !DESCRIPTION: + ! + ! !USES: + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + ! + ! !ARGUMENTS + type(ed_site_type), intent(inout) :: site_in + ! + ! !LOCAL VARIABLES: + !---------------------------------------------------------------------- + + site_in%oldest_patch => null() ! pointer to oldest patch at the site + site_in%youngest_patch => null() ! pointer to yngest patch at the site + + ! DISTURBANCE + site_in%disturbance_rate = 0._r8 ! site level disturbance rates from mortality and fire. + site_in%dist_type = 0 ! disturbance dist_type id. + site_in%total_burn_flux_to_atm = 0._r8 ! + + ! PHENOLOGY + site_in%status = 0 ! are leaves in this pixel on or off? + site_in%dstatus = 0 + site_in%ED_GDD_site = nan ! growing degree days + site_in%ncd = nan ! no chilling days + site_in%last_n_days(:) = 999 ! record of last 10 days temperature for senescence model. + site_in%leafondate = 999 ! doy of leaf on + site_in%leafoffdate = 999 ! doy of leaf off + site_in%dleafondate = 999 ! doy of leaf on drought + site_in%dleafoffdate = 999 ! doy of leaf on drought + site_in%water_memory(:) = nan + + + ! SEED + site_in%seed_bank(:) = 0._r8 + + ! FIRE + site_in%acc_ni = 0.0_r8 ! daily nesterov index accumulating over time. time unlimited theoretically. + site_in%frac_burnt = 0.0_r8 ! burn area read in from external file + + ! BGC Balance Checks + site_in%fates_to_bgc_this_ts = 0.0_r8 + site_in%fates_to_bgc_last_ts = 0.0_r8 + + ! termination and recruitment info + site_in%terminated_nindivs(:,:,:) = 0._r8 + site_in%termination_carbonflux(:) = 0._r8 + site_in%recruitment_rate(:) = 0._r8 + + ! demotion/promotion info + site_in%demotion_rate(:) = 0._r8 + site_in%demotion_carbonflux = 0._r8 + site_in%promotion_rate(:) = 0._r8 + site_in%promotion_carbonflux = 0._r8 + + ! diagnostic site-level cwd and litter fluxes + site_in%CWD_AG_diagnostic_input_carbonflux(:) = 0._r8 + site_in%CWD_BG_diagnostic_input_carbonflux(:) = 0._r8 + site_in%leaf_litter_diagnostic_input_carbonflux(:) = 0._r8 + site_in%root_litter_diagnostic_input_carbonflux(:) = 0._r8 + + end subroutine zero_site + + ! ============================================================================ + subroutine set_site_properties( nsites, sites) + ! + ! !DESCRIPTION: + ! + ! !USES: + ! + ! !ARGUMENTS + + integer, intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + ! + ! !LOCAL VARIABLES: + integer :: s + real(r8) :: leafon + real(r8) :: leafoff + real(r8) :: stat + real(r8) :: NCD + real(r8) :: GDD + real(r8) :: dstat + real(r8) :: acc_NI + real(r8) :: watermem + integer :: dleafoff + integer :: dleafon + !---------------------------------------------------------------------- + + if ( hlm_is_restart == ifalse ) then + !initial guess numbers for site condition. + NCD = 0.0_r8 + GDD = 30.0_r8 + leafon = 100.0_r8 + leafoff = 300.0_r8 + stat = 2 + acc_NI = 0.0_r8 + dstat = 2 + dleafoff = 300 + dleafon = 100 + watermem = 0.5_r8 + + else ! assignements for restarts + + NCD = 1.0_r8 ! NCD should be 1 on restart + GDD = 0.0_r8 + leafon = 0.0_r8 + leafoff = 0.0_r8 + stat = 1 + acc_NI = 0.0_r8 + dstat = 2 + dleafoff = 300 + dleafon = 100 + watermem = 0.5_r8 + + endif + + do s = 1,nsites + sites(s)%ncd = NCD + sites(s)%leafondate = leafon + sites(s)%leafoffdate = leafoff + sites(s)%dleafoffdate = dleafoff + sites(s)%dleafondate = dleafon + sites(s)%ED_GDD_site = GDD + + if ( hlm_is_restart == ifalse ) then + sites(s)%water_memory(1:numWaterMem) = watermem + end if + + sites(s)%status = stat + !start off with leaves off to initialise + sites(s)%dstatus= dstat + + sites(s)%acc_NI = acc_NI + sites(s)%frac_burnt = 0.0_r8 + sites(s)%old_stock = 0.0_r8 + + + end do + + return + end subroutine set_site_properties + + ! ============================================================================ + subroutine init_patches( nsites, sites, bc_in) + ! + ! !DESCRIPTION: + !initialize patches on new ground + ! + ! !USES: + use EDParamsMod , only : ED_val_maxspread + use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydProps + ! + ! !ARGUMENTS + integer, intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type), intent(in) :: bc_in(nsites) + ! + ! !LOCAL VARIABLES: + integer :: s + real(r8) :: cwd_ag_local(ncwd) + real(r8) :: cwd_bg_local(ncwd) + real(r8) :: spread_local(nclmax) + real(r8) :: leaf_litter_local(numpft_ed) + real(r8) :: root_litter_local(numpft_ed) + real(r8) :: age !notional age of this patch + type(ed_patch_type), pointer :: newp + !---------------------------------------------------------------------- + + cwd_ag_local(:) = 0.0_r8 !ED_val_init_litter -- arbitrary value for litter pools. kgC m-2 + cwd_bg_local(:) = 0.0_r8 !ED_val_init_litter + leaf_litter_local(:) = 0.0_r8 + root_litter_local(:) = 0.0_r8 + spread_local(:) = ED_val_maxspread + age = 0.0_r8 + + !FIX(SPM,032414) clean this up...inits out of this loop + do s = 1, nsites + + allocate(newp) + + newp%patchno = 1 + newp%younger => null() + newp%older => null() + + sites(s)%youngest_patch => newp + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp + + ! make new patch... + call create_patch(sites(s), newp, age, AREA, & + spread_local, cwd_ag_local, cwd_bg_local, leaf_litter_local, & + root_litter_local) + + call init_cohorts(newp, bc_in(s)) + + ! This sets the rhizosphere shells based on the plant initialization + ! The initialization of the plant-relevant hydraulics variables + ! were set from a call inside of the init_cohorts()->create_cohort() subroutine + if (use_fates_plant_hydro) then + call updateSizeDepRhizHydProps(sites(s), bc_in(s)) + end if + + enddo + + end subroutine init_patches + + ! ============================================================================ + subroutine init_cohorts( patch_in, bc_in) + ! + ! !DESCRIPTION: + ! initialize new cohorts on bare ground + ! + ! !USES: + ! + ! !ARGUMENTS + type(ed_patch_type), intent(inout), pointer :: patch_in + type(bc_in_type), intent(in) :: bc_in + ! + ! !LOCAL VARIABLES: + type(ed_cohort_type),pointer :: temp_cohort + integer :: cstatus + integer :: pft + !---------------------------------------------------------------------- + + patch_in%tallest => null() + patch_in%shortest => null() + + do pft = 1,numpft_ed !FIX(RF,032414) - turning off veg dynamics + + if(EDecophyscon%initd(pft)>1.0E-7) then + + allocate(temp_cohort) ! temporary cohort + + temp_cohort%pft = pft + temp_cohort%n = EDecophyscon%initd(pft) * patch_in%area + temp_cohort%hite = EDecophyscon%hgt_min(pft) + !temp_cohort%n = 0.5_r8 * 0.0028_r8 * patch_in%area ! BOC for fixed size runs EDecophyscon%initd(pft) * patch_in%area + !temp_cohort%hite = 28.65_r8 ! BOC translates to DBH of 50cm. EDecophyscon%hgt_min(pft) + temp_cohort%dbh = Dbh(temp_cohort) ! FIX(RF, 090314) - comment out addition of ' + 0.0001_r8*pft ' - seperate out PFTs a little bit... + temp_cohort%canopy_trim = 1.0_r8 + temp_cohort%bdead = Bdead(temp_cohort) + temp_cohort%balive = Bleaf(temp_cohort)*(1.0_r8 + EDPftvarcon_inst%froot_leaf(pft) & + + EDecophyscon%sapwood_ratio(temp_cohort%pft)*temp_cohort%hite) + temp_cohort%b = temp_cohort%balive + temp_cohort%bdead + + if( EDPftvarcon_inst%evergreen(pft) == 1) then + temp_cohort%bstore = Bleaf(temp_cohort) * EDecophyscon%cushion(pft) + temp_cohort%laimemory = 0._r8 + cstatus = 2 + endif + + if( EDPftvarcon_inst%season_decid(pft) == 1 ) then !for dorment places + temp_cohort%bstore = Bleaf(temp_cohort) * EDecophyscon%cushion(pft) !stored carbon in new seedlings. + if(patch_in%siteptr%status == 2)then + temp_cohort%laimemory = 0.0_r8 + else + temp_cohort%laimemory = Bleaf(temp_cohort) + endif + ! reduce biomass according to size of store, this will be recovered when elaves com on. + temp_cohort%balive = temp_cohort%balive - temp_cohort%laimemory + cstatus = patch_in%siteptr%status + endif + + if ( EDPftvarcon_inst%stress_decid(pft) == 1 ) then + temp_cohort%bstore = Bleaf(temp_cohort) * EDecophyscon%cushion(pft) + temp_cohort%laimemory = Bleaf(temp_cohort) + temp_cohort%balive = temp_cohort%balive - temp_cohort%laimemory + cstatus = patch_in%siteptr%dstatus + endif + + if ( DEBUG ) write(fates_log(),*) 'EDInitMod.F90 call create_cohort ' + + call create_cohort(patch_in, pft, temp_cohort%n, temp_cohort%hite, temp_cohort%dbh, & + temp_cohort%balive, temp_cohort%bdead, temp_cohort%bstore, & + temp_cohort%laimemory, cstatus, temp_cohort%canopy_trim, 1, bc_in) + + deallocate(temp_cohort) ! get rid of temporary cohort + + endif + + enddo !numpft + + call fuse_cohorts(patch_in,bc_in) + call sort_cohorts(patch_in) + + end subroutine init_cohorts + +end module EDInitMod diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 new file mode 100644 index 00000000..c9bc00f3 --- /dev/null +++ b/main/EDMainMod.F90 @@ -0,0 +1,575 @@ +module EDMainMod + + ! =========================================================================== + ! Main ED module. + ! ============================================================================ + + use shr_kind_mod , only : r8 => shr_kind_r8 + + use FatesGlobals , only : fates_log + use FatesInterfaceMod , only : hlm_freq_day + use FatesInterfaceMod , only : hlm_day_of_year + use FatesInterfaceMod , only : hlm_days_per_year + use FatesInterfaceMod , only : hlm_current_year + use FatesInterfaceMod , only : hlm_current_month + use FatesInterfaceMod , only : hlm_current_day + use EDCohortDynamicsMod , only : allocate_live_biomass + use EDCohortDynamicsMod , only : terminate_cohorts + use EDCohortDynamicsMod , only : fuse_cohorts + use EDCohortDynamicsMod , only : sort_cohorts + use EDCohortDynamicsMod , only : count_cohorts + use EDPatchDynamicsMod , only : disturbance_rates + use EDPatchDynamicsMod , only : fuse_patches + use EDPatchDynamicsMod , only : spawn_patches + use EDPatchDynamicsMod , only : terminate_patches + use EDTypesMod , only : get_age_class_index + use EDPhysiologyMod , only : canopy_derivs + use EDPhysiologyMod , only : non_canopy_derivs + use EDPhysiologyMod , only : phenology + use EDPhysiologyMod , only : recruitment + use EDPhysiologyMod , only : trim_canopy + use SFMainMod , only : fire_model + use EDtypesMod , only : ncwd + use EDTypesMod , only : numpft_ed + use EDtypesMod , only : ed_site_type + use EDtypesMod , only : ed_patch_type + use EDtypesMod , only : ed_cohort_type + use FatesInterfaceMod , only : bc_in_type + use FatesInterfaceMod , only : hlm_masterproc + use FatesConstantsMod , only : itrue + use FatesPlantHydraulicsMod, only : do_growthrecruiteffects + use FatesPlantHydraulicsMod, only : updateSizeDepTreeHydProps + use FatesPlantHydraulicsMod, only : updateSizeDepTreeHydStates + use FatesPlantHydraulicsMod, only : initTreeHydStates + use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydProps +! use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydStates + use EDTypesMod , only : use_fates_plant_hydro + use EDTypesMod , only : do_ed_phenology +! use EDTypesMod , only : do_ed_growth +! use EDTypesMod , only : do_ed_recruitment +! use EDTypesMod , only : do_ed_mort_dist + use EDTypesMod , only : do_ed_dynamics + + implicit none + private + + ! + ! !PUBLIC MEMBER FUNCTIONS: + public :: ed_ecosystem_dynamics + public :: ed_update_site + ! + ! !PRIVATE MEMBER FUNCTIONS: + + private :: ed_integrate_state_variables + private :: ed_total_balance_check + private :: bypass_dynamics + + logical :: DEBUG = .false. + ! + ! 10/30/09: Created by Rosie Fisher + !----------------------------------------------------------------------- + +contains + + !-------------------------------------------------------------------------------! + subroutine ed_ecosystem_dynamics(currentSite, bc_in) + ! + ! !DESCRIPTION: + ! Core of ed model, calling all subsequent vegetation dynamics routines + ! + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type) , intent(in) :: bc_in + ! + ! !LOCAL VARIABLES: + type(ed_patch_type), pointer :: currentPatch + !----------------------------------------------------------------------- + + if ( hlm_masterproc==itrue ) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& + hlm_current_year,'-',hlm_current_month,'-',hlm_current_day + + !************************************************************************** + ! Fire, growth, biogeochemistry. + !************************************************************************** + + !FIX(SPM,032414) take this out. On startup these values are all zero and on restart it + !zeros out values read in the restart file + + call ed_total_balance_check(currentSite, 0) + + if (do_ed_phenology) then + call phenology(currentSite, bc_in ) + end if + + if (do_ed_dynamics) then + call fire_model(currentSite, bc_in) + + ! Calculate disturbance and mortality based on previous timestep vegetation. + call disturbance_rates(currentSite) + end if + + if (do_ed_dynamics) then + ! Integrate state variables from annual rates to daily timestep + call ed_integrate_state_variables(currentSite, bc_in ) + + else + ! ed_intergrate_state_variables is where the new cohort flag + ! is set. This flag designates wether a cohort has + ! experienced a day, and therefore has been populated with non-nonsense + ! values. If we aren't entering that sequence, we need to set the flag + ! Make sure cohorts are marked as non-recruits + + call bypass_dynamics(currentSite) + + end if + + !****************************************************************************** + ! Reproduction, Recruitment and Cohort Dynamics : controls cohort organisation + !****************************************************************************** + + if(do_ed_dynamics) then + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) + + ! adds small cohort of each PFT + call recruitment(0, currentSite, currentPatch, bc_in) + + currentPatch => currentPatch%younger + enddo + end if + + + call ed_total_balance_check(currentSite,1) + + if( do_ed_dynamics ) then + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) + + ! puts cohorts in right order + call sort_cohorts(currentPatch) + + ! fuses similar cohorts + call fuse_cohorts(currentPatch, bc_in ) + + ! kills cohorts that are too small + call terminate_cohorts(currentSite, currentPatch) + + + currentPatch => currentPatch%younger + enddo + end if + + call ed_total_balance_check(currentSite,2) + + !********************************************************************************* + ! Patch dynamics sub-routines: fusion, new patch creation (spwaning), termination. + !********************************************************************************* + + ! make new patches from disturbed land + if ( do_ed_dynamics ) then + call spawn_patches(currentSite, bc_in) + end if + + call ed_total_balance_check(currentSite,3) + + ! fuse on the spawned patches. + if ( do_ed_dynamics ) then + call fuse_patches(currentSite, bc_in ) + + ! If using BC FATES hydraulics, update the rhizosphere geometry + ! based on the new cohort-patch structure + ! 'rhizosphere geometry' (column-level root biomass + rootfr --> root length + ! density --> node radii and volumes) + if(use_fates_plant_hydro .and. do_growthrecruiteffects) then + call updateSizeDepRhizHydProps(currentSite, bc_in) + ! call updateSizeDepRhizHydStates(currentSite, bc_in) + ! if(nshell > 1) then (THIS BEING CHECKED INSIDE OF the update) + ! call updateSizeDepRhizHydStates(currentSite, c, soilstate_inst, & + ! waterstate_inst) + ! end if + end if + end if + + call ed_total_balance_check(currentSite,4) + + ! kill patches that are too small + if ( do_ed_dynamics ) then + call terminate_patches(currentSite) + end if + + call ed_total_balance_check(currentSite,5) + + end subroutine ed_ecosystem_dynamics + + !-------------------------------------------------------------------------------! + subroutine ed_integrate_state_variables(currentSite, bc_in ) + ! + ! !DESCRIPTION: + ! FIX(SPM,032414) refactor so everything goes through interface + ! + ! !USES: + use EDTypesMod, only : ageclass_ed + ! + ! !ARGUMENTS: + type(ed_site_type) , intent(inout) :: currentSite + type(bc_in_type) , intent(in) :: bc_in + + ! + ! !LOCAL VARIABLES: + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type) , pointer :: currentCohort + + integer :: c ! Counter for litter size class + integer :: ft ! Counter for PFT + real(r8) :: small_no ! to circumvent numerical errors that cause negative values of things that can't be negative + real(r8) :: cohort_biomass_store ! remembers the biomass in the cohort for balance checking + !----------------------------------------------------------------------- + + small_no = 0.0000000000_r8 ! Obviously, this is arbitrary. RF - changed to zero + + do ft = 1,numpft_ed + currentSite%dseed_dt(ft) = 0._r8 ! zero the dseed_dt at the site level before looping through patches and adding the fluxes from each patch + end do + currentSite%seed_rain_flux(:) = 0._r8 + + currentPatch => currentSite%youngest_patch + + do while(associated(currentPatch)) + + currentPatch%age = currentPatch%age + hlm_freq_day + ! FIX(SPM,032414) valgrind 'Conditional jump or move depends on uninitialised value' + if( currentPatch%age < 0._r8 )then + write(fates_log(),*) 'negative patch age?',currentPatch%age, & + currentPatch%patchno,currentPatch%area + endif + + ! check to see if the patch has moved to the next age class + currentPatch%age_class = get_age_class_index(currentPatch%age) + + ! Find the derivatives of the growth and litter processes. + call canopy_derivs(currentSite, currentPatch, bc_in) + + ! Update Canopy Biomass Pools + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + + cohort_biomass_store = (currentCohort%balive+currentCohort%bdead+currentCohort%bstore) + currentCohort%dbh = max(small_no,currentCohort%dbh + currentCohort%ddbhdt * hlm_freq_day ) + currentCohort%balive = currentCohort%balive + currentCohort%dbalivedt * hlm_freq_day + currentCohort%bdead = max(small_no,currentCohort%bdead + currentCohort%dbdeaddt * hlm_freq_day ) + if ( DEBUG ) then + write(fates_log(),*) 'EDMainMod dbstoredt I ',currentCohort%bstore, & + currentCohort%dbstoredt,hlm_freq_day + end if + currentCohort%bstore = currentCohort%bstore + currentCohort%dbstoredt * hlm_freq_day + if ( DEBUG ) then + write(fates_log(),*) 'EDMainMod dbstoredt II ',currentCohort%bstore, & + currentCohort%dbstoredt,hlm_freq_day + end if + + if( (currentCohort%balive+currentCohort%bdead+currentCohort%bstore)*currentCohort%n<0._r8)then + write(fates_log(),*) 'biomass is negative', currentCohort%n,currentCohort%balive, & + currentCohort%bdead,currentCohort%bstore + endif + + if(abs((currentCohort%balive+currentCohort%bdead+currentCohort%bstore+hlm_freq_day*(currentCohort%md+ & + currentCohort%seed_prod)-cohort_biomass_store)-currentCohort%npp_acc) > 1e-8_r8)then + write(fates_log(),*) 'issue with c balance in integration', abs(currentCohort%balive+currentCohort%bdead+ & + currentCohort%bstore+hlm_freq_day* & + (currentCohort%md+currentCohort%seed_prod)-cohort_biomass_store-currentCohort%npp_acc) + endif + + ! THESE SHOULD BE MOVED TO A MORE "VISIBLE" LOCATION (RGK 10-2016) + currentCohort%npp_acc = 0.0_r8 + currentCohort%gpp_acc = 0.0_r8 + currentCohort%resp_acc = 0.0_r8 + + call allocate_live_biomass(currentCohort,1) + + ! BOC...update tree 'hydraulic geometry' + ! (size --> heights of elements --> hydraulic path lengths --> + ! maximum node-to-node conductances) + if(use_fates_plant_hydro .and. do_growthrecruiteffects) then + call updateSizeDepTreeHydProps(currentCohort, bc_in) + call updateSizeDepTreeHydStates(currentCohort) + end if + + currentCohort => currentCohort%taller + + enddo + + call non_canopy_derivs( currentSite, currentPatch, bc_in) + + !update state variables simultaneously according to derivatives for this time period. + + ! first update the litter variables that are tracked at the patch level + do c = 1,ncwd + currentPatch%cwd_ag(c) = currentPatch%cwd_ag(c) + currentPatch%dcwd_ag_dt(c)* hlm_freq_day + currentPatch%cwd_bg(c) = currentPatch%cwd_bg(c) + currentPatch%dcwd_bg_dt(c)* hlm_freq_day + enddo + + do ft = 1,numpft_ed + currentPatch%leaf_litter(ft) = currentPatch%leaf_litter(ft) + currentPatch%dleaf_litter_dt(ft)* hlm_freq_day + currentPatch%root_litter(ft) = currentPatch%root_litter(ft) + currentPatch%droot_litter_dt(ft)* hlm_freq_day + enddo + + do c = 1,ncwd + if(currentPatch%cwd_ag(c) currentPatch%shortest + do while(associated(currentCohort)) + currentCohort%n = max(small_no,currentCohort%n + currentCohort%dndt * hlm_freq_day ) + currentCohort => currentCohort%taller + enddo + + currentPatch => currentPatch%older + + enddo + + ! at the site level, update the seed bank mass + do ft = 1,numpft_ed + currentSite%seed_bank(ft) = currentSite%seed_bank(ft) + currentSite%dseed_dt(ft)*hlm_freq_day + enddo + + ! Check for negative values. Write out warning to show carbon balance. + do ft = 1,numpft_ed + if(currentSite%seed_bank(ft) currentSite%oldest_patch + do while(associated(currentPatch)) + + call terminate_cohorts(currentSite, currentPatch) + + ! FIX(SPM,040314) why is this needed for BFB restarts? Look into this at some point + cohort_number = count_cohorts(currentPatch) + if ( DEBUG ) then + write(fates_log(),*) 'tempCount ',cohort_number + endif + + ! Note (RF) + ! This breaks the balance check, but if we leave it out, then + ! the first new patch that isn't fused has no cohorts at the end of the spawn process + ! and so there are radiation errors instead. + ! Fixing this would likely require a re-work of how seed germination works which would be tricky. + if(currentPatch%countcohorts < 1)then + !write(fates_log(),*) 'ED: calling recruitment for no cohorts',currentPatch%siteptr%clmgcell,currentPatch%patchno + !call recruitment(1, currentSite, currentPatch) + ! write(fates_log(),*) 'patch empty',currentPatch%area,currentPatch%age + endif + + currentPatch => currentPatch%younger + + enddo + + ! FIX(RF,032414). This needs to be monthly, not annual + ! If this is the second to last day of the year, then perform trimming + if( hlm_day_of_year == hlm_days_per_year-1) then + + write(fates_log(),*) 'calling trim canopy' + call trim_canopy(currentSite) + endif + + end subroutine ed_update_site + + !-------------------------------------------------------------------------------! + subroutine ed_total_balance_check (currentSite, call_index ) + ! + ! !DESCRIPTION: + ! This routine looks at the carbon in and out of the ED model and compares it to + ! the change in total carbon stocks. + ! Fluxes in are NPP. Fluxes out are decay of CWD and litter into SOM pools. + ! ed_allsites_inst%flux_out and ed_allsites_inst%flux_in are set where they occur + ! in the code. + use EDTypesMod , only : AREA + + ! + ! !ARGUMENTS: + type(ed_site_type) , intent(inout) :: currentSite + integer , intent(in) :: call_index + ! + ! !LOCAL VARIABLES: + real(r8) :: biomass_stock ! total biomass in KgC/site + real(r8) :: litter_stock ! total litter in KgC/site + real(r8) :: seed_stock ! total seed mass in KgC/site + real(r8) :: total_stock ! total ED carbon in KgC/site + real(r8) :: change_in_stock ! Change since last time we set ed_allsites_inst%old_stock in this routine. KgC/site + real(r8) :: error ! How much carbon did we gain or lose (should be zero!) + real(r8) :: net_flux ! Difference between recorded fluxes in and out. KgC/site + + ! nb. There is no time associated with these variables + ! because this routine can be called between any two + ! arbitrary points in code, even if no time has passed. + ! Also, the carbon pools are per site/gridcell, so that + ! we can account for the changing areas of patches. + + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type) , pointer :: currentCohort + !----------------------------------------------------------------------- + + change_in_stock = 0.0_r8 + biomass_stock = 0.0_r8 + litter_stock = 0.0_r8 + + seed_stock = sum(currentSite%seed_bank)*AREA + + currentPatch => currentSite%oldest_patch + do while(associated(currentPatch)) + + litter_stock = litter_stock + currentPatch%area * (sum(currentPatch%cwd_ag)+ & + sum(currentPatch%cwd_bg)+sum(currentPatch%leaf_litter)+sum(currentPatch%root_litter)) + currentCohort => currentPatch%tallest; + + do while(associated(currentCohort)) + + biomass_stock = biomass_stock + (currentCohort%bdead + currentCohort%balive + & + currentCohort%bstore) * currentCohort%n + currentCohort => currentCohort%shorter; + + enddo !end cohort loop + + currentPatch => currentPatch%younger + + enddo !end patch loop + + total_stock = biomass_stock + seed_stock +litter_stock + change_in_stock = total_stock - currentSite%old_stock + net_flux = currentSite%flux_in - currentSite%flux_out + error = abs(net_flux - change_in_stock) + + if ( abs(error) > 10e-6 ) then + write(fates_log(),*) 'total error: call index: ',call_index, & + 'in: ',currentSite%flux_in, & + 'out: ',currentSite%flux_out, & + 'net: ',net_flux, & + 'dstock: ',change_in_stock, & + 'error=net_flux-dstock:', error + write(fates_log(),*) 'biomass,litter,seeds', biomass_stock,litter_stock,seed_stock + write(fates_log(),*) 'lat lon',currentSite%lat,currentSite%lon + endif + + currentSite%flux_in = 0.0_r8 + currentSite%flux_out = 0.0_r8 + currentSite%old_stock = total_stock + + end subroutine ed_total_balance_check + + ! ===================================================================================== + + subroutine bypass_dynamics(currentSite) + + ! ---------------------------------------------------------------------------------- + ! If dynamics are bypassed, various fluxes, rates and flags need to be set + ! to trivial values. + ! WARNING: Turning off things like dynamics is experimental. The setting of + ! variables to trivial values may not be complete, use at your own risk. + ! ---------------------------------------------------------------------------------- + + ! Arguments + type(ed_site_type) , intent(inout), target :: currentSite + + ! Locals + type(ed_patch_type), pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + currentPatch => currentSite%youngest_patch + do while(associated(currentPatch)) + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + + currentCohort%isnew=.false. + + currentCohort%npp_acc_hold = currentCohort%npp_acc * dble(hlm_days_per_year) + currentCohort%gpp_acc_hold = currentCohort%gpp_acc * dble(hlm_days_per_year) + currentCohort%resp_acc_hold = currentCohort%resp_acc * dble(hlm_days_per_year) + + currentCohort%npp_acc = 0.0_r8 + currentCohort%gpp_acc = 0.0_r8 + currentCohort%resp_acc = 0.0_r8 + + currentCohort%npp_leaf = 0.0_r8 + currentCohort%npp_froot = 0.0_r8 + currentCohort%npp_bsw = 0.0_r8 + currentCohort%npp_bdead = 0.0_r8 + currentCohort%npp_bseed = 0.0_r8 + currentCohort%npp_store = 0.0_r8 + + currentCohort%bmort = 0.0_r8 + currentCohort%hmort = 0.0_r8 + currentCohort%cmort = 0.0_r8 + currentCohort%imort = 0.0_r8 + currentCohort%fmort = 0.0_r8 + + currentCohort => currentCohort%taller + enddo + currentPatch => currentPatch%older + enddo + + end subroutine bypass_dynamics + + +end module EDMainMod diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 new file mode 100644 index 00000000..8bc4e9f9 --- /dev/null +++ b/main/EDParamsMod.F90 @@ -0,0 +1,314 @@ +module EDParamsMod + ! + ! module that deals with reading the ED parameter file + ! + use shr_kind_mod , only: r8 => shr_kind_r8 + use EDtypesMod , only: maxPft + use FatesParametersInterface, only : param_string_length + + implicit none + save + ! private - if we allow this module to be private, it does not allow the protected values below to be + ! seen outside of this module. + + ! + ! this is what the user can use for the actual values + ! + + real(r8),protected :: ED_val_grass_spread + real(r8),protected :: ED_val_comp_excln + real(r8),protected :: ED_val_stress_mort + real(r8),protected :: ED_val_dispersal + real(r8),protected :: ED_val_maxspread + real(r8),protected :: ED_val_minspread + real(r8),protected :: ED_val_init_litter + real(r8),protected :: ED_val_nignitions + real(r8),protected :: ED_val_understorey_death + real(r8),protected :: ED_val_ag_biomass + real(r8),protected :: ED_val_cwd_fcel + real(r8),protected :: ED_val_cwd_flig + real(r8),protected :: ED_val_bbopt_c3 + real(r8),protected :: ED_val_bbopt_c4 + real(r8),protected :: ED_val_base_mr_20 + real(r8),protected :: ED_val_phen_drought_threshold + real(r8),protected :: ED_val_phen_doff_time + real(r8),protected :: ED_val_phen_a + real(r8),protected :: ED_val_phen_b + real(r8),protected :: ED_val_phen_c + real(r8),protected :: ED_val_phen_chiltemp + real(r8),protected :: ED_val_phen_mindayson + real(r8),protected :: ED_val_phen_ncolddayslim + real(r8),protected :: ED_val_phen_coldtemp + real(r8),protected :: ED_val_cohort_fusion_tol + real(r8),protected :: ED_val_patch_fusion_tol + + character(len=param_string_length),parameter :: ED_name_grass_spread = "fates_grass_spread" + character(len=param_string_length),parameter :: ED_name_comp_excln = "fates_comp_excln" + character(len=param_string_length),parameter :: ED_name_stress_mort = "fates_stress_mort" + character(len=param_string_length),parameter :: ED_name_dispersal = "fates_dispersal" + character(len=param_string_length),parameter :: ED_name_maxspread = "fates_maxspread" + character(len=param_string_length),parameter :: ED_name_minspread = "fates_minspread" + character(len=param_string_length),parameter :: ED_name_init_litter = "fates_init_litter" + character(len=param_string_length),parameter :: ED_name_nignitions = "fates_nfires" + character(len=param_string_length),parameter :: ED_name_understorey_death = "fates_understorey_death" + character(len=param_string_length),parameter :: ED_name_ag_biomass= "fates_ag_biomass" + character(len=param_string_length),parameter :: ED_name_cwd_fcel= "fates_cwd_fcel" + character(len=param_string_length),parameter :: ED_name_cwd_flig= "fates_cwd_flig" + character(len=param_string_length),parameter :: ED_name_bbopt_c3= "fates_bbopt_c3" + character(len=param_string_length),parameter :: ED_name_bbopt_c4= "fates_bbopt_c4" + character(len=param_string_length),parameter :: ED_name_base_mr_20= "fates_base_mr_20" + character(len=param_string_length),parameter :: ED_name_phen_drought_threshold= "fates_phen_drought_threshold" + character(len=param_string_length),parameter :: ED_name_phen_doff_time= "fates_phen_doff_time" + character(len=param_string_length),parameter :: ED_name_phen_a= "fates_phen_a" + character(len=param_string_length),parameter :: ED_name_phen_b= "fates_phen_b" + character(len=param_string_length),parameter :: ED_name_phen_c= "fates_phen_c" + character(len=param_string_length),parameter :: ED_name_phen_chiltemp= "fates_phen_chiltemp" + character(len=param_string_length),parameter :: ED_name_phen_mindayson= "fates_phen_mindayson" + character(len=param_string_length),parameter :: ED_name_phen_ncolddayslim= "fates_phen_ncolddayslim" + character(len=param_string_length),parameter :: ED_name_phen_coldtemp= "fates_phen_coldtemp" + character(len=param_string_length),parameter :: ED_name_cohort_fusion_tol= "fates_cohort_fusion_tol" + character(len=param_string_length),parameter :: ED_name_patch_fusion_tol= "fates_patch_fusion_tol" + + public :: FatesParamsInit + public :: FatesRegisterParams + public :: FatesReceiveParams + +contains + + !----------------------------------------------------------------------- + subroutine FatesParamsInit() + ! Initialize all parameters to nan to ensure that we get valid + ! values back from the host. + + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + + implicit none + + ED_val_grass_spread = nan + ED_val_comp_excln = nan + ED_val_stress_mort = nan + ED_val_dispersal = nan + ED_val_maxspread = nan + ED_val_minspread = nan + ED_val_init_litter = nan + ED_val_nignitions = nan + ED_val_understorey_death = nan + ED_val_ag_biomass = nan + ED_val_cwd_fcel = nan + ED_val_cwd_flig = nan + ED_val_bbopt_c3 = nan + ED_val_bbopt_c4 = nan + ED_val_base_mr_20 = nan + ED_val_phen_drought_threshold = nan + ED_val_phen_doff_time = nan + ED_val_phen_a = nan + ED_val_phen_b = nan + ED_val_phen_c = nan + ED_val_phen_chiltemp = nan + ED_val_phen_mindayson = nan + ED_val_phen_ncolddayslim = nan + ED_val_phen_coldtemp = nan + ED_val_cohort_fusion_tol = nan + ED_val_patch_fusion_tol = nan + + end subroutine FatesParamsInit + + !----------------------------------------------------------------------- + subroutine FatesRegisterParams(fates_params) + ! Register the parameters we want the host to provide, and + ! indicate whether they are fates parameters or host parameters + ! that need to be synced with host values. + + use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar1d, dimension_shape_1d + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_scalar1d/) + + call FatesParamsInit() + + call fates_params%RegisterParameter(name=ED_name_grass_spread, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_comp_excln, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_grass_spread, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_comp_excln, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_stress_mort, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_dispersal, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_maxspread, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_minspread, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_init_litter, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_nignitions, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_understorey_death, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_ag_biomass, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_cwd_fcel, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_cwd_flig, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_bbopt_c3, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_bbopt_c4, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_base_mr_20, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_phen_drought_threshold, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_phen_doff_time, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_phen_a, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_phen_b, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_phen_c, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_phen_chiltemp, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_phen_mindayson, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_phen_ncolddayslim, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_phen_coldtemp, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_cohort_fusion_tol, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + call fates_params%RegisterParameter(name=ED_name_patch_fusion_tol, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + end subroutine FatesRegisterParams + + + !----------------------------------------------------------------------- + subroutine FatesReceiveParams(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + call fates_params%RetreiveParameter(name=ED_name_grass_spread, & + data=ED_val_grass_spread) + + call fates_params%RetreiveParameter(name=ED_name_comp_excln, & + data=ED_val_comp_excln) + + call fates_params%RetreiveParameter(name=ED_name_grass_spread, & + data=ED_val_grass_spread) + + call fates_params%RetreiveParameter(name=ED_name_comp_excln, & + data=ED_val_comp_excln) + + call fates_params%RetreiveParameter(name=ED_name_stress_mort, & + data=ED_val_stress_mort) + + call fates_params%RetreiveParameter(name=ED_name_dispersal, & + data=ED_val_dispersal) + + call fates_params%RetreiveParameter(name=ED_name_maxspread, & + data=ED_val_maxspread) + + call fates_params%RetreiveParameter(name=ED_name_minspread, & + data=ED_val_minspread) + + call fates_params%RetreiveParameter(name=ED_name_init_litter, & + data=ED_val_init_litter) + + call fates_params%RetreiveParameter(name=ED_name_nignitions, & + data=ED_val_nignitions) + + call fates_params%RetreiveParameter(name=ED_name_understorey_death, & + data=ED_val_understorey_death) + + call fates_params%RetreiveParameter(name=ED_name_ag_biomass, & + data=ED_val_ag_biomass) + + call fates_params%RetreiveParameter(name=ED_name_cwd_fcel, & + data=ED_val_cwd_fcel) + + call fates_params%RetreiveParameter(name=ED_name_cwd_flig, & + data=ED_val_cwd_flig) + + call fates_params%RetreiveParameter(name=ED_name_bbopt_c3, & + data=ED_val_bbopt_c3) + + call fates_params%RetreiveParameter(name=ED_name_bbopt_c4, & + data=ED_val_bbopt_c4) + + call fates_params%RetreiveParameter(name=ED_name_base_mr_20, & + data=ED_val_base_mr_20) + + call fates_params%RetreiveParameter(name=ED_name_phen_drought_threshold, & + data=ED_val_phen_drought_threshold) + + call fates_params%RetreiveParameter(name=ED_name_phen_doff_time, & + data=ED_val_phen_doff_time) + + call fates_params%RetreiveParameter(name=ED_name_phen_a, & + data=ED_val_phen_a) + + call fates_params%RetreiveParameter(name=ED_name_phen_b, & + data=ED_val_phen_b) + + call fates_params%RetreiveParameter(name=ED_name_phen_c, & + data=ED_val_phen_c) + + call fates_params%RetreiveParameter(name=ED_name_phen_chiltemp, & + data=ED_val_phen_chiltemp) + + call fates_params%RetreiveParameter(name=ED_name_phen_mindayson, & + data=ED_val_phen_mindayson) + + call fates_params%RetreiveParameter(name=ED_name_phen_ncolddayslim, & + data=ED_val_phen_ncolddayslim) + + call fates_params%RetreiveParameter(name=ED_name_phen_coldtemp, & + data=ED_val_phen_coldtemp) + + call fates_params%RetreiveParameter(name=ED_name_cohort_fusion_tol, & + data=ED_val_cohort_fusion_tol) + + call fates_params%RetreiveParameter(name=ED_name_patch_fusion_tol, & + data=ED_val_patch_fusion_tol) + + end subroutine FatesReceiveParams + +end module EDParamsMod diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 new file mode 100644 index 00000000..1a81ccf2 --- /dev/null +++ b/main/EDPftvarcon.F90 @@ -0,0 +1,1015 @@ +module EDPftvarcon + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Module containing vegetation constants and method to + ! read and initialize vegetation (PFT) constants. + ! + ! !USES: + use EDTypesMod , only : maxSWb, ivis, inir + use shr_kind_mod, only : r8 => shr_kind_r8 + + use FatesGlobals, only : fates_log + ! + ! !PUBLIC TYPES: + implicit none + save + private + + integer, parameter, public :: lower_bound_pft = 0 + integer, parameter, public :: lower_bound_general = 1 + + !ED specific variables. + type, public :: EDPftvarcon_type + real(r8), allocatable :: max_dbh (:) ! maximum dbh at which height growth ceases... + real(r8), allocatable :: freezetol (:) ! minimum temperature tolerance... + real(r8), allocatable :: wood_density (:) ! wood density g cm^-3 ... + real(r8), allocatable :: alpha_stem (:) ! live stem turnover rate. y-1 + real(r8), allocatable :: hgt_min (:) ! sapling height m + real(r8), allocatable :: dleaf (:) ! leaf characteristic dimension length (m) + real(r8), allocatable :: z0mr (:) ! ratio of roughness length of vegetation to height (-) + real(r8), allocatable :: displar (:) ! ratio of displacement height to canopy top height (-) + real(r8), allocatable :: cushion (:) ! labile carbon storage target as multiple of leaf pool. + real(r8), allocatable :: leaf_stor_priority (:) ! leaf turnover vs labile carbon use prioritisation. (1 = lose leaves, 0 = use store). + real(r8), allocatable :: leafwatermax (:) ! degree to which respiration is limited by btran if btran = 0 + real(r8), allocatable :: rootresist (:) + real(r8), allocatable :: soilbeta (:) + real(r8), allocatable :: crown (:) + real(r8), allocatable :: bark_scaler (:) + real(r8), allocatable :: crown_kill (:) + real(r8), allocatable :: initd (:) + real(r8), allocatable :: sd_mort (:) + real(r8), allocatable :: seed_rain (:) + real(r8), allocatable :: BB_slope (:) + real(r8), allocatable :: root_long (:) ! root longevity (yrs) + real(r8), allocatable :: clone_alloc (:) ! fraction of carbon balance allocated to clonal reproduction. + real(r8), allocatable :: seed_alloc (:) ! fraction of carbon balance allocated to seeds. + real(r8), allocatable :: sapwood_ratio (:) ! amount of sapwood per unit leaf carbon and m of height. gC/gC/m + real(r8), allocatable :: woody(:) + real(r8), allocatable :: stress_decid(:) + real(r8), allocatable :: season_decid(:) + real(r8), allocatable :: evergreen(:) + real(r8), allocatable :: froot_leaf(:) + real(r8), allocatable :: slatop(:) + real(r8), allocatable :: leaf_long(:) + real(r8), allocatable :: roota_par(:) + real(r8), allocatable :: rootb_par(:) + real(r8), allocatable :: lf_flab(:) + real(r8), allocatable :: lf_fcel(:) + real(r8), allocatable :: lf_flig(:) + real(r8), allocatable :: fr_flab(:) + real(r8), allocatable :: fr_fcel(:) + real(r8), allocatable :: fr_flig(:) + real(r8), allocatable :: xl(:) + real(r8), allocatable :: c3psn(:) + real(r8), allocatable :: flnr(:) + real(r8), allocatable :: fnitr(:) + real(r8), allocatable :: leafcn(:) + real(r8), allocatable :: frootcn(:) + real(r8), allocatable :: smpso(:) + real(r8), allocatable :: smpsc(:) + real(r8), allocatable :: grperc(:) ! NOTE(bja, 2017-01) moved from EDParamsMod, was allocated as (maxPft=79), not (0:mxpft=78)! + real(r8), allocatable :: dbh2h_m(:) + real(r8), allocatable :: dbh2h_c(:) + real(r8), allocatable :: dbh2bl_a(:) + real(r8), allocatable :: dbh2bl_b(:) + real(r8), allocatable :: dbh2bl_dbh2carea_expnt_diff(:) + real(r8), allocatable :: dbh2bl_c(:) + real(r8), allocatable :: dbh2bl_slascaler(:) + real(r8), allocatable :: sai_scaler(:) + real(r8), allocatable :: dbh2bd_a(:) + real(r8), allocatable :: dbh2bd_b(:) + real(r8), allocatable :: dbh2bd_c(:) + real(r8), allocatable :: dbh2bd_d(:) + real(r8), allocatable :: bmort(:) + real(r8), allocatable :: hf_sm_threshold(:) + real(r8), allocatable :: vcmaxha(:) + real(r8), allocatable :: jmaxha(:) + real(r8), allocatable :: tpuha(:) + real(r8), allocatable :: vcmaxhd(:) + real(r8), allocatable :: jmaxhd(:) + real(r8), allocatable :: tpuhd(:) + real(r8), allocatable :: vcmaxse(:) + real(r8), allocatable :: jmaxse(:) + real(r8), allocatable :: tpuse(:) + real(r8), allocatable :: germination_timescale(:) + real(r8), allocatable :: seed_decay_turnover(:) + real(r8), allocatable :: rhol(:, :) + real(r8), allocatable :: rhos(:, :) + real(r8), allocatable :: taul(:, :) + real(r8), allocatable :: taus(:, :) + real(r8), allocatable :: rootprof_beta(:, :) + contains + procedure, public :: Init => EDpftconInit + procedure, public :: Register + procedure, public :: Receive + procedure, private :: Register_PFT + procedure, private :: Receive_PFT + procedure, private :: Register_PFT_nvariants + procedure, private :: Receive_PFT_nvariants + procedure, private :: Register_PFT_numrad + procedure, private :: Receive_PFT_numrad + end type EDPftvarcon_type + + type(EDPftvarcon_type), public :: EDPftvarcon_inst + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + ! + ! !PUBLIC MEMBER FUNCTIONS: + + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + subroutine EDpftconInit(this) + + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + + implicit none + + class(EDPftvarcon_type), intent(inout) :: this + + end subroutine EDpftconInit + + !----------------------------------------------------------------------- + subroutine Register(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type + + implicit none + + class(EDPftvarcon_type), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + call this%Register_PFT(fates_params) + call this%Register_PFT_numrad(fates_params) + call this%Register_PFT_nvariants(fates_params) + + end subroutine Register + + !----------------------------------------------------------------------- + subroutine Receive(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type + + implicit none + + class(EDPftvarcon_type), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + call this%Receive_PFT(fates_params) + call this%Receive_PFT_numrad(fates_params) + call this%Receive_PFT_nvariants(fates_params) + + end subroutine Receive + + !----------------------------------------------------------------------- + subroutine Register_PFT(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + use FatesParametersInterface, only : dimension_name_pft, dimension_shape_1d + + implicit none + + class(EDPftvarcon_type), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_pft/) + + integer, parameter :: dim_lower_bound(1) = (/ lower_bound_pft /) + + character(len=param_string_length) :: name + + !X! name = '' + !X! call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + !X! dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_max_dbh' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_freezetol' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_wood_density' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_alpha_stem' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hgt_min' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_cushion' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_leaf_stor_priority' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_leafwatermax' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_rootresist' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_soilbeta' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_crown' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_bark_scaler' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_crown_kill' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_initd' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_sd_mort' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_seed_rain' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_BB_slope' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_root_long' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_clone_alloc' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_seed_alloc' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_sapwood_ratio' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_woody' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_stress_decid' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_season_decid' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_evergreen' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_froot_leaf' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_slatop' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_leaf_long' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_roota_par' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_rootb_par' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_lf_flab' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_lf_fcel' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_lf_flig' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_fr_flab' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_fr_fcel' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_fr_flig' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_xl' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_c3psn' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_flnr' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_fnitr' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_leafcn' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_frootcn' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_smpso' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_smpsc' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_grperc' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2h_m' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2h_c' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2bl_a' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2bl_b' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2bl_dbh2carea_expnt_diff' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2bl_c' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2bl_slascaler' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_sai_scaler' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2bd_a' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2bd_b' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2bd_c' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dbh2bd_d' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_bmort' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hf_sm_threshold' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_vcmaxha' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_jmaxha' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_tpuha' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_vcmaxhd' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_jmaxhd' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_tpuhd' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_vcmaxse' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_jmaxse' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_tpuse' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_germination_timescale' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_seed_decay_turnover' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dleaf' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_z0mr' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_displar' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + + + end subroutine Register_PFT + + !----------------------------------------------------------------------- + subroutine Receive_PFT(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + + implicit none + + class(EDPftvarcon_type), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length) :: name + + !X! name = '' + !X! call fates_params%RetreiveParameter(name=name, & + !X! data=this%) + + name = 'fates_max_dbh' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%max_dbh) + + name = 'fates_freezetol' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%freezetol) + + name = 'fates_wood_density' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%wood_density) + + name = 'fates_alpha_stem' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%alpha_stem) + + name = 'fates_hgt_min' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hgt_min) + + name = 'fates_cushion' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%cushion) + + name = 'fates_leaf_stor_priority' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%leaf_stor_priority) + + name = 'fates_leafwatermax' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%leafwatermax) + + name = 'fates_rootresist' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%rootresist) + + name = 'fates_soilbeta' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%soilbeta) + + name = 'fates_crown' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%crown) + + name = 'fates_bark_scaler' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%bark_scaler) + + name = 'fates_crown_kill' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%crown_kill) + + name = 'fates_initd' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%initd) + + name = 'fates_sd_mort' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%sd_mort) + + name = 'fates_seed_rain' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%seed_rain) + + name = 'fates_BB_slope' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%BB_slope) + + name = 'fates_root_long' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%root_long) + + name = 'fates_clone_alloc' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%clone_alloc) + + name = 'fates_seed_alloc' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%seed_alloc) + + name = 'fates_sapwood_ratio' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%sapwood_ratio) + + name = 'fates_woody' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%woody) + + name = 'fates_stress_decid' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%stress_decid) + + name = 'fates_season_decid' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%season_decid) + + name = 'fates_evergreen' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%evergreen) + + name = 'fates_froot_leaf' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%froot_leaf) + + name = 'fates_slatop' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%slatop) + + name = 'fates_leaf_long' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%leaf_long) + + name = 'fates_roota_par' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%roota_par) + + name = 'fates_rootb_par' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%rootb_par) + + name = 'fates_lf_flab' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%lf_flab) + + name = 'fates_lf_fcel' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%lf_fcel) + + name = 'fates_lf_flig' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%lf_flig) + + name = 'fates_fr_flab' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%fr_flab) + + name = 'fates_fr_fcel' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%fr_fcel) + + name = 'fates_fr_flig' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%fr_flig) + + name = 'fates_xl' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%xl) + + name = 'fates_c3psn' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%c3psn) + + name = 'fates_flnr' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%flnr) + + name = 'fates_fnitr' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%fnitr) + + name = 'fates_leafcn' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%leafcn) + + name = 'fates_frootcn' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%frootcn) + + name = 'fates_smpso' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%smpso) + + name = 'fates_smpsc' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%smpsc) + + name = 'fates_grperc' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%grperc) + + name = 'fates_dbh2h_m' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2h_m) + + name = 'fates_dbh2h_c' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2h_c) + + name = 'fates_dbh2bl_a' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2bl_a) + + name = 'fates_dbh2bl_b' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2bl_b) + + name = 'fates_dbh2bl_dbh2carea_expnt_diff' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2bl_dbh2carea_expnt_diff) + + name = 'fates_dbh2bl_c' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2bl_c) + + name = 'fates_dbh2bl_slascaler' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2bl_slascaler) + + name = 'fates_sai_scaler' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%sai_scaler) + + name = 'fates_dbh2bd_a' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2bd_a) + + name = 'fates_dbh2bd_b' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2bd_b) + + name = 'fates_dbh2bd_c' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2bd_c) + + name = 'fates_dbh2bd_d' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dbh2bd_d) + + name = 'fates_bmort' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%bmort) + + name = 'fates_hf_sm_threshold' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hf_sm_threshold) + + name = 'fates_vcmaxha' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%vcmaxha) + + name = 'fates_jmaxha' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%jmaxha) + + name = 'fates_tpuha' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%tpuha) + + name = 'fates_vcmaxhd' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%vcmaxhd) + + name = 'fates_jmaxhd' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%jmaxhd) + + name = 'fates_tpuhd' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%tpuhd) + + name = 'fates_vcmaxse' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%vcmaxse) + + name = 'fates_jmaxse' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%jmaxse) + + name = 'fates_tpuse' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%tpuse) + + name = 'fates_germination_timescale' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%germination_timescale) + + name = 'fates_seed_decay_turnover' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%seed_decay_turnover) + + name = 'fates_dleaf' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dleaf) + + name = 'fates_z0mr' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%z0mr) + + name = 'fates_displar' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%displar) + + + end subroutine Receive_PFT + + !----------------------------------------------------------------------- + subroutine Register_PFT_numrad(this, fates_params) + ! NOTE(bja, 2017-02) these are 2-d parameters, but they are + ! currently stored in the parameter file as separate 1-d + ! arrays. We have to register the parameters as 1-d arrays as they + ! are on the parameter file. We store them as 2-d in the receive step. + use FatesParametersInterface, only : fates_parameters_type, param_string_length + use FatesParametersInterface, only : dimension_name_pft, dimension_shape_1d + + implicit none + + class(EDPftvarcon_type), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_pft/) + integer, parameter :: dim_lower_bound(1) = (/ lower_bound_pft /) + character(len=param_string_length) :: name + + !X! name = '' + !X! call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + !X! dimension_names=dim_names) + + name = 'fates_rholvis' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'fates_rholnir' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'fates_rhosvis' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'fates_rhosnir' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'fates_taulvis' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'fates_taulnir' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'fates_tausvis' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + name = 'fates_tausnir' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names) + + + end subroutine Register_PFT_numrad + + !----------------------------------------------------------------------- + subroutine Receive_PFT_numrad(this, fates_params) + ! NOTE(bja, 2017-02) these are 2-d parameters, but they are + ! currently stored in the parameter file as separate 1-d arrays. + ! We can't allocate slices of arrays separately, so we have to + ! manually allocate the memory here, retreive into a dummy array, + ! and copy. All parameters in this subroutine are sized the same, + ! so we can reused the dummy array. If someone wants to cleanup + ! the input file, all this complexity can be removed. + use FatesParametersInterface, only : fates_parameters_type + use FatesParametersInterface, only : param_string_length, max_dimensions + + implicit none + + class(EDPftvarcon_type), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length) :: name + + !X! name = '' + !X! call fates_params%RetreiveParameter(name=name, & + !X! data=this%) + + integer :: index + integer :: dimension_shape + integer :: dimension_sizes(max_dimensions) + character(len=param_string_length) :: dimension_names(max_dimensions) + logical :: is_host_param + + integer :: lower_bound_1, upper_bound_1, lower_bound_2, upper_bound_2 + real(r8), allocatable :: dummy_data(:) + + ! Fetch metadata from a representative variable. All variables + ! called by this subroutine must be dimensioned the same way! + name = 'fates_rholvis' + index = fates_params%FindIndex(name) + call fates_params%GetMetaData(index, name, dimension_shape, dimension_sizes, dimension_names, is_host_param) + lower_bound_1 = lower_bound_pft + upper_bound_1 = lower_bound_pft + dimension_sizes(1) - 1 + lower_bound_2 = lower_bound_general + upper_bound_2 = maxSWb ! When we have radiation parameters read in as a vector + ! We will compare the vector dimension size that we + ! read-in to the parameterized size that fates expects + + allocate(dummy_data(lower_bound_1:upper_bound_1)) + + ! + ! received rhol data + ! + allocate(this%rhol(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) + + name = 'fates_rholvis' + call fates_params%RetreiveParameter(name=name, & + data=dummy_data) + this%rhol(lower_bound_1:upper_bound_1, ivis) = dummy_data + + name = 'fates_rholnir' + call fates_params%RetreiveParameter(name=name, & + data=dummy_data) + this%rhol(lower_bound_1:upper_bound_1, inir) = dummy_data + + ! + ! received rhos data + ! + allocate(this%rhos(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) + + name = 'fates_rhosvis' + call fates_params%RetreiveParameter(name=name, & + data=dummy_data) + this%rhos(lower_bound_1:upper_bound_1, ivis) = dummy_data + + name = 'fates_rhosnir' + call fates_params%RetreiveParameter(name=name, & + data=dummy_data) + this%rhos(lower_bound_1:upper_bound_1, inir) = dummy_data + + ! + ! received taul data + ! + allocate(this%taul(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) + + name = 'fates_taulvis' + call fates_params%RetreiveParameter(name=name, & + data=dummy_data) + this%taul(lower_bound_1:upper_bound_1, ivis) = dummy_data + + name = 'fates_taulnir' + call fates_params%RetreiveParameter(name=name, & + data=dummy_data) + this%taul(lower_bound_1:upper_bound_1, inir) = dummy_data + + ! + ! received taus data + ! + allocate(this%taus(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) + + name = 'fates_tausvis' + call fates_params%RetreiveParameter(name=name, & + data=dummy_data) + this%taus(lower_bound_1:upper_bound_1, ivis) = dummy_data + + name = 'fates_tausnir' + call fates_params%RetreiveParameter(name=name, & + data=dummy_data) + this%taus(lower_bound_1:upper_bound_1, inir) = dummy_data + + end subroutine Receive_PFT_numrad + + !----------------------------------------------------------------------- + subroutine Register_PFT_nvariants(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + use FatesParametersInterface, only : max_dimensions, dimension_name_variants, dimension_name_pft, dimension_shape_2d + + implicit none + + class(EDPftvarcon_type), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + integer, parameter :: dim_lower_bound(2) = (/ lower_bound_pft, lower_bound_general /) + character(len=param_string_length) :: dim_names(2) + character(len=param_string_length) :: name + + ! NOTE(bja, 2017-01) initialization doesn't seem to work correctly + ! if dim_names has a parameter qualifier. + dim_names(1) = dimension_name_pft + dim_names(2) = dimension_name_variants + + !X! name = '' + !X! call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + !X! dimension_names=dim_names) + + name = 'fates_rootprof_beta' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + end subroutine Register_PFT_nvariants + + !----------------------------------------------------------------------- + subroutine Receive_PFT_nvariants(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type + use FatesParametersInterface, only : param_string_length + + implicit none + + class(EDPftvarcon_type), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length) :: name + + !X! name = '' + !X! call fates_params%RetreiveParameter(name=name, & + !X! data=this%) + + name = 'fates_rootprof_beta' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%rootprof_beta) + + end subroutine Receive_PFT_nvariants + +end module EDPftvarcon + diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 new file mode 100644 index 00000000..785e6cbd --- /dev/null +++ b/main/EDTypesMod.F90 @@ -0,0 +1,740 @@ +module EDTypesMod + + use FatesConstantsMod , only : r8 => fates_r8 + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + + use FatesHydraulicsMemMod, only : ed_cohort_hydr_type + use FatesHydraulicsMemMod, only : ed_patch_hydr_type + use FatesHydraulicsMemMod, only : ed_site_hydr_type + + implicit none + save + + integer, parameter :: maxPatchesPerSite = 10 ! maximum number of patches to live on a site + integer, parameter :: maxCohortsPerPatch = 160 ! maximum number of cohorts to live on a patch + integer, parameter :: nclmax = 2 ! Maximum number of canopy layers + integer, parameter :: ican_upper = 1 ! Nominal index for the upper canopy + integer, parameter :: ican_ustory = 2 ! Nominal index for understory in two-canopy system + + integer, parameter :: nlevleaf = 40 ! number of leaf layers in canopy layer + integer, parameter :: maxpft = 10 ! maximum number of PFTs allowed + ! the parameter file may determine that fewer + ! are used, but this helps allocate scratch + ! space and output arrays. + + integer, parameter :: numpft_ed = 2 ! number of PFTs used in ED. + + ! TODO: we use this cp_maxSWb only because we have a static array q(size=2) of + ! land-ice abledo for vis and nir. This should be a parameter, which would + ! get us on track to start using multi-spectral or hyper-spectral (RGK 02-2017) + integer, parameter :: maxSWb = 2 ! maximum number of broad-bands in the + ! shortwave spectrum cp_numSWb <= cp_maxSWb + ! this is just for scratch-array purposes + ! if cp_numSWb is larger than this value + ! simply bump this number up as needed + + integer, parameter :: ivis = 1 ! This is the array index for short-wave + ! radiation in the visible spectrum, as expected + ! in boundary condition files and parameter + ! files. This will be compared with + ! the HLM's expectation in FatesInterfaceMod + integer, parameter :: inir = 2 ! This is the array index for short-wave + ! radiation in the near-infrared spectrum, as expected + ! in boundary condition files and parameter + ! files. This will be compared with + ! the HLM's expectation in FatesInterfaceMod + + ! Module switches (this will be read in one day) + ! This variable only exists now to serve as a place holder + !!!!!!!!!! THIS SHOULD NOT BE SET TO TRUE !!!!!!!!!!!!!!!!! + logical,parameter :: use_fates_plant_hydro = .false. + + + ! Switches that turn on/off ED dynamics process (names are self explanatory) + ! IMPORTANT NOTE!!! THESE SWITCHES ARE EXPERIMENTAL. + ! THEY SHOULD CORRECTLY TURN OFF OR ON THE PROCESS, BUT.. THERE ARE VARIOUS + ! ASPECTS REGARDING DIAGNOSING RATES AND HOW THEY ARE REPORTED WHEN THESE + ! PROCESSES ARE OFF THAT NEED TO BE DISCUSSED AND CONSIDERED. + ! TO-DO: THESE SHOULD BE PARAMETERS IN THE FILE OR NAMELIST - ADDING THESE + ! WAS OUTSIDE THE SCOPE OF THE VERY LARGE CHANGESET WHERE THESE WERE FIRST + ! INTRODUCED (RGK 03-2017) + logical, parameter :: do_ed_phenology = .true. + logical, parameter :: do_ed_dynamics = .true. + + + ! MODEL PARAMETERS + real(r8), parameter :: AREA = 10000.0_r8 ! Notional area of simulated forest m2 + real(r8), parameter :: AREA_INV = 1.0e-4_r8 ! Inverse of the notion area (faster math) + + integer, parameter :: numWaterMem = 10 ! watermemory saved as site level var + + ! BIOLOGY/BIOGEOCHEMISTRY + integer , parameter :: external_recruitment = 0 ! external recruitment flag 1=yes + integer , parameter :: SENES = 10 ! Window of time over which we track temp for cold sensecence (days) + real(r8), parameter :: DINC_ED = 1.0_r8 ! size of LAI bins. + integer , parameter :: N_DIST_TYPES = 2 ! number of disturbance types (mortality, fire) + + + ! SPITFIRE + integer, parameter :: NCWD = 4 ! number of coarse woody debris pools + integer , parameter :: NFSC = NCWD+2 ! number fuel size classes (really this is a mix of cwd size classes, leaf litter, and grass types) + integer, parameter :: lg_sf = 6 ! array index of live grass pool for spitfire + integer, parameter :: dl_sf = 1 ! array index of dead leaf pool for spitfire (dead grass and dead leaves) + integer, parameter :: tw_sf = 2 ! array index of twig pool for spitfire + integer, parameter :: tr_sf = 5 ! array index of dead trunk pool for spitfire + integer, parameter :: lb_sf = 4 ! array index of large branch pool for spitfire + real(r8), parameter :: fire_threshold = 35.0_r8 ! threshold for fires that spread or go out. KWm-2 + + ! PATCH FUSION + real(r8), parameter :: NTOL = 0.05_r8 ! min plant density for hgt bin to be used in height profile comparisons + real(r8), parameter :: HITEMAX = 30.0_r8 ! max dbh value used in hgt profile comparison + real(r8), parameter :: DBHMAX = 150.0_r8 ! max dbh value used in hgt profile comparison + integer , parameter :: N_HITE_BINS = 60 ! no. of hite bins used to distribute LAI + integer , parameter :: N_DBH_BINS = 5 ! no. of dbh bins used when comparing patches + + + real(r8), parameter :: min_npm2 = 1.0E-8_r8 ! minimum cohort number density per m2 before termination + real(r8), parameter :: min_patch_area = 0.001_r8 ! smallest allowable patch area before termination + real(r8), parameter :: min_nppatch = 1.0E-11_r8 ! minimum number of cohorts per patch (min_npm2*min_patch_area) + real(r8), parameter :: min_n_safemath = 1.0E-15_r8 ! in some cases, we want to immediately remove super small + ! number densities of cohorts to prevent FPEs, this is usually + ! just relevant in the first day after recruitment + character*4 yearchar + + ! special mode to cause PFTs to create seed mass of all currently-existing PFTs + logical, parameter :: homogenize_seed_pfts = .false. + + !the lower limit of the size classes of ED cohorts + !0-10,10-20... + integer, parameter :: nlevsclass_ed = 13 ! Number of dbh size classes for size structure analysis + ! |0-1,1-2,2-3,3-4,4-5,5-10,10-20,20-30,30-40,40-50,50-60,60-70,70-80,80-90,90-100,100+| +! real(r8), parameter, dimension(16) :: sclass_ed = (/0.0_r8,1.0_r8,2.0_r8,3.0_r8,4.0_r8,5.0_r8,10.0_r8,20.0_r8,30.0_r8,40.0_r8, & +! 50.0_r8,60.0_r8,70.0_r8,80.0_r8,90.0_r8,100.0_r8/) + + real(r8), parameter, dimension(nlevsclass_ed) :: sclass_ed = (/0.0_r8,5.0_r8,10.0_r8,15.0_r8,20.0_r8,30.0_r8,40.0_r8, & + 50.0_r8,60.0_r8,70.0_r8,80.0_r8,90.0_r8,100.0_r8/) + + integer, parameter :: nlevage_ed = 7 ! Number of patch-age classes for age structured analyses + real(r8), parameter, dimension(nlevage_ed) :: ageclass_ed = (/0.0_r8,1.0_r8,2._r8,5.0_r8,10.0_r8,20.0_r8,50.0_r8/) + + + ! integer, parameter :: nlevsclass_ed = 17 + ! real(r8), parameter, dimension(17) :: sclass_ed = (/0.1_r8, 5.0_r8,10.0_r8,15.0_r8,20.0_r8,25.0_r8, & + ! 30.0_r8,35.0_r8,40.0_r8,45.0_r8,50.0_r8,55.0_r8, & + ! 60.0_r8,65.0_r8,70.0_r8,75.0_r8,80.0_r8/) + + integer, parameter :: nlevmclass_ed = 5 ! nlev "mortality" classes in ED + ! Number of ways to die + ! (background,hydraulic,carbon,impact,fire) + + character(len = 10), parameter,dimension(nlevmclass_ed) :: char_list = & + (/"background","hydraulic ","carbon ","impact ","fire "/) + + + ! ------------------------------------------------------------------------------------- + ! These vectors are used for history output mapping + ! CLM/ALM have limited support for multi-dimensional history output arrays. + ! FATES structure and composition is multi-dimensional, so we end up "multi-plexing" + ! multiple dimensions into one dimension. These new dimensions need definitions, + ! mapping to component dimensions, and definitions for those component dimensions as + ! well. + ! ------------------------------------------------------------------------------------- + + real(r8) ,allocatable :: fates_hdim_levsclass(:) ! plant size class lower bound dimension + integer , allocatable :: fates_hdim_pfmap_levscpf(:) ! map of pfts into size-class x pft dimension + integer , allocatable :: fates_hdim_scmap_levscpf(:) ! map of size-class into size-class x pft dimension + real(r8), allocatable :: fates_hdim_levage(:) ! patch age lower bound dimension + integer , allocatable :: fates_hdim_levpft(:) ! plant pft dimension + integer , allocatable :: fates_hdim_levfuel(:) ! fire fuel class dimension + integer , allocatable :: fates_hdim_levcwdsc(:) ! cwd class dimension + integer , allocatable :: fates_hdim_levcan(:) ! canopy-layer dimension + integer , allocatable :: fates_hdim_canmap_levcnlf(:) ! canopy-layer map into the canopy-layer x leaf-layer dimension + integer , allocatable :: fates_hdim_lfmap_levcnlf(:) ! leaf-layer map into the canopy-layer x leaf-layer dimension + integer , allocatable :: fates_hdim_canmap_levcnlfpf(:) ! canopy-layer map into the canopy-layer x pft x leaf-layer dimension + integer , allocatable :: fates_hdim_lfmap_levcnlfpf(:) ! leaf-layer map into the canopy-layer x pft x leaf-layer dimension + integer , allocatable :: fates_hdim_pftmap_levcnlfpf(:) ! pft map into the canopy-layer x pft x leaf-layer dimension + integer , allocatable :: fates_hdim_scmap_levscag(:) ! map of size-class into size-class x patch age dimension + integer , allocatable :: fates_hdim_agmap_levscag(:) ! map of patch-age into size-class x patch age dimension + + !************************************ + !** COHORT type structure ** + !************************************ + type ed_cohort_type + + ! POINTERS + type (ed_cohort_type) , pointer :: taller => null() ! pointer to next tallest cohort + type (ed_cohort_type) , pointer :: shorter => null() ! pointer to next shorter cohort + type (ed_patch_type) , pointer :: patchptr => null() ! pointer to patch that cohort is in + type (ed_site_type) , pointer :: siteptr => null() ! pointer to site that cohort is in + + ! VEGETATION STRUCTURE + integer :: pft ! pft number + real(r8) :: n ! number of individuals in cohort per 'area' (10000m2 default) + real(r8) :: dbh ! dbh: cm + real(r8) :: hite ! height: meters + integer :: indexnumber ! unique number for each cohort. (within clump?) + real(r8) :: balive ! total living biomass: kGC per indiv + real(r8) :: bdead ! dead biomass: kGC per indiv + real(r8) :: bstore ! stored carbon: kGC per indiv + real(r8) :: laimemory ! target leaf biomass- set from previous year: kGC per indiv + integer :: canopy_layer ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) + real(r8) :: canopy_layer_yesterday ! recent canopy status of cohort (1 = canopy, 2 = understorey, etc.) real to be conservative during fusion + real(r8) :: b ! total biomass: kGC per indiv + real(r8) :: bsw ! sapwood in stem and roots: kGC per indiv + real(r8) :: bl ! leaf biomass: kGC per indiv + real(r8) :: br ! fine root biomass: kGC per indiv + real(r8) :: lai ! leaf area index of cohort m2/m2 + real(r8) :: sai ! stem area index of cohort m2/m2 + real(r8) :: gscan ! Stomatal resistance of cohort. + real(r8) :: canopy_trim ! What is the fraction of the maximum leaf biomass that we are targeting? :- + real(r8) :: leaf_cost ! How much does it cost to maintain leaves: kgC/m2/year-1 + real(r8) :: excl_weight ! How much of this cohort is demoted each year, as a proportion of all cohorts:- + real(r8) :: prom_weight ! How much of this cohort is promoted each year, as a proportion of all cohorts:- + integer :: nv ! Number of leaf layers: - + integer :: status_coh ! growth status of plant (2 = leaves on , 1 = leaves off) + real(r8) :: c_area ! areal extent of canopy (m2) + real(r8) :: treelai ! lai of tree (total leaf area (m2) / canopy area (m2) + real(r8) :: treesai ! stem area index of tree (total stem area (m2) / canopy area (m2) + logical :: isnew ! flag to signify a new cohort, new cohorts have not experienced + ! npp or mortality and should therefore not be fused or averaged + integer :: size_class ! An index that indicates which diameter size bin the cohort currently resides in + ! this is used for history output. We maintain this in the main cohort memory + ! because we don't want to continually re-calculate the cohort's position when + ! performing size diagnostics at high-frequency calls + integer :: size_by_pft_class ! An index that indicates the cohorts position of the joint size-class x functional + ! type classification. We also maintain this in the main cohort memory + ! because we don't want to continually re-calculate the cohort's position when + ! performing size diagnostics at high-frequency calls + + + ! CARBON FLUXES + + ! ---------------------------------------------------------------------------------- + ! NPP, GPP and RESP: Instantaneous, accumulated and accumulated-hold types.* + ! + ! _tstep: The instantaneous estimate that is calculated at each rapid plant biophysics + ! time-step (ie photosynthesis, sub-hourly). (kgC/indiv/timestep) + ! _acc: The accumulation of the _tstep variable from the beginning to ending of + ! the dynamics time-scale. This variable is zero'd during initialization and + ! after the dynamics call-sequence is completed. (kgC/indiv/day) + ! _acc_hold: While _acc is zero'd after the dynamics call sequence and then integrated, + ! _acc_hold "holds" the integrated value until the next time dynamics is + ! called. This is necessary for restarts. This variable also has units + ! converted to a useful rate (kgC/indiv/yr) + ! ---------------------------------------------------------------------------------- + + real(r8) :: gpp_tstep ! Gross Primary Production (see above *) + real(r8) :: gpp_acc + real(r8) :: gpp_acc_hold + + real(r8) :: npp_tstep ! Net Primary Production (see above *) + real(r8) :: npp_acc + real(r8) :: npp_acc_hold + + real(r8) :: resp_tstep ! Autotrophic respiration (see above *) + real(r8) :: resp_acc + real(r8) :: resp_acc_hold + + ! Net Primary Production Partitions + + real(r8) :: npp_leaf ! NPP into leaves (includes replacement of turnover): KgC/indiv/year + real(r8) :: npp_froot ! NPP into fine roots (includes replacement of turnover): KgC/indiv/year + + real(r8) :: npp_bsw ! NPP into sapwood: KgC/indiv/year + real(r8) :: npp_bdead ! NPP into deadwood (structure): KgC/indiv/year + real(r8) :: npp_bseed ! NPP into seeds: KgC/indiv/year + real(r8) :: npp_store ! NPP into storage: KgC/indiv/year + + real(r8) :: ts_net_uptake(nlevleaf) ! Net uptake of leaf layers: kgC/m2/s + real(r8) :: year_net_uptake(nlevleaf) ! Net uptake of leaf layers: kgC/m2/year + + ! RESPIRATION COMPONENTS + real(r8) :: rdark ! Dark respiration: kgC/indiv/s + real(r8) :: resp_g ! Growth respiration: kgC/indiv/timestep + real(r8) :: resp_m ! Maintenance respiration: kgC/indiv/timestep + real(r8) :: livestem_mr ! Live stem maintenance respiration: kgC/indiv/s + ! (Above ground) + real(r8) :: livecroot_mr ! Live stem maintenance respiration: kgC/indiv/s + ! (below ground) + real(r8) :: froot_mr ! Live fine root maintenance respiration: kgC/indiv/s + + ! ALLOCATION + real(r8) :: md ! plant maintenance demand: kgC/indiv/year + real(r8) :: leaf_md ! leaf maintenance demand: kgC/indiv/year + real(r8) :: root_md ! root maintenance demand: kgC/indiv/year + real(r8) :: carbon_balance ! carbon remaining for growth and storage: kg/indiv/year + real(r8) :: seed_prod ! reproduction seed and clonal: KgC/indiv/year + real(r8) :: leaf_litter ! leaf litter from phenology: KgC/m2 + real(r8) :: woody_turnover ! amount of wood lost each day: kgC/indiv/year. Currently set to zero. + + !MORTALITY + real(r8) :: dmort ! proportional mortality rate. (year-1) + + ! Mortality Rate Partitions + real(r8) :: bmort ! background mortality rate n/year + real(r8) :: cmort ! carbon starvation mortality rate n/year + real(r8) :: hmort ! hydraulic failure mortality rate n/year + real(r8) :: imort ! mortality from impacts by others n/year + real(r8) :: fmort ! fire mortality n/year + + ! NITROGEN POOLS + ! ---------------------------------------------------------------------------------- + ! Nitrogen pools are not prognostic in the current implementation. + ! They are diagnosed during photosynthesis using a simple C2N parameter. Local values + ! used in that routine. + ! ---------------------------------------------------------------------------------- + + ! GROWTH DERIVIATIVES + real(r8) :: dndt ! time derivative of cohort size : n/year + real(r8) :: dhdt ! time derivative of height : m/year + real(r8) :: ddbhdt ! time derivative of dbh : cm/year + real(r8) :: dbalivedt ! time derivative of total living biomass : KgC/year + real(r8) :: dbdeaddt ! time derivative of dead biomass : KgC/year + real(r8) :: dbstoredt ! time derivative of stored biomass : KgC/year + real(r8) :: storage_flux ! flux from npp into bstore : KgC/year + + ! FIRE + real(r8) :: cfa ! proportion of crown affected by fire:- + real(r8) :: cambial_mort ! probability that trees dies due to cambial char:- + real(r8) :: crownfire_mort ! probability of tree post-fire mortality due to crown scorch:- + real(r8) :: fire_mort ! post-fire mortality from cambial and crown damage assuming two are independent:- + + ! Hydraulics + type(ed_cohort_hydr_type), pointer :: co_hydr ! All cohort hydraulics data, see FatesHydraulicsMemMod.F90 + + + end type ed_cohort_type + + !************************************ + !** Patch type structure ** + !************************************ + + type ed_patch_type + + ! POINTERS + type (ed_cohort_type), pointer :: tallest => null() ! pointer to patch's tallest cohort + type (ed_cohort_type), pointer :: shortest => null() ! pointer to patch's shortest cohort + type (ed_patch_type), pointer :: older => null() ! pointer to next older patch + type (ed_patch_type), pointer :: younger => null() ! pointer to next younger patch + type (ed_site_type), pointer :: siteptr => null() ! pointer to the site that the patch is in + + !INDICES + integer :: patchno ! unique number given to each new patch created for tracking + + ! PATCH INFO + real(r8) :: age ! average patch age: years + integer :: age_class ! age class of the patch for history binning purposes + real(r8) :: area ! patch area: m2 + integer :: countcohorts ! Number of cohorts in patch + integer :: ncl_p ! Number of occupied canopy layers + + ! LEAF ORGANIZATION + real(r8) :: spread(nclmax) ! dynamic ratio of dbh to canopy area: cm/m2 + real(r8) :: pft_agb_profile(numpft_ed,n_dbh_bins) ! binned above ground biomass, for patch fusion: KgC/m2 + real(r8) :: canopy_layer_lai(nclmax) ! lai that is shading this canopy layer: m2/m2 + real(r8) :: total_canopy_area ! area that is covered by vegetation : m2 + real(r8) :: total_tree_area ! area that is covered by woody vegetation : m2 + real(r8) :: canopy_area ! area that is covered by vegetation : m2 (is this different to total_canopy_area? + real(r8) :: bare_frac_area ! bare soil in this patch expressed as a fraction of the total soil surface. + real(r8) :: lai ! leaf area index of patch + + real(r8) :: tlai_profile(nclmax,numpft_ed,nlevleaf) ! total leaf area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: elai_profile(nclmax,numpft_ed,nlevleaf) ! exposed leaf area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: tsai_profile(nclmax,numpft_ed,nlevleaf) ! total stem area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: esai_profile(nclmax,numpft_ed,nlevleaf) ! exposed stem area in each canopy layer, pft, and leaf layer. m2/m2 + real(r8) :: layer_height_profile(nclmax,numpft_ed,nlevleaf) + real(r8) :: canopy_area_profile(nclmax,numpft_ed,nlevleaf) ! fraction of canopy in each canopy + ! layer, pft, and leaf layer:- + integer :: present(nclmax,numpft_ed) ! is there any of this pft in this canopy layer? + integer :: nrad(nclmax,numpft_ed) ! number of exposed leaf layers for each canopy layer and pft + integer :: ncan(nclmax,numpft_ed) ! number of total leaf layers for each canopy layer and pft + + !RADIATION FLUXES + real(r8) :: fabd_sun_z(nclmax,numpft_ed,nlevleaf) ! sun fraction of direct light absorbed by each canopy + ! layer, pft, and leaf layer:- + real(r8) :: fabd_sha_z(nclmax,numpft_ed,nlevleaf) ! shade fraction of direct light absorbed by each canopy + ! layer, pft, and leaf layer:- + real(r8) :: fabi_sun_z(nclmax,numpft_ed,nlevleaf) ! sun fraction of indirect light absorbed by each canopy + ! layer, pft, and leaf layer:- + real(r8) :: fabi_sha_z(nclmax,numpft_ed,nlevleaf) ! shade fraction of indirect light absorbed by each canopy + ! layer, pft, and leaf layer:- + + real(r8) :: ed_laisun_z(nclmax,numpft_ed,nlevleaf) ! amount of LAI in the sun in each canopy layer, + ! pft, and leaf layer. m2/m2 + real(r8) :: ed_laisha_z(nclmax,numpft_ed,nlevleaf) ! amount of LAI in the shade in each canopy layer, + real(r8) :: ed_parsun_z(nclmax,numpft_ed,nlevleaf) ! PAR absorbed in the sun in each canopy layer, + real(r8) :: ed_parsha_z(nclmax,numpft_ed,nlevleaf) ! PAR absorbed in the shade in each canopy layer, + real(r8) :: f_sun(nclmax,numpft_ed,nlevleaf) ! fraction of leaves in the sun in each canopy layer, pft, + + ! and leaf layer. m2/m2 + real(r8),allocatable :: tr_soil_dir(:) ! fraction of incoming direct radiation that (cm_numSWb) + ! is transmitted to the soil as direct + real(r8),allocatable :: tr_soil_dif(:) ! fraction of incoming diffuse radiation that + ! is transmitted to the soil as diffuse + real(r8),allocatable :: tr_soil_dir_dif(:) ! fraction of incoming direct radiation that + ! is transmitted to the soil as diffuse + real(r8),allocatable :: fab(:) ! fraction of incoming total radiation that is absorbed by the canopy + real(r8),allocatable :: fabd(:) ! fraction of incoming direct radiation that is absorbed by the canopy + real(r8),allocatable :: fabi(:) ! fraction of incoming diffuse radiation that is absorbed by the canopy + real(r8),allocatable :: sabs_dir(:) ! fraction of incoming direct radiation that is absorbed by the canopy + real(r8),allocatable :: sabs_dif(:) ! fraction of incoming diffuse radiation that is absorbed by the canopy + + + !SEED BANK + real(r8) :: seeds_in(numpft_ed) ! seed production KgC/m2/year + real(r8) :: seed_decay(numpft_ed) ! seed decay in KgC/m2/year + real(r8) :: seed_germination(numpft_ed) ! germination rate of seed pool in KgC/m2/year + + ! PHOTOSYNTHESIS + + real(r8) :: psn_z(nclmax,numpft_ed,nlevleaf) ! carbon assimilation in each canopy layer, pft, and leaf layer. umolC/m2/s +! real(r8) :: gpp ! total patch gpp: KgC/m2/year +! real(r8) :: npp ! total patch npp: KgC/m2/year + + ! ROOTS + real(r8), allocatable :: rootfr_ft(:,:) ! root fraction of each PFT in each soil layer:- + real(r8), allocatable :: rootr_ft(:,:) ! fraction of water taken from each PFT and soil layer:- + real(r8) :: btran_ft(numpft_ed) ! btran calculated seperately for each PFT:- + + ! DISTURBANCE + real(r8) :: disturbance_rates(n_dist_types) ! disturbance rate from 1) mortality and 2) fire: fraction/day + real(r8) :: disturbance_rate ! larger effective disturbance rate: fraction/day + + ! LITTER AND COARSE WOODY DEBRIS + ! Pools of litter (non respiring) + real(r8) :: cwd_ag(ncwd) ! above ground coarse wood debris litter that does not respire. KgC/m2 + real(r8) :: cwd_bg(ncwd) ! below ground coarse wood debris litter that does not respire. KgC/m2 + real(r8) :: leaf_litter(numpft_ed) ! above ground leaf litter that does not respire. KgC/m2 + real(r8) :: root_litter(numpft_ed) ! below ground fine root litter that does not respire. KgC/m2 + + ! Fluxes of litter (non respiring) + real(r8) :: fragmentation_scaler ! Scale rate of litter fragmentation. 0 to 1. + real(r8) :: cwd_ag_in(ncwd) ! Flux into CWD_AG from turnover and mortality KgC/m2/y + real(r8) :: cwd_bg_in(ncwd) ! Flux into cwd_bg from root turnover and mortality KgC/m2/y + real(r8) :: cwd_ag_out(ncwd) ! Flux out of AG CWD into AG litter KgC/m2/y + real(r8) :: cwd_bg_out(ncwd) ! Flux out of BG CWD into BG litter KgC/m2/ + + + real(r8) :: leaf_litter_in(numpft_ed) ! Flux in to AG leaf litter from leaf turnover and mortality KgC/m2/y + real(r8) :: leaf_litter_out(numpft_ed) ! Flux out of AG leaf litter from fragmentation KgC/m2/y + real(r8) :: root_litter_in(numpft_ed) ! Flux in to BG root litter from leaf turnover and mortality KgC/m2/y + real(r8) :: root_litter_out(numpft_ed) ! Flux out of BG root from fragmentation KgC/m2/y + + ! Derivatives of litter (non respiring) + real(r8) :: dcwd_AG_dt(ncwd) ! rate of change of above ground CWD in each size class: KgC/m2/year. + real(r8) :: dcwd_BG_dt(ncwd) ! rate of change of below ground CWD in each size class: KgC/m2/year. + real(r8) :: dleaf_litter_dt(numpft_ed) ! rate of change of leaf litter in each size class: KgC/m2/year. + real(r8) :: droot_litter_dt(numpft_ed) ! rate of change of root litter in each size class: KgC/m2/year. + + real(r8) :: repro(numpft_ed) ! allocation to reproduction per PFT : KgC/m2 + + !FUEL CHARECTERISTICS + real(r8) :: sum_fuel ! total ground fuel related to ros (omits 1000hr fuels): KgC/m2 + real(r8) :: fuel_frac(nfsc) ! fraction of each litter class in the ros_fuel:-. + real(r8) :: livegrass ! total aboveground grass biomass in patch. KgC/m2 + real(r8) :: fuel_bulkd ! average fuel bulk density of the ground fuel + ! (incl. live grasses. omits 1000hr fuels). KgC/m3 + real(r8) :: fuel_sav ! average surface area to volume ratio of the ground fuel + ! (incl. live grasses. omits 1000hr fuels). + real(r8) :: fuel_mef ! average moisture of extinction factor + ! of the ground fuel (incl. live grasses. omits 1000hr fuels). + real(r8) :: fuel_eff_moist ! effective avearage fuel moisture content of the ground fuel + ! (incl. live grasses. omits 1000hr fuels) + real(r8) :: litter_moisture(nfsc) + + ! FIRE SPREAD + real(r8) :: ros_front ! rate of forward spread of fire: m/min + real(r8) :: ros_back ! rate of backward spread of fire: m/min + real(r8) :: effect_wspeed ! windspeed modified by fraction of relative grass and tree cover: m/min + real(r8) :: tau_l ! Duration of lethal heating: mins + real(r8) :: fi ! average fire intensity of flaming front: kj/m/s or kw/m + integer :: fire ! Is there a fire? 1=yes 0=no + real(r8) :: fd ! fire duration: mins + real(r8) :: nf ! number of fires initiated daily: n/gridcell/day + real(r8) :: sh ! average scorch height: m + + ! FIRE EFFECTS + real(r8) :: ab ! area burnt: m2/day + real(r8) :: frac_burnt ! fraction burnt: frac gridcell/day + real(r8) :: tfc_ros ! total fuel consumed - no trunks. KgC/m2/day + real(r8) :: burnt_frac_litter(nfsc) ! fraction of each litter pool burned:- + + ! PLANT HYDRAULICS + type(ed_patch_hydr_type) , pointer :: pa_hydr ! All patch hydraulics data, see FatesHydraulicsMemMod.F90 + + contains + + end type ed_patch_type + + !************************************ + !** Site type structure ** + !************************************ + + type ed_site_type + + ! POINTERS + type (ed_patch_type), pointer :: oldest_patch => null() ! pointer to oldest patch at the site + type (ed_patch_type), pointer :: youngest_patch => null() ! pointer to yngest patch at the site + + ! INDICES + real(r8) :: lat ! latitude: degrees + real(r8) :: lon ! longitude: degrees + + ! CARBON BALANCE + real(r8) :: flux_in ! for carbon balance purpose. C coming into biomass pool: KgC/site + real(r8) :: flux_out ! for carbon balance purpose. C leaving ED pools KgC/site + real(r8) :: old_stock ! for accounting purposes, remember biomass stock from last time: KgC/site + real(r8) :: npp ! used for calculating NEP and NBP during BGC summarization phase + real(r8) :: nep ! Net ecosystem production, i.e. fast-timescale carbon balance that + ! does not include disturbance [gC/m2/s] + real(r8) :: nbp ! Net biosphere production, i.e. slow-timescale carbon balance that + ! integrates to total carbon change [gC/m2/s] + real(r8) :: tot_seed_rain_flux ! [gC/m2/s] total flux of carbon from seed rain + real(r8) :: fire_c_to_atm ! total fire carbon loss to atmosphere [gC/m2/s] + real(r8) :: ed_litter_stock ! litter in [gC/m2] + real(r8) :: cwd_stock ! coarse woody debris [gC/m2] + real(r8) :: biomass_stock ! total biomass at the column level in [gC / m2] + real(r8) :: totfatesc ! Total FATES carbon at the site, including vegetation, CWD, seeds, + ! and FATES portion of litter [gC/m2] + real(r8) :: totbgcc ! Total BGC carbon at the site, including litter, and soil pools [gC/m2] + real(r8) :: totecosysc ! Total ecosystem C at the site, including vegetation, + ! CWD, litter (from HLM and FATES), and soil pools [gC/m2] + + real(r8) :: totfatesc_old ! Total FATES C at the site from last call to balance check [gC/m2] + real(r8) :: totbgcc_old ! Total BGC C at the site from last call to balance check [gC/m2] + real(r8) :: totecosysc_old ! Total ecosystem C at the site from last call to balance check [gC/m2] + + real(r8) :: fates_to_bgc_this_ts ! total flux of carbon from FATES to BGC models on current timestep [gC/m2/s] + real(r8) :: fates_to_bgc_last_ts ! total flux of carbon from FATES to BGC models on previous timestep [gC/m2/s] + + real(r8) :: cbal_err_fates ! [gC/m2/s] total carbon balance error for FATES processes + real(r8) :: cbal_err_bgc ! [gC/m2/s] total carbon balance error for BGC (HLM) processes + real(r8) :: cbal_err_tot ! [gC/m2/s] total carbon balance error for all land processes + + real(r8) :: nep_timeintegrated ! Net ecosystem production accumulated over model time-steps [gC/m2] + real(r8) :: hr_timeintegrated ! Heterotrophic respiration accumulated over model time-steps [gC/m2] + real(r8) :: npp_timeintegrated ! Net primary production accumulated over model time-steps [gC/m2] + real(r8) :: nbp_integrated ! Net biosphere production accumulated over model time-steps [gC/m2] + + + ! DISTURBANCE + real(r8) :: disturbance_mortality ! site level disturbance rates from mortality. + real(r8) :: disturbance_fire ! site level disturbance rates from fire. + integer :: dist_type ! disturbance dist_type id. + real(r8) :: disturbance_rate ! site total dist rate + + ! PHENOLOGY + real(r8) :: ED_GDD_site ! ED Phenology growing degree days. + integer :: status ! are leaves in this pixel on or off for cold decid + integer :: dstatus ! are leaves in this pixel on or off for drought decid + real(r8) :: ncd ! no chilling days:- + real(r8) :: last_n_days(senes) ! record of last 10 days temperature for senescence model. deg C + integer :: leafondate ! doy of leaf on:- + integer :: leafoffdate ! doy of leaf off:- + integer :: dleafondate ! doy of leaf on drought:- + integer :: dleafoffdate ! doy of leaf on drought:- + real(r8) :: water_memory(numWaterMem) ! last 10 days of soil moisture memory... + + !SEED BANK + real(r8) :: seed_bank(numpft_ed) ! seed pool in KgC/m2/year + real(r8) :: dseed_dt(numpft_ed) + real(r8) :: seed_rain_flux(numpft_ed) ! flux of seeds from exterior KgC/m2/year (needed for C balance purposes) + + ! FIRE + real(r8) :: acc_ni ! daily nesterov index accumulating over time. + real(r8) :: ab ! daily burnt area: m2 + real(r8) :: frac_burnt ! fraction of soil burnt in this day. + real(r8) :: total_burn_flux_to_atm ! total carbon burnt to the atmosphere in this day. KgC/site + real(r8) :: cwd_ag_burned(ncwd) + real(r8) :: leaf_litter_burned(numpft_ed) + + ! PLANT HYDRAULICS + type(ed_site_hydr_type), pointer :: si_hydr + + ! TERMINATION, RECRUITMENT, DEMOTION, and DISTURBANCE + + real(r8) :: terminated_nindivs(1:nlevsclass_ed,1:maxpft,2) ! number of individuals that were in cohorts which were terminated this timestep, on size x pft x canopy array. + real(r8) :: termination_carbonflux(2) ! carbon flux from live to dead pools associated with termination mortality, per canopy level + real(r8) :: recruitment_rate(1:maxpft) ! number of individuals that were recruited into new cohorts + real(r8) :: demotion_rate(1:nlevsclass_ed) ! rate of individuals demoted from canopy to understory per FATES timestep + real(r8) :: demotion_carbonflux ! biomass of demoted individuals from canopy to understory [kgC/ha/day] + real(r8) :: promotion_rate(1:nlevsclass_ed) ! rate of individuals promoted from understory to canopy per FATES timestep + real(r8) :: promotion_carbonflux ! biomass of promoted individuals from understory to canopy [kgC/ha/day] + + ! some diagnostic-only (i.e. not resolved by ODE solver) flux of carbon to CWD and litter pools from termination and canopy mortality + real(r8) :: CWD_AG_diagnostic_input_carbonflux(1:ncwd) ! diagnostic flux to AG CWD [kg C / m2 / yr] + real(r8) :: CWD_BG_diagnostic_input_carbonflux(1:ncwd) ! diagnostic flux to BG CWD [kg C / m2 / yr] + real(r8) :: leaf_litter_diagnostic_input_carbonflux(1:maxpft) ! diagnostic flux to AG litter [kg C / m2 / yr] + real(r8) :: root_litter_diagnostic_input_carbonflux(1:maxpft) ! diagnostic flux to BG litter [kg C / m2 / yr] + + end type ed_site_type + + public :: ed_hist_scpfmaps + +contains + + + !-------------------------------------------------------------------------------------! + subroutine ed_hist_scpfmaps + ! This subroutine allocates and populates the variables + ! that define the mapping of variables in history files in the "scpf" format + ! back to + ! its respective size-class "sc" and pft "pf" + + integer :: i + integer :: isc + integer :: ipft + integer :: icwd + integer :: ifuel + integer :: ican + integer :: ileaf + integer :: iage + + allocate( fates_hdim_levsclass(1:nlevsclass_ed )) + allocate( fates_hdim_pfmap_levscpf(1:nlevsclass_ed*maxpft)) + allocate( fates_hdim_scmap_levscpf(1:nlevsclass_ed*maxpft)) + allocate( fates_hdim_levpft(1:maxpft )) + allocate( fates_hdim_levfuel(1:NFSC )) + allocate( fates_hdim_levcwdsc(1:NCWD )) + allocate( fates_hdim_levage(1:nlevage_ed )) + + allocate( fates_hdim_levcan(nclmax)) + allocate( fates_hdim_canmap_levcnlf(nlevleaf*nclmax)) + allocate( fates_hdim_lfmap_levcnlf(nlevleaf*nclmax)) + allocate( fates_hdim_canmap_levcnlfpf(nlevleaf*nclmax*numpft_ed)) + allocate( fates_hdim_lfmap_levcnlfpf(nlevleaf*nclmax*numpft_ed)) + allocate( fates_hdim_pftmap_levcnlfpf(nlevleaf*nclmax*numpft_ed)) + allocate( fates_hdim_scmap_levscag(nlevsclass_ed * nlevage_ed )) + allocate( fates_hdim_agmap_levscag(nlevsclass_ed * nlevage_ed )) + + ! Fill the IO array of plant size classes + ! For some reason the history files did not like + ! a hard allocation of sclass_ed + fates_hdim_levsclass(:) = sclass_ed(:) + + fates_hdim_levage(:) = ageclass_ed(:) + + ! make pft array + do ipft=1,maxpft + fates_hdim_levpft(ipft) = ipft + end do + + ! make fuel array + do ifuel=1,NFSC + fates_hdim_levfuel(ifuel) = ifuel + end do + + ! make cwd array + do icwd=1,NCWD + fates_hdim_levcwdsc(icwd) = icwd + end do + + ! make canopy array + do ican = 1,nclmax + fates_hdim_levcan(ican) = ican + end do + + ! Fill the IO arrays that match pft and size class to their combined array + i=0 + do ipft=1,maxpft + do isc=1,nlevsclass_ed + i=i+1 + fates_hdim_pfmap_levscpf(i) = ipft + fates_hdim_scmap_levscpf(i) = isc + end do + end do + + i=0 + do ican=1,nclmax + do ileaf=1,nlevleaf + i=i+1 + fates_hdim_canmap_levcnlf(i) = ican + fates_hdim_lfmap_levcnlf(i) = ileaf + end do + end do + + i=0 + do iage=1,nlevage_ed + do isc=1,nlevsclass_ed + i=i+1 + fates_hdim_scmap_levscag(i) = isc + fates_hdim_agmap_levscag(i) = iage + end do + end do + + i=0 + do ipft=1,numpft_ed + do ican=1,nclmax + do ileaf=1,nlevleaf + i=i+1 + fates_hdim_canmap_levcnlfpf(i) = ican + fates_hdim_lfmap_levcnlfpf(i) = ileaf + fates_hdim_pftmap_levcnlfpf(i) = ipft + end do + end do + end do + + end subroutine ed_hist_scpfmaps + + ! ===================================================================================== + + function get_age_class_index(age) result( patch_age_class ) + + real(r8), intent(in) :: age + + integer :: patch_age_class + + patch_age_class = count(age-ageclass_ed.ge.0.0_r8) + + end function get_age_class_index + + ! ===================================================================================== + + function get_sizeage_class_index(dbh,age) result(size_by_age_class) + + ! Arguments + real(r8),intent(in) :: dbh + real(r8),intent(in) :: age + + integer :: size_class + integer :: age_class + integer :: size_by_age_class + + size_class = get_size_class_index(dbh) + + age_class = get_age_class_index(age) + + size_by_age_class = (age_class-1)*nlevsclass_ed + size_class + + end function get_sizeage_class_index + + ! ===================================================================================== + + subroutine sizetype_class_index(dbh,pft,size_class,size_by_pft_class) + + ! Arguments + real(r8),intent(in) :: dbh + integer,intent(in) :: pft + integer,intent(out) :: size_class + integer,intent(out) :: size_by_pft_class + + size_class = get_size_class_index(dbh) + + size_by_pft_class = (pft-1)*nlevsclass_ed+size_class + + return + end subroutine sizetype_class_index + + ! ===================================================================================== + + function get_size_class_index(dbh) result(cohort_size_class) + + real(r8), intent(in) :: dbh + + integer :: cohort_size_class + + cohort_size_class = count(dbh-sclass_ed.ge.0.0_r8) + + end function get_size_class_index + +end module EDTypesMod diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 new file mode 100644 index 00000000..6170d6d6 --- /dev/null +++ b/main/FatesConstantsMod.F90 @@ -0,0 +1,98 @@ +module FatesConstantsMod + ! This module is used to define global _immutable_ data. Everything in + ! this module must have the parameter attribute. + + implicit none + + public + + ! kinds + integer, parameter :: fates_r8 = selected_real_kind(12) ! 8 byte real + + ! string lengths + integer, parameter :: fates_avg_flag_length = 3 + integer, parameter :: fates_short_string_length = 32 + integer, parameter :: fates_long_string_length = 199 + + ! Unset and various other 'special' values + integer, parameter :: fates_unset_int = -9999 + + + ! Integer equivalent of true (in case some compilers dont auto convert) + integer, parameter :: itrue = 1 + + ! Integer equivalent of false (in case come compilers dont auto convert) + integer, parameter :: ifalse = 0 + + + ! Unit conversion constants: + + ! Conversion factor umols of Carbon -> kg of Carbon (1 mol = 12g) + ! We do not use umolC_per_kg because it is a non-terminating decimal + real(fates_r8), parameter :: umolC_to_kgC = 12.0E-9_fates_r8 + + ! Conversion factor: grams per kilograms + real(fates_r8), parameter :: g_per_kg = 1000.0_fates_r8 + + ! Conversion factor: miligrams per grams + real(fates_r8), parameter :: mg_per_g = 1000.0_fates_r8 + + ! Conversion factor: micromoles per milimole + real(fates_r8), parameter :: umol_per_mmol = 1000.0_fates_r8 + + ! Conversion factor: milimoles per mole + real(fates_r8), parameter :: mmol_per_mol = 1000.0_fates_r8 + + ! Conversion factor: micromoles per mole + real(fates_r8), parameter :: umol_per_mol = 1.0E6_fates_r8 + + ! Conversion factor: m2 per ha + real(fates_r8), parameter :: m2_per_ha = 1.0e4_fates_r8 + + ! Conversion factor :: ha per m2 + real(fates_r8), parameter :: ha_per_m2 = 1.0e-4_fates_r8 + + ! Conversion: seconds per minute + real(fates_r8), parameter :: sec_per_min = 60.0_fates_r8 + + ! Conversion: seconds per day + real(fates_r8), parameter :: sec_per_day = 86400.0_fates_r8 + + ! Conversion: days per second + real(fates_r8), parameter :: days_per_sec = 1.0_fates_r8/86400.0_fates_r8 + + ! Conversion: days per year. assume HLM uses 365 day calendar. If we need to link to 365.25-day-calendared HLM, rewire to pass through interface + real(fates_r8), parameter :: days_per_year = 365.00_fates_r8 + + ! Conversion: years per day. assume HLM uses 365 day calendar. If we need to link to 365.25-day-calendared HLM, rewire to pass through interface + real(fates_r8), parameter :: years_per_day = 1.0_fates_r8/365.00_fates_r8 + + ! Physical constants + + ! universal gas constant [J/K/kmol] + real(fates_r8), parameter :: rgas_J_K_kmol = 8314.4598_fates_r8 + + ! freezing point of water at 1 atm (K) + real(fates_r8), parameter :: t_water_freeze_k_1atm = 273.15_fates_r8 + + ! freezing point of water at triple point (K) + real(fates_r8), parameter :: t_water_freeze_k_triple = 273.16_fates_r8 + + ! Density of fresh liquid water (kg/m3) + real(fates_r8), parameter :: dens_fresh_liquid_water = 1.0E3_fates_r8 + + ! Gravity constant on earth [m/s] + real(fates_r8), parameter :: grav_earth = 9.8_fates_r8 + + + ! For numerical inquiry + real(fates_r8), parameter :: fates_huge = huge(g_per_kg) + + real(fates_r8), parameter :: fates_tiny = tiny(g_per_kg) + + ! Geometric Constants + + ! PI + real(fates_r8), parameter :: pi_const = 3.14159265359_fates_r8 + +end module FatesConstantsMod diff --git a/main/FatesGlobals.F90 b/main/FatesGlobals.F90 new file mode 100644 index 00000000..3d4d561c --- /dev/null +++ b/main/FatesGlobals.F90 @@ -0,0 +1,70 @@ +module FatesGlobals + ! NOTE(bja, 201608) This is a temporary hack module to store global + ! data used inside fates. It's main use it to explicitly call out + ! global data that needs to be dealt with, but doesn't have an + ! immediately obvious home. + + use FatesConstantsMod , only : r8 => fates_r8 + + implicit none + + public :: FatesGlobalsInit + public :: fates_log + public :: fates_global_verbose + + integer, private :: fates_log_ + logical, private :: fates_global_verbose_ + +contains + + + + ! ===================================================================================== + + subroutine FatesGlobalsInit(log_unit,global_verbose) + + implicit none + + integer, intent(in) :: log_unit + logical, intent(in) :: global_verbose + + fates_log_ = log_unit + fates_global_verbose_ = global_verbose + + end subroutine FatesGlobalsInit + + ! ===================================================================================== + + integer function fates_log() + fates_log = fates_log_ + end function fates_log + + logical function fates_global_verbose() + fates_global_verbose = fates_global_verbose_ + end function fates_global_verbose + + subroutine fates_endrun(msg) + + !----------------------------------------------------------------------- + ! !DESCRIPTION: + ! Abort the model for abnormal termination + ! This subroutine was derived from CLM's + ! endrun_vanilla() in abortutils.F90 + ! + use shr_sys_mod , only: shr_sys_abort + ! + ! !ARGUMENTS: + implicit none + character(len=*), intent(in) :: msg ! string to be printed + !----------------------------------------------------------------------- + + write(fates_log(),*)'ENDRUN:', msg + call shr_sys_abort() + + end subroutine fates_endrun + + ! ===================================================================================== + + + +end module FatesGlobals diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 new file mode 100644 index 00000000..4d0a6a04 --- /dev/null +++ b/main/FatesHistoryInterfaceMod.F90 @@ -0,0 +1,3614 @@ +module FatesHistoryInterfaceMod + + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : fates_avg_flag_length, fates_short_string_length, fates_long_string_length + use FatesGlobals , only : fates_log + use FatesGlobals, only : endrun => fates_endrun + + use FatesIODimensionsMod, only : fates_io_dimension_type + use FatesIOVariableKindMod, only : fates_io_variable_kind_type + use FatesHistoryVariableType, only : fates_history_variable_type + use FatesInterfaceMod, only : hlm_hio_ignore_val + + ! FIXME(bja, 2016-10) need to remove CLM dependancy + use EDPftvarcon , only : EDPftvarcon_inst + + ! CIME Globals + use shr_log_mod , only : errMsg => shr_log_errMsg + use shr_infnan_mod , only : isnan => shr_infnan_isnan + use FatesConstantsMod, only : g_per_kg + use FatesConstantsMod, only : ha_per_m2 + use FatesConstantsMod, only : days_per_sec + use FatesConstantsMod, only : sec_per_day + use FatesConstantsMod, only : days_per_year + use FatesConstantsMod, only : years_per_day + + implicit none + + ! These variables hold the index of the history output structure so we don't + ! have to constantly do name lookup when we want to populate the dataset + ! These indices are set during "define_history_vars()" call to "set_history_var()" + ! during the initialize phase. Definitions are not provide, for an explanation of + ! the variable go to its registry. (IH_ signifies "index history") + + ! Indices to 1D Patch variables + + integer, private :: ih_trimming_pa + integer, private :: ih_area_plant_pa + integer, private :: ih_area_treespread_pa + integer, private :: ih_canopy_spread_pa + integer, private :: ih_nesterov_fire_danger_pa + integer, private :: ih_spitfire_ROS_pa + integer, private :: ih_effect_wspeed_pa + integer, private :: ih_TFC_ROS_pa + integer, private :: ih_fire_intensity_pa + integer, private :: ih_fire_area_pa + integer, private :: ih_scorch_height_pa + integer, private :: ih_fire_fuel_bulkd_pa + integer, private :: ih_fire_fuel_eff_moist_pa + integer, private :: ih_fire_fuel_sav_pa + integer, private :: ih_fire_fuel_mef_pa + integer, private :: ih_sum_fuel_pa + integer, private :: ih_litter_in_si + integer, private :: ih_litter_out_pa + + integer, private :: ih_efpot_pa ! NA + integer, private :: ih_rb_pa ! NA + + integer, private :: ih_daily_temp + integer, private :: ih_daily_rh + integer, private :: ih_daily_prec + integer, private :: ih_seed_bank_si + integer, private :: ih_seeds_in_pa + integer, private :: ih_seed_decay_pa + integer, private :: ih_seed_germination_pa + integer, private :: ih_bstore_pa + integer, private :: ih_bdead_pa + integer, private :: ih_balive_pa + integer, private :: ih_bleaf_pa + integer, private :: ih_btotal_pa + integer, private :: ih_npp_pa + integer, private :: ih_gpp_pa + integer, private :: ih_aresp_pa + integer, private :: ih_maint_resp_pa + integer, private :: ih_growth_resp_pa + integer, private :: ih_ar_canopy_pa + integer, private :: ih_gpp_canopy_pa + integer, private :: ih_ar_understory_pa + integer, private :: ih_gpp_understory_pa + integer, private :: ih_canopy_biomass_pa + integer, private :: ih_understory_biomass_pa + + ! Indices to site by size-class by pft variables + integer, private :: ih_nplant_si_scag + + ! Indices to (site) variables + integer, private :: ih_nep_si + integer, private :: ih_nep_timeintegrated_si + integer, private :: ih_npp_timeintegrated_si + integer, private :: ih_hr_timeintegrated_si + integer, private :: ih_nbp_si + integer, private :: ih_npp_si + integer, private :: ih_fire_c_to_atm_si + integer, private :: ih_ed_to_bgc_this_edts_si + integer, private :: ih_ed_to_bgc_last_edts_si + integer, private :: ih_totecosysc_si + integer, private :: ih_totecosysc_old_si + integer, private :: ih_totedc_si + integer, private :: ih_totedc_old_si + integer, private :: ih_totbgcc_si + integer, private :: ih_totbgcc_old_si + integer, private :: ih_biomass_stock_si + integer, private :: ih_litter_stock_si + integer, private :: ih_cwd_stock_si + integer, private :: ih_cbal_err_fates_si + integer, private :: ih_cbal_err_bgc_si + integer, private :: ih_cbal_err_tot_si + integer, private :: ih_npatches_si + integer, private :: ih_ncohorts_si + integer, private :: ih_demotion_carbonflux_si + integer, private :: ih_promotion_carbonflux_si + integer, private :: ih_canopy_mortality_carbonflux_si + integer, private :: ih_understory_mortality_carbonflux_si + + ! Indices to (site x scpf) variables + integer, private :: ih_nplant_si_scpf + integer, private :: ih_gpp_si_scpf + integer, private :: ih_npp_totl_si_scpf + integer, private :: ih_npp_leaf_si_scpf + integer, private :: ih_npp_seed_si_scpf + integer, private :: ih_npp_fnrt_si_scpf + integer, private :: ih_npp_bgsw_si_scpf + integer, private :: ih_npp_bgdw_si_scpf + integer, private :: ih_npp_agsw_si_scpf + integer, private :: ih_npp_agdw_si_scpf + integer, private :: ih_npp_stor_si_scpf + + integer, private :: ih_bstor_canopy_si_scpf + integer, private :: ih_bstor_understory_si_scpf + integer, private :: ih_bleaf_canopy_si_scpf + integer, private :: ih_bleaf_understory_si_scpf + integer, private :: ih_mortality_canopy_si_scpf + integer, private :: ih_mortality_understory_si_scpf + integer, private :: ih_nplant_canopy_si_scpf + integer, private :: ih_nplant_understory_si_scpf + integer, private :: ih_ddbh_canopy_si_scpf + integer, private :: ih_ddbh_understory_si_scpf + integer, private :: ih_gpp_canopy_si_scpf + integer, private :: ih_gpp_understory_si_scpf + integer, private :: ih_ar_canopy_si_scpf + integer, private :: ih_ar_understory_si_scpf + + integer, private :: ih_ddbh_si_scpf + integer, private :: ih_ba_si_scpf + integer, private :: ih_m1_si_scpf + integer, private :: ih_m2_si_scpf + integer, private :: ih_m3_si_scpf + integer, private :: ih_m4_si_scpf + integer, private :: ih_m5_si_scpf + integer, private :: ih_m6_si_scpf + + integer, private :: ih_ar_si_scpf + integer, private :: ih_ar_grow_si_scpf + integer, private :: ih_ar_maint_si_scpf + integer, private :: ih_ar_darkm_si_scpf + integer, private :: ih_ar_agsapm_si_scpf + integer, private :: ih_ar_crootm_si_scpf + integer, private :: ih_ar_frootm_si_scpf + + ! indices to (site x scls) variables + integer, private :: ih_ba_si_scls + integer, private :: ih_nplant_canopy_si_scls + integer, private :: ih_nplant_understory_si_scls + integer, private :: ih_mortality_canopy_si_scls + integer, private :: ih_mortality_understory_si_scls + integer, private :: ih_demotion_rate_si_scls + integer, private :: ih_promotion_rate_si_scls + + ! lots of non-default diagnostics for understanding canopy versus understory carbon balances + integer, private :: ih_rdark_canopy_si_scls + integer, private :: ih_livestem_mr_canopy_si_scls + integer, private :: ih_livecroot_mr_canopy_si_scls + integer, private :: ih_froot_mr_canopy_si_scls + integer, private :: ih_resp_g_canopy_si_scls + integer, private :: ih_resp_m_canopy_si_scls + integer, private :: ih_leaf_md_canopy_si_scls + integer, private :: ih_root_md_canopy_si_scls + integer, private :: ih_carbon_balance_canopy_si_scls + integer, private :: ih_seed_prod_canopy_si_scls + integer, private :: ih_dbalivedt_canopy_si_scls + integer, private :: ih_dbdeaddt_canopy_si_scls + integer, private :: ih_dbstoredt_canopy_si_scls + integer, private :: ih_storage_flux_canopy_si_scls + integer, private :: ih_npp_leaf_canopy_si_scls + integer, private :: ih_npp_froot_canopy_si_scls + integer, private :: ih_npp_bsw_canopy_si_scls + integer, private :: ih_npp_bdead_canopy_si_scls + integer, private :: ih_npp_bseed_canopy_si_scls + integer, private :: ih_npp_store_canopy_si_scls + + integer, private :: ih_rdark_understory_si_scls + integer, private :: ih_livestem_mr_understory_si_scls + integer, private :: ih_livecroot_mr_understory_si_scls + integer, private :: ih_froot_mr_understory_si_scls + integer, private :: ih_resp_g_understory_si_scls + integer, private :: ih_resp_m_understory_si_scls + integer, private :: ih_leaf_md_understory_si_scls + integer, private :: ih_root_md_understory_si_scls + integer, private :: ih_carbon_balance_understory_si_scls + integer, private :: ih_seed_prod_understory_si_scls + integer, private :: ih_dbalivedt_understory_si_scls + integer, private :: ih_dbdeaddt_understory_si_scls + integer, private :: ih_dbstoredt_understory_si_scls + integer, private :: ih_storage_flux_understory_si_scls + integer, private :: ih_npp_leaf_understory_si_scls + integer, private :: ih_npp_froot_understory_si_scls + integer, private :: ih_npp_bsw_understory_si_scls + integer, private :: ih_npp_bdead_understory_si_scls + integer, private :: ih_npp_bseed_understory_si_scls + integer, private :: ih_npp_store_understory_si_scls + + integer, private :: ih_yesterdaycanopylevel_canopy_si_scls + integer, private :: ih_yesterdaycanopylevel_understory_si_scls + + ! indices to (site x pft) variables + integer, private :: ih_biomass_si_pft + integer, private :: ih_leafbiomass_si_pft + integer, private :: ih_storebiomass_si_pft + integer, private :: ih_nindivs_si_pft + integer, private :: ih_recruitment_si_pft + integer, private :: ih_mortality_si_pft + + + ! indices to (site x patch-age) variables + integer, private :: ih_area_si_age + integer, private :: ih_lai_si_age + integer, private :: ih_canopy_area_si_age + integer, private :: ih_gpp_si_age + integer, private :: ih_npp_si_age + integer, private :: ih_ncl_si_age + integer, private :: ih_npatches_si_age + + ! Indices to hydraulics variables + + integer, private :: ih_errh2o_scpf + integer, private :: ih_tran_scpf + integer, private :: ih_rootuptake_scpf + integer, private :: ih_rootuptake01_scpf + integer, private :: ih_rootuptake02_scpf + integer, private :: ih_rootuptake03_scpf + integer, private :: ih_rootuptake04_scpf + integer, private :: ih_rootuptake05_scpf + integer, private :: ih_rootuptake06_scpf + integer, private :: ih_rootuptake07_scpf + integer, private :: ih_rootuptake08_scpf + integer, private :: ih_rootuptake09_scpf + integer, private :: ih_rootuptake10_scpf + integer, private :: ih_sapflow_scpf + integer, private :: ih_iterh1_scpf + integer, private :: ih_iterh2_scpf + integer, private :: ih_supsub_scpf + integer, private :: ih_ath_scpf + integer, private :: ih_tth_scpf + integer, private :: ih_sth_scpf + integer, private :: ih_lth_scpf + integer, private :: ih_awp_scpf + integer, private :: ih_twp_scpf + integer, private :: ih_swp_scpf + integer, private :: ih_lwp_scpf + integer, private :: ih_btran_scpf + + ! indices to (site x fuel class) variables + integer, private :: ih_litter_moisture_si_fuel + + ! indices to (site x cwd size class) variables + integer, private :: ih_cwd_ag_si_cwdsc + integer, private :: ih_cwd_bg_si_cwdsc + integer, private :: ih_cwd_ag_in_si_cwdsc + integer, private :: ih_cwd_bg_in_si_cwdsc + integer, private :: ih_cwd_ag_out_si_cwdsc + integer, private :: ih_cwd_bg_out_si_cwdsc + + ! indices to (site x [canopy layer x leaf layer]) variables + integer, private :: ih_parsun_z_si_cnlf + integer, private :: ih_parsha_z_si_cnlf + integer, private :: ih_laisun_z_si_cnlf + integer, private :: ih_laisha_z_si_cnlf + integer, private :: ih_fabd_sun_si_cnlf + integer, private :: ih_fabd_sha_si_cnlf + integer, private :: ih_fabi_sun_si_cnlf + integer, private :: ih_fabi_sha_si_cnlf + + ! indices to (site x [canopy layer x leaf layer x pft]) variables + integer, private :: ih_parsun_z_si_cnlfpft + integer, private :: ih_parsha_z_si_cnlfpft + integer, private :: ih_laisun_z_si_cnlfpft + integer, private :: ih_laisha_z_si_cnlfpft + integer, private :: ih_fabd_sun_si_cnlfpft + integer, private :: ih_fabd_sha_si_cnlfpft + integer, private :: ih_fabi_sun_si_cnlfpft + integer, private :: ih_fabi_sha_si_cnlfpft + + ! indices to (site x canopy layer) variables + integer, private :: ih_parsun_top_si_can + integer, private :: ih_parsha_top_si_can + integer, private :: ih_laisun_top_si_can + integer, private :: ih_laisha_top_si_can + integer, private :: ih_fabd_sun_top_si_can + integer, private :: ih_fabd_sha_top_si_can + integer, private :: ih_fabi_sun_top_si_can + integer, private :: ih_fabi_sha_top_si_can + + ! The number of variable dim/kind types we have defined (static) + integer, parameter :: fates_history_num_dimensions = 13 + integer, parameter :: fates_history_num_dim_kinds = 15 + + + + ! This structure is allocated by thread, and must be calculated after the FATES + ! sites are allocated, and their mapping to the HLM is identified. This structure + ! is not combined with iovar_bounds, because that one is multi-instanced. This + ! structure is used more during the update phase, wherease _bounds is used + ! more for things like flushing + type iovar_map_type + integer, allocatable :: site_index(:) ! maps site indexes to the HIO site position + integer, allocatable :: patch1_index(:) ! maps site index to the HIO patch 1st position + end type iovar_map_type + + + type, public :: fates_history_interface_type + + ! Instance of the list of history output varialbes + type(fates_history_variable_type), allocatable :: hvars(:) + integer, private :: num_history_vars_ + + ! Instanteat one registry of the different dimension/kinds (dk) + ! All output variables will have a pointer to one of these dk's + type(fates_io_variable_kind_type) :: dim_kinds(fates_history_num_dim_kinds) + + ! This is a structure that explains where FATES patch boundaries + ! on each thread point to in the host IO array, this structure is + ! allocated by number of threads. This could be dynamically + ! allocated, but is unlikely to change...? + type(fates_io_dimension_type) :: dim_bounds(fates_history_num_dimensions) + + type(iovar_map_type), pointer :: iovar_map(:) + + integer, private :: patch_index_, column_index_, levgrnd_index_, levscpf_index_ + integer, private :: levscls_index_, levpft_index_, levage_index_ + integer, private :: levfuel_index_, levcwdsc_index_, levscag_index_ + integer, private :: levcan_index_, levcnlf_index_, levcnlfpft_index_ + contains + + procedure, public :: Init + procedure, public :: SetThreadBoundsEach + procedure, public :: initialize_history_vars + procedure, public :: assemble_history_output_types + + procedure, public :: update_history_dyn + procedure, public :: update_history_prod + procedure, public :: update_history_cbal + procedure, public :: update_history_hydraulics + + ! 'get' methods used by external callers to access private read only data + procedure, public :: num_history_vars + procedure, public :: patch_index + procedure, public :: column_index + procedure, public :: levgrnd_index + procedure, public :: levscpf_index + procedure, public :: levscls_index + procedure, public :: levpft_index + procedure, public :: levage_index + procedure, public :: levfuel_index + procedure, public :: levcwdsc_index + procedure, public :: levcan_index + procedure, public :: levcnlf_index + procedure, public :: levcnlfpft_index + procedure, public :: levscag_index + + ! private work functions + procedure, private :: define_history_vars + procedure, private :: set_history_var + procedure, private :: init_dim_kinds_maps + procedure, private :: set_dim_indices + procedure, private :: flush_hvars + + procedure, private :: set_patch_index + procedure, private :: set_column_index + procedure, private :: set_levgrnd_index + procedure, private :: set_levscpf_index + procedure, private :: set_levscls_index + procedure, private :: set_levpft_index + procedure, private :: set_levage_index + procedure, private :: set_levfuel_index + procedure, private :: set_levcwdsc_index + procedure, private :: set_levcan_index + procedure, private :: set_levcnlf_index + procedure, private :: set_levcnlfpft_index + procedure, private :: set_levscag_index + + end type fates_history_interface_type + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + +contains + + ! ====================================================================== + + subroutine Init(this, num_threads, fates_bounds) + + use FatesIODimensionsMod, only : patch, column, levgrnd, levscpf + use FatesIODimensionsMod, only : levscls, levpft, levage + use FatesIODimensionsMod, only : levfuel, levcwdsc, levscag + use FatesIODimensionsMod, only : levcan, levcnlf, levcnlfpft + use FatesIODimensionsMod, only : fates_bounds_type + + implicit none + + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: num_threads + type(fates_bounds_type), intent(in) :: fates_bounds + + integer :: dim_count = 0 + + dim_count = dim_count + 1 + call this%set_patch_index(dim_count) + call this%dim_bounds(dim_count)%Init(patch, num_threads, & + fates_bounds%patch_begin, fates_bounds%patch_end) + + dim_count = dim_count + 1 + call this%set_column_index(dim_count) + call this%dim_bounds(dim_count)%Init(column, num_threads, & + fates_bounds%column_begin, fates_bounds%column_end) + + dim_count = dim_count + 1 + call this%set_levgrnd_index(dim_count) + call this%dim_bounds(dim_count)%Init(levgrnd, num_threads, & + fates_bounds%ground_begin, fates_bounds%ground_end) + + dim_count = dim_count + 1 + call this%set_levscpf_index(dim_count) + call this%dim_bounds(dim_count)%Init(levscpf, num_threads, & + fates_bounds%sizepft_class_begin, fates_bounds%sizepft_class_end) + + dim_count = dim_count + 1 + call this%set_levscls_index(dim_count) + call this%dim_bounds(dim_count)%Init(levscls, num_threads, & + fates_bounds%size_class_begin, fates_bounds%size_class_end) + + dim_count = dim_count + 1 + call this%set_levpft_index(dim_count) + call this%dim_bounds(dim_count)%Init(levpft, num_threads, & + fates_bounds%pft_class_begin, fates_bounds%pft_class_end) + + dim_count = dim_count + 1 + call this%set_levage_index(dim_count) + call this%dim_bounds(dim_count)%Init(levage, num_threads, & + fates_bounds%age_class_begin, fates_bounds%age_class_end) + + dim_count = dim_count + 1 + call this%set_levfuel_index(dim_count) + call this%dim_bounds(dim_count)%Init(levfuel, num_threads, & + fates_bounds%fuel_begin, fates_bounds%fuel_end) + + dim_count = dim_count + 1 + call this%set_levcwdsc_index(dim_count) + call this%dim_bounds(dim_count)%Init(levcwdsc, num_threads, & + fates_bounds%cwdsc_begin, fates_bounds%cwdsc_end) + + dim_count = dim_count + 1 + call this%set_levcan_index(dim_count) + call this%dim_bounds(dim_count)%Init(levcan, num_threads, & + fates_bounds%can_begin, fates_bounds%can_end) + + dim_count = dim_count + 1 + call this%set_levcnlf_index(dim_count) + call this%dim_bounds(dim_count)%Init(levcnlf, num_threads, & + fates_bounds%cnlf_begin, fates_bounds%cnlf_end) + + dim_count = dim_count + 1 + call this%set_levcnlfpft_index(dim_count) + 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_levscag_index(dim_count) + call this%dim_bounds(dim_count)%Init(levscag, num_threads, & + fates_bounds%sizeage_class_begin, fates_bounds%sizeage_class_end) + + + ! FIXME(bja, 2016-10) assert(dim_count == FatesHistorydimensionmod::num_dimension_types) + + ! Allocate the mapping between FATES indices and the IO indices + allocate(this%iovar_map(num_threads)) + + end subroutine Init + + ! ====================================================================== + subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) + + use FatesIODimensionsMod, only : fates_bounds_type + + implicit none + + class(fates_history_interface_type), intent(inout) :: this + + integer, intent(in) :: thread_index + type(fates_bounds_type), intent(in) :: thread_bounds + + integer :: index + + index = this%patch_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%patch_begin, thread_bounds%patch_end) + + index = this%column_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%column_begin, thread_bounds%column_end) + + index = this%levgrnd_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%ground_begin, thread_bounds%ground_end) + + index = this%levscpf_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%sizepft_class_begin, thread_bounds%sizepft_class_end) + + index = this%levscls_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%size_class_begin, thread_bounds%size_class_end) + + index = this%levpft_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%pft_class_begin, thread_bounds%pft_class_end) + + index = this%levage_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%age_class_begin, thread_bounds%age_class_end) + + index = this%levfuel_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%fuel_begin, thread_bounds%fuel_end) + + index = this%levcwdsc_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%cwdsc_begin, thread_bounds%cwdsc_end) + + index = this%levcan_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%can_begin, thread_bounds%can_end) + + index = this%levcnlf_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%cnlf_begin, thread_bounds%cnlf_end) + + index = this%levcnlfpft_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%cnlfpft_begin, thread_bounds%cnlfpft_end) + + index = this%levscag_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%sizeage_class_begin, thread_bounds%sizeage_class_end) + + end subroutine SetThreadBoundsEach + + ! =================================================================================== + subroutine assemble_history_output_types(this) + + use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 + use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 + use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 + + implicit none + + class(fates_history_interface_type), intent(inout) :: this + + call this%init_dim_kinds_maps() + + call this%set_dim_indices(patch_r8, 1, this%patch_index()) + + call this%set_dim_indices(site_r8, 1, this%column_index()) + + call this%set_dim_indices(patch_ground_r8, 1, this%patch_index()) + call this%set_dim_indices(patch_ground_r8, 2, this%levgrnd_index()) + + call this%set_dim_indices(site_ground_r8, 1, this%column_index()) + call this%set_dim_indices(site_ground_r8, 2, this%levgrnd_index()) + + call this%set_dim_indices(patch_size_pft_r8, 1, this%patch_index()) + call this%set_dim_indices(patch_size_pft_r8, 2, this%levscpf_index()) + + call this%set_dim_indices(site_size_pft_r8, 1, this%column_index()) + call this%set_dim_indices(site_size_pft_r8, 2, this%levscpf_index()) + + call this%set_dim_indices(site_size_r8, 1, this%column_index()) + call this%set_dim_indices(site_size_r8, 2, this%levscls_index()) + + call this%set_dim_indices(site_pft_r8, 1, this%column_index()) + call this%set_dim_indices(site_pft_r8, 2, this%levpft_index()) + + call this%set_dim_indices(site_age_r8, 1, this%column_index()) + call this%set_dim_indices(site_age_r8, 2, this%levage_index()) + + call this%set_dim_indices(site_fuel_r8, 1, this%column_index()) + call this%set_dim_indices(site_fuel_r8, 2, this%levfuel_index()) + + call this%set_dim_indices(site_cwdsc_r8, 1, this%column_index()) + call this%set_dim_indices(site_cwdsc_r8, 2, this%levcwdsc_index()) + + call this%set_dim_indices(site_can_r8, 1, this%column_index()) + call this%set_dim_indices(site_can_r8, 2, this%levcan_index()) + + call this%set_dim_indices(site_cnlf_r8, 1, this%column_index()) + call this%set_dim_indices(site_cnlf_r8, 2, this%levcnlf_index()) + + 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_scag_r8, 1, this%column_index()) + call this%set_dim_indices(site_scag_r8, 2, this%levscag_index()) + + end subroutine assemble_history_output_types + + ! =================================================================================== + + subroutine set_dim_indices(this, dk_name, idim, dim_index) + + use FatesIOVariableKindMod , only : iotype_index + + implicit none + + ! arguments + class(fates_history_interface_type), intent(inout) :: this + character(len=*), intent(in) :: dk_name + integer, intent(in) :: idim ! dimension index + integer, intent(in) :: dim_index + + + ! local + integer :: ityp + + ityp = iotype_index(trim(dk_name), fates_history_num_dim_kinds, this%dim_kinds) + + ! First check to see if the dimension is allocated + if (this%dim_kinds(ityp)%ndims < idim) then + write(fates_log(), *) 'Trying to define dimension size to a dim-type structure' + write(fates_log(), *) 'but the dimension index does not exist' + write(fates_log(), *) 'type: ',dk_name,' ndims: ',this%dim_kinds(ityp)%ndims,' input dim:',idim + stop + !end_run + end if + + if (idim == 1) then + this%dim_kinds(ityp)%dim1_index = dim_index + else if (idim == 2) then + this%dim_kinds(ityp)%dim2_index = dim_index + end if + + ! With the map, we can set the dimension size + this%dim_kinds(ityp)%dimsize(idim) = this%dim_bounds(dim_index)%upper_bound - & + this%dim_bounds(dim_index)%lower_bound + 1 + + end subroutine set_dim_indices + + ! ======================================================================= + subroutine set_patch_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%patch_index_ = index + end subroutine set_patch_index + + integer function patch_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + patch_index = this%patch_index_ + end function patch_index + + ! ======================================================================= + subroutine set_column_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%column_index_ = index + end subroutine set_column_index + + integer function column_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + column_index = this%column_index_ + end function column_index + + ! ======================================================================= + subroutine set_levgrnd_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levgrnd_index_ = index + end subroutine set_levgrnd_index + + integer function levgrnd_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levgrnd_index = this%levgrnd_index_ + end function levgrnd_index + + ! ======================================================================= + subroutine set_levscpf_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levscpf_index_ = index + end subroutine set_levscpf_index + + integer function levscpf_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levscpf_index = this%levscpf_index_ + end function levscpf_index + + ! ======================================================================= + subroutine set_levscls_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levscls_index_ = index + end subroutine set_levscls_index + + integer function levscls_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levscls_index = this%levscls_index_ + end function levscls_index + + ! ======================================================================= + subroutine set_levpft_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levpft_index_ = index + end subroutine set_levpft_index + + integer function levpft_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levpft_index = this%levpft_index_ + end function levpft_index + + ! ======================================================================= + subroutine set_levage_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levage_index_ = index + end subroutine set_levage_index + + integer function levage_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levage_index = this%levage_index_ + end function levage_index + + ! ======================================================================= + subroutine set_levfuel_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levfuel_index_ = index + end subroutine set_levfuel_index + + integer function levfuel_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levfuel_index = this%levfuel_index_ + end function levfuel_index + + ! ======================================================================= + subroutine set_levcwdsc_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levcwdsc_index_ = index + end subroutine set_levcwdsc_index + + integer function levcwdsc_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levcwdsc_index = this%levcwdsc_index_ + end function levcwdsc_index + + ! ======================================================================= + subroutine set_levcan_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levcan_index_ = index + end subroutine set_levcan_index + + integer function levcan_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levcan_index = this%levcan_index_ + end function levcan_index + + ! ======================================================================= + subroutine set_levcnlf_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levcnlf_index_ = index + end subroutine set_levcnlf_index + + integer function levcnlf_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levcnlf_index = this%levcnlf_index_ + end function levcnlf_index + + ! ======================================================================= + subroutine set_levcnlfpft_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levcnlfpft_index_ = index + end subroutine set_levcnlfpft_index + + integer function levcnlfpft_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levcnlfpft_index = this%levcnlfpft_index_ + end function levcnlfpft_index + + ! ====================================================================================== + subroutine set_levscag_index(this, index) + implicit none + class(fates_history_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%levscag_index_ = index + end subroutine set_levscag_index + + integer function levscag_index(this) + implicit none + class(fates_history_interface_type), intent(in) :: this + levscag_index = this%levscag_index_ + end function levscag_index + ! ====================================================================================== + + + subroutine flush_hvars(this,nc,upfreq_in) + + class(fates_history_interface_type) :: this + integer,intent(in) :: nc + integer,intent(in) :: upfreq_in + + integer :: ivar + type(fates_history_variable_type),pointer :: hvar + integer :: lb1,ub1,lb2,ub2 + + do ivar=1,ubound(this%hvars,1) + associate( hvar => this%hvars(ivar) ) + if (hvar%upfreq == upfreq_in) then ! Only flush variables with update on dynamics step + call hvar%Flush(nc, this%dim_bounds, this%dim_kinds) + end if + end associate + end do + + end subroutine flush_hvars + + + ! ===================================================================================== + + subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype, & + hlms, flushval, upfreq, ivar, initialize, index) + + use FatesUtilsMod, only : check_hlm_list + use FatesInterfaceMod, only : hlm_name + + implicit none + + ! arguments + class(fates_history_interface_type), intent(inout) :: this + character(len=*), intent(in) :: vname + character(len=*), intent(in) :: units + character(len=*), intent(in) :: long + character(len=*), intent(in) :: use_default + character(len=*), intent(in) :: avgflag + character(len=*), intent(in) :: vtype + character(len=*), intent(in) :: hlms + real(r8), intent(in) :: flushval ! IF THE TYPE IS AN INT WE WILL round with NINT + integer, intent(in) :: upfreq + logical, intent(in) :: initialize + integer, intent(inout) :: ivar + integer, intent(inout) :: index ! This is the index for the variable of + ! interest that is associated with an + ! explict name (for fast reference during update) + ! A zero is passed back when the variable is + ! not used + + ! locals + type(fates_history_variable_type), pointer :: hvar + integer :: ub1, lb1, ub2, lb2 ! Bounds for allocating the var + integer :: ityp + + logical :: write_var + + write_var = check_hlm_list(trim(hlms), trim(hlm_name)) + if( write_var ) then + ivar = ivar+1 + index = ivar + + if (initialize) then + call this%hvars(ivar)%Init(vname, units, long, use_default, & + vtype, avgflag, flushval, upfreq, fates_history_num_dim_kinds, this%dim_kinds, & + this%dim_bounds) + end if + else + index = 0 + end if + + return + end subroutine set_history_var + + ! ==================================================================================== + + subroutine init_dim_kinds_maps(this) + + ! ---------------------------------------------------------------------------------- + ! This subroutine simply initializes the structures that define the different + ! array and type formats for different IO variables + ! + ! PA_R8 : 1D patch scale 8-byte reals + ! SI_R8 : 1D site scale 8-byte reals + ! + ! The allocation on the structures is not dynamic and should only add up to the + ! number of entries listed here. + ! + ! ---------------------------------------------------------------------------------- + use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 + use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 + use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 + + implicit none + + ! Arguments + class(fates_history_interface_type), intent(inout) :: this + + + integer :: index + + ! 1d Patch + index = 1 + call this%dim_kinds(index)%Init(patch_r8, 1) + + ! 1d Site + index = index + 1 + call this%dim_kinds(index)%Init(site_r8, 1) + + ! patch x ground + index = index + 1 + call this%dim_kinds(index)%Init(patch_ground_r8, 2) + + ! patch x size-class/pft + index = index + 1 + call this%dim_kinds(index)%Init(patch_size_pft_r8, 2) + + ! site x ground + index = index + 1 + call this%dim_kinds(index)%Init(site_ground_r8, 2) + + ! site x size-class/pft + index = index + 1 + call this%dim_kinds(index)%Init(site_size_pft_r8, 2) + + ! site x size-class + index = index + 1 + call this%dim_kinds(index)%Init(site_size_r8, 2) + + ! site x pft + index = index + 1 + call this%dim_kinds(index)%Init(site_pft_r8, 2) + + ! site x patch-age class + index = index + 1 + call this%dim_kinds(index)%Init(site_age_r8, 2) + + ! site x fuel size class + index = index + 1 + call this%dim_kinds(index)%Init(site_fuel_r8, 2) + + ! site x cwd size class + index = index + 1 + call this%dim_kinds(index)%Init(site_cwdsc_r8, 2) + + ! site x can class + index = index + 1 + call this%dim_kinds(index)%Init(site_can_r8, 2) + + ! site x cnlf class + index = index + 1 + call this%dim_kinds(index)%Init(site_cnlf_r8, 2) + + ! site x cnlfpft class + index = index + 1 + call this%dim_kinds(index)%Init(site_cnlfpft_r8, 2) + + ! site x size-class x age class + index = index + 1 + call this%dim_kinds(index)%Init(site_scag_r8, 2) + + ! FIXME(bja, 2016-10) assert(index == fates_history_num_dim_kinds) + end subroutine init_dim_kinds_maps + + ! ======================================================================= + subroutine update_history_cbal(this,nc,nsites,sites) + + use EDtypesMod , only : ed_site_type + + ! Arguments + class(fates_history_interface_type) :: this + integer , intent(in) :: nc ! clump index + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + + ! Locals + integer :: s ! The local site index + integer :: io_si ! The site index of the IO array + + + associate( hio_nep_si => this%hvars(ih_nep_si)%r81d, & + hio_nbp_si => this%hvars(ih_nbp_si)%r81d, & + hio_fire_c_to_atm_si => this%hvars(ih_fire_c_to_atm_si)%r81d, & + hio_totecosysc_si => this%hvars(ih_totecosysc_si)%r81d, & + hio_cbal_err_fates_si => this%hvars(ih_cbal_err_fates_si)%r81d, & + hio_cbal_err_bgc_si => this%hvars(ih_cbal_err_bgc_si)%r81d, & + hio_cbal_err_tot_si => this%hvars(ih_cbal_err_tot_si)%r81d, & + hio_biomass_stock_si => this%hvars(ih_biomass_stock_si)%r81d, & + hio_litter_stock_si => this%hvars(ih_litter_stock_si)%r81d, & + hio_cwd_stock_si => this%hvars(ih_cwd_stock_si)%r81d ) + + ! --------------------------------------------------------------------------------- + ! Flush arrays to values defined by %flushval (see registry entry in + ! subroutine define_history_vars() + ! --------------------------------------------------------------------------------- + call this%flush_hvars(nc,upfreq_in=3) + + + do s = 1,nsites + + io_si = this%iovar_map(nc)%site_index(s) + + hio_nep_si(io_si) = sites(s)%nep + hio_nbp_si(io_si) = sites(s)%nbp + hio_fire_c_to_atm_si(io_si) = sites(s)%fire_c_to_atm + hio_totecosysc_si(io_si) = sites(s)%totecosysc + hio_cbal_err_fates_si(io_si) = sites(s)%cbal_err_fates + hio_cbal_err_bgc_si(io_si) = sites(s)%cbal_err_bgc + hio_cbal_err_tot_si(io_si) = sites(s)%cbal_err_tot + hio_biomass_stock_si(io_si) = sites(s)%biomass_stock + hio_litter_stock_si(io_si) = sites(s)%ed_litter_stock + hio_cwd_stock_si(io_si) = sites(s)%cwd_stock + + end do + + end associate + + end subroutine update_history_cbal + + + ! ==================================================================================== + + subroutine update_history_dyn(this,nc,nsites,sites) + + ! --------------------------------------------------------------------------------- + ! This is the call to update the history IO arrays that are expected to only change + ! after Ecosystem Dynamics have been processed. + ! --------------------------------------------------------------------------------- + + use EDtypesMod , only : ed_site_type + use EDtypesMod , only : ed_cohort_type + use EDtypesMod , only : ed_patch_type + use EDtypesMod , only : AREA + use EDtypesMod , only : AREA_INV + use EDtypesMod , only : nlevsclass_ed + use EDtypesMod , only : nlevage_ed + use EDtypesMod , only : do_ed_dynamics + use EDtypesMod , only : nfsc + use EDtypesMod , only : ncwd + use EDtypesMod , only : ican_upper + use EDtypesMod , only : ican_ustory + use EDTypesMod , only : maxpft + + use EDParamsMod , only : ED_val_ag_biomass + use EDTypesMod , only : get_sizeage_class_index + + ! Arguments + class(fates_history_interface_type) :: this + integer , intent(in) :: nc ! clump index + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + + ! Locals + integer :: s ! The local site index + integer :: io_si ! The site index of the IO array + integer :: ipa, ipa2 ! The local "I"ndex of "PA"tches + integer :: io_pa ! The patch index of the IO array + integer :: io_pa1 ! The first patch index in the IO array for each site + integer :: io_soipa + integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread + integer :: ivar ! index of IO variable object vector + integer :: ft ! functional type index + integer :: i_scpf,i_pft,i_scls ! iterators for scpf, pft, and scls dims + integer :: i_cwd,i_fuel ! iterators for cwd and fuel dims + integer :: iscag ! size-class x age index + + real(r8) :: n_density ! individual of cohort per m2. + real(r8) :: n_perm2 ! individuals per m2 for the whole column + real(r8) :: patch_scaling_scalar ! ratio of canopy to patch area for counteracting patch scaling + real(r8) :: dbh ! diameter ("at breast height") + + type(fates_history_variable_type),pointer :: hvar + type(ed_patch_type),pointer :: cpatch + type(ed_cohort_type),pointer :: ccohort + + real(r8), parameter :: tiny = 1.e-5_r8 ! some small number + + associate( hio_npatches_si => this%hvars(ih_npatches_si)%r81d, & + hio_ncohorts_si => this%hvars(ih_ncohorts_si)%r81d, & + hio_trimming_pa => this%hvars(ih_trimming_pa)%r81d, & + hio_area_plant_pa => this%hvars(ih_area_plant_pa)%r81d, & + hio_area_treespread_pa => this%hvars(ih_area_treespread_pa)%r81d, & + hio_canopy_spread_pa => this%hvars(ih_canopy_spread_pa)%r81d, & + hio_biomass_si_pft => this%hvars(ih_biomass_si_pft)%r82d, & + hio_leafbiomass_si_pft => this%hvars(ih_leafbiomass_si_pft)%r82d, & + hio_storebiomass_si_pft => this%hvars(ih_storebiomass_si_pft)%r82d, & + hio_nindivs_si_pft => this%hvars(ih_nindivs_si_pft)%r82d, & + hio_recruitment_si_pft => this%hvars(ih_recruitment_si_pft)%r82d, & + hio_mortality_si_pft => this%hvars(ih_mortality_si_pft)%r82d, & + hio_nesterov_fire_danger_pa => this%hvars(ih_nesterov_fire_danger_pa)%r81d, & + hio_spitfire_ros_pa => this%hvars(ih_spitfire_ROS_pa)%r81d, & + hio_tfc_ros_pa => this%hvars(ih_TFC_ROS_pa)%r81d, & + hio_effect_wspeed_pa => this%hvars(ih_effect_wspeed_pa)%r81d, & + hio_fire_intensity_pa => this%hvars(ih_fire_intensity_pa)%r81d, & + hio_fire_area_pa => this%hvars(ih_fire_area_pa)%r81d, & + hio_scorch_height_pa => this%hvars(ih_scorch_height_pa)%r81d, & + hio_fire_fuel_bulkd_pa => this%hvars(ih_fire_fuel_bulkd_pa)%r81d, & + hio_fire_fuel_eff_moist_pa => this%hvars(ih_fire_fuel_eff_moist_pa)%r81d, & + hio_fire_fuel_sav_pa => this%hvars(ih_fire_fuel_sav_pa)%r81d, & + hio_fire_fuel_mef_pa => this%hvars(ih_fire_fuel_mef_pa)%r81d, & + hio_sum_fuel_pa => this%hvars(ih_sum_fuel_pa)%r81d, & + hio_litter_in_si => this%hvars(ih_litter_in_si)%r81d, & + hio_litter_out_pa => this%hvars(ih_litter_out_pa)%r81d, & + hio_seed_bank_si => this%hvars(ih_seed_bank_si)%r81d, & + hio_seeds_in_pa => this%hvars(ih_seeds_in_pa)%r81d, & + hio_seed_decay_pa => this%hvars(ih_seed_decay_pa)%r81d, & + hio_seed_germination_pa => this%hvars(ih_seed_germination_pa)%r81d, & + hio_bstore_pa => this%hvars(ih_bstore_pa)%r81d, & + hio_bdead_pa => this%hvars(ih_bdead_pa)%r81d, & + hio_balive_pa => this%hvars(ih_balive_pa)%r81d, & + hio_bleaf_pa => this%hvars(ih_bleaf_pa)%r81d, & + hio_btotal_pa => this%hvars(ih_btotal_pa)%r81d, & + hio_canopy_biomass_pa => this%hvars(ih_canopy_biomass_pa)%r81d, & + hio_understory_biomass_pa => this%hvars(ih_understory_biomass_pa)%r81d, & + hio_gpp_si_scpf => this%hvars(ih_gpp_si_scpf)%r82d, & + hio_npp_totl_si_scpf => this%hvars(ih_npp_totl_si_scpf)%r82d, & + hio_npp_leaf_si_scpf => this%hvars(ih_npp_leaf_si_scpf)%r82d, & + hio_npp_seed_si_scpf => this%hvars(ih_npp_seed_si_scpf)%r82d, & + hio_npp_fnrt_si_scpf => this%hvars(ih_npp_fnrt_si_scpf)%r82d, & + hio_npp_bgsw_si_scpf => this%hvars(ih_npp_bgsw_si_scpf)%r82d, & + hio_npp_bgdw_si_scpf => this%hvars(ih_npp_bgdw_si_scpf)%r82d, & + hio_npp_agsw_si_scpf => this%hvars(ih_npp_agsw_si_scpf)%r82d, & + hio_npp_agdw_si_scpf => this%hvars(ih_npp_agdw_si_scpf)%r82d, & + hio_npp_stor_si_scpf => this%hvars(ih_npp_stor_si_scpf)%r82d, & + hio_bstor_canopy_si_scpf => this%hvars(ih_bstor_canopy_si_scpf)%r82d, & + hio_bstor_understory_si_scpf => this%hvars(ih_bstor_understory_si_scpf)%r82d, & + hio_bleaf_canopy_si_scpf => this%hvars(ih_bleaf_canopy_si_scpf)%r82d, & + hio_bleaf_understory_si_scpf => this%hvars(ih_bleaf_understory_si_scpf)%r82d, & + hio_mortality_canopy_si_scpf => this%hvars(ih_mortality_canopy_si_scpf)%r82d, & + hio_mortality_understory_si_scpf => this%hvars(ih_mortality_understory_si_scpf)%r82d, & + hio_nplant_canopy_si_scpf => this%hvars(ih_nplant_canopy_si_scpf)%r82d, & + 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, & + hio_ddbh_understory_si_scpf => this%hvars(ih_ddbh_understory_si_scpf)%r82d, & + hio_gpp_canopy_si_scpf => this%hvars(ih_gpp_canopy_si_scpf)%r82d, & + hio_gpp_understory_si_scpf => this%hvars(ih_gpp_understory_si_scpf)%r82d, & + hio_ar_canopy_si_scpf => this%hvars(ih_ar_canopy_si_scpf)%r82d, & + hio_ar_understory_si_scpf => this%hvars(ih_ar_understory_si_scpf)%r82d, & + hio_ddbh_si_scpf => this%hvars(ih_ddbh_si_scpf)%r82d, & + hio_ba_si_scpf => this%hvars(ih_ba_si_scpf)%r82d, & + hio_nplant_si_scpf => this%hvars(ih_nplant_si_scpf)%r82d, & + hio_m1_si_scpf => this%hvars(ih_m1_si_scpf)%r82d, & + hio_m2_si_scpf => this%hvars(ih_m2_si_scpf)%r82d, & + hio_m3_si_scpf => this%hvars(ih_m3_si_scpf)%r82d, & + hio_m4_si_scpf => this%hvars(ih_m4_si_scpf)%r82d, & + hio_m5_si_scpf => this%hvars(ih_m5_si_scpf)%r82d, & + hio_m6_si_scpf => this%hvars(ih_m6_si_scpf)%r82d, & + hio_ba_si_scls => this%hvars(ih_ba_si_scls)%r82d, & + hio_nplant_canopy_si_scls => this%hvars(ih_nplant_canopy_si_scls)%r82d, & + hio_nplant_understory_si_scls => this%hvars(ih_nplant_understory_si_scls)%r82d, & + hio_mortality_canopy_si_scls => this%hvars(ih_mortality_canopy_si_scls)%r82d, & + hio_mortality_understory_si_scls => this%hvars(ih_mortality_understory_si_scls)%r82d, & + hio_demotion_rate_si_scls => this%hvars(ih_demotion_rate_si_scls)%r82d, & + hio_demotion_carbonflux_si => this%hvars(ih_demotion_carbonflux_si)%r81d, & + hio_promotion_rate_si_scls => this%hvars(ih_promotion_rate_si_scls)%r82d, & + hio_promotion_carbonflux_si => this%hvars(ih_promotion_carbonflux_si)%r81d, & + hio_canopy_mortality_carbonflux_si => this%hvars(ih_canopy_mortality_carbonflux_si)%r81d, & + hio_understory_mortality_carbonflux_si => this%hvars(ih_understory_mortality_carbonflux_si)%r81d, & + hio_leaf_md_canopy_si_scls => this%hvars(ih_leaf_md_canopy_si_scls)%r82d, & + hio_root_md_canopy_si_scls => this%hvars(ih_root_md_canopy_si_scls)%r82d, & + hio_carbon_balance_canopy_si_scls => this%hvars(ih_carbon_balance_canopy_si_scls)%r82d, & + hio_seed_prod_canopy_si_scls => this%hvars(ih_seed_prod_canopy_si_scls)%r82d, & + hio_dbalivedt_canopy_si_scls => this%hvars(ih_dbalivedt_canopy_si_scls)%r82d, & + hio_dbdeaddt_canopy_si_scls => this%hvars(ih_dbdeaddt_canopy_si_scls)%r82d, & + hio_dbstoredt_canopy_si_scls => this%hvars(ih_dbstoredt_canopy_si_scls)%r82d, & + hio_storage_flux_canopy_si_scls => this%hvars(ih_storage_flux_canopy_si_scls)%r82d, & + hio_npp_leaf_canopy_si_scls => this%hvars(ih_npp_leaf_canopy_si_scls)%r82d, & + hio_npp_froot_canopy_si_scls => this%hvars(ih_npp_froot_canopy_si_scls)%r82d, & + hio_npp_bsw_canopy_si_scls => this%hvars(ih_npp_bsw_canopy_si_scls)%r82d, & + hio_npp_bdead_canopy_si_scls => this%hvars(ih_npp_bdead_canopy_si_scls)%r82d, & + hio_npp_bseed_canopy_si_scls => this%hvars(ih_npp_bseed_canopy_si_scls)%r82d, & + hio_npp_store_canopy_si_scls => this%hvars(ih_npp_store_canopy_si_scls)%r82d, & + hio_leaf_md_understory_si_scls => this%hvars(ih_leaf_md_understory_si_scls)%r82d, & + hio_root_md_understory_si_scls => this%hvars(ih_root_md_understory_si_scls)%r82d, & + hio_carbon_balance_understory_si_scls=> this%hvars(ih_carbon_balance_understory_si_scls)%r82d, & + hio_seed_prod_understory_si_scls => this%hvars(ih_seed_prod_understory_si_scls)%r82d, & + hio_dbalivedt_understory_si_scls => this%hvars(ih_dbalivedt_understory_si_scls)%r82d, & + hio_dbdeaddt_understory_si_scls => this%hvars(ih_dbdeaddt_understory_si_scls)%r82d, & + hio_dbstoredt_understory_si_scls => this%hvars(ih_dbstoredt_understory_si_scls)%r82d, & + hio_storage_flux_understory_si_scls => this%hvars(ih_storage_flux_understory_si_scls)%r82d, & + hio_npp_leaf_understory_si_scls => this%hvars(ih_npp_leaf_understory_si_scls)%r82d, & + hio_npp_froot_understory_si_scls => this%hvars(ih_npp_froot_understory_si_scls)%r82d, & + hio_npp_bsw_understory_si_scls => this%hvars(ih_npp_bsw_understory_si_scls)%r82d, & + hio_npp_bdead_understory_si_scls => this%hvars(ih_npp_bdead_understory_si_scls)%r82d, & + hio_npp_bseed_understory_si_scls => this%hvars(ih_npp_bseed_understory_si_scls)%r82d, & + hio_npp_store_understory_si_scls => this%hvars(ih_npp_store_understory_si_scls)%r82d, & + hio_yesterdaycanopylevel_canopy_si_scls => this%hvars(ih_yesterdaycanopylevel_canopy_si_scls)%r82d, & + hio_yesterdaycanopylevel_understory_si_scls => this%hvars(ih_yesterdaycanopylevel_understory_si_scls)%r82d, & + hio_area_si_age => this%hvars(ih_area_si_age)%r82d, & + hio_lai_si_age => this%hvars(ih_lai_si_age)%r82d, & + hio_canopy_area_si_age => this%hvars(ih_canopy_area_si_age)%r82d, & + hio_ncl_si_age => this%hvars(ih_ncl_si_age)%r82d, & + hio_npatches_si_age => this%hvars(ih_npatches_si_age)%r82d, & + hio_litter_moisture_si_fuel => this%hvars(ih_litter_moisture_si_fuel)%r82d, & + hio_cwd_ag_si_cwdsc => this%hvars(ih_cwd_ag_si_cwdsc)%r82d, & + hio_cwd_bg_si_cwdsc => this%hvars(ih_cwd_bg_si_cwdsc)%r82d, & + hio_cwd_ag_in_si_cwdsc => this%hvars(ih_cwd_ag_in_si_cwdsc)%r82d, & + hio_cwd_bg_in_si_cwdsc => this%hvars(ih_cwd_bg_in_si_cwdsc)%r82d, & + hio_cwd_ag_out_si_cwdsc => this%hvars(ih_cwd_ag_out_si_cwdsc)%r82d, & + hio_cwd_bg_out_si_cwdsc => this%hvars(ih_cwd_bg_out_si_cwdsc)%r82d, & + hio_nplant_si_scag => this%hvars(ih_nplant_si_scag)%r82d) + + + ! --------------------------------------------------------------------------------- + ! Flush arrays to values defined by %flushval (see registry entry in + ! subroutine define_history_vars() + ! --------------------------------------------------------------------------------- + call this%flush_hvars(nc,upfreq_in=1) + + + ! If we don't have dynamics turned on, we just abort these diagnostics + if (.not.do_ed_dynamics) return + + ! --------------------------------------------------------------------------------- + ! Loop through the FATES scale hierarchy and fill the history IO arrays + ! --------------------------------------------------------------------------------- + + do s = 1,nsites + + io_si = this%iovar_map(nc)%site_index(s) + io_pa1 = this%iovar_map(nc)%patch1_index(s) + io_soipa = io_pa1-1 + + ! Set trimming on the soil patch to 1.0 + hio_trimming_pa(io_soipa) = 1.0_r8 + + ! The seed bank is a site level variable + hio_seed_bank_si(io_si) = sum(sites(s)%seed_bank) * g_per_kg + + ipa = 0 + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + + io_pa = io_pa1 + ipa + + ! Increment the number of patches per site + hio_npatches_si(io_si) = hio_npatches_si(io_si) + 1._r8 + + ! Increment the fractional area in each age class bin + hio_area_si_age(io_si,cpatch%age_class) = hio_area_si_age(io_si,cpatch%age_class) & + + cpatch%area * AREA_INV + + ! Increment some patch-age-resolved diagnostics + hio_lai_si_age(io_si,cpatch%age_class) = hio_lai_si_age(io_si,cpatch%age_class) & + + cpatch%lai * cpatch%area + hio_ncl_si_age(io_si,cpatch%age_class) = hio_ncl_si_age(io_si,cpatch%age_class) & + + cpatch%ncl_p * cpatch%area + hio_npatches_si_age(io_si,cpatch%age_class) = hio_npatches_si_age(io_si,cpatch%age_class) + 1._r8 + + ccohort => cpatch%shortest + do while(associated(ccohort)) + + ft = ccohort%pft + + ! Increment the number of cohorts per site + hio_ncohorts_si(io_si) = hio_ncohorts_si(io_si) + 1._r8 + + if ((cpatch%area .gt. 0._r8) .and. (cpatch%total_canopy_area .gt. 0._r8)) then + + ! for quantities that are at the CLM patch level, because of the way + ! that CLM patches are weighted for radiative purposes this # density needs + ! to be over either ED patch canopy area or ED patch total area, whichever is less + n_density = ccohort%n/min(cpatch%area,cpatch%total_canopy_area) + + ! for quantities that are natively at column level, calculate plant + ! density using whole area + n_perm2 = ccohort%n * AREA_INV + + else + n_density = 0.0_r8 + n_perm2 = 0.0_r8 + endif + + if(associated(cpatch%tallest))then + hio_trimming_pa(io_pa) = cpatch%tallest%canopy_trim + else + hio_trimming_pa(io_pa) = 0.0_r8 + endif + + hio_area_plant_pa(io_pa) = 1._r8 + + if (min(cpatch%total_canopy_area,cpatch%area)>0.0_r8) then + hio_area_treespread_pa(io_pa) = cpatch%total_tree_area & + / min(cpatch%total_canopy_area,cpatch%area) + else + hio_area_treespread_pa(io_pa) = 0.0_r8 + end if + + hio_canopy_area_si_age(io_si,cpatch%age_class) = hio_canopy_area_si_age(io_si,cpatch%age_class) & + + ccohort%c_area * AREA_INV + + ! Update biomass components + hio_bleaf_pa(io_pa) = hio_bleaf_pa(io_pa) + n_density * ccohort%bl * g_per_kg + hio_bstore_pa(io_pa) = hio_bstore_pa(io_pa) + n_density * ccohort%bstore * g_per_kg + hio_btotal_pa(io_pa) = hio_btotal_pa(io_pa) + n_density * ccohort%b * g_per_kg + hio_bdead_pa(io_pa) = hio_bdead_pa(io_pa) + n_density * ccohort%bdead * g_per_kg + hio_balive_pa(io_pa) = hio_balive_pa(io_pa) + n_density * ccohort%balive * g_per_kg + + ! Update PFT partitioned biomass components + hio_leafbiomass_si_pft(io_si,ft) = hio_leafbiomass_si_pft(io_si,ft) + & + (ccohort%n * AREA_INV) * ccohort%bl * g_per_kg + + hio_storebiomass_si_pft(io_si,ft) = hio_storebiomass_si_pft(io_si,ft) + & + (ccohort%n * AREA_INV) * ccohort%bstore * g_per_kg + + hio_nindivs_si_pft(io_si,ft) = hio_nindivs_si_pft(io_si,ft) + & + ccohort%n * AREA_INV + + hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & + (ccohort%n * AREA_INV) * ccohort%b * g_per_kg + + ! Site by Size-Class x PFT (SCPF) + ! ------------------------------------------------------------------------ + + dbh = ccohort%dbh !-0.5*(1./365.25)*ccohort%ddbhdt + + ! Flux Variables (cohorts must had experienced a day before any of these values + ! have any meaning, otherwise they are just inialization values + if( .not.(ccohort%isnew) ) then + + associate( scpf => ccohort%size_by_pft_class, & + scls => ccohort%size_class ) + + hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + & + n_perm2*ccohort%gpp_acc_hold ! [kgC/m2/yr] + hio_npp_totl_si_scpf(io_si,scpf) = hio_npp_totl_si_scpf(io_si,scpf) + & + ccohort%npp_acc_hold *n_perm2 + hio_npp_leaf_si_scpf(io_si,scpf) = hio_npp_leaf_si_scpf(io_si,scpf) + & + ccohort%npp_leaf*n_perm2 + hio_npp_fnrt_si_scpf(io_si,scpf) = hio_npp_fnrt_si_scpf(io_si,scpf) + & + ccohort%npp_froot*n_perm2 + hio_npp_bgsw_si_scpf(io_si,scpf) = hio_npp_bgsw_si_scpf(io_si,scpf) + & + ccohort%npp_bsw*(1._r8-ED_val_ag_biomass)*n_perm2 + hio_npp_agsw_si_scpf(io_si,scpf) = hio_npp_agsw_si_scpf(io_si,scpf) + & + ccohort%npp_bsw*ED_val_ag_biomass*n_perm2 + hio_npp_bgdw_si_scpf(io_si,scpf) = hio_npp_bgdw_si_scpf(io_si,scpf) + & + ccohort%npp_bdead*(1._r8-ED_val_ag_biomass)*n_perm2 + hio_npp_agdw_si_scpf(io_si,scpf) = hio_npp_agdw_si_scpf(io_si,scpf) + & + ccohort%npp_bdead*ED_val_ag_biomass*n_perm2 + hio_npp_seed_si_scpf(io_si,scpf) = hio_npp_seed_si_scpf(io_si,scpf) + & + ccohort%npp_bseed*n_perm2 + hio_npp_stor_si_scpf(io_si,scpf) = hio_npp_stor_si_scpf(io_si,scpf) + & + ccohort%npp_store*n_perm2 + + if( abs(ccohort%npp_acc_hold-(ccohort%npp_leaf+ccohort%npp_froot+ & + ccohort%npp_bsw+ccohort%npp_bdead+ & + ccohort%npp_bseed+ccohort%npp_store))>1.e-9) then + write(fates_log(),*) 'NPP Partitions are not balancing' + write(fates_log(),*) 'Fractional Error: ', & + abs(ccohort%npp_acc_hold-(ccohort%npp_leaf+ccohort%npp_froot+ & + ccohort%npp_bsw+ccohort%npp_bdead+ & + ccohort%npp_bseed+ccohort%npp_store))/ccohort%npp_acc_hold + write(fates_log(),*) 'Terms: ',ccohort%npp_acc_hold,ccohort%npp_leaf,ccohort%npp_froot, & + ccohort%npp_bsw,ccohort%npp_bdead, & + ccohort%npp_bseed,ccohort%npp_store + write(fates_log(),*) ' NPP components during FATES-HLM linking does not balance ' + stop ! we need termination control for FATES!!! + ! call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + ! Woody State Variables (basal area and number density and mortality) + if (EDPftvarcon_inst%woody(ft) == 1) then + + hio_m1_si_scpf(io_si,scpf) = hio_m1_si_scpf(io_si,scpf) + ccohort%bmort*ccohort%n + hio_m2_si_scpf(io_si,scpf) = hio_m2_si_scpf(io_si,scpf) + ccohort%hmort*ccohort%n + hio_m3_si_scpf(io_si,scpf) = hio_m3_si_scpf(io_si,scpf) + ccohort%cmort*ccohort%n + hio_m4_si_scpf(io_si,scpf) = hio_m4_si_scpf(io_si,scpf) + ccohort%imort*ccohort%n + hio_m5_si_scpf(io_si,scpf) = hio_m5_si_scpf(io_si,scpf) + ccohort%fmort*ccohort%n + + ! basal area [m2/ha] + hio_ba_si_scpf(io_si,scpf) = hio_ba_si_scpf(io_si,scpf) + & + 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*ccohort%n + ! also by size class only + hio_ba_si_scls(io_si,scls) = hio_ba_si_scls(io_si,scls) + & + 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*ccohort%n + + ! number density [/ha] + hio_nplant_si_scpf(io_si,scpf) = hio_nplant_si_scpf(io_si,scpf) + ccohort%n + + ! growth increment + hio_ddbh_si_scpf(io_si,scpf) = hio_ddbh_si_scpf(io_si,scpf) + & + ccohort%ddbhdt*ccohort%n + end if + + ! update size-class x patch-age related quantities + + iscag = get_sizeage_class_index(ccohort%dbh,cpatch%age) + + hio_nplant_si_scag(io_si,iscag) = hio_nplant_si_scag(io_si,iscag) + ccohort%n + + ! update SCPF/SCLS- and canopy/subcanopy- partitioned quantities + if (ccohort%canopy_layer .eq. 1) then + hio_bstor_canopy_si_scpf(io_si,scpf) = hio_bstor_canopy_si_scpf(io_si,scpf) + & + ccohort%bstore * ccohort%n + hio_bleaf_canopy_si_scpf(io_si,scpf) = hio_bleaf_canopy_si_scpf(io_si,scpf) + & + ccohort%bl * ccohort%n + hio_canopy_biomass_pa(io_pa) = hio_canopy_biomass_pa(io_pa) + n_density * ccohort%b * g_per_kg + hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n + hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + ccohort%n + hio_nplant_canopy_si_scls(io_si,scls) = hio_nplant_canopy_si_scls(io_si,scls) + ccohort%n + hio_gpp_canopy_si_scpf(io_si,scpf) = hio_gpp_canopy_si_scpf(io_si,scpf) + & + n_perm2*ccohort%gpp_acc_hold + hio_ar_canopy_si_scpf(io_si,scpf) = hio_ar_canopy_si_scpf(io_si,scpf) + & + n_perm2*ccohort%resp_acc_hold + ! growth increment + hio_ddbh_canopy_si_scpf(io_si,scpf) = hio_ddbh_canopy_si_scpf(io_si,scpf) + & + ccohort%ddbhdt*ccohort%n + ! 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%imort + ccohort%fmort) * ccohort%n + hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * & + ccohort%b * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + ! + hio_leaf_md_canopy_si_scls(io_si,scls) = hio_leaf_md_canopy_si_scls(io_si,scls) + & + ccohort%leaf_md * ccohort%n + hio_root_md_canopy_si_scls(io_si,scls) = hio_root_md_canopy_si_scls(io_si,scls) + & + ccohort%root_md * ccohort%n + hio_carbon_balance_canopy_si_scls(io_si,scls) = hio_carbon_balance_canopy_si_scls(io_si,scls) + & + ccohort%carbon_balance * ccohort%n + hio_seed_prod_canopy_si_scls(io_si,scls) = hio_seed_prod_canopy_si_scls(io_si,scls) + & + ccohort%seed_prod * ccohort%n + hio_dbalivedt_canopy_si_scls(io_si,scls) = hio_dbalivedt_canopy_si_scls(io_si,scls) + & + ccohort%dbalivedt * ccohort%n + hio_dbdeaddt_canopy_si_scls(io_si,scls) = hio_dbdeaddt_canopy_si_scls(io_si,scls) + & + ccohort%dbdeaddt * ccohort%n + hio_dbstoredt_canopy_si_scls(io_si,scls) = hio_dbstoredt_canopy_si_scls(io_si,scls) + & + ccohort%dbstoredt * ccohort%n + hio_storage_flux_canopy_si_scls(io_si,scls) = hio_storage_flux_canopy_si_scls(io_si,scls) + & + ccohort%storage_flux * ccohort%n + hio_npp_leaf_canopy_si_scls(io_si,scls) = hio_npp_leaf_canopy_si_scls(io_si,scls) + & + ccohort%npp_leaf * ccohort%n + hio_npp_froot_canopy_si_scls(io_si,scls) = hio_npp_froot_canopy_si_scls(io_si,scls) + & + ccohort%npp_froot * ccohort%n + hio_npp_bsw_canopy_si_scls(io_si,scls) = hio_npp_bsw_canopy_si_scls(io_si,scls) + & + ccohort%npp_bsw * ccohort%n + hio_npp_bdead_canopy_si_scls(io_si,scls) = hio_npp_bdead_canopy_si_scls(io_si,scls) + & + ccohort%npp_bdead * ccohort%n + hio_npp_bseed_canopy_si_scls(io_si,scls) = hio_npp_bseed_canopy_si_scls(io_si,scls) + & + ccohort%npp_bseed * ccohort%n + hio_npp_store_canopy_si_scls(io_si,scls) = hio_npp_store_canopy_si_scls(io_si,scls) + & + ccohort%npp_store * ccohort%n + hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) = & + hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) + & + ccohort%canopy_layer_yesterday * ccohort%n + else + hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & + ccohort%bstore * ccohort%n + hio_bleaf_understory_si_scpf(io_si,scpf) = hio_bleaf_understory_si_scpf(io_si,scpf) + & + ccohort%bl * ccohort%n + hio_understory_biomass_pa(io_pa) = hio_understory_biomass_pa(io_pa) + n_density * ccohort%b * g_per_kg + hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * ccohort%n + hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + ccohort%n + hio_nplant_understory_si_scls(io_si,scls) = hio_nplant_understory_si_scls(io_si,scls) + ccohort%n + hio_gpp_understory_si_scpf(io_si,scpf) = hio_gpp_understory_si_scpf(io_si,scpf) + & + n_perm2*ccohort%gpp_acc_hold + hio_ar_understory_si_scpf(io_si,scpf) = hio_ar_understory_si_scpf(io_si,scpf) + & + n_perm2*ccohort%resp_acc_hold + ! growth increment + hio_ddbh_understory_si_scpf(io_si,scpf) = hio_ddbh_understory_si_scpf(io_si,scpf) + & + ccohort%ddbhdt*ccohort%n + ! 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%imort + ccohort%fmort) * ccohort%n + hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%imort + ccohort%fmort) * & + ccohort%b * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + ! + hio_leaf_md_understory_si_scls(io_si,scls) = hio_leaf_md_understory_si_scls(io_si,scls) + & + ccohort%leaf_md * ccohort%n + hio_root_md_understory_si_scls(io_si,scls) = hio_root_md_understory_si_scls(io_si,scls) + & + ccohort%root_md * ccohort%n + hio_carbon_balance_understory_si_scls(io_si,scls) = hio_carbon_balance_understory_si_scls(io_si,scls) + & + ccohort%carbon_balance * ccohort%n + hio_seed_prod_understory_si_scls(io_si,scls) = hio_seed_prod_understory_si_scls(io_si,scls) + & + ccohort%seed_prod * ccohort%n + hio_dbalivedt_understory_si_scls(io_si,scls) = hio_dbalivedt_understory_si_scls(io_si,scls) + & + ccohort%dbalivedt * ccohort%n + hio_dbdeaddt_understory_si_scls(io_si,scls) = hio_dbdeaddt_understory_si_scls(io_si,scls) + & + ccohort%dbdeaddt * ccohort%n + hio_dbstoredt_understory_si_scls(io_si,scls) = hio_dbstoredt_understory_si_scls(io_si,scls) + & + ccohort%dbstoredt * ccohort%n + hio_storage_flux_understory_si_scls(io_si,scls) = hio_storage_flux_understory_si_scls(io_si,scls) + & + ccohort%storage_flux * ccohort%n + hio_npp_leaf_understory_si_scls(io_si,scls) = hio_npp_leaf_understory_si_scls(io_si,scls) + & + ccohort%npp_leaf * ccohort%n + hio_npp_froot_understory_si_scls(io_si,scls) = hio_npp_froot_understory_si_scls(io_si,scls) + & + ccohort%npp_froot * ccohort%n + hio_npp_bsw_understory_si_scls(io_si,scls) = hio_npp_bsw_understory_si_scls(io_si,scls) + & + ccohort%npp_bsw * ccohort%n + hio_npp_bdead_understory_si_scls(io_si,scls) = hio_npp_bdead_understory_si_scls(io_si,scls) + & + ccohort%npp_bdead * ccohort%n + hio_npp_bseed_understory_si_scls(io_si,scls) = hio_npp_bseed_understory_si_scls(io_si,scls) + & + ccohort%npp_bseed * ccohort%n + hio_npp_store_understory_si_scls(io_si,scls) = hio_npp_store_understory_si_scls(io_si,scls) + & + ccohort%npp_store * ccohort%n + hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) = & + hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) + & + ccohort%canopy_layer_yesterday * ccohort%n + endif + ! + ccohort%canopy_layer_yesterday = real(ccohort%canopy_layer, r8) + + end associate + end if + + ccohort => ccohort%taller + enddo ! cohort loop + + ! Patch specific variables that are already calculated + ! These things are all duplicated. Should they all be converted to LL or array structures RF? + ! define scalar to counteract the patch albedo scaling logic for conserved quantities + + if (cpatch%area .gt. 0._r8 .and. cpatch%total_canopy_area .gt.0 ) then + patch_scaling_scalar = min(1._r8, cpatch%area / cpatch%total_canopy_area) + else + patch_scaling_scalar = 0._r8 + endif + + ! Update Fire Variables + hio_nesterov_fire_danger_pa(io_pa) = sites(s)%acc_NI + hio_spitfire_ros_pa(io_pa) = cpatch%ROS_front + hio_effect_wspeed_pa(io_pa) = cpatch%effect_wspeed + hio_tfc_ros_pa(io_pa) = cpatch%TFC_ROS + hio_fire_intensity_pa(io_pa) = cpatch%FI + hio_fire_area_pa(io_pa) = cpatch%frac_burnt + hio_scorch_height_pa(io_pa) = cpatch%SH + hio_fire_fuel_bulkd_pa(io_pa) = cpatch%fuel_bulkd + hio_fire_fuel_eff_moist_pa(io_pa) = cpatch%fuel_eff_moist + hio_fire_fuel_sav_pa(io_pa) = cpatch%fuel_sav + hio_fire_fuel_mef_pa(io_pa) = cpatch%fuel_mef + hio_sum_fuel_pa(io_pa) = cpatch%sum_fuel * g_per_kg * patch_scaling_scalar + + do i_fuel = 1,nfsc + hio_litter_moisture_si_fuel(io_si, i_fuel) = hio_litter_moisture_si_fuel(io_si, i_fuel) + & + cpatch%litter_moisture(i_fuel) * cpatch%area * AREA_INV + end do + ! Update Litter Flux Variables + + ! put litter_in flux onto site level variable so as to be able to append site-level distubance-related input flux after patch loop + hio_litter_in_si(io_si) = hio_litter_in_si(io_si) + & + (sum(cpatch%CWD_AG_in) +sum(cpatch%leaf_litter_in) + sum(cpatch%root_litter_in)) & + * g_per_kg * cpatch%area * AREA_INV * years_per_day * days_per_sec + ! keep litter_out at patch level + hio_litter_out_pa(io_pa) = (sum(cpatch%CWD_AG_out)+sum(cpatch%leaf_litter_out) & + + sum(cpatch%root_litter_out)) & + * g_per_kg * patch_scaling_scalar * years_per_day * days_per_sec + + hio_seeds_in_pa(io_pa) = sum(cpatch%seeds_in) * & + g_per_kg * patch_scaling_scalar * years_per_day * days_per_sec + hio_seed_decay_pa(io_pa) = sum(cpatch%seed_decay) * & + g_per_kg * patch_scaling_scalar * years_per_day * days_per_sec + hio_seed_germination_pa(io_pa) = sum(cpatch%seed_germination) * & + g_per_kg * patch_scaling_scalar * years_per_day * days_per_sec + + + hio_canopy_spread_pa(io_pa) = cpatch%spread(1) + + do i_cwd = 1, ncwd + hio_cwd_ag_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_si_cwdsc(io_si, i_cwd) + & + cpatch%CWD_AG(i_cwd)*cpatch%area * AREA_INV * g_per_kg + hio_cwd_bg_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_si_cwdsc(io_si, i_cwd) + & + cpatch%CWD_BG(i_cwd)*cpatch%area * AREA_INV * g_per_kg + hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) + & + cpatch%CWD_AG_IN(i_cwd)*cpatch%area * AREA_INV * g_per_kg + hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) + & + cpatch%CWD_BG_IN(i_cwd)*cpatch%area * AREA_INV * g_per_kg + hio_cwd_ag_out_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_out_si_cwdsc(io_si, i_cwd) + & + cpatch%CWD_AG_OUT(i_cwd)*cpatch%area * AREA_INV * g_per_kg + hio_cwd_bg_out_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_out_si_cwdsc(io_si, i_cwd) + & + cpatch%CWD_BG_OUT(i_cwd)*cpatch%area * AREA_INV * g_per_kg + end do + + ipa = ipa + 1 + cpatch => cpatch%younger + end do !patch loop + + ! divide so-far-just-summed but to-be-averaged patch-age-class variables by patch-age-class area to get mean values + do ipa2 = 1, nlevage_ed + if (hio_area_si_age(io_si, ipa2) .gt. tiny) then + hio_lai_si_age(io_si, ipa2) = hio_lai_si_age(io_si, ipa2) / (hio_area_si_age(io_si, ipa2)*AREA) + hio_ncl_si_age(io_si, ipa2) = hio_ncl_si_age(io_si, ipa2) / (hio_area_si_age(io_si, ipa2)*AREA) + else + hio_lai_si_age(io_si, ipa2) = 0._r8 + hio_ncl_si_age(io_si, ipa2) = 0._r8 + endif + end do + + ! pass the cohort termination mortality as a flux to the history, and then reset the termination mortality buffer + ! note there are various ways of reporting the total mortality, so pass to these as well + do i_pft = 1, maxpft + do i_scls = 1,nlevsclass_ed + i_scpf = (i_pft-1)*nlevsclass_ed + i_scls + hio_m6_si_scpf(io_si,i_scpf) = (sites(s)%terminated_nindivs(i_scls,i_pft,1) + & + sites(s)%terminated_nindivs(i_scls,i_pft,2)) * days_per_year + hio_mortality_canopy_si_scls(io_si,i_scls) = hio_mortality_canopy_si_scls(io_si,i_scls) + & + sites(s)%terminated_nindivs(i_scls,i_pft,1) * days_per_year + hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & + sites(s)%terminated_nindivs(i_scls,i_pft,2) * days_per_year + hio_mortality_canopy_si_scpf(io_si,i_scpf) = hio_mortality_canopy_si_scpf(io_si,i_scpf) + & + sites(s)%terminated_nindivs(i_scls,i_pft,1) * days_per_year + hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & + sites(s)%terminated_nindivs(i_scls,i_pft,2) * days_per_year + end do + end do + sites(s)%terminated_nindivs(:,:,:) = 0._r8 + + ! pass the recruitment rate as a flux to the history, and then reset the recruitment buffer + do i_pft = 1, maxpft + hio_recruitment_si_pft(io_si,i_pft) = sites(s)%recruitment_rate(i_pft) * days_per_year + end do + sites(s)%recruitment_rate(:) = 0._r8 + + ! summarize all of the mortality fluxes by PFT + do i_pft = 1, maxpft + do i_scls = 1,nlevsclass_ed + i_scpf = (i_pft-1)*nlevsclass_ed + i_scls + hio_mortality_si_pft(io_si,i_pft) = hio_mortality_si_pft(io_si,i_pft) + & + hio_m1_si_scpf(io_si,i_scpf) + & + hio_m2_si_scpf(io_si,i_scpf) + & + hio_m3_si_scpf(io_si,i_scpf) + & + hio_m4_si_scpf(io_si,i_scpf) + & + hio_m5_si_scpf(io_si,i_scpf) + & + hio_m6_si_scpf(io_si,i_scpf) + end do + end do + + ! pass demotion rates and associated carbon fluxes to history + do i_scls = 1,nlevsclass_ed + hio_demotion_rate_si_scls(io_si,i_scls) = sites(s)%demotion_rate(i_scls) * days_per_year + hio_promotion_rate_si_scls(io_si,i_scls) = sites(s)%promotion_rate(i_scls) * days_per_year + end do + ! + ! convert kg C / ha / day to gc / m2 / sec + hio_demotion_carbonflux_si(io_si) = sites(s)%demotion_carbonflux * g_per_kg * ha_per_m2 * days_per_sec + hio_promotion_carbonflux_si(io_si) = sites(s)%promotion_carbonflux * g_per_kg * ha_per_m2 * days_per_sec + ! + ! mortality-associated carbon fluxes + + hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & + sites(s)%termination_carbonflux(ican_upper) * g_per_kg * days_per_sec * ha_per_m2 + hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & + sites(s)%termination_carbonflux(ican_ustory) * g_per_kg * days_per_sec * ha_per_m2 + ! and zero the site-level termination carbon flux variable + sites(s)%termination_carbonflux(:) = 0._r8 + ! + ! add the site-level disturbance-associated cwd and litter input fluxes to thir respective flux fields + do i_cwd = 1, ncwd + hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) + & + sites(s)%CWD_AG_diagnostic_input_carbonflux(i_cwd) * g_per_kg + hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) + & + sites(s)%CWD_BG_diagnostic_input_carbonflux(i_cwd) * g_per_kg + end do + hio_litter_in_si(io_si) = hio_litter_in_si(io_si) + & + (sum(sites(s)%leaf_litter_diagnostic_input_carbonflux) + & + sum(sites(s)%root_litter_diagnostic_input_carbonflux)) * g_per_kg * days_per_sec * years_per_day + ! and reset the disturbance-related field buffers + sites(s)%CWD_AG_diagnostic_input_carbonflux(:) = 0._r8 + sites(s)%CWD_BG_diagnostic_input_carbonflux(:) = 0._r8 + sites(s)%leaf_litter_diagnostic_input_carbonflux(:) = 0._r8 + sites(s)%root_litter_diagnostic_input_carbonflux(:) = 0._r8 + + enddo ! site loop + + end associate + + return + end subroutine update_history_dyn + + ! ====================================================================================== + + subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) + + ! --------------------------------------------------------------------------------- + ! This is the call to update the history IO arrays that are expected to only change + ! after rapid timescale productivity calculations (gpp and respiration). + ! --------------------------------------------------------------------------------- + + use EDtypesMod , only : ed_site_type, & + ed_cohort_type, & + ed_patch_type, & + AREA, & + AREA_INV, & + nlevage_ed, & + nlevsclass_ed + use EDTypesMod, only : numpft_ed, nclmax, nlevleaf + ! + ! Arguments + class(fates_history_interface_type) :: this + integer , intent(in) :: nc ! clump index + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + real(r8) , intent(in) :: dt_tstep + + ! Locals + integer :: s ! The local site index + integer :: io_si ! The site index of the IO array + integer :: ipa ! The local "I"ndex of "PA"tches + integer :: io_pa ! The patch index of the IO array + integer :: io_pa1 ! The first patch index in the IO array for each site + integer :: io_soipa + integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread + integer :: ivar ! index of IO variable object vector + integer :: ft ! functional type index + real(r8) :: n_density ! individual of cohort per m2. + real(r8) :: n_perm2 ! individuals per m2 for the whole column + real(r8) :: patch_area_by_age(nlevage_ed) ! patch area in each bin for normalizing purposes + real(r8), parameter :: tiny = 1.e-5_r8 ! some small number + integer :: ipa2 ! patch incrementer + integer :: cnlfpft_indx, cnlf_indx, ipft, ican, ileaf ! more iterators and indices + type(fates_history_variable_type),pointer :: hvar + type(ed_patch_type),pointer :: cpatch + type(ed_cohort_type),pointer :: ccohort + real(r8) :: per_dt_tstep ! Time step in frequency units (/s) + + associate( hio_gpp_pa => this%hvars(ih_gpp_pa)%r81d, & + hio_npp_pa => this%hvars(ih_npp_pa)%r81d, & + hio_aresp_pa => this%hvars(ih_aresp_pa)%r81d, & + hio_maint_resp_pa => this%hvars(ih_maint_resp_pa)%r81d, & + hio_growth_resp_pa => this%hvars(ih_growth_resp_pa)%r81d, & + hio_npp_si => this%hvars(ih_npp_si)%r81d, & + hio_ar_si_scpf => this%hvars(ih_ar_si_scpf)%r82d, & + hio_ar_grow_si_scpf => this%hvars(ih_ar_grow_si_scpf)%r82d, & + hio_ar_maint_si_scpf => this%hvars(ih_ar_maint_si_scpf)%r82d, & + hio_ar_agsapm_si_scpf => this%hvars(ih_ar_agsapm_si_scpf)%r82d, & + hio_ar_darkm_si_scpf => this%hvars(ih_ar_darkm_si_scpf)%r82d, & + hio_ar_crootm_si_scpf => this%hvars(ih_ar_crootm_si_scpf)%r82d, & + hio_ar_frootm_si_scpf => this%hvars(ih_ar_frootm_si_scpf)%r82d, & + hio_gpp_canopy_pa => this%hvars(ih_gpp_canopy_pa)%r81d, & + hio_ar_canopy_pa => this%hvars(ih_ar_canopy_pa)%r81d, & + hio_gpp_understory_pa => this%hvars(ih_gpp_understory_pa)%r81d, & + hio_ar_understory_pa => this%hvars(ih_ar_understory_pa)%r81d, & + hio_rdark_canopy_si_scls => this%hvars(ih_rdark_canopy_si_scls)%r82d, & + hio_livestem_mr_canopy_si_scls => this%hvars(ih_livestem_mr_canopy_si_scls)%r82d, & + hio_livecroot_mr_canopy_si_scls => this%hvars(ih_livecroot_mr_canopy_si_scls)%r82d, & + hio_froot_mr_canopy_si_scls => this%hvars(ih_froot_mr_canopy_si_scls)%r82d, & + hio_resp_g_canopy_si_scls => this%hvars(ih_resp_g_canopy_si_scls)%r82d, & + hio_resp_m_canopy_si_scls => this%hvars(ih_resp_m_canopy_si_scls)%r82d, & + hio_rdark_understory_si_scls => this%hvars(ih_rdark_understory_si_scls)%r82d, & + hio_livestem_mr_understory_si_scls => this%hvars(ih_livestem_mr_understory_si_scls)%r82d, & + hio_livecroot_mr_understory_si_scls => this%hvars(ih_livecroot_mr_understory_si_scls)%r82d, & + hio_froot_mr_understory_si_scls => this%hvars(ih_froot_mr_understory_si_scls)%r82d, & + hio_resp_g_understory_si_scls => this%hvars(ih_resp_g_understory_si_scls)%r82d, & + hio_resp_m_understory_si_scls => this%hvars(ih_resp_m_understory_si_scls)%r82d, & + hio_gpp_si_age => this%hvars(ih_gpp_si_age)%r82d, & + hio_npp_si_age => this%hvars(ih_npp_si_age)%r82d, & + hio_parsun_z_si_cnlf => this%hvars(ih_parsun_z_si_cnlf)%r82d, & + hio_parsha_z_si_cnlf => this%hvars(ih_parsha_z_si_cnlf)%r82d, & + hio_parsun_z_si_cnlfpft => this%hvars(ih_parsun_z_si_cnlfpft)%r82d, & + hio_parsha_z_si_cnlfpft => this%hvars(ih_parsha_z_si_cnlfpft)%r82d, & + hio_laisun_z_si_cnlf => this%hvars(ih_laisun_z_si_cnlf)%r82d, & + hio_laisha_z_si_cnlf => this%hvars(ih_laisha_z_si_cnlf)%r82d, & + hio_laisun_z_si_cnlfpft => this%hvars(ih_laisun_z_si_cnlfpft)%r82d, & + hio_laisha_z_si_cnlfpft => this%hvars(ih_laisha_z_si_cnlfpft)%r82d, & + hio_laisun_top_si_can => this%hvars(ih_laisun_top_si_can)%r82d, & + hio_laisha_top_si_can => this%hvars(ih_laisha_top_si_can)%r82d, & + hio_fabd_sun_si_cnlfpft => this%hvars(ih_fabd_sun_si_cnlfpft)%r82d, & + hio_fabd_sha_si_cnlfpft => this%hvars(ih_fabd_sha_si_cnlfpft)%r82d, & + hio_fabi_sun_si_cnlfpft => this%hvars(ih_fabi_sun_si_cnlfpft)%r82d, & + hio_fabi_sha_si_cnlfpft => this%hvars(ih_fabi_sha_si_cnlfpft)%r82d, & + hio_fabd_sun_si_cnlf => this%hvars(ih_fabd_sun_si_cnlf)%r82d, & + hio_fabd_sha_si_cnlf => this%hvars(ih_fabd_sha_si_cnlf)%r82d, & + hio_fabi_sun_si_cnlf => this%hvars(ih_fabi_sun_si_cnlf)%r82d, & + hio_fabi_sha_si_cnlf => this%hvars(ih_fabi_sha_si_cnlf)%r82d, & + hio_fabd_sun_top_si_can => this%hvars(ih_fabd_sun_top_si_can)%r82d, & + hio_fabd_sha_top_si_can => this%hvars(ih_fabd_sha_top_si_can)%r82d, & + hio_fabi_sun_top_si_can => this%hvars(ih_fabi_sun_top_si_can)%r82d, & + hio_fabi_sha_top_si_can => this%hvars(ih_fabi_sha_top_si_can)%r82d, & + hio_parsun_top_si_can => this%hvars(ih_parsun_top_si_can)%r82d, & + hio_parsha_top_si_can => this%hvars(ih_parsha_top_si_can)%r82d & + ) + + + ! Flush the relevant history variables + call this%flush_hvars(nc,upfreq_in=2) + + per_dt_tstep = 1.0_r8/dt_tstep + + do s = 1,nsites + + io_si = this%iovar_map(nc)%site_index(s) + io_pa1 = this%iovar_map(nc)%patch1_index(s) + io_soipa = io_pa1-1 + + ipa = 0 + cpatch => sites(s)%oldest_patch + + patch_area_by_age(:) = 0._r8 + + do while(associated(cpatch)) + + io_pa = io_pa1 + ipa + + patch_area_by_age(cpatch%age_class) = patch_area_by_age(cpatch%age_class) + cpatch%area + + ccohort => cpatch%shortest + do while(associated(ccohort)) + + ! TODO: we need a standardized logical function on this (used lots, RGK) + if ((cpatch%area .gt. 0._r8) .and. (cpatch%total_canopy_area .gt. 0._r8)) then + n_density = ccohort%n/min(cpatch%area,cpatch%total_canopy_area) + n_perm2 = ccohort%n * AREA_INV + else + n_density = 0.0_r8 + n_perm2 = 0.0_r8 + endif + + if ( .not. ccohort%isnew ) then + + ! Calculate index for the scpf class + associate( scpf => ccohort%size_by_pft_class, & + scls => ccohort%size_class ) + + ! scale up cohort fluxes to their patches + hio_npp_pa(io_pa) = hio_npp_pa(io_pa) + & + ccohort%npp_tstep * g_per_kg * n_density * per_dt_tstep + hio_gpp_pa(io_pa) = hio_gpp_pa(io_pa) + & + ccohort%gpp_tstep * g_per_kg * n_density * per_dt_tstep + hio_aresp_pa(io_pa) = hio_aresp_pa(io_pa) + & + ccohort%resp_tstep * g_per_kg * n_density * per_dt_tstep + hio_growth_resp_pa(io_pa) = hio_growth_resp_pa(io_pa) + & + ccohort%resp_g * g_per_kg * n_density * per_dt_tstep + hio_maint_resp_pa(io_pa) = hio_maint_resp_pa(io_pa) + & + ccohort%resp_m * g_per_kg * n_density * per_dt_tstep + + ! map ed cohort-level npp fluxes to clm column fluxes + hio_npp_si(io_si) = hio_npp_si(io_si) + ccohort%npp_tstep * n_perm2 * g_per_kg * per_dt_tstep + + + ! Total AR (kgC/m2/yr) = (kgC/plant/step) / (s/step) * (plant/m2) * (s/yr) + hio_ar_si_scpf(io_si,scpf) = hio_ar_si_scpf(io_si,scpf) + & + (ccohort%resp_tstep/dt_tstep) * n_perm2 * sec_per_day * days_per_year + + ! Growth AR (kgC/m2/yr) + hio_ar_grow_si_scpf(io_si,scpf) = hio_ar_grow_si_scpf(io_si,scpf) + & + (ccohort%resp_g/dt_tstep) * n_perm2 * sec_per_day * days_per_year + + ! Maint AR (kgC/m2/yr) + hio_ar_maint_si_scpf(io_si,scpf) = hio_ar_maint_si_scpf(io_si,scpf) + & + (ccohort%resp_m/dt_tstep) * n_perm2 * sec_per_day * days_per_year + + ! Maintenance AR partition variables are stored as rates (kgC/plant/s) + ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + hio_ar_agsapm_si_scpf(io_si,scpf) = hio_ar_agsapm_si_scpf(io_si,scpf) + & + ccohort%livestem_mr * n_perm2 * sec_per_day * days_per_year + + ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + hio_ar_darkm_si_scpf(io_si,scpf) = hio_ar_darkm_si_scpf(io_si,scpf) + & + ccohort%rdark * n_perm2 * sec_per_day * days_per_year + + ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + hio_ar_crootm_si_scpf(io_si,scpf) = hio_ar_crootm_si_scpf(io_si,scpf) + & + ccohort%livecroot_mr * n_perm2 * sec_per_day * days_per_year + + ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + hio_ar_frootm_si_scpf(io_si,scpf) = hio_ar_frootm_si_scpf(io_si,scpf) + & + ccohort%froot_mr * n_perm2 * sec_per_day * days_per_year + + ! accumulate fluxes per patch age bin + hio_gpp_si_age(io_si,cpatch%age_class) = hio_gpp_si_age(io_si,cpatch%age_class) & + + ccohort%gpp_tstep * ccohort%n * g_per_kg * per_dt_tstep + hio_npp_si_age(io_si,cpatch%age_class) = hio_npp_si_age(io_si,cpatch%age_class) & + + ccohort%npp_tstep * ccohort%n * g_per_kg * per_dt_tstep + + ! accumulate fluxes on canopy- and understory- separated fluxes + if (ccohort%canopy_layer .eq. 1) then + hio_gpp_canopy_pa(io_pa) = hio_gpp_canopy_pa(io_pa) + & + ccohort%gpp_tstep * g_per_kg * n_density * per_dt_tstep + hio_ar_canopy_pa(io_pa) = hio_ar_canopy_pa(io_pa) + & + ccohort%resp_tstep * g_per_kg * n_density * per_dt_tstep + ! + hio_rdark_canopy_si_scls(io_si,scls) = hio_rdark_canopy_si_scls(io_si,scls) + & + ccohort%rdark * g_per_kg * ccohort%n * sec_per_day * days_per_year + hio_livestem_mr_canopy_si_scls(io_si,scls) = hio_livestem_mr_canopy_si_scls(io_si,scls) + & + ccohort%livestem_mr * g_per_kg * ccohort%n * sec_per_day * days_per_year + hio_livecroot_mr_canopy_si_scls(io_si,scls) = hio_livecroot_mr_canopy_si_scls(io_si,scls) + & + ccohort%livecroot_mr * g_per_kg * ccohort%n * sec_per_day * days_per_year + hio_froot_mr_canopy_si_scls(io_si,scls) = hio_froot_mr_canopy_si_scls(io_si,scls) + & + ccohort%froot_mr * g_per_kg * ccohort%n * sec_per_day * days_per_year + hio_resp_g_canopy_si_scls(io_si,scls) = hio_resp_g_canopy_si_scls(io_si,scls) + & + ccohort%resp_g * g_per_kg * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + hio_resp_m_canopy_si_scls(io_si,scls) = hio_resp_m_canopy_si_scls(io_si,scls) + & + ccohort%resp_m * g_per_kg * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + else + hio_gpp_understory_pa(io_pa) = hio_gpp_understory_pa(io_pa) + & + ccohort%gpp_tstep * g_per_kg * n_density * per_dt_tstep + hio_ar_understory_pa(io_pa) = hio_ar_understory_pa(io_pa) + & + ccohort%resp_tstep * g_per_kg * n_density * per_dt_tstep + ! + hio_rdark_understory_si_scls(io_si,scls) = hio_rdark_understory_si_scls(io_si,scls) + & + ccohort%rdark * g_per_kg * ccohort%n * sec_per_day * days_per_year + hio_livestem_mr_understory_si_scls(io_si,scls) = hio_livestem_mr_understory_si_scls(io_si,scls) + & + ccohort%livestem_mr * g_per_kg * ccohort%n * sec_per_day * days_per_year + hio_livecroot_mr_understory_si_scls(io_si,scls) = hio_livecroot_mr_understory_si_scls(io_si,scls) + & + ccohort%livecroot_mr * g_per_kg * ccohort%n * sec_per_day * days_per_year + hio_froot_mr_understory_si_scls(io_si,scls) = hio_froot_mr_understory_si_scls(io_si,scls) + & + ccohort%froot_mr * g_per_kg * ccohort%n * sec_per_day * days_per_year + hio_resp_g_understory_si_scls(io_si,scls) = hio_resp_g_understory_si_scls(io_si,scls) + & + ccohort%resp_g * g_per_kg * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + hio_resp_m_understory_si_scls(io_si,scls) = hio_resp_m_understory_si_scls(io_si,scls) + & + ccohort%resp_m * g_per_kg * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + endif + end associate + endif + + ccohort => ccohort%taller + enddo ! cohort loop + + ! summarize radiation profiles through the canopy + do ipft=1,numpft_ed + do ican=1,nclmax + do ileaf=1,nlevleaf + ! calculate where we are on multiplexed dimensions + cnlfpft_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax + cnlf_indx = ileaf + (ican-1) * nlevleaf + ! + ! first do all the canopy x leaf x pft calculations + hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsun_z_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_parsha_z_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + ! + hio_laisun_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_laisun_z_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_laisha_z_si_cnlfpft(io_si,cnlfpft_indx) = hio_laisha_z_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + ! + hio_fabd_sun_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabd_sun_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabd_sha_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabd_sha_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabi_sun_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabi_sun_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabi_sha_si_cnlfpft(io_si,cnlfpft_indx) = hio_fabi_sha_si_cnlfpft(io_si,cnlfpft_indx) + & + cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + ! + ! summarize across all PFTs + hio_parsun_z_si_cnlf(io_si,cnlf_indx) = hio_parsun_z_si_cnlf(io_si,cnlf_indx) + & + cpatch%ed_parsun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_parsha_z_si_cnlf(io_si,cnlf_indx) = hio_parsha_z_si_cnlf(io_si,cnlf_indx) + & + cpatch%ed_parsha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + ! + hio_laisun_z_si_cnlf(io_si,cnlf_indx) = hio_laisun_z_si_cnlf(io_si,cnlf_indx) + & + cpatch%ed_laisun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_laisha_z_si_cnlf(io_si,cnlf_indx) = hio_laisha_z_si_cnlf(io_si,cnlf_indx) + & + cpatch%ed_laisha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + ! + hio_fabd_sun_si_cnlf(io_si,cnlf_indx) = hio_fabd_sun_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabd_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabd_sha_si_cnlf(io_si,cnlf_indx) = hio_fabd_sha_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabd_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabi_sun_si_cnlf(io_si,cnlf_indx) = hio_fabi_sun_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabi_sun_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + hio_fabi_sha_si_cnlf(io_si,cnlf_indx) = hio_fabi_sha_si_cnlf(io_si,cnlf_indx) + & + cpatch%fabi_sha_z(ican,ipft,ileaf) * cpatch%area * AREA_INV + + end do + ! + ! summarize just the top leaf level across all PFTs, for each canopy level + hio_parsun_top_si_can(io_si,ican) = hio_parsun_top_si_can(io_si,ican) + & + cpatch%ed_parsun_z(ican,ipft,1) * cpatch%area * AREA_INV + hio_parsha_top_si_can(io_si,ican) = hio_parsha_top_si_can(io_si,ican) + & + cpatch%ed_parsha_z(ican,ipft,1) * cpatch%area * AREA_INV + ! + hio_laisun_top_si_can(io_si,ican) = hio_laisun_top_si_can(io_si,ican) + & + cpatch%ed_laisun_z(ican,ipft,1) * cpatch%area * AREA_INV + hio_laisha_top_si_can(io_si,ican) = hio_laisha_top_si_can(io_si,ican) + & + cpatch%ed_laisha_z(ican,ipft,1) * cpatch%area * AREA_INV + ! + hio_fabd_sun_top_si_can(io_si,ican) = hio_fabd_sun_top_si_can(io_si,ican) + & + cpatch%fabd_sun_z(ican,ipft,1) * cpatch%area * AREA_INV + hio_fabd_sha_top_si_can(io_si,ican) = hio_fabd_sha_top_si_can(io_si,ican) + & + cpatch%fabd_sha_z(ican,ipft,1) * cpatch%area * AREA_INV + hio_fabi_sun_top_si_can(io_si,ican) = hio_fabi_sun_top_si_can(io_si,ican) + & + cpatch%fabi_sun_z(ican,ipft,1) * cpatch%area * AREA_INV + hio_fabi_sha_top_si_can(io_si,ican) = hio_fabi_sha_top_si_can(io_si,ican) + & + cpatch%fabi_sha_z(ican,ipft,1) * cpatch%area * AREA_INV + ! + end do + end do + + + ipa = ipa + 1 + cpatch => cpatch%younger + end do !patch loop + + do ipa2 = 1, nlevage_ed + if (patch_area_by_age(ipa2) .gt. tiny) then + hio_gpp_si_age(io_si, ipa2) = hio_gpp_si_age(io_si, ipa2) / (patch_area_by_age(ipa2)) + hio_npp_si_age(io_si, ipa2) = hio_npp_si_age(io_si, ipa2) / (patch_area_by_age(ipa2)) + else + hio_gpp_si_age(io_si, ipa2) = 0._r8 + hio_npp_si_age(io_si, ipa2) = 0._r8 + endif + end do + + enddo ! site loop + + end associate + + end subroutine update_history_prod + + ! ===================================================================================== + + subroutine update_history_hydraulics(this,nc,nsites,sites,dt_tstep) + + ! --------------------------------------------------------------------------------- + ! This is the call to update the history IO arrays that are expected to only change + ! after rapid timescale productivity calculations (gpp and respiration). + ! --------------------------------------------------------------------------------- + + use EDtypesMod , only : ed_site_type, & + ed_cohort_type, & + ed_patch_type, & + AREA, & + nlevage_ed, & + sclass_ed, & + nlevsclass_ed + + use FatesHydraulicsMemMod, only : ed_cohort_hydr_type + use EDTypesMod , only : use_fates_plant_hydro + use FatesHydraulicsMemMod, only : nlevsoi_hyd + use EDTypesMod , only : nlevsclass_ed + use EDTypesMod , only : do_ed_dynamics + use EDTypesMod , only : maxpft + + ! Arguments + class(fates_history_interface_type) :: this + integer , intent(in) :: nc ! clump index + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + real(r8) , intent(in) :: dt_tstep + + ! Locals + integer :: s ! The local site index + integer :: io_si ! The site index of the IO array + integer :: ipa ! The local "I"ndex of "PA"tches + integer :: io_pa ! The patch index of the IO array + integer :: io_pa1 ! The first patch index in the IO array for each site + integer :: ft ! functional type index + integer :: scpf + real(r8) :: n_density ! individual of cohort per m2. + real(r8) :: n_perm2 ! individuals per m2 for the whole column + real(r8), parameter :: tiny = 1.e-5_r8 ! some small number + real(r8) :: ncohort_scpf(nlevsclass_ed*maxpft) ! Bins to count up cohorts counts used in weighting + ! should be "hio_nplant_si_scpf" + real(r8) :: number_fraction + real(r8) :: number_fraction_rate + integer :: ipa2 ! patch incrementer + integer :: iscpf ! index of the scpf group + + type(fates_history_variable_type),pointer :: hvar + type(ed_patch_type),pointer :: cpatch + type(ed_cohort_type),pointer :: ccohort + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + + real(r8), parameter :: daysecs = 86400.0_r8 ! What modeler doesn't recognize 86400? + real(r8), parameter :: yeardays = 365.0_r8 ! Should this be 365.25? + + if(.not.use_fates_plant_hydro) return + + associate( hio_errh2o_scpf => this%hvars(ih_errh2o_scpf)%r82d, & + hio_tran_scpf => this%hvars(ih_tran_scpf)%r82d, & + hio_rootuptake_scpf => this%hvars(ih_rootuptake_scpf)%r82d, & + hio_rootuptake01_scpf => this%hvars(ih_rootuptake01_scpf)%r82d, & + hio_rootuptake02_scpf => this%hvars(ih_rootuptake02_scpf)%r82d, & + hio_rootuptake03_scpf => this%hvars(ih_rootuptake03_scpf)%r82d, & + hio_rootuptake04_scpf => this%hvars(ih_rootuptake04_scpf)%r82d, & + hio_rootuptake05_scpf => this%hvars(ih_rootuptake05_scpf)%r82d, & + hio_rootuptake06_scpf => this%hvars(ih_rootuptake06_scpf)%r82d, & + hio_rootuptake07_scpf => this%hvars(ih_rootuptake07_scpf)%r82d, & + hio_rootuptake08_scpf => this%hvars(ih_rootuptake08_scpf)%r82d, & + hio_rootuptake09_scpf => this%hvars(ih_rootuptake09_scpf)%r82d, & + hio_rootuptake10_scpf => this%hvars(ih_rootuptake10_scpf)%r82d, & + hio_sapflow_scpf => this%hvars(ih_sapflow_scpf)%r82d, & + hio_iterh1_scpf => this%hvars(ih_iterh1_scpf)%r82d, & + hio_iterh2_scpf => this%hvars(ih_iterh2_scpf)%r82d, & + hio_ath_scpf => this%hvars(ih_ath_scpf)%r82d, & + hio_tth_scpf => this%hvars(ih_tth_scpf)%r82d, & + hio_sth_scpf => this%hvars(ih_sth_scpf)%r82d, & + hio_lth_scpf => this%hvars(ih_lth_scpf)%r82d, & + hio_awp_scpf => this%hvars(ih_awp_scpf)%r82d, & + hio_twp_scpf => this%hvars(ih_twp_scpf)%r82d, & + hio_swp_scpf => this%hvars(ih_swp_scpf)%r82d, & + hio_lwp_scpf => this%hvars(ih_lwp_scpf)%r82d, & + hio_btran_scpf => this%hvars(ih_btran_scpf)%r82d, & + hio_nplant_si_scpf => this%hvars(ih_nplant_si_scpf)%r82d ) + + ! Flush the relevant history variables + call this%flush_hvars(nc,upfreq_in=4) + + do s = 1,nsites + + io_si = this%iovar_map(nc)%site_index(s) + io_pa1 = this%iovar_map(nc)%patch1_index(s) + + ncohort_scpf(:) = 0.0_r8 ! Counter for normalizing weighting + ! factors for cohort mean propoerties + ! This is actually used as a check + ! on hio_nplant_si_scpf + + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + ccohort => cpatch%shortest + do while(associated(ccohort)) + if ( .not. ccohort%isnew ) then + ! Calculate index for the scpf class + iscpf = ccohort%size_by_pft_class + ncohort_scpf(iscpf) = ncohort_scpf(iscpf) + ccohort%n + end if + ccohort => ccohort%taller + enddo ! cohort loop + cpatch => cpatch%younger + end do !patch loop + + + ipa = 0 + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + + io_pa = io_pa1 + ipa + + ccohort => cpatch%shortest + do while(associated(ccohort)) + + ccohort_hydr => ccohort%co_hydr + + ! TODO: we need a standardized logical function on this (used lots, RGK) + if ((cpatch%area .gt. 0._r8) .and. (cpatch%total_canopy_area .gt. 0._r8)) then + n_density = ccohort%n/min(cpatch%area,cpatch%total_canopy_area) + n_perm2 = ccohort%n/AREA + else + n_density = 0.0_r8 + n_perm2 = 0.0_r8 + endif + + if ( .not. ccohort%isnew ) then + + ! Calculate index for the scpf class + iscpf = ccohort%size_by_pft_class + + ! scale up cohort fluxes to their sites + number_fraction_rate = (ccohort%n / ncohort_scpf(iscpf))/dt_tstep + + ! scale cohorts to mean quantity + number_fraction = (ccohort%n / ncohort_scpf(iscpf)) + + hio_errh2o_scpf(io_si,iscpf) = hio_errh2o_scpf(io_si,iscpf) + & + ccohort_hydr%errh2o * number_fraction_rate ! [kg/indiv/s] + + hio_tran_scpf(io_si,iscpf) = hio_tran_scpf(io_si,iscpf) + & + (ccohort_hydr%qtop_dt + ccohort_hydr%dqtopdth_dthdt) * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake_scpf(io_si,iscpf) = hio_rootuptake_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake * number_fraction_rate ! [kg/indiv/s] + + if(nlevsoi_hyd == 10) then + hio_rootuptake01_scpf(io_si,iscpf) = hio_rootuptake01_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake01 * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake02_scpf(io_si,iscpf) = hio_rootuptake02_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake02 * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake03_scpf(io_si,iscpf) = hio_rootuptake03_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake03 * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake04_scpf(io_si,iscpf) = hio_rootuptake04_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake04 * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake05_scpf(io_si,iscpf) = hio_rootuptake05_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake05 * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake06_scpf(io_si,iscpf) = hio_rootuptake06_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake06 * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake07_scpf(io_si,iscpf) = hio_rootuptake07_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake07 * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake08_scpf(io_si,iscpf) = hio_rootuptake08_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake08 * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake09_scpf(io_si,iscpf) = hio_rootuptake09_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake09 * number_fraction_rate ! [kg/indiv/s] + + hio_rootuptake10_scpf(io_si,iscpf) = hio_rootuptake10_scpf(io_si,iscpf) + & + ccohort_hydr%rootuptake10 * number_fraction_rate ! [kg/indiv/s] + + end if + + hio_sapflow_scpf(io_si,iscpf) = hio_sapflow_scpf(io_si,iscpf) + & + ccohort_hydr%sapflow * number_fraction_rate ! [kg/indiv/s] + + hio_iterh1_scpf(io_si,iscpf) = hio_iterh1_scpf(io_si,iscpf) + & + ccohort_hydr%iterh1 * number_fraction ! [-] + + hio_iterh2_scpf(io_si,iscpf) = hio_iterh2_scpf(io_si,iscpf) + & + ccohort_hydr%iterh2 * number_fraction ! [-] + + hio_ath_scpf(io_si,iscpf) = hio_ath_scpf(io_si,iscpf) + & + ccohort_hydr%th_aroot(1) * number_fraction ! [m3 m-3] + + hio_tth_scpf(io_si,iscpf) = hio_tth_scpf(io_si,iscpf) + & + ccohort_hydr%th_bg(1) * number_fraction ! [m3 m-3] + + hio_sth_scpf(io_si,iscpf) = hio_sth_scpf(io_si,iscpf) + & + ccohort_hydr%th_ag(2) * number_fraction ! [m3 m-3] + + hio_lth_scpf(io_si,iscpf) = hio_lth_scpf(io_si,iscpf) + & + ccohort_hydr%th_ag(1) * number_fraction ! [m3 m-3] + + hio_awp_scpf(io_si,iscpf) = hio_awp_scpf(io_si,iscpf) + & + ccohort_hydr%psi_aroot(1) * number_fraction ! [MPa] + + hio_twp_scpf(io_si,iscpf) = hio_twp_scpf(io_si,iscpf) + & + ccohort_hydr%psi_bg(1) * number_fraction ! [MPa] + + hio_swp_scpf(io_si,iscpf) = hio_swp_scpf(io_si,iscpf) + & + ccohort_hydr%psi_ag(2) * number_fraction ! [MPa] + + hio_lwp_scpf(io_si,iscpf) = hio_lwp_scpf(io_si,iscpf) + & + ccohort_hydr%psi_ag(1) * number_fraction ! [MPa] + + hio_btran_scpf(io_si,iscpf) = hio_btran_scpf(io_si,iscpf) + & + ccohort_hydr%btran(1) * number_fraction ! [-] + + endif + + ccohort => ccohort%taller + enddo ! cohort loop + ipa = ipa + 1 + cpatch => cpatch%younger + end do !patch loop + + if(do_ed_dynamics) then + do scpf=1,nlevsclass_ed*maxpft + if( abs(hio_nplant_si_scpf(io_si, scpf)-ncohort_scpf(scpf)) > 1.0E-8_r8 ) then + write(fates_log(),*) 'nplant check on hio_nplant_si_scpf fails during hydraulics history updates' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do + end if + + enddo ! site loop + + end associate + + end subroutine update_history_hydraulics + + ! ==================================================================================== + integer function num_history_vars(this) + + implicit none + + class(fates_history_interface_type), intent(in) :: this + + num_history_vars = this%num_history_vars_ + + end function num_history_vars + + ! ==================================================================================== + + subroutine initialize_history_vars(this) + + implicit none + + class(fates_history_interface_type), intent(inout) :: this + + ! Determine how many of the history IO variables registered in FATES + ! are going to be allocated + call this%define_history_vars(initialize_variables=.false.) + + ! Allocate the list of history output variable objects + allocate(this%hvars(this%num_history_vars())) + + ! construct the object that defines all of the IO variables + call this%define_history_vars(initialize_variables=.true.) + + end subroutine initialize_history_vars + + ! ==================================================================================== + + subroutine define_history_vars(this, initialize_variables) + + ! --------------------------------------------------------------------------------- + ! + ! REGISTRY OF HISTORY OUTPUT VARIABLES + ! + ! This subroutine is called in two contexts, either in count mode or inialize mode + ! In count mode, we just walk through the list of registerred variables, compare + ! if the variable of interest list the current host model and add it to the count + ! if true. This count is used just to allocate the variable space. After this + ! has been done, we go through the list a second time populating a memory structure. + ! This phase is the "initialize" phase. These two phases are differntiated by the + ! string "callstep", which should be either "count" or "initialize". + ! + ! Note 1 there are different ways you can flush or initialize the output fields. + ! If you flush to a native type, (such as zero), the entire slab which covers + ! indices which may not be relevant to FATES, are flushed to this value. So + ! in that case, lakes and crops that are not controlled by FATES will zero'd + ! and when values are scaled up to the land-grid, the zero's for non FATES will + ! be included. This is good and correct if nothing is there. + ! + ! But, what if crops exist in the host model and occupy a fraction of the land-surface + ! shared with natural vegetation? In that case, you want to flush your arrays + ! with a value that the HLM treats as "do not average" + ! + ! If your HLM makes use of, and you want, INTEGER OUTPUT, pass the flushval as + ! a real. The applied flush value will use the NINT() intrinsic function + ! --------------------------------------------------------------------------------- + + use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 + use EDTypesMod , only : use_fates_plant_hydro + use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 + use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 + + implicit none + + class(fates_history_interface_type), intent(inout) :: this + logical, intent(in) :: initialize_variables ! are we 'count'ing or 'initializ'ing? + + integer :: ivar + + ivar=0 + + ! Site level counting variables + call this%set_history_var(vname='ED_NPATCHES', units='none', & + long='Total number of ED patches per site', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=1.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_npatches_si) + + call this%set_history_var(vname='ED_NCOHORTS', units='none', & + long='Total number of ED cohorts per site', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=1.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_ncohorts_si) + + ! Patch variables + call this%set_history_var(vname='TRIMMING', units='none', & + long='Degree to which canopy expansion is limited by leaf economics', & + use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=1.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_trimming_pa) + + call this%set_history_var(vname='AREA_PLANT', units='m2', & + long='area occupied by all plants', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_area_plant_pa) + + call this%set_history_var(vname='AREA_TREES', units='m2', & + long='area occupied by woody plants', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_area_treespread_pa) + + call this%set_history_var(vname='CANOPY_SPREAD', units='0-1', & + long='Scaling factor between tree basal area and canopy area', & + use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_canopy_spread_pa) + + call this%set_history_var(vname='PFTbiomass', units='gC/m2', & + long='total PFT level biomass', use_default='active', & + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_pft ) + + call this%set_history_var(vname='PFTleafbiomass', units='gC/m2', & + long='total PFT level leaf biomass', use_default='active', & + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_leafbiomass_si_pft ) + + call this%set_history_var(vname='PFTstorebiomass', units='gC/m2', & + long='total PFT level stored biomass', use_default='active', & + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_storebiomass_si_pft ) + + call this%set_history_var(vname='PFTnindivs', units='indiv / m2', & + long='total PFT level number of individuals', use_default='active', & + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_nindivs_si_pft ) + + call this%set_history_var(vname='RECRUITMENT', units='indiv/ha/yr', & + long='Rate of recruitment by PFT', use_default='active', & + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_recruitment_si_pft ) + + call this%set_history_var(vname='MORTALITY', units='indiv/ha/yr', & + long='Rate of total mortality by PFT', use_default='active', & + avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_mortality_si_pft ) + + ! patch age class variables + call this%set_history_var(vname='PATCH_AREA_BY_AGE', units='m2/m2', & + long='patch area by age bin', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_area_si_age ) + + call this%set_history_var(vname='LAI_BY_AGE', units='m2/m2', & + long='leaf area index by age bin', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_lai_si_age ) + + call this%set_history_var(vname='CANOPY_AREA_BY_AGE', units='m2/m2', & + long='canopy area by age bin', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_canopy_area_si_age ) + + call this%set_history_var(vname='NCL_BY_AGE', units='--', & + long='number of canopy levels by age bin', use_default='inactive', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_ncl_si_age ) + + call this%set_history_var(vname='NPATCH_BY_AGE', units='--', & + long='number of patches by age bin', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_npatches_si_age ) + + ! Fire Variables + + call this%set_history_var(vname='FIRE_NESTEROV_INDEX', units='none', & + long='nesterov_fire_danger index', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_nesterov_fire_danger_pa) + + call this%set_history_var(vname='FIRE_ROS', units='m/min', & + long='fire rate of spread m/min', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_spitfire_ROS_pa) + + call this%set_history_var(vname='EFFECT_WSPEED', units='none', & + long ='effective windspeed for fire spread', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_effect_wspeed_pa ) + + call this%set_history_var(vname='FIRE_TFC_ROS', units='none', & + long ='total fuel consumed', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_TFC_ROS_pa ) + + call this%set_history_var(vname='FIRE_INTENSITY', units='kJ/m/s', & + long='spitfire fire intensity: kJ/m/s', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_intensity_pa ) + + call this%set_history_var(vname='FIRE_AREA', units='fraction', & + long='spitfire fire area:m2', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_area_pa ) + + call this%set_history_var(vname='SCORCH_HEIGHT', units='m', & + long='spitfire fire area:m2', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_scorch_height_pa ) + + call this%set_history_var(vname='fire_fuel_mef', units='m', & + long='spitfire fuel moisture', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_mef_pa ) + + call this%set_history_var(vname='fire_fuel_bulkd', units='m', & + long='spitfire fuel bulk density', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_bulkd_pa ) + + call this%set_history_var(vname='FIRE_FUEL_EFF_MOIST', units='m', & + long='spitfire fuel moisture', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_eff_moist_pa ) + + call this%set_history_var(vname='fire_fuel_sav', units='m', & + long='spitfire fuel surface/volume ', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_sav_pa ) + + call this%set_history_var(vname='SUM_FUEL', units='gC m-2', & + long='total ground fuel related to ros (omits 1000hr fuels)', & + use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_sum_fuel_pa ) + + call this%set_history_var(vname='FUEL_MOISTURE_NFSC', units='-', & + long='spitfire size-resolved fuel moisture', use_default='active', & + avgflag='A', vtype=site_fuel_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_litter_moisture_si_fuel ) + + ! Litter Variables + + call this%set_history_var(vname='LITTER_IN', units='gC m-2 s-1', & + long='FATES litter flux in', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_litter_in_si ) + + call this%set_history_var(vname='LITTER_OUT', units='gC m-2 s-1', & + long='FATES litter flux out', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_litter_out_pa ) + + call this%set_history_var(vname='SEED_BANK', units='gC m-2', & + long='Total Seed Mass of all PFTs', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_seed_bank_si ) + + call this%set_history_var(vname='SEEDS_IN', units='gC m-2 s-1', & + long='Seed Production Rate', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_seeds_in_pa ) + + call this%set_history_var(vname='SEED_GERMINATION', units='gC m-2 s-1', & + long='Seed mass converted into new cohorts', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_seed_germination_pa ) + + call this%set_history_var(vname='SEED_DECAY', units='gC m-2 s-1', & + long='Seed mass decay', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_seed_decay_pa ) + + call this%set_history_var(vname='ED_bstore', units='gC m-2', & + long='Storage biomass', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_bstore_pa ) + + call this%set_history_var(vname='ED_bdead', units='gC m-2', & + long='Dead (structural) biomass (live trees, not CWD)', & + use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_bdead_pa ) + + call this%set_history_var(vname='ED_balive', units='gC m-2', & + long='Live biomass', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_balive_pa ) + + call this%set_history_var(vname='ED_bleaf', units='gC m-2', & + long='Leaf biomass', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_bleaf_pa ) + + call this%set_history_var(vname='ED_biomass', units='gC m-2', & + long='Total biomass', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_btotal_pa ) + + call this%set_history_var(vname='BIOMASS_CANOPY', units='gC m-2', & + long='Biomass of canopy plants', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_canopy_biomass_pa ) + + call this%set_history_var(vname='BIOMASS_UNDERSTORY', units='gC m-2', & + long='Biomass of understory plants', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_understory_biomass_pa ) + + + ! Ecosystem Carbon Fluxes (updated rapidly, upfreq=2) + + call this%set_history_var(vname='NPP_column', units='gC/m^2/s', & + long='net primary production on the site', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_npp_si ) + + call this%set_history_var(vname='GPP', units='gC/m^2/s', & + long='gross primary production', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_gpp_pa ) + + call this%set_history_var(vname='NPP', units='gC/m^2/s', & + long='net primary production', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_npp_pa ) + + call this%set_history_var(vname='AR', units='gC/m^2/s', & + long='autotrophic respiration', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_aresp_pa ) + + call this%set_history_var(vname='GROWTH_RESP', units='gC/m^2/s', & + long='growth respiration', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_growth_resp_pa ) + + call this%set_history_var(vname='MAINT_RESP', units='gC/m^2/s', & + long='maintenance respiration', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_maint_resp_pa ) + + ! fast fluxes by age bin + call this%set_history_var(vname='NPP_BY_AGE', units='gC/m^2/s', & + long='net primary productivity by age bin', use_default='inactive', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_npp_si_age ) + + call this%set_history_var(vname='GPP_BY_AGE', units='gC/m^2/s', & + long='gross primary productivity by age bin', use_default='inactive', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_gpp_si_age ) + + ! fast fluxes separated canopy/understory + call this%set_history_var(vname='GPP_CANOPY', units='gC/m^2/s', & + long='gross primary production of canopy plants', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_gpp_canopy_pa ) + + call this%set_history_var(vname='AR_CANOPY', units='gC/m^2/s', & + long='autotrophic respiration of canopy plants', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_ar_canopy_pa ) + + call this%set_history_var(vname='GPP_UNDERSTORY', units='gC/m^2/s', & + long='gross primary production of understory plants', use_default='inactive', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_gpp_understory_pa ) + + call this%set_history_var(vname='AR_UNDERSTORY', units='gC/m^2/s', & + long='autotrophic respiration of understory plants', use_default='active', & + avgflag='A', vtype=patch_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_ar_understory_pa ) + + + ! fast radiative fluxes resolved through the canopy + call this%set_history_var(vname='PARSUN_Z_CNLF', units='W/m2', & + long='PAR absorbed in the sun by each canopy and leaf layer', & + use_default='inactive', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_parsun_z_si_cnlf ) + + call this%set_history_var(vname='PARSHA_Z_CNLF', units='W/m2', & + long='PAR absorbed in the shade by each canopy and leaf layer', & + use_default='inactive', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_parsha_z_si_cnlf ) + + call this%set_history_var(vname='PARSUN_Z_CNLFPFT', units='W/m2', & + long='PAR absorbed in the sun by each canopy, leaf, and PFT', & + use_default='inactive', & + avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_parsun_z_si_cnlfpft ) + + call this%set_history_var(vname='PARSHA_Z_CNLFPFT', units='W/m2', & + long='PAR absorbed in the shade by each canopy, leaf, and PFT', & + use_default='inactive', & + avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_parsha_z_si_cnlfpft ) + + call this%set_history_var(vname='PARSUN_Z_CAN', units='W/m2', & + long='PAR absorbed in the sun by top leaf layer in each canopy layer', & + use_default='inactive', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_parsun_top_si_can ) + + call this%set_history_var(vname='PARSHA_Z_CAN', units='W/m2', & + long='PAR absorbed in the shade by top leaf layer in each canopy layer', & + use_default='inactive', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_parsha_top_si_can ) + + call this%set_history_var(vname='LAISUN_Z_CNLF', units='m2/m2', & + long='LAI in the sun by each canopy and leaf layer', & + use_default='inactive', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_laisun_z_si_cnlf ) + + call this%set_history_var(vname='LAISHA_Z_CNLF', units='m2/m2', & + long='LAI in the shade by each canopy and leaf layer', & + use_default='inactive', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_laisha_z_si_cnlf ) + + call this%set_history_var(vname='LAISUN_Z_CNLFPFT', units='m2/m2', & + long='LAI in the sun by each canopy, leaf, and PFT', & + use_default='inactive', & + avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_laisun_z_si_cnlfpft ) + + call this%set_history_var(vname='LAISHA_Z_CNLFPFT', units='m2/m2', & + long='LAI in the shade by each canopy, leaf, and PFT', & + use_default='inactive', & + avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_laisha_z_si_cnlfpft ) + + call this%set_history_var(vname='LAISUN_TOP_CAN', units='m2/m2', & + long='LAI in the sun by the top leaf layer of each canopy layer', & + use_default='inactive', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_laisun_top_si_can ) + + call this%set_history_var(vname='LAISHA_TOP_CAN', units='m2/m2', & + long='LAI in the shade by the top leaf layer of each canopy layer', & + use_default='inactive', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_laisha_top_si_can ) + + call this%set_history_var(vname='FABD_SUN_CNLFPFT', units='fraction', & + long='sun fraction of direct light absorbed by each canopy, leaf, and PFT', & + use_default='inactive', & + avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabd_sun_si_cnlfpft ) + + call this%set_history_var(vname='FABD_SHA_CNLFPFT', units='fraction', & + long='shade fraction of direct light absorbed by each canopy, leaf, and PFT', & + use_default='inactive', & + avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabd_sha_si_cnlfpft ) + + call this%set_history_var(vname='FABI_SUN_CNLFPFT', units='fraction', & + long='sun fraction of indirect light absorbed by each canopy, leaf, and PFT', & + use_default='inactive', & + avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabi_sun_si_cnlfpft ) + + call this%set_history_var(vname='FABI_SHA_CNLFPFT', units='fraction', & + long='shade fraction of indirect light absorbed by each canopy, leaf, and PFT', & + use_default='inactive', & + avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabi_sha_si_cnlfpft ) + + call this%set_history_var(vname='FABD_SUN_CNLF', units='fraction', & + long='sun fraction of direct light absorbed by each canopy and leaf layer', & + use_default='inactive', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabd_sun_si_cnlf ) + + call this%set_history_var(vname='FABD_SHA_CNLF', units='fraction', & + long='shade fraction of direct light absorbed by each canopy and leaf layer', & + use_default='inactive', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabd_sha_si_cnlf ) + + call this%set_history_var(vname='FABI_SUN_CNLF', units='fraction', & + long='sun fraction of indirect light absorbed by each canopy and leaf layer', & + use_default='inactive', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabi_sun_si_cnlf ) + + call this%set_history_var(vname='FABI_SHA_CNLF', units='fraction', & + long='shade fraction of indirect light absorbed by each canopy and leaf layer', & + use_default='inactive', & + avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabi_sha_si_cnlf ) + + call this%set_history_var(vname='FABD_SUN_TOPLF_BYCANLAYER', units='fraction', & + long='sun fraction of direct light absorbed by the top leaf layer of each canopy layer', & + use_default='inactive', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabd_sun_top_si_can ) + + call this%set_history_var(vname='FABD_SHA_TOPLF_BYCANLAYER', units='fraction', & + long='shade fraction of direct light absorbed by the top leaf layer of each canopy layer', & + use_default='inactive', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabd_sha_top_si_can ) + + call this%set_history_var(vname='FABI_SUN_TOPLF_BYCANLAYER', units='fraction', & + long='sun fraction of indirect light absorbed by the top leaf layer of each canopy layer', & + use_default='inactive', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabi_sun_top_si_can ) + + call this%set_history_var(vname='FABI_SHA_TOPLF_BYCANLAYER', units='fraction', & + long='shade fraction of indirect light absorbed by the top leaf layer of each canopy layer', & + use_default='inactive', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_fabi_sha_top_si_can ) + + ! slow carbon fluxes associated with mortality from or transfer betweeen canopy and understory + call this%set_history_var(vname='DEMOTION_CARBONFLUX', units = 'gC/m2/s', & + long='demotion-associated biomass carbon flux from canopy to understory', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_demotion_carbonflux_si ) + + call this%set_history_var(vname='PROMOTION_CARBONFLUX', units = 'gC/m2/s', & + long='promotion-associated biomass carbon flux from understory to canopy', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_promotion_carbonflux_si ) + + call this%set_history_var(vname='MORTALITY_CARBONFLUX_CANOPY', units = 'gC/m2/s', & + long='flux of biomass carbon from live to dead pools from mortality of canopy plants', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_canopy_mortality_carbonflux_si ) + + call this%set_history_var(vname='MORTALITY_CARBONFLUX_UNDERSTORY', units = 'gC/m2/s', & + long='flux of biomass carbon from live to dead pools from mortality of understory plants', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_understory_mortality_carbonflux_si ) + + + call this%set_history_var(vname='NPLANT_SCAG',units = 'plants/ha', & + long='number of plants per hectare in each size x age class', use_default='inactive', & + avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scag ) + + + ! Carbon Flux (grid dimension x scpf) (THESE ARE DEFAULT INACTIVE!!! + ! (BECAUSE THEY TAKE UP SPACE!!! + ! =================================================================================== + + call this%set_history_var(vname='GPP_SCPF', units='kgC/m2/yr', & + long='gross primary production by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_gpp_si_scpf ) + + call this%set_history_var(vname='GPP_CANOPY_SCPF', units='kgC/m2/yr', & + long='gross primary production of canopy plants by pft/size ', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_gpp_canopy_si_scpf ) + + call this%set_history_var(vname='AR_CANOPY_SCPF', units='kgC/m2/yr', & + long='autotrophic respiration of canopy plants by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ar_canopy_si_scpf ) + + call this%set_history_var(vname='GPP_UNDERSTORY_SCPF', units='kgC/m2/yr', & + long='gross primary production of understory plants by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_gpp_understory_si_scpf ) + + call this%set_history_var(vname='AR_UNDERSTORY_SCPF', units='kgC/m2/yr', & + long='autotrophic respiration of understory plants by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ar_understory_si_scpf ) + + call this%set_history_var(vname='NPP_SCPF', units='kgC/m2/yr', & + long='total net primary production by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_totl_si_scpf ) + + + call this%set_history_var(vname='NPP_LEAF_SCPF', units='kgC/m2/yr', & + long='NPP flux into leaves by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_si_scpf ) + + call this%set_history_var(vname='NPP_SEED_SCPF', units='kgC/m2/yr', & + long='NPP flux into seeds by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_seed_si_scpf ) + + call this%set_history_var(vname='NPP_FNRT_SCPF', units='kgC/m2/yr', & + long='NPP flux into fine roots by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_fnrt_si_scpf ) + + call this%set_history_var(vname='NPP_BGSW_SCPF', units='kgC/m2/yr', & + long='NPP flux into below-ground sapwood by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bgsw_si_scpf ) + + call this%set_history_var(vname='NPP_BGDW_SCPF', units='kgC/m2/yr', & + long='NPP flux into below-ground deadwood by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bgdw_si_scpf ) + + call this%set_history_var(vname='NPP_AGSW_SCPF', units='kgC/m2/yr', & + long='NPP flux into above-ground sapwood by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_agsw_si_scpf ) + + call this%set_history_var(vname = 'NPP_AGDW_SCPF', units='kgC/m2/yr', & + long='NPP flux into above-ground deadwood by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_agdw_si_scpf ) + + call this%set_history_var(vname = 'NPP_STOR_SCPF', units='kgC/m2/yr', & + long='NPP flux into storage by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stor_si_scpf ) + + call this%set_history_var(vname='DDBH_SCPF', units = 'cm/yr/ha', & + long='diameter growth increment by pft/size',use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_si_scpf ) + + call this%set_history_var(vname='DDBH_CANOPY_SCPF', units = 'cm/yr/ha', & + long='diameter growth increment by pft/size',use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_canopy_si_scpf ) + + call this%set_history_var(vname='DDBH_UNDERSTORY_SCPF', units = 'cm/yr/ha', & + long='diameter growth increment by pft/size',use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_understory_si_scpf ) + + call this%set_history_var(vname='BA_SCPF', units = 'm2/ha', & + long='basal area by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scpf ) + + call this%set_history_var(vname='NPLANT_SCPF', units = 'N/ha', & + long='stem number density by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scpf ) + + call this%set_history_var(vname='M1_SCPF', units = 'N/ha/yr', & + long='background mortality by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m1_si_scpf ) + + call this%set_history_var(vname='M2_SCPF', units = 'N/ha/yr', & + long='hydraulic mortality by pft/size',use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m2_si_scpf ) + + call this%set_history_var(vname='M3_SCPF', units = 'N/ha/yr', & + long='carbon starvation mortality by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m3_si_scpf ) + + call this%set_history_var(vname='M4_SCPF', units = 'N/ha/yr', & + long='impact mortality by pft/size',use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m4_si_scpf ) + + call this%set_history_var(vname='M5_SCPF', units = 'N/ha/yr', & + long='fire mortality by pft/size',use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m5_si_scpf ) + + call this%set_history_var(vname='M6_SCPF', units = 'N/ha/yr', & + long='termination mortality by pft/size',use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m6_si_scpf ) + + call this%set_history_var(vname='MORTALITY_CANOPY_SCPF', units = 'N/ha/yr', & + long='total mortality of canopy plants by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_canopy_si_scpf ) + + call this%set_history_var(vname='BSTOR_CANOPY_SCPF', units = 'kgC/ha', & + long='biomass carbon in storage pools of canopy plants by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstor_canopy_si_scpf ) + + call this%set_history_var(vname='BLEAF_CANOPY_SCPF', units = 'kgC/ha', & + long='biomass carbon in leaf of canopy plants by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bleaf_canopy_si_scpf ) + + call this%set_history_var(vname='NPLANT_CANOPY_SCPF', units = 'N/ha', & + long='stem number of canopy plants density by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_canopy_si_scpf ) + + call this%set_history_var(vname='MORTALITY_UNDERSTORY_SCPF', units = 'N/ha/yr', & + long='total mortality of understory plants by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_understory_si_scpf ) + + call this%set_history_var(vname='BSTOR_UNDERSTORY_SCPF', units = 'kgC/ha', & + long='biomass carbon in storage pools of understory plants by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstor_understory_si_scpf ) + + call this%set_history_var(vname='BLEAF_UNDERSTORY_SCPF', units = 'kgC/ha', & + long='biomass carbon in leaf of understory plants by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bleaf_understory_si_scpf ) + + call this%set_history_var(vname='NPLANT_UNDERSTORY_SCPF', units = 'N/ha', & + long='stem number of understory plants density by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_understory_si_scpf ) + + call this%set_history_var(vname='CWD_AG_CWDSC', units='gC/m^2', & + long='size-resolved AG CWD stocks', use_default='inactive', & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_si_cwdsc ) + + call this%set_history_var(vname='CWD_BG_CWDSC', units='gC/m^2', & + long='size-resolved BG CWD stocks', use_default='inactive', & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_si_cwdsc ) + + call this%set_history_var(vname='CWD_AG_IN_CWDSC', units='gC/m^2/y', & + long='size-resolved AG CWD input', use_default='inactive', & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_in_si_cwdsc ) + + call this%set_history_var(vname='CWD_BG_IN_CWDSC', units='gC/m^2/y', & + long='size-resolved BG CWD input', use_default='inactive', & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_in_si_cwdsc ) + + call this%set_history_var(vname='CWD_AG_OUT_CWDSC', units='gC/m^2/y', & + long='size-resolved AG CWD output', use_default='inactive', & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_out_si_cwdsc ) + + call this%set_history_var(vname='CWD_BG_OUT_CWDSC', units='gC/m^2/y', & + long='size-resolved BG CWD output', use_default='inactive', & + avgflag='A', vtype=site_cwdsc_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_out_si_cwdsc ) + + ! Size structured diagnostics that require rapid updates (upfreq=2) + + call this%set_history_var(vname='AR_SCPF',units = 'kgC/m2/yr', & + long='total autotrophic respiration per m2 per year by pft/size',use_default='inactive',& + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_si_scpf ) + + call this%set_history_var(vname='AR_GROW_SCPF',units = 'kgC/m2/yr', & + long='growth autotrophic respiration per m2 per year by pft/size',use_default='inactive',& + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_grow_si_scpf ) + + call this%set_history_var(vname='AR_MAINT_SCPF',units = 'kgC/m2/yr', & + long='maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_maint_si_scpf ) + + call this%set_history_var(vname='AR_DARKM_SCPF',units = 'kgC/m2/yr', & + long='dark portion of maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& + avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_darkm_si_scpf ) + + call this%set_history_var(vname='AR_AGSAPM_SCPF',units = 'kgC/m2/yr', & + long='above-ground sapwood maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& + avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_agsapm_si_scpf ) + + call this%set_history_var(vname='AR_CROOTM_SCPF',units = 'kgC/m2/yr', & + long='below-ground sapwood maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& + avgflag='A', vtype=site_size_pft_r8,hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_crootm_si_scpf ) + + call this%set_history_var(vname='AR_FROOTM_SCPF',units = 'kgC/m2/yr', & + long='fine root maintenance autotrophic respiration per m2 per year by pft/size',use_default='inactive',& + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_ar_frootm_si_scpf ) + + ! size-class only variables + + call this%set_history_var(vname='YESTERDAYCANLEV_CANOPY_SCLS', units = 'indiv/ha', & + long='Yesterdays canopy level for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_yesterdaycanopylevel_canopy_si_scls ) + + call this%set_history_var(vname='YESTERDAYCANLEV_UNDERSTORY_SCLS', units = 'indiv/ha', & + long='Yesterdays canopy level for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_yesterdaycanopylevel_understory_si_scls ) + + call this%set_history_var(vname='BA_SCLS', units = 'm2/ha', & + long='basal area by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scls ) + + call this%set_history_var(vname='DEMOTION_RATE_SCLS', units = 'indiv/ha/yr', & + long='demotion rate from canopy to understory by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_demotion_rate_si_scls ) + + call this%set_history_var(vname='PROMOTION_RATE_SCLS', units = 'indiv/ha/yr', & + long='promotion rate from understory to canopy by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_promotion_rate_si_scls ) + + call this%set_history_var(vname='NPLANT_CANOPY_SCLS', units = 'indiv/ha', & + long='number of canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_canopy_si_scls ) + + call this%set_history_var(vname='MORTALITY_CANOPY_SCLS', units = 'indiv/ha/yr', & + long='total mortality of canopy trees by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_canopy_si_scls ) + + call this%set_history_var(vname='NPLANT_UNDERSTORY_SCLS', units = 'indiv/ha', & + long='number of understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_understory_si_scls ) + + call this%set_history_var(vname='MORTALITY_UNDERSTORY_SCLS', units = 'indiv/ha/yr', & + long='total mortality of understory trees by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_understory_si_scls ) + + call this%set_history_var(vname='LEAF_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='LEAF_MD for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leaf_md_canopy_si_scls ) + + call this%set_history_var(vname='ROOT_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='ROOT_MD for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_root_md_canopy_si_scls ) + + call this%set_history_var(vname='CARBON_BALANCE_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='CARBON_BALANCE for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_carbon_balance_canopy_si_scls ) + + call this%set_history_var(vname='SEED_PROD_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='SEED_PROD for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_seed_prod_canopy_si_scls ) + + call this%set_history_var(vname='DBALIVEDT_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='DBALIVEDT for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_dbalivedt_canopy_si_scls ) + + call this%set_history_var(vname='DBDEADDT_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='DBDEADDT for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_dbdeaddt_canopy_si_scls ) + + call this%set_history_var(vname='DBSTOREDT_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='DBSTOREDT for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_dbstoredt_canopy_si_scls ) + + call this%set_history_var(vname='STORAGE_FLUX_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='STORAGE_FLUX for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storage_flux_canopy_si_scls ) + + call this%set_history_var(vname='NPP_LEAF_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='NPP_LEAF for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_canopy_si_scls ) + + call this%set_history_var(vname='NPP_FROOT_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='NPP_FROOT for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_froot_canopy_si_scls ) + + call this%set_history_var(vname='NPP_BSW_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='NPP_BSW for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bsw_canopy_si_scls ) + + call this%set_history_var(vname='NPP_BDEAD_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='NPP_BDEAD for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bdead_canopy_si_scls ) + + call this%set_history_var(vname='NPP_BSEED_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='NPP_BSEED for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bseed_canopy_si_scls ) + + call this%set_history_var(vname='NPP_STORE_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='NPP_STORE for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_store_canopy_si_scls ) + + call this%set_history_var(vname='RDARK_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='RDARK for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_rdark_canopy_si_scls ) + + call this%set_history_var(vname='LIVESTEM_MR_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='LIVESTEM_MR for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livestem_mr_canopy_si_scls ) + + call this%set_history_var(vname='LIVECROOT_MR_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='LIVECROOT_MR for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livecroot_mr_canopy_si_scls ) + + call this%set_history_var(vname='FROOT_MR_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='FROOT_MR for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_froot_mr_canopy_si_scls ) + + call this%set_history_var(vname='RESP_G_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='RESP_G for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_g_canopy_si_scls ) + + call this%set_history_var(vname='RESP_M_CANOPY_SCLS', units = 'kg C / ha / yr', & + long='RESP_M for canopy plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_m_canopy_si_scls ) + + call this%set_history_var(vname='LEAF_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='LEAF_MD for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leaf_md_understory_si_scls ) + + call this%set_history_var(vname='ROOT_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='ROOT_MD for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_root_md_understory_si_scls ) + + call this%set_history_var(vname='CARBON_BALANCE_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='CARBON_BALANCE for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_carbon_balance_understory_si_scls ) + + call this%set_history_var(vname='SEED_PROD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='SEED_PROD for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_seed_prod_understory_si_scls ) + + call this%set_history_var(vname='DBALIVEDT_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='DBALIVEDT for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_dbalivedt_understory_si_scls ) + + call this%set_history_var(vname='DBDEADDT_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='DBDEADDT for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_dbdeaddt_understory_si_scls ) + + call this%set_history_var(vname='DBSTOREDT_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='DBSTOREDT for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_dbstoredt_understory_si_scls ) + + call this%set_history_var(vname='STORAGE_FLUX_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='STORAGE_FLUX for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storage_flux_understory_si_scls ) + + call this%set_history_var(vname='NPP_LEAF_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='NPP_LEAF for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_understory_si_scls ) + + call this%set_history_var(vname='NPP_FROOT_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='NPP_FROOT for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_froot_understory_si_scls ) + + call this%set_history_var(vname='NPP_BSW_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='NPP_BSW for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bsw_understory_si_scls ) + + call this%set_history_var(vname='NPP_BDEAD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='NPP_BDEAD for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bdead_understory_si_scls ) + + call this%set_history_var(vname='NPP_BSEED_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='NPP_BSEED for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bseed_understory_si_scls ) + + call this%set_history_var(vname='NPP_STORE_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='NPP_STORE for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_store_understory_si_scls ) + + call this%set_history_var(vname='RDARK_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='RDARK for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_rdark_understory_si_scls ) + + call this%set_history_var(vname='LIVESTEM_MR_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='LIVESTEM_MR for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livestem_mr_understory_si_scls ) + + call this%set_history_var(vname='LIVECROOT_MR_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='LIVECROOT_MR for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livecroot_mr_understory_si_scls ) + + call this%set_history_var(vname='FROOT_MR_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='FROOT_MR for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_froot_mr_understory_si_scls ) + + call this%set_history_var(vname='RESP_G_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='RESP_G for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_g_understory_si_scls ) + + call this%set_history_var(vname='RESP_M_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & + long='RESP_M for understory plants by size class', use_default='inactive', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_m_understory_si_scls ) + + + ! CARBON BALANCE VARIABLES THAT DEPEND ON HLM BGC INPUTS + + call this%set_history_var(vname='NEP', units='gC/m^2/s', & + long='net ecosystem production', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_nep_si ) + + call this%set_history_var(vname='Fire_Closs', units='gC/m^2/s', & + long='ED/SPitfire Carbon loss to atmosphere', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_fire_c_to_atm_si ) + + call this%set_history_var(vname='NBP', units='gC/m^2/s', & + long='net biosphere production', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_nbp_si ) + + call this%set_history_var(vname='TOTECOSYSC', units='gC/m^2', & + long='total ecosystem carbon', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_totecosysc_si ) + + call this%set_history_var(vname='CBALANCE_ERROR_ED', units='gC/m^2/s', & + long='total carbon balance error on ED side', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cbal_err_fates_si ) + + call this%set_history_var(vname='CBALANCE_ERROR_BGC', units='gC/m^2/s', & + long='total carbon balance error on HLMs BGC side', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cbal_err_bgc_si ) + + call this%set_history_var(vname='CBALANCE_ERROR_TOTAL', units='gC/m^2/s', & + long='total carbon balance error total', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cbal_err_tot_si ) + + call this%set_history_var(vname='BIOMASS_STOCK_COL', units='gC/m^2', & + long='total ED biomass carbon at the column level', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_biomass_stock_si ) + + call this%set_history_var(vname='ED_LITTER_STOCK_COL', units='gC/m^2', & + long='total ED litter carbon at the column level', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_litter_stock_si ) + + call this%set_history_var(vname='CWD_STOCK_COL', units='gC/m^2', & + long='total CWD carbon at the column level', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_cwd_stock_si ) + + + ! PLANT HYDRAULICS + + if(use_fates_plant_hydro) then + + call this%set_history_var(vname='FATES_ERRH2O_SCPF', units='kg/indiv/s', & + long='mean individual water balance error', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_errh2o_scpf ) + + call this%set_history_var(vname='FATES_TRAN_SCPF', units='kg/indiv/s', & + long='mean individual transpiration rate', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_tran_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE01_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 1', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake01_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE02_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 2', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake02_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE03_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 3', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake03_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE04_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 4', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake04_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE05_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 5', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake05_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE06_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 6', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake06_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE07_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 7', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake07_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE08_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 8', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake08_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE09_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 9', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake09_scpf ) + + call this%set_history_var(vname='FATES_ROOTUPTAKE10_SCPF', units='kg/indiv/s', & + long='mean individual root uptake rate, layer 10', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake10_scpf ) + + call this%set_history_var(vname='FATES_SAPFLOW_COL_SCPF', units='kg/indiv/s', & + long='individual sap flow rate', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sapflow_scpf ) + + call this%set_history_var(vname='FATES_ITERH1_COL_SCPF', units='count/indiv/step', & + long='number of outer iterations required to achieve tolerable water balance error', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_iterh1_scpf ) + + call this%set_history_var(vname='FATES_ITERH2_COL_SCPF', units='count/indiv/step', & + long='number of inner iterations required to achieve tolerable water balance error', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_iterh2_scpf ) + + call this%set_history_var(vname='FATES_ATH_COL_SCPF', units='m3 m-3', & + long='absorbing root water content', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_ath_scpf ) + + call this%set_history_var(vname='FATES_TTH_COL_SCPF', units='m3 m-3', & + long='transporting root water content', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_tth_scpf ) + + call this%set_history_var(vname='FATES_STH_COL_SCPF', units='m3 m-3', & + long='stem water contenet', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sth_scpf ) + + call this%set_history_var(vname='FATES_LTH_COL_SCPF', units='m3 m-3', & + long='leaf water content', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_lth_scpf ) + + call this%set_history_var(vname='FATES_AWP_COL_SCPF', units='MPa', & + long='absorbing root water potential', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_awp_scpf ) + + call this%set_history_var(vname='FATES_TWP_COL_SCPF', units='MPa', & + long='transporting root water potential', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_twp_scpf ) + + call this%set_history_var(vname='FATES_SWP_COL_SCPF', units='MPa', & + long='stem water potential', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_swp_scpf ) + + call this%set_history_var(vname='FATES_LWP_COL_SCPF', units='MPa', & + long='leaf water potential', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_lwp_scpf ) + + call this%set_history_var(vname='FATES_BTRAN_COL_SCPF', units='MPa', & + long='mean individual level btran', use_default='active', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_btran_scpf ) + +! call this%set_history_var(vname='FATES_LAROOT_COL_SCPF', units='kg/indiv/s', & +! long='Needs Description', use_default='active', & +! avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & +! upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_laroot_scpf) + + end if + + ! Must be last thing before return + this%num_history_vars_ = ivar + + end subroutine define_history_vars + + + ! ==================================================================================== + ! DEPRECATED, TRANSITIONAL OR FUTURE CODE SECTION + ! ==================================================================================== + + !subroutine set_fates_hio_str(tag,iotype_name, iostr_val) + +! ! Arguments +! character(len=*), intent(in) :: tag +! character(len=*), optional, intent(in) :: iotype_name +! integer, optional, intent(in) :: iostr_val + +! ! local variables +! logical :: all_set +! integer, parameter :: unset_int = -999 +! real(r8), parameter :: unset_double = -999.9 +! integer :: ityp, idim + +! select case (trim(tag)) +! case('flush_to_unset') +! write(*, *) '' +! write(*, *) 'Flushing FATES IO types prior to transfer from host' +! do ityp=1,ubound(iovar_str, 1) +! iovar_str(ityp)%dimsize = unset_int +! iovar_str(ityp)%active = .false. +! end do + +! case('check_allset') +! do ityp=1,ubound(iovar_str, 1) +! write(*, *) 'Checking to see if ',iovar_str(ityp)%name, ' IO communicators were sent to FATES' +! if(iovar_str(ityp)%active)then +! if(iovar_str(ityp)%offset .eq. unset_int) then +! write(*, *) 'FATES offset information of IO type:', iovar_str(ityp)%name +! write(*, *) 'was never set' +! ! end_run('MESSAGE') +! end if +! do idim=1, iovar_str(ityp)%ndims +! if(iovar_str(ityp)%dimsize(idim) .eq. unset_int) then +! write(*, *) 'FATES dimension information of IO type:', iovar_str(ityp)%name +! write(*, *) 'was never set' +! ! end_run('MESSAGE') +! end if +! end do +! end if +! end do +! write(*, *) 'Checked. All history IO specifications properly sent to FATES.' +! case default + +! ! Must have two arguments if this is not a check or flush +! if(present(iostr_val) .and. present(iotype_name))then +! +! ! Tag in this case is dimsize or offset +! select case (trim(tag)) +! +! case('offset') +! ityp=iotype_index(trim(iotype_name)) +! iovar_str(ityp)%offset = iostr_val +! write(*, *) 'Transfering offset for IOTYPE',iotype_name, ' to FATES' + +! case('dimsize1') +! ityp=iotype_index(trim(iotype_name)) +! iovar_str(ityp)%dimsize(1) = iostr_val +! write(*, *) 'Transfering 1st dimension size for IOTYPE',iotype_name, ' to FATES' + +! case('dimsize2') +! ityp=iotype_index(trim(iotype_name)) +! if(ubound(iovar_str(ityp)%dimsize, 1)==1)then +! write(fates_log(), *) 'Transfering second dimensional bound to unallocated space' +! write(fates_log(), *) 'type:', iotype_name +! ! end_run +! end if +! iovar_str(ityp)%dimsize(2) = iostr_val +! write(*, *) 'Transfering 2nd dimension size for IOTYPE',iotype_name, ' to FATES' + +! case('dimsize3') +! ityp=iotype_index(trim(iotype_name)) +! if(ubound(iovar_str(ityp)%dimsize, 1)<3)then +! write(fates_log(), *) 'Transfering third dimensional bound to unallocated space' +! write(fates_log(), *) 'type:', iotype_name +! ! end_run +! end if +! iovar_str(ityp)%dimsize(3) = iostr_val +! write(*, *) 'Transfering 3rd dimension size for IOTYPE',iotype_name, ' to FATES' + +! case default +! write(*, *) 'IO parameter not recognized:', trim(tag) +! ! end_run +! end select +! else +! write(*, *) 'no value was provided for the tag' +! end if +! +! end select +! return +! end subroutine set_fates_hio_str + + + +end module FatesHistoryInterfaceMod diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 new file mode 100644 index 00000000..eca19a31 --- /dev/null +++ b/main/FatesHistoryVariableType.F90 @@ -0,0 +1,281 @@ +module FatesHistoryVariableType + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesGlobals, only : fates_log + use FatesIOVariableKindMod, only : fates_io_variable_kind_type + + implicit none + + ! This type is instanteated in the HLM-FATES interface (clmfates_interfaceMod.F90) + + type fates_history_variable_type + character(len=32) :: vname + character(len=24) :: units + character(len=128) :: long + character(len=24) :: use_default ! States whether a variable should be turned + ! on the output files by default (active/inactive) + ! It is a good idea to set inactive for very large + ! or infrequently used output datasets + character(len=24) :: vtype + character(len=1) :: avgflag + integer :: upfreq ! Update frequency (this is for checks and flushing) + ! 1 = dynamics "dyn" (daily) + ! 2 = production "prod" (prob model tstep) + real(r8) :: flushval + integer :: dim_kinds_index + ! Pointers (only one of these is allocated per variable) + real(r8), pointer :: r81d(:) + real(r8), pointer :: r82d(:,:) + real(r8), pointer :: r83d(:,:,:) + integer, pointer :: int1d(:) + integer, pointer :: int2d(:,:) + integer, pointer :: int3d(:,:,:) + contains + procedure, public :: Init + procedure, public :: Flush + procedure, private :: GetBounds + end type fates_history_variable_type + +contains + + subroutine Init(this, vname, units, long, use_default, & + vtype, avgflag, flushval, upfreq, num_dim_kinds, dim_kinds, dim_bounds) + + use FatesIODimensionsMod, only : fates_io_dimension_type + + use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 + 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 : iotype_index + + implicit none + + class(fates_history_variable_type), intent(inout) :: this + character(len=*), intent(in) :: vname + character(len=*), intent(in) :: units + character(len=*), intent(in) :: long + character(len=*), intent(in) :: use_default + character(len=*), intent(in) :: vtype + character(len=*), intent(in) :: avgflag + real(r8), intent(in) :: flushval ! If the type is an int we will round with nint + integer, intent(in) :: upfreq + integer, intent(in) :: num_dim_kinds + type(fates_io_dimension_type), intent(in) :: dim_bounds(:) + type(fates_io_variable_kind_type), intent(inout) :: dim_kinds(:) + + integer :: dk_index + integer :: lb1, ub1, lb2, ub2 + + this%vname = vname + this%units = units + this%long = long + this%use_default = use_default + this%vtype = vtype + this%avgflag = avgflag + this%flushval = flushval + this%upfreq = upfreq + + nullify(this%r81d) + nullify(this%r82d) + nullify(this%r83d) + nullify(this%int1d) + nullify(this%int2d) + nullify(this%int3d) + + dk_index = iotype_index(trim(vtype), num_dim_kinds, dim_kinds) + this%dim_kinds_index = dk_index + call dim_kinds(dk_index)%set_active() + + call this%GetBounds(0, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) + + ! NOTE(rgk, 2016-09) currently, all array spaces are flushed each + ! time the update is called. The flush here on the initialization + ! may be redundant, but will prevent issues in the future if we + ! have host models where not all threads are updating the HHistory + ! array spaces. + + select case(trim(vtype)) + case(patch_r8) + allocate(this%r81d(lb1:ub1)) + this%r81d(:) = flushval + + case(site_r8) + allocate(this%r81d(lb1:ub1)) + this%r81d(:) = flushval + + case(patch_ground_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(patch_size_pft_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_ground_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_size_pft_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_size_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_pft_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_age_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_fuel_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_cwdsc_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_can_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_cnlf_r8) + allocate(this%r82d(lb1:ub1, lb2:ub2)) + this%r82d(:,:) = flushval + + case(site_cnlfpft_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 + + case default + write(fates_log(),*) 'Incompatible vtype passed to set_history_var' + write(fates_log(),*) 'vtype = ',trim(vtype),' ?' + stop + ! end_run + end select + + end subroutine Init + + ! ===================================================================================== + + subroutine GetBounds(this, thread, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) + + use FatesIODimensionsMod, only : fates_io_dimension_type + + implicit none + + class(fates_history_variable_type), intent(inout) :: this + integer, intent(in) :: thread + class(fates_io_dimension_type), intent(in) :: dim_bounds(:) + type(fates_io_variable_kind_type), intent(in) :: dim_kinds(:) + integer, intent(out) :: lb1 + integer, intent(out) :: ub1 + integer, intent(out) :: lb2 + integer, intent(out) :: ub2 + + ! local + integer :: ndims + integer :: d_index + + lb1 = 0 + ub1 = 0 + lb2 = 0 + ub2 = 0 + + ndims = dim_kinds(this%dim_kinds_index)%ndims + + ! The thread = 0 case is the boundaries for the whole proc/node + if (thread==0) then + d_index = dim_kinds(this%dim_kinds_index)%dim1_index + lb1 = dim_bounds(d_index)%lower_bound + ub1 = dim_bounds(d_index)%upper_bound + if(ndims>1)then + d_index = dim_kinds(this%dim_kinds_index)%dim2_index + lb2 = dim_bounds(d_index)%lower_bound + ub2 = dim_bounds(d_index)%upper_bound + end if + else + d_index = dim_kinds(this%dim_kinds_index)%dim1_index + lb1 = dim_bounds(d_index)%clump_lower_bound(thread) + ub1 = dim_bounds(d_index)%clump_upper_bound(thread) + if(ndims>1)then + d_index = dim_kinds(this%dim_kinds_index)%dim2_index + lb2 = dim_bounds(d_index)%clump_lower_bound(thread) + ub2 = dim_bounds(d_index)%clump_upper_bound(thread) + end if + end if + + end subroutine GetBounds + + subroutine Flush(this, thread, dim_bounds, dim_kinds) + + use FatesIODimensionsMod, only : fates_io_dimension_type + use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8, patch_int + use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 + use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 + use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 + + implicit none + + class(fates_history_variable_type), intent(inout) :: this + integer, intent(in) :: thread + type(fates_io_dimension_type), intent(in) :: dim_bounds(:) + type(fates_io_variable_kind_type), intent(in) :: dim_kinds(:) + + integer :: lb1, ub1, lb2, ub2 + + call this%GetBounds(thread, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) + + select case(trim(dim_kinds(this%dim_kinds_index)%name)) + case(patch_r8) + this%r81d(lb1:ub1) = this%flushval + case(site_r8) + this%r81d(lb1:ub1) = this%flushval + case(patch_ground_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(patch_size_pft_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_ground_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_size_pft_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_size_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_pft_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_age_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_fuel_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_cwdsc_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_can_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_cnlf_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_cnlfpft_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(site_scag_r8) + this%r82d(lb1:ub1, lb2:ub2) = this%flushval + case(patch_int) + this%int1d(lb1:ub1) = nint(this%flushval) + case default + write(fates_log(),*) 'fates history variable type undefined while flushing history variables' + stop + !end_run + end select + + end subroutine Flush + +end module FatesHistoryVariableType diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 new file mode 100644 index 00000000..71f921a7 --- /dev/null +++ b/main/FatesHydraulicsMemMod.F90 @@ -0,0 +1,214 @@ +module FatesHydraulicsMemMod + + use FatesConstantsMod, only : r8 => fates_r8 + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + + implicit none + + integer,parameter :: nlevsoi_hyd = 10 ! use_fates_plant_hydro parameter: + ! Number of soil layers for indexing + ! cohort fine root quanitities + + + integer , parameter :: n_porous_media = 4 ! number of distinct types + ! of plant porous media + ! (leaf, stem, troot, aroot) + integer , parameter :: npool_leaf = 1 ! + integer , parameter :: npool_stem = 1 ! + integer , parameter :: npool_troot = 1 ! + integer , parameter :: npool_aroot = 1 ! + integer , parameter :: nshell = 5 ! + integer , parameter :: npool_ag = npool_leaf+npool_stem ! number of aboveground plant water storage nodes + integer , parameter :: npool_bg = npool_troot ! number of belowground plant water storage nodes + integer , parameter :: npool_tot = npool_ag + 2 + nshell ! total number of water storage nodes + integer :: porous_media(npool_tot) ! vector indexing the type of + ! porous medium over an arbitrary + ! number of plant pools + integer, parameter :: numLWPmem = 4 ! number of previous timestep's leaf water + ! potential to be retained + integer, parameter :: nlevcan_hyd = 2 ! mirror of nlevcan, hard-set for simplicity + ! TODO: remove nlevcan_hyd on a rainy day + real(r8), parameter :: fine_root_radius_const = 0.001_r8 ! Mean fine root radius expected in the bulk soil + + type ed_site_hydr_type + + ! Plant Hydraulics + + real(r8),allocatable :: v_shell(:,:) ! Volume of rhizosphere compartment (m) + real(r8),allocatable :: v_shell_init(:,:) ! Previous volume of rhizosphere compartment (m) + real(r8),allocatable :: v_shell_1D(:) ! Volume of rhizosphere compartment (m) + real(r8),allocatable :: r_node_shell(:,:) ! Nodal radius of rhizosphere compartment (m) + real(r8),allocatable :: r_node_shell_init(:,:) ! Previous Nodal radius of rhizosphere compartment (m) + real(r8),allocatable :: l_aroot_layer(:) ! Total length (across cohorts) of absorbing + ! roots by soil layer (m) + real(r8),allocatable :: l_aroot_layer_init(:) ! Total length (across cohorts) of absorbing + ! roots by soil layer (m) + real(r8),allocatable :: kmax_upper_shell(:,:) ! Maximum soil hydraulic conductance node k + ! to upper (closer to atmosphere) rhiz + ! shell boundaries (kg s-1 MPa-1) + real(r8),allocatable :: kmax_bound_shell(:,:) ! Maximum soil hydraulic conductance at upper + ! (closer to atmosphere) rhiz shell + ! boundaries (kg s-1 MPa-1) + real(r8),allocatable :: kmax_lower_shell(:,:) ! Maximum soil hydraulic conductance node k + ! to lower (further from atmosphere) + ! rhiz shell boundaries (kg s-1 MPa-1) + real(r8),allocatable :: r_out_shell(:,:) ! Outer radius of rhizosphere compartment (m) + real(r8),allocatable :: r_out_shell_1D(:) ! Outer radius of rhizosphere compartment (m) (USED?) + real(r8),allocatable :: r_node_shell_1D(:) ! Nodal radius of rhizosphere compartment (m) + + real(r8),allocatable :: rs1(:) ! Mean fine root radius (m) (currently a constant) + + real(r8),allocatable :: kmax_upper_shell_1D(:) ! Maximum soil hydraulic conductance node + ! k to upper (closer to atmosphere) rhiz + ! shell boundaries (kg s-1 MPa-1) + real(r8),allocatable :: kmax_bound_shell_1D(:) ! Maximum soil hydraulic conductance at upper + ! (closer to atmosphere) rhiz shell + ! boundaries (kg s-1 MPa-1) + real(r8),allocatable :: kmax_lower_shell_1D(:) ! Maximum soil hydraulic conductance node + ! k to lower (further from atmosphere) rhiz + ! shell boundaries (kg s-1 MPa-1) + + integer,allocatable :: supsub_flag(:) ! index of the outermost rhizosphere shell + ! encountering super- or sub-saturation + real(r8),allocatable :: h2osoi_liqvol_shell(:,:) ! volumetric water in rhizosphere compartment (m3/m3) + + real(r8),allocatable :: h2osoi_liq_prev(:) ! liquid water mass for the bulk soil layer + ! defined at the end of the hydraulics sequence + ! after root water has been extracted. This should + ! be equal to the sum of the water over the rhizosphere shells + + real(r8),allocatable :: psisoi_liq_innershell(:) ! Matric potential of the inner rhizosphere shell (MPa) + + real(r8) :: l_aroot_1D ! Total (across cohorts) absorbing root + ! length across all layers + + real(r8) :: errh2o_hyd ! plant hydraulics error summed across + ! cohorts to column level (mm) + real(r8) :: dwat_veg ! change in stored water in vegetation + ! column level (kg) + real(r8) :: h2oveg ! stored water in vegetation (kg) + + ! Hold Until Van Genuchten is implemented + ! real(r8), allocatable :: alpha_VG(:) ! col inverse of air-entry pressure [MPa-1] (for van Genuchten SWC only) + ! real(r8), allocatable :: n_VG(:) ! col pore-size distribution index [-] (for van Genuchten SWC only) + ! real(r8), allocatable :: m_VG(:) ! = 1 - 1/n_VG [-] (for van Genuchten SWC only) + ! real(r8), allocatable :: l_VG(:) ! col pore tortuosity parameter [-] (for van Genuchten SWC only) + + contains + + procedure :: InitHydrSite + + end type ed_site_hydr_type + + type ed_patch_hydr_type + real(r8) :: netRad_mem(numLWPmem) ! patch-level net radiation for the previous numLWPmem timesteps [W m-2] + end type ed_patch_hydr_type + + + type ed_cohort_hydr_type + + ! BC...PLANT HYDRAULICS - "constants" that change with size. Heights are referenced to soil surface (+ = above; - = below) + real(r8) :: z_node_ag(npool_ag) ! nodal height of aboveground water storage compartments [m] + real(r8) :: z_node_bg(npool_bg) ! nodal height of belowground water storage compartments [m] + real(r8) :: z_node_aroot(nlevsoi_hyd) ! nodal height of absorbing root water storage compartments [m] + real(r8) :: z_upper_ag(npool_ag) ! upper boundary height of aboveground water storage compartments [m] + real(r8) :: z_upper_bg(npool_bg) ! upper boundary height of belowground water storage compartments [m] + real(r8) :: z_lower_ag(npool_ag) ! lower boundary height of aboveground water storage compartments [m] + real(r8) :: z_lower_bg(npool_bg) ! lower boundary height of belowground water storage compartments [m] + real(r8) :: kmax_upper(npool_ag) ! maximum hydraulic conductance from node to upper boundary [kg s-1 MPa-1] + real(r8) :: kmax_lower(npool_ag) ! maximum hydraulic conductance from node to lower boundary [kg s-1 MPa-1] + real(r8) :: kmax_upper_troot ! maximum hydraulic conductance from troot node to upper boundary [kg s-1 MPa-1] + real(r8) :: kmax_bound(npool_ag) ! maximum hydraulic conductance at lower boundary (canopy to troot) [kg s-1 MPa-1] + real(r8) :: kmax_treebg_tot ! total belowground tree kmax (troot to surface of absorbing roots) [kg s-1 MPa-1] + real(r8) :: kmax_treebg_layer(nlevsoi_hyd) ! total belowground tree kmax partitioned by soil layer [kg s-1 MPa-1] + real(r8) :: v_ag_init(npool_ag) ! previous day's volume of aboveground water storage compartments [m3] + real(r8) :: v_ag(npool_ag) ! volume of aboveground water storage compartments [m3] + real(r8) :: v_bg_init(npool_bg) ! previous day's volume of belowground water storage compartments [m3] + real(r8) :: v_bg(npool_bg) ! volume of belowground water storage compartments [m3] + real(r8) :: v_aroot_tot ! total volume of absorbing roots [m3] + real(r8) :: v_aroot_layer_init(nlevsoi_hyd) ! previous day's volume of absorbing roots by soil layer [m3] + real(r8) :: v_aroot_layer(nlevsoi_hyd) ! volume of absorbing roots by soil layer [m3] + real(r8) :: l_aroot_tot ! total length of absorbing roots [m] + real(r8) :: l_aroot_layer(nlevsoi_hyd) ! length of absorbing roots by soil layer [m] + + ! BC PLANT HYDRAULICS - state variables + real(r8) :: th_ag(npool_ag) ! water in aboveground compartments [kgh2o/indiv] + real(r8) :: th_bg(npool_bg) ! water in belowground compartments [kgh2o/indiv] + real(r8) :: th_aroot(nlevsoi_hyd) ! water in absorbing roots [kgh2o/indiv] + real(r8) :: lwp_mem(numLWPmem) ! leaf water potential over the previous numLWPmem timesteps [MPa] + real(r8) :: lwp_stable ! leaf water potential just before it became unstable [MPa] + logical :: lwp_is_unstable ! flag for instability of leaf water potential over previous timesteps + real(r8) :: psi_ag(npool_ag) ! water potential in aboveground compartments [MPa] + real(r8) :: psi_bg(npool_bg) ! water potential in belowground compartments [MPa] + real(r8) :: psi_aroot(nlevsoi_hyd) ! water potential in absorbing roots [MPa] + real(r8) :: flc_ag(npool_ag) ! fractional loss of conductivity in aboveground compartments [-] + real(r8) :: flc_bg(npool_bg) ! fractional loss of conductivity in belowground compartments [-] + real(r8) :: flc_aroot(nlevsoi_hyd) ! fractional loss of conductivity in absorbing roots [-] + real(r8) :: flc_min_ag(npool_ag) ! min attained fractional loss of conductivity in aboveground compartments (for tracking xylem refilling dynamics) [-] + real(r8) :: flc_min_bg(npool_bg) ! min attained fractional loss of conductivity in belowground compartments (for tracking xylem refilling dynamics) [-] + real(r8) :: flc_min_aroot(nlevsoi_hyd) ! min attained fractional loss of conductivity in absorbing roots (for tracking xylem refilling dynamics) [-] + real(r8) :: refill_thresh ! water potential threshold for xylem refilling to occur [MPa] + real(r8) :: refill_days ! number of days required for 50% of xylem refilling to occur [days] + real(r8) :: btran(nlevcan_hyd) ! leaf water potential limitation on gs [0-1] + real(r8) :: supsub_flag ! k index of last node to encounter supersaturation or sub-residual water content (+ supersaturation; - subsaturation) + real(r8) :: iterh1 ! number of iterations required to achieve tolerable water balance error + real(r8) :: iterh2 ! number of inner iterations + real(r8) :: errh2o ! total water balance error per unit crown area [kgh2o/m2] + + ! BC PLANT HYDRAULICS - fluxes + real(r8) :: qtop_dt ! transpiration boundary condition (+ to atm) [kg/indiv/timestep] + real(r8) :: dqtopdth_dthdt ! transpiration tendency term (+ to atm) [kg/indiv/timestep] + ! NOTE: total transpiration is given by qtop_dt + dqtopdth_dthdt + real(r8) :: sapflow ! flow at base of tree (+ upward) [kg/indiv/timestep] + real(r8) :: rootuptake ! net flow into roots (+ into roots) [kg/indiv/timestep] + real(r8) :: rootuptake01 ! net flow into roots (+ into roots), soil layer 1 [kg/indiv/timestep] + real(r8) :: rootuptake02 ! net flow into roots (+ into roots), soil layer 2 [kg/indiv/timestep] + real(r8) :: rootuptake03 ! net flow into roots (+ into roots), soil layer 3 [kg/indiv/timestep] + real(r8) :: rootuptake04 ! net flow into roots (+ into roots), soil layer 4 [kg/indiv/timestep] + real(r8) :: rootuptake05 ! net flow into roots (+ into roots), soil layer 5 [kg/indiv/timestep] + real(r8) :: rootuptake06 ! net flow into roots (+ into roots), soil layer 6 [kg/indiv/timestep] + real(r8) :: rootuptake07 ! net flow into roots (+ into roots), soil layer 7 [kg/indiv/timestep] + real(r8) :: rootuptake08 ! net flow into roots (+ into roots), soil layer 8 [kg/indiv/timestep] + real(r8) :: rootuptake09 ! net flow into roots (+ into roots), soil layer 9 [kg/indiv/timestep] + real(r8) :: rootuptake10 ! net flow into roots (+ into roots), soil layer 10 [kg/indiv/timestep] + end type ed_cohort_hydr_type + + contains + + ! =================================================================================== + + subroutine InitHydrSite(this) + + ! Arguments + class(ed_site_hydr_type),intent(inout) :: this + + allocate(this%v_shell(1:nlevsoi_hyd,1:nshell)) ; this%v_shell = nan + allocate(this%v_shell_init(1:nlevsoi_hyd,1:nshell)) ; this%v_shell_init = nan + allocate(this%v_shell_1D(1:nshell)) ; this%v_shell_1D = nan + allocate(this%r_node_shell(1:nlevsoi_hyd,1:nshell)) ; this%r_node_shell = nan + allocate(this%r_node_shell_init(1:nlevsoi_hyd,1:nshell)); this%r_node_shell_init = nan + allocate(this%r_out_shell(1:nlevsoi_hyd,1:nshell)) ; this%r_out_shell = nan + allocate(this%l_aroot_layer(1:nlevsoi_hyd)) ; this%l_aroot_layer = nan + allocate(this%l_aroot_layer_init(1:nlevsoi_hyd)) ; this%l_aroot_layer_init = nan + allocate(this%kmax_upper_shell(1:nlevsoi_hyd,1:nshell)); this%kmax_upper_shell = nan + allocate(this%kmax_bound_shell(1:nlevsoi_hyd,1:nshell)); this%kmax_bound_shell = nan + allocate(this%kmax_lower_shell(1:nlevsoi_hyd,1:nshell)); this%kmax_lower_shell = nan + allocate(this%r_out_shell_1D(1:nshell)) ; this%r_out_shell_1D = nan + allocate(this%r_node_shell_1D(1:nshell)) ; this%r_node_shell_1D = nan + allocate(this%kmax_upper_shell_1D(1:nshell)) ; this%kmax_upper_shell_1D = nan + allocate(this%kmax_bound_shell_1D(1:nshell)) ; this%kmax_bound_shell_1D = nan + allocate(this%kmax_lower_shell_1D(1:nshell)) ; this%kmax_lower_shell_1D = nan + allocate(this%supsub_flag(nlevsoi_hyd)) ; this%supsub_flag = -999 + allocate(this%h2osoi_liqvol_shell(1:nlevsoi_hyd,1:nshell)) ; this%h2osoi_liqvol_shell = nan + allocate(this%h2osoi_liq_prev(1:nlevsoi_hyd)) ; this%h2osoi_liq_prev = nan + allocate(this%psisoi_liq_innershell(1:nlevsoi_hyd)); this%psisoi_liq_innershell = nan + allocate(this%rs1(1:nlevsoi_hyd)); this%rs1(:) = fine_root_radius_const + + this%l_aroot_1D = nan + this%errh2o_hyd = nan + this%dwat_veg = nan + this%h2oveg = nan + return + end subroutine InitHydrSite + +end module FatesHydraulicsMemMod diff --git a/main/FatesIODimensionsMod.F90 b/main/FatesIODimensionsMod.F90 new file mode 100644 index 00000000..1dd5cce0 --- /dev/null +++ b/main/FatesIODimensionsMod.F90 @@ -0,0 +1,155 @@ +module FatesIODimensionsMod + + use FatesConstantsMod, only : fates_short_string_length + + implicit none + + ! The following dimension names must be replicated in + ! CLM/ALMs histFileMod.F90 and + + character(*), parameter :: cohort = 'cohort' ! matches clm_varcon + character(*), parameter :: patch = 'patch' ! matches clm_varcon + character(*), parameter :: column = 'column' ! matches clm_varcon + character(*), parameter :: levgrnd = 'levgrnd' ! matches clm_varcon + character(*), parameter :: levscag = 'fates_levscag' ! matches histFileMod + character(*), parameter :: levscpf = 'fates_levscpf' ! matches histFileMod + character(*), parameter :: levscls = 'fates_levscls' ! matches histFileMod + character(*), parameter :: levpft = 'fates_levpft' ! matches histFileMod + character(*), parameter :: levage = 'fates_levage' ! matches histFileMod + character(*), parameter :: levfuel = 'fates_levfuel' ! matches histFileMod + character(*), parameter :: levcwdsc = 'fates_levcwdsc' ! matches histFileMod + character(*), parameter :: levcan = 'fates_levcan' ! matches histFileMod + character(*), parameter :: levcnlf = 'fates_levcnlf' ! matches histFileMod + character(*), parameter :: levcnlfpft = 'fates_levcnlfpf' ! matches histFileMod + + ! patch = This is a structure that records where FATES patch boundaries + ! on each thread point to in the host IO array, this structure + ! is allocated by number of threads + + ! column = This is a structure that records where FATES column boundaries + ! on each thread point to in the host IO array, this structure + ! is allocated by number of threads + + ! ground = This is a structure that records the boundaries for the + ! ground level (includes rock) dimension + + ! levscpf = This is a structure that records the boundaries for the + ! number of size-class x pft dimension + + ! levscls = This is a structure that records the boundaries for the + ! number of size-class dimension + + ! levpft = This is a structure that records the boundaries for the + ! number of pft dimension + + ! levage = This is a structure that records the boundaries for the + ! number of patch-age-class dimension + + ! levfuel = This is a structure that records the boundaries for the + ! number of fuel-size-class dimension + + ! levcwdsc = This is a structure that records the boundaries for the + ! number of coarse-woody-debris-size-class dimension + + ! levcan = This is a structure that records the boundaries for the + ! number of canopy layer dimension + + ! levcnlf = This is a structure that records the boundaries for the + ! number of cnanopy layer x leaf layer dimension + + ! levcnlfpft = This is a structure that records the boundaries for the + ! number of canopy layer x leaf layer x pft dimension + + ! levscag = This is a strcture that records the boundaries for the + ! number of size-classes x patch age + + + type, public :: fates_bounds_type + integer :: patch_begin + integer :: patch_end + integer :: cohort_begin + integer :: cohort_end + integer :: column_begin ! FATES does not have a "column" type + integer :: column_end ! we call this a "site" (rgk 11-2016) + integer :: ground_begin + integer :: ground_end + integer :: sizeage_class_begin + integer :: sizeage_class_end + integer :: sizepft_class_begin + integer :: sizepft_class_end + integer :: size_class_begin + integer :: size_class_end + integer :: pft_class_begin + integer :: pft_class_end + integer :: age_class_begin + integer :: age_class_end + integer :: fuel_begin + integer :: fuel_end + integer :: cwdsc_begin + integer :: cwdsc_end + integer :: can_begin + integer :: can_end + integer :: cnlf_begin + integer :: cnlf_end + integer :: cnlfpft_begin + integer :: cnlfpft_end + end type fates_bounds_type + + + + ! This structure is not allocated by thread, but the upper and lower boundaries + ! of the dimension for each thread is saved in the clump_ entry + type fates_io_dimension_type + character(len=fates_short_string_length) :: name + integer :: lower_bound + integer :: upper_bound + integer, allocatable :: clump_lower_bound(:) ! lower bound of thread's portion of HIO array + integer, allocatable :: clump_upper_bound(:) ! upper bound of thread's portion of HIO array + contains + procedure, public :: Init + procedure, public :: SetThreadBounds + end type fates_io_dimension_type + +contains + + ! ===================================================================================== + subroutine Init(this, name, num_threads, lower_bound, upper_bound) + + implicit none + + ! arguments + class(fates_io_dimension_type), intent(inout) :: this + character(len=*), intent(in) :: name + integer, intent(in) :: num_threads + integer, intent(in) :: lower_bound + integer, intent(in) :: upper_bound + + this%name = trim(name) + this%lower_bound = lower_bound + this%upper_bound = upper_bound + + allocate(this%clump_lower_bound(num_threads)) + this%clump_lower_bound(:) = -1 + + allocate(this%clump_upper_bound(num_threads)) + this%clump_upper_bound(:) = -1 + + end subroutine Init + + ! ===================================================================================== + + subroutine SetThreadBounds(this, thread_index, lower_bound, upper_bound) + + implicit none + + class(fates_io_dimension_type), intent(inout) :: this + integer, intent(in) :: thread_index + integer, intent(in) :: lower_bound + integer, intent(in) :: upper_bound + + this%clump_lower_bound(thread_index) = lower_bound + this%clump_upper_bound(thread_index) = upper_bound + + end subroutine SetThreadBounds + +end module FatesIODimensionsMod diff --git a/main/FatesIOVariableKindMod.F90 b/main/FatesIOVariableKindMod.F90 new file mode 100644 index 00000000..25e2f2bc --- /dev/null +++ b/main/FatesIOVariableKindMod.F90 @@ -0,0 +1,114 @@ +module FatesIOVariableKindMod + + use FatesConstantsMod, only : fates_long_string_length + use FatesGlobals, only : fates_log + use FatesIODimensionsMod, only : fates_io_dimension_type + + implicit none + + ! FIXME(bja, 2016-10) do these need to be strings, or can they be integer enumerations? + ! FIXME(rgk, 2016-11) these should probably be moved to varkindmod? + + character(*), parameter :: patch_r8 = 'PA_R8' + character(*), parameter :: patch_ground_r8 = 'PA_GRND_R8' + character(*), parameter :: patch_size_pft_r8 = 'PA_SCPF_R8' + character(*), parameter :: site_r8 = 'SI_R8' + character(*), parameter :: site_int = 'SI_INT' + character(*), parameter :: site_ground_r8 = 'SI_GRND_R8' + character(*), parameter :: site_size_pft_r8 = 'SI_SCPF_R8' + character(*), parameter :: site_size_r8 = 'SI_SCLS_R8' + character(*), parameter :: patch_int = 'PA_INT' + character(*), parameter :: cohort_r8 = 'CO_R8' + character(*), parameter :: cohort_int = 'CO_INT' + character(*), parameter :: site_pft_r8 = 'SI_PFT_R8' + character(*), parameter :: site_age_r8 = 'SI_AGE_R8' + character(*), parameter :: site_fuel_r8 = 'SI_FUEL_R8' + character(*), parameter :: site_cwdsc_r8 = 'SI_CWDSC_R8' + character(*), parameter :: site_can_r8 = 'SI_CAN_R8' + character(*), parameter :: site_cnlf_r8 = 'SI_CNLF_R8' + character(*), parameter :: site_cnlfpft_r8 = 'SI_CNLFPFT_R8' + character(*), parameter :: site_scag_r8 = 'SI_SCAG_R8' + + ! NOTE(RGK, 2016) %active is not used yet. Was intended as a check on the HLM->FATES + ! control parameter passing to ensure all active dimension types received all + ! dimensioning specifications from the host, but we currently arent using those + ! passing functions.. + + ! This structure is not multi-threaded + type fates_io_variable_kind_type + character(len=fates_long_string_length) :: name ! String labelling this IO type + integer :: ndims ! number of dimensions in this IO type + integer, allocatable :: dimsize(:) ! The size of each dimension + logical, private :: active_ + integer :: dim1_index + integer :: dim2_index + + contains + + procedure, public :: Init + procedure, public :: set_active + procedure, public :: is_active + + end type fates_io_variable_kind_type + + + +contains + + ! =================================================================================== + subroutine Init(this, name, num_dims) + + use FatesConstantsMod, only : fates_unset_int + + implicit none + + class(fates_io_variable_kind_type), intent(inout) :: this + character(*), intent(in) :: name + integer, intent(in) :: num_dims + + this%name = trim(name) + this%ndims = num_dims + allocate(this%dimsize(this%ndims)) + this%dimsize(:) = fates_unset_int + this%active_ = .false. + this%dim1_index = fates_unset_int + this%dim2_index = fates_unset_int + + end subroutine Init + + ! ======================================================================= + subroutine set_active(this) + implicit none + class(fates_io_variable_kind_type), intent(inout) :: this + this%active_ = .true. + end subroutine set_active + + logical function is_active(this) + implicit none + class(fates_io_variable_kind_type), intent(in) :: this + is_active = this%active_ + end function is_active + + ! ==================================================================================== + + function iotype_index(iotype_name, num_dim_kinds, dim_kinds) result(dk_index) + + ! argument + character(len=*), intent(in) :: iotype_name + integer, intent(in) :: num_dim_kinds + type(fates_io_variable_kind_type), intent(in) :: dim_kinds(:) + + ! local + integer :: dk_index + + do dk_index=1, num_dim_kinds + if (trim(iotype_name) .eq. trim(dim_kinds(dk_index)%name)) then + return + end if + end do + write(fates_log(),*) 'An IOTYPE THAT DOESNT EXIST WAS SPECIFIED' + !end_run + + end function iotype_index + +end module FatesIOVariableKindMod diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 new file mode 100644 index 00000000..669a73b3 --- /dev/null +++ b/main/FatesInterfaceMod.F90 @@ -0,0 +1,1122 @@ +module FatesInterfaceMod + + ! ------------------------------------------------------------------------------------ + ! This is the FATES public API + ! A host land model has defined and allocated a structure "fates" as + ! defined by fates_interface_type + ! + ! It is also likely/possible that this type is defined as a vector + ! which is allocated by thread + ! ------------------------------------------------------------------------------------ + + use EDTypesMod , only : ed_site_type + use EDTypesMod , only : maxPatchesPerSite + use EDTypesMod , only : maxCohortsPerPatch + use EDTypesMod , only : maxSWb + use EDTypesMod , only : ivis + use EDTypesMod , only : inir + use EDTypesMod , only : nclmax + use EDTypesMod , only : nlevleaf + use EDTypesMod , only : numpft_ed + use FatesConstantsMod , only : r8 => fates_r8 + use FatesGlobals , only : fates_global_verbose + use FatesGlobals , only : fates_log + use EDTypesMod , only : use_fates_plant_hydro + use FatesGlobals , only : endrun => fates_endrun + + ! CIME Globals + use shr_log_mod , only : errMsg => shr_log_errMsg + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + + implicit none + + public :: FatesInterfaceInit + public :: set_fates_ctrlparms + public :: SetFatesTime + public :: set_fates_global_elements + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + ! ------------------------------------------------------------------------------------- + ! Parameters that are dictated by the Host Land Model + ! THESE ARE NOT DYNAMIC. SHOULD BE SET ONCE DURING INTIALIZATION. + ! ------------------------------------------------------------------------------------- + + + integer, protected :: hlm_numSWb ! Number of broad-bands in the short-wave radiation + ! specturm to track + ! (typically 2 as a default, VIS/NIR, in ED variants <2016) + + integer, protected :: hlm_ivis ! The HLMs assumption of the array index associated with the + ! visible portion of the spectrum in short-wave radiation arrays + + integer, protected :: hlm_inir ! The HLMs assumption of the array index associated with the + ! NIR portion of the spectrum in short-wave radiation arrays + + + integer, protected :: hlm_numlevgrnd ! Number of ground layers + integer, protected :: hlm_numlevsoil ! Number of soil layers + + + integer, protected :: hlm_numlevdecomp_full ! Number of GROUND layers for the purposes + ! of biogeochemistry; can be either 1 + ! or the total number of soil layers + ! (includes bedrock) + + + integer, protected :: hlm_numlevdecomp ! Number of SOIL layers for the purposes of + ! biogeochemistry; can be either 1 or the total + ! number of soil layers + + integer, protected :: hlm_is_restart ! Is the HLM signalling that this is a restart + ! type simulation? + ! 1=TRUE, 0=FALSE + + character(len=16), protected :: hlm_name ! This character string passed by the HLM + ! is used during the processing of IO data, + ! so that FATES knows which IO variables it + ! should prepare. For instance + ! ATS, ALM and CLM will only want variables + ! specficially packaged for them. + ! This string sets which filter is enacted. + + + real(r8), protected :: hlm_hio_ignore_val ! This value can be flushed to history + ! diagnostics, such that the + ! HLM will interpret that the value should not + ! be included in the average. + + integer, protected :: hlm_masterproc ! Is this the master processor, typically useful + ! for knowing if the current machine should be + ! printing out messages to the logs or terminals + ! 1 = TRUE (is master) 0 = FALSE (is not master) + + integer, protected :: hlm_ipedof ! The HLM pedotransfer index + ! this is only used by the plant hydraulics + ! submodule to check and/or enable consistency + ! between the pedotransfer functions of the HLM + ! and how it moves and stores water in its + ! rhizosphere shells + + integer, protected :: hlm_use_vertsoilc ! This flag signals whether or not the + ! host model is using vertically discretized + ! soil carbon + ! 1 = TRUE, 0 = FALSE + + ! SOON TO BE DEPRECATED, WILL BE READ IN VIA + ! FATES NL OR PARAM FILE. + integer, protected :: hlm_use_spitfire ! This flag signals whether or not to use SPITFIRE + ! 1 = TRUE, 0 = FALSE + + ! ------------------------------------------------------------------------------------- + ! Parameters that are dictated by FATES and known to be required knowledge + ! needed by the HLMs + ! ------------------------------------------------------------------------------------- + + ! Variables mostly used for dimensioning host land model (HLM) array spaces + + integer, protected :: fates_maxElementsPerPatch ! maxElementsPerPatch is the value that is ultimately + ! used to set the size of the largest arrays necessary + ! in things like restart files (probably hosted by the + ! HLM). The size of these arrays are not a parameter + ! because it is simply the maximum of several different + ! dimensions. It is possible that this would be the + ! maximum number of cohorts per patch, but + ! but it could be other things. + + integer, protected :: fates_maxElementsPerSite ! This is the max number of individual items one can store per + ! each grid cell and effects the striding in the ED restart + ! data as some fields are arrays where each array is + ! associated with one cohort + + + + ! ------------------------------------------------------------------------------------ + ! DYNAMIC BOUNDARY CONDITIONS + ! ------------------------------------------------------------------------------------ + + + ! ------------------------------------------------------------------------------------- + ! Scalar Timing Variables + ! It is assumed that all of the sites on a given machine will be synchronous. + ! It is also assumed that the HLM will control time. + ! ------------------------------------------------------------------------------------- + integer, protected :: hlm_current_year ! Current year + integer, protected :: hlm_current_month ! month of year + integer, protected :: hlm_current_day ! day of month + integer, protected :: hlm_current_tod ! time of day (seconds past 0Z) + integer, protected :: hlm_current_date ! time of day (seconds past 0Z) + integer, protected :: hlm_reference_date ! YYYYMMDD + real(r8), protected :: hlm_model_day ! elapsed days between current date and ref + integer, protected :: hlm_day_of_year ! The integer day of the year + integer, protected :: hlm_days_per_year ! The HLM controls time, some HLMs may + ! include a leap + real(r8), protected :: hlm_freq_day ! fraction of year for daily time-step + ! (1/days_per_year_, this is a frequency + + ! ------------------------------------------------------------------------------------- + ! Structured Boundary Conditions (SITE/PATCH SCALE) + ! For floating point arrays, it is sometimes the convention to define the arrays as + ! POINTER instead of ALLOCATABLE. This usually achieves the same result with subtle + ! differences. POINTER arrays can point to scalar values, discontinuous array slices + ! or alias other variables, ALLOCATABLES cannnot. According to S. Lionel + ! (Intel-Forum Post), ALLOCATABLES are better perfomance wise as long as they point + ! to contiguous memory spaces and do not alias other variables, the case here. + ! Naming conventions: _gl means ground layer dimensions + ! _si means site dimensions (scalar in that case) + ! _pa means patch dimensions + ! _rb means radiation band + ! ------------------------------------------------------------------------------------ + + + + + + type, public :: bc_in_type + + ! The actual number of FATES' ED patches + integer :: npatches + + + ! Soil layer structure + real(r8),allocatable :: zi_sisl(:) ! interface level below a "z" level (m) + ! this contains a zero index for surface. + real(r8),allocatable :: dz_sisl(:) ! layer thickness (m) + real(r8),allocatable :: z_sisl(:) ! layer depth (m) (1:hlm_nlevsoil) + + ! Decomposition Layer Structure + real(r8), allocatable :: dz_decomp_sisl(:) + + ! Vegetation Dynamics + ! --------------------------------------------------------------------------------- + + ! The site level 24 hour vegetation temperature is used for various purposes during vegetation + ! dynamics. However, we are currently using the bare ground patch's value [K] + ! TO-DO: Get some consensus on the correct vegetation temperature used for phenology. + ! It is possible that the bare-ground value is where the average is being stored. + ! (RGK-01-2017) + real(r8) :: t_veg24_si + + ! Patch 24 hour vegetation temperature [K] + real(r8),allocatable :: t_veg24_pa(:) + + ! Fire Model + + ! Average precipitation over the last 24 hours [mm/s] + real(r8), allocatable :: precip24_pa(:) + + ! Average relative humidity over past 24 hours [-] + real(r8), allocatable :: relhumid24_pa(:) + + ! Patch 24-hour running mean of wind (m/s ?) + real(r8), allocatable :: wind24_pa(:) + + + ! Radiation variables for calculating sun/shade fractions + ! --------------------------------------------------------------------------------- + + ! Downwelling direct beam radiation (patch,radiation-band) [W/m2] + real(r8), allocatable :: solad_parb(:,:) + + ! Downwelling diffuse (I-ndirect) radiation (patch,radiation-band) [W/m2] + real(r8), allocatable :: solai_parb(:,:) + + + + ! Photosynthesis variables + ! --------------------------------------------------------------------------------- + + ! Patch level filter flag for photosynthesis calculations + ! has a short memory, flags: + ! 1 = patch has not been called + ! 2 = patch is currently marked for photosynthesis + ! 3 = patch has been called for photosynthesis at least once + integer, allocatable :: filter_photo_pa(:) + + ! atmospheric pressure (Pa) + real(r8) :: forc_pbot + + ! daylength scaling factor (0-1) + real(r8), allocatable :: dayl_factor_pa(:) + + ! saturation vapor pressure at t_veg (Pa) + real(r8), allocatable :: esat_tv_pa(:) + + ! vapor pressure of canopy air (Pa) + real(r8), allocatable :: eair_pa(:) + + ! Atmospheric O2 partial pressure (Pa) + real(r8), allocatable :: oair_pa(:) + + ! Atmospheric CO2 partial pressure (Pa) + real(r8), allocatable :: cair_pa(:) + + ! boundary layer resistance (s/m) + real(r8), allocatable :: rb_pa(:) + + ! vegetation temperature (Kelvin) + real(r8), allocatable :: t_veg_pa(:) + + ! air temperature at agcm reference height (kelvin) + real(r8), allocatable :: tgcm_pa(:) + + ! soil temperature (Kelvin) + real(r8), allocatable :: t_soisno_gl(:) + + ! Canopy Radiation Boundaries + ! --------------------------------------------------------------------------------- + + ! Filter for vegetation patches with a positive zenith angle (daylight) + logical, allocatable :: filter_vegzen_pa(:) + + ! Cosine of the zenith angle (0-1), by patch + ! Note RGK: It does not seem like the code would currently generate + ! different zenith angles for different patches (nor should it) + ! I am leaving it at this scale for simplicity. Patches should + ! have no spacially variable information + real(r8), allocatable :: coszen_pa(:) + + ! Abledo of the ground for direct radiation, by site broadband (0-1) + real(r8), allocatable :: albgr_dir_rb(:) + + ! Albedo of the ground for diffuse radiation, by site broadband (0-1) + real(r8), allocatable :: albgr_dif_rb(:) + + ! LitterFlux Boundaries + ! the index of the deepest model soil level where roots may be + ! due to permafrost or bedrock constraints + integer :: max_rooting_depth_index_col + + ! BGC Accounting + + real(r8) :: tot_het_resp ! total heterotrophic respiration (gC/m2/s) + real(r8) :: tot_somc ! total soil organic matter carbon (gc/m2) + real(r8) :: tot_litc ! total litter carbon tracked in the HLM (gc/m2) + + ! Canopy Structure + + real(r8) :: snow_depth_si ! Depth of snow in snowy areas of site (m) + real(r8) :: frac_sno_eff_si ! Fraction of ground covered by snow (0-1) + + ! Hydrology variables for BTRAN + ! --------------------------------------------------------------------------------- + + ! Soil suction potential of layers in each site, negative, [mm] + real(r8), allocatable :: smp_gl(:) + + ! Effective porosity = porosity - vol_ic, of layers in each site [-] + real(r8), allocatable :: eff_porosity_gl(:) + + ! volumetric soil water at saturation (porosity) + real(r8), allocatable :: watsat_gl(:) + + ! Temperature of ground layers [K] + real(r8), allocatable :: tempk_gl(:) + + ! Liquid volume in ground layer (m3/m3) + real(r8), allocatable :: h2o_liqvol_gl(:) + + ! Site level filter for uptake response functions + logical :: filter_btran + + ! Plant-Hydro + ! --------------------------------------------------------------------------------- + + + real(r8),allocatable :: qflx_transp_pa(:) ! Transpiration flux as dictated by the HLM's + ! canopy solver. [mm H2O/s] [+ into root] + real(r8),allocatable :: swrad_net_pa(:) ! Net absorbed shortwave radiation (W/m2) + real(r8),allocatable :: lwrad_net_pa(:) ! Net absorbed longwave radiation (W/m2) + real(r8),allocatable :: watsat_sisl(:) ! volumetric soil water at saturation (porosity) + real(r8),allocatable :: watres_sisl(:) ! volumetric residual soil water + real(r8),allocatable :: sucsat_sisl(:) ! minimum soil suction (mm) (hlm_nlevsoil) + real(r8),allocatable :: bsw_sisl(:) ! Clapp and Hornberger "b" (hlm_nlevsoil) + real(r8),allocatable :: hksat_sisl(:) ! hydraulic conductivity at saturation (mm H2O /s) + real(r8),allocatable :: h2o_liq_sisl(:) ! Liquid water mass in each layer (kg/m2) + real(r8) :: smpmin_si ! restriction for min of soil potential (mm) + + end type bc_in_type + + + type, public :: bc_out_type + + ! Sunlit fraction of the canopy for this patch [0-1] + real(r8),allocatable :: fsun_pa(:) + + ! Sunlit canopy LAI + real(r8),allocatable :: laisun_pa(:) + + ! Shaded canopy LAI + real(r8),allocatable :: laisha_pa(:) + + ! Logical stating whether a ground layer can have water uptake by plants + ! The only condition right now is that liquid water exists + ! The name (suction) is used to indicate that soil suction should be calculated + logical, allocatable :: active_suction_gl(:) + + ! Effective fraction of roots in each soil layer + real(r8), allocatable :: rootr_pagl(:,:) + + ! Integrated (vertically) transpiration wetness factor (0 to 1) + ! (diagnostic, should not be used by HLM) + real(r8), allocatable :: btran_pa(:) + + ! Sunlit canopy resistance [s/m] + real(r8), allocatable :: rssun_pa(:) + + ! Shaded canopy resistance [s/m] + real(r8), allocatable :: rssha_pa(:) + + ! leaf photosynthesis (umol CO2 /m**2/ s) + ! (NOT CURRENTLY USED, PLACE-HOLDER) + !real(r8), allocatable :: psncanopy_pa(:) + + ! leaf maintenance respiration rate (umol CO2/m**2/s) + ! (NOT CURRENTLY USED, PLACE-HOLDER) + !real(r8), allocatable :: lmrcanopy_pa(:) + + ! Canopy Radiation Boundaries + ! --------------------------------------------------------------------------------- + + ! Surface albedo (direct) (HLMs use this for atm coupling and balance checks) + real(r8), allocatable :: albd_parb(:,:) + + ! Surface albedo (diffuse) (HLMs use this for atm coupling and balance checks) + real(r8), allocatable :: albi_parb(:,:) + + ! Flux absorbed by canopy per unit direct flux (HLMs use this for balance checks) + real(r8), allocatable :: fabd_parb(:,:) + + ! Flux absorbed by canopy per unit diffuse flux (HLMs use this for balance checks) + real(r8), allocatable :: fabi_parb(:,:) + + ! Down direct flux below canopy per unit direct flx (HLMs use this for balance checks) + real(r8), allocatable :: ftdd_parb(:,:) + + ! Down diffuse flux below canopy per unit direct flx (HLMs use this for balance checks) + real(r8), allocatable :: ftid_parb(:,:) + + ! Down diffuse flux below canopy per unit diffuse flx (HLMs use this for balance checks) + real(r8), allocatable :: ftii_parb(:,:) + + + ! litterfall fluxes of C from FATES patches to BGC columns + + ! total labile litter coming from ED. gC/m3/s + real(r8), allocatable :: FATES_c_to_litr_lab_c_col(:) + + !total cellulose litter coming from ED. gC/m3/s + real(r8), allocatable :: FATES_c_to_litr_cel_c_col(:) + + !total lignin litter coming from ED. gC/m3/s + real(r8), allocatable :: FATES_c_to_litr_lig_c_col(:) + + + + ! Canopy Structure + + real(r8), allocatable :: elai_pa(:) ! exposed leaf area index + real(r8), allocatable :: esai_pa(:) ! exposed stem area index + real(r8), allocatable :: tlai_pa(:) ! total leaf area index + real(r8), allocatable :: tsai_pa(:) ! total stem area index + real(r8), allocatable :: htop_pa(:) ! top of the canopy [m] + real(r8), allocatable :: hbot_pa(:) ! bottom of canopy? [m] + + real(r8), allocatable :: z0m_pa(:) ! roughness length [m] + real(r8), allocatable :: displa_pa(:) ! displacement height [m] + real(r8), allocatable :: dleaf_pa(:) ! leaf characteristic dimension/width/diameter [m] + + real(r8), allocatable :: canopy_fraction_pa(:) ! Area fraction of each patch in the site + ! Use most likely for weighting + ! This is currently the projected canopy + ! area of each patch [0-1] + + real(r8), allocatable :: frac_veg_nosno_alb_pa(:) ! This is not really a fraction + ! this is actually binary based on if any + ! vegetation in the patch is exposed. + ! [0,1] + + ! FATES Hydraulics + + real(r8) :: plant_stored_h2o_si ! stored water in vegetation (kg/m2 H2O) + ! Assuming density of 1Mg/m3 ~= mm/m2 H2O + ! This must be set and transfered prior to clm_drv() + ! following the calls to ed_update_site() + ! ed_update_site() is called during both the restart + ! and coldstart process + + real(r8),allocatable :: qflx_soil2root_sisl(:) ! Water flux from soil into root by site and soil layer + ! [mm H2O/s] [+ into root] + + end type bc_out_type + + + type, public :: fates_interface_type + + ! This is the root of the ED/FATES hierarchy of instantaneous state variables + ! ie the root of the linked lists. Each path list is currently associated with a + ! grid-cell, this is intended to be migrated to columns + + integer :: nsites + + type(ed_site_type), pointer :: sites(:) + + ! These are boundary conditions that the FATES models are required to be filled. + ! These values are filled by the driver or HLM. Once filled, these have an + ! intent(in) status. Each site has a derived type structure, which may include + ! a scalar for site level data, a patch vector, potentially cohort vectors (but + ! not yet atm) and other dimensions such as soil-depth or pft. These vectors + ! are initialized by maximums, and the allocations are static in time to avoid + ! having to allocate/de-allocate memory + + type(bc_in_type), allocatable :: bc_in(:) + + ! These are the boundary conditions that the FATES model returns to its HLM or + ! driver. It has the same allocation strategy and similar vector types. + + type(bc_out_type), allocatable :: bc_out(:) + + contains + + procedure, public :: zero_bcs + + end type fates_interface_type + + + + +contains + + ! ==================================================================================== + subroutine FatesInterfaceInit(log_unit,global_verbose) + + use FatesGlobals, only : FatesGlobalsInit + + implicit none + + integer, intent(in) :: log_unit + logical, intent(in) :: global_verbose + + call FatesGlobalsInit(log_unit,global_verbose) + + end subroutine FatesInterfaceInit + + ! ==================================================================================== + + ! INTERF-TODO: THIS IS A PLACE-HOLDER ROUTINE, NOT CALLED YET... + subroutine fates_clean(this) + + implicit none + + ! Input Arguments + class(fates_interface_type), intent(inout) :: this + + ! Incrementally walk through linked list and deallocate + + + + ! Deallocate the site list +! deallocate (this%sites) + + return + end subroutine fates_clean + + + ! ==================================================================================== + + + subroutine allocate_bcin(bc_in) + + ! --------------------------------------------------------------------------------- + ! Allocate and Initialze the FATES boundary condition vectors + ! --------------------------------------------------------------------------------- + + implicit none + type(bc_in_type), intent(inout) :: bc_in + + ! Allocate input boundaries + allocate(bc_in%zi_sisl(0:hlm_numlevsoil)) + allocate(bc_in%dz_sisl(hlm_numlevsoil)) + allocate(bc_in%z_sisl(hlm_numlevsoil)) + + allocate(bc_in%dz_decomp_sisl(hlm_numlevdecomp_full)) + + ! Vegetation Dynamics + allocate(bc_in%t_veg24_pa(maxPatchesPerSite)) + + allocate(bc_in%wind24_pa(maxPatchesPerSite)) + allocate(bc_in%relhumid24_pa(maxPatchesPerSite)) + allocate(bc_in%precip24_pa(maxPatchesPerSite)) + + ! Radiation + allocate(bc_in%solad_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_in%solai_parb(maxPatchesPerSite,hlm_numSWb)) + + ! Hydrology + allocate(bc_in%smp_gl(hlm_numlevgrnd)) + allocate(bc_in%eff_porosity_gl(hlm_numlevgrnd)) + allocate(bc_in%watsat_gl(hlm_numlevgrnd)) + allocate(bc_in%tempk_gl(hlm_numlevgrnd)) + allocate(bc_in%h2o_liqvol_gl(hlm_numlevgrnd)) + + ! Photosynthesis + allocate(bc_in%filter_photo_pa(maxPatchesPerSite)) + allocate(bc_in%dayl_factor_pa(maxPatchesPerSite)) + allocate(bc_in%esat_tv_pa(maxPatchesPerSite)) + allocate(bc_in%eair_pa(maxPatchesPerSite)) + allocate(bc_in%oair_pa(maxPatchesPerSite)) + allocate(bc_in%cair_pa(maxPatchesPerSite)) + allocate(bc_in%rb_pa(maxPatchesPerSite)) + allocate(bc_in%t_veg_pa(maxPatchesPerSite)) + allocate(bc_in%tgcm_pa(maxPatchesPerSite)) + allocate(bc_in%t_soisno_gl(hlm_numlevgrnd)) + + ! Canopy Radiation + allocate(bc_in%filter_vegzen_pa(maxPatchesPerSite)) + allocate(bc_in%coszen_pa(maxPatchesPerSite)) + allocate(bc_in%albgr_dir_rb(hlm_numSWb)) + allocate(bc_in%albgr_dif_rb(hlm_numSWb)) + + ! Plant-Hydro BC's + if (use_fates_plant_hydro) then + + allocate(bc_in%qflx_transp_pa(maxPatchesPerSite)) + allocate(bc_in%swrad_net_pa(maxPatchesPerSite)) + allocate(bc_in%lwrad_net_pa(maxPatchesPerSite)) + allocate(bc_in%watsat_sisl(hlm_numlevsoil)) + allocate(bc_in%watres_sisl(hlm_numlevsoil)) + allocate(bc_in%sucsat_sisl(hlm_numlevsoil)) + allocate(bc_in%bsw_sisl(hlm_numlevsoil)) + allocate(bc_in%hksat_sisl(hlm_numlevsoil)) + allocate(bc_in%h2o_liq_sisl(hlm_numlevsoil)); bc_in%h2o_liq_sisl = nan + end if + + return + end subroutine allocate_bcin + + subroutine allocate_bcout(bc_out) + + ! --------------------------------------------------------------------------------- + ! Allocate and Initialze the FATES boundary condition vectors + ! --------------------------------------------------------------------------------- + + implicit none + type(bc_out_type), intent(inout) :: bc_out + + + ! Radiation + allocate(bc_out%fsun_pa(maxPatchesPerSite)) + allocate(bc_out%laisun_pa(maxPatchesPerSite)) + allocate(bc_out%laisha_pa(maxPatchesPerSite)) + + ! Hydrology + allocate(bc_out%active_suction_gl(hlm_numlevgrnd)) + allocate(bc_out%rootr_pagl(maxPatchesPerSite,hlm_numlevgrnd)) + allocate(bc_out%btran_pa(maxPatchesPerSite)) + + ! Photosynthesis + + allocate(bc_out%rssun_pa(maxPatchesPerSite)) + allocate(bc_out%rssha_pa(maxPatchesPerSite)) + + ! Canopy Radiation + allocate(bc_out%albd_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_out%albi_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_out%fabd_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_out%fabi_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_out%ftdd_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_out%ftid_parb(maxPatchesPerSite,hlm_numSWb)) + allocate(bc_out%ftii_parb(maxPatchesPerSite,hlm_numSWb)) + + ! biogeochemistry + allocate(bc_out%FATES_c_to_litr_lab_c_col(hlm_numlevdecomp_full)) + allocate(bc_out%FATES_c_to_litr_cel_c_col(hlm_numlevdecomp_full)) + allocate(bc_out%FATES_c_to_litr_lig_c_col(hlm_numlevdecomp_full)) + + ! Canopy Structure + allocate(bc_out%elai_pa(maxPatchesPerSite)) + allocate(bc_out%esai_pa(maxPatchesPerSite)) + allocate(bc_out%tlai_pa(maxPatchesPerSite)) + allocate(bc_out%tsai_pa(maxPatchesPerSite)) + allocate(bc_out%htop_pa(maxPatchesPerSite)) + allocate(bc_out%hbot_pa(maxPatchesPerSite)) + allocate(bc_out%dleaf_pa(maxPatchesPerSite)) + + allocate(bc_out%displa_pa(maxPatchesPerSite)) + allocate(bc_out%z0m_pa(maxPatchesPerSite)) + + allocate(bc_out%canopy_fraction_pa(maxPatchesPerSite)) + allocate(bc_out%frac_veg_nosno_alb_pa(maxPatchesPerSite)) + + ! Plant-Hydro BC's + if (use_fates_plant_hydro) then + allocate(bc_out%qflx_soil2root_sisl(hlm_numlevsoil)) + end if + + return + end subroutine allocate_bcout + + ! ==================================================================================== + + subroutine zero_bcs(this,s) + + implicit none + class(fates_interface_type), intent(inout) :: this + integer, intent(in) :: s + + ! Input boundaries + this%bc_in(s)%zi_sisl(:) = 0.0_r8 + this%bc_in(s)%dz_sisl(:) = 0.0_r8 + this%bc_in(s)%z_sisl(:) = 0.0_r8 + this%bc_in(s)%dz_decomp_sisl = 0.0_r8 + + this%bc_in(s)%t_veg24_si = 0.0_r8 + this%bc_in(s)%t_veg24_pa(:) = 0.0_r8 + this%bc_in(s)%precip24_pa(:) = 0.0_r8 + this%bc_in(s)%relhumid24_pa(:) = 0.0_r8 + this%bc_in(s)%wind24_pa(:) = 0.0_r8 + + this%bc_in(s)%solad_parb(:,:) = 0.0_r8 + this%bc_in(s)%solai_parb(:,:) = 0.0_r8 + this%bc_in(s)%smp_gl(:) = 0.0_r8 + this%bc_in(s)%eff_porosity_gl(:) = 0.0_r8 + this%bc_in(s)%watsat_gl(:) = 0.0_r8 + this%bc_in(s)%tempk_gl(:) = 0.0_r8 + this%bc_in(s)%h2o_liqvol_gl(:) = 0.0_r8 + this%bc_in(s)%filter_vegzen_pa(:) = .false. + this%bc_in(s)%coszen_pa(:) = 0.0_r8 + this%bc_in(s)%albgr_dir_rb(:) = 0.0_r8 + this%bc_in(s)%albgr_dif_rb(:) = 0.0_r8 + this%bc_in(s)%max_rooting_depth_index_col = 0 + this%bc_in(s)%tot_het_resp = 0.0_r8 + this%bc_in(s)%tot_somc = 0.0_r8 + this%bc_in(s)%tot_litc = 0.0_r8 + this%bc_in(s)%snow_depth_si = 0.0_r8 + this%bc_in(s)%frac_sno_eff_si = 0.0_r8 + + if (use_fates_plant_hydro) then + + this%bc_in(s)%qflx_transp_pa(:) = 0.0_r8 + this%bc_in(s)%swrad_net_pa(:) = 0.0_r8 + this%bc_in(s)%lwrad_net_pa(:) = 0.0_r8 + this%bc_in(s)%watsat_sisl(:) = 0.0_r8 + this%bc_in(s)%watres_sisl(:) = 0.0_r8 + this%bc_in(s)%sucsat_sisl(:) = 0.0_r8 + this%bc_in(s)%bsw_sisl(:) = 0.0_r8 + this%bc_in(s)%hksat_sisl(:) = 0.0_r8 + end if + + + ! Output boundaries + this%bc_out(s)%active_suction_gl(:) = .false. + this%bc_out(s)%fsun_pa(:) = 0.0_r8 + this%bc_out(s)%laisun_pa(:) = 0.0_r8 + this%bc_out(s)%laisha_pa(:) = 0.0_r8 + this%bc_out(s)%rootr_pagl(:,:) = 0.0_r8 + this%bc_out(s)%btran_pa(:) = 0.0_r8 + + this%bc_out(s)%FATES_c_to_litr_lab_c_col(:) = 0.0_r8 + this%bc_out(s)%FATES_c_to_litr_cel_c_col(:) = 0.0_r8 + this%bc_out(s)%FATES_c_to_litr_lig_c_col(:) = 0.0_r8 + + this%bc_out(s)%rssun_pa(:) = 0.0_r8 + this%bc_out(s)%rssha_pa(:) = 0.0_r8 + + this%bc_out(s)%albd_parb(:,:) = 0.0_r8 + this%bc_out(s)%albi_parb(:,:) = 0.0_r8 + this%bc_out(s)%fabd_parb(:,:) = 0.0_r8 + this%bc_out(s)%fabi_parb(:,:) = 0.0_r8 + this%bc_out(s)%ftdd_parb(:,:) = 0.0_r8 + this%bc_out(s)%ftid_parb(:,:) = 0.0_r8 + this%bc_out(s)%ftii_parb(:,:) = 0.0_r8 + + this%bc_out(s)%elai_pa(:) = 0.0_r8 + this%bc_out(s)%esai_pa(:) = 0.0_r8 + this%bc_out(s)%tlai_pa(:) = 0.0_r8 + this%bc_out(s)%tsai_pa(:) = 0.0_r8 + this%bc_out(s)%htop_pa(:) = 0.0_r8 + this%bc_out(s)%hbot_pa(:) = 0.0_r8 + this%bc_out(s)%displa_pa(:) = 0.0_r8 + this%bc_out(s)%z0m_pa(:) = 0.0_r8 + this%bc_out(s)%dleaf_pa(:) = 0.0_r8 + + this%bc_out(s)%canopy_fraction_pa(:) = 0.0_r8 + this%bc_out(s)%frac_veg_nosno_alb_pa(:) = 0.0_r8 + + if (use_fates_plant_hydro) then + this%bc_out(s)%qflx_soil2root_sisl(:) = 0.0_r8 + end if + this%bc_out(s)%plant_stored_h2o_si = 0.0_r8 + + return + end subroutine zero_bcs + + + ! =================================================================================== + + subroutine set_fates_global_elements(use_fates) + implicit none + + logical,intent(in) :: use_fates ! Is fates turned on? + + if (use_fates) then + + fates_maxElementsPerPatch = max(maxCohortsPerPatch, & + numpft_ed * nclmax * nlevleaf) + + fates_maxElementsPerSite = maxPatchesPerSite * fates_maxElementsPerPatch + + else + ! If we are not using FATES, the cohort dimension is still + ! going to be initialized, lets set it to the smallest value + ! possible so that the dimensioning info takes up little space + + fates_maxElementsPerPatch = 1 + + fates_maxElementsPerSite = 1 + + + end if + + + end subroutine set_fates_global_elements + + ! =================================================================================== + + subroutine SetFatesTime(current_year_in, current_month_in, & + current_day_in, current_tod_in, & + current_date_in, reference_date_in, & + model_day_in, day_of_year_in, & + days_per_year_in, freq_day_in) + + ! This subroutine should be called directly from the HLM + + integer, intent(in) :: current_year_in + integer, intent(in) :: current_month_in + integer, intent(in) :: current_day_in + integer, intent(in) :: current_tod_in + integer, intent(in) :: current_date_in + integer, intent(in) :: reference_date_in + real(r8), intent(in) :: model_day_in + integer, intent(in) :: day_of_year_in + integer, intent(in) :: days_per_year_in + real(r8), intent(in) :: freq_day_in + + hlm_current_year = current_year_in + hlm_current_month = current_month_in + hlm_current_day = current_day_in + hlm_current_tod = current_tod_in + hlm_current_date = current_date_in + hlm_reference_date = reference_date_in + hlm_model_day = model_day_in + hlm_day_of_year = day_of_year_in + hlm_days_per_year = days_per_year_in + hlm_freq_day = freq_day_in + + end subroutine SetFatesTime + + ! ==================================================================================== + + subroutine set_fates_ctrlparms(tag,ival,rval,cval) + + ! --------------------------------------------------------------------------------- + ! Certain model control parameters and dimensions used by FATES are dictated by + ! the the driver or the host mode. To see which parameters should be filled here + ! please also look at the ctrl_parms_type in FATESTYpeMod, in the section listing + ! components dictated by the host model. + ! + ! Some important points: + ! 1. Calls to this function are likely from the clm_fates module in the HLM. + ! 2. The calls should be preceeded by a flush function. + ! 3. All values in ctrl_parm (FATESTypesMod.F90) that are classified as + ! 'dictated by the HLM' must be listed in this subroutine + ! 4. Should look like this: + ! + ! call set_fates_ctrlparms('flush_to_unset') + ! call set_fates_ctrlparms('num_sw_bbands',numrad) ! or other variable + ! ... + ! call set_fates_ctrlparms('num_lev_ground',nlevgrnd) ! or other variable + ! call set_fates_ctrlparms('check_allset') + ! + ! RGK-2016 + ! --------------------------------------------------------------------------------- + + ! Arguments + integer, optional, intent(in) :: ival + real(r8), optional, intent(in) :: rval + character(len=*),optional, intent(in) :: cval + character(len=*),intent(in) :: tag + + ! local variables + logical :: all_set + integer, parameter :: unset_int = -999 + real(r8), parameter :: unset_double = -999.9 + + + select case (trim(tag)) + case('flush_to_unset') + if (fates_global_verbose()) then + write(fates_log(), *) 'Flushing FATES control parameters prior to transfer from host' + end if + + hlm_numSWb = unset_int + hlm_inir = unset_int + hlm_ivis = unset_int + hlm_is_restart = unset_int + hlm_numlevgrnd = unset_int + hlm_numlevsoil = unset_int + hlm_numlevdecomp_full = unset_int + hlm_numlevdecomp = unset_int + hlm_name = 'unset' + hlm_hio_ignore_val = unset_double + hlm_masterproc = unset_int + hlm_ipedof = unset_int + hlm_use_vertsoilc = unset_int + hlm_use_spitfire = unset_int + + case('check_allset') + + if(hlm_numSWb .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES dimension/parameter unset: num_sw_rad_bbands' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_masterproc .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES parameter unset: hlm_masterproc' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_numSWb > maxSWb) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES sets a maximum number of shortwave bands' + write(fates_log(), *) 'for some scratch-space, maxSWb' + write(fates_log(), *) 'it defaults to 2, but can be increased as needed' + write(fates_log(), *) 'your driver or host model is intending to drive' + write(fates_log(), *) 'FATES with:',hlm_numSWb,' bands.' + write(fates_log(), *) 'please increase maxSWb in EDTypes to match' + write(fates_log(), *) 'or exceed this value' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_ivis .ne. ivis) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES assumption about the index of visible shortwave' + write(fates_log(), *) 'radiation is different from the HLM' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_inir .ne. inir) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES assumption about the index of NIR shortwave' + write(fates_log(), *) 'radiation is different from the HLM' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_is_restart .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES parameter unset: hlm_is_restart' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_numlevgrnd .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES dimension/parameter unset: numlevground' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_numlevsoil .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES dimension/parameter unset: numlevground' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_numlevdecomp_full .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES dimension/parameter unset: numlevdecomp_full' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_numlevdecomp .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'FATES dimension/parameter unset: numlevdecomp' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(trim(hlm_name) .eq. 'unset') then + if (fates_global_verbose()) then + write(fates_log(),*) 'FATES dimension/parameter unset: hlm_name' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if( abs(hlm_hio_ignore_val-unset_double)<1e-10 ) then + if (fates_global_verbose()) then + write(fates_log(),*) 'FATES dimension/parameter unset: hio_ignore' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_ipedof .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'index for the HLMs pedotransfer function unset: hlm_ipedof' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_use_vertsoilc .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'switch for the HLMs soil carbon discretization unset: hlm_use_vertsoilc' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_use_spitfire .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'switch for SPITFIRE unset: hlm_use_spitfire' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if (fates_global_verbose()) then + write(fates_log(), *) 'Checked. All control parameters sent to FATES.' + end if + + + case default + + if(present(ival))then + select case (trim(tag)) + + case('masterproc') + hlm_masterproc = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering masterproc = ',ival,' to FATES' + end if + + case('num_sw_bbands') + hlm_numSwb = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering num_sw_bbands = ',ival,' to FATES' + end if + + case('vis_sw_index') + hlm_ivis = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering index associated with visible SW rad = ',ival,' to FATES' + end if + + case('nir_sw_index') + hlm_inir = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering index associated with NIR SW rad = ',ival,' to FATES' + end if + + case('is_restart') + hlm_is_restart = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering flag signaling restart / not-restart = ',ival,' to FATES' + end if + + case('num_lev_ground') + hlm_numlevgrnd = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering num_lev_ground = ',ival,' to FATES' + end if + + case('num_lev_soil') + hlm_numlevsoil = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering num_lev_ground = ',ival,' to FATES' + end if + + case('num_levdecomp_full') + hlm_numlevdecomp_full = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering num_levdecomp_full = ',ival,' to FATES' + end if + + case('num_levdecomp') + hlm_numlevdecomp = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering num_levdecomp = ',ival,' to FATES' + end if + + case('soilwater_ipedof') + hlm_ipedof = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_ipedof = ',ival,' to FATES' + end if + + case('use_vertsoilc') + hlm_use_vertsoilc = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_use_vertsoilc= ',ival,' to FATES' + end if + + case('use_spitfire') + hlm_use_spitfire = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_use_spitfire= ',ival,' to FATES' + end if + + case default + if (fates_global_verbose()) then + write(fates_log(), *) 'tag not recognized:',trim(tag) + end if + ! end_run + end select + + end if + + if(present(rval))then + select case (trim(tag)) + case ('hio_ignore_val') + hlm_hio_ignore_val = rval + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hio_ignore_val = ',rval,' to FATES' + end if + case default + if (fates_global_verbose()) then + write(fates_log(),*) 'tag not recognized:',trim(tag) + end if + ! end_run + end select + end if + + if(present(cval))then + select case (trim(tag)) + + case('hlm_name') + hlm_name = trim(cval) + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering the HLM name = ',trim(cval) + end if + + case default + if (fates_global_verbose()) then + write(fates_log(),*) 'tag not recognized:',trim(tag) + end if + ! end_run + end select + end if + + end select + + return + end subroutine set_fates_ctrlparms + + +end module FatesInterfaceMod diff --git a/main/FatesParameterDerivedMod.F90 b/main/FatesParameterDerivedMod.F90 new file mode 100644 index 00000000..c72e70d7 --- /dev/null +++ b/main/FatesParameterDerivedMod.F90 @@ -0,0 +1,117 @@ +module FatesParameterDerivedMod + + ! ------------------------------------------------------------------------------------- + ! This module contains all procedures types and settings for any quantities that are + ! statically derived from static model parameters. These are unchanging quantities + ! and are based off of simple relationships from parameters that the user can + ! vary. This should be called once, and early in the model initialization call + ! sequence immediately after FATES parameters are read in. + ! ------------------------------------------------------------------------------------- + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : umolC_to_kgC + use FatesConstantsMod, only : g_per_kg + + type param_derived_type + + real(r8), allocatable :: vcmax25top(:) ! canopy top: maximum rate of carboxylation + ! at 25C (umol CO2/m**2/s) + real(r8), allocatable :: jmax25top(:) ! canopy top: maximum electron transport + ! rate at 25C (umol electrons/m**2/s) + real(r8), allocatable :: tpu25top(:) ! canopy top: triose phosphate utilization + ! 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 :: lmr25top(:) ! canopy top: leaf maintenance respiration + ! rate at 25C (umol CO2/m**2/s) + contains + + procedure :: Init + procedure :: InitAllocate + + end type param_derived_type + + type(param_derived_type) :: param_derived + +contains + + subroutine InitAllocate(this,maxpft) + + class(param_derived_type), intent(inout) :: this + integer, intent(in) :: maxpft + + allocate(this%vcmax25top(maxpft)) + allocate(this%jmax25top(maxpft)) + allocate(this%tpu25top(maxpft)) + allocate(this%kp25top(maxpft)) + allocate(this%lmr25top(maxpft)) + + return + end subroutine InitAllocate + + ! ===================================================================================== + + subroutine Init(this,maxpft) + + use EDPftvarcon, only: EDPftvarcon_inst + + class(param_derived_type), intent(inout) :: this + integer, intent(in) :: maxpft + + ! local variables + integer :: ft ! pft index + real(r8) :: lnc ! leaf N concentration (gN leaf/m^2) + + associate( & + + slatop => EDPftvarcon_inst%slatop , & ! specific leaf area at top of canopy, + ! projected area basis [m^2/gC] + fnitr => EDPftvarcon_inst%fnitr , & ! foliage nitrogen limitation factor (-) + leafcn => EDPftvarcon_inst%leafcn ) ! leaf C:N (gC/gN) + + call this%InitAllocate(maxpft) + + do ft = 1,maxpft + + ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) + lnc = 1._r8 / (slatop(ft) * leafcn(ft)) + + ! at the moment in ED we assume that there is no active N cycle. + ! This should change, of course. FIX(RF,032414) Sep2011. + ! fudge - shortcut using fnitr as a proxy for vcmax... + this%vcmax25top(ft) = fnitr(ft) + + ! Parameters derived from vcmax25top. + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + ! used jmax25 = 1.97 vcmax25, from Wullschleger (1993) Journal of + ! Experimental Botany 44:907-920. Here use a factor "1.67", from + ! Medlyn et al (2002) Plant, Cell and Environment 25:1167-1179 + + ! RF - copied this from the CLM trunk code, but where did it come from, + ! and how can we make these consistant? + ! jmax25top(ft) = & + ! (2.59_r8 - 0.035_r8*min(max((t10(p)-tfrzc),11._r8),35._r8)) * vcmax25top(ft) + + this%jmax25top(ft) = 1.67_r8 * this%vcmax25top(ft) + this%tpu25top(ft) = 0.167_r8 * this%vcmax25top(ft) + this%kp25top(ft) = 20000._r8 * this%vcmax25top(ft) + + ! Leaf maintenance respiration to match the base rate used in CN + ! but with the new temperature functions for C3 and C4 plants. + ! + ! + ! CN respiration has units: g C / g N [leaf] / s. This needs to be + ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s + ! + ! Then scale this value at the top of the canopy for canopy depth + + this%lmr25top(ft) = 2.525e-6_r8 * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) + this%lmr25top(ft) = this%lmr25top(ft) * lnc / (umolC_to_kgC * g_per_kg) + + end do !ft + end associate + return + end subroutine Init + + +end module FatesParameterDerivedMod diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 new file mode 100644 index 00000000..007dd78d --- /dev/null +++ b/main/FatesParametersInterface.F90 @@ -0,0 +1,484 @@ +module FatesParametersInterface + ! NOTE(bja, 2017-01) this is part of the interface between fates and + ! the host model. To avoid circular dependancies, it should not + ! depend on any host modules. + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesGlobals, only : fates_log + + implicit none + + integer, parameter, public :: max_params = 250 + integer, parameter, public :: max_dimensions = 2 + integer, parameter, public :: max_used_dimensions = 25 + integer, parameter, public :: param_string_length = 40 + ! NOTE(bja, 2017-02) these are the values returned from netcdf after + ! inquiring about the number of dimensions + integer, parameter, public :: dimension_shape_scalar = 0 + integer, parameter, public :: dimension_shape_1d = 1 + integer, parameter, public :: dimension_shape_2d = 2 + + ! Dimensions in the fates namespace: + character(len=*), parameter, public :: dimension_name_scalar = '' + character(len=*), parameter, public :: dimension_name_scalar1d = 'fates_scalar' + character(len=*), parameter, public :: dimension_name_pft = 'fates_pft' + character(len=*), parameter, public :: dimension_name_segment = 'fates_segment' + character(len=*), parameter, public :: dimension_name_cwd = 'fates_NCWD' + character(len=*), parameter, public :: dimension_name_lsc = 'fates_litterclass' + character(len=*), parameter, public :: dimension_name_fsc = 'fates_litterclass' + character(len=*), parameter, public :: dimension_name_allpfts = 'fates_allpfts' + character(len=*), parameter, public :: dimension_name_variants = 'fates_variants' + + ! Dimensions in the host namespace: + character(len=*), parameter, public :: dimension_name_host_allpfts = 'allpfts' + + type, private :: parameter_type + character(len=param_string_length) :: name + logical :: sync_with_host + integer :: dimension_shape + integer :: dimension_sizes(max_dimensions) + character(len=param_string_length) :: dimension_names(max_dimensions) + integer :: dimension_lower_bound(max_dimensions) + real(r8), allocatable :: data(:, :) + end type parameter_type + + type, public :: fates_parameters_type + integer, private :: num_parameters + type(parameter_type), private :: parameters(max_params) + + contains + procedure, public :: Init + procedure, public :: Destroy + procedure, public :: RegisterParameter + generic, public :: RetreiveParameter => RetreiveParameterScalar, RetreiveParameter1D, RetreiveParameter2D + generic, public :: RetreiveParameterAllocate => RetreiveParameter1DAllocate, RetreiveParameter2DAllocate + generic, public :: SetData => SetDataScalar, SetData1D, SetData2D + procedure, public :: GetUsedDimensions + procedure, public :: SetDimensionSizes + procedure, public :: GetMaxDimensionSize + procedure, public :: GetMetaData + procedure, public :: num_params + procedure, public :: FindIndex + + procedure, private :: RetreiveParameterScalar + procedure, private :: RetreiveParameter1D + procedure, private :: RetreiveParameter2D + procedure, private :: RetreiveParameter1DAllocate + procedure, private :: RetreiveParameter2DAllocate + procedure, private :: SetDataScalar + procedure, private :: SetData1D + procedure, private :: SetData2D + + end type fates_parameters_type + +contains + + !----------------------------------------------------------------------- + subroutine Init(this) + + implicit none + + class(fates_parameters_type), intent(inout) :: this + + this%num_parameters = 0 + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine Destroy(this) + + implicit none + + class(fates_parameters_type), intent(inout) :: this + + integer :: n + do n = 1, this%num_parameters + deallocate(this%parameters(n)%data) + end do + + end subroutine Destroy + + !----------------------------------------------------------------------- + subroutine RegisterParameter(this, name, dimension_shape, dimension_names, & + sync_with_host, lower_bounds) + + implicit none + + class(fates_parameters_type), intent(inout) :: this + character(len=param_string_length), intent(in) :: name + integer, intent(in) :: dimension_shape + character(len=param_string_length) :: dimension_names(1:) + logical, intent(in), optional :: sync_with_host + integer, intent(in), optional :: lower_bounds(1:) + + integer :: i, n, num_names, num_bounds + + this%num_parameters = this%num_parameters + 1 + i = this%num_parameters + ! FIXME(bja, 2017-01) assert(i <= max_params) + this%parameters(i)%name = name + this%parameters(i)%dimension_shape = dimension_shape + this%parameters(i)%dimension_sizes(:) = 0 + ! FIXME(bja, 2017-01) assert(size(dimension_names, 1) <= max_dimensions) + num_names = min(max_dimensions, size(dimension_names, 1)) + this%parameters(i)%dimension_names(:) = '' + do n = 1, num_names + this%parameters(i)%dimension_names(n) = dimension_names(n) + end do + this%parameters(i)%sync_with_host = .false. + if (present(sync_with_host)) then + this%parameters(i)%sync_with_host = sync_with_host + end if + ! allocate as a standard 1-based array unless otherwise specified + ! by the caller. + this%parameters(i)%dimension_lower_bound = (/ 1, 1 /) + if (present(lower_bounds)) then + num_bounds = min(max_dimensions, size(lower_bounds, 1)) + do n = 1, num_bounds + this%parameters(i)%dimension_lower_bound(n) = lower_bounds(n) + end do + endif + end subroutine RegisterParameter + + !----------------------------------------------------------------------- + subroutine RetreiveParameterScalar(this, name, data) + + implicit none + + class(fates_parameters_type), intent(inout) :: this + character(len=param_string_length), intent(in) :: name + real(r8), intent(out) :: data + + integer :: i + + i = this%FindIndex(name) + ! assert(size(data) == size(this%parameters(i)%data)) + data = this%parameters(i)%data(1, 1) + + end subroutine RetreiveParameterScalar + + !----------------------------------------------------------------------- + subroutine RetreiveParameter1D(this, name, data) + + use abortutils, only : endrun + + implicit none + + class(fates_parameters_type), intent(inout) :: this + character(len=param_string_length), intent(in) :: name + real(r8), intent(out) :: data(:) + + integer :: i, d, size_dim_1 + + i = this%FindIndex(name) + if (size(data) /= size(this%parameters(i)%data(:, 1))) then + write(fates_log(), *) 'ERROR : retreiveparameter1d : ', name, ' size inconsistent.' + write(fates_log(), *) 'ERROR : expected size = ', size(data) + write(fates_log(), *) 'ERROR : data size received from file = ', size(this%parameters(i)%data(:, 1)) + write(fates_log(), *) 'ERROR : dimesions received from file' + write(fates_log(), *) 'ERROR : names size' + do d = 1, max_dimensions + write(fates_log(), *) this%parameters(i)%dimension_names(d), ', ', this%parameters(i)%dimension_sizes(d) + end do + call endrun(msg='size error retreiving 1d parameter.') + end if + data = this%parameters(i)%data(:, 1) + + end subroutine RetreiveParameter1D + + !----------------------------------------------------------------------- + subroutine RetreiveParameter2D(this, name, data) + + use abortutils, only : endrun + + implicit none + + class(fates_parameters_type), intent(inout) :: this + character(len=param_string_length), intent(in) :: name + real(r8), intent(out) :: data(:, :) + + integer :: i, d + + i = this%FindIndex(name) + if (size(data, 1) /= size(this%parameters(i)%data, 1) .and. & + size(data, 2) /= size(this%parameters(i)%data, 2)) then + write(fates_log(), *) 'ERROR : retreiveparameter2d : ', name, ' size inconsistent.' + write(fates_log(), *) 'ERROR : expected shape = ', shape(data) + write(fates_log(), *) 'ERROR : dim 1 expected size = ', size(data, 1) + write(fates_log(), *) 'ERROR : dim 2 expected size = ', size(data, 2) + write(fates_log(), *) 'ERROR : dim 1 data size received from file = ', size(this%parameters(i)%data, 1) + write(fates_log(), *) 'ERROR : dim 2 data size received from file = ', size(this%parameters(i)%data, 2) + write(fates_log(), *) 'ERROR : dimesions received from file' + write(fates_log(), *) 'ERROR : names size' + do d = 1, max_dimensions + write(fates_log(), *) this%parameters(i)%dimension_names(d), ', ', this%parameters(i)%dimension_sizes(d) + end do + call endrun(msg='size error retreiving 2d parameter.') + end if + data = this%parameters(i)%data + + end subroutine RetreiveParameter2D + + !----------------------------------------------------------------------- + subroutine RetreiveParameter1DAllocate(this, name, data) + + use abortutils, only : endrun + + implicit none + + class(fates_parameters_type), intent(inout) :: this + character(len=param_string_length), intent(in) :: name + real(r8), intent(out), allocatable :: data(:) + + integer :: i, lower_bound, upper_bound + + i = this%FindIndex(name) + lower_bound = this%parameters(i)%dimension_lower_bound(1) + upper_bound = lower_bound + this%parameters(i)%dimension_sizes(1) - 1 + allocate(data(lower_bound:upper_bound)) + data(lower_bound:upper_bound) = this%parameters(i)%data(:, 1) + + end subroutine RetreiveParameter1DAllocate + + !----------------------------------------------------------------------- + subroutine RetreiveParameter2DAllocate(this, name, data) + + use abortutils, only : endrun + + implicit none + + class(fates_parameters_type), intent(inout) :: this + character(len=param_string_length), intent(in) :: name + real(r8), intent(out), allocatable :: data(:, :) + + integer :: i, lb_1, ub_1, lb_2, ub_2 + + i = this%FindIndex(name) + lb_1 = this%parameters(i)%dimension_lower_bound(1) + ub_1 = lb_1 + this%parameters(i)%dimension_sizes(1) - 1 + lb_2 = this%parameters(i)%dimension_lower_bound(2) + ub_2 = lb_2 + this%parameters(i)%dimension_sizes(2) - 1 + allocate(data(lb_1:ub_1, lb_2:ub_2)) + data(lb_1:ub_1, lb_2:ub_2) = this%parameters(i)%data + + end subroutine RetreiveParameter2DAllocate + + !----------------------------------------------------------------------- + function FindIndex(this, name) result(i) + + implicit none + + class(fates_parameters_type), intent(in) :: this + character(len=param_string_length), intent(in) :: name + + integer :: i + + do i = 1, this%num_parameters + if (trim(this%parameters(i)%name) == trim(name)) then + exit + end if + end do + if (i > this%num_parameters) then + ! error, parameter name not found. + end if + + end function FindIndex + + !----------------------------------------------------------------------- + integer function num_params(this) + + implicit none + + class(fates_parameters_type), intent(in) :: this + + num_params = this%num_parameters + + end function num_params + + !----------------------------------------------------------------------- + subroutine GetUsedDimensions(this, is_host_file, num_used_dimensions, used_dimensions) + ! Construct a list of the unique dimension names used by the + ! parameters. + + implicit none + + class(fates_parameters_type), intent(inout) :: this + logical, intent(in) :: is_host_file + integer, intent(out) :: num_used_dimensions + character(len=param_string_length), intent(out) :: used_dimensions(max_used_dimensions) + + integer :: p, d, i + character(len=param_string_length) :: dim_name + + num_used_dimensions = 0 + do p = 1, this%num_parameters + if (is_host_file .eqv. this%parameters(p)%sync_with_host) then + do d = 1, max_dimensions + dim_name = this%parameters(p)%dimension_names(d) + if (len_trim(dim_name) /= 0) then + ! non-empty dimension name, check if it needs to be added to the list. + do i = 1, num_used_dimensions + if (used_dimensions(i) == dim_name) then + ! dimension is already in list. can stop searching + exit + end if + end do + + if (i > num_used_dimensions) then + ! dimension name was not in the list, add it. + num_used_dimensions = num_used_dimensions + 1 + used_dimensions(num_used_dimensions) = dim_name + end if + end if ! if dim_name + end do ! do d + end if ! if host_param + end do ! do p + + end subroutine GetUsedDimensions + + !----------------------------------------------------------------------- + subroutine SetDimensionSizes(this, is_host_file, num_used_dimensions, dimension_names, dimension_sizes) + ! Construct a list of the unique dimension names used by the + ! parameters. + + implicit none + + class(fates_parameters_type), intent(inout) :: this + logical, intent(in) :: is_host_file + integer, intent(in) :: num_used_dimensions + character(len=param_string_length), intent(in) :: dimension_names(max_used_dimensions) + integer, intent(in) :: dimension_sizes(max_used_dimensions) + + integer :: p, d, i + character(len=param_string_length) :: dim_name + + do p = 1, this%num_parameters + if (is_host_file .eqv. this%parameters(p)%sync_with_host) then + do d = 1, max_dimensions + dim_name = this%parameters(p)%dimension_names(d) + if (len_trim(dim_name) /= 0) then + ! non-empty dimension name, set the size + do i = 1, num_used_dimensions + if (trim(dimension_names(i)) == trim(dim_name)) then + !write(*, *) '--> ', trim(this%parameters(p)%name), ' setting ', trim(dim_name), ' d = ', d, 'size = ', dimension_sizes(i) + this%parameters(p)%dimension_sizes(d) = dimension_sizes(i) + exit + end if + end do + end if ! if dim_name + end do ! do dim + end if ! if host_param + end do ! do param + + end subroutine SetDimensionSizes + + !----------------------------------------------------------------------- + subroutine GetMetaData(this, index, name, dimension_shape, dimension_sizes, dimension_names, is_host_param) + + implicit none + + class(fates_parameters_type), intent(in) :: this + integer, intent(in) :: index + character(len=param_string_length), intent(out) :: name + integer, intent(out) :: dimension_shape + integer, intent(out) :: dimension_sizes(max_dimensions) + character(len=param_string_length), intent(out) :: dimension_names(max_dimensions) + logical, intent(out) :: is_host_param + + name = this%parameters(index)%name + dimension_shape = this%parameters(index)%dimension_shape + dimension_sizes = this%parameters(index)%dimension_sizes + dimension_names = this%parameters(index)%dimension_names + is_host_param = this%parameters(index)%sync_with_host + + end subroutine GetMetaData + + !----------------------------------------------------------------------- + function GetMaxDimensionSize(this) result(max_dim_size) + + implicit none + + class(fates_parameters_type), intent(in) :: this + + integer :: p, d, max_dim_size + + max_dim_size = 0 + + do p = 1, this%num_params() + do d = 1, max_dimensions + max_dim_size = max(max_dim_size, this%parameters(p)%dimension_sizes(d)) + end do + end do + + end function GetMaxDimensionSize + + !----------------------------------------------------------------------- + subroutine SetDataScalar(this, index, data) + + implicit none + + class(fates_parameters_type), intent(inout) :: this + integer, intent(in) :: index + real(r8), intent(in) :: data + + allocate(this%parameters(index)%data(1, 1)) + this%parameters(index)%data(1, 1) = data + + end subroutine SetDataScalar + + !----------------------------------------------------------------------- + subroutine SetData1D(this, index, data) + + use abortutils, only : endrun + + implicit none + + class(fates_parameters_type), intent(inout) :: this + integer, intent(in) :: index + real(r8), intent(in) :: data(:) + + integer :: size_dim_1, d + + size_dim_1 = this%parameters(index)%dimension_sizes(1) + if (size(data) /= size_dim_1) then + write(fates_log(), *) 'ERROR : setdata1d : ', this%parameters(index)%name, ' size inconsistent.' + write(fates_log(), *) 'ERROR : expected size = ', size(data) + write(fates_log(), *) 'ERROR : data size received from file = ', size_dim_1 + write(fates_log(), *) 'ERROR : dimesions received from file' + write(fates_log(), *) 'ERROR : names size' + do d = 1, max_dimensions + write(fates_log(), *) this%parameters(index)%dimension_names(d), ', ', this%parameters(index)%dimension_sizes(d) + end do + call endrun(msg='size error setting 1d parameter.') + end if + + allocate(this%parameters(index)%data(size_dim_1, 1)) + this%parameters(index)%data(:, 1) = data(:) + + end subroutine SetData1D + + !----------------------------------------------------------------------- + subroutine SetData2D(this, index, data) + ! FIXME(bja, 2017-01) this is broken, needs data dimensions to work correctly! + + implicit none + + class(fates_parameters_type), intent(inout) :: this + integer, intent(in) :: index + real(r8), intent(in) :: data(:, :) + + ! NOTE(bja, 2017-01) This should work for fortran 2003? Or 2008? + ! Either way, it works with intel and pgi being used in 2017-01, + ! but is broken in gfortran 5.2 and earlier. That would copy the + ! data as well.... + + !X! allocate(this%parameters(index)%data, source=data) + + allocate(this%parameters(index)%data(size(data, 1), size(data, 2))) + this%parameters(index)%data = data + + end subroutine SetData2D +end module FatesParametersInterface + + + diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 new file mode 100644 index 00000000..12b1d6bc --- /dev/null +++ b/main/FatesRestartInterfaceMod.F90 @@ -0,0 +1,1853 @@ +module FatesRestartInterfaceMod + + + use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : fates_avg_flag_length + use FatesConstantsMod , only : fates_short_string_length + use FatesConstantsMod , only : fates_long_string_length + use FatesGlobals , only : fates_log + use FatesGlobals , only : endrun => fates_endrun + use FatesIODimensionsMod, only : fates_io_dimension_type + use FatesIOVariableKindMod, only : fates_io_variable_kind_type + use FatesRestartVariableMod, only : fates_restart_variable_type + use FatesInterfaceMod, only : bc_in_type + + ! CIME GLOBALS + use shr_log_mod , only : errMsg => shr_log_errMsg + + + implicit none + + ! ------------------------------------------------------------ + ! A note on variable naming conventions. + ! Many variables in this restart IO portion of the code will + ! follow the conventions: + ! + ! __ + ! + ! For instance we use an index for restart variable "ir_" + ! to point the object that contains the number of patches per + ! site "npatch" and this value is relevant to all sites "si" + ! thus: ir_npatch_si + ! + ! We also use associations to the data arrays of restart IO + ! variables "rio", for example the leaf litter "leaf_litter" + ! is retrieved for every patch and every functional type "paft" + ! thus: rio_leaf_litter_paft + ! + ! si: site dimension + ! pa: patch dimension + ! co: cohort dimension + ! ft: functional type dimension + ! cl: canopy layer dimension (upper, lower, etc) + ! ls: layer sublayer dimension (fine discretization of upper,lower) + ! wm: the number of memory slots for water (currently 10) + ! ------------------------------------------------------------- + + + ! Indices to the restart variable object + integer, private :: ir_npatch_si + integer, private :: ir_oldstock_si + integer, private :: ir_cd_status_si + integer, private :: ir_dd_status_si + integer, private :: ir_nchill_days_si + integer, private :: ir_leafondate_si + integer, private :: ir_leafoffdate_si + integer, private :: ir_dleafondate_si + integer, private :: ir_dleafoffdate_si + integer, private :: ir_acc_ni_si + integer, private :: ir_gdd_si + integer, private :: ir_nep_timeintegrated_si + integer, private :: ir_npp_timeintegrated_si + integer, private :: ir_hr_timeintegrated_si + integer, private :: ir_cbal_error_fates_si + integer, private :: ir_cbal_error_bgc_si + integer, private :: ir_cbal_error_total_si + integer, private :: ir_totecosysc_old_si + integer, private :: ir_totfatesc_old_si + integer, private :: ir_totbgcc_old_si + integer, private :: ir_fates_to_bgc_this_ts_si + integer, private :: ir_fates_to_bgc_last_ts_si + integer, private :: ir_seedrainflux_si + integer, private :: ir_ncohort_pa + integer, private :: ir_balive_co + integer, private :: ir_bdead_co + integer, private :: ir_bleaf_co + integer, private :: ir_broot_co + integer, private :: ir_bstore_co + integer, private :: ir_canopy_layer_co + integer, private :: ir_canopy_layer_yesterday_co + integer, private :: ir_canopy_trim_co + integer, private :: ir_dbh_co + integer, private :: ir_height_co + integer, private :: ir_laimemory_co + integer, private :: ir_leaf_md_co + integer, private :: ir_root_md_co + integer, private :: ir_nplant_co + integer, private :: ir_gpp_acc_co + integer, private :: ir_npp_acc_co + integer, private :: ir_gpp_acc_hold_co + integer, private :: ir_npp_acc_hold_co + integer, private :: ir_npp_leaf_co + integer, private :: ir_npp_froot_co + integer, private :: ir_npp_sw_co + integer, private :: ir_npp_dead_co + integer, private :: ir_npp_seed_co + integer, private :: ir_npp_store_co + integer, private :: ir_bmort_co + integer, private :: ir_hmort_co + integer, private :: ir_cmort_co + integer, private :: ir_imort_co + integer, private :: ir_fmort_co + integer, private :: ir_ddbhdt_co + integer, private :: ir_dbalivedt_co + integer, private :: ir_dbdeaddt_co + integer, private :: ir_dbstoredt_co + integer, private :: ir_resp_tstep_co + integer, private :: ir_pft_co + integer, private :: ir_status_co + integer, private :: ir_isnew_co + integer, private :: ir_cwd_ag_pacw + integer, private :: ir_cwd_bg_pacw + integer, private :: ir_leaf_litter_paft + integer, private :: ir_root_litter_paft + integer, private :: ir_leaf_litter_in_paft + integer, private :: ir_root_litter_in_paft + integer, private :: ir_seed_bank_sift + integer, private :: ir_spread_pacl + integer, private :: ir_livegrass_pa + integer, private :: ir_age_pa + integer, private :: ir_area_pa + integer, private :: ir_fsun_paclftls + integer, private :: ir_fabd_sun_paclftls + integer, private :: ir_fabi_sun_paclftls + integer, private :: ir_fabd_sha_paclftls + integer, private :: ir_fabi_sha_paclftls + integer, private :: ir_watermem_siwm + + ! The number of variable dim/kind types we have defined (static) + integer, parameter :: fates_restart_num_dimensions = 2 !(cohort,column) + integer, parameter :: fates_restart_num_dim_kinds = 4 !(cohort-int,cohort-r8,site-int,site-r8) + + ! integer constants for storing logical data + integer, parameter :: old_cohort = 0 + integer, parameter :: new_cohort = 1 + + ! Local debug flag + logical, parameter :: DEBUG=.false. + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + ! This structure is allocated by thread, and must be calculated after the FATES + ! sites are allocated, and their mapping to the HLM is identified. This structure + ! is not combined with iovar_bounds, because that one is multi-instanced. This + ! structure is used more during the update phase, wherease _bounds is used + ! more for things like flushing + type restart_map_type + integer, allocatable :: site_index(:) ! maps site indexes to the HIO site position + integer, allocatable :: cohort1_index(:) ! maps site index to the HIO cohort 1st position + end type restart_map_type + + + + type, public :: fates_restart_interface_type + + type(fates_restart_variable_type),allocatable :: rvars(:) + integer,private :: num_restart_vars_ + + ! Instanteate one registry of the different dimension/kinds (dk) + ! All output variables will have a pointer to one of these dk's + type(fates_io_variable_kind_type) :: dim_kinds(fates_restart_num_dim_kinds) + + ! This is a structure that explains where FATES patch boundaries + ! on each thread point to in the host IO array, this structure is + ! allocated by number of threads. This could be dynamically + ! allocated, but is unlikely to change...? + ! Note: history io also instanteates fates_io_dimension_type + type(fates_io_dimension_type) :: dim_bounds(fates_restart_num_dimensions) + + type(restart_map_type), pointer :: restart_map(:) + + integer, private :: cohort_index_, column_index_ + + contains + + procedure, public :: Init + procedure, public :: SetThreadBoundsEach + procedure, public :: assemble_restart_output_types + procedure, public :: initialize_restart_vars + procedure, public :: num_restart_vars + procedure, public :: column_index + procedure, public :: cohort_index + procedure, public :: set_restart_vectors + procedure, public :: create_patchcohort_structure + procedure, public :: get_restart_vectors + ! private work functions + procedure, private :: init_dim_kinds_maps + procedure, private :: set_dim_indices + procedure, private :: set_cohort_index + procedure, private :: set_column_index + procedure, private :: flush_rvars + procedure, private :: define_restart_vars + procedure, private :: set_restart_var + + end type fates_restart_interface_type + + + + +contains + + ! ===================================================================================== + + subroutine Init(this, num_threads, fates_bounds) + + use FatesIODimensionsMod, only : fates_bounds_type, column, cohort + + implicit none + + class(fates_restart_interface_type), intent(inout) :: this + integer, intent(in) :: num_threads + type(fates_bounds_type), intent(in) :: fates_bounds + + integer :: dim_count = 0 + + dim_count = dim_count + 1 + call this%set_cohort_index(dim_count) + call this%dim_bounds(dim_count)%Init(cohort, num_threads, & + fates_bounds%cohort_begin, fates_bounds%cohort_end) + + dim_count = dim_count + 1 + call this%set_column_index(dim_count) + call this%dim_bounds(dim_count)%Init(column, num_threads, & + fates_bounds%column_begin, fates_bounds%column_end) + + ! FIXME(bja, 2016-10) assert(dim_count == FatesIOdimensionsmod::num_dimension_types) + + ! Allocate the mapping between FATES indices and the IO indices + allocate(this%restart_map(num_threads)) + + end subroutine Init + + ! ====================================================================== + + subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) + + use FatesIODimensionsMod, only : fates_bounds_type + + implicit none + + class(fates_restart_interface_type), intent(inout) :: this + + integer, intent(in) :: thread_index + type(fates_bounds_type), intent(in) :: thread_bounds + + integer :: index + + index = this%cohort_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%cohort_begin, thread_bounds%cohort_end) + + index = this%column_index() + call this%dim_bounds(index)%SetThreadBounds(thread_index, & + thread_bounds%column_begin, thread_bounds%column_end) + + end subroutine SetThreadBoundsEach + + ! =================================================================================== + + subroutine assemble_restart_output_types(this) + + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int + + implicit none + + class(fates_restart_interface_type), intent(inout) :: this + + call this%init_dim_kinds_maps() + + call this%set_dim_indices(cohort_r8, 1, this%cohort_index()) + call this%set_dim_indices(cohort_int, 1, this%cohort_index()) + + call this%set_dim_indices(site_r8, 1, this%column_index()) + call this%set_dim_indices(site_int, 1, this%column_index()) + + end subroutine assemble_restart_output_types + + ! =================================================================================== + + subroutine set_dim_indices(this, dk_name, idim, dim_index) + + use FatesIOVariableKindMod , only : iotype_index + + implicit none + + ! arguments + class(fates_restart_interface_type), intent(inout) :: this + character(len=*), intent(in) :: dk_name + integer, intent(in) :: idim ! dimension index + integer, intent(in) :: dim_index + + + ! local + integer :: ityp + + ityp = iotype_index(trim(dk_name), fates_restart_num_dim_kinds, this%dim_kinds) + + ! First check to see if the dimension is allocated + if (this%dim_kinds(ityp)%ndims < idim) then + write(fates_log(), *) 'Trying to define dimension size to a dim-type structure' + write(fates_log(), *) 'but the dimension index does not exist' + write(fates_log(), *) 'type: ',dk_name,' ndims: ',this%dim_kinds(ityp)%ndims,' input dim:',idim + stop + !end_run + end if + + if (idim == 1) then + this%dim_kinds(ityp)%dim1_index = dim_index + else if (idim == 2) then + this%dim_kinds(ityp)%dim2_index = dim_index + end if + + ! With the map, we can set the dimension size + this%dim_kinds(ityp)%dimsize(idim) = this%dim_bounds(dim_index)%upper_bound - & + this%dim_bounds(dim_index)%lower_bound + 1 + + end subroutine set_dim_indices + + + ! ======================================================================= + + subroutine set_cohort_index(this, index) + implicit none + class(fates_restart_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%cohort_index_ = index + end subroutine set_cohort_index + + integer function cohort_index(this) + implicit none + class(fates_restart_interface_type), intent(in) :: this + cohort_index = this%cohort_index_ + end function cohort_index + + ! ======================================================================= + + subroutine set_column_index(this, index) + implicit none + class(fates_restart_interface_type), intent(inout) :: this + integer, intent(in) :: index + this%column_index_ = index + end subroutine set_column_index + + integer function column_index(this) + implicit none + class(fates_restart_interface_type), intent(in) :: this + column_index = this%column_index_ + end function column_index + + ! ======================================================================= + + subroutine init_dim_kinds_maps(this) + + ! ---------------------------------------------------------------------------------- + ! This subroutine simply initializes the structures that define the different + ! array and type formats for different IO variables + ! + ! CO_R8 : 1D cohort scale 8-byte reals + ! SI_R8 : 1D site scale 8-byte reals + ! CO_INT : 1D cohort scale integers + ! SI_INT : 1D site scale integers + ! + ! The allocation on the structures is not dynamic and should only add up to the + ! number of entries listed here. + ! + ! ---------------------------------------------------------------------------------- + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int + + implicit none + + ! Arguments + class(fates_restart_interface_type), intent(inout) :: this + + integer :: index + + ! 1d cohort r8 + index = 1 + call this%dim_kinds(index)%Init(cohort_r8, 1) + + ! 1d Site r8 + index = index + 1 + call this%dim_kinds(index)%Init(site_r8, 1) + + ! cohort int + index = index + 1 + call this%dim_kinds(index)%Init(cohort_int, 1) + + ! site int + index = index + 1 + call this%dim_kinds(index)%Init(site_int, 1) + + ! FIXME(bja, 2016-10) assert(index == fates_num_dim_kinds) + end subroutine init_dim_kinds_maps + + + ! ==================================================================================== + + integer function num_restart_vars(this) + + implicit none + + class(fates_restart_interface_type), intent(in) :: this + + num_restart_vars = this%num_restart_vars_ + + end function num_restart_vars + + ! ==================================================================================== + + subroutine initialize_restart_vars(this) + + implicit none + + class(fates_restart_interface_type), intent(inout) :: this + + ! Determine how many of the restart IO variables registered in FATES + ! are going to be allocated + call this%define_restart_vars(initialize_variables=.false.) + + ! Allocate the list of restart output variable objects + allocate(this%rvars(this%num_restart_vars())) + + ! construct the object that defines all of the IO variables + call this%define_restart_vars(initialize_variables=.true.) + + end subroutine initialize_restart_vars + + ! ====================================================================================== + + subroutine flush_rvars(this,nc) + + class(fates_restart_interface_type) :: this + integer,intent(in) :: nc + + integer :: ivar + type(fates_restart_variable_type),pointer :: rvar + integer :: lb1,ub1,lb2,ub2 + + do ivar=1,ubound(this%rvars,1) + associate( rvar => this%rvars(ivar) ) + call rvar%Flush(nc, this%dim_bounds, this%dim_kinds) + end associate + end do + + end subroutine flush_rvars + + + + ! ==================================================================================== + + subroutine define_restart_vars(this, initialize_variables) + + ! --------------------------------------------------------------------------------- + ! + ! REGISTRY OF RESTART OUTPUT VARIABLES + ! + ! Please add any restart variables to this registry. This registry will handle + ! all variables that can make use of 1D column dimensioned or 1D cohort dimensioned + ! variables. Note that restarts are only using 1D vectors in ALM and CLM. If you + ! have a multi-dimensional variable that is below the cohort scale, then pack + ! that variable into a cohort-sized output array by giving it a vtype "cohort_r8" + ! or "cohort_int". + ! + ! Unlike history variables, restarts flush to zero. + ! --------------------------------------------------------------------------------- + + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_int, cohort_r8 + implicit none + + class(fates_restart_interface_type), intent(inout) :: this + logical, intent(in) :: initialize_variables ! are we 'count'ing or 'initializ'ing? + integer :: ivar + real(r8), parameter :: flushinvalid = -9999.0 + real(r8), parameter :: flushzero = 0.0 + real(r8), parameter :: flushone = 1.0 + + + ivar=0 + + ! ----------------------------------------------------------------------------------- + ! Site level variables + ! ----------------------------------------------------------------------------------- + + call this%set_restart_var(vname='fates_PatchesPerSite', vtype=site_int, & + long_name='Total number of FATES patches per column', units='none', flushval = flushinvalid, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npatch_si ) + + call this%set_restart_var(vname='fates_old_stock', vtype=site_r8, & + long_name='biomass stock in each site (previous step)', units='kgC/site', & + flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_oldstock_si ) + + call this%set_restart_var(vname='fates_cold_dec_status', vtype=site_r8, & + long_name='status flag for cold deciduous plants', units='unitless', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cd_status_si ) + + call this%set_restart_var(vname='fates_drought_dec_status', vtype=site_r8, & + long_name='status flag for drought deciduous plants', units='unitless', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dd_status_si ) + + call this%set_restart_var(vname='fates_chilling_days', vtype=site_r8, & + long_name='chilling day counter', units='unitless', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_nchill_days_si ) + + call this%set_restart_var(vname='fates_leafondate', vtype=site_r8, & + long_name='the day of year for leaf on', units='day of year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leafondate_si ) + + call this%set_restart_var(vname='fates_leafoffdate', vtype=site_r8, & + long_name='the day of year for leaf off', units='day of year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leafoffdate_si ) + + call this%set_restart_var(vname='fates_drought_leafondate', vtype=site_r8, & + long_name='the day of year for drought based leaf-on', units='day of year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dleafondate_si ) + + call this%set_restart_var(vname='fates_drought_leafoffdate', vtype=site_r8, & + long_name='the day of year for drought based leaf-off', units='day of year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dleafoffdate_si ) + + call this%set_restart_var(vname='fates_acc_nesterov_id', vtype=site_r8, & + long_name='a nesterov index accumulator', units='unitless', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_acc_ni_si ) + + call this%set_restart_var(vname='fates_gdd_site', vtype=site_r8, & + long_name='growing degree days at each site', units='degC days', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gdd_si ) + + call this%set_restart_var(vname='fates_nep_timeintegrated_site', vtype=site_r8, & + long_name='NEP integrated over model time-steps', units='gc/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_nep_timeintegrated_si ) + + call this%set_restart_var(vname='fates_npp_timeintegrated_site', vtype=site_r8, & + long_name='NPP integrated over model time-steps', units='gc/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_timeintegrated_si ) + + call this%set_restart_var(vname='fates_hr_timeintegrated_site', vtype=site_r8, & + long_name='heterotrophic respiration integrated over model time-steps', & + units='gc/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hr_timeintegrated_si ) + + call this%set_restart_var(vname='fates_cbal_err_fatesite', vtype=site_r8, & + long_name='the carbon accounting error for FATES processes', & + units='gC/m2/s', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cbal_error_fates_si ) + + call this%set_restart_var(vname='fates_cbal_err_bgcsite', vtype=site_r8, & + long_name='the carbon accounting error for (fates relevant) BGC processes', & + units='gC/m2/s', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cbal_error_bgc_si ) + + call this%set_restart_var(vname='fates_cbal_err_totsite', vtype=site_r8, & + long_name='the carbon accounting error for fates and bgc processes', & + units='gC/m2/s', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cbal_error_total_si ) + + call this%set_restart_var(vname='fates_totecosysc_old_site', vtype=site_r8, & + long_name='total ecosystem carbon above and below ground (previous time-step)', & + units='gC/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_totecosysc_old_si ) + + call this%set_restart_var(vname='fates_totfatesc_old_site', vtype=site_r8, & + long_name='total carbon tracked in FATES, (previous time-step)', & + units='gc/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_totfatesc_old_si ) + + call this%set_restart_var(vname='fates_totbgcc_old_site', vtype=site_r8, & + long_name='total carbon tracked in the BGC module', & + units='gc/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_totbgcc_old_si ) + + call this%set_restart_var(vname='fates_to_bgc_this_edts_col', vtype=site_r8, & + long_name='total flux of carbon from FATES to BGC models on current timestep', & + units='gC/m2/s', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fates_to_bgc_this_ts_si ) + + call this%set_restart_var(vname='fates_to_bgc_last_edts_col', vtype=site_r8, & + long_name='total flux of carbon from FATES to BGC models on previous timestep', & + units='gC/m2/s', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fates_to_bgc_last_ts_si ) + + call this%set_restart_var(vname='fates_seed_rain_flux_site', vtype=site_r8, & + long_name='flux of seeds from exterior', & + units='kgC/m2/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seedrainflux_si ) + + ! ----------------------------------------------------------------------------------- + ! Variables stored within cohort vectors + ! Note: Some of these are multi-dimensional variables in the patch/site dimension + ! that are collapsed into the cohort vectors for storage and transfer + ! ----------------------------------------------------------------------------------- + + ! This variable may be confusing, because it is a patch level variables + ! but it is using the cohort IO vector to hold data + call this%set_restart_var(vname='fates_CohortsPerPatch', vtype=cohort_int, & + long_name='the number of cohorts per patch', units='unitless', flushval = flushinvalid, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_ncohort_pa ) + + ! 1D cohort Variables + ! ----------------------------------------------------------------------------------- + + call this%set_restart_var(vname='fates_balive', vtype=cohort_r8, & + long_name='ed cohort alive biomass', units='kgC/indiv', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_balive_co ) + + call this%set_restart_var(vname='fates_bdead', vtype=cohort_r8, & + long_name='ed cohort - dead (structural) biomass in living plants', & + units='kgC/indiv', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bdead_co ) + + call this%set_restart_var(vname='fates_bl', vtype=cohort_r8, & + long_name='ed cohort - leaf biomass', units='kgC/indiv', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bleaf_co ) + + call this%set_restart_var(vname='fates_br', vtype=cohort_r8, & + long_name='ed cohort - fine root biomass', units='kgC/indiv', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_broot_co ) + + call this%set_restart_var(vname='fates_bstore', vtype=cohort_r8, & + long_name='ed cohort - storage biomass', units='kgC/indiv', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bstore_co ) + + call this%set_restart_var(vname='fates_canopy_layer', vtype=cohort_r8, & + long_name='ed cohort - canopy_layer', units='unitless', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_layer_co ) + + call this%set_restart_var(vname='fates_canopy_layer_yesterday', vtype=cohort_r8, & + 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_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 ) + + call this%set_restart_var(vname='fates_dbh', vtype=cohort_r8, & + long_name='ed cohort - diameter at breast height', units='cm', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dbh_co ) + + call this%set_restart_var(vname='fates_height', vtype=cohort_r8, & + long_name='ed cohort - plant height', units='m', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_height_co ) + + call this%set_restart_var(vname='fates_laimemory', vtype=cohort_r8, & + long_name='ed cohort - target leaf biomass set from prev year', & + units='kgC/indiv', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_laimemory_co ) + + call this%set_restart_var(vname='fates_leaf_maint_dmnd', vtype=cohort_r8, & + long_name='ed cohort - leaf maintenance demand', & + units='kgC/indiv/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_md_co ) + + call this%set_restart_var(vname='fates_root_maint_dmnd', vtype=cohort_r8, & + long_name='ed cohort - fine root maintenance demand', & + units='kgC/indiv', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_root_md_co ) + + call this%set_restart_var(vname='fates_nplant', vtype=cohort_r8, & + long_name='ed cohort - number of plants in the cohort', & + units='/patch', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_nplant_co ) + + call this%set_restart_var(vname='fates_gpp_acc', vtype=cohort_r8, & + long_name='ed cohort - accumulated gpp over dynamics step', & + units='kgC/indiv', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gpp_acc_co ) + + call this%set_restart_var(vname='fates_npp_acc', vtype=cohort_r8, & + long_name='ed cohort - accumulated npp over dynamics step', & + units='kgC/indiv', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_acc_co ) + + call this%set_restart_var(vname='fates_gpp_acc_hold', vtype=cohort_r8, & + long_name='ed cohort - current step gpp', & + units='kgC/indiv/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gpp_acc_hold_co ) + + call this%set_restart_var(vname='fates_npp_acc_hold', vtype=cohort_r8, & + long_name='ed cohort - current step npp', & + units='kgC/indiv/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_acc_hold_co ) + + call this%set_restart_var(vname='fates_npp_leaf', vtype=cohort_r8, & + long_name='ed cohort - npp sent to leaves', & + units='kgC/indiv/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_leaf_co ) + + call this%set_restart_var(vname='fates_npp_froot', vtype=cohort_r8, & + long_name='ed cohort - npp sent to fine roots', & + units='kgC/indiv/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_froot_co ) + + call this%set_restart_var(vname='fates_npp_sapwood', vtype=cohort_r8, & + long_name='ed cohort - npp sent to sapwood', & + units='kgC/indiv/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_sw_co ) + + call this%set_restart_var(vname='fates_npp_bdead', vtype=cohort_r8, & + long_name='ed cohort - npp sent to dead (structure) biomass in live plants', & + units='kgC/indiv/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_dead_co ) + + call this%set_restart_var(vname='fates_npp_seed', vtype=cohort_r8, & + long_name='ed cohort - npp sent to seed biomass', & + units='kgC/indiv/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_seed_co ) + + call this%set_restart_var(vname='fates_npp_store', vtype=cohort_r8, & + long_name='ed cohort - npp sent to storage biomass', & + units='kgC/indiv/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_store_co ) + + call this%set_restart_var(vname='fates_bmort', vtype=cohort_r8, & + long_name='ed cohort - background mortality rate', & + units='/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bmort_co ) + + call this%set_restart_var(vname='fates_hmort', vtype=cohort_r8, & + long_name='ed cohort - hydraulic mortality rate', & + units='/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hmort_co ) + + call this%set_restart_var(vname='fates_cmort', vtype=cohort_r8, & + long_name='ed cohort - carbon starvation mortality rate', & + units='/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cmort_co ) + + call this%set_restart_var(vname='fates_imort', vtype=cohort_r8, & + long_name='ed cohort - impact mortality rate', & + units='/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_imort_co ) + + call this%set_restart_var(vname='fates_fmort', vtype=cohort_r8, & + long_name='ed cohort - frost mortality rate', & + units='/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fmort_co ) + + call this%set_restart_var(vname='fates_ddbhdt', vtype=cohort_r8, & + long_name='ed cohort - differential: ddbh/dt', & + units='cm/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_ddbhdt_co ) + + call this%set_restart_var(vname='fates_dbalivedt', vtype=cohort_r8, & + long_name='ed cohort - differential: ddbh/dt', & + units='cm/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dbalivedt_co ) + + call this%set_restart_var(vname='fates_dbdeaddt', vtype=cohort_r8, & + long_name='ed cohort - differential: ddbh/dt', & + units='cm/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dbdeaddt_co ) + + call this%set_restart_var(vname='fates_dbstoredt', vtype=cohort_r8, & + long_name='ed cohort - differential: ddbh/dt', & + units='cm/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dbstoredt_co ) + + call this%set_restart_var(vname='fates_resp_tstep', vtype=cohort_r8, & + long_name='ed cohort - autotrophic respiration over timestep', & + units='kgC/indiv/timestep', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_resp_tstep_co ) + + call this%set_restart_var(vname='fates_pft', vtype=cohort_int, & + long_name='ed cohort - plant functional type', units='index', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_pft_co ) + + call this%set_restart_var(vname='fates_status_coh', vtype=cohort_int, & + long_name='ed cohort - plant phenology status', units='unitless', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_status_co ) + + call this%set_restart_var(vname='fates_isnew', vtype=cohort_int, & + long_name='ed cohort - binary flag specifying if a plant has experienced a full day cycle', & + units='0/1', flushval = flushone, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_isnew_co ) + + + ! Mixed dimension variables using the cohort vector + ! ----------------------------------------------------------------------------------- + + call this%set_restart_var(vname='fates_cwd_ag', vtype=cohort_r8, & + long_name='coarse woody debris above ground (non-respiring), by patch x cw class', & + units='kgC/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cwd_ag_pacw ) + + call this%set_restart_var(vname='fates_cwd_bg', vtype=cohort_r8, & + long_name='coarse woody debris below ground (non-respiring), by patch x cw class', & + units='kgC/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cwd_bg_pacw ) + + call this%set_restart_var(vname='fates_leaf_litter', vtype=cohort_r8, & + long_name='leaf litter, by patch x pft (non-respiring)', & + units='kgC/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litter_paft ) + + call this%set_restart_var(vname='fates_root_litter', vtype=cohort_r8, & + long_name='root litter, by patch x pft (non-respiring)', & + units='kgC/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_root_litter_paft ) + + call this%set_restart_var(vname='fates_leaf_litter_in', vtype=cohort_r8, & + long_name='leaf litter flux from turnover and mort, by patch x pft', & + units='kgC/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litter_in_paft ) + + call this%set_restart_var(vname='fates_root_litter_in', vtype=cohort_r8, & + long_name='root litter flux from turnover and mort, by patch x pft', & + units='kgC/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_root_litter_in_paft ) + + call this%set_restart_var(vname='fates_seed_bank', vtype=cohort_r8, & + long_name='seed pool for each functional type, by site x pft', & + units='kgC/m2/year', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seed_bank_sift ) + + call this%set_restart_var(vname='fates_spread', vtype=cohort_r8, & + long_name='dynamic ratio of dbh to canopy area, by patch x canopy-layer', & + units='cm/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_spread_pacl ) + + call this%set_restart_var(vname='fates_livegrass', vtype=cohort_r8, & + long_name='total AGB from grass, by patch', & + units='kgC/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_livegrass_pa ) + + call this%set_restart_var(vname='fates_age', vtype=cohort_r8, & + long_name='age of the ED patch', units='yr', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_age_pa ) + + call this%set_restart_var(vname='fates_area', vtype=cohort_r8, & + long_name='are of the ED patch', units='m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_area_pa ) + + ! These dimensions are pa "patch" cl "canopy layer" ft "functional type" ls "layer sublevel" + call this%set_restart_var(vname='fates_f_sun', vtype=cohort_r8, & + long_name='fraction of sunlit leaves, by patch x can-layer x pft x sublayer', & + units='fraction', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fsun_paclftls ) + + call this%set_restart_var(vname='fates_fabd_sun_z', vtype=cohort_r8, & + long_name='sun fraction of direct light absorbed, by patch x can-layer x pft x sublayer', & + units='fraction', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fabd_sun_paclftls ) + + call this%set_restart_var(vname='fates_fabi_sun_z', vtype=cohort_r8, & + long_name='sun fraction of indirect light absorbed, by patch x can-layer x pft x sublayer', & + units='fraction', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fabi_sun_paclftls ) + + call this%set_restart_var(vname='fates_fabd_sha_z', vtype=cohort_r8, & + long_name='shade fraction of direct light absorbed, by patch x can-layer x pft x sublayer', & + units='fraction', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fabd_sha_paclftls ) + + call this%set_restart_var(vname='fates_fabi_sha_z', vtype=cohort_r8, & + long_name='shade fraction of indirect light absorbed, by patch x can-layer x pft x sublayer', & + units='fraction', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fabi_sha_paclftls ) + + ! + ! site x time level vars + ! + + call this%set_restart_var(vname='fates_water_memory', vtype=cohort_r8, & + long_name='last 10 days of volumetric soil water, by site x day-index', & + units='m3/m3', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_watermem_siwm ) + + + ! Must be last thing before return + this%num_restart_vars_ = ivar + + end subroutine define_restart_vars + + + ! ===================================================================================== + + subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & + hlms,initialize,ivar,index) + + use FatesUtilsMod, only : check_hlm_list + use FatesInterfaceMod, only : hlm_name + + ! arguments + class(fates_restart_interface_type) :: this + character(len=*),intent(in) :: vname + character(len=*),intent(in) :: vtype + character(len=*),intent(in) :: units + real(r8), intent(in) :: flushval + character(len=*),intent(in) :: long_name + character(len=*),intent(in) :: hlms + logical, intent(in) :: initialize + integer, intent(inout) :: ivar + integer, intent(inout) :: index ! This is the index for the variable of + ! interest that is associated with an + ! explict name (for fast reference during update) + ! A zero is passed back when the variable is + ! not used + + + type(fates_restart_variable_type),pointer :: rvar + integer :: ub1,lb1,ub2,lb2 ! Bounds for allocating the var + integer :: ityp + + logical :: use_var + + use_var = check_hlm_list(trim(hlms), trim(hlm_name)) + + + if( use_var ) then + + ivar = ivar+1 + index = ivar + + if( initialize )then + + call this%rvars(ivar)%Init(vname, units, long_name, vtype, flushval, & + fates_restart_num_dim_kinds, this%dim_kinds, this%dim_bounds) + + end if + else + + index = 0 + end if + + return + end subroutine set_restart_var + + ! ===================================================================================== + + subroutine set_restart_vectors(this,nc,nsites,sites) + + use EDTypesMod, only : nclmax + use EDTypesMod, only : nlevleaf + use FatesInterfaceMod, only : fates_maxElementsPerPatch + use EDTypesMod, only : numpft_ed + use EDTypesMod, only : ed_site_type + use EDTypesMod, only : ed_cohort_type + use EDTypesMod, only : ed_patch_type + use EDTypesMod, only : ncwd + use EDTypesMod, only : numWaterMem + + ! Arguments + class(fates_restart_interface_type) :: this + integer , intent(in) :: nc ! clump index + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + + ! Locals + integer :: s ! The local site index + + ! ---------------------------------------------------------------------------------- + ! The following group of integers indicate the positional index (idx) + ! of variables at different scales inside the I/O arrays (io) + ! Keep in mind that many of these variables have a composite dimension + ! at the patch scale. To hold this memory, we borrow the cohort + ! vector. Thus the head of each array points to the first cohort + ! of each patch. "io_idx_co_1st" + ! ---------------------------------------------------------------------------------- + integer :: io_idx_si ! site index + integer :: io_idx_co_1st ! 1st cohort of each patch + integer :: io_idx_co ! cohort index + integer :: io_idx_pa_pft ! each pft within each patch (pa_pft) + integer :: io_idx_pa_cwd ! each cwd class within each patch (pa_cwd) + integer :: io_idx_pa_cl ! each canopy layer class within each patch (pa_cl) + integer :: io_idx_pa_sunz ! index for the combined dimensions for radiation + integer :: io_idx_si_wmem ! each water memory class within each site + + ! Some counters (for checking mostly) + integer :: totalcohorts ! total cohort count on this thread (diagnostic) + integer :: patchespersite ! number of patches per site + integer :: cohortsperpatch ! number of cohorts per patch + + integer :: ft ! functional type index + integer :: k,j,i ! indices to the radiation matrix + + type(fates_restart_variable_type) :: rvar + type(ed_patch_type),pointer :: cpatch + type(ed_cohort_type),pointer :: ccohort + + + associate( rio_npatch_si => this%rvars(ir_npatch_si)%int1d, & + rio_old_stock_si => this%rvars(ir_oldstock_si)%r81d, & + rio_cd_status_si => this%rvars(ir_cd_status_si)%r81d, & + rio_dd_status_si => this%rvars(ir_dd_status_si)%r81d, & + rio_nchill_days_si => this%rvars(ir_nchill_days_si)%r81d, & + rio_leafondate_si => this%rvars(ir_leafondate_si)%r81d, & + rio_leafoffdate_si => this%rvars(ir_leafoffdate_si)%r81d, & + rio_dleafondate_si => this%rvars(ir_dleafondate_si)%r81d, & + rio_dleafoffdate_si => this%rvars(ir_dleafoffdate_si)%r81d, & + rio_acc_ni_si => this%rvars(ir_acc_ni_si)%r81d, & + rio_gdd_si => this%rvars(ir_gdd_si)%r81d, & + rio_nep_timeintegrated_si => this%rvars(ir_nep_timeintegrated_si)%r81d, & + rio_npp_timeintegrated_si => this%rvars(ir_npp_timeintegrated_si)%r81d, & + rio_hr_timeintegrated_si => this%rvars(ir_hr_timeintegrated_si)%r81d, & + rio_cbal_err_fates_si => this%rvars(ir_cbal_error_fates_si)%r81d, & + rio_cbal_err_bgc_si => this%rvars(ir_cbal_error_bgc_si)%r81d, & + rio_cbal_err_tot_si => this%rvars(ir_cbal_error_total_si)%r81d, & + rio_totecosysc_old_si => this%rvars(ir_totecosysc_old_si)%r81d, & + rio_totfatesc_old_si => this%rvars(ir_totfatesc_old_si)%r81d, & + rio_totbgcc_old_si => this%rvars(ir_totbgcc_old_si)%r81d, & + rio_fates_to_bgc_this_ts_si => this%rvars(ir_fates_to_bgc_this_ts_si)%r81d, & + rio_fates_to_bgc_last_ts_si => this%rvars(ir_fates_to_bgc_last_ts_si)%r81d, & + rio_seedrainflux_si => this%rvars(ir_seedrainflux_si)%r81d, & + rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d, & + rio_balive_co => this%rvars(ir_balive_co)%r81d, & + rio_bdead_co => this%rvars(ir_bdead_co)%r81d, & + rio_bleaf_co => this%rvars(ir_bleaf_co)%r81d, & + rio_broot_co => this%rvars(ir_broot_co)%r81d, & + rio_bstore_co => this%rvars(ir_bstore_co)%r81d, & + rio_canopy_layer_co => this%rvars(ir_canopy_layer_co)%r81d, & + rio_canopy_layer_yesterday_co => this%rvars(ir_canopy_layer_yesterday_co)%r81d, & + rio_canopy_trim_co => this%rvars(ir_canopy_trim_co)%r81d, & + rio_dbh_co => this%rvars(ir_dbh_co)%r81d, & + rio_height_co => this%rvars(ir_height_co)%r81d, & + rio_laimemory_co => this%rvars(ir_laimemory_co)%r81d, & + rio_leaf_md_co => this%rvars(ir_leaf_md_co)%r81d, & + rio_root_md_co => this%rvars(ir_root_md_co)%r81d, & + rio_nplant_co => this%rvars(ir_nplant_co)%r81d, & + rio_gpp_acc_co => this%rvars(ir_gpp_acc_co)%r81d, & + rio_npp_acc_co => this%rvars(ir_npp_acc_co)%r81d, & + rio_gpp_acc_hold_co => this%rvars(ir_gpp_acc_hold_co)%r81d, & + rio_npp_acc_hold_co => this%rvars(ir_npp_acc_hold_co)%r81d, & + rio_npp_leaf_co => this%rvars(ir_npp_leaf_co)%r81d, & + rio_npp_froot_co => this%rvars(ir_npp_froot_co)%r81d, & + rio_npp_sw_co => this%rvars(ir_npp_sw_co)%r81d, & + rio_npp_dead_co => this%rvars(ir_npp_dead_co)%r81d, & + rio_npp_seed_co => this%rvars(ir_npp_seed_co)%r81d, & + rio_npp_store_co => this%rvars(ir_npp_store_co)%r81d, & + rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & + rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & + rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & + rio_imort_co => this%rvars(ir_imort_co)%r81d, & + rio_fmort_co => this%rvars(ir_fmort_co)%r81d, & + rio_ddbhdt_co => this%rvars(ir_ddbhdt_co)%r81d, & + rio_dbalivedt_co => this%rvars(ir_dbalivedt_co)%r81d, & + rio_dbdeaddt_co => this%rvars(ir_dbdeaddt_co)%r81d, & + rio_dbstoredt_co => this%rvars(ir_dbstoredt_co)%r81d, & + rio_resp_tstep_co => this%rvars(ir_resp_tstep_co)%r81d, & + rio_pft_co => this%rvars(ir_pft_co)%int1d, & + rio_status_co => this%rvars(ir_status_co)%int1d, & + rio_isnew_co => this%rvars(ir_isnew_co)%int1d, & + rio_cwd_ag_pacw => this%rvars(ir_cwd_ag_pacw)%r81d, & + rio_cwd_bg_pacw => this%rvars(ir_cwd_bg_pacw)%r81d, & + rio_leaf_litter_paft => this%rvars(ir_leaf_litter_paft)%r81d, & + rio_root_litter_paft => this%rvars(ir_root_litter_paft)%r81d, & + rio_leaf_litter_in_paft => this%rvars(ir_leaf_litter_in_paft)%r81d, & + rio_root_litter_in_paft => this%rvars(ir_root_litter_in_paft)%r81d, & + rio_seed_bank_sift => this%rvars(ir_seed_bank_sift)%r81d, & + rio_spread_pacl => this%rvars(ir_spread_pacl)%r81d, & + rio_livegrass_pa => this%rvars(ir_livegrass_pa)%r81d, & + rio_age_pa => this%rvars(ir_age_pa)%r81d, & + rio_area_pa => this%rvars(ir_area_pa)%r81d, & + rio_fsun_paclftls => this%rvars(ir_fsun_paclftls)%r81d, & + rio_fabd_sun_z_paclftls => this%rvars(ir_fabd_sun_paclftls)%r81d, & + rio_fabi_sun_z_paclftls => this%rvars(ir_fabi_sun_paclftls)%r81d, & + rio_fabd_sha_z_paclftls => this%rvars(ir_fabd_sha_paclftls)%r81d, & + rio_fabi_sha_z_paclftls => this%rvars(ir_fabi_sha_paclftls)%r81d, & + rio_watermem_siwm => this%rvars(ir_watermem_siwm)%r81d ) + + totalCohorts = 0 + + ! --------------------------------------------------------------------------------- + ! Flush arrays to values defined by %flushval (see registry entry in + ! subroutine define_history_vars() + ! --------------------------------------------------------------------------------- + call this%flush_rvars(nc) + + do s = 1,nsites + + ! Calculate the offsets + ! fcolumn is the global column index of the current site. + ! For the first site, if that site aligns with the first column index + ! in the clump, than the offset should be be equal to begCohort + + io_idx_si = this%restart_map(nc)%site_index(s) + io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) + + io_idx_co = io_idx_co_1st + io_idx_pa_pft = io_idx_co_1st + io_idx_pa_cwd = io_idx_co_1st + io_idx_pa_cl = io_idx_co_1st + io_idx_si_wmem = io_idx_co_1st + io_idx_pa_sunz = io_idx_co_1st + + ! write seed_bank info(site-level, but PFT-resolved) + do i = 1,numpft_ed + rio_seed_bank_sift(io_idx_co_1st+i-1) = sites(s)%seed_bank(i) + end do + + cpatch => sites(s)%oldest_patch + + ! new column, reset num patches + patchespersite = 0 + + do while(associated(cpatch)) + + ! found patch, increment + patchespersite = patchespersite + 1 + + ccohort => cpatch%shortest + + ! new patch, reset num cohorts + cohortsperpatch = 0 + + do while(associated(ccohort)) + + ! found cohort, increment + cohortsperpatch = cohortsperpatch + 1 + totalCohorts = totalCohorts + 1 + + if ( DEBUG ) then + write(fates_log(),*) 'CLTV io_idx_co ', io_idx_co + write(fates_log(),*) 'CLTV lowerbound ', lbound(rio_npp_acc_co,1) + write(fates_log(),*) 'CLTV upperbound ', ubound(rio_npp_acc_co,1) + endif + + rio_balive_co(io_idx_co) = ccohort%balive + rio_bdead_co(io_idx_co) = ccohort%bdead + rio_bleaf_co(io_idx_co) = ccohort%bl + rio_broot_co(io_idx_co) = ccohort%br + rio_bstore_co(io_idx_co) = ccohort%bstore + rio_canopy_layer_co(io_idx_co) = ccohort%canopy_layer + rio_canopy_layer_yesterday_co(io_idx_co) = ccohort%canopy_layer_yesterday + rio_canopy_trim_co(io_idx_co) = ccohort%canopy_trim + rio_dbh_co(io_idx_co) = ccohort%dbh + rio_height_co(io_idx_co) = ccohort%hite + rio_laimemory_co(io_idx_co) = ccohort%laimemory + rio_leaf_md_co(io_idx_co) = ccohort%leaf_md + rio_root_md_co(io_idx_co) = ccohort%root_md + rio_nplant_co(io_idx_co) = ccohort%n + rio_gpp_acc_co(io_idx_co) = ccohort%gpp_acc + rio_npp_acc_co(io_idx_co) = ccohort%npp_acc + rio_gpp_acc_hold_co(io_idx_co) = ccohort%gpp_acc_hold + rio_npp_acc_hold_co(io_idx_co) = ccohort%npp_acc_hold + rio_npp_leaf_co(io_idx_co) = ccohort%npp_leaf + rio_npp_froot_co(io_idx_co) = ccohort%npp_froot + rio_npp_sw_co(io_idx_co) = ccohort%npp_bsw + rio_npp_dead_co(io_idx_co) = ccohort%npp_bdead + rio_npp_seed_co(io_idx_co) = ccohort%npp_bseed + rio_npp_store_co(io_idx_co) = ccohort%npp_store + rio_bmort_co(io_idx_co) = ccohort%bmort + rio_hmort_co(io_idx_co) = ccohort%hmort + rio_cmort_co(io_idx_co) = ccohort%cmort + rio_imort_co(io_idx_co) = ccohort%imort + rio_fmort_co(io_idx_co) = ccohort%fmort + rio_ddbhdt_co(io_idx_co) = ccohort%ddbhdt + rio_dbalivedt_co(io_idx_co) = ccohort%dbalivedt + rio_dbdeaddt_co(io_idx_co) = ccohort%dbdeaddt + rio_dbstoredt_co(io_idx_co) = ccohort%dbstoredt + rio_resp_tstep_co(io_idx_co) = ccohort%resp_tstep + rio_pft_co(io_idx_co) = ccohort%pft + rio_status_co(io_idx_co) = ccohort%status_coh + if ( ccohort%isnew ) then + rio_isnew_co(io_idx_co) = new_cohort + else + rio_isnew_co(io_idx_co) = old_cohort + endif + + if ( DEBUG ) then + write(fates_log(),*) 'CLTV offsetNumCohorts II ',io_idx_co, & + cohortsperpatch + endif + + io_idx_co = io_idx_co + 1 + + ccohort => ccohort%taller + + enddo ! ccohort do while + + ! + ! deal with patch level fields here + ! + rio_livegrass_pa(io_idx_co_1st) = cpatch%livegrass + rio_age_pa(io_idx_co_1st) = cpatch%age + rio_area_pa(io_idx_co_1st) = cpatch%area + + ! set cohorts per patch for IO + rio_ncohort_pa( io_idx_co_1st ) = cohortsperpatch + + if ( DEBUG ) then + write(fates_log(),*) 'offsetNumCohorts III ' & + ,io_idx_co,cohortsperpatch + endif + ! + ! deal with patch level fields of arrays here + ! + ! these are arrays of length numpft_ed, each patch contains one + ! vector so we increment + do i = 1,numpft_ed + rio_leaf_litter_paft(io_idx_pa_pft) = cpatch%leaf_litter(i) + rio_root_litter_paft(io_idx_pa_pft) = cpatch%root_litter(i) + rio_leaf_litter_in_paft(io_idx_pa_pft) = cpatch%leaf_litter_in(i) + rio_root_litter_in_paft(io_idx_pa_pft) = cpatch%root_litter_in(i) + io_idx_pa_pft = io_idx_pa_pft + 1 + end do + + do i = 1,ncwd ! ncwd currently 4 + rio_cwd_ag_pacw(io_idx_pa_cwd) = cpatch%cwd_ag(i) + rio_cwd_bg_pacw(io_idx_pa_cwd) = cpatch%cwd_bg(i) + io_idx_pa_cwd = io_idx_pa_cwd + 1 + end do + + do i = 1,nclmax ! nclmax currently 2 + rio_spread_pacl(io_idx_pa_cl) = cpatch%spread(i) + io_idx_pa_cl = io_idx_pa_cl + 1 + end do + + if ( DEBUG ) write(fates_log(),*) 'CLTV io_idx_pa_sunz 1 ',io_idx_pa_sunz + + if ( DEBUG ) write(fates_log(),*) 'CLTV 1186 ',nlevleaf,numpft_ed,nclmax + + do k = 1,nlevleaf ! nlevleaf currently 40 + do j = 1,numpft_ed ! numpft_ed currently 2 + do i = 1,nclmax ! nclmax currently 2 + rio_fsun_paclftls(io_idx_pa_sunz) = cpatch%f_sun(i,j,k) + rio_fabd_sun_z_paclftls(io_idx_pa_sunz) = cpatch%fabd_sun_z(i,j,k) + rio_fabi_sun_z_paclftls(io_idx_pa_sunz) = cpatch%fabi_sun_z(i,j,k) + rio_fabd_sha_z_paclftls(io_idx_pa_sunz) = cpatch%fabd_sha_z(i,j,k) + rio_fabi_sha_z_paclftls(io_idx_pa_sunz) = cpatch%fabi_sha_z(i,j,k) + io_idx_pa_sunz = io_idx_pa_sunz + 1 + end do + end do + end do + + if ( DEBUG ) write(fates_log(),*) 'CLTV io_idx_pa_sunz 2 ',io_idx_pa_sunz + + + ! Set the first cohort index to the start of the next patch, increment + ! by the maximum number of cohorts per patch + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch + + ! reset counters so that they are all advanced evenly. Currently + ! the offset is 10, the max of numpft_ed, ncwd, nclmax, + ! io_idx_si_wmem and the number of allowed cohorts per patch + io_idx_pa_pft = io_idx_co_1st + io_idx_pa_cwd = io_idx_co_1st + io_idx_pa_cl = io_idx_co_1st + io_idx_co = io_idx_co_1st + io_idx_pa_sunz = io_idx_co_1st + + if ( DEBUG ) then + write(fates_log(),*) 'CLTV io_idx_co_1st ', io_idx_co_1st + write(fates_log(),*) 'CLTV numCohort ', cohortsperpatch + write(fates_log(),*) 'CLTV totalCohorts ', totalCohorts + end if + + cpatch => cpatch%younger + + enddo ! cpatch do while + + rio_old_stock_si(io_idx_si) = sites(s)%old_stock + rio_cd_status_si(io_idx_si) = sites(s)%status + rio_dd_status_si(io_idx_si) = sites(s)%dstatus + rio_nchill_days_si(io_idx_si) = sites(s)%ncd + rio_leafondate_si(io_idx_si) = sites(s)%leafondate + rio_leafoffdate_si(io_idx_si) = sites(s)%leafoffdate + rio_dleafondate_si(io_idx_si) = sites(s)%dleafondate + rio_dleafoffdate_si(io_idx_si) = sites(s)%dleafoffdate + rio_acc_ni_si(io_idx_si) = sites(s)%acc_NI + rio_gdd_si(io_idx_si) = sites(s)%ED_GDD_site + + ! Carbon Balance and Checks + rio_nep_timeintegrated_si(io_idx_si) = sites(s)%nep_timeintegrated + rio_npp_timeintegrated_si(io_idx_si) = sites(s)%npp_timeintegrated + rio_hr_timeintegrated_si(io_idx_si) = sites(s)%hr_timeintegrated + rio_totecosysc_old_si(io_idx_si) = sites(s)%totecosysc_old + rio_totfatesc_old_si(io_idx_si) = sites(s)%totfatesc_old + rio_totbgcc_old_si(io_idx_si) = sites(s)%totbgcc_old + rio_cbal_err_fates_si(io_idx_si) = sites(s)%cbal_err_fates + rio_cbal_err_bgc_si(io_idx_si) = sites(s)%cbal_err_bgc + rio_cbal_err_tot_si(io_idx_si) = sites(s)%cbal_err_tot + rio_fates_to_bgc_this_ts_si(io_idx_si) = sites(s)%fates_to_bgc_this_ts + rio_fates_to_bgc_last_ts_si(io_idx_si) = sites(s)%fates_to_bgc_last_ts + rio_seedrainflux_si(io_idx_si) = sites(s)%tot_seed_rain_flux + + ! set numpatches for this column + rio_npatch_si(io_idx_si) = patchespersite + + do i = 1,numWaterMem ! numWaterMem currently 10 + rio_watermem_siwm( io_idx_si_wmem ) = sites(s)%water_memory(i) + io_idx_si_wmem = io_idx_si_wmem + 1 + end do + + enddo + + if ( DEBUG ) then + write(fates_log(),*) 'CLTV total cohorts ',totalCohorts + end if + + return + end associate + end subroutine set_restart_vectors + + ! ==================================================================================== + + subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) + + ! ---------------------------------------------------------------------------------- + ! This subroutine takes a peak at the restart file to determine how to allocate + ! memory for the state structure, and then makes those allocations. This + ! subroutine is called prior to the transfer of the restart vectors into the + ! linked-list state structure. + ! --------------------------------------------------------------------------------- + use EDTypesMod, only : ed_site_type + use EDTypesMod, only : ed_cohort_type + use EDTypesMod, only : ed_patch_type + use EDTypesMod, only : ncwd + use EDTypesMod, only : nlevleaf + use EDTypesMod, only : nclmax + use FatesInterfaceMod, only : fates_maxElementsPerPatch + use EDTypesMod, only : numpft_ed + use EDTypesMod, only : area + use EDPatchDynamicsMod, only : zero_patch + use EDGrowthFunctionsMod, only : Dbh + use EDCohortDynamicsMod, only : create_cohort + use EDInitMod, only : zero_site + use EDParamsMod, only : ED_val_maxspread + use EDPatchDynamicsMod, only : create_patch + use EDPftvarcon, only : EDPftvarcon_inst + + ! !ARGUMENTS: + class(fates_restart_interface_type) , intent(inout) :: this + integer , intent(in) :: nc + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type) , intent(in) :: bc_in(nsites) + + ! local variables + + type(ed_patch_type) , pointer :: newp + type(ed_cohort_type), allocatable :: temp_cohort + real(r8) :: cwd_ag_local(ncwd) + real(r8) :: cwd_bg_local(ncwd) + real(r8) :: spread_local(nclmax) + real(r8) :: leaf_litter_local(numpft_ed) + real(r8) :: root_litter_local(numpft_ed) + real(r8) :: patch_age + integer :: cohortstatus + integer :: s ! site index + integer :: idx_pa ! local patch index + integer :: io_idx_si ! global site index in IO vector + integer :: io_idx_co_1st ! global cohort index in IO vector + + integer :: fto + integer :: ft + + ! Dummy arguments used for calling create patch, these will be overwritten before + ! run-time. Just used now for allocation. + cwd_ag_local(:) = 0.0_r8 + cwd_bg_local(:) = 0.0_r8 + leaf_litter_local(:) = 0.0_r8 + root_litter_local(:) = 0.0_r8 + spread_local(:) = ED_val_maxspread + patch_age = 0.0_r8 + + ! ---------------------------------------------------------------------------------- + ! We really only need the counts for the number of patches per site + ! and the number of cohorts per patch. These values tell us how much + ! space to allocate. + ! ---------------------------------------------------------------------------------- + + associate( rio_npatch_si => this%rvars(ir_npatch_si)%int1d , & + rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d ) + + do s = 1,nsites + + io_idx_si = this%restart_map(nc)%site_index(s) + io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) + + call zero_site( sites(s) ) + + ! + ! set a few items that are necessary on restart for ED but not on the + ! restart file + ! + + sites(s)%ncd = 0.0_r8 + + if ( rio_npatch_si(io_idx_si)<0 .or. rio_npatch_si(io_idx_si) > 10000 ) then + write(fates_log(),*) 'a column was expected to contain a valid number of patches' + write(fates_log(),*) '0 is a valid number, but this column seems uninitialized',rio_npatch_si(io_idx_si) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Initialize the site pointers to null + sites(s)%youngest_patch => null() + sites(s)%oldest_patch => null() + + do idx_pa = 1,rio_npatch_si(io_idx_si) + + if ( DEBUG ) then + write(fates_log(),*) 'create patch ',idx_pa + write(fates_log(),*) 'idx_pa 1-cohortsperpatch : ', rio_ncohort_pa( io_idx_co_1st ) + end if + + ! create patch + allocate(newp) + + ! make new patch + call create_patch(sites(s), newp, patch_age, area, & + spread_local, cwd_ag_local, cwd_bg_local, & + leaf_litter_local, root_litter_local) + + newp%siteptr => sites(s) + + ! give this patch a unique patch number + newp%patchno = idx_pa + + do fto = 1, rio_ncohort_pa( io_idx_co_1st ) + + allocate(temp_cohort) + + temp_cohort%n = 700.0_r8 + temp_cohort%balive = 0.0_r8 + temp_cohort%bdead = 0.0_r8 + temp_cohort%bstore = 0.0_r8 + temp_cohort%laimemory = 0.0_r8 + temp_cohort%canopy_trim = 0.0_r8 + temp_cohort%canopy_layer = 1.0_r8 + temp_cohort%canopy_layer_yesterday = 1.0_r8 + + ! set the pft (only 2 used in ed) based on odd/even cohort + ! number + ft=2 + if ((mod(fto, 2) == 0 )) then + ft=1 + endif + temp_cohort%pft = ft + + cohortstatus = newp%siteptr%status + + if(EDPftvarcon_inst%stress_decid(ft) == 1)then !drought decidous, override status. + cohortstatus = newp%siteptr%dstatus + endif + + temp_cohort%hite = 1.25_r8 + ! the dbh function should only take as an argument, the one + ! item it needs, not the entire cohort...refactor + temp_cohort%dbh = Dbh(temp_cohort) + 0.0001_r8*ft + + if (DEBUG) then + write(fates_log(),*) 'EDRestVectorMod.F90::createPatchCohortStructure call create_cohort ' + end if + + call create_cohort(newp, ft, temp_cohort%n, temp_cohort%hite, temp_cohort%dbh, & + temp_cohort%balive, temp_cohort%bdead, temp_cohort%bstore, & + temp_cohort%laimemory, cohortstatus, temp_cohort%canopy_trim, newp%NCL_p, & + bc_in(s)) + + deallocate(temp_cohort) + + enddo ! ends loop over fto + + ! + ! insert this patch with cohorts into the site pointer. At this + ! point just insert the new patch in the youngest position + ! + if (idx_pa == 1) then ! nothing associated yet. first patch is pointed to by youngest and oldest + + if ( DEBUG ) write(fates_log(),*) 'idx_pa = 1 ',idx_pa + + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp + sites(s)%youngest_patch%younger => null() + sites(s)%youngest_patch%older => null() + sites(s)%oldest_patch%younger => null() + sites(s)%oldest_patch%older => null() + + else if (idx_pa == 2) then ! add second patch to list + + if ( DEBUG ) write(fates_log(),*) 'idx_pa = 2 ',idx_pa + + sites(s)%youngest_patch => newp + sites(s)%youngest_patch%younger => null() + sites(s)%youngest_patch%older => sites(s)%oldest_patch + sites(s)%oldest_patch%younger => sites(s)%youngest_patch + sites(s)%oldest_patch%older => null() + + else ! more than 2 patches, insert patch into youngest slot + + if ( DEBUG ) write(fates_log(),*) 'idx_pa > 2 ',idx_pa + + newp%older => sites(s)%youngest_patch + sites(s)%youngest_patch%younger => newp + newp%younger => null() + sites(s)%youngest_patch => newp + + endif + + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch + + enddo ! ends loop over idx_pa + + enddo ! ends loop over s + + end associate + end subroutine create_patchcohort_structure + + ! ==================================================================================== + + subroutine get_restart_vectors(this, nc, nsites, sites) + + use EDTypesMod, only : ed_site_type + use EDTypesMod, only : ed_cohort_type + use EDTypesMod, only : ed_patch_type + use EDTypesMod, only : numpft_ed + use EDTypesMod, only : ncwd + use EDTypesMod, only : nlevleaf + use EDTypesMod, only : nclmax + use FatesInterfaceMod, only : fates_maxElementsPerPatch + use EDTypesMod, only : numWaterMem + + ! !ARGUMENTS: + class(fates_restart_interface_type) , intent(inout) :: this + integer , intent(in) :: nc + integer , intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + + + ! locals + ! ---------------------------------------------------------------------------------- + ! LL pointers + type(ed_patch_type),pointer :: cpatch ! current patch + type(ed_cohort_type),pointer :: ccohort ! current cohort + + ! loop indices + integer :: s, i, j, k + + ! ---------------------------------------------------------------------------------- + ! The following group of integers indicate the positional index (idx) + ! of variables at different scales inside the I/O arrays (io) + ! Keep in mind that many of these variables have a composite dimension + ! at the patch scale. To hold this memory, we borrow the cohort + ! vector. Thus the head of each array points to the first cohort + ! of each patch. "io_idx_co_1st" + ! ---------------------------------------------------------------------------------- + integer :: io_idx_si ! site index + integer :: io_idx_co_1st ! 1st cohort of each patch + integer :: io_idx_co ! cohort index + integer :: io_idx_pa_pft ! each pft within each patch (pa_pft) + integer :: io_idx_pa_cwd ! each cwd class within each patch (pa_cwd) + integer :: io_idx_pa_cl ! each canopy layer class within each patch (pa_cl) + integer :: io_idx_pa_sunz ! index for the combined dimensions for radiation + integer :: io_idx_si_wmem ! each water memory class within each site + + ! Some counters (for checking mostly) + integer :: totalcohorts ! total cohort count on this thread (diagnostic) + integer :: patchespersite ! number of patches per site + integer :: cohortsperpatch ! number of cohorts per patch + + + + associate( rio_npatch_si => this%rvars(ir_npatch_si)%int1d, & + rio_old_stock_si => this%rvars(ir_oldstock_si)%r81d, & + rio_cd_status_si => this%rvars(ir_cd_status_si)%r81d, & + rio_dd_status_si => this%rvars(ir_dd_status_si)%r81d, & + rio_nchill_days_si => this%rvars(ir_nchill_days_si)%r81d, & + rio_leafondate_si => this%rvars(ir_leafondate_si)%r81d, & + rio_leafoffdate_si => this%rvars(ir_leafoffdate_si)%r81d, & + rio_dleafondate_si => this%rvars(ir_dleafondate_si)%r81d, & + rio_dleafoffdate_si => this%rvars(ir_dleafoffdate_si)%r81d, & + rio_acc_ni_si => this%rvars(ir_acc_ni_si)%r81d, & + rio_gdd_si => this%rvars(ir_gdd_si)%r81d, & + rio_nep_timeintegrated_si => this%rvars(ir_nep_timeintegrated_si)%r81d, & + rio_npp_timeintegrated_si => this%rvars(ir_npp_timeintegrated_si)%r81d, & + rio_hr_timeintegrated_si => this%rvars(ir_hr_timeintegrated_si)%r81d, & + rio_cbal_err_fates_si => this%rvars(ir_cbal_error_fates_si)%r81d, & + rio_cbal_err_bgc_si => this%rvars(ir_cbal_error_bgc_si)%r81d, & + rio_cbal_err_tot_si => this%rvars(ir_cbal_error_total_si)%r81d, & + rio_totecosysc_old_si => this%rvars(ir_totecosysc_old_si)%r81d, & + rio_totfatesc_old_si => this%rvars(ir_totfatesc_old_si)%r81d, & + rio_totbgcc_old_si => this%rvars(ir_totbgcc_old_si)%r81d, & + rio_fates_to_bgc_this_ts_si => this%rvars(ir_fates_to_bgc_this_ts_si)%r81d, & + rio_fates_to_bgc_last_ts_si => this%rvars(ir_fates_to_bgc_last_ts_si)%r81d, & + rio_seedrainflux_si => this%rvars(ir_seedrainflux_si)%r81d, & + rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d, & + rio_balive_co => this%rvars(ir_balive_co)%r81d, & + rio_bdead_co => this%rvars(ir_bdead_co)%r81d, & + rio_bleaf_co => this%rvars(ir_bleaf_co)%r81d, & + rio_broot_co => this%rvars(ir_broot_co)%r81d, & + rio_bstore_co => this%rvars(ir_bstore_co)%r81d, & + rio_canopy_layer_co => this%rvars(ir_canopy_layer_co)%r81d, & + rio_canopy_layer_yesterday_co => this%rvars(ir_canopy_layer_yesterday_co)%r81d, & + rio_canopy_trim_co => this%rvars(ir_canopy_trim_co)%r81d, & + rio_dbh_co => this%rvars(ir_dbh_co)%r81d, & + rio_height_co => this%rvars(ir_height_co)%r81d, & + rio_laimemory_co => this%rvars(ir_laimemory_co)%r81d, & + rio_leaf_md_co => this%rvars(ir_leaf_md_co)%r81d, & + rio_root_md_co => this%rvars(ir_root_md_co)%r81d, & + rio_nplant_co => this%rvars(ir_nplant_co)%r81d, & + rio_gpp_acc_co => this%rvars(ir_gpp_acc_co)%r81d, & + rio_npp_acc_co => this%rvars(ir_npp_acc_co)%r81d, & + rio_gpp_acc_hold_co => this%rvars(ir_gpp_acc_hold_co)%r81d, & + rio_npp_acc_hold_co => this%rvars(ir_npp_acc_hold_co)%r81d, & + rio_npp_leaf_co => this%rvars(ir_npp_leaf_co)%r81d, & + rio_npp_froot_co => this%rvars(ir_npp_froot_co)%r81d, & + rio_npp_sw_co => this%rvars(ir_npp_sw_co)%r81d, & + rio_npp_dead_co => this%rvars(ir_npp_dead_co)%r81d, & + rio_npp_seed_co => this%rvars(ir_npp_seed_co)%r81d, & + rio_npp_store_co => this%rvars(ir_npp_store_co)%r81d, & + rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & + rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & + rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & + rio_imort_co => this%rvars(ir_imort_co)%r81d, & + rio_fmort_co => this%rvars(ir_fmort_co)%r81d, & + rio_ddbhdt_co => this%rvars(ir_ddbhdt_co)%r81d, & + rio_dbalivedt_co => this%rvars(ir_dbalivedt_co)%r81d, & + rio_dbdeaddt_co => this%rvars(ir_dbdeaddt_co)%r81d, & + rio_dbstoredt_co => this%rvars(ir_dbstoredt_co)%r81d, & + rio_resp_tstep_co => this%rvars(ir_resp_tstep_co)%r81d, & + rio_pft_co => this%rvars(ir_pft_co)%int1d, & + rio_status_co => this%rvars(ir_status_co)%int1d, & + rio_isnew_co => this%rvars(ir_isnew_co)%int1d, & + rio_cwd_ag_pacw => this%rvars(ir_cwd_ag_pacw)%r81d, & + rio_cwd_bg_pacw => this%rvars(ir_cwd_bg_pacw)%r81d, & + rio_leaf_litter_paft => this%rvars(ir_leaf_litter_paft)%r81d, & + rio_root_litter_paft => this%rvars(ir_root_litter_paft)%r81d, & + rio_leaf_litter_in_paft => this%rvars(ir_leaf_litter_in_paft)%r81d, & + rio_root_litter_in_paft => this%rvars(ir_root_litter_in_paft)%r81d, & + rio_seed_bank_sift => this%rvars(ir_seed_bank_sift)%r81d, & + rio_spread_pacl => this%rvars(ir_spread_pacl)%r81d, & + rio_livegrass_pa => this%rvars(ir_livegrass_pa)%r81d, & + rio_age_pa => this%rvars(ir_age_pa)%r81d, & + rio_area_pa => this%rvars(ir_area_pa)%r81d, & + rio_fsun_paclftls => this%rvars(ir_fsun_paclftls)%r81d, & + rio_fabd_sun_z_paclftls => this%rvars(ir_fabd_sun_paclftls)%r81d, & + rio_fabi_sun_z_paclftls => this%rvars(ir_fabi_sun_paclftls)%r81d, & + rio_fabd_sha_z_paclftls => this%rvars(ir_fabd_sha_paclftls)%r81d, & + rio_fabi_sha_z_paclftls => this%rvars(ir_fabi_sha_paclftls)%r81d, & + rio_watermem_siwm => this%rvars(ir_watermem_siwm)%r81d ) + + totalcohorts = 0 + + do s = 1,nsites + + io_idx_si = this%restart_map(nc)%site_index(s) + io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) + + io_idx_co = io_idx_co_1st + io_idx_pa_pft = io_idx_co_1st + io_idx_pa_cwd = io_idx_co_1st + io_idx_pa_cl = io_idx_co_1st + io_idx_pa_sunz = io_idx_co_1st + io_idx_si_wmem = io_idx_co_1st + + ! read seed_bank info(site-level, but PFT-resolved) + do i = 1,numpft_ed + sites(s)%seed_bank(i) = rio_seed_bank_sift(io_idx_co_1st+i-1) + enddo + + ! Perform a check on the number of patches per site + patchespersite = 0 + + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + + patchespersite = patchespersite + 1 + + ccohort => cpatch%shortest + + ! new patch, reset num cohorts + cohortsperpatch = 0 + + do while(associated(ccohort)) + + ! found cohort, increment + cohortsperpatch = cohortsperpatch + 1 + totalcohorts = totalcohorts + 1 + + if ( DEBUG ) then + write(fates_log(),*) 'CVTL io_idx_co ',io_idx_co + endif + + ccohort%balive = rio_balive_co(io_idx_co) + ccohort%bdead = rio_bdead_co(io_idx_co) + ccohort%bl = rio_bleaf_co(io_idx_co) + ccohort%br = rio_broot_co(io_idx_co) + ccohort%bstore = rio_bstore_co(io_idx_co) + ccohort%canopy_layer = rio_canopy_layer_co(io_idx_co) + ccohort%canopy_layer_yesterday = rio_canopy_layer_yesterday_co(io_idx_co) + ccohort%canopy_trim = rio_canopy_trim_co(io_idx_co) + ccohort%dbh = rio_dbh_co(io_idx_co) + ccohort%hite = rio_height_co(io_idx_co) + ccohort%laimemory = rio_laimemory_co(io_idx_co) + ccohort%leaf_md = rio_leaf_md_co(io_idx_co) + ccohort%root_md = rio_root_md_co(io_idx_co) + ccohort%n = rio_nplant_co(io_idx_co) + ccohort%gpp_acc = rio_gpp_acc_co(io_idx_co) + ccohort%npp_acc = rio_npp_acc_co(io_idx_co) + ccohort%gpp_acc_hold = rio_gpp_acc_hold_co(io_idx_co) + ccohort%npp_acc_hold = rio_npp_acc_hold_co(io_idx_co) + ccohort%npp_leaf = rio_npp_leaf_co(io_idx_co) + ccohort%npp_froot = rio_npp_froot_co(io_idx_co) + ccohort%npp_bsw = rio_npp_sw_co(io_idx_co) + ccohort%npp_bdead = rio_npp_dead_co(io_idx_co) + ccohort%npp_bseed = rio_npp_seed_co(io_idx_co) + ccohort%npp_store = rio_npp_store_co(io_idx_co) + ccohort%bmort = rio_bmort_co(io_idx_co) + ccohort%hmort = rio_hmort_co(io_idx_co) + ccohort%cmort = rio_cmort_co(io_idx_co) + ccohort%imort = rio_imort_co(io_idx_co) + ccohort%fmort = rio_fmort_co(io_idx_co) + ccohort%ddbhdt = rio_ddbhdt_co(io_idx_co) + ccohort%dbalivedt = rio_dbalivedt_co(io_idx_co) + ccohort%dbdeaddt = rio_dbdeaddt_co(io_idx_co) + ccohort%dbstoredt = rio_dbstoredt_co(io_idx_co) + ccohort%resp_tstep = rio_resp_tstep_co(io_idx_co) + ccohort%pft = rio_pft_co(io_idx_co) + ccohort%status_coh = rio_status_co(io_idx_co) + ccohort%isnew = ( rio_isnew_co(io_idx_co) .eq. new_cohort ) + + io_idx_co = io_idx_co + 1 + + ccohort => ccohort%taller + + enddo ! current cohort do while + + if(cohortsperpatch .ne. rio_ncohort_pa(io_idx_co_1st)) then + write(fates_log(),*) 'Number of cohorts per patch during retrieval' + write(fates_log(),*) 'does not match allocation' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + ! FIX(SPM,032414) move to init if you can...or make a new init function + cpatch%leaf_litter(:) = 0.0_r8 + cpatch%root_litter(:) = 0.0_r8 + cpatch%leaf_litter_in(:) = 0.0_r8 + cpatch%root_litter_in(:) = 0.0_r8 + cpatch%spread(:) = 0.0_r8 + + ! + ! deal with patch level fields here + ! + cpatch%livegrass = rio_livegrass_pa(io_idx_co_1st) + cpatch%age = rio_age_pa(io_idx_co_1st) + cpatch%area = rio_area_pa(io_idx_co_1st) + + ! set cohorts per patch for IO + + if ( DEBUG ) then + write(fates_log(),*) 'CVTL III ' & + ,io_idx_co,cohortsperpatch + endif + ! + ! deal with patch level fields of arrays here + ! + ! these are arrays of length numpft_ed, each patch contains one + ! vector so we increment + + do i = 1,numpft_ed + cpatch%leaf_litter(i) = rio_leaf_litter_paft(io_idx_pa_pft) + cpatch%root_litter(i) = rio_root_litter_paft(io_idx_pa_pft) + cpatch%leaf_litter_in(i) = rio_leaf_litter_in_paft(io_idx_pa_pft) + cpatch%root_litter_in(i) = rio_root_litter_in_paft(io_idx_pa_pft) + io_idx_pa_pft = io_idx_pa_pft + 1 + enddo + + do i = 1,ncwd ! ncwd currently 4 + cpatch%cwd_ag(i) = rio_cwd_ag_pacw(io_idx_pa_cwd) + cpatch%cwd_bg(i) = rio_cwd_bg_pacw(io_idx_pa_cwd) + io_idx_pa_cwd = io_idx_pa_cwd + 1 + enddo + + do i = 1,nclmax ! nclmax currently 2 + cpatch%spread(i) = rio_spread_pacl(io_idx_pa_cl) + io_idx_pa_cl = io_idx_pa_cl + 1 + enddo + + if ( DEBUG ) write(fates_log(),*) 'CVTL io_idx_pa_sunz 1 ',io_idx_pa_sunz + + do k = 1,nlevleaf ! nlevleaf currently 40 + do j = 1,numpft_ed ! numpft_ed currently 2 + do i = 1,nclmax ! nclmax currently 2 + cpatch%f_sun(i,j,k) = rio_fsun_paclftls(io_idx_pa_sunz) + cpatch%fabd_sun_z(i,j,k) = rio_fabd_sun_z_paclftls(io_idx_pa_sunz) + cpatch%fabi_sun_z(i,j,k) = rio_fabi_sun_z_paclftls(io_idx_pa_sunz) + cpatch%fabd_sha_z(i,j,k) = rio_fabd_sha_z_paclftls(io_idx_pa_sunz) + cpatch%fabi_sha_z(i,j,k) = rio_fabi_sha_z_paclftls(io_idx_pa_sunz) + io_idx_pa_sunz = io_idx_pa_sunz + 1 + end do + end do + end do + + if ( DEBUG ) write(fates_log(),*) 'CVTL io_idx_pa_sunz 2 ',io_idx_pa_sunz + + ! Now increment the position of the first cohort to that of the next + ! patch + + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch + + ! and max the number of allowed cohorts per patch + io_idx_pa_pft = io_idx_co_1st + io_idx_pa_cwd = io_idx_co_1st + io_idx_pa_cl = io_idx_co_1st + io_idx_co = io_idx_co_1st + io_idx_pa_sunz = io_idx_co_1st + + if ( DEBUG ) then + write(fates_log(),*) 'CVTL io_idx_co_1st ', io_idx_co_1st + write(fates_log(),*) 'CVTL cohortsperpatch ', cohortsperpatch + write(fates_log(),*) 'CVTL totalCohorts ', totalCohorts + end if + + cpatch => cpatch%younger + + enddo ! patch do while + + if(patchespersite .ne. rio_npatch_si(io_idx_si)) then + write(fates_log(),*) 'Number of patches per site during retrieval does not match allocation' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + do i = 1,numWaterMem + sites(s)%water_memory(i) = rio_watermem_siwm( io_idx_si_wmem ) + io_idx_si_wmem = io_idx_si_wmem + 1 + end do + + sites(s)%old_stock = rio_old_stock_si(io_idx_si) + sites(s)%status = rio_cd_status_si(io_idx_si) + sites(s)%dstatus = rio_dd_status_si(io_idx_si) + sites(s)%ncd = rio_nchill_days_si(io_idx_si) + sites(s)%leafondate = rio_leafondate_si(io_idx_si) + sites(s)%leafoffdate = rio_leafoffdate_si(io_idx_si) + sites(s)%dleafondate = rio_dleafondate_si(io_idx_si) + sites(s)%dleafoffdate = rio_dleafoffdate_si(io_idx_si) + sites(s)%acc_NI = rio_acc_ni_si(io_idx_si) + sites(s)%ED_GDD_site = rio_gdd_si(io_idx_si) + + ! Carbon Balance and Checks + sites(s)%nep_timeintegrated = rio_nep_timeintegrated_si(io_idx_si) + sites(s)%npp_timeintegrated = rio_npp_timeintegrated_si(io_idx_si) + sites(s)%hr_timeintegrated = rio_hr_timeintegrated_si(io_idx_si) + sites(s)%totecosysc_old = rio_totecosysc_old_si(io_idx_si) + sites(s)%totfatesc_old = rio_totfatesc_old_si(io_idx_si) + sites(s)%totbgcc_old = rio_totbgcc_old_si(io_idx_si) + sites(s)%cbal_err_fates = rio_cbal_err_fates_si(io_idx_si) + sites(s)%cbal_err_bgc = rio_cbal_err_bgc_si(io_idx_si) + sites(s)%cbal_err_tot = rio_cbal_err_tot_si(io_idx_si) + sites(s)%fates_to_bgc_this_ts = rio_fates_to_bgc_this_ts_si(io_idx_si) + sites(s)%fates_to_bgc_last_ts = rio_fates_to_bgc_last_ts_si(io_idx_si) + sites(s)%tot_seed_rain_flux = rio_seedrainflux_si(io_idx_si) + + end do + + if ( DEBUG ) then + write(fates_log(),*) 'CVTL total cohorts ',totalCohorts + end if + + end associate + end subroutine get_restart_vectors + + end module FatesRestartInterfaceMod diff --git a/main/FatesRestartVariableType.F90 b/main/FatesRestartVariableType.F90 new file mode 100644 index 00000000..40648fb4 --- /dev/null +++ b/main/FatesRestartVariableType.F90 @@ -0,0 +1,203 @@ +module FatesRestartVariableMod + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesGlobals, only : fates_log + use FatesIOVariableKindMod, only : fates_io_variable_kind_type + + implicit none + + ! This type is instanteated in the HLM-FATES interface (clmfates_interfaceMod.F90) + + type fates_restart_variable_type + character(len=32) :: vname + character(len=24) :: units + character(len=128) :: long + character(len=24) :: vtype + real(r8) :: flushval ! DONT THINK THIS IS NEEDED IN RESTARTS + ! RESTARTS HAVE A MAPPING TABLE AND + ! THERE IS NO AVERAGING AND NO NEED TO + ! INDICATE NON-INCLUDED ARRAY SPACES + ! KEEPING FOR NOW (RGK-11-2016) + integer :: dim_kinds_index + ! Pointers (only one of these is allocated per variable) + real(r8), pointer :: r81d(:) + integer, pointer :: int1d(:) + contains + procedure, public :: Init + procedure, public :: Flush + procedure, private :: GetBounds + end type fates_restart_variable_type + +contains + + subroutine Init(this, vname, units, long, vtype, flushval, num_dim_kinds, dim_kinds, dim_bounds) + + use FatesIODimensionsMod, only : fates_io_dimension_type + use FatesIOVariableKindMod, only : patch_r8, site_r8, cohort_r8 + use FatesIOVariableKindMod, only : patch_int, site_int, cohort_int + use FatesIOVariableKindMod, only : iotype_index + + implicit none + + class(fates_restart_variable_type), intent(inout) :: this + character(len=*), intent(in) :: vname + character(len=*), intent(in) :: units + character(len=*), intent(in) :: long + character(len=*), intent(in) :: vtype + real(r8), intent(in) :: flushval + integer, intent(in) :: num_dim_kinds + type(fates_io_dimension_type), intent(in) :: dim_bounds(:) + type(fates_io_variable_kind_type), intent(inout) :: dim_kinds(:) + + integer :: dk_index + integer :: lb1, ub1, lb2, ub2 + + this%vname = vname + this%units = units + this%long = long + this%vtype = vtype + this%flushval = flushval + + nullify(this%r81d) + nullify(this%int1d) + + dk_index = iotype_index(trim(vtype), num_dim_kinds, dim_kinds) + this%dim_kinds_index = dk_index + call dim_kinds(dk_index)%set_active() + + call this%GetBounds(0, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) + + ! NOTE(rgk, 2016-09) currently, all array spaces are flushed each + ! time the update is called. The flush here on the initialization + ! may be redundant, but will prevent issues in the future if we + ! have host models where not all threads are updating the HHistory + ! array spaces. + + select case(trim(vtype)) + + case(cohort_r8) + allocate(this%r81d(lb1:ub1)) + this%r81d(:) = flushval + + case(patch_r8) + allocate(this%r81d(lb1:ub1)) + this%r81d(:) = flushval + + case(site_r8) + allocate(this%r81d(lb1:ub1)) + this%r81d(:) = flushval + + case(cohort_int) + allocate(this%int1d(lb1:ub1)) + this%int1d(:) = idnint(flushval) + + case(patch_int) + allocate(this%int1d(lb1:ub1)) + this%int1d(:) = idnint(flushval) + + case(site_int) + allocate(this%int1d(lb1:ub1)) + this%int1d(:) = idnint(flushval) + + case default + write(fates_log(),*) 'Incompatible vtype passed to set_restart_var' + write(fates_log(),*) 'vtype = ',trim(vtype),' ?' + stop + ! end_run + end select + + end subroutine Init + + ! ===================================================================================== + + subroutine GetBounds(this, thread, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) + + use FatesIODimensionsMod, only : fates_io_dimension_type + + implicit none + + class(fates_restart_variable_type), intent(inout) :: this + integer, intent(in) :: thread + class(fates_io_dimension_type), intent(in) :: dim_bounds(:) + type(fates_io_variable_kind_type), intent(in) :: dim_kinds(:) + integer, intent(out) :: lb1 + integer, intent(out) :: ub1 + integer, intent(out) :: lb2 + integer, intent(out) :: ub2 + + ! local + integer :: ndims + integer :: d_index + + lb1 = 0 + ub1 = 0 + lb2 = 0 + ub2 = 0 + + ndims = dim_kinds(this%dim_kinds_index)%ndims + + ! The thread = 0 case is the boundaries for the whole proc/node + if (thread==0) then + d_index = dim_kinds(this%dim_kinds_index)%dim1_index + lb1 = dim_bounds(d_index)%lower_bound + ub1 = dim_bounds(d_index)%upper_bound + if(ndims>1)then + d_index = dim_kinds(this%dim_kinds_index)%dim2_index + lb2 = dim_bounds(d_index)%lower_bound + ub2 = dim_bounds(d_index)%upper_bound + end if + else + d_index = dim_kinds(this%dim_kinds_index)%dim1_index + lb1 = dim_bounds(d_index)%clump_lower_bound(thread) + ub1 = dim_bounds(d_index)%clump_upper_bound(thread) + if(ndims>1)then + d_index = dim_kinds(this%dim_kinds_index)%dim2_index + lb2 = dim_bounds(d_index)%clump_lower_bound(thread) + ub2 = dim_bounds(d_index)%clump_upper_bound(thread) + end if + end if + + end subroutine GetBounds + + ! ==================================================================================== + + subroutine flush(this, thread, dim_bounds, dim_kinds) + + use FatesIODimensionsMod, only : fates_io_dimension_type + use FatesIOVariableKindMod, only : patch_r8, site_r8, cohort_r8 + use FatesIOVariableKindMod, only : patch_int, site_int, cohort_int + + implicit none + + class(fates_restart_variable_type), intent(inout) :: this + integer, intent(in) :: thread + type(fates_io_dimension_type), intent(in) :: dim_bounds(:) + type(fates_io_variable_kind_type), intent(in) :: dim_kinds(:) + + integer :: lb1, ub1, lb2, ub2 + + call this%GetBounds(thread, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) + + select case(trim(dim_kinds(this%dim_kinds_index)%name)) + case(patch_r8) + this%r81d(lb1:ub1) = this%flushval + case(site_r8) + this%r81d(lb1:ub1) = this%flushval + case(cohort_r8) + this%r81d(lb1:ub1) = this%flushval + case(patch_int) + this%int1d(lb1:ub1) = nint(this%flushval) + case(site_int) + this%int1d(lb1:ub1) = nint(this%flushval) + case(cohort_int) + this%int1d(lb1:ub1) = nint(this%flushval) + + case default + write(fates_log(),*) 'fates history variable type undefined while flushing history variables' + stop + !end_run + end select + + end subroutine Flush + +end module FatesRestartVariableMod diff --git a/main/FatesSynchronizedParamsMod.F90 b/main/FatesSynchronizedParamsMod.F90 new file mode 100644 index 00000000..57c61439 --- /dev/null +++ b/main/FatesSynchronizedParamsMod.F90 @@ -0,0 +1,131 @@ +module FatesSynchronizedParamsMod + + !----------------------------------------------------------------------- + ! + ! !USES: + use FatesConstantsMod, only : r8 => fates_r8 + implicit none + + ! FatesSynchronizedParamsInst. PGI wants the type decl. public but the instance + ! is indeed protected. A generic private statement at the start of the module + ! overrides the protected functionality with PGI + + type, public :: FatesSynchronizedParamsType + real(r8) :: Q10 ! temperature dependence + real(r8) :: froz_q10 ! separate q10 for frozen soil respiration rates + contains + procedure, public :: RegisterParams + procedure, public :: ReceiveParams + procedure, private :: Init + procedure, private :: RegisterParamsScalar + procedure, private :: ReceiveParamsScalar + end type FatesSynchronizedParamsType + + type(FatesSynchronizedParamsType), public :: FatesSynchronizedParamsInst + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + !----------------------------------------------------------------------- + +contains + + subroutine Init(this) + ! Initialize all parameters to nan to ensure that we get valid + ! values back from the host. + + use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) + + implicit none + + class(FatesSynchronizedParamsType), intent(inout) :: this + + this%Q10 = nan + this%froz_q10 = nan + + end subroutine Init + + !----------------------------------------------------------------------- + subroutine RegisterParams(this, fates_params) + ! Register the parameters we want the host to provide, and + ! indicate whether they are fates parameters or host parameters + ! that need to be synced with host values. + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + + implicit none + + class(FatesSynchronizedParamsType), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + call this%Init() + call this%RegisterParamsScalar(fates_params) + + end subroutine RegisterParams + + !----------------------------------------------------------------------- + subroutine ReceiveParams(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + + implicit none + + class(FatesSynchronizedParamsType), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + call this%ReceiveParamsScalar(fates_params) + + end subroutine ReceiveParams + + !----------------------------------------------------------------------- + subroutine RegisterParamsScalar(this, fates_params) + ! Register the parameters we want the host to provide, and + ! indicate whether they are fates parameters or host parameters + ! that need to be synced with host values. + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + use FatesParametersInterface, only : dimension_name_host_allpfts, dimension_shape_1d + + implicit none + + class(FatesSynchronizedParamsType), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_host_allpfts/) + character(len=param_string_length) :: name + + call this%Init() + + name = 'q10_mr' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, sync_with_host=.true.) + + name = 'froz_q10' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, sync_with_host=.true.) + + end subroutine RegisterParamsScalar + + !----------------------------------------------------------------------- + subroutine ReceiveParamsScalar(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + + implicit none + + class(FatesSynchronizedParamsType), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length) :: name + + name = 'q10_mr' + call fates_params%RetreiveParameter(name=name, & + data=this%Q10) + + name = 'froz_q10' + call fates_params%RetreiveParameter(name=name, & + data=this%froz_q10) + + end subroutine ReceiveParamsScalar + +end module FatesSynchronizedParamsMod diff --git a/main/FatesUtilsMod.F90 b/main/FatesUtilsMod.F90 new file mode 100644 index 00000000..08bf3069 --- /dev/null +++ b/main/FatesUtilsMod.F90 @@ -0,0 +1,34 @@ +module FatesUtilsMod + + ! This module contains helper functions and subroutines which are general in nature. + ! Think string parsing, timing, maybe numerics, etc. + +contains + + + function check_hlm_list(hlms,hlm_name) result(astatus) + + ! --------------------------------------------------------------------------------- + ! This simple function compares a string of HLM tags to see if any of the names + ! match the name of the currently active HLM. If any do, return true, if any + ! don't, if any don't its a big secret. + ! --------------------------------------------------------------------------------- + + character(len=*),intent(in) :: hlms + character(len=*),intent(in) :: hlm_name + + integer :: index + logical :: astatus + + astatus = .false. + index = scan(trim(hlms),trim(hlm_name)) + + if(index>0)then + astatus=.true. + end if + return + + end function check_hlm_list + + +end module FatesUtilsMod