diff --git a/.github/images/logo_fates_large.png b/.github/images/logo_fates_large.png new file mode 100644 index 0000000000..91907d7545 Binary files /dev/null and b/.github/images/logo_fates_large.png differ diff --git a/.github/images/logo_fates_medium.png b/.github/images/logo_fates_medium.png new file mode 100644 index 0000000000..32a1473b5e Binary files /dev/null and b/.github/images/logo_fates_medium.png differ diff --git a/.github/images/logo_fates_small.png b/.github/images/logo_fates_small.png new file mode 100644 index 0000000000..ed014a552c Binary files /dev/null and b/.github/images/logo_fates_small.png differ diff --git a/README.md b/README.md index e3886bc268..a7688d60fa 100644 --- a/README.md +++ b/README.md @@ -1,18 +1,23 @@ -# FATES + +![FATES_logo](.github/images/logo_fates_small.png) ------------------------------ [![DOI](https://zenodo.org/badge/DOI/10.5281/zenodo.3825473.svg)](https://doi.org/10.5281/zenodo.3825473) This repository holds the Functionally Assembled Terrestrial Ecosystem Simulator (FATES). FATES is a numerical terrestrial ecosystem model. Its development and support is primarily supported by the Department of Energy's Office of Science, through the Next Generation Ecosystem Experiment - Tropics ([NGEE-T](https://ngee-tropics.lbl.gov/)) project. -For more information on the FATES model, see our [wiki](https://github.com/NGEET/fates/wiki) and [technical documentation](https://fates-docs.readthedocs.io/en/latest/index.html). +For more information on the FATES model, see our [User's Guide](https://fates-users-guide.readthedocs.io/en/latest/) and [technical documentation](https://fates-docs.readthedocs.io/en/latest/index.html). ## Important Guides: ------------------------------ +[User's Guide](https://fates-users-guide.readthedocs.io/en/latest/) + [How to Contribute](https://github.com/NGEET/fates/blob/master/CONTRIBUTING.md) -[List of Unsupported or Broken Features](https://github.com/NGEET/fates/wiki/Current-Unsupported-or-Broken-Features) +[Table of FATES and Host Land Model API compatability](https://fates-users-guide.readthedocs.io/en/latest/user/Table-of-FATES-API-and-HLM-STATUS.html) + +[List of Unsupported or Broken Features](https://fates-users-guide.readthedocs.io/en/latest/user/Current-Unsupported-or-Broken-Features.html) [Code of Conduct](https://github.com/NGEET/fates/blob/master/CODE_OF_CONDUCT.md) @@ -27,8 +32,6 @@ FATES has support to be run via the Energy Exascale Earth System Model (E3SM), t https://github.com/E3SM-Project/E3SM https://github.com/ESCOMP/cesm -https://github.com/ESCOMP/ctsm - ## Important Note About Host-Models and Compatible Branches: ------------------------------------------------------------ diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index e1fad85b66..9f0061f860 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -1,8 +1,8 @@ module EDCanopyStructureMod ! ===================================================================================== - ! Code to determine whether the canopy is closed, and which plants are either in the - ! understorey or overstorey. This is obviosuly far too complicated for it's own good + ! Code to determine whether the canopy is closed, and which plants are either in the + ! understorey or overstorey. This is obviosuly far too complicated for it's own good ! ===================================================================================== use FatesConstantsMod , only : r8 => fates_r8 @@ -14,10 +14,9 @@ module EDCanopyStructureMod use EDPftvarcon , only : EDPftvarcon_inst use PRTParametersMod , only : prt_params use FatesAllometryMod , only : carea_allom - use EDCohortDynamicsMod , only : copy_cohort, terminate_cohorts, fuse_cohorts + use EDCohortDynamicsMod , only : copy_cohort, terminate_cohorts, terminate_cohort, fuse_cohorts use EDCohortDynamicsMod , only : InitPRTObject use EDCohortDynamicsMod , only : InitPRTBoundaryConditions - use EDCohortDynamicsMod , only : SendCohortToLitter use FatesAllometryMod , only : tree_lai use FatesAllometryMod , only : tree_sai use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type @@ -29,6 +28,7 @@ module EDCanopyStructureMod use FatesInterfaceTypesMod , only : hlm_days_per_year use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking + use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : numpft use FatesInterfaceTypesMod, only : bc_in_type use FatesPlantHydraulicsMod, only : UpdateH2OVeg,InitHydrCohort, RecruitWaterStorage @@ -42,7 +42,7 @@ module EDCanopyStructureMod use PRTGenericMod, only : repro_organ use PRTGenericMod, only : struct_organ use PRTGenericMod, only : SetState - + use FatesRunningMeanMod, only : ema_lpa ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -56,23 +56,23 @@ module EDCanopyStructureMod public :: canopy_summarization public :: update_hlm_dynamics public :: UpdateFatesAvgSnowDepth - + logical, parameter :: debug=.false. character(len=*), parameter, private :: sourcefile = & __FILE__ - + real(r8), parameter :: area_target_precision = 1.0E-11_r8 ! Area conservation - ! will attempt to reduce errors - ! below this level - - real(r8), parameter :: area_check_precision = 1.0E-7_r8 ! Area conservation checks must - ! be within this absolute tolerance + ! will attempt to reduce errors + ! below this level + + real(r8), parameter :: area_check_precision = 1.0E-7_r8 ! Area conservation checks must + ! be within this absolute tolerance real(r8), parameter :: area_check_rel_precision = 1.0E-4_r8 ! Area conservation checks must - ! be within this relative tolerance + ! be within this relative tolerance real(r8), parameter :: similar_height_tol = 1.0E-3_r8 ! I think trees that differ by 1mm - ! can be roughly considered the same right? + ! can be roughly considered the same right? ! 10/30/09: Created by Rosie Fisher @@ -82,1135 +82,1145 @@ module EDCanopyStructureMod contains ! ============================================================================ - subroutine canopy_structure( currentSite , bc_in ) - ! - ! !DESCRIPTION: - ! create cohort instance - ! - ! This routine allocates the 'canopy_layer' attribute to each cohort - ! All top leaves in the same canopy layer get the same light resources. - ! The first canopy layer is the 'canopy' or 'overstorey'. The second is the 'understorey'. - ! More than two layers is not permitted at the moment - ! Seeds germinating into the 3rd or higher layers are automatically removed. - ! - ! ------Perfect Plasticity----- - ! The idea of these canopy layers derives originally from Purves et al. 2009 - ! Their concept is that, given enoughplasticity in canopy position, size, shape and depth - ! all of the gound area will be filled perfectly by leaves, and additional leaves will have - ! to exist in the understorey. - ! Purves et al. use the concept of 'Z*' to assume that the height required to attain a place in the - ! canopy is spatially uniform. In this implementation, described in Fisher et al. (2010, New Phyt) we - ! extent that concept to assume that position in the canopy has some random element, and that BOTH height - ! and chance combine to determine whether trees get into the canopy. - ! Thus, when the canopy is closed and there is excess area, some of it must be demoted - ! If we demote -all- the trees less than a given height, there is a massive advantage in being the cohort that is - ! the biggest when the canopy is closed. - ! In this implementation, the amount demoted, ('weight') is a function of the height weighted by the competitive exclusion - ! parameter (ED_val_comp_excln). - - ! Complexity in this routine results from a few things. - ! Firstly, the complication of the demotion amount sometimes being larger than the cohort area (for a very small, short cohort) - ! Second, occasionaly, disturbance (specifically fire) can cause the canopy layer to become less than closed, - ! without changing the area of the patch. If this happens, then some of the plants in the lower layer need to be 'promoted' so - ! all of the routine has to happen in both the downwards and upwards directions. - ! - ! The order of events here is therefore: - ! (The entire subroutine has a single outer 'patch' loop. - ! Section 1: figure out the total area, and whether there are >1 canopy layers at all. - ! - ! Sorts out cohorts into canopy and understorey layers... - ! - ! !USES: - - use EDParamsMod, only : ED_val_comp_excln - use EDTypesMod , only : min_patch_area - - ! - ! !ARGUMENTS - type(ed_site_type) , intent(inout), target :: currentSite - type(bc_in_type), intent(in) :: bc_in - - ! - ! !LOCAL VARIABLES: - type(ed_patch_type) , pointer :: currentPatch - type(ed_cohort_type), pointer :: currentCohort - integer :: i_lyr ! current layer index - integer :: z ! Current number of canopy layers. (1= canopy, 2 = understorey) - integer :: ipft - real(r8) :: arealayer(nclmax+2) ! Amount of plant area currently in each canopy layer - integer :: patch_area_counter ! count iterations used to solve canopy areas - logical :: area_not_balanced ! logical controlling if the patch layer areas - ! have successfully been redistributed - integer :: return_code ! math checks on variables will return>0 if problems exist - - ! We only iterate because of possible imprecisions generated by the cohort - ! termination process. These should be super small, so at the most - ! try to re-balance 3 times. If that doesn't give layer areas - ! within tolerance of canopy area, there is something wrong - - integer, parameter :: max_patch_iterations = 10 - - - !---------------------------------------------------------------------- - - currentPatch => currentSite%oldest_patch - ! - ! zero site-level demotion / promotion tracking info - currentSite%demotion_rate(:) = 0._r8 - currentSite%promotion_rate(:) = 0._r8 - currentSite%demotion_carbonflux = 0._r8 - currentSite%promotion_carbonflux = 0._r8 - - - ! - ! Section 1: Check total canopy area. - ! - do while (associated(currentPatch)) ! Patch loop - - ! ------------------------------------------------------------------------------ - ! Perform numerical checks on some cohort and patch structures - ! ------------------------------------------------------------------------------ - - ! canopy layer has a special bounds check - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if( currentCohort%canopy_layer < 1 .or. currentCohort%canopy_layer > nclmax+1 ) then - write(fates_log(),*) 'lat:',currentSite%lat - write(fates_log(),*) 'lon:',currentSite%lon - write(fates_log(),*) 'BOGUS CANOPY LAYER: ',currentCohort%canopy_layer - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - currentCohort => currentCohort%shorter - enddo - - - ! Does any layer have excess area in it? Keep going until it does not... - patch_area_counter = 0 - area_not_balanced = .true. - - do while(area_not_balanced) - - ! --------------------------------------------------------------------------- - ! Demotion Phase: Identify upper layers that are too full, and demote them to - ! the layers below. - ! --------------------------------------------------------------------------- - - ! Its possible that before we even enter this scheme - ! some cohort numbers are very low. Terminate them. - call terminate_cohorts(currentSite, currentPatch, 1, 12) - - ! Calculate how many layers we have in this canopy - ! This also checks the understory to see if its crown - ! area is large enough to warrant a temporary sub-understory layer - z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) - - do i_lyr = 1,z ! Loop around the currently occupied canopy layers. - call DemoteFromLayer(currentSite, currentPatch, i_lyr) - end do - - ! After demotions, we may then again have cohorts that are very very - ! very sparse, remove them - call terminate_cohorts(currentSite, currentPatch, 1,13) - - call fuse_cohorts(currentSite, currentPatch, bc_in) - - ! Remove cohorts for various other reasons - call terminate_cohorts(currentSite, currentPatch, 2,13) - - - ! --------------------------------------------------------------------------------------- - ! Promotion Phase: Identify if any upper-layers are underful and layers below them - ! have cohorts that can be split and promoted to the layer above. - ! --------------------------------------------------------------------------------------- - - ! Re-calculate Number of layers without the false substory - z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) - - ! We only promote if we have at least two layers - if (z>1) then - - do i_lyr=1,z-1 - call PromoteIntoLayer(currentSite, currentPatch, i_lyr) - end do - - ! Remove cohorts that are incredibly sparse - call terminate_cohorts(currentSite, currentPatch, 1,14) - - call fuse_cohorts(currentSite, currentPatch, bc_in) - - ! Remove cohorts for various other reasons - call terminate_cohorts(currentSite, currentPatch, 2,14) - - end if - - ! --------------------------------------------------------------------------------------- - ! Check on Layer Area (if the layer differences are not small - ! Continue trying to demote/promote. Its possible on the first pass through, - ! that cohort fusion has nudged the areas a little bit. - ! --------------------------------------------------------------------------------------- - - z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) - area_not_balanced = .false. - do i_lyr = 1,z - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer(i_lyr)) - if( ((arealayer(i_lyr)-currentPatch%area)/currentPatch%area > area_check_rel_precision) .or. & - ((arealayer(i_lyr)-currentPatch%area) > area_check_precision ) ) then - area_not_balanced = .true. - endif - enddo - - ! --------------------------------------------------------------------------------------- - ! Gracefully exit if too many iterations have gone by - ! --------------------------------------------------------------------------------------- - - patch_area_counter = patch_area_counter + 1 - if(patch_area_counter > max_patch_iterations .and. area_not_balanced) then - write(fates_log(),*) 'PATCH AREA CHECK NOT CLOSING' - write(fates_log(),*) 'patch area:',currentpatch%area - do i_lyr = 1,z - write(fates_log(),*) 'layer: ',i_lyr,' area: ',arealayer(i_lyr) - write(fates_log(),*) 'rel error: ',(arealayer(i_lyr)-currentPatch%area)/currentPatch%area - write(fates_log(),*) 'abs error: ',arealayer(i_lyr)-currentPatch%area - enddo - write(fates_log(),*) 'lat:',currentSite%lat - write(fates_log(),*) 'lon:',currentSite%lon - write(fates_log(),*) 'spread:',currentSite%spread - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - write(fates_log(),*) 'coh ilayer:',currentCohort%canopy_layer - write(fates_log(),*) 'coh dbh:',currentCohort%dbh - write(fates_log(),*) 'coh pft:',currentCohort%pft - write(fates_log(),*) 'coh n:',currentCohort%n - write(fates_log(),*) 'coh carea:',currentCohort%c_area - ipft=currentCohort%pft - write(fates_log(),*) 'maxh:',prt_params%allom_dbh_maxheight(ipft) - write(fates_log(),*) 'lmode: ',prt_params%allom_lmode(ipft) - write(fates_log(),*) 'd2bl2: ',prt_params%allom_d2bl2(ipft) - write(fates_log(),*) 'd2bl_ediff: ',prt_params%allom_blca_expnt_diff(ipft) - write(fates_log(),*) 'd2ca_min: ',prt_params%allom_d2ca_coefficient_min(ipft) - write(fates_log(),*) 'd2ca_max: ',prt_params%allom_d2ca_coefficient_max(ipft) - currentCohort => currentCohort%shorter - enddo - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - enddo ! do while(area_not_balanced) - - - ! Set current canopy layer occupancy indicator. - currentPatch%NCL_p = min(nclmax,z) - - ! ------------------------------------------------------------------------------------------- - ! if we are using "strict PPA", then calculate a z_star value as - ! the height of the smallest tree in the canopy - ! loop from top to bottom and locate the shortest cohort in level 1 whose shorter - ! neighbor is in level 2 set zstar as the ehight of that shortest level 1 cohort - ! ------------------------------------------------------------------------------------------- - - if ( ED_val_comp_excln .lt. 0.0_r8) then - currentPatch%zstar = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer .eq. 2)then - if (associated(currentCohort%taller)) then - if (currentCohort%taller%canopy_layer .eq. 1 ) then - currentPatch%zstar = currentCohort%taller%hite - endif - endif - endif - currentCohort => currentCohort%shorter - enddo - endif - - currentPatch => currentPatch%younger - enddo !patch - - return - end subroutine canopy_structure - - - ! ============================================================================================== - - - subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) - - use EDParamsMod, only : ED_val_comp_excln - use SFParamsMod, only : SF_val_CWD_frac - - ! !ARGUMENTS - type(ed_site_type), intent(inout), target :: currentSite - type(ed_patch_type), intent(inout), target :: currentPatch - integer, intent(in) :: i_lyr ! Current canopy layer of interest - - ! !LOCAL VARIABLES: - type(ed_cohort_type), pointer :: currentCohort - type(ed_cohort_type), pointer :: copyc - type(ed_cohort_type), pointer :: nextc ! The next cohort in line - integer :: i_cwd ! Index for CWD pool - real(r8) :: cc_loss ! cohort crown area loss in demotion (m2) - real(r8) :: leaf_c ! leaf carbon [kg] - real(r8) :: fnrt_c ! fineroot carbon [kg] - real(r8) :: sapw_c ! sapwood carbon [kg] - real(r8) :: store_c ! storage carbon [kg] - real(r8) :: struct_c ! structure carbon [kg] - real(r8) :: scale_factor ! for prob. exclusion - scales weight to a fraction - real(r8) :: scale_factor_min ! "" minimum before exeedance of 1 - real(r8) :: scale_factor_res ! "" applied to residual areas - real(r8) :: area_res ! residual area to demote after weakest cohort hits max - real(r8) :: newarea - real(r8) :: demote_area - real(r8) :: sumweights - real(r8) :: sumequal ! for rank-ordered same-size cohorts - ! this tallies their excluded area - real(r8) :: arealayer ! the area of the current canopy layer - logical :: tied_size_with_neighbors - real(r8) :: total_crownarea_of_tied_cohorts - - ! First, determine how much total canopy area we have in this layer - - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer) - - demote_area = arealayer - currentPatch%area - - if ( demote_area > area_target_precision ) then - - ! Is this layer currently over-occupied? - ! In that case, we need to work out which cohorts to demote. - ! We go in order from shortest to tallest for ranked demotion - - sumweights = 0.0_r8 - currentCohort => currentPatch%shortest - do while (associated(currentCohort)) - - call carea_allom(currentCohort%dbh,currentCohort%n, & - currentSite%spread,currentCohort%pft,currentCohort%c_area) - - if(debug) then - if(currentCohort%c_area<0._r8)then - write(fates_log(),*) 'negative c_area stage 1d: ',currentCohort%dbh,i_lyr,currentCohort%n, & - currentSite%spread,currentCohort%pft,currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if( currentCohort%canopy_layer == i_lyr)then - - if (ED_val_comp_excln .ge. 0.0_r8 ) then - - ! ---------------------------------------------------------- - ! Stochastic method. - ! Weight cohort demotion by inverse size to a constant power. - ! In this hypothesis, it is assumed that even the tallest - ! cohorts have a chance (although smaller) of being forced - ! to the understory. - ! ---------------------------------------------------------- - - currentCohort%excl_weight = 1._r8 / (currentCohort%hite**ED_val_comp_excln) - sumweights = sumweights + currentCohort%excl_weight - - else - - ! ----------------------------------------------------------- - ! Rank ordered deterministic method - ! ----------------------------------------------------------- - ! If there are cohorts that have the exact same height (which is possible, really) - ! we don't want to unilaterally promote/demote one before the others. - ! So we <>mote them as a unit - ! now we need to go through and figure out how many equal-size cohorts there are. - ! then we need to go through, add up the collective crown areas of all equal-sized - ! and equal-canopy-layer cohorts, - ! and then demote from each as if they were a single group - - total_crownarea_of_tied_cohorts = currentCohort%c_area - - tied_size_with_neighbors = .false. - nextc => currentCohort%taller - do while (associated(nextc)) - if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then - if( nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - tied_size_with_neighbors = .true. - total_crownarea_of_tied_cohorts = & - total_crownarea_of_tied_cohorts + nextc%c_area - end if - else - exit - endif - nextc => nextc%taller - end do - - if ( tied_size_with_neighbors ) then - - currentCohort%excl_weight = & - max(0.0_r8,min(currentCohort%c_area, & - (currentCohort%c_area/total_crownarea_of_tied_cohorts) * & - (demote_area - sumweights) )) - - sumequal = currentCohort%excl_weight - - nextc => currentCohort%taller - do while (associated(nextc)) - if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then - if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - ! now we know the total crown area of all equal-sized, - ! equal-canopy-layer cohorts - nextc%excl_weight = & - max(0.0_r8,min(nextc%c_area, & - (nextc%c_area/total_crownarea_of_tied_cohorts) * & - (demote_area - sumweights) )) - sumequal = sumequal + nextc%excl_weight - end if - else - exit - endif - nextc => nextc%taller - end do - - ! Update the current cohort pointer to the last similar cohort - ! Its ok if this is not in the right layer - if(associated(nextc))then - currentCohort => nextc%shorter - else - currentCohort => currentPatch%tallest - end if - sumweights = sumweights + sumequal - - else - currentCohort%excl_weight = & - max(min(currentCohort%c_area, demote_area - sumweights ), 0._r8) - sumweights = sumweights + currentCohort%excl_weight - end if - - endif - endif - currentCohort => currentCohort%taller - enddo - - ! If this is probabalistic demotion, we need to do a round of normalization. - ! And then a few rounds where we pre-calculate the demotion areas - ! and adjust things if the demoted area wants to be greater than - ! what is available. The math is too hard to explain here, see - ! the tech note section on promotion/demotion. - - if (ED_val_comp_excln .ge. 0.0_r8 ) then - - scale_factor_min = 1.e10_r8 - scale_factor = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - - if(currentCohort%canopy_layer == i_lyr) then - - currentCohort%excl_weight = currentCohort%excl_weight/sumweights - if( 1._r8/currentCohort%excl_weight < scale_factor_min ) & - scale_factor_min = 1._r8/currentCohort%excl_weight - - scale_factor = scale_factor + currentCohort%excl_weight * currentCohort%c_area - - endif - currentCohort => currentCohort%shorter - enddo - - ! This is the factor by which we need to multiply - ! the demotion probabilities, so the sum result equals - ! the total amount to demote - - scale_factor = demote_area/scale_factor - - if(scale_factor <= scale_factor_min) then - - ! Trivial case, all of the demotion fractions are less than 1. - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then - currentCohort%excl_weight = currentCohort%c_area * currentCohort%excl_weight * scale_factor - - if(debug) then - if((currentCohort%excl_weight > (currentCohort%c_area+area_target_precision)) .or. & - (currentCohort%excl_weight < 0._r8) ) then - write(fates_log(),*) 'exclusion area too big (1)' - write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area - write(fates_log(),*) 'dbh: ',currentCohort%dbh - write(fates_log(),*) 'n: ',currentCohort%n - write(fates_log(),*) 'spread: ',currentSite%spread - write(fates_log(),*) 'pft: ',currentCohort%pft - write(fates_log(),*) 'currentCohort%excl_weight: ',currentCohort%excl_weight - write(fates_log(),*) 'excess: ',currentCohort%excl_weight - currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - endif - currentCohort => currentCohort%shorter - enddo - - else - - - ! Non-trivial case, at least 1 cohort's demotion - ! rate would exceed its area, given the trivial scale factor - - area_res = 0._r8 - scale_factor_res = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then - area_res = area_res + & - currentCohort%c_area * currentCohort%excl_weight * & - scale_factor_min - scale_factor_res = scale_factor_res + & - currentCohort%c_area * & - (1._r8 - (currentCohort%excl_weight * scale_factor_min)) - endif - currentCohort => currentCohort%shorter - enddo - - area_res = demote_area - area_res - - scale_factor_res = area_res / scale_factor_res - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then - - currentCohort%excl_weight = currentCohort%c_area * & - (currentCohort%excl_weight * scale_factor_min + & - (1._r8 - (currentCohort%excl_weight*scale_factor_min) ) * scale_factor_res) - - if(debug)then - if((currentCohort%excl_weight > & - (currentCohort%c_area+area_target_precision)) .or. & - (currentCohort%excl_weight < 0._r8) ) then - write(fates_log(),*) 'exclusion area error (2)' + subroutine canopy_structure( currentSite , bc_in ) + ! + ! !DESCRIPTION: + ! create cohort instance + ! + ! This routine allocates the 'canopy_layer' attribute to each cohort + ! All top leaves in the same canopy layer get the same light resources. + ! The first canopy layer is the 'canopy' or 'overstorey'. The second is the 'understorey'. + ! More than two layers is not permitted at the moment + ! Seeds germinating into the 3rd or higher layers are automatically removed. + ! + ! ------Perfect Plasticity----- + ! The idea of these canopy layers derives originally from Purves et al. 2009 + ! Their concept is that, given enoughplasticity in canopy position, size, shape and depth + ! all of the gound area will be filled perfectly by leaves, and additional leaves will have + ! to exist in the understorey. + ! Purves et al. use the concept of 'Z*' to assume that the height required to attain a place in the + ! canopy is spatially uniform. In this implementation, described in Fisher et al. (2010, New Phyt) we + ! extent that concept to assume that position in the canopy has some random element, and that BOTH height + ! and chance combine to determine whether trees get into the canopy. + ! Thus, when the canopy is closed and there is excess area, some of it must be demoted + ! If we demote -all- the trees less than a given height, there is a massive advantage in being the cohort that is + ! the biggest when the canopy is closed. + ! In this implementation, the amount demoted, ('weight') is a function of the height weighted by the competitive exclusion + ! parameter (ED_val_comp_excln). + + ! Complexity in this routine results from a few things. + ! Firstly, the complication of the demotion amount sometimes being larger than the cohort area (for a very small, short cohort) + ! Second, occasionaly, disturbance (specifically fire) can cause the canopy layer to become less than closed, + ! without changing the area of the patch. If this happens, then some of the plants in the lower layer need to be 'promoted' so + ! all of the routine has to happen in both the downwards and upwards directions. + ! + ! The order of events here is therefore: + ! (The entire subroutine has a single outer 'patch' loop. + ! Section 1: figure out the total area, and whether there are >1 canopy layers at all. + ! + ! Sorts out cohorts into canopy and understorey layers... + ! + ! !USES: + + use EDParamsMod, only : ED_val_comp_excln + use EDTypesMod , only : min_patch_area + + ! + ! !ARGUMENTS + type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type), intent(in) :: bc_in + + ! + ! !LOCAL VARIABLES: + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + integer :: i_lyr ! current layer index + integer :: z ! Current number of canopy layers. (1= canopy, 2 = understorey) + integer :: ipft + real(r8) :: arealayer(nclmax+2) ! Amount of plant area currently in each canopy layer + integer :: patch_area_counter ! count iterations used to solve canopy areas + logical :: area_not_balanced ! logical controlling if the patch layer areas + ! have successfully been redistributed + integer :: return_code ! math checks on variables will return>0 if problems exist + + ! We only iterate because of possible imprecisions generated by the cohort + ! termination process. These should be super small, so at the most + ! try to re-balance 3 times. If that doesn't give layer areas + ! within tolerance of canopy area, there is something wrong + + integer, parameter :: max_patch_iterations = 10 + + + !---------------------------------------------------------------------- + currentPatch => currentSite%oldest_patch + ! + ! zero site-level demotion / promotion tracking info + currentSite%demotion_rate(:) = 0._r8 + currentSite%promotion_rate(:) = 0._r8 + currentSite%demotion_carbonflux = 0._r8 + currentSite%promotion_carbonflux = 0._r8 + + + ! + ! Section 1: Check total canopy area. + ! + do while (associated(currentPatch)) ! Patch loop + + ! ------------------------------------------------------------------------------ + ! Perform numerical checks on some cohort and patch structures + ! ------------------------------------------------------------------------------ + + ! canopy layer has a special bounds check + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if( currentCohort%canopy_layer < 1 .or. currentCohort%canopy_layer > nclmax+1 ) then + write(fates_log(),*) 'lat:',currentSite%lat + write(fates_log(),*) 'lon:',currentSite%lon + write(fates_log(),*) 'BOGUS CANOPY LAYER: ',currentCohort%canopy_layer + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + currentCohort => currentCohort%shorter + enddo + + + ! Does any layer have excess area in it? Keep going until it does not... + patch_area_counter = 0 + area_not_balanced = .true. + + do while(area_not_balanced) + + ! --------------------------------------------------------------------------- + ! Demotion Phase: Identify upper layers that are too full, and demote them to + ! the layers below. + ! --------------------------------------------------------------------------- + + ! Its possible that before we even enter this scheme + ! some cohort numbers are very low. Terminate them. + call terminate_cohorts(currentSite, currentPatch, 1, 12, bc_in) + + ! Calculate how many layers we have in this canopy + ! This also checks the understory to see if its crown + ! area is large enough to warrant a temporary sub-understory layer + z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) + + do i_lyr = 1,z ! Loop around the currently occupied canopy layers. + call DemoteFromLayer(currentSite, currentPatch, i_lyr, bc_in) + end do + + ! After demotions, we may then again have cohorts that are very very + ! very sparse, remove them + call terminate_cohorts(currentSite, currentPatch, 1,13,bc_in) + + call fuse_cohorts(currentSite, currentPatch, bc_in) + + ! Remove cohorts for various other reasons + call terminate_cohorts(currentSite, currentPatch, 2,13,bc_in) + + + ! --------------------------------------------------------------------------------------- + ! Promotion Phase: Identify if any upper-layers are underful and layers below them + ! have cohorts that can be split and promoted to the layer above. + ! --------------------------------------------------------------------------------------- + + ! Re-calculate Number of layers without the false substory + z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) + + ! We only promote if we have at least two layers + if (z>1) then + + do i_lyr=1,z-1 + call PromoteIntoLayer(currentSite, currentPatch, i_lyr) + end do + + ! Remove cohorts that are incredibly sparse + call terminate_cohorts(currentSite, currentPatch, 1,14,bc_in) + + call fuse_cohorts(currentSite, currentPatch, bc_in) + + ! Remove cohorts for various other reasons + call terminate_cohorts(currentSite, currentPatch, 2,14,bc_in) + + end if + + ! --------------------------------------------------------------------------------------- + ! Check on Layer Area (if the layer differences are not small + ! Continue trying to demote/promote. Its possible on the first pass through, + ! that cohort fusion has nudged the areas a little bit. + ! --------------------------------------------------------------------------------------- + + z = NumPotentialCanopyLayers(currentPatch,currentSite%spread,include_substory=.false.) + area_not_balanced = .false. + do i_lyr = 1,z + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer(i_lyr)) + if( ((arealayer(i_lyr)-currentPatch%area)/currentPatch%area > area_check_rel_precision) .or. & + ((arealayer(i_lyr)-currentPatch%area) > area_check_precision ) ) then + area_not_balanced = .true. + endif + enddo + + ! --------------------------------------------------------------------------------------- + ! Gracefully exit if too many iterations have gone by + ! --------------------------------------------------------------------------------------- + + patch_area_counter = patch_area_counter + 1 + if(patch_area_counter > max_patch_iterations .and. area_not_balanced) then + write(fates_log(),*) 'PATCH AREA CHECK NOT CLOSING' + write(fates_log(),*) 'patch area:',currentpatch%area + do i_lyr = 1,z + write(fates_log(),*) 'layer: ',i_lyr,' area: ',arealayer(i_lyr) + write(fates_log(),*) 'rel error: ',(arealayer(i_lyr)-currentPatch%area)/currentPatch%area + write(fates_log(),*) 'abs error: ',arealayer(i_lyr)-currentPatch%area + enddo + write(fates_log(),*) 'lat:',currentSite%lat + write(fates_log(),*) 'lon:',currentSite%lon + write(fates_log(),*) 'spread:',currentSite%spread + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + write(fates_log(),*) 'coh ilayer:',currentCohort%canopy_layer + write(fates_log(),*) 'coh dbh:',currentCohort%dbh + write(fates_log(),*) 'coh pft:',currentCohort%pft + write(fates_log(),*) 'coh n:',currentCohort%n + write(fates_log(),*) 'coh carea:',currentCohort%c_area + ipft=currentCohort%pft + write(fates_log(),*) 'maxh:',prt_params%allom_dbh_maxheight(ipft) + write(fates_log(),*) 'lmode: ',prt_params%allom_lmode(ipft) + write(fates_log(),*) 'd2bl2: ',prt_params%allom_d2bl2(ipft) + write(fates_log(),*) 'd2bl_ediff: ',prt_params%allom_blca_expnt_diff(ipft) + write(fates_log(),*) 'd2ca_min: ',prt_params%allom_d2ca_coefficient_min(ipft) + write(fates_log(),*) 'd2ca_max: ',prt_params%allom_d2ca_coefficient_max(ipft) + currentCohort => currentCohort%shorter + enddo + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + enddo ! do while(area_not_balanced) + + + ! Set current canopy layer occupancy indicator. + currentPatch%NCL_p = min(nclmax,z) + + ! ------------------------------------------------------------------------------------------- + ! if we are using "strict PPA", then calculate a z_star value as + ! the height of the smallest tree in the canopy + ! loop from top to bottom and locate the shortest cohort in level 1 whose shorter + ! neighbor is in level 2 set zstar as the ehight of that shortest level 1 cohort + ! ------------------------------------------------------------------------------------------- + + if ( ED_val_comp_excln .lt. 0.0_r8) then + currentPatch%zstar = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer .eq. 2)then + if (associated(currentCohort%taller)) then + if (currentCohort%taller%canopy_layer .eq. 1 ) then + currentPatch%zstar = currentCohort%taller%hite + endif + endif + endif + currentCohort => currentCohort%shorter + enddo + endif + + currentPatch => currentPatch%younger + enddo !patch + + return + end subroutine canopy_structure + + + ! ============================================================================================== + + + subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr,bc_in) + + use EDParamsMod, only : ED_val_comp_excln + use SFParamsMod, only : SF_val_CWD_frac + + ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite + type(ed_patch_type), intent(inout), target :: currentPatch + integer, intent(in) :: i_lyr ! Current canopy layer of interest + type(bc_in_type), intent(in) :: bc_in + + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer :: currentCohort + type(ed_cohort_type), pointer :: copyc + type(ed_cohort_type), pointer :: nextc ! The next cohort in line + integer :: i_cwd ! Index for CWD pool + real(r8) :: cc_loss ! cohort crown area loss in demotion (m2) + real(r8) :: leaf_c ! leaf carbon [kg] + real(r8) :: fnrt_c ! fineroot carbon [kg] + real(r8) :: sapw_c ! sapwood carbon [kg] + real(r8) :: store_c ! storage carbon [kg] + real(r8) :: struct_c ! structure carbon [kg] + real(r8) :: scale_factor ! for prob. exclusion - scales weight to a fraction + real(r8) :: scale_factor_min ! "" minimum before exeedance of 1 + real(r8) :: scale_factor_res ! "" applied to residual areas + real(r8) :: area_res ! residual area to demote after weakest cohort hits max + real(r8) :: newarea + real(r8) :: demote_area + real(r8) :: sumweights + real(r8) :: sumequal ! for rank-ordered same-size cohorts + ! this tallies their excluded area + real(r8) :: arealayer ! the area of the current canopy layer + logical :: tied_size_with_neighbors + real(r8) :: total_crownarea_of_tied_cohorts + + ! First, determine how much total canopy area we have in this layer + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer) + + demote_area = arealayer - currentPatch%area + + if ( demote_area > area_target_precision ) then + + ! Is this layer currently over-occupied? + ! In that case, we need to work out which cohorts to demote. + ! We go in order from shortest to tallest for ranked demotion + + sumweights = 0.0_r8 + currentCohort => currentPatch%shortest + do while (associated(currentCohort)) + call carea_allom(currentCohort%dbh,currentCohort%n, & + currentSite%spread,currentCohort%pft,currentCohort%c_area) + + if(debug) then + if(currentCohort%c_area<0._r8)then + write(fates_log(),*) 'negative c_area stage 1d: ',currentCohort%dbh,i_lyr,currentCohort%n, & + currentSite%spread,currentCohort%pft,currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + if( currentCohort%canopy_layer == i_lyr)then + + if (ED_val_comp_excln .ge. 0.0_r8 ) then + + ! ---------------------------------------------------------- + ! Stochastic method. + ! Weight cohort demotion by inverse size to a constant power. + ! In this hypothesis, it is assumed that even the tallest + ! cohorts have a chance (although smaller) of being forced + ! to the understory. + ! ---------------------------------------------------------- + + currentCohort%excl_weight = 1._r8 / (currentCohort%hite**ED_val_comp_excln) + sumweights = sumweights + currentCohort%excl_weight + + else + + ! ----------------------------------------------------------- + ! Rank ordered deterministic method + ! ----------------------------------------------------------- + ! If there are cohorts that have the exact same height (which is possible, really) + ! we don't want to unilaterally promote/demote one before the others. + ! So we <>mote them as a unit + ! now we need to go through and figure out how many equal-size cohorts there are. + ! then we need to go through, add up the collective crown areas of all equal-sized + ! and equal-canopy-layer cohorts, + ! and then demote from each as if they were a single group + + total_crownarea_of_tied_cohorts = currentCohort%c_area + + tied_size_with_neighbors = .false. + nextc => currentCohort%taller + do while (associated(nextc)) + if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then + if( nextc%canopy_layer .eq. currentCohort%canopy_layer ) then + tied_size_with_neighbors = .true. + total_crownarea_of_tied_cohorts = & + total_crownarea_of_tied_cohorts + nextc%c_area + end if + else + exit + endif + nextc => nextc%taller + end do + + if ( tied_size_with_neighbors ) then + + currentCohort%excl_weight = & + max(0.0_r8,min(currentCohort%c_area, & + (currentCohort%c_area/total_crownarea_of_tied_cohorts) * & + (demote_area - sumweights) )) + + sumequal = currentCohort%excl_weight + + nextc => currentCohort%taller + do while (associated(nextc)) + if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then + if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then + ! now we know the total crown area of all equal-sized, + ! equal-canopy-layer cohorts + nextc%excl_weight = & + max(0.0_r8,min(nextc%c_area, & + (nextc%c_area/total_crownarea_of_tied_cohorts) * & + (demote_area - sumweights) )) + sumequal = sumequal + nextc%excl_weight + end if + else + exit + endif + nextc => nextc%taller + end do + + ! Update the current cohort pointer to the last similar cohort + ! Its ok if this is not in the right layer + if(associated(nextc))then + currentCohort => nextc%shorter + else + currentCohort => currentPatch%tallest + end if + sumweights = sumweights + sumequal + + else + currentCohort%excl_weight = & + max(min(currentCohort%c_area, demote_area - sumweights ), 0._r8) + sumweights = sumweights + currentCohort%excl_weight + end if + + endif + endif + currentCohort => currentCohort%taller + enddo + + ! If this is probabalistic demotion, we need to do a round of normalization. + ! And then a few rounds where we pre-calculate the demotion areas + ! and adjust things if the demoted area wants to be greater than + ! what is available. The math is too hard to explain here, see + ! the tech note section on promotion/demotion. + + if (ED_val_comp_excln .ge. 0.0_r8 ) then + + scale_factor_min = 1.e10_r8 + scale_factor = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + + if(currentCohort%canopy_layer == i_lyr) then + + currentCohort%excl_weight = currentCohort%excl_weight/sumweights + if( 1._r8/currentCohort%excl_weight < scale_factor_min ) & + scale_factor_min = 1._r8/currentCohort%excl_weight + + scale_factor = scale_factor + currentCohort%excl_weight * currentCohort%c_area + + endif + currentCohort => currentCohort%shorter + enddo + + ! This is the factor by which we need to multiply + ! the demotion probabilities, so the sum result equals + ! the total amount to demote + + scale_factor = demote_area/scale_factor + + if(scale_factor <= scale_factor_min) then + + ! Trivial case, all of the demotion fractions are less than 1. + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then + currentCohort%excl_weight = currentCohort%c_area * currentCohort%excl_weight * scale_factor + + if(debug) then + if((currentCohort%excl_weight > (currentCohort%c_area+area_target_precision)) .or. & + (currentCohort%excl_weight < 0._r8) ) then + write(fates_log(),*) 'exclusion area too big (1)' + write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area + write(fates_log(),*) 'dbh: ',currentCohort%dbh + write(fates_log(),*) 'n: ',currentCohort%n + write(fates_log(),*) 'spread: ',currentSite%spread + write(fates_log(),*) 'pft: ',currentCohort%pft + write(fates_log(),*) 'currentCohort%excl_weight: ',currentCohort%excl_weight + write(fates_log(),*) 'excess: ',currentCohort%excl_weight - currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + endif + currentCohort => currentCohort%shorter + enddo + + else + + + ! Non-trivial case, at least 1 cohort's demotion + ! rate would exceed its area, given the trivial scale factor + + area_res = 0._r8 + scale_factor_res = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then + area_res = area_res + & + currentCohort%c_area * currentCohort%excl_weight * & + scale_factor_min + scale_factor_res = scale_factor_res + & + currentCohort%c_area * & + (1._r8 - (currentCohort%excl_weight * scale_factor_min)) + endif + currentCohort => currentCohort%shorter + enddo + + area_res = demote_area - area_res + + scale_factor_res = area_res / scale_factor_res + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then + + currentCohort%excl_weight = currentCohort%c_area * & + (currentCohort%excl_weight * scale_factor_min + & + (1._r8 - (currentCohort%excl_weight*scale_factor_min) ) * scale_factor_res) + + if(debug)then + if((currentCohort%excl_weight > & + (currentCohort%c_area+area_target_precision)) .or. & + (currentCohort%excl_weight < 0._r8) ) then + write(fates_log(),*) 'exclusion area error (2)' + write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area + write(fates_log(),*) 'currentCohort%excl_weight: ', & + currentCohort%excl_weight + write(fates_log(),*) 'excess: ', & + currentCohort%excl_weight - currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + endif + currentCohort => currentCohort%shorter + enddo + + end if + + end if + + + ! perform a check and see if the demotions meet the demand + sumweights = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == i_lyr) then + sumweights = sumweights + currentCohort%excl_weight + end if + currentCohort => currentCohort%shorter + end do + + if (abs(sumweights - demote_area) > area_check_precision ) then + write(fates_log(),*) 'demotions dont add up' + write(fates_log(),*) 'sum demotions: ',sumweights + write(fates_log(),*) 'area needed to be demoted: ',demote_area + write(fates_log(),*) 'excess: ',sumweights - demote_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + ! Weights have been calculated. Now move them to the lower layer + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + + nextc => currentCohort%shorter + + if(currentCohort%canopy_layer == i_lyr )then + + cc_loss = currentCohort%excl_weight + leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) + sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) + struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) + + if ( (cc_loss-currentCohort%c_area) > -nearzero .and. & + (cc_loss-currentCohort%c_area) < area_target_precision ) then + + ! If the whole cohort is being demoted, just change its + ! layer index + + currentCohort%canopy_layer = i_lyr+1 + + ! keep track of number and biomass of demoted cohort + currentSite%demotion_rate(currentCohort%size_class) = & + currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & + (leaf_c + store_c + fnrt_c + sapw_c + struct_c) * currentCohort%n + + elseif( (cc_loss < currentCohort%c_area) .and. & + (cc_loss > area_target_precision) ) then + + ! If only part of the cohort is demoted + ! then it must be split (little more complicated) + + ! Make a copy of the current cohort. The copy and the original + ! conserve total number density of the original. The copy + ! remains in the upper-story. The original is the one + ! demoted to the understory + + + allocate(copyc) + + ! Initialize the PARTEH object and point to the + ! correct boundary condition fields + copyc%prt => null() + call InitPRTObject(copyc%prt) + call InitPRTBoundaryConditions(copyc) + + if( hlm_use_planthydro.eq.itrue ) then + call InitHydrCohort(currentSite,copyc) + endif + + ! (keep as an example) + ! Initialize running means + !allocate(copyc%tveg_lpa) + !call copyc%tveg_lpa%InitRMean(ema_lpa, & + ! init_value=currentPatch%tveg_lpa%GetMean()) + + call copy_cohort(currentCohort, copyc) + + newarea = currentCohort%c_area - cc_loss + copyc%n = currentCohort%n*newarea/currentCohort%c_area + currentCohort%n = currentCohort%n - copyc%n + + copyc%canopy_layer = i_lyr !the taller cohort is the copy + + ! Demote the current cohort to the understory. + currentCohort%canopy_layer = i_lyr + 1 + + ! keep track of number and biomass of demoted cohort + currentSite%demotion_rate(currentCohort%size_class) = & + currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & + (leaf_c + store_c + fnrt_c + sapw_c + struct_c) * currentCohort%n + + call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + currentCohort%pft,currentCohort%c_area) + + !----------- Insert copy into linked list ------------------------! + copyc%shorter => currentCohort + if(associated(currentCohort%taller))then + copyc%taller => currentCohort%taller + currentCohort%taller%shorter => copyc + else + currentPatch%tallest => copyc + copyc%taller => null() + endif + currentCohort%taller => copyc + + elseif(cc_loss > currentCohort%c_area)then + + write(fates_log(),*) 'more area than the cohort has is being demoted' + write(fates_log(),*) 'loss:',cc_loss + write(fates_log(),*) 'existing area:',currentCohort%c_area + write(fates_log(),*) 'excess: ',cc_loss - currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end if + + ! kill the ones which go into canopy layers that are not allowed + if(currentCohort%canopy_layer>nclmax )then + ! put the litter from the terminated cohorts + ! straight into the fragmenting pools + call terminate_cohort(currentSite,currentPatch,currentCohort,bc_in) + deallocate(currentCohort) + else + call carea_allom(currentCohort%dbh,currentCohort%n, & + currentSite%spread,currentCohort%pft,currentCohort%c_area) + end if + + endif !canopy layer = i_ly + + ! We dont use our typical (point to smaller) + ! here, because, we may had deallocated the existing + ! currentCohort + + currentCohort => nextc + enddo !currentCohort + + + ! Update the area calculations of the current layer + ! And the layer below that may or may not had recieved + ! Demotions + + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer) + + if ( (abs(arealayer - currentPatch%area)/arealayer > area_check_rel_precision ) .or. & + (abs(arealayer - currentPatch%area) > area_check_precision) ) then + write(fates_log(),*) 'demotion did not trim area within tolerance' + write(fates_log(),*) 'arealayer:',arealayer + write(fates_log(),*) 'patch%area:',currentPatch%area + write(fates_log(),*) 'ilayer: ',i_lyr + write(fates_log(),*) 'bias:',arealayer - currentPatch%area + write(fates_log(),*) 'rel bias:',(arealayer - currentPatch%area)/arealayer + write(fates_log(),*) 'demote_area:',demote_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + end if + + return + end subroutine DemoteFromLayer + + ! ============================================================================================== + + subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) + + ! ------------------------------------------------------------------------------------------- + ! Check whether the intended 'full' layers are actually filling all the space. + ! If not, promote some fraction of cohorts upwards. + ! THIS SECTION MIGHT BE TRIGGERED BY A FIRE OR MORTALITY EVENT, FOLLOWED BY A PATCH FUSION, + ! SO THE TOP LAYER IS NO LONGER FULL. + ! ------------------------------------------------------------------------------------------- + + use EDParamsMod, only : ED_val_comp_excln + + ! !ARGUMENTS + type(ed_site_type), intent(inout), target :: currentSite + type(ed_patch_type), intent(inout), target :: currentPatch + integer, intent(in) :: i_lyr ! Current canopy layer of interest + + ! !LOCAL VARIABLES: + type(ed_cohort_type), pointer :: currentCohort + type(ed_cohort_type), pointer :: copyc + type(ed_cohort_type), pointer :: nextc ! the next cohort, or used for looping + ! cohorts against the current + + real(r8) :: scale_factor ! for prob. exclusion - scales weight to a fraction + real(r8) :: scale_factor_min ! "" minimum before exeedance of 1 + real(r8) :: scale_factor_res ! "" applied to residual areas + real(r8) :: area_res ! residual area to demote after weakest cohort hits max + real(r8) :: promote_area + real(r8) :: newarea + real(r8) :: sumweights + real(r8) :: sumequal ! for tied cohorts, the sum of weights in + ! their group + real(r8) :: cc_gain ! cohort crown area gain in promotion (m2) + real(r8) :: arealayer_current ! area (m2) of the current canopy layer + real(r8) :: arealayer_below ! area (m2) of the layer below the current layer + real(r8) :: leaf_c ! leaf carbon [kg] + real(r8) :: fnrt_c ! fineroot carbon [kg] + real(r8) :: sapw_c ! sapwood carbon [kg] + real(r8) :: store_c ! storage carbon [kg] + real(r8) :: struct_c ! structure carbon [kg] + + logical :: tied_size_with_neighbors + real(r8) :: total_crownarea_of_tied_cohorts + + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr+1,arealayer_below) + + + ! how much do we need to gain? + promote_area = currentPatch%area - arealayer_current + + if( promote_area > area_target_precision ) then + + if(arealayer_below <= promote_area ) then + + ! --------------------------------------------------------------------------- + ! Promote all cohorts from layer below if that whole layer has area smaller + ! than the tolerance on the gains needed into current layer + ! --------------------------------------------------------------------------- + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + !look at the cohorts in the canopy layer below... + if(currentCohort%canopy_layer == i_lyr+1)then + + leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) + sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) + struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) + + currentCohort%canopy_layer = i_lyr + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + currentCohort%pft,currentCohort%c_area) + ! keep track of number and biomass of promoted cohort + currentSite%promotion_rate(currentCohort%size_class) = & + currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & + (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n + + endif + currentCohort => currentCohort%shorter + enddo + + else + + ! --------------------------------------------------------------------------- + ! This is the non-trivial case where the lower layer can accomodate + ! more than what is necessary. + ! --------------------------------------------------------------------------- + + + ! figure out with what weighting we need to promote cohorts. + ! This is the opposite of the demotion weighting... + + sumweights = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + currentCohort%pft,currentCohort%c_area) + if(currentCohort%canopy_layer == i_lyr+1)then !look at the cohorts in the canopy layer below... + + if (ED_val_comp_excln .ge. 0.0_r8 ) then + + ! ------------------------------------------------------------------ + ! Stochastic case, as above (in demotion portion of code) + ! ------------------------------------------------------------------ + + currentCohort%prom_weight = currentCohort%hite**ED_val_comp_excln + sumweights = sumweights + currentCohort%prom_weight + else + + ! ------------------------------------------------------------------ + ! Rank ordered deterministic method + ! If there are cohorts that have the exact same height (which is possible, really) + ! we don't want to unilaterally promote/demote one before the others. + ! So we <>mote them as a unit + ! now we need to go through and figure out how many equal-size cohorts there are. + ! then we need to go through, add up the collective crown areas of all equal-sized + ! and equal-canopy-layer cohorts, + ! and then demote from each as if they were a single group + ! ------------------------------------------------------------------ + + total_crownarea_of_tied_cohorts = currentCohort%c_area + tied_size_with_neighbors = .false. + nextc => currentCohort%shorter + do while (associated(nextc)) + if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then + if( nextc%canopy_layer .eq. currentCohort%canopy_layer ) then + tied_size_with_neighbors = .true. + total_crownarea_of_tied_cohorts = & + total_crownarea_of_tied_cohorts + nextc%c_area + end if + else + exit + endif + nextc => nextc%shorter + end do + + if ( tied_size_with_neighbors ) then + + currentCohort%prom_weight = & + max(0.0_r8,min(currentCohort%c_area, & + (currentCohort%c_area/total_crownarea_of_tied_cohorts) * & + (promote_area - sumweights) )) + sumequal = currentCohort%prom_weight + + nextc => currentCohort%shorter + do while (associated(nextc)) + if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then + if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then + ! now we know the total crown area of all equal-sized, + ! equal-canopy-layer cohorts + nextc%prom_weight = & + max(0.0_r8,min(nextc%c_area, & + (nextc%c_area/total_crownarea_of_tied_cohorts) * & + (promote_area - sumweights) )) + sumequal = sumequal + nextc%prom_weight + end if + else + exit + endif + nextc => nextc%shorter + end do + + ! Update the current cohort pointer to the last similar cohort + ! Its ok if this is not in the right layer + if(associated(nextc))then + currentCohort => nextc%taller + else + currentCohort => currentPatch%shortest + end if + sumweights = sumweights + sumequal + + else + currentCohort%prom_weight = & + max(min(currentCohort%c_area, promote_area - sumweights ), 0._r8) + sumweights = sumweights + currentCohort%prom_weight + + end if + + endif + endif + currentCohort => currentCohort%shorter + enddo !currentCohort + + + ! If this is probabalistic promotion, we need to do a round of normalization. + ! And then a few rounds where we pre-calculate the promotion areas + ! and adjust things if the promoted area wants to be greater than + ! what is available. + + if (ED_val_comp_excln .ge. 0.0_r8 ) then + + scale_factor_min = 1.e10_r8 + scale_factor = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + + if(currentCohort%canopy_layer == (i_lyr+1) ) then + + currentCohort%prom_weight = currentCohort%prom_weight/sumweights + if( 1._r8/currentCohort%prom_weight < scale_factor_min ) & + scale_factor_min = 1._r8/currentCohort%prom_weight + + scale_factor = scale_factor + currentCohort%prom_weight * currentCohort%c_area + + endif + currentCohort => currentCohort%shorter + enddo + + ! This is the factor by which we need to multiply + ! the demotion probabilities, so the sum result equals + ! the total amount to demote + scale_factor = promote_area/scale_factor + + + if(scale_factor <= scale_factor_min) then + + ! Trivial case, all of the demotion fractions + ! are less than 1. + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1) ) then + currentCohort%prom_weight = currentCohort%c_area * & + currentCohort%prom_weight * scale_factor + + if(debug)then + if((currentCohort%prom_weight > & + (currentCohort%c_area+area_target_precision)) .or. & + (currentCohort%prom_weight < 0._r8) ) then + write(fates_log(),*) 'promotion area too big (1)' write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area - write(fates_log(),*) 'currentCohort%excl_weight: ', & - currentCohort%excl_weight + write(fates_log(),*) 'currentCohort%prom_weight: ', & + currentCohort%prom_weight write(fates_log(),*) 'excess: ', & - currentCohort%excl_weight - currentCohort%c_area + currentCohort%prom_weight - currentCohort%c_area call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - endif - currentCohort => currentCohort%shorter - enddo - - end if - - end if - - - ! perform a check and see if the demotions meet the demand - sumweights = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == i_lyr) then - sumweights = sumweights + currentCohort%excl_weight - end if - currentCohort => currentCohort%shorter - end do - - if (abs(sumweights - demote_area) > area_check_precision ) then - write(fates_log(),*) 'demotions dont add up' - write(fates_log(),*) 'sum demotions: ',sumweights - write(fates_log(),*) 'area needed to be demoted: ',demote_area - write(fates_log(),*) 'excess: ',sumweights - demote_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - ! Weights have been calculated. Now move them to the lower layer - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - - if(currentCohort%canopy_layer == i_lyr )then - - cc_loss = currentCohort%excl_weight - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) - fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) - sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) - struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) - - if ( (cc_loss-currentCohort%c_area) > -nearzero .and. & - (cc_loss-currentCohort%c_area) < area_target_precision ) then - - ! If the whole cohort is being demoted, just change its - ! layer index - - currentCohort%canopy_layer = i_lyr+1 - - ! keep track of number and biomass of demoted cohort - currentSite%demotion_rate(currentCohort%size_class) = & - currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n - currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & - (leaf_c + store_c + fnrt_c + sapw_c + struct_c) * currentCohort%n - - elseif( (cc_loss < currentCohort%c_area) .and. & - (cc_loss > area_target_precision) ) then - - ! If only part of the cohort is demoted - ! then it must be split (little more complicated) - - ! Make a copy of the current cohort. The copy and the original - ! conserve total number density of the original. The copy - ! remains in the upper-story. The original is the one - ! demoted to the understory - - - allocate(copyc) - - ! Initialize the PARTEH object and point to the - ! correct boundary condition fields - copyc%prt => null() - call InitPRTObject(copyc%prt) - call InitPRTBoundaryConditions(copyc) - - if( hlm_use_planthydro.eq.itrue ) then - call InitHydrCohort(currentSite,copyc) - endif - - call copy_cohort(currentCohort, copyc) - - newarea = currentCohort%c_area - cc_loss - copyc%n = currentCohort%n*newarea/currentCohort%c_area - currentCohort%n = currentCohort%n - copyc%n - - copyc%canopy_layer = i_lyr !the taller cohort is the copy - - ! Demote the current cohort to the understory. - currentCohort%canopy_layer = i_lyr + 1 - - ! keep track of number and biomass of demoted cohort - currentSite%demotion_rate(currentCohort%size_class) = & - currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n - currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & - (leaf_c + store_c + fnrt_c + sapw_c + struct_c) * currentCohort%n - - call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) - - !----------- Insert copy into linked list ------------------------! - copyc%shorter => currentCohort - if(associated(currentCohort%taller))then - copyc%taller => currentCohort%taller - currentCohort%taller%shorter => copyc - else - currentPatch%tallest => copyc - copyc%taller => null() - endif - currentCohort%taller => copyc - - elseif(cc_loss > currentCohort%c_area)then - - write(fates_log(),*) 'more area than the cohort has is being demoted' - write(fates_log(),*) 'loss:',cc_loss - write(fates_log(),*) 'existing area:',currentCohort%c_area - write(fates_log(),*) 'excess: ',cc_loss - currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - - end if - - ! kill the ones which go into canopy layers that are not allowed - - if(currentCohort%canopy_layer>nclmax )then - - ! put the litter from the terminated cohorts - ! straight into the fragmenting pools - call SendCohortToLitter(currentSite,currentPatch, & - currentCohort,currentCohort%n) - - currentCohort%n = 0.0_r8 - currentCohort%c_area = 0.0_r8 - currentCohort%canopy_layer = i_lyr - - end if - - call carea_allom(currentCohort%dbh,currentCohort%n, & - currentSite%spread,currentCohort%pft,currentCohort%c_area) - - endif !canopy layer = i_ly - - currentCohort => currentCohort%shorter - enddo !currentCohort - - - ! Update the area calculations of the current layer - ! And the layer below that may or may not had recieved - ! Demotions - - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer) - - if ( (abs(arealayer - currentPatch%area)/arealayer > area_check_rel_precision ) .or. & - (abs(arealayer - currentPatch%area) > area_check_precision) ) then - write(fates_log(),*) 'demotion did not trim area within tolerance' - write(fates_log(),*) 'arealayer:',arealayer - write(fates_log(),*) 'patch%area:',currentPatch%area - write(fates_log(),*) 'ilayer: ',i_lyr - write(fates_log(),*) 'bias:',arealayer - currentPatch%area - write(fates_log(),*) 'rel bias:',(arealayer - currentPatch%area)/arealayer - write(fates_log(),*) 'demote_area:',demote_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - end if - - return - end subroutine DemoteFromLayer - - ! ============================================================================================== - - subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) - - ! ------------------------------------------------------------------------------------------- - ! Check whether the intended 'full' layers are actually filling all the space. - ! If not, promote some fraction of cohorts upwards. - ! THIS SECTION MIGHT BE TRIGGERED BY A FIRE OR MORTALITY EVENT, FOLLOWED BY A PATCH FUSION, - ! SO THE TOP LAYER IS NO LONGER FULL. - ! ------------------------------------------------------------------------------------------- - - use EDParamsMod, only : ED_val_comp_excln - - ! !ARGUMENTS - type(ed_site_type), intent(inout), target :: currentSite - type(ed_patch_type), intent(inout), target :: currentPatch - integer, intent(in) :: i_lyr ! Current canopy layer of interest - - ! !LOCAL VARIABLES: - type(ed_cohort_type), pointer :: currentCohort - type(ed_cohort_type), pointer :: copyc - type(ed_cohort_type), pointer :: nextc ! the next cohort, or used for looping - ! cohorts against the current - - real(r8) :: scale_factor ! for prob. exclusion - scales weight to a fraction - real(r8) :: scale_factor_min ! "" minimum before exeedance of 1 - real(r8) :: scale_factor_res ! "" applied to residual areas - real(r8) :: area_res ! residual area to demote after weakest cohort hits max - real(r8) :: promote_area - real(r8) :: newarea - real(r8) :: sumweights - real(r8) :: sumequal ! for tied cohorts, the sum of weights in - ! their group - real(r8) :: cc_gain ! cohort crown area gain in promotion (m2) - real(r8) :: arealayer_current ! area (m2) of the current canopy layer - real(r8) :: arealayer_below ! area (m2) of the layer below the current layer - real(r8) :: leaf_c ! leaf carbon [kg] - real(r8) :: fnrt_c ! fineroot carbon [kg] - real(r8) :: sapw_c ! sapwood carbon [kg] - real(r8) :: store_c ! storage carbon [kg] - real(r8) :: struct_c ! structure carbon [kg] - - logical :: tied_size_with_neighbors - real(r8) :: total_crownarea_of_tied_cohorts - - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr+1,arealayer_below) - - - ! how much do we need to gain? - promote_area = currentPatch%area - arealayer_current - - if( promote_area > area_target_precision ) then - - if(arealayer_below <= promote_area ) then - - ! --------------------------------------------------------------------------- - ! Promote all cohorts from layer below if that whole layer has area smaller - ! than the tolerance on the gains needed into current layer - ! --------------------------------------------------------------------------- - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - !look at the cohorts in the canopy layer below... - if(currentCohort%canopy_layer == i_lyr+1)then - - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) - fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) - sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) - struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) - - currentCohort%canopy_layer = i_lyr - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + end if + end if + + endif + currentCohort => currentCohort%shorter + enddo + + else + + ! Non-trivial case, at least 1 cohort's promotion + ! rate would exceed its area, given the trivial scale factor + + area_res = 0._r8 + scale_factor_res = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1) ) then + area_res = area_res + & + currentCohort%c_area*currentCohort%prom_weight*scale_factor_min + scale_factor_res = scale_factor_res + & + currentCohort%c_area * & + (1._r8 - (currentCohort%prom_weight * scale_factor_min)) + endif + currentCohort => currentCohort%shorter + enddo + + area_res = promote_area - area_res + + scale_factor_res = area_res / scale_factor_res + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1)) then + + currentCohort%prom_weight = currentCohort%c_area * & + (currentCohort%prom_weight * scale_factor_min + & + (1._r8 - (currentCohort%prom_weight*scale_factor_min) ) * & + scale_factor_res) + + if(debug)then + if((currentCohort%prom_weight > & + (currentCohort%c_area+area_target_precision)) .or. & + (currentCohort%prom_weight < 0._r8) ) then + write(fates_log(),*) 'promotion area error (2)' + write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area + write(fates_log(),*) 'currentCohort%prom_weight: ', & + currentCohort%prom_weight + write(fates_log(),*) 'excess: ', & + currentCohort%prom_weight - currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + endif + currentCohort => currentCohort%shorter + enddo + + end if + + end if + + + ! lets perform a check and see if the promotions meet the demand + sumweights = 0._r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == (i_lyr+1)) then + sumweights = sumweights + currentCohort%prom_weight + end if + currentCohort => currentCohort%shorter + end do + + if(debug)then + if (abs(sumweights - promote_area) > area_check_precision ) then + write(fates_log(),*) 'promotions dont add up' + write(fates_log(),*) 'sum promotions: ',sumweights + write(fates_log(),*) 'area needed to be promoted: ',promote_area + write(fates_log(),*) 'excess: ',sumweights - promote_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + + + !All the trees in this layer need to promote some area upwards... + if( (currentCohort%canopy_layer == i_lyr+1) ) then + + cc_gain = currentCohort%prom_weight + leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) + sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) + struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) + + if ( (cc_gain-currentCohort%c_area) > -nearzero .and. & + (cc_gain-currentCohort%c_area) < area_target_precision ) then + + currentCohort%canopy_layer = i_lyr + + ! keep track of number and biomass of promoted cohort + currentSite%promotion_rate(currentCohort%size_class) = & + currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n + + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & + (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n + + elseif ( (cc_gain < currentCohort%c_area) .and. & + (cc_gain > area_target_precision) ) then + + allocate(copyc) + + ! Initialize the PARTEH object and point to the + ! correct boundary condition fields + copyc%prt => null() + call InitPRTObject(copyc%prt) + call InitPRTBoundaryConditions(copyc) + + if( hlm_use_planthydro.eq.itrue ) then + call InitHydrCohort(CurrentSite,copyc) + endif + + ! (keep as an example) + ! Initialize running means + !allocate(copyc%tveg_lpa) + !call copyc%tveg_lpa%InitRMean(ema_lpa,& + ! init_value=currentPatch%tveg_lpa%GetMean()) + + call copy_cohort(currentCohort, copyc) !makes an identical copy... + + newarea = currentCohort%c_area - cc_gain !new area of existing cohort + + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) - ! keep track of number and biomass of promoted cohort - currentSite%promotion_rate(currentCohort%size_class) = & - currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n - currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & - (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n - - endif - currentCohort => currentCohort%shorter - enddo - - else - - ! --------------------------------------------------------------------------- - ! This is the non-trivial case where the lower layer can accomodate - ! more than what is necessary. - ! --------------------------------------------------------------------------- - - - ! figure out with what weighting we need to promote cohorts. - ! This is the opposite of the demotion weighting... - - sumweights = 0.0_r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) - if(currentCohort%canopy_layer == i_lyr+1)then !look at the cohorts in the canopy layer below... - - if (ED_val_comp_excln .ge. 0.0_r8 ) then - - ! ------------------------------------------------------------------ - ! Stochastic case, as above (in demotion portion of code) - ! ------------------------------------------------------------------ - - currentCohort%prom_weight = currentCohort%hite**ED_val_comp_excln - sumweights = sumweights + currentCohort%prom_weight - else - - ! ------------------------------------------------------------------ - ! Rank ordered deterministic method - ! If there are cohorts that have the exact same height (which is possible, really) - ! we don't want to unilaterally promote/demote one before the others. - ! So we <>mote them as a unit - ! now we need to go through and figure out how many equal-size cohorts there are. - ! then we need to go through, add up the collective crown areas of all equal-sized - ! and equal-canopy-layer cohorts, - ! and then demote from each as if they were a single group - ! ------------------------------------------------------------------ - - total_crownarea_of_tied_cohorts = currentCohort%c_area - tied_size_with_neighbors = .false. - nextc => currentCohort%shorter - do while (associated(nextc)) - if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then - if( nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - tied_size_with_neighbors = .true. - total_crownarea_of_tied_cohorts = & - total_crownarea_of_tied_cohorts + nextc%c_area - end if - else - exit - endif - nextc => nextc%shorter - end do - - if ( tied_size_with_neighbors ) then - - currentCohort%prom_weight = & - max(0.0_r8,min(currentCohort%c_area, & - (currentCohort%c_area/total_crownarea_of_tied_cohorts) * & - (promote_area - sumweights) )) - sumequal = currentCohort%prom_weight - - nextc => currentCohort%shorter - do while (associated(nextc)) - if ( abs(nextc%hite - currentCohort%hite) < similar_height_tol ) then - if (nextc%canopy_layer .eq. currentCohort%canopy_layer ) then - ! now we know the total crown area of all equal-sized, - ! equal-canopy-layer cohorts - nextc%prom_weight = & - max(0.0_r8,min(nextc%c_area, & - (nextc%c_area/total_crownarea_of_tied_cohorts) * & - (promote_area - sumweights) )) - sumequal = sumequal + nextc%prom_weight - end if - else - exit - endif - nextc => nextc%shorter - end do - - ! Update the current cohort pointer to the last similar cohort - ! Its ok if this is not in the right layer - if(associated(nextc))then - currentCohort => nextc%taller - else - currentCohort => currentPatch%shortest - end if - sumweights = sumweights + sumequal - - else - currentCohort%prom_weight = & - max(min(currentCohort%c_area, promote_area - sumweights ), 0._r8) - sumweights = sumweights + currentCohort%prom_weight - - end if - - endif - endif - currentCohort => currentCohort%shorter - enddo !currentCohort - - - ! If this is probabalistic promotion, we need to do a round of normalization. - ! And then a few rounds where we pre-calculate the promotion areas - ! and adjust things if the promoted area wants to be greater than - ! what is available. - - if (ED_val_comp_excln .ge. 0.0_r8 ) then - - scale_factor_min = 1.e10_r8 - scale_factor = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - - if(currentCohort%canopy_layer == (i_lyr+1) ) then - - currentCohort%prom_weight = currentCohort%prom_weight/sumweights - if( 1._r8/currentCohort%prom_weight < scale_factor_min ) & - scale_factor_min = 1._r8/currentCohort%prom_weight - - scale_factor = scale_factor + currentCohort%prom_weight * currentCohort%c_area - - endif - currentCohort => currentCohort%shorter - enddo - - ! This is the factor by which we need to multiply - ! the demotion probabilities, so the sum result equals - ! the total amount to demote - scale_factor = promote_area/scale_factor - - - if(scale_factor <= scale_factor_min) then - - ! Trivial case, all of the demotion fractions - ! are less than 1. - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1) ) then - currentCohort%prom_weight = currentCohort%c_area * & - currentCohort%prom_weight * scale_factor - - if(debug)then - if((currentCohort%prom_weight > & - (currentCohort%c_area+area_target_precision)) .or. & - (currentCohort%prom_weight < 0._r8) ) then - write(fates_log(),*) 'promotion area too big (1)' - write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area - write(fates_log(),*) 'currentCohort%prom_weight: ', & - currentCohort%prom_weight - write(fates_log(),*) 'excess: ', & - currentCohort%prom_weight - currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - endif - currentCohort => currentCohort%shorter - enddo - - else - - ! Non-trivial case, at least 1 cohort's promotion - ! rate would exceed its area, given the trivial scale factor - - area_res = 0._r8 - scale_factor_res = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1) ) then - area_res = area_res + & - currentCohort%c_area*currentCohort%prom_weight*scale_factor_min - scale_factor_res = scale_factor_res + & - currentCohort%c_area * & - (1._r8 - (currentCohort%prom_weight * scale_factor_min)) - endif - currentCohort => currentCohort%shorter - enddo - - area_res = promote_area - area_res - - scale_factor_res = area_res / scale_factor_res - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1)) then - - currentCohort%prom_weight = currentCohort%c_area * & - (currentCohort%prom_weight * scale_factor_min + & - (1._r8 - (currentCohort%prom_weight*scale_factor_min) ) * & - scale_factor_res) - - if(debug)then - if((currentCohort%prom_weight > & - (currentCohort%c_area+area_target_precision)) .or. & - (currentCohort%prom_weight < 0._r8) ) then - write(fates_log(),*) 'promotion area error (2)' - write(fates_log(),*) 'currentCohort%c_area: ',currentCohort%c_area - write(fates_log(),*) 'currentCohort%prom_weight: ', & - currentCohort%prom_weight - write(fates_log(),*) 'excess: ', & - currentCohort%prom_weight - currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - endif - currentCohort => currentCohort%shorter - enddo - - end if - - end if - - - ! lets perform a check and see if the promotions meet the demand - sumweights = 0._r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == (i_lyr+1)) then - sumweights = sumweights + currentCohort%prom_weight - end if - currentCohort => currentCohort%shorter - end do - - if(debug)then - if (abs(sumweights - promote_area) > area_check_precision ) then - write(fates_log(),*) 'promotions dont add up' - write(fates_log(),*) 'sum promotions: ',sumweights - write(fates_log(),*) 'area needed to be promoted: ',promote_area - write(fates_log(),*) 'excess: ',sumweights - promote_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - - - !All the trees in this layer need to promote some area upwards... - if( (currentCohort%canopy_layer == i_lyr+1) ) then - - cc_gain = currentCohort%prom_weight - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - store_c = currentCohort%prt%GetState(store_organ,all_carbon_elements) - fnrt_c = currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) - sapw_c = currentCohort%prt%GetState(sapw_organ,all_carbon_elements) - struct_c = currentCohort%prt%GetState(struct_organ,all_carbon_elements) - - if ( (cc_gain-currentCohort%c_area) > -nearzero .and. & - (cc_gain-currentCohort%c_area) < area_target_precision ) then - - currentCohort%canopy_layer = i_lyr - - ! keep track of number and biomass of promoted cohort - currentSite%promotion_rate(currentCohort%size_class) = & - currentSite%promotion_rate(currentCohort%size_class) + currentCohort%n - - currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & - (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n - - elseif ( (cc_gain < currentCohort%c_area) .and. & - (cc_gain > area_target_precision) ) then - - allocate(copyc) - - ! Initialize the PARTEH object and point to the - ! correct boundary condition fields - copyc%prt => null() - call InitPRTObject(copyc%prt) - call InitPRTBoundaryConditions(copyc) - - if( hlm_use_planthydro.eq.itrue ) then - call InitHydrCohort(CurrentSite,copyc) - endif - call copy_cohort(currentCohort, copyc) !makes an identical copy... - - newarea = currentCohort%c_area - cc_gain !new area of existing cohort - - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) - - ! number of individuals in promoted cohort. - copyc%n = currentCohort%n*cc_gain/currentCohort%c_area - - ! number of individuals in cohort remaining in understorey - currentCohort%n = currentCohort%n - copyc%n - - currentCohort%canopy_layer = i_lyr + 1 ! keep current cohort in the understory. - copyc%canopy_layer = i_lyr ! promote copy to the higher canopy layer. - - ! keep track of number and biomass of promoted cohort - currentSite%promotion_rate(copyc%size_class) = & - currentSite%promotion_rate(copyc%size_class) + copyc%n - - currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & - (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * copyc%n - - call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & - currentCohort%pft,currentCohort%c_area) - call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) - - !----------- Insert copy into linked list ------------------------! - copyc%shorter => currentCohort - if(associated(currentCohort%taller))then - copyc%taller => currentCohort%taller - currentCohort%taller%shorter => copyc - else - currentPatch%tallest => copyc - copyc%taller => null() - endif - currentCohort%taller => copyc - - elseif(cc_gain > currentCohort%c_area)then - - write(fates_log(),*) 'more area than the cohort has is being promoted' - write(fates_log(),*) 'loss:',cc_gain - write(fates_log(),*) 'existing area:',currentCohort%c_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - - endif - - endif ! if(currentCohort%canopy_layer == i_lyr+1) then - currentCohort => currentCohort%shorter - enddo !currentCohort - - call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) - - if ((abs(arealayer_current - currentPatch%area)/arealayer_current > & - area_check_rel_precision ) .or. & - (abs(arealayer_current - currentPatch%area) > area_check_precision) ) then - write(fates_log(),*) 'promotion did not bring area within tolerance' - write(fates_log(),*) 'arealayer:',arealayer_current - write(fates_log(),*) 'patch%area:',currentPatch%area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - end if - - end if - - return - end subroutine PromoteIntoLayer + + ! number of individuals in promoted cohort. + copyc%n = currentCohort%n*cc_gain/currentCohort%c_area + + ! number of individuals in cohort remaining in understorey + currentCohort%n = currentCohort%n - copyc%n + + currentCohort%canopy_layer = i_lyr + 1 ! keep current cohort in the understory. + copyc%canopy_layer = i_lyr ! promote copy to the higher canopy layer. + + ! keep track of number and biomass of promoted cohort + currentSite%promotion_rate(copyc%size_class) = & + currentSite%promotion_rate(copyc%size_class) + copyc%n + + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & + (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * copyc%n + + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & + currentCohort%pft,currentCohort%c_area) + call carea_allom(copyc%dbh,copyc%n,currentSite%spread,copyc%pft,copyc%c_area) + + !----------- Insert copy into linked list ------------------------! + copyc%shorter => currentCohort + if(associated(currentCohort%taller))then + copyc%taller => currentCohort%taller + currentCohort%taller%shorter => copyc + else + currentPatch%tallest => copyc + copyc%taller => null() + endif + currentCohort%taller => copyc + + elseif(cc_gain > currentCohort%c_area)then + + write(fates_log(),*) 'more area than the cohort has is being promoted' + write(fates_log(),*) 'loss:',cc_gain + write(fates_log(),*) 'existing area:',currentCohort%c_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + + endif + + endif ! if(currentCohort%canopy_layer == i_lyr+1) then + currentCohort => currentCohort%shorter + enddo !currentCohort + + call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) + + if ((abs(arealayer_current - currentPatch%area)/arealayer_current > & + area_check_rel_precision ) .or. & + (abs(arealayer_current - currentPatch%area) > area_check_precision) ) then + write(fates_log(),*) 'promotion did not bring area within tolerance' + write(fates_log(),*) 'arealayer:',arealayer_current + write(fates_log(),*) 'patch%area:',currentPatch%area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end if + + end if + + return + end subroutine PromoteIntoLayer ! ============================================================================ subroutine canopy_spread( currentSite ) ! ! !DESCRIPTION: - ! Calculates the spatial spread of tree canopies based on canopy closure. + ! Calculates the spatial spread of tree canopies based on canopy closure. ! ! !USES: use EDTypesMod , only : AREA - use EDParamsMod, only : ED_val_canopy_closure_thresh + use EDParamsMod, only : ED_val_canopy_closure_thresh ! - ! !ARGUMENTS + ! !ARGUMENTS type (ed_site_type), intent(inout), target :: currentSite ! ! !LOCAL VARIABLES: type (ed_cohort_type), pointer :: currentCohort type (ed_patch_type) , pointer :: currentPatch real(r8) :: sitelevel_canopyarea ! Amount of canopy in top layer at the site level - real(r8) :: inc ! Arbitrary daily incremental change in canopy area + real(r8) :: inc ! Arbitrary daily incremental change in canopy area integer :: z !---------------------------------------------------------------------- @@ -1218,16 +1228,16 @@ subroutine canopy_spread( currentSite ) currentPatch => currentSite%oldest_patch - sitelevel_canopyarea = 0.0_r8 + sitelevel_canopyarea = 0.0_r8 do while (associated(currentPatch)) !calculate canopy area in each patch... currentCohort => currentPatch%tallest do while (associated(currentCohort)) call carea_allom(currentCohort%dbh,currentCohort%n, & - currentSite%spread,currentCohort%pft,currentCohort%c_area) + currentSite%spread,currentCohort%pft,currentCohort%c_area) if( ( int(prt_params%woody(currentCohort%pft)) .eq. itrue ) .and. & - (currentCohort%canopy_layer .eq. 1 ) ) then + (currentCohort%canopy_layer .eq. 1 ) ) then sitelevel_canopyarea = sitelevel_canopyarea + currentCohort%c_area endif currentCohort => currentCohort%shorter @@ -1241,8 +1251,8 @@ subroutine canopy_spread( currentSite ) ! squash the tree canopies and make them taller and thinner if( sitelevel_canopyarea/AREA .gt. ED_val_canopy_closure_thresh ) then currentSite%spread = currentSite%spread - inc - else - currentSite%spread = currentSite%spread + inc + else + currentSite%spread = currentSite%spread + inc endif ! put within bounds to make sure it stays between 0 and 1 @@ -1255,9 +1265,9 @@ end subroutine canopy_spread subroutine canopy_summarization( nsites, sites, bc_in ) - ! ---------------------------------------------------------------------------------- - ! Much of this routine was once ed_clm_link minus all the IO and history stuff - ! --------------------------------------------------------------------------------- + ! ---------------------------------------------------------------------------------- + ! Much of this routine was once ed_clm_link minus all the IO and history stuff + ! --------------------------------------------------------------------------------- use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking use EDPatchDynamicsMod , only : set_patchno @@ -1266,7 +1276,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) use EDtypesMod , only : area use FatesConstantsMod , only : itrue - ! !ARGUMENTS + ! !ARGUMENTS integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) type(bc_in_type) , intent(in) :: bc_in(nsites) @@ -1276,9 +1286,8 @@ subroutine canopy_summarization( nsites, sites, bc_in ) 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. + integer :: ifp ! the number of the vegetated patch (1,2,3). In SP mode bareground patch is 0 + integer :: patchn ! identification number for each patch. real(r8) :: leaf_c ! leaf carbon [kg] real(r8) :: fnrt_c ! fineroot carbon [kg] real(r8) :: sapw_c ! sapwood carbon [kg] @@ -1286,16 +1295,16 @@ subroutine canopy_summarization( nsites, sites, bc_in ) real(r8) :: struct_c ! structure carbon [kg] !---------------------------------------------------------------------- - + if ( debug ) then write(fates_log(),*) 'in canopy_summarization' endif do s = 1,nsites - + ! -------------------------------------------------------------------------------- - ! Set the patch indices (this is usefull mostly for communicating with a host or - ! driving model. Loops through all patches and sets cpatch%patchno to the integer + ! 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) ) @@ -1303,16 +1312,15 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentPatch => sites(s)%oldest_patch do while(associated(currentPatch)) - - !zero cohort-summed variables. + + !zero cohort-summed variables. currentPatch%total_canopy_area = 0.0_r8 currentPatch%total_tree_area = 0.0_r8 - canopy_leaf_area = 0.0_r8 - - !update cohort quantitie s + + !update cohort quantitie s currentCohort => currentPatch%shortest do while(associated(currentCohort)) - + ft = currentCohort%pft @@ -1321,58 +1329,77 @@ subroutine canopy_summarization( nsites, sites, bc_in ) struct_c = currentCohort%prt%GetState(struct_organ, all_carbon_elements) fnrt_c = currentCohort%prt%GetState(fnrt_organ, all_carbon_elements) store_c = currentCohort%prt%GetState(store_organ, all_carbon_elements) - + ! Update the cohort's index within the size bin classes ! Update the cohort's index within the SCPF classification system call sizetype_class_index(currentCohort%dbh,currentCohort%pft, & currentCohort%size_class,currentCohort%size_by_pft_class) if (hlm_use_cohort_age_tracking .eq. itrue) then - call coagetype_class_index(currentCohort%coage,currentCohort%pft, & - currentCohort%coage_class,currentCohort%coage_by_pft_class) - end if - - call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& - currentCohort%pft,currentCohort%c_area) + call coagetype_class_index(currentCohort%coage,currentCohort%pft, & + currentCohort%coage_class,currentCohort%coage_by_pft_class) + end if - currentCohort%treelai = tree_lai(leaf_c, & - currentCohort%pft, currentCohort%c_area, currentCohort%n, & - currentCohort%canopy_layer, currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + if(hlm_use_sp.eq.ifalse)then + call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& + currentCohort%pft,currentCohort%c_area) + endif - canopy_leaf_area = canopy_leaf_area + currentCohort%treelai *currentCohort%c_area - if(currentCohort%canopy_layer==1)then currentPatch%total_canopy_area = currentPatch%total_canopy_area + currentCohort%c_area if( int(prt_params%woody(ft))==itrue)then currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area endif endif - - ! Check for erroneous zero values. + + ! adding checks for SP and NOCOMP modes. + if(currentPatch%nocomp_pft_label.eq.0)then + write(fates_log(),*) 'cohorts in barepatch',currentPatch%total_canopy_area,currentPatch%nocomp_pft_label + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_use_sp.eq.itrue)then + + if(associated(currentPatch%tallest%shorter))then + write(fates_log(),*) 'more than one cohort in SP mode',s,currentPatch%nocomp_pft_label + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(currentPatch%total_canopy_area-currentPatch%area.gt.1.0e-16)then + write(fates_log(),*) 'too much canopy in summary',s, & + currentPatch%nocomp_pft_label, currentPatch%total_canopy_area-currentPatch%area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if !sp mode + + ! Check for erroneous zero values. if(currentCohort%dbh <= 0._r8 .or. currentCohort%n == 0._r8)then write(fates_log(),*) 'FATES: dbh or n is zero in canopy_summarization', & - currentCohort%dbh,currentCohort%n + currentCohort%dbh,currentCohort%n call endrun(msg=errMsg(sourcefile, __LINE__)) endif + if(currentCohort%pft == 0.or.currentCohort%canopy_trim <= 0._r8)then write(fates_log(),*) 'FATES: PFT or trim is zero in canopy_summarization', & - currentCohort%pft,currentCohort%canopy_trim + currentCohort%pft,currentCohort%canopy_trim call endrun(msg=errMsg(sourcefile, __LINE__)) endif if( (sapw_c + leaf_c + fnrt_c) <= 0._r8)then write(fates_log(),*) 'FATES: alive biomass is zero in canopy_summarization', & - sapw_c + leaf_c + fnrt_c + sapw_c + leaf_c + fnrt_c call endrun(msg=errMsg(sourcefile, __LINE__)) endif currentCohort => currentCohort%taller - + enddo ! ends 'do while(associated(currentCohort)) - + if ( currentPatch%total_canopy_area>currentPatch%area ) then if ( currentPatch%total_canopy_area-currentPatch%area > 0.001_r8 ) then write(fates_log(),*) 'FATES: canopy area bigger than area', & - currentPatch%total_canopy_area ,currentPatch%area + currentPatch%total_canopy_area ,currentPatch%area, & + currentPatch%total_canopy_area -currentPatch%area,& + currentPatch%nocomp_pft_label call endrun(msg=errMsg(sourcefile, __LINE__)) end if currentPatch%total_canopy_area = currentPatch%area @@ -1380,45 +1407,45 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentPatch => currentPatch%younger end do !patch loop - - call leaf_area_profile(sites(s)) - + + call leaf_area_profile(sites(s)) + end do ! site loop - + return end subroutine canopy_summarization ! ==================================================================================== subroutine UpdateFatesAvgSnowDepth(sites,bc_in) - + ! This routine updates the snow depth used in FATES to occlude vegetation ! Currently this average takes into account the depth of snow and the ! areal coverage fraction - + type(ed_site_type) , intent(inout), target :: sites(:) type(bc_in_type) , intent(in) :: bc_in(:) - + integer :: s - + do s = 1, size(sites,dim=1) sites(s)%snow_depth = bc_in(s)%snow_depth_si * bc_in(s)%frac_sno_eff_si end do - + return end subroutine UpdateFatesAvgSnowDepth - - + + ! ===================================================================================== - subroutine leaf_area_profile( currentSite ) - + subroutine leaf_area_profile( currentSite ) + ! ----------------------------------------------------------------------------------- - ! This subroutine calculates how leaf and stem areas are distributed + ! This subroutine calculates how leaf and stem areas are distributed ! in vertical and horizontal space. ! ! The following cohort level diagnostics are updated here: - ! + ! ! currentCohort%treelai ! LAI per unit crown area (m2/m2) ! currentCohort%treesai ! SAI per unit crown area (m2/m2) ! currentCohort%lai ! LAI per unit canopy area (m2/m2) @@ -1427,10 +1454,10 @@ subroutine leaf_area_profile( currentSite ) ! ! layers needed to describe this crown ! ! The following patch level diagnostics are updated here: - ! + ! ! currentPatch%canopy_layer_tlai(cl) ! total leaf area index of canopy layer ! currentPatch%ncan(cl,ft) ! number of vegetation layers needed - ! ! in this patch's pft/canopy-layer + ! ! in this patch's pft/canopy-layer ! currentPatch%nrad(cl,ft) ! same as ncan, but does not include ! ! layers occluded by snow ! ! CURRENTLY SAME AS NCAN @@ -1440,7 +1467,7 @@ subroutine leaf_area_profile( currentSite ) ! currentPatch%elai_profile(cl,ft,iv) ! non-snow covered m2 of leaves per m2 of PFT footprint ! currentPatch%tsai_profile(cl,ft,iv) ! m2 of stems per m2 of PFT footprint ! currentPatch%esai_profile(cl,ft,iv) ! non-snow covered m2 of stems per m2 of PFT footprint - ! currentPatch%canopy_area_profile(cl,ft,iv) ! Fractional area of leaf layer + ! currentPatch%canopy_area_profile(cl,ft,iv) ! Fractional area of leaf layer ! ! relative to vegetated area ! currentPatch%layer_height_profile(cl,ft,iv) ! Elevation of layer in m ! @@ -1448,10 +1475,10 @@ subroutine leaf_area_profile( currentSite ) ! !USES: - use EDtypesMod , only : area, dinc_ed, hitemax, n_hite_bins + use EDtypesMod , only : area, dinc_vai, dlower_vai, hitemax, n_hite_bins ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type) , intent(inout) :: currentSite @@ -1459,10 +1486,10 @@ subroutine leaf_area_profile( currentSite ) ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch type (ed_cohort_type) , pointer :: currentCohort - real(r8) :: remainder !Thickness of layer at bottom of canopy. - real(r8) :: fleaf ! fraction of cohort incepting area that is leaves. - integer :: ft ! Plant functional type index. - integer :: iv ! Vertical leaf layer index + real(r8) :: remainder !Thickness of layer at bottom of canopy. + real(r8) :: fleaf ! fraction of cohort incepting area that is leaves. + integer :: ft ! Plant functional type index. + integer :: iv ! Vertical leaf layer index integer :: cl ! Canopy layer index real(r8) :: fraction_exposed ! how much of this layer is not covered by snow? real(r8) :: layer_top_hite ! notional top height of this canopy layer (m) @@ -1477,193 +1504,188 @@ subroutine leaf_area_profile( currentSite ) real(r8) :: max_chite ! top of cohort canopy (m) real(r8) :: lai ! summed lai for checking m2 m-2 real(r8) :: leaf_c ! leaf carbon [kg] - - !---------------------------------------------------------------------- - + !---------------------------------------------------------------------- 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... + ! leaf area index above it, irrespective of PFT identity... ! Each leaf is defined by how deep in the canopy it is, in terms of LAI units. (FIX(RF,032414), GB) - - currentPatch => currentSite%oldest_patch + + currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) ! -------------------------------------------------------------------------------- - ! Calculate tree and canopy areas. + ! Calculate tree and canopy areas. ! calculate tree lai and sai. ! -------------------------------------------------------------------------------- currentPatch%canopy_layer_tlai(:) = 0._r8 - currentPatch%ncan(:,:) = 0 - currentPatch%nrad(:,:) = 0 + currentPatch%ncan(:,:) = 0 + currentPatch%nrad(:,:) = 0 patch_lai = 0._r8 currentPatch%tlai_profile(:,:,:) = 0._r8 - currentPatch%tsai_profile(:,:,:) = 0._r8 + currentPatch%tsai_profile(:,:,:) = 0._r8 currentPatch%elai_profile(:,:,:) = 0._r8 - currentPatch%esai_profile(:,:,:) = 0._r8 + currentPatch%esai_profile(:,:,:) = 0._r8 currentPatch%layer_height_profile(:,:,:) = 0._r8 - currentPatch%canopy_area_profile(:,:,:) = 0._r8 + currentPatch%canopy_area_profile(:,:,:) = 0._r8 currentPatch%canopy_mask(:,:) = 0 ! ------------------------------------------------------------------------------ ! It is remotely possible that in deserts we will not have any canopy ! area, ie not plants at all... ! ------------------------------------------------------------------------------ - + if (currentPatch%total_canopy_area > nearzero ) then - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) - ft = currentCohort%pft - cl = currentCohort%canopy_layer + ft = currentCohort%pft + cl = currentCohort%canopy_layer - ! Calculate LAI of layers above - ! Note that the canopy_layer_lai is also calculated in this loop - ! but since we go top down in terms of plant size, we should be okay + ! Calculate LAI of layers above + ! Note that the canopy_layer_lai is also calculated in this loop + ! but since we go top down in terms of plant size, we should be okay - leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + leaf_c = currentCohort%prt%GetState(leaf_organ,all_carbon_elements) - currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & - currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & + currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) - currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & - currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai, currentCohort%treelai , & - currentCohort%vcmax25top,4) + if (hlm_use_sp .eq. ifalse) then + currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & + currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai, currentCohort%treelai , & + currentCohort%vcmax25top,4) + end if - currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area - currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area + currentCohort%lai = currentCohort%treelai *currentCohort%c_area/currentPatch%total_canopy_area + currentCohort%sai = currentCohort%treesai *currentCohort%c_area/currentPatch%total_canopy_area - ! Number of actual vegetation layers in this cohort's crown - currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) + ! Number of actual vegetation layers in this cohort's crown + currentCohort%nv = count((currentCohort%treelai+currentCohort%treesai) .gt. dlower_vai(:)) + 1 - currentPatch%ncan(cl,ft) = max(currentPatch%ncan(cl,ft),currentCohort%NV) + currentPatch%ncan(cl,ft) = max(currentPatch%ncan(cl,ft),currentCohort%NV) - patch_lai = patch_lai + currentCohort%lai + patch_lai = patch_lai + currentCohort%lai - currentPatch%canopy_layer_tlai(cl) = currentPatch%canopy_layer_tlai(cl) + currentCohort%lai + currentPatch%canopy_layer_tlai(cl) = currentPatch%canopy_layer_tlai(cl) + currentCohort%lai - currentCohort => currentCohort%shorter - - enddo !currentCohort + currentCohort => currentCohort%shorter - if(smooth_leaf_distribution == 1)then - - ! ----------------------------------------------------------------------------- - ! we are going to ignore the concept of canopy layers, and put all of the leaf - ! area into height banded bins. using the same domains as we had before, except - ! that CL always = 1 - ! ----------------------------------------------------------------------------- - - ! this is a crude way of dividing up the bins. Should it be a function of actual maximum height? - dh = 1.0_r8*(HITEMAX/N_HITE_BINS) - do iv = 1,N_HITE_BINS - if (iv == 1) then - minh(iv) = 0.0_r8 - maxh(iv) = dh - else - minh(iv) = (iv-1)*dh - maxh(iv) = (iv)*dh - endif - enddo - - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - ft = currentCohort%pft - min_chite = currentCohort%hite - currentCohort%hite * EDPftvarcon_inst%crown(ft) - max_chite = currentCohort%hite - do iv = 1,N_HITE_BINS - frac_canopy(iv) = 0.0_r8 - ! this layer is in the middle of the canopy - if(max_chite > maxh(iv).and.min_chite < minh(iv))then - frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*EDPftvarcon_inst%crown(ft))) - ! this is the layer with the bottom of the canopy in it. - elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then - frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) - ! this is the layer with the top of the canopy in it. - elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then - frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*EDPftvarcon_inst%crown(ft)) - elseif(max_chite < maxh(iv).and.min_chite > minh(iv))then !the whole cohort is within this layer. - frac_canopy(iv) = 1.0_r8 - endif - - ! no m2 of leaf per m2 of ground in each height class - currentPatch%tlai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) + frac_canopy(iv) * & - currentCohort%lai - currentPatch%tsai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) + frac_canopy(iv) * & - currentCohort%sai - - !snow burial - if(currentSite%snow_depth > maxh(iv))then - fraction_exposed = 0._r8 - endif - if(currentSite%snow_depth < minh(iv))then - fraction_exposed = 1._r8 - endif - if(currentSite%snow_depth >= minh(iv) .and. currentSite%snow_depth <= maxh(iv)) then !only partly hidden... - fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(currentSite%snow_depth-minh(iv))/dh))) + enddo !currentCohort + + if(smooth_leaf_distribution == 1)then + + ! ----------------------------------------------------------------------------- + ! we are going to ignore the concept of canopy layers, and put all of the leaf + ! area into height banded bins. using the same domains as we had before, except + ! that CL always = 1 + ! ----------------------------------------------------------------------------- + + ! this is a crude way of dividing up the bins. Should it be a function of actual maximum height? + dh = 1.0_r8*(HITEMAX/N_HITE_BINS) + do iv = 1,N_HITE_BINS + if (iv == 1) then + minh(iv) = 0.0_r8 + maxh(iv) = dh + else + minh(iv) = (iv-1)*dh + maxh(iv) = (iv)*dh endif - - if ( debug ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) - - currentPatch%elai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) * fraction_exposed - currentPatch%esai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) * fraction_exposed - - if ( debug ) write(fates_log(), *) 'leaf_area_profile()', currentPatch%elai_profile(1,ft,iv) - - enddo ! (iv) hite bins - - currentCohort => currentCohort%taller - - enddo !currentCohort - - ! ----------------------------------------------------------------------------- - ! Perform a leaf area conservation check on the LAI profile - lai = 0.0_r8 - do ft = 1,numpft - lai = lai+ sum(currentPatch%tlai_profile(1,ft,:)) - enddo - - if(lai > patch_lai)then - write(fates_log(), *) 'FATES: problem with lai assignments' - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - - - else ! smooth leaf distribution + enddo + + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + ft = currentCohort%pft + min_chite = currentCohort%hite - currentCohort%hite * prt_params%crown(ft) + max_chite = currentCohort%hite + do iv = 1,N_HITE_BINS + frac_canopy(iv) = 0.0_r8 + ! this layer is in the middle of the canopy + if(max_chite > maxh(iv).and.min_chite < minh(iv))then + frac_canopy(iv)= min(1.0_r8,dh / (currentCohort%hite*prt_params%crown(ft))) + ! this is the layer with the bottom of the canopy in it. + elseif(min_chite < maxh(iv).and.min_chite > minh(iv).and.max_chite > maxh(iv))then + frac_canopy(iv) = (maxh(iv) -min_chite ) / (currentCohort%hite*prt_params%crown(ft)) + ! this is the layer with the top of the canopy in it. + elseif(max_chite > minh(iv).and.max_chite < maxh(iv).and.min_chite < minh(iv))then + frac_canopy(iv) = (max_chite - minh(iv)) / (currentCohort%hite*prt_params%crown(ft)) + elseif(max_chite < maxh(iv).and.min_chite > minh(iv))then !the whole cohort is within this layer. + frac_canopy(iv) = 1.0_r8 + endif + + ! no m2 of leaf per m2 of ground in each height class + currentPatch%tlai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) + frac_canopy(iv) * & + currentCohort%lai + currentPatch%tsai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) + frac_canopy(iv) * & + currentCohort%sai + + !snow burial + if(currentSite%snow_depth > maxh(iv))then + fraction_exposed = 0._r8 + endif + if(currentSite%snow_depth < minh(iv))then + fraction_exposed = 1._r8 + endif + if(currentSite%snow_depth >= minh(iv) .and. currentSite%snow_depth <= maxh(iv)) then !only partly hidden... + fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(currentSite%snow_depth-minh(iv))/dh))) + endif + + currentPatch%elai_profile(1,ft,iv) = currentPatch%tlai_profile(1,ft,iv) * fraction_exposed + currentPatch%esai_profile(1,ft,iv) = currentPatch%tsai_profile(1,ft,iv) * fraction_exposed + + enddo ! (iv) hite bins + + currentCohort => currentCohort%taller + + enddo !currentCohort + + ! ----------------------------------------------------------------------------- + ! Perform a leaf area conservation check on the LAI profile + lai = 0.0_r8 + do ft = 1,numpft + lai = lai+ sum(currentPatch%tlai_profile(1,ft,:)) + enddo + + if(lai > patch_lai)then + write(fates_log(), *) 'FATES: problem with lai assignments' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + + else ! smooth leaf distribution + + ! ----------------------------------------------------------------------------- + ! Standard canopy layering model. + ! Go through all cohorts and add their leaf area + ! and canopy area to the accumulators. + ! ----------------------------------------------------------------------------- - ! ----------------------------------------------------------------------------- - ! Standard canopy layering model. - ! Go through all cohorts and add their leaf area - ! and canopy area to the accumulators. - ! ----------------------------------------------------------------------------- - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - - ft = currentCohort%pft + do while(associated(currentCohort)) + ft = currentCohort%pft cl = currentCohort%canopy_layer - + ! ---------------------------------------------------------------- - ! How much of each tree is stem area index? Assuming that there is + ! How much of each tree is stem area index? Assuming that there is ! This may indeed be zero if there is a sensecent grass ! ---------------------------------------------------------------- - - if( (currentCohort%treelai+currentCohort%treesai) > 0._r8)then - fleaf = currentCohort%lai / (currentCohort%lai + currentCohort%sai) + + if( (currentCohort%treelai+currentCohort%treesai) > 0._r8)then + fleaf = currentCohort%lai / (currentCohort%lai + currentCohort%sai) else fleaf = 0._r8 endif - - currentPatch%nrad(cl,ft) = currentPatch%ncan(cl,ft) + + currentPatch%nrad(cl,ft) = currentPatch%ncan(cl,ft) if (currentPatch%nrad(cl,ft) > nlevleaf ) then write(fates_log(), *) 'Number of radiative leaf layers is larger' @@ -1677,25 +1699,25 @@ subroutine leaf_area_profile( currentSite ) ! -------------------------------------------------------------------------- - ! Whole layers. Make a weighted average of the leaf area in each layer - ! before dividing it by the total area. Fill up layer for whole layers. + ! Whole layers. Make a weighted average of the leaf area in each layer + ! before dividing it by the total area. Fill up layer for whole layers. ! -------------------------------------------------------------------------- - + do iv = 1,currentCohort%NV - + ! This loop builds the arrays that define the effective (not snow covered) ! and total (includes snow covered) area indices for leaves and stems ! We calculate the absolute elevation of each layer to help determine if the layer ! is obscured by snow. - + layer_top_hite = currentCohort%hite - & - ( real(iv-1,r8)/currentCohort%NV * currentCohort%hite * & - EDPftvarcon_inst%crown(currentCohort%pft) ) - + ( real(iv-1,r8)/currentCohort%NV * currentCohort%hite * & + prt_params%crown(currentCohort%pft) ) + layer_bottom_hite = currentCohort%hite - & - ( real(iv,r8)/currentCohort%NV * currentCohort%hite * & - EDPftvarcon_inst%crown(currentCohort%pft) ) - + ( real(iv,r8)/currentCohort%NV * currentCohort%hite * & + prt_params%crown(currentCohort%pft) ) + fraction_exposed = 1.0_r8 if(currentSite%snow_depth > layer_top_hite)then fraction_exposed = 0._r8 @@ -1706,55 +1728,56 @@ subroutine leaf_area_profile( currentSite ) if(currentSite%snow_depth >= layer_bottom_hite .and. & currentSite%snow_depth <= layer_top_hite) then !only partly hidden... fraction_exposed = 1._r8 - max(0._r8,(min(1.0_r8,(currentSite%snow_depth -layer_bottom_hite)/ & - (layer_top_hite-layer_bottom_hite )))) + (layer_top_hite-layer_bottom_hite )))) endif - + if(iv==currentCohort%NV) then remainder = (currentCohort%treelai + currentCohort%treesai) - & - (dinc_ed*real(currentCohort%nv-1,r8)) - if(remainder > dinc_ed )then + (dlower_vai(iv) - dinc_vai(iv)) + if(remainder > dinc_vai(iv) )then write(fates_log(), *)'ED: issue with remainder', & - currentCohort%treelai,currentCohort%treesai,dinc_ed, & - currentCohort%NV,remainder + currentCohort%treelai,currentCohort%treesai,dinc_vai(iv), & + currentCohort%NV,remainder + call endrun(msg=errMsg(sourcefile, __LINE__)) endif else - remainder = dinc_ed + remainder = dinc_vai(iv) end if - + currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) + & - remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area - + remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%elai_profile(cl,ft,iv) = currentPatch%elai_profile(cl,ft,iv) + & - remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & - fraction_exposed - + remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & + fraction_exposed + currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) + & - remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area - + remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%esai_profile(cl,ft,iv) = currentPatch%esai_profile(cl,ft,iv) + & - remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area * & - fraction_exposed - + remainder * (1._r8 - fleaf) * currentCohort%c_area/currentPatch%total_canopy_area * & + fraction_exposed + currentPatch%canopy_area_profile(cl,ft,iv) = currentPatch%canopy_area_profile(cl,ft,iv) + & - currentCohort%c_area/currentPatch%total_canopy_area - + currentCohort%c_area/currentPatch%total_canopy_area + currentPatch%layer_height_profile(cl,ft,iv) = currentPatch%layer_height_profile(cl,ft,iv) + & - (remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & - (layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. - + (remainder * fleaf * currentCohort%c_area/currentPatch%total_canopy_area * & + (layer_top_hite+layer_bottom_hite)/2.0_r8) !average height of layer. + end do - + currentCohort => currentCohort%taller - + enddo !cohort - + ! -------------------------------------------------------------------------- - + ! If there is an upper-story, the top canopy layer ! should have a value of exactly 1.0 in its top leaf layer ! -------------------------------------------------------------------------- - + if ( (currentPatch%NCL_p > 1) .and. & (sum(currentPatch%canopy_area_profile(1,:,1)) < 0.9999 )) then write(fates_log(), *) 'FATES: canopy_area_profile was less than 1 at the canopy top' @@ -1770,12 +1793,12 @@ subroutine leaf_area_profile( currentSite ) write(fates_log(), *) 'ED: fracarea', currentCohort%pft, & currentCohort%c_area/currentPatch%total_canopy_area endif - currentCohort => currentCohort%taller + currentCohort => currentCohort%taller enddo !currentCohort call endrun(msg=errMsg(sourcefile, __LINE__)) - + end if - + ! -------------------------------------------------------------------------- ! In the following loop we are now normalizing the effective and @@ -1790,57 +1813,57 @@ subroutine leaf_area_profile( currentSite ) do cl = 1,currentPatch%NCL_p do iv = 1,currentPatch%ncan(cl,ft) - + if( debug .and. sum(currentPatch%canopy_area_profile(cl,:,iv)) > 1.0001_r8 ) then - + write(fates_log(), *) 'FATES: A canopy_area_profile exceeded 1.0' write(fates_log(), *) 'cl: ',cl write(fates_log(), *) 'iv: ',iv write(fates_log(), *) 'sum(cpatch%canopy_area_profile(cl,:,iv)): ', & - sum(currentPatch%canopy_area_profile(cl,:,iv)) - currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - if(currentCohort%canopy_layer==cl)then - write(fates_log(), *) 'FATES: cohorts in layer cl = ',cl, & - currentCohort%dbh,currentCohort%c_area, & - currentPatch%total_canopy_area,currentPatch%area - write(fates_log(), *) 'ED: fracarea', currentCohort%pft, & - currentCohort%c_area/currentPatch%total_canopy_area - endif - currentCohort => currentCohort%taller - enddo !currentCohort - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end do - + sum(currentPatch%canopy_area_profile(cl,:,iv)) + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + if(currentCohort%canopy_layer==cl)then + write(fates_log(), *) 'FATES: cohorts in layer cl = ',cl, & + currentCohort%dbh,currentCohort%c_area, & + currentPatch%total_canopy_area,currentPatch%area + write(fates_log(), *) 'ED: fracarea', currentCohort%pft, & + currentCohort%c_area/currentPatch%total_canopy_area + endif + currentCohort => currentCohort%taller + enddo !currentCohort + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do + do ft = 1,numpft do iv = 1,currentPatch%ncan(cl,ft) if( currentPatch%canopy_area_profile(cl,ft,iv) > nearzero ) then - + currentPatch%tlai_profile(cl,ft,iv) = currentPatch%tlai_profile(cl,ft,iv) / & - currentPatch%canopy_area_profile(cl,ft,iv) - + currentPatch%canopy_area_profile(cl,ft,iv) + currentPatch%tsai_profile(cl,ft,iv) = currentPatch%tsai_profile(cl,ft,iv) / & - currentPatch%canopy_area_profile(cl,ft,iv) - + currentPatch%canopy_area_profile(cl,ft,iv) + currentPatch%elai_profile(cl,ft,iv) = currentPatch%elai_profile(cl,ft,iv) / & - currentPatch%canopy_area_profile(cl,ft,iv) - + currentPatch%canopy_area_profile(cl,ft,iv) + currentPatch%esai_profile(cl,ft,iv) = currentPatch%esai_profile(cl,ft,iv) / & - currentPatch%canopy_area_profile(cl,ft,iv) + currentPatch%canopy_area_profile(cl,ft,iv) end if - + if(currentPatch%tlai_profile(cl,ft,iv)>nearzero )then currentPatch%layer_height_profile(cl,ft,iv) = currentPatch%layer_height_profile(cl,ft,iv) & - /currentPatch%tlai_profile(cl,ft,iv) + /currentPatch%tlai_profile(cl,ft,iv) end if - + enddo - + enddo enddo - + ! -------------------------------------------------------------------------- ! Set the mask that identifies which PFT x can-layer combinations have ! scattering elements in them. @@ -1850,197 +1873,261 @@ subroutine leaf_area_profile( currentSite ) do ft = 1,numpft do iv = 1, currentPatch%nrad(cl,ft) if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then - currentPatch%canopy_mask(cl,ft) = 1 + currentPatch%canopy_mask(cl,ft) = 1 endif end do !iv enddo !ft enddo ! loop over cl - + endif !leaf distribution - + end if - - currentPatch => currentPatch%younger - - enddo !patch - + + currentPatch => currentPatch%younger + + enddo !patch + return - end subroutine leaf_area_profile + end subroutine leaf_area_profile - ! ====================================================================================== + ! ====================================================================================== subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_in,bc_out) - ! ---------------------------------------------------------------------------------- - ! The purpose of this routine is to package output boundary conditions related - ! to vegetation coverage to the host land model. - ! ---------------------------------------------------------------------------------- - - use EDTypesMod , only : ed_patch_type, ed_cohort_type, & - ed_site_type, AREA - use FatesInterfaceTypesMod , only : bc_in_type, bc_out_type - - ! - ! !ARGUMENTS - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) - integer, intent(in) :: fcolumn(nsites) - type(bc_in_type), intent(in) :: bc_in(nsites) - type(bc_out_type), intent(inout) :: bc_out(nsites) - - ! Locals - type (ed_cohort_type) , pointer :: currentCohort - integer :: s, ifp, c, p - type (ed_patch_type) , pointer :: currentPatch - real(r8) :: bare_frac_area - real(r8) :: total_patch_area - real(r8) :: total_canopy_area - real(r8) :: weight ! Weighting for cohort variables in patch - - do s = 1,nsites - - ifp = 0 - total_patch_area = 0._r8 - total_canopy_area = 0._r8 - bc_out(s)%canopy_fraction_pa(:) = 0._r8 - currentPatch => sites(s)%oldest_patch - c = fcolumn(s) - do while(associated(currentPatch)) - 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 - - total_canopy_area = total_canopy_area + bc_out(s)%canopy_fraction_pa(ifp) - - ! Calculate area indices for output boundary to HLM - ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles - ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) - - bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') - bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') - bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') - bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') - - ! Fraction of vegetation free of snow. This is used to flag those - ! patches which shall under-go photosynthesis - ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let - ! FATES internal variables decide if photosynthesis is possible - ! we are essentially calculating it inside FATES to tell the - ! host to tell itself when to do things (circuitous). Just have - ! to determine where else it is used - - if ((bc_out(s)%elai_pa(ifp) + bc_out(s)%esai_pa(ifp)) > 0._r8) then - bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 1.0_r8 - else - bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 0.0_r8 - end if - - currentPatch => currentPatch%younger - end do - - ! Apply patch and canopy area corrections - ! If the difference is above reasonable math precision, apply a fix - ! If the difference is way above reasonable math precision, gracefully exit - - if(abs(total_patch_area-1.0_r8) > rsnbl_math_prec ) then - - if(abs(total_patch_area-1.0_r8) > 1.0e-8_r8 )then - write(fates_log(),*) 'total area is wrong in update_hlm_dynamics',total_patch_area - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if(debug) then - write(fates_log(),*) 'imprecise patch areas in update_hlm_dynamics',total_patch_area - end if - - currentPatch => sites(s)%oldest_patch - ifp = 0 - do while(associated(currentPatch)) - ifp = ifp+1 - bc_out(s)%canopy_fraction_pa(ifp) = bc_out(s)%canopy_fraction_pa(ifp)/total_patch_area - currentPatch => currentPatch%younger - end do - - endif - - ! If running hydro, perform a final check to make sure that we - ! have conserved water. Since this is the very end of the dynamics - ! cycle. No water should had been added or lost to the site during dynamics. - ! With growth and death, we may have shuffled it around. - ! For recruitment, we initialized their water, but flagged them - ! to not be included in the site level balance yet, for they - ! will demand the water for their initialization on the first hydraulics time-step - - if (hlm_use_planthydro.eq.itrue) then - call UpdateH2OVeg(sites(s),bc_out(s),bc_out(s)%plant_stored_h2o_si,1) - end if - - ! Pass FATES Harvested C to bc_out. - call UpdateHarvestC(sites(s),bc_out(s)) - - end do - - ! This call to RecruitWaterStorage() makes an accounting of - ! how much water is used to intialize newly recruited plants. - ! However, it does not actually move water from the soil or create - ! a flux, it is just accounting for diagnostics purposes. The water - ! will not actually be moved until the beginning of the first hydraulics - ! call during the fast timestep sequence - - if (hlm_use_planthydro.eq.itrue) then - call RecruitWaterStorage(nsites,sites,bc_out) - end if - + ! ---------------------------------------------------------------------------------- + ! The purpose of this routine is to package output boundary conditions related + ! to vegetation coverage to the host land model. + ! ---------------------------------------------------------------------------------- + + use EDTypesMod , only : ed_patch_type, ed_cohort_type, & + ed_site_type, AREA + use FatesInterfaceTypesMod , only : bc_in_type, bc_out_type + + ! + ! !ARGUMENTS + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + integer, intent(in) :: fcolumn(nsites) + type(bc_in_type), intent(in) :: bc_in(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + ! Locals + type (ed_cohort_type) , pointer :: currentCohort + integer :: s, ifp, c, p + type (ed_patch_type) , pointer :: currentPatch + real(r8) :: bare_frac_area + real(r8) :: total_patch_area + real(r8) :: total_canopy_area + real(r8) :: total_patch_leaf_stem_area + real(r8) :: weight ! Weighting for cohort variables in patch + + do s = 1,nsites + + ifp = 0 + total_patch_area = 0._r8 + total_canopy_area = 0._r8 + bc_out(s)%canopy_fraction_pa(:) = 0._r8 + bc_out(s)%dleaf_pa(:) = 0._r8 + bc_out(s)%z0m_pa(:) = 0._r8 + bc_out(s)%displa_pa(:) = 0._r8 + + currentPatch => sites(s)%oldest_patch + c = fcolumn(s) + do while(associated(currentPatch)) + + if(currentPatch%nocomp_pft_label.ne.0)then ! ignore the bare-ground-PFT patch entirely for these BC outs + + ifp = ifp+1 + + if ( currentPatch%total_canopy_area-currentPatch%area > 0.000001_r8 ) then + write(fates_log(),*) 'ED: canopy area bigger than area',currentPatch%total_canopy_area ,currentPatch%area + currentPatch%total_canopy_area = currentPatch%area + endif + + if (associated(currentPatch%tallest)) then + bc_out(s)%htop_pa(ifp) = currentPatch%tallest%hite + else + ! FIX(RF,040113) - should this be a parameter for the minimum possible vegetation height? + bc_out(s)%htop_pa(ifp) = 0.1_r8 + endif + + bc_out(s)%hbot_pa(ifp) = max(0._r8, min(0.2_r8, bc_out(s)%htop_pa(ifp)- 1.0_r8)) + + ! Use canopy-only crown area weighting for all cohorts in the patch to define the characteristic + ! Roughness length and displacement height used by the HLM + ! use total LAI + SAI to weight the leaft characteristic dimension + ! Avoid this if running in satellite phenology mode + ! ---------------------------------------------------------------------------- + + if (currentPatch%total_canopy_area > nearzero) then + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + if (currentCohort%canopy_layer .eq. 1) then + weight = min(1.0_r8,currentCohort%c_area/currentPatch%total_canopy_area) + bc_out(s)%z0m_pa(ifp) = bc_out(s)%z0m_pa(ifp) + & + EDPftvarcon_inst%z0mr(currentCohort%pft) * currentCohort%hite * weight + bc_out(s)%displa_pa(ifp) = bc_out(s)%displa_pa(ifp) + & + EDPftvarcon_inst%displar(currentCohort%pft) * currentCohort%hite * weight + endif + currentCohort => currentCohort%taller + end do + + ! for lai, scale to total LAI + SAI in patch. first add up all the LAI and SAI in the patch + total_patch_leaf_stem_area = 0._r8 + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + + if (hlm_use_sp.eq.ifalse) then + ! make sure that allometries are correct + call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& + currentCohort%pft,currentCohort%c_area) + + currentCohort%treelai = tree_lai(currentCohort%prt%GetState(leaf_organ, all_carbon_elements), & + currentCohort%pft, currentCohort%c_area, currentCohort%n, & + currentCohort%canopy_layer, currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + + currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & + currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai, currentCohort%treelai , & + currentCohort%vcmax25top,4) + endif + + total_patch_leaf_stem_area = total_patch_leaf_stem_area + & + (currentCohort%treelai + currentCohort%treesai) * currentCohort%c_area + currentCohort => currentCohort%taller + end do + + ! make sure there is some leaf and stem area + if (total_patch_leaf_stem_area > nearzero) then + currentCohort => currentPatch%shortest + do while(associated(currentCohort)) + ! weight dleaf by the relative totals of leaf and stem area + weight = (currentCohort%treelai + currentCohort%treesai) * currentCohort%c_area / total_patch_leaf_stem_area + bc_out(s)%dleaf_pa(ifp) = bc_out(s)%dleaf_pa(ifp) + & + EDPftvarcon_inst%dleaf(currentCohort%pft) * weight + currentCohort => currentCohort%taller + end do + else + ! dummy case + bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) + endif + else + ! if no canopy, then use dummy values (first PFT) of aerodynamic properties + bc_out(s)%z0m_pa(ifp) = EDPftvarcon_inst%z0mr(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%displa_pa(ifp) = EDPftvarcon_inst%displar(1) * bc_out(s)%htop_pa(ifp) + bc_out(s)%dleaf_pa(ifp) = EDPftvarcon_inst%dleaf(1) + endif + ! ----------------------------------------------------------------------------- + + ! We are assuming here that grass is all located underneath tree canopies. + ! The alternative is to assume it is all spatial distinct from tree canopies. + ! In which case, the bare area would have to be reduced by the grass area... + ! currentPatch%total_canopy_area/currentPatch%area is fraction of this patch cover by plants + ! currentPatch%area/AREA is the fraction of the soil covered by this patch. + + if(currentPatch%area.gt.0.0_r8)then + bc_out(s)%canopy_fraction_pa(ifp) = & + min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)*(currentPatch%area/AREA) + else + bc_out(s)%canopy_fraction_pa(ifp) = 0.0_r8 + endif + + bare_frac_area = (1.0_r8 - min(1.0_r8,currentPatch%total_canopy_area/currentPatch%area)) * & + (currentPatch%area/AREA) + + total_patch_area = total_patch_area + bc_out(s)%canopy_fraction_pa(ifp) + bare_frac_area + + total_canopy_area = total_canopy_area + bc_out(s)%canopy_fraction_pa(ifp) + + bc_out(s)%nocomp_pft_label_pa(ifp) = currentPatch%nocomp_pft_label + + ! Calculate area indices for output boundary to HLM + ! It is assumed that cpatch%canopy_area_profile and cpat%xai_profiles + ! have been updated (ie ed_leaf_area_profile has been called since dynamics has been called) + + bc_out(s)%elai_pa(ifp) = calc_areaindex(currentPatch,'elai') + bc_out(s)%tlai_pa(ifp) = calc_areaindex(currentPatch,'tlai') + bc_out(s)%esai_pa(ifp) = calc_areaindex(currentPatch,'esai') + bc_out(s)%tsai_pa(ifp) = calc_areaindex(currentPatch,'tsai') + + ! Fraction of vegetation free of snow. This is used to flag those + ! patches which shall under-go photosynthesis + ! INTERF-TODO: we may want to stop using frac_veg_nosno_alb and let + ! FATES internal variables decide if photosynthesis is possible + ! we are essentially calculating it inside FATES to tell the + ! host to tell itself when to do things (circuitous). Just have + ! to determine where else it is used + + if ((bc_out(s)%elai_pa(ifp) + bc_out(s)%esai_pa(ifp)) > 0._r8) then + bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 1.0_r8 + else + bc_out(s)%frac_veg_nosno_alb_pa(ifp) = 0.0_r8 + end if + + else ! nocomp or SP, and currentPatch%nocomp_pft_label .eq. 0 + + total_patch_area = total_patch_area + currentPatch%area/AREA + + end if + currentPatch => currentPatch%younger + end do + + ! Apply patch and canopy area corrections + ! If the difference is above reasonable math precision, apply a fix + ! If the difference is way above reasonable math precision, gracefully exit + + if(abs(total_patch_area-1.0_r8) > rsnbl_math_prec ) then + + if(abs(total_patch_area-1.0_r8) > 1.0e-8_r8 )then + write(fates_log(),*) 'total area is wrong in update_hlm_dynamics',total_patch_area + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(debug) then + write(fates_log(),*) 'imprecise patch areas in update_hlm_dynamics',total_patch_area + end if + + currentPatch => sites(s)%oldest_patch + ifp = 0 + do while(associated(currentPatch)) + if(currentPatch%nocomp_pft_label.ne.0)then ! for vegetated patches only + ifp = ifp+1 + bc_out(s)%canopy_fraction_pa(ifp) = bc_out(s)%canopy_fraction_pa(ifp)/total_patch_area + endif ! veg patch + + currentPatch => currentPatch%younger + end do + + endif + + ! If running hydro, perform a final check to make sure that we + ! have conserved water. Since this is the very end of the dynamics + ! cycle. No water should had been added or lost to the site during dynamics. + ! With growth and death, we may have shuffled it around. + ! For recruitment, we initialized their water, but flagged them + ! to not be included in the site level balance yet, for they + ! will demand the water for their initialization on the first hydraulics time-step + + if (hlm_use_planthydro.eq.itrue) then + call UpdateH2OVeg(sites(s),bc_out(s),bc_out(s)%plant_stored_h2o_si,1) + end if + + ! Pass FATES Harvested C to bc_out. + call UpdateHarvestC(sites(s),bc_out(s)) + + end do + + ! This call to RecruitWaterStorage() makes an accounting of + ! how much water is used to intialize newly recruited plants. + ! However, it does not actually move water from the soil or create + ! a flux, it is just accounting for diagnostics purposes. The water + ! will not actually be moved until the beginning of the first hydraulics + ! call during the fast timestep sequence + + if (hlm_use_planthydro.eq.itrue) then + call RecruitWaterStorage(nsites,sites,bc_out) + end if + end subroutine update_hlm_dynamics @@ -2048,147 +2135,152 @@ end subroutine update_hlm_dynamics function calc_areaindex(cpatch,ai_type) result(ai) - ! ---------------------------------------------------------------------------------- - ! This subroutine calculates the exposed leaf area index of a patch - ! this is the square meters of leaf per square meter of ground area - ! It does so by integrating over the depth and functional type profile of leaf area - ! which are per area of crown. This value has to be scaled by crown area to convert - ! to ground area. - ! ---------------------------------------------------------------------------------- - - ! Arguments - type(ed_patch_type),intent(in), target :: cpatch - character(len=*),intent(in) :: ai_type - - integer :: cl,ft - real(r8) :: ai - ! TODO: THIS MIN LAI IS AN ARTIFACT FROM TESTING LONG-AGO AND SHOULD BE REMOVED - ! THIS HAS BEEN KEPT THUS FAR TO MAINTAIN B4B IN TESTING OTHER COMMITS - real(r8),parameter :: ai_min = 0.1_r8 - - real(r8),pointer :: ai_profile - - ai = 0._r8 - if (trim(ai_type) == 'elai') then - do cl = 1,cpatch%NCL_p - do ft = 1,numpft - ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & - cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft))) - enddo - enddo - elseif (trim(ai_type) == 'tlai') then - do cl = 1,cpatch%NCL_p - do ft = 1,numpft - ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & - cpatch%tlai_profile(cl,ft,1:cpatch%nrad(cl,ft))) - enddo - enddo - elseif (trim(ai_type) == 'esai') then - do cl = 1,cpatch%NCL_p - do ft = 1,numpft - ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & - cpatch%esai_profile(cl,ft,1:cpatch%nrad(cl,ft))) - enddo - enddo - elseif (trim(ai_type) == 'tsai') then - do cl = 1,cpatch%NCL_p - do ft = 1,numpft - ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & - cpatch%tsai_profile(cl,ft,1:cpatch%nrad(cl,ft))) - enddo - enddo - else - - write(fates_log(),*) 'Unsupported area index sent to calc_areaindex' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ai = max(ai_min,ai) - - return + ! ---------------------------------------------------------------------------------- + ! This subroutine calculates the exposed leaf area index of a patch + ! this is the square meters of leaf per square meter of ground area + ! It does so by integrating over the depth and functional type profile of leaf area + ! which are per area of crown. This value has to be scaled by crown area to convert + ! to ground area. + ! ---------------------------------------------------------------------------------- + + ! Arguments + type(ed_patch_type),intent(in), target :: cpatch + character(len=*),intent(in) :: ai_type + + integer :: cl,ft + real(r8) :: ai + ! TODO: THIS MIN LAI IS AN ARTIFACT FROM TESTING LONG-AGO AND SHOULD BE REMOVED + ! THIS HAS BEEN KEPT THUS FAR TO MAINTAIN B4B IN TESTING OTHER COMMITS + real(r8),parameter :: ai_min = 0.1_r8 + + real(r8),pointer :: ai_profile + + ai = 0._r8 + if (trim(ai_type) == 'elai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%elai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + elseif (trim(ai_type) == 'tlai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%tlai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + + elseif (trim(ai_type) == 'esai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%esai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + elseif (trim(ai_type) == 'tsai') then + do cl = 1,cpatch%NCL_p + do ft = 1,numpft + ai = ai + sum(cpatch%canopy_area_profile(cl,ft,1:cpatch%nrad(cl,ft)) * & + cpatch%tsai_profile(cl,ft,1:cpatch%nrad(cl,ft))) + enddo + enddo + else + + write(fates_log(),*) 'Unsupported area index sent to calc_areaindex' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ai = max(ai_min,ai) + + return end function calc_areaindex ! =============================================================================================== - + subroutine CanopyLayerArea(currentPatch,site_spread,layer_index,layer_area) - - ! -------------------------------------------------------------------------------------------- - ! This function calculates the total crown area footprint for a desired layer of the canopy - ! within a patch. - ! The return units are the same as patch%area, which is m2 - ! --------------------------------------------------------------------------------------------- - - ! Arguments - type(ed_patch_type),intent(inout), target :: currentPatch - real(r8),intent(in) :: site_spread - integer,intent(in) :: layer_index - real(r8),intent(inout) :: layer_area - - type(ed_cohort_type), pointer :: currentCohort - - - layer_area = 0.0_r8 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - call carea_allom(currentCohort%dbh,currentCohort%n,site_spread, & - currentCohort%pft,currentCohort%c_area) - if (currentCohort%canopy_layer .eq. layer_index) then - layer_area = layer_area + currentCohort%c_area - end if - currentCohort => currentCohort%shorter - enddo - return + + ! -------------------------------------------------------------------------------------------- + ! This function calculates the total crown area footprint for a desired layer of the canopy + ! within a patch. + ! The return units are the same as patch%area, which is m2 + ! --------------------------------------------------------------------------------------------- + + ! Arguments + type(ed_patch_type),intent(inout), target :: currentPatch + real(r8),intent(in) :: site_spread + integer,intent(in) :: layer_index + real(r8),intent(inout) :: layer_area + + type(ed_cohort_type), pointer :: currentCohort + + + layer_area = 0.0_r8 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + call carea_allom(currentCohort%dbh,currentCohort%n,site_spread, & + currentCohort%pft,currentCohort%c_area) + if (currentCohort%canopy_layer .eq. layer_index) then + layer_area = layer_area + currentCohort%c_area + end if + currentCohort => currentCohort%shorter + enddo + return end subroutine CanopyLayerArea ! =============================================================================================== - + function NumPotentialCanopyLayers(currentPatch,site_spread,include_substory) result(z) - ! -------------------------------------------------------------------------------------------- - ! Calculate the number of canopy layers in this patch. - ! This simple call only determines total layering by querying the cohorts - ! which layer they are in, it doesn't do any size evaluation. - ! It may also, optionally, account for the temporary "substory", which is the imaginary - ! layer below the understory which will be needed to temporarily accomodate demotions from - ! the understory in the event the understory has reached maximum allowable area. - ! -------------------------------------------------------------------------------------------- - - type(ed_patch_type),target :: currentPatch - real(r8),intent(in) :: site_spread - logical :: include_substory - - type(ed_cohort_type),pointer :: currentCohort - - integer :: z - real(r8) :: c_area - real(r8) :: arealayer - - z = 1 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - z = max(z,currentCohort%canopy_layer) - currentCohort => currentCohort%shorter - enddo - - if(include_substory)then - arealayer = 0.0 - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) - if(currentCohort%canopy_layer == z) then - call carea_allom(currentCohort%dbh,currentCohort%n,site_spread,currentCohort%pft,c_area) - arealayer = arealayer + c_area - end if - currentCohort => currentCohort%shorter - enddo - - ! Does the bottom layer have more than a full canopy? - ! If so we need to make another layer. - if(arealayer > currentPatch%area)then - z = z + 1 - endif - end if - + ! -------------------------------------------------------------------------------------------- + ! Calculate the number of canopy layers in this patch. + ! This simple call only determines total layering by querying the cohorts + ! which layer they are in, it doesn't do any size evaluation. + ! It may also, optionally, account for the temporary "substory", which is the imaginary + ! layer below the understory which will be needed to temporarily accomodate demotions from + ! the understory in the event the understory has reached maximum allowable area. + ! -------------------------------------------------------------------------------------------- + + type(ed_patch_type),target :: currentPatch + real(r8),intent(in) :: site_spread + logical :: include_substory + + type(ed_cohort_type),pointer :: currentCohort + + integer :: z + real(r8) :: c_area + real(r8) :: arealayer + + z = 1 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + z = max(z,currentCohort%canopy_layer) + currentCohort => currentCohort%shorter + enddo + + if(include_substory)then + arealayer = 0.0 + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + if(currentCohort%canopy_layer == z) then + call carea_allom(currentCohort%dbh,currentCohort%n,site_spread,currentCohort%pft,c_area) + arealayer = arealayer + c_area + end if + currentCohort => currentCohort%shorter + enddo + + ! Does the bottom layer have more than a full canopy? + ! If so we need to make another layer. + if(arealayer > currentPatch%area)then + z = z + 1 + if(hlm_use_sp.eq.itrue)then + write(fates_log(),*) 'SPmode, canopy_layer full:',arealayer,currentPatch%area + end if + + endif + end if + end function NumPotentialCanopyLayers end module EDCanopyStructureMod diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index f29fd27fc4..4318ee469f 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -1,21 +1,24 @@ module EDCohortDynamicsMod ! ! !DESCRIPTION: - ! Cohort stuctures in ED. + ! Cohort stuctures in ED. ! - ! !USES: + ! !USES: use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log use FatesInterfaceTypesMod , only : hlm_freq_day use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking + use FatesInterfaceTypesMod , only : hlm_is_restart use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : fates_unset_int use FatesConstantsMod , only : itrue,ifalse use FatesConstantsMod , only : fates_unset_r8 use FatesConstantsMod , only : nearzero use FatesConstantsMod , only : calloc_abs_error + use FatesRunningMeanMod , only : ema_lpa use FatesInterfaceTypesMod , only : hlm_days_per_year use FatesInterfaceTypesMod , only : nleafage use SFParamsMod , only : SF_val_CWD_frac @@ -66,7 +69,7 @@ module EDCohortDynamicsMod use FatesAllometryMod , only : ForceDBH use FatesAllometryMod , only : tree_lai, tree_sai use FatesAllometryMod , only : set_root_fraction - use PRTGenericMod, only : prt_carbon_allom_hyp + use PRTGenericMod, only : prt_carbon_allom_hyp use PRTGenericMod, only : prt_cnp_flex_allom_hyp use PRTGenericMod, only : prt_vartypes use PRTGenericMod, only : all_carbon_elements @@ -91,14 +94,14 @@ module EDCohortDynamicsMod use PRTAllometricCNPMod, only : acnp_bc_in_id_pft, acnp_bc_in_id_ctrim use PRTAllometricCNPMod, only : acnp_bc_in_id_lstat, acnp_bc_inout_id_dbh use PRTAllometricCNPMod, only : acnp_bc_inout_id_rmaint_def, acnp_bc_in_id_netdc - use PRTAllometricCNPMod, only : acnp_bc_in_id_netdn, acnp_bc_in_id_netdp + use PRTAllometricCNPMod, only : acnp_bc_in_id_netdnh4, acnp_bc_in_id_netdno3, acnp_bc_in_id_netdp use PRTAllometricCNPMod, only : acnp_bc_out_id_cefflux, acnp_bc_out_id_nefflux use PRTAllometricCNPMod, only : acnp_bc_out_id_pefflux - use PRTAllometricCNPMod, only : acnp_bc_out_id_ngrow,acnp_bc_out_id_nmax - use PRTAllometricCNPMod, only : acnp_bc_out_id_pgrow,acnp_bc_out_id_pmax - - - use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + use PRTAllometricCNPMod, only : acnp_bc_out_id_nneed + use PRTAllometricCNPMod, only : acnp_bc_out_id_pneed + + + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) ! CIME globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -110,6 +113,7 @@ module EDCohortDynamicsMod public :: zero_cohort public :: nan_cohort public :: terminate_cohorts + public :: terminate_cohort public :: fuse_cohorts public :: insert_cohort public :: sort_cohorts @@ -132,7 +136,7 @@ module EDCohortDynamicsMod integer, parameter, private :: conserve_dbh_and_number_not_crownarea = 2 integer, parameter, private :: cohort_fusion_conservation_method = conserve_crownarea_and_number_not_dbh - + ! 10/30/09: Created by Rosie Fisher !-------------------------------------------------------------------------------------! @@ -141,10 +145,10 @@ module EDCohortDynamicsMod !-------------------------------------------------------------------------------------! - + subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & prt, laimemory, sapwmemory, structmemory, & - status, recruitstatus,ctrim, clayer, spread, bc_in) + status, recruitstatus,ctrim, carea, clayer, spread, bc_in) ! ! !DESCRIPTION: ! create new cohort @@ -158,57 +162,58 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & ! ! !USES: ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type), intent(inout), pointer :: patchptr integer, intent(in) :: pft ! Cohort Plant Functional Type - integer, intent(in) :: clayer ! canopy status of cohort + integer, intent(in) :: clayer ! canopy status of cohort ! (1 = canopy, 2 = understorey, etc.) - integer, intent(in) :: status ! growth status of plant + integer, intent(in) :: status ! growth status of plant ! (2 = leaves on , 1 = leaves off) - integer, intent(in) :: recruitstatus ! recruit status of plant + integer, intent(in) :: recruitstatus ! recruit status of plant ! (1 = recruitment , 0 = other) - real(r8), intent(in) :: nn ! number of individuals in cohort + real(r8), intent(in) :: nn ! number of individuals in cohort ! per 'area' (10000m2 default) real(r8), intent(in) :: hite ! height: meters real(r8), intent(in) :: coage ! cohort age in years real(r8), intent(in) :: dbh ! dbh: cm class(prt_vartypes),target :: prt ! The allocated PARTEH ! object - real(r8), intent(in) :: laimemory ! target leaf biomass- set from + real(r8), intent(in) :: laimemory ! target leaf biomass- set from ! previous year: kGC per indiv - real(r8), intent(in) :: sapwmemory ! target sapwood biomass- set from - ! previous year: kGC per indiv - real(r8), intent(in) :: structmemory ! target structural biomass- set from - ! previous year: kGC per indiv - real(r8), intent(in) :: ctrim ! What is the fraction of the maximum + real(r8), intent(in) :: sapwmemory ! target sapwood biomass- set from + ! previous year: kGC per indiv + real(r8), intent(in) :: structmemory ! target structural biomass- set from + ! previous year: kGC per indiv + real(r8), intent(in) :: ctrim ! What is the fraction of the maximum ! leaf biomass that we are targeting? - real(r8), intent(in) :: spread ! The community assembly effects how + real(r8), intent(in) :: spread ! The community assembly effects how ! spread crowns are in horizontal space + real(r8), intent(in) :: carea ! area of cohort ONLY USED IN SP MODE. type(bc_in_type), intent(in) :: bc_in ! External boundary conditions - + ! !LOCAL VARIABLES: type(ed_cohort_type), pointer :: new_cohort ! Pointer to New Cohort structure. - type(ed_cohort_type), pointer :: storesmallcohort - type(ed_cohort_type), pointer :: storebigcohort - integer :: iage ! loop counter for leaf age classes + type(ed_cohort_type), pointer :: storesmallcohort + type(ed_cohort_type), pointer :: storebigcohort + integer :: iage ! loop counter for leaf age classes real(r8) :: leaf_c ! total leaf carbon integer :: tnull,snull ! are the tallest and shortest cohorts allocate integer :: nlevrhiz ! number of rhizosphere layers !---------------------------------------------------------------------- - + allocate(new_cohort) call nan_cohort(new_cohort) ! Make everything in the cohort not-a-number - call zero_cohort(new_cohort) ! Zero things that need to be zeroed. + call zero_cohort(new_cohort) ! Zero things that need to be zeroed. ! Point to the PARTEH object new_cohort%prt => prt - + ! The PARTEH cohort object should be allocated and already ! initialized in this routine. call new_cohort%prt%CheckInitialConditions() @@ -223,7 +228,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & new_cohort%patchptr => patchptr - new_cohort%pft = pft + new_cohort%pft = pft new_cohort%status_coh = status new_cohort%n = nn new_cohort%hite = hite @@ -249,12 +254,12 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & ! we don't need to update this ever if cohort age tracking is off call coagetype_class_index(new_cohort%coage, new_cohort%pft, & new_cohort%coage_class,new_cohort%coage_by_pft_class) - + ! This routine may be called during restarts, and at this point in the call sequence ! the actual cohort data is unknown, as this is really only used for allocation ! In these cases, testing if things like biomass are reasonable is pre-mature ! However, in this part of the code, we will pass in nominal values for size, number and type - + if (new_cohort%dbh <= 0._r8 .or. new_cohort%n == 0._r8 .or. new_cohort%pft == 0 ) then write(fates_log(),*) 'ED: something is zero in create_cohort', & new_cohort%dbh,new_cohort%n, & @@ -263,26 +268,31 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & endif ! Assign canopy extent and depth - call carea_allom(new_cohort%dbh,new_cohort%n,spread,new_cohort%pft,new_cohort%c_area) - + if(hlm_use_sp.eq.ifalse)then + call carea_allom(new_cohort%dbh,new_cohort%n,spread,new_cohort%pft,new_cohort%c_area) + else + new_cohort%c_area = carea ! set this from previously precision-controlled value in SP mode + endif ! Query PARTEH for the leaf carbon [kg] leaf_c = new_cohort%prt%GetState(leaf_organ,carbon12_element) new_cohort%treelai = tree_lai(leaf_c, new_cohort%pft, new_cohort%c_area, & new_cohort%n, new_cohort%canopy_layer, & - patchptr%canopy_layer_tlai,new_cohort%vcmax25top ) + patchptr%canopy_layer_tlai,new_cohort%vcmax25top ) + if(hlm_use_sp.eq.ifalse)then new_cohort%treesai = tree_sai(new_cohort%pft, new_cohort%dbh, new_cohort%canopy_trim, & new_cohort%c_area, new_cohort%n, new_cohort%canopy_layer, & - patchptr%canopy_layer_tlai, new_cohort%treelai,new_cohort%vcmax25top,2 ) + patchptr%canopy_layer_tlai, new_cohort%treelai,new_cohort%vcmax25top,2 ) + end if new_cohort%lai = new_cohort%treelai * new_cohort%c_area/patchptr%area ! Put cohort at the right place in the linked list storebigcohort => patchptr%tallest - storesmallcohort => patchptr%shortest + storesmallcohort => patchptr%shortest if (associated(patchptr%tallest)) then tnull = 0 @@ -295,17 +305,23 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & snull = 0 else snull = 1 - patchptr%shortest => new_cohort + patchptr%shortest => new_cohort endif call InitPRTBoundaryConditions(new_cohort) - + ! Allocate running mean functions + + ! (Keeping as an example) + !! allocate(new_cohort%tveg_lpa) + !! call new_cohort%tveg_lpa%InitRMean(ema_lpa,init_value=patchptr%tveg_lpa%GetMean()) + + ! Recuits do not have mortality rates, nor have they moved any ! carbon when they are created. They will bias our statistics ! until they have experienced a full day. We need a newly recruited flag. - ! This flag will be set to false after it has experienced + ! This flag will be set to false after it has experienced ! growth, disturbance and mortality. new_cohort%isnew = .true. @@ -317,19 +333,19 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & call InitHydrCohort(currentSite,new_cohort) ! This calculates node heights - call UpdatePlantHydrNodes(new_cohort%co_hydr,new_cohort%pft, & + call UpdatePlantHydrNodes(new_cohort,new_cohort%pft, & new_cohort%hite,currentSite%si_hydr) ! This calculates volumes and lengths call UpdatePlantHydrLenVol(new_cohort,currentSite%si_hydr) - + ! This updates the Kmax's of the plant's compartments call UpdatePlantKmax(new_cohort%co_hydr,new_cohort,currentSite%si_hydr) ! Since this is a newly initialized plant, we set the previous compartment-size ! equal to the ones we just calculated. call SavePreviousCompartmentVolumes(new_cohort%co_hydr) - + ! This comes up with starter suctions and then water contents ! based on the soil values call InitPlantHydStates(currentSite,new_cohort) @@ -349,11 +365,11 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & endif endif - + call insert_cohort(new_cohort, patchptr%tallest, patchptr%shortest, tnull, snull, & storebigcohort, storesmallcohort) - patchptr%tallest => storebigcohort + patchptr%tallest => storebigcohort patchptr%shortest => storesmallcohort end subroutine create_cohort @@ -361,7 +377,7 @@ end subroutine create_cohort ! ------------------------------------------------------------------------------------- subroutine InitPRTBoundaryConditions(new_cohort) - + ! Set the boundary conditions that flow in an out of the PARTEH ! allocation hypotheses. Each of these calls to "RegsterBC" are simply ! setting pointers. @@ -385,9 +401,9 @@ subroutine InitPRTBoundaryConditions(new_cohort) select case(hlm_parteh_mode) case (prt_carbon_allom_hyp) - + ! Register boundary conditions for the Carbon Only Allometric Hypothesis - + call new_cohort%prt%RegisterBCInOut(ac_bc_inout_id_dbh,bc_rval = new_cohort%dbh) call new_cohort%prt%RegisterBCInOut(ac_bc_inout_id_netdc,bc_rval = new_cohort%npp_acc) call new_cohort%prt%RegisterBCIn(ac_bc_in_id_pft,bc_ival = new_cohort%pft) @@ -400,34 +416,33 @@ subroutine InitPRTBoundaryConditions(new_cohort) call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_ctrim,bc_rval = new_cohort%canopy_trim) call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_lstat,bc_ival = new_cohort%status_coh) call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdc, bc_rval = new_cohort%npp_acc) - call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdn, bc_rval = new_cohort%daily_n_uptake) + call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdnh4, bc_rval = new_cohort%daily_nh4_uptake) + call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdno3, bc_rval = new_cohort%daily_no3_uptake) call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdp, bc_rval = new_cohort%daily_p_uptake) - + call new_cohort%prt%RegisterBCInOut(acnp_bc_inout_id_dbh,bc_rval = new_cohort%dbh) call new_cohort%prt%RegisterBCInOut(acnp_bc_inout_id_rmaint_def,bc_rval = new_cohort%resp_m_def) call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_cefflux, bc_rval = new_cohort%daily_c_efflux) call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_nefflux, bc_rval = new_cohort%daily_n_efflux) call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_pefflux, bc_rval = new_cohort%daily_p_efflux) - call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_ngrow, bc_rval = new_cohort%daily_n_need1) - call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_nmax, bc_rval = new_cohort%daily_n_need2) - call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_pgrow, bc_rval = new_cohort%daily_p_need1) - call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_pmax, bc_rval = new_cohort%daily_p_need2) - - + call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_nneed, bc_rval = new_cohort%daily_n_need) + call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_pneed, bc_rval = new_cohort%daily_p_need) + + case DEFAULT - + write(fates_log(),*) 'You specified an unknown PRT module' write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) - + end select - + end subroutine InitPRTBoundaryConditions ! ------------------------------------------------------------------------------------! - + subroutine InitPRTObject(prt) ! ----------------------------------------------------------------------------------- @@ -436,7 +451,7 @@ subroutine InitPRTObject(prt) ! The argument that is passed in is a pointer that is then associated with this ! newly allocated object. ! The object that is allocated is the specific extended class for the hypothesis - ! of choice. + ! of choice. ! Following this, the object and its internal mappings are initialized. ! This routine does NOT set any of the initial conditions, or boundary conditions ! such as the organ/element masses. Those are handled after this call. @@ -445,36 +460,36 @@ subroutine InitPRTObject(prt) ! Argument class(prt_vartypes), pointer :: prt - + ! Potential Extended types class(callom_prt_vartypes), pointer :: c_allom_prt class(cnp_allom_prt_vartypes), pointer :: cnp_allom_prt - + select case(hlm_parteh_mode) case (prt_carbon_allom_hyp) - + allocate(c_allom_prt) prt => c_allom_prt - + case (prt_cnp_flex_allom_hyp) - + allocate(cnp_allom_prt) prt => cnp_allom_prt case DEFAULT - + write(fates_log(),*) 'You specified an unknown PRT module' write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) - + end select - + ! This is the call to allocate the data structures in the PRT object ! This call will be extended to each specific class. call prt%InitPRTVartype() - + return end subroutine InitPRTObject @@ -485,14 +500,14 @@ end subroutine InitPRTObject subroutine nan_cohort(cc_p) ! ! !DESCRIPTION: - ! Make all the cohort variables NaN so they aren't used before defined. + ! Make all the cohort variables NaN so they aren't used before defined. ! ! !USES: use FatesConstantsMod, only : fates_unset_int ! - ! !ARGUMENTS + ! !ARGUMENTS type (ed_cohort_type), intent(inout), target :: cc_p ! ! !LOCAL VARIABLES: @@ -501,35 +516,35 @@ subroutine nan_cohort(cc_p) currentCohort => cc_p - currentCohort%taller => null() ! pointer to next tallest cohort - currentCohort%shorter => null() ! pointer to next shorter cohort + currentCohort%taller => null() ! pointer to next tallest cohort + currentCohort%shorter => null() ! pointer to next shorter cohort currentCohort%patchptr => null() ! pointer to patch that cohort is in - nullify(currentCohort%taller) - nullify(currentCohort%shorter) - nullify(currentCohort%patchptr) + nullify(currentCohort%taller) + nullify(currentCohort%shorter) + nullify(currentCohort%patchptr) ! VEGETATION STRUCTURE - currentCohort%pft = fates_unset_int ! pft number + currentCohort%pft = fates_unset_int ! pft number currentCohort%indexnumber = fates_unset_int ! unique number for each cohort. (within clump?) - currentCohort%canopy_layer = fates_unset_int ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) - currentCohort%canopy_layer_yesterday = nan ! recent canopy status of cohort (1 = canopy, 2 = understorey, etc.) + currentCohort%canopy_layer = fates_unset_int ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) + currentCohort%canopy_layer_yesterday = nan ! recent canopy status of cohort (1 = canopy, 2 = understorey, etc.) currentCohort%NV = fates_unset_int ! Number of leaf layers: - currentCohort%status_coh = fates_unset_int ! growth status of plant (2 = leaves on , 1 = leaves off) currentCohort%size_class = fates_unset_int ! size class index currentCohort%size_class_lasttimestep = fates_unset_int ! size class index currentCohort%size_by_pft_class = fates_unset_int ! size by pft classification index currentCohort%coage_class = fates_unset_int ! cohort age class index - currentCohort%coage_by_pft_class = fates_unset_int ! cohort age by pft class index + currentCohort%coage_by_pft_class = fates_unset_int ! cohort age by pft class index - currentCohort%n = nan ! number of individuals in cohort per 'area' (10000m2 default) + currentCohort%n = nan ! number of individuals in cohort per 'area' (10000m2 default) currentCohort%dbh = nan ! 'diameter at breast height' in cm currentCohort%coage = nan ! age of the cohort in years - currentCohort%hite = nan ! height: meters + currentCohort%hite = nan ! height: meters currentCohort%laimemory = nan ! target leaf biomass- set from previous year: kGC per indiv currentCohort%sapwmemory = nan ! target sapwood biomass- set from previous year: kGC per indiv currentCohort%structmemory = nan ! target structural biomass- set from previous year: kGC per indiv - currentCohort%lai = nan ! leaf area index of cohort m2/m2 + currentCohort%lai = nan ! leaf area index of cohort m2/m2 currentCohort%sai = nan ! stem area index of cohort m2/m2 currentCohort%g_sb_laweight = nan ! Total leaf conductance of cohort (stomata+blayer) weighted by leaf-area [m/s]*[m2] currentCohort%canopy_trim = nan ! What is the fraction of the maximum leaf biomass that we are targeting? :- @@ -540,18 +555,18 @@ subroutine nan_cohort(cc_p) currentCohort%treelai = nan ! lai of tree (total leaf area (m2) / canopy area (m2) currentCohort%treesai = nan ! stem area index of tree (total stem area (m2) / canopy area (m2) currentCohort%seed_prod = nan - currentCohort%vcmax25top = nan - currentCohort%jmax25top = nan - currentCohort%tpu25top = nan - currentCohort%kp25top = nan + currentCohort%vcmax25top = nan + currentCohort%jmax25top = nan + currentCohort%tpu25top = nan + currentCohort%kp25top = nan - ! CARBON FLUXES + ! CARBON FLUXES currentCohort%gpp_acc_hold = nan ! GPP: kgC/indiv/year currentCohort%gpp_tstep = nan ! GPP: kgC/indiv/timestep - currentCohort%gpp_acc = nan ! GPP: kgC/indiv/day + currentCohort%gpp_acc = nan ! GPP: kgC/indiv/day currentCohort%npp_acc_hold = nan ! NPP: kgC/indiv/year currentCohort%npp_tstep = nan ! NPP: kGC/indiv/timestep - currentCohort%npp_acc = nan ! NPP: kgC/indiv/day + currentCohort%npp_acc = nan ! NPP: kgC/indiv/day currentCohort%year_net_uptake(:) = nan ! Net uptake of individual leaf layers kgC/m2/year currentCohort%ts_net_uptake(:) = nan ! Net uptake of individual leaf layers kgC/m2/s currentCohort%resp_acc_hold = nan ! RESP: kgC/indiv/year @@ -559,19 +574,18 @@ subroutine nan_cohort(cc_p) currentCohort%resp_acc = nan ! RESP: kGC/cohort/day ! Fluxes from nutrient allocation - currentCohort%daily_n_uptake = nan + currentCohort%daily_nh4_uptake = nan + currentCohort%daily_no3_uptake = nan currentCohort%daily_p_uptake = nan currentCohort%daily_c_efflux = nan currentCohort%daily_n_efflux = nan currentCohort%daily_p_efflux = nan - currentCohort%daily_n_need1 = nan - currentCohort%daily_n_need2 = nan - currentCohort%daily_p_need1 = nan - currentCohort%daily_p_need2 = nan + currentCohort%daily_n_need = nan + currentCohort%daily_p_need = nan currentCohort%daily_n_demand = nan currentCohort%daily_p_demand = nan - - + + currentCohort%c13disc_clm = nan ! C13 discrimination, per mil at indiv/timestep currentCohort%c13disc_acc = nan ! C13 discrimination, per mil at indiv/timestep at indiv/daily at the end of a day @@ -579,9 +593,9 @@ subroutine nan_cohort(cc_p) currentCohort%rdark = nan currentCohort%resp_m = nan ! Maintenance respiration. kGC/cohort/year currentCohort%resp_m_def = nan ! Maintenance respiration deficit kgC/plant - currentCohort%livestem_mr = nan ! Live stem maintenance respiration. kgC/indiv/s-1 - currentCohort%livecroot_mr = nan ! Coarse root maintenance respiration. kgC/indiv/s-1 - currentCohort%froot_mr = nan ! Fine root maintenance respiration. kgC/indiv/s-1 + currentCohort%livestem_mr = nan ! Live stem maintenance respiration. kgC/indiv/s-1 + currentCohort%livecroot_mr = nan ! Coarse root maintenance respiration. kgC/indiv/s-1 + currentCohort%froot_mr = nan ! Fine root maintenance respiration. kgC/indiv/s-1 currentCohort%resp_g_tstep = nan ! Growth respiration. kGC/indiv/timestep @@ -599,10 +613,10 @@ subroutine nan_cohort(cc_p) currentCohort%treesai = nan ! stem area index of tree (total stem area (m2) / canopy area (m2) - ! VARIABLES NEEDED FOR INTEGRATION - currentCohort%dndt = nan ! time derivative of cohort size - currentCohort%dhdt = nan ! time derivative of height - currentCohort%ddbhdt = nan ! time derivative of dbh + ! VARIABLES NEEDED FOR INTEGRATION + currentCohort%dndt = nan ! time derivative of cohort size + currentCohort%dhdt = nan ! time derivative of height + currentCohort%ddbhdt = nan ! time derivative of dbh ! FIRE currentCohort%fraction_crown_burned = nan ! proportion of crown affected by fire @@ -617,12 +631,12 @@ end subroutine nan_cohort subroutine zero_cohort(cc_p) ! ! !DESCRIPTION: - ! Zero variables that need to be accounted for if - ! this cohort is altered before they are defined. + ! Zero variables that need to be accounted for if + ! this cohort is altered before they are defined. ! ! !USES: ! - ! !ARGUMENTS + ! !ARGUMENTS type (ed_cohort_type), intent(inout), target :: cc_p ! ! !LOCAL VARIABLES: @@ -631,8 +645,8 @@ subroutine zero_cohort(cc_p) currentCohort => cc_p - currentCohort%NV = 0 - currentCohort%status_coh = 0 + currentCohort%NV = 0 + currentCohort%status_coh = 0 currentCohort%rdark = 0._r8 currentCohort%resp_m = 0._r8 currentCohort%resp_m_def = 0._r8 @@ -640,7 +654,7 @@ subroutine zero_cohort(cc_p) currentCohort%livestem_mr = 0._r8 currentCohort%livecroot_mr = 0._r8 currentCohort%froot_mr = 0._r8 - currentCohort%fire_mort = 0._r8 + currentCohort%fire_mort = 0._r8 currentcohort%npp_acc = 0._r8 currentcohort%gpp_acc = 0._r8 currentcohort%resp_acc = 0._r8 @@ -649,28 +663,28 @@ subroutine zero_cohort(cc_p) currentcohort%resp_tstep = 0._r8 currentcohort%resp_acc_hold = 0._r8 - currentcohort%year_net_uptake(:) = 999._r8 ! this needs to be 999, or trimming of new cohorts will break. + currentcohort%year_net_uptake(:) = 999._r8 ! this needs to be 999, or trimming of new cohorts will break. currentcohort%ts_net_uptake(:) = 0._r8 - currentcohort%fraction_crown_burned = 0._r8 + currentcohort%fraction_crown_burned = 0._r8 currentCohort%size_class = 1 currentCohort%coage_class = 1 currentCohort%seed_prod = 0._r8 currentCohort%size_class_lasttimestep = 0 - currentcohort%npp_acc_hold = 0._r8 - currentcohort%gpp_acc_hold = 0._r8 - currentcohort%dmort = 0._r8 - currentcohort%g_sb_laweight = 0._r8 - currentcohort%treesai = 0._r8 + currentcohort%npp_acc_hold = 0._r8 + currentcohort%gpp_acc_hold = 0._r8 + currentcohort%dmort = 0._r8 + currentcohort%g_sb_laweight = 0._r8 + currentcohort%treesai = 0._r8 currentCohort%lmort_direct = 0._r8 currentCohort%lmort_infra = 0._r8 currentCohort%lmort_collateral = 0._r8 - currentCohort%l_degrad = 0._r8 + currentCohort%l_degrad = 0._r8 currentCohort%leaf_cost = 0._r8 currentcohort%excl_weight = 0._r8 currentcohort%prom_weight = 0._r8 currentcohort%crownfire_mort = 0._r8 currentcohort%cambial_mort = 0._r8 - currentCohort%c13disc_clm = 0._r8 + currentCohort%c13disc_clm = 0._r8 currentCohort%c13disc_acc = 0._r8 ! Daily nutrient fluxes are INTEGRATED over the course of the @@ -678,44 +692,43 @@ subroutine zero_cohort(cc_p) ! after allocation. These variables exist in ! carbon-only mode but are not used. - currentCohort%daily_n_uptake = 0._r8 + currentCohort%daily_nh4_uptake = 0._r8 + currentCohort%daily_no3_uptake = 0._r8 currentCohort%daily_p_uptake = 0._r8 - + currentCohort%daily_c_efflux = 0._r8 currentCohort%daily_n_efflux = 0._r8 currentCohort%daily_p_efflux = 0._r8 - - currentCohort%daily_n_need1 = 0._r8 - currentCohort%daily_n_need2 = 0._r8 - currentCohort%daily_p_need1 = 0._r8 - currentCohort%daily_p_need2 = 0._r8 + + currentCohort%daily_n_need = 0._r8 + currentCohort%daily_p_need = 0._r8 ! Initialize these as negative currentCohort%daily_p_demand = -9._r8 currentCohort%daily_n_demand = -9._r8 - - + + end subroutine zero_cohort !-------------------------------------------------------------------------------------! - subroutine terminate_cohorts( currentSite, currentPatch, level , call_index) + subroutine terminate_cohorts( currentSite, currentPatch, level , call_index, bc_in) ! ! !DESCRIPTION: - ! terminates cohorts when they get too small + ! terminates all cohorts when they get too small ! ! !USES: - ! - ! !ARGUMENTS + ! !ARGUMENTS type (ed_site_type) , intent(inout), target :: currentSite type (ed_patch_type), intent(inout), target :: currentPatch integer , intent(in) :: level integer :: call_index + type(bc_in_type), intent(in) :: bc_in ! Important point regarding termination levels. Termination is typically ! called after fusion. We do this so that we can re-capture the biomass that would ! otherwise be lost from termination. The biomass of a fused plant remains in the - ! live pool. However, some plant number densities can be so low that they + ! live pool. However, some plant number densities can be so low that they ! can cause numerical instabilities. Thus, we call terminate_cohorts at level=1 ! before fusion to get rid of these cohorts that are so incredibly sparse, and then ! terminate the remainder at level 2 for various other reasons. @@ -733,8 +746,6 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index) real(r8) :: repro_c ! reproductive carbon [kg] real(r8) :: struct_c ! structural carbon [kg] integer :: terminate ! do we terminate (itrue) or not (ifalse) - integer :: c ! counter for litter size class. - integer :: levcan ! canopy level !---------------------------------------------------------------------- currentCohort => currentPatch%shortest @@ -757,14 +768,14 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index) write(fates_log(),*) 'terminating cohorts 0',currentCohort%n/currentPatch%area,currentCohort%dbh,call_index endif endif - + ! The rest of these are only allowed if we are not dealing with a recruit (level 2) if (.not.currentCohort%isnew .and. level == 2) then ! Not enough n or dbh if (currentCohort%n/currentPatch%area <= min_npm2 .or. & ! currentCohort%n <= min_nppatch .or. & - (currentCohort%dbh < 0.00001_r8 .and. store_c < 0._r8) ) then + (currentCohort%dbh < 0.00001_r8 .and. store_c < 0._r8) ) then terminate = itrue if ( debug ) then write(fates_log(),*) 'terminating cohorts 1',currentCohort%n/currentPatch%area,currentCohort%dbh,call_index @@ -772,7 +783,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index) endif ! Outside the maximum canopy layer - if (currentCohort%canopy_layer > nclmax ) then + if (currentCohort%canopy_layer > nclmax ) then terminate = itrue if ( debug ) then write(fates_log(),*) 'terminating cohorts 2', currentCohort%canopy_layer,call_index @@ -793,84 +804,122 @@ subroutine terminate_cohorts( currentSite, currentPatch, level , call_index) if ( ( struct_c+sapw_c+leaf_c+fnrt_c+store_c ) < 0._r8) then terminate = itrue if ( debug ) then - write(fates_log(),*) 'terminating cohorts 4', & + write(fates_log(),*) 'terminating cohorts 4', & struct_c,sapw_c,leaf_c,fnrt_c,store_c,call_index endif - + endif endif ! if (.not.currentCohort%isnew .and. level == 2) then - if (terminate == itrue) then - - ! preserve a record of the to-be-terminated cohort for mortality accounting - levcan = currentCohort%canopy_layer - - if( hlm_use_planthydro == itrue ) & - call AccumulateMortalityWaterStorage(currentSite,currentCohort,currentCohort%n) - - if(levcan==ican_upper) then - currentSite%term_nindivs_canopy(currentCohort%size_class,currentCohort%pft) = & - currentSite%term_nindivs_canopy(currentCohort%size_class,currentCohort%pft) + currentCohort%n - - currentSite%term_carbonflux_canopy = currentSite%term_carbonflux_canopy + & - currentCohort%n * (struct_c+sapw_c+leaf_c+fnrt_c+store_c+repro_c) - else - currentSite%term_nindivs_ustory(currentCohort%size_class,currentCohort%pft) = & - currentSite%term_nindivs_ustory(currentCohort%size_class,currentCohort%pft) + currentCohort%n - - currentSite%term_carbonflux_ustory = currentSite%term_carbonflux_ustory + & - currentCohort%n * (struct_c+sapw_c+leaf_c+fnrt_c+store_c+repro_c) - end if - - ! put the litter from the terminated cohorts - ! straight into the fragmenting pools - - if (currentCohort%n.gt.0.0_r8) then - call SendCohortToLitter(currentSite,currentPatch, & - currentCohort,currentCohort%n) - end if - - ! Set pointers and remove the current cohort from the list - shorterCohort => currentCohort%shorter - - if (.not. associated(tallerCohort)) then - currentPatch%tallest => shorterCohort - if(associated(shorterCohort)) shorterCohort%taller => null() - else - tallerCohort%shorter => shorterCohort - - endif - - if (.not. associated(shorterCohort)) then - currentPatch%shortest => tallerCohort - if(associated(tallerCohort)) tallerCohort%shorter => null() - else - shorterCohort%taller => tallerCohort - endif - - - call DeallocateCohort(currentCohort) - deallocate(currentCohort) - nullify(currentCohort) - - endif - currentCohort => tallerCohort + if (terminate == itrue) then + call terminate_cohort(currentSite, currentPatch, currentCohort, bc_in) + deallocate(currentCohort) + endif + currentCohort => tallerCohort enddo end subroutine terminate_cohorts + !-------------------------------------------------------------------------------------! + subroutine terminate_cohort(currentSite, currentPatch, currentCohort, bc_in) + ! + ! !DESCRIPTION: + ! Terminates an individual cohort and updates the site-level + ! updates the carbon flux and nuber of individuals appropriately + ! + ! !USES: + ! + ! !ARGUMENTS + type (ed_site_type) , intent(inout), target :: currentSite + type (ed_patch_type) , intent(inout), target :: currentPatch + type (ed_cohort_type), intent(inout), target :: currentCohort + type(bc_in_type), intent(in) :: bc_in + + ! !LOCAL VARIABLES: + type (ed_cohort_type) , pointer :: shorterCohort + type (ed_cohort_type) , pointer :: tallerCohort + + real(r8) :: leaf_c ! leaf carbon [kg] + real(r8) :: store_c ! storage carbon [kg] + real(r8) :: sapw_c ! sapwood carbon [kg] + real(r8) :: fnrt_c ! fineroot carbon [kg] + real(r8) :: repro_c ! reproductive carbon [kg] + real(r8) :: struct_c ! structural carbon [kg] + integer :: terminate ! do we terminate (itrue) or not (ifalse) + integer :: c ! counter for litter size class. + integer :: levcan ! canopy level + !---------------------------------------------------------------------- + + leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) + store_c = currentCohort%prt%GetState(store_organ, carbon12_element) + sapw_c = currentCohort%prt%GetState(sapw_organ, carbon12_element) + fnrt_c = currentCohort%prt%GetState(fnrt_organ, carbon12_element) + struct_c = currentCohort%prt%GetState(struct_organ, carbon12_element) + repro_c = currentCohort%prt%GetState(repro_organ, carbon12_element) + + ! preserve a record of the to-be-terminated cohort for mortality accounting + levcan = currentCohort%canopy_layer + + if( hlm_use_planthydro == itrue ) & + call AccumulateMortalityWaterStorage(currentSite,currentCohort,currentCohort%n) + + ! Update the site-level carbon flux and individuals count for the appropriate canopy layer + if(levcan==ican_upper) then + currentSite%term_nindivs_canopy(currentCohort%size_class,currentCohort%pft) = & + currentSite%term_nindivs_canopy(currentCohort%size_class,currentCohort%pft) + currentCohort%n + + currentSite%term_carbonflux_canopy = currentSite%term_carbonflux_canopy + & + currentCohort%n * (struct_c+sapw_c+leaf_c+fnrt_c+store_c+repro_c) + else + currentSite%term_nindivs_ustory(currentCohort%size_class,currentCohort%pft) = & + currentSite%term_nindivs_ustory(currentCohort%size_class,currentCohort%pft) + currentCohort%n + + currentSite%term_carbonflux_ustory = currentSite%term_carbonflux_ustory + & + currentCohort%n * (struct_c+sapw_c+leaf_c+fnrt_c+store_c+repro_c) + end if + + ! put the litter from the terminated cohorts + ! straight into the fragmenting pools + + if (currentCohort%n.gt.0.0_r8) then + call SendCohortToLitter(currentSite,currentPatch, & + currentCohort,currentCohort%n,bc_in) + end if + + ! Set pointers and deallocate the current cohort from the list + shorterCohort => currentCohort%shorter + tallerCohort => currentCohort%taller + + if (.not. associated(tallerCohort)) then + currentPatch%tallest => shorterCohort + if(associated(shorterCohort)) shorterCohort%taller => null() + else + tallerCohort%shorter => shorterCohort + endif + + if (.not. associated(shorterCohort)) then + currentPatch%shortest => tallerCohort + if(associated(tallerCohort)) tallerCohort%shorter => null() + else + shorterCohort%taller => tallerCohort + endif + + call DeallocateCohort(currentCohort) + + end subroutine terminate_cohort + ! ===================================================================================== - subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant) - + subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant,bc_in) + ! ----------------------------------------------------------------------------------- ! This routine transfers the existing mass in all pools and all elements ! on a vegetation cohort, into the litter pool. - ! + ! ! Important: (1) This IS NOT turnover, this is not a partial transfer. ! (2) This is from a select number of plants in the cohort. ie this is ! not a "whole-sale" sending of all plants to litter. - ! (3) This does not affect the PER PLANT mass pools, so + ! (3) This does not affect the PER PLANT mass pools, so ! do not update any PARTEH structures. ! (4) The change in plant number density (due to death or termination) ! IS NOT handled here. @@ -885,8 +934,8 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant) type (ed_cohort_type) , target :: ccohort real(r8) :: nplant ! Number (absolute) ! of plants to transfer - - ! + type(bc_in_type), intent(in) :: bc_in + type(litter_type), pointer :: litt ! Litter object for each element type(site_fluxdiags_type),pointer :: flux_diags @@ -903,24 +952,25 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant) integer :: pft ! pft index of the cohort integer :: sl ! loop index for soil layers integer :: dcmpy ! loop index for decomposability - + !---------------------------------------------------------------------- pft = ccohort%pft plant_dens = nplant/cpatch%area - call set_root_fraction(csite%rootfrac_scr, pft, csite%zi_soil) + call set_root_fraction(csite%rootfrac_scr, pft, csite%zi_soil, & + bc_in%max_rooting_depth_index_col) do el=1,num_elements - + leaf_m = ccohort%prt%GetState(leaf_organ, element_list(el)) store_m = ccohort%prt%GetState(store_organ, element_list(el)) sapw_m = ccohort%prt%GetState(sapw_organ, element_list(el)) fnrt_m = ccohort%prt%GetState(fnrt_organ, element_list(el)) struct_m = ccohort%prt%GetState(struct_organ, element_list(el)) repro_m = ccohort%prt%GetState(repro_organ, element_list(el)) - + litt => cpatch%litter(el) flux_diags => csite%flux_diags(el) @@ -950,13 +1000,13 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant) (1.0_r8 - prt_params%allom_agb_frac(pft)) * nplant enddo - + do dcmpy=1,ndcmpy dcmpy_frac = GetDecompyFrac(pft,leaf_organ,dcmpy) - + litt%leaf_fines(dcmpy) = litt%leaf_fines(dcmpy) + & plant_dens * (leaf_m+repro_m) * dcmpy_frac - + dcmpy_frac = GetDecompyFrac(pft,fnrt_organ,dcmpy) do sl=1,csite%nlevsoil litt%root_fines(dcmpy,sl) = litt%root_fines(dcmpy,sl) + & @@ -971,10 +1021,10 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant) flux_diags%root_litter_input(pft) = & flux_diags%root_litter_input(pft) + & (fnrt_m+store_m) * nplant - - + + end do - + return end subroutine SendCohortToLitter @@ -990,27 +1040,31 @@ subroutine DeallocateCohort(currentCohort) ! inside the cohort structure. This DOES NOT deallocate ! the cohort structure itself. ! ---------------------------------------------------------------------------------- - + type(ed_cohort_type),intent(inout) :: currentCohort - + + ! (Keeping as an example) + ! Remove the running mean structure + ! deallocate(currentCohort%tveg_lpa) + ! At this point, nothing should be pointing to current Cohort if (hlm_use_planthydro.eq.itrue) call DeallocateHydrCohort(currentCohort) - + ! Deallocate the cohort's PRT structures call currentCohort%prt%DeallocatePRTVartypes() - + ! Deallocate the PRT object deallocate(currentCohort%prt) - + return end subroutine DeallocateCohort - - subroutine fuse_cohorts(currentSite, currentPatch, bc_in) + + subroutine fuse_cohorts(currentSite, currentPatch, bc_in) ! ! !DESCRIPTION: - ! Join similar cohorts to reduce total number + ! Join similar cohorts to reduce total number ! ! !USES: use EDParamsMod , only : ED_val_cohort_size_fusion_tol @@ -1019,10 +1073,10 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) use FatesConstantsMod , only : itrue use FatesConstantsMod, only : days_per_year use EDTypesMod , only : maxCohortsPerPatch - + ! - ! !ARGUMENTS - type (ed_site_type), intent(inout), target :: currentSite + ! !ARGUMENTS + type (ed_site_type), intent(inout), target :: currentSite type (ed_patch_type), intent(inout), target :: currentPatch type (bc_in_type), intent(in) :: bc_in ! @@ -1035,7 +1089,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) type (ed_cohort_type) , pointer :: shorterCohort type (ed_cohort_type) , pointer :: tallerCohort - integer :: i + integer :: i integer :: fusion_took_place integer :: iterate ! do we need to keep fusing to get below maxcohorts? integer :: nocohorts @@ -1044,7 +1098,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) real(r8) :: coage_diff real(r8) :: leaf_c_next ! Leaf carbon * plant density of current (for weighting) real(r8) :: leaf_c_curr ! Leaf carbon * plant density of next (for weighting) - real(r8) :: leaf_c_target + real(r8) :: leaf_c_target real(r8) :: dynamic_size_fusion_tolerance real(r8) :: dynamic_age_fusion_tolerance real(r8) :: dbh @@ -1065,47 +1119,47 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) ! set the cohort age fusion tolerance (in fraction of years) dynamic_age_fusion_tolerance = ED_val_cohort_age_fusion_tol - + !This needs to be a function of the canopy layer, because otherwise, at canopy closure !the number of cohorts doubles and very dissimilar cohorts are fused together !because c_area and biomass are non-linear with dbh, this causes several mass inconsistancies - !in theory, all of this routine therefore causes minor losses of C and area, but these are below - !detection limit normally. + !in theory, all of this routine therefore causes minor losses of C and area, but these are below + !detection limit normally. iterate = 1 - fusion_took_place = 0 + fusion_took_place = 0 + - !---------------------------------------------------------------------! ! Keep doing this until nocohorts <= maxcohorts ! !---------------------------------------------------------------------! - - if (associated(currentPatch%shortest)) then + + if (associated(currentPatch%shortest)) then do while(iterate == 1) - + currentCohort => currentPatch%tallest - + ! The following logic continues the loop while the current cohort is not the shortest cohort ! if they point to the same target (ie equivalence), then the loop ends. ! This loop is different than the simple "continue while associated" loop in that ! it omits the last cohort (because it has already been compared by that point) - + do while ( .not.associated(currentCohort,currentPatch%shortest) ) nextc => currentPatch%tallest do while (associated(nextc)) nextnextc => nextc%shorter - diff = abs((currentCohort%dbh - nextc%dbh)/(0.5_r8*(currentCohort%dbh + nextc%dbh))) + diff = abs((currentCohort%dbh - nextc%dbh)/(0.5_r8*(currentCohort%dbh + nextc%dbh))) !Criteria used to divide up the height continuum into different cohorts. if (diff < dynamic_size_fusion_tolerance) then - ! Only fuse if the cohorts are within x years of each other + ! Only fuse if the cohorts are within x years of each other ! if they are the same age we make diff 0- to avoid errors divding by zero !NB if cohort age tracking is off then the age of both should be 0 - ! and hence the age fusion criterion is met + ! and hence the age fusion criterion is met if (abs(currentCohort%coage - nextc%coage) shorterCohort if(associated(shorterCohort)) shorterCohort%taller => null() - else + else tallerCohort%shorter => shorterCohort endif if (.not. associated(shorterCohort)) then currentPatch%shortest => tallerCohort if(associated(tallerCohort)) tallerCohort%shorter => null() - else + else shorterCohort%taller => tallerCohort endif ! At this point, nothing should be pointing to current Cohort ! update hydraulics quantities that are functions of hite & biomasses ! deallocate the hydro structure of nextc - if (hlm_use_planthydro.eq.itrue) then + if (hlm_use_planthydro.eq.itrue) then call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread, & currentCohort%pft,currentCohort%c_area) leaf_c = currentCohort%prt%GetState(leaf_organ, carbon12_element) currentCohort%treelai = tree_lai(leaf_c, & currentCohort%pft, currentCohort%c_area, currentCohort%n, & currentCohort%canopy_layer, currentPatch%canopy_layer_tlai, & - currentCohort%vcmax25top ) - call UpdateSizeDepPlantHydProps(currentSite,currentCohort, bc_in) + currentCohort%vcmax25top ) + call UpdateSizeDepPlantHydProps(currentSite,currentCohort, bc_in) endif - + call DeallocateCohort(nextc) deallocate(nextc) nullify(nextc) - + endif ! if( currentCohort%isnew.eqv.nextc%isnew ) then endif !canopy layer endif !pft - endif !index no. - endif ! cohort age diff - endif !diff + endif !index no. + endif ! cohort age diff + endif !diff nextc => nextnextc @@ -1511,12 +1568,12 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) if (associated (currentCohort%shorter)) then currentCohort => currentCohort%shorter endif - + enddo !end currentCohort cohort loop !---------------------------------------------------------------------! ! Is the number of cohorts larger than the maximum? ! - !---------------------------------------------------------------------! + !---------------------------------------------------------------------! nocohorts = 0 currentCohort => currentPatch%tallest do while(associated(currentCohort)) @@ -1530,7 +1587,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) iterate = 1 !---------------------------------------------------------------------! ! Making profile tolerance larger means that more fusion will happen ! - !---------------------------------------------------------------------! + !---------------------------------------------------------------------! dynamic_size_fusion_tolerance = dynamic_size_fusion_tolerance * 1.1_r8 dynamic_age_fusion_tolerance = dynamic_age_fusion_tolerance * 1.1_r8 !write(fates_log(),*) 'maxcohorts exceeded',dynamic_fusion_tolerance @@ -1540,13 +1597,13 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) iterate = 0 endif - else + else if (nocohorts > maxCohortsPerPatch) then iterate = 1 !---------------------------------------------------------------------! ! Making profile tolerance larger means that more fusion will happen ! - !---------------------------------------------------------------------! + !---------------------------------------------------------------------! dynamic_size_fusion_tolerance = dynamic_size_fusion_tolerance * 1.1_r8 !write(fates_log(),*) 'maxcohorts exceeded',dynamic_fusion_tolerance @@ -1556,7 +1613,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) endif end if - + if ( dynamic_size_fusion_tolerance .gt. 100._r8) then ! something has gone terribly wrong and we need to report what write(fates_log(),*) 'exceeded reasonable expectation of cohort fusion.' @@ -1573,9 +1630,9 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) enddo !do while nocohorts>maxcohorts - endif ! patch. + endif ! patch. - if (fusion_took_place == 1) then ! if fusion(s) occured sort cohorts + if (fusion_took_place == 1) then ! if fusion(s) occured sort cohorts call sort_cohorts(currentPatch) endif @@ -1583,7 +1640,7 @@ end subroutine fuse_cohorts !-------------------------------------------------------------------------------------! - subroutine sort_cohorts(patchptr) + subroutine sort_cohorts(patchptr) ! ============================================================================ ! sort cohorts into the correct order DO NOT CHANGE THIS IT WILL BREAK ! ============================================================================ @@ -1592,9 +1649,9 @@ subroutine sort_cohorts(patchptr) type(ed_patch_type) , pointer :: current_patch type(ed_cohort_type), pointer :: current_c, next_c - type(ed_cohort_type), pointer :: shortestc, tallestc - type(ed_cohort_type), pointer :: storesmallcohort - type(ed_cohort_type), pointer :: storebigcohort + type(ed_cohort_type), pointer :: shortestc, tallestc + type(ed_cohort_type), pointer :: storesmallcohort + type(ed_cohort_type), pointer :: storebigcohort integer :: snull,tnull current_patch => patchptr @@ -1602,12 +1659,12 @@ subroutine sort_cohorts(patchptr) shortestc => NULL() storebigcohort => null() storesmallcohort => null() - current_c => current_patch%tallest + current_c => current_patch%tallest - do while (associated(current_c)) + do while (associated(current_c)) next_c => current_c%shorter - tallestc => storebigcohort - shortestc => storesmallcohort + tallestc => storebigcohort + shortestc => storesmallcohort if (associated(tallestc)) then tnull = 0 else @@ -1624,7 +1681,7 @@ subroutine sort_cohorts(patchptr) call insert_cohort(current_c, tallestc, shortestc, tnull, snull, storebigcohort, storesmallcohort) - current_patch%tallest => storebigcohort + current_patch%tallest => storebigcohort current_patch%shortest => storesmallcohort current_c => next_c @@ -1636,24 +1693,24 @@ end subroutine sort_cohorts subroutine insert_cohort(pcc, ptall, pshort, tnull, snull, storebigcohort, storesmallcohort) ! ! !DESCRIPTION: - ! Insert cohort into linked list + ! Insert cohort into linked list ! ! !USES: ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_cohort_type) , intent(inout), target :: pcc type(ed_cohort_type) , intent(inout), target :: ptall type(ed_cohort_type) , intent(inout), target :: pshort integer , intent(in) :: tnull integer , intent(in) :: snull type(ed_cohort_type) , intent(inout),pointer,optional :: storesmallcohort ! storage of the smallest cohort for insertion routine - type(ed_cohort_type) , intent(inout),pointer,optional :: storebigcohort ! storage of the largest cohort for insertion routine + type(ed_cohort_type) , intent(inout),pointer,optional :: storebigcohort ! storage of the largest cohort for insertion routine ! ! !LOCAL VARIABLES: type(ed_patch_type), pointer :: currentPatch type(ed_cohort_type), pointer :: current type(ed_cohort_type), pointer :: tallptr, shortptr, icohort - type(ed_cohort_type), pointer :: ptallest, pshortest + type(ed_cohort_type), pointer :: ptallest, pshortest real(r8) :: tsp integer :: tallptrnull,exitloop !---------------------------------------------------------------------- @@ -1669,21 +1726,21 @@ subroutine insert_cohort(pcc, ptall, pshort, tnull, snull, storebigcohort, store pshortest => null() endif - icohort => pcc ! assign address to icohort local name - !place in the correct place in the linked list of heights - !begin by finding cohort that is just taller than the new cohort + icohort => pcc ! assign address to icohort local name + !place in the correct place in the linked list of heights + !begin by finding cohort that is just taller than the new cohort tsp = icohort%hite current => pshortest exitloop = 0 - !starting with shortest tree on the grid, find tree just - !taller than tree being considered and return its pointer + !starting with shortest tree on the grid, find tree just + !taller than tree being considered and return its pointer if (associated(current)) then do while (associated(current).and.exitloop == 0) if (current%hite < tsp) then - current => current%taller + current => current%taller else - exitloop = 1 + exitloop = 1 endif enddo endif @@ -1696,48 +1753,48 @@ subroutine insert_cohort(pcc, ptall, pshort, tnull, snull, storebigcohort, store tallptrnull = 1 endif - !new cohort is tallest - if (.not.associated(tallptr)) then - !new shorter cohort to the new cohort is the old tallest cohort + !new cohort is tallest + if (.not.associated(tallptr)) then + !new shorter cohort to the new cohort is the old tallest cohort shortptr => ptallest - !new cohort is tallest cohort and next taller remains null + !new cohort is tallest cohort and next taller remains null ptallest => icohort if (present(storebigcohort)) then storebigcohort => icohort end if - currentPatch%tallest => icohort - icohort%patchptr%tallest => icohort - !new cohort is not tallest + currentPatch%tallest => icohort + icohort%patchptr%tallest => icohort + !new cohort is not tallest else - !next shorter cohort to new cohort is the next shorter cohort - !to the cohort just taller than the new cohort + !next shorter cohort to new cohort is the next shorter cohort + !to the cohort just taller than the new cohort shortptr => tallptr%shorter - !new cohort becomes the next shorter cohort to the cohort - !just taller than the new cohort + !new cohort becomes the next shorter cohort to the cohort + !just taller than the new cohort tallptr%shorter => icohort endif - !new cohort is shortest + !new cohort is shortest if (.not.associated(shortptr)) then - !next shorter reamins null - !cohort is placed at the bottom of the list + !next shorter reamins null + !cohort is placed at the bottom of the list pshortest => icohort if (present(storesmallcohort)) then - storesmallcohort => icohort + storesmallcohort => icohort end if - currentPatch%shortest => icohort - icohort%patchptr%shortest => icohort + currentPatch%shortest => icohort + icohort%patchptr%shortest => icohort else - !new cohort is not shortest and becomes next taller cohort - !to the cohort just below it as defined in the previous block + !new cohort is not shortest and becomes next taller cohort + !to the cohort just below it as defined in the previous block shortptr%taller => icohort endif - ! assign taller and shorter links for the new cohort + ! assign taller and shorter links for the new cohort icohort%taller => tallptr - if (tallptrnull == 1) then + if (tallptrnull == 1) then icohort%taller=> null() endif icohort%shorter => shortptr @@ -1748,11 +1805,11 @@ end subroutine insert_cohort subroutine copy_cohort( currentCohort,copyc ) ! ! !DESCRIPTION: - ! Copies all the variables in one cohort into another empty cohort + ! Copies all the variables in one cohort into another empty cohort ! ! !USES: ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_cohort_type), intent(inout) , target :: copyc ! New cohort argument. type(ed_cohort_type), intent(in) , target :: currentCohort ! Old cohort argument. ! @@ -1764,18 +1821,18 @@ subroutine copy_cohort( currentCohort,copyc ) n => copyc n%indexnumber = fates_unset_int - + ! VEGETATION STRUCTURE n%pft = o%pft - n%n = o%n + n%n = o%n n%dbh = o%dbh - n%coage = o%coage + n%coage = o%coage n%hite = o%hite n%laimemory = o%laimemory n%sapwmemory = o%sapwmemory n%structmemory = o%structmemory - n%lai = o%lai - n%sai = o%sai + n%lai = o%lai + n%sai = o%sai n%g_sb_laweight = o%g_sb_laweight n%leaf_cost = o%leaf_cost n%canopy_layer = o%canopy_layer @@ -1783,13 +1840,14 @@ subroutine copy_cohort( currentCohort,copyc ) n%nv = o%nv n%status_coh = o%status_coh n%canopy_trim = o%canopy_trim - n%excl_weight = o%excl_weight - n%prom_weight = o%prom_weight + n%excl_weight = o%excl_weight + n%prom_weight = o%prom_weight n%size_class = o%size_class n%size_class_lasttimestep = o%size_class_lasttimestep n%size_by_pft_class = o%size_by_pft_class n%coage_class = o%coage_class n%coage_by_pft_class = o%coage_by_pft_class + ! This transfers the PRT objects over. call n%prt%CopyPRTVartypes(o%prt) @@ -1797,8 +1855,12 @@ subroutine copy_cohort( currentCohort,copyc ) n%vcmax25top = o%vcmax25top n%jmax25top = o%jmax25top n%tpu25top = o%tpu25top - n%kp25top = o%kp25top + n%kp25top = o%kp25top + ! (Keeping as an example) + ! Copy over running means + ! call n%tveg_lpa%CopyFromDonor(o%tveg_lpa) + ! CARBON FLUXES n%gpp_acc_hold = o%gpp_acc_hold n%gpp_acc = o%gpp_acc @@ -1817,18 +1879,17 @@ subroutine copy_cohort( currentCohort,copyc ) n%year_net_uptake = o%year_net_uptake n%ts_net_uptake = o%ts_net_uptake - n%daily_n_uptake = o%daily_n_uptake + n%daily_nh4_uptake = o%daily_nh4_uptake + n%daily_no3_uptake = o%daily_no3_uptake n%daily_p_uptake = o%daily_p_uptake n%daily_c_efflux = o%daily_c_efflux n%daily_n_efflux = o%daily_n_efflux n%daily_p_efflux = o%daily_p_efflux - n%daily_n_need1 = o%daily_n_need1 - n%daily_n_need2 = o%daily_n_need2 - n%daily_p_need1 = o%daily_p_need1 - n%daily_p_need2 = o%daily_p_need2 + n%daily_n_need = o%daily_n_need + n%daily_p_need = o%daily_p_need n%daily_n_demand = o%daily_n_demand n%daily_p_demand = o%daily_p_demand - + ! C13 discrimination n%c13disc_clm = o%c13disc_clm n%c13disc_acc = o%c13disc_acc @@ -1841,7 +1902,7 @@ subroutine copy_cohort( currentCohort,copyc ) n%livestem_mr = o%livestem_mr n%livecroot_mr = o%livecroot_mr n%froot_mr = o%froot_mr - + ! ALLOCATION n%dmort = o%dmort n%seed_prod = o%seed_prod @@ -1862,12 +1923,12 @@ subroutine copy_cohort( currentCohort,copyc ) n%lmort_direct =o%lmort_direct n%lmort_collateral =o%lmort_collateral n%lmort_infra =o%lmort_infra - n%l_degrad =o%l_degrad + n%l_degrad =o%l_degrad ! Flags n%isnew = o%isnew - ! VARIABLES NEEDED FOR INTEGRATION + ! VARIABLES NEEDED FOR INTEGRATION n%dndt = o%dndt n%dhdt = o%dhdt n%ddbhdt = o%ddbhdt @@ -1879,7 +1940,7 @@ subroutine copy_cohort( currentCohort,copyc ) n%cambial_mort = o%cambial_mort ! Plant Hydraulics - + if( hlm_use_planthydro.eq.itrue ) then call CopyCohortHydraulics(n,o) endif @@ -1890,11 +1951,11 @@ subroutine copy_cohort( currentCohort,copyc ) n%size_by_pft_class = o%size_by_pft_class n%coage_class = o%coage_class n%coage_by_pft_class = o%coage_by_pft_class - + !Pointers - n%taller => NULL() ! pointer to next tallest cohort - n%shorter => NULL() ! pointer to next shorter cohort - n%patchptr => o%patchptr ! pointer to patch that cohort is in + n%taller => NULL() ! pointer to next tallest cohort + n%shorter => NULL() ! pointer to next shorter cohort + n%patchptr => o%patchptr ! pointer to patch that cohort is in end subroutine copy_cohort @@ -1905,7 +1966,7 @@ subroutine count_cohorts( currentPatch ) ! ! !USES: ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_patch_type), intent(inout), target :: currentPatch !new site ! ! !LOCAL VARIABLES: @@ -1916,20 +1977,20 @@ subroutine count_cohorts( currentPatch ) currentCohort => currentPatch%shortest currentPatch%countcohorts = 0 - do while (associated(currentCohort)) - currentPatch%countcohorts = currentPatch%countcohorts + 1 - currentCohort => currentCohort%taller + do while (associated(currentCohort)) + currentPatch%countcohorts = currentPatch%countcohorts + 1 + currentCohort => currentCohort%taller enddo backcount = 0 currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) backcount = backcount + 1 - currentCohort => currentCohort%shorter + currentCohort => currentCohort%shorter enddo if (backcount /= currentPatch%countcohorts) then - write(fates_log(),*) 'problem with linked list, not symmetrical' + write(fates_log(),*) 'problem with linked list, not symmetrical' endif end subroutine count_cohorts @@ -1949,8 +2010,8 @@ subroutine UpdateCohortBioPhysRates(currentCohort) ! -------------------------------------------------------------------------------- type(ed_cohort_type),intent(inout) :: currentCohort - - + + real(r8) :: frac_leaf_aclass(max_nleafage) ! Fraction of leaves in each age-class integer :: iage ! loop index for leaf ages integer :: ipft ! plant functional type index @@ -1967,29 +2028,37 @@ subroutine UpdateCohortBioPhysRates(currentCohort) ! If there are leaves, then perform proportional weighting on the four rates ! We assume that leaf age does not effect the specific leaf area, so the mass ! fractions are applicable to these rates - - if(sum(frac_leaf_aclass(1:nleafage))>nearzero) then - ipft = currentCohort%pft + ipft = currentCohort%pft + + if(sum(frac_leaf_aclass(1:nleafage))>nearzero .and. hlm_use_sp .eq. ifalse) then + frac_leaf_aclass(1:nleafage) = frac_leaf_aclass(1:nleafage) / & sum(frac_leaf_aclass(1:nleafage)) - + currentCohort%vcmax25top = sum(EDPftvarcon_inst%vcmax25top(ipft,1:nleafage) * & frac_leaf_aclass(1:nleafage)) - + currentCohort%jmax25top = sum(param_derived%jmax25top(ipft,1:nleafage) * & frac_leaf_aclass(1:nleafage)) - + currentCohort%tpu25top = sum(param_derived%tpu25top(ipft,1:nleafage) * & frac_leaf_aclass(1:nleafage)) - - currentCohort%kp25top = sum(param_derived%kp25top(ipft,1:nleafage) * & + + currentCohort%kp25top = sum(param_derived%kp25top(ipft,1:nleafage) * & frac_leaf_aclass(1:nleafage)) + elseif (hlm_use_sp .eq. itrue) then + + currentCohort%vcmax25top = EDPftvarcon_inst%vcmax25top(ipft,1) + currentCohort%jmax25top = param_derived%jmax25top(ipft,1) + currentCohort%tpu25top = param_derived%tpu25top(ipft,1) + currentCohort%kp25top = param_derived%kp25top(ipft,1) + else - - currentCohort%vcmax25top = 0._r8 + + currentCohort%vcmax25top = 0._r8 currentCohort%jmax25top = 0._r8 currentCohort%tpu25top = 0._r8 currentCohort%kp25top = 0._r8 @@ -2000,15 +2069,15 @@ subroutine UpdateCohortBioPhysRates(currentCohort) return end subroutine UpdateCohortBioPhysRates - + ! ============================================================================ subroutine EvaluateAndCorrectDBH(currentCohort,delta_dbh,delta_hite) ! ----------------------------------------------------------------------------------- - ! If the current diameter of a plant is somehow less than what is allometrically - ! consistent with stuctural biomass (or, in the case of grasses, leaf biomass) + ! If the current diameter of a plant is somehow less than what is allometrically + ! consistent with stuctural biomass (or, in the case of grasses, leaf biomass) ! then correct (increase) the dbh to match that. ! ----------------------------------------------------------------------------------- @@ -2016,7 +2085,7 @@ subroutine EvaluateAndCorrectDBH(currentCohort,delta_dbh,delta_hite) type(ed_cohort_type),intent(inout) :: currentCohort real(r8),intent(out) :: delta_dbh real(r8),intent(out) :: delta_hite - + ! locals real(r8) :: dbh real(r8) :: canopy_trim @@ -2030,44 +2099,44 @@ subroutine EvaluateAndCorrectDBH(currentCohort,delta_dbh,delta_hite) real(r8) :: struct_c real(r8) :: hite_out real(r8) :: leaf_c - + dbh = currentCohort%dbh ipft = currentCohort%pft canopy_trim = currentCohort%canopy_trim delta_dbh = 0._r8 delta_hite = 0._r8 - + if( int(prt_params%woody(currentCohort%pft)) == itrue) then struct_c = currentCohort%prt%GetState(struct_organ, all_carbon_elements) - + ! Target sapwood biomass according to allometry and trimming [kgC] call bsap_allom(dbh,ipft,canopy_trim,sapw_area,target_sapw_c) - + ! Target total above ground biomass in woody/fibrous tissues [kgC] call bagw_allom(dbh,ipft,target_agw_c) - - ! Target total below ground biomass in woody/fibrous tissues [kgC] + + ! Target total below ground biomass in woody/fibrous tissues [kgC] call bbgw_allom(dbh,ipft,target_bgw_c) - + ! Target total dead (structrual) biomass [kgC] call bdead_allom( target_agw_c, target_bgw_c, target_sapw_c, ipft, target_struct_c) - + ! ------------------------------------------------------------------------------------ ! If structure is larger than target, then we need to correct some integration errors ! by slightly increasing dbh to match it. ! For grasses, if leaf biomass is larger than target, then we reset dbh to match ! ----------------------------------------------------------------------------------- - + if( (struct_c - target_struct_c ) > calloc_abs_error ) then call ForceDBH( ipft, canopy_trim, dbh, hite_out, bdead=struct_c ) - delta_dbh = dbh - currentCohort%dbh + delta_dbh = dbh - currentCohort%dbh delta_hite = hite_out - currentCohort%hite currentCohort%dbh = dbh currentCohort%hite = hite_out end if - + else ! This returns the sum of leaf carbon over all (age) bins @@ -2078,15 +2147,15 @@ subroutine EvaluateAndCorrectDBH(currentCohort,delta_dbh,delta_hite) if( ( leaf_c - target_leaf_c ) > calloc_abs_error ) then call ForceDBH( ipft, canopy_trim, dbh, hite_out, bl=leaf_c ) - delta_dbh = dbh - currentCohort%dbh + delta_dbh = dbh - currentCohort%dbh delta_hite = hite_out - currentCohort%hite currentCohort%dbh = dbh currentCohort%hite = hite_out end if - + end if return end subroutine EvaluateAndCorrectDBH - + end module EDCohortDynamicsMod diff --git a/biogeochem/EDLoggingMortalityMod.F90 b/biogeochem/EDLoggingMortalityMod.F90 index 36641f58cb..0f1129282f 100644 --- a/biogeochem/EDLoggingMortalityMod.F90 +++ b/biogeochem/EDLoggingMortalityMod.F90 @@ -40,6 +40,7 @@ module EDLoggingMortalityMod use EDParamsMod , only : logging_mechanical_frac use EDParamsMod , only : logging_coll_under_frac use EDParamsMod , only : logging_dbhmax_infra + use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_current_year use FatesInterfaceTypesMod , only : hlm_current_month use FatesInterfaceTypesMod , only : hlm_current_day @@ -414,7 +415,7 @@ end subroutine get_harvest_rate_area ! ============================================================================ - subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site_areadis) + subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site_areadis, bc_in) ! ------------------------------------------------------------------------------------------- ! @@ -460,6 +461,8 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site type(ed_patch_type) , intent(inout), target :: currentPatch type(ed_patch_type) , intent(inout), target :: newPatch real(r8) , intent(in) :: patch_site_areadis + type(bc_in_type) , intent(in) :: bc_in + !LOCAL VARIABLES: type(ed_cohort_type), pointer :: currentCohort @@ -587,7 +590,9 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site ! derived from the current patch, so we need to multiply by patch_areadis/np%area ! ---------------------------------------------------------------------------------------- - call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil) + call set_root_fraction(currentSite%rootfrac_scr, pft, & + currentSite%zi_soil, & + bc_in%max_rooting_depth_index_col) ag_wood = (direct_dead+indirect_dead) * (struct_m + sapw_m ) * & prt_params%allom_agb_frac(currentCohort%pft) diff --git a/biogeochem/EDMortalityFunctionsMod.F90 b/biogeochem/EDMortalityFunctionsMod.F90 index fa0b933fc5..e4a0b3c138 100644 --- a/biogeochem/EDMortalityFunctionsMod.F90 +++ b/biogeochem/EDMortalityFunctionsMod.F90 @@ -19,7 +19,6 @@ module EDMortalityFunctionsMod use FatesInterfaceTypesMod , only : hlm_use_planthydro use EDLoggingMortalityMod , only : LoggingMortality_frac use EDParamsMod , only : fates_mortality_disturbance_fraction - use FatesInterfaceTypesMod , only : bc_in_type use PRTGenericMod, only : all_carbon_elements use PRTGenericMod, only : store_organ @@ -62,7 +61,6 @@ subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort,smort,asmor real(r8),intent(out) :: smort ! size dependent senescence term real(r8),intent(out) :: asmort ! age dependent senescence term - integer :: ifp real(r8) :: frac ! relativised stored carbohydrate real(r8) :: leaf_c_target ! target leaf biomass kgC real(r8) :: store_c @@ -173,8 +171,8 @@ subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort,smort,asmor ! Eastern US carbon sink. Glob. Change Biol., 12, 2370-2390, ! doi: 10.1111/j.1365-2486.2006.01254.x - ifp = cohort_in%patchptr%patchno - temp_in_C = bc_in%t_veg24_pa(ifp) - tfrz + temp_in_C = cohort_in%patchptr%tveg24%GetMean() - tfrz + temp_dep_fraction = max(0.0_r8, min(1.0_r8, 1.0_r8 - (temp_in_C - & EDPftvarcon_inst%freezetol(cohort_in%pft))/frost_mort_buffer) ) frmort = EDPftvarcon_inst%mort_scalar_coldstress(cohort_in%pft) * temp_dep_fraction diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index c2ad0236c7..9ebdb9132b 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -45,9 +45,14 @@ module EDPatchDynamicsMod use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_days_per_year use FatesInterfaceTypesMod , only : numpft + use FatesInterfaceTypesMod , only : hlm_stepsize + use FatesInterfaceTypesMod , only : hlm_use_sp + use FatesInterfaceTypesMod , only : hlm_use_nocomp + use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog use FatesGlobals , only : endrun => fates_endrun use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue, ifalse + use FatesConstantsMod , only : t_water_freeze_k_1atm use FatesPlantHydraulicsMod, only : InitHydrCohort use FatesPlantHydraulicsMod, only : AccumulateMortalityWaterStorage use FatesPlantHydraulicsMod, only : DeallocateHydrCohort @@ -84,7 +89,8 @@ module EDPatchDynamicsMod use SFParamsMod, only : SF_VAL_CWD_FRAC use EDParamsMod, only : logging_event_code use EDParamsMod, only : logging_export_frac - + use FatesRunningMeanMod, only : ema_24hr, fixed_24hr, ema_lpa + ! CIME globals use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) use shr_log_mod , only : errMsg => shr_log_errMsg @@ -417,6 +423,7 @@ subroutine disturbance_rates( site_in, bc_in) end subroutine disturbance_rates ! ============================================================================ + subroutine spawn_patches( currentSite, bc_in) ! ! !DESCRIPTION: @@ -470,24 +477,41 @@ subroutine spawn_patches( currentSite, bc_in) ! for both woody and grass species real(r8) :: leaf_m ! leaf mass during partial burn calculations logical :: found_youngest_primary ! logical for finding the first primary forest patch + integer :: min_nocomp_pft, max_nocomp_pft, i_nocomp_pft !--------------------------------------------------------------------- storesmallcohort => null() ! storage of the smallest cohort for insertion routine storebigcohort => null() ! storage of the largest cohort for insertion routine - ! calculate area of disturbed land, in this timestep, by summing contributions from each existing patch. - currentPatch => currentSite%youngest_patch - - site_areadis_primary = 0.0_r8 - site_areadis_secondary = 0.0_r8 + if (hlm_use_nocomp .eq. itrue) then + min_nocomp_pft = 0 + max_nocomp_pft = numpft + else + min_nocomp_pft = fates_unset_int + max_nocomp_pft = fates_unset_int + endif ! zero the diagnostic disturbance rate fields currentSite%disturbance_rates_primary_to_primary(1:N_DIST_TYPES) = 0._r8 currentSite%disturbance_rates_primary_to_secondary(1:N_DIST_TYPES) = 0._r8 currentSite%disturbance_rates_secondary_to_secondary(1:N_DIST_TYPES) = 0._r8 + ! in the nocomp cases, since every patch has a PFT identity, it can only receive patch area from patches + ! that have the same identity. In order to allow this, we have this very high level loop over nocomp PFTs + ! and only do the disturbance for any patches that have that nocomp PFT identity. + ! If nocomp is not enabled, then this is not much of a loop, it only passes through once. + nocomp_pft_loop: do i_nocomp_pft = min_nocomp_pft,max_nocomp_pft + + ! calculate area of disturbed land, in this timestep, by summing contributions from each existing patch. + currentPatch => currentSite%youngest_patch + + site_areadis_primary = 0.0_r8 + site_areadis_secondary = 0.0_r8 + do while(associated(currentPatch)) + cp_nocomp_matches_1_if: if ( hlm_use_nocomp .eq. ifalse .or. & + currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then if(currentPatch%disturbance_rate > (1.0_r8 + rsnbl_math_prec)) then write(fates_log(),*) 'patch disturbance rate > 1 ?',currentPatch%disturbance_rate @@ -534,7 +558,8 @@ subroutine spawn_patches( currentSite, bc_in) endif end if - + + end if cp_nocomp_matches_1_if currentPatch => currentPatch%older enddo ! end loop over patches. sum area disturbed for all patches. @@ -549,7 +574,7 @@ subroutine spawn_patches( currentSite, bc_in) allocate(new_patch_primary) call create_patch(currentSite, new_patch_primary, age, & - site_areadis_primary, primaryforest) + site_areadis_primary, primaryforest, i_nocomp_pft) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -567,12 +592,11 @@ subroutine spawn_patches( currentSite, bc_in) endif - ! next create patch to receive secondary forest area if ( site_areadis_secondary .gt. nearzero) then allocate(new_patch_secondary) call create_patch(currentSite, new_patch_secondary, age, & - site_areadis_secondary, secondaryforest) + site_areadis_secondary, secondaryforest,i_nocomp_pft) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -598,6 +622,9 @@ subroutine spawn_patches( currentSite, bc_in) currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) + cp_nocomp_matches_2_if: if ( hlm_use_nocomp .eq. ifalse .or. & + currentPatch%nocomp_pft_label .eq. i_nocomp_pft ) then + ! This is the amount of patch area that is disturbed, and donated by the donor patch_site_areadis = currentPatch%area * currentPatch%disturbance_rate @@ -648,13 +675,24 @@ subroutine spawn_patches( currentSite, bc_in) ! Transfer in litter fluxes from plants in various contexts of death and destruction if(currentPatch%disturbance_mode .eq. dtype_ilog) then - call logging_litter_fluxes(currentSite, currentPatch, new_patch, patch_site_areadis) + call logging_litter_fluxes(currentSite, currentPatch, & + new_patch, patch_site_areadis,bc_in) elseif(currentPatch%disturbance_mode .eq. dtype_ifire) then - call fire_litter_fluxes(currentSite, currentPatch, new_patch, patch_site_areadis) + call fire_litter_fluxes(currentSite, currentPatch, & + new_patch, patch_site_areadis,bc_in) else - call mortality_litter_fluxes(currentSite, currentPatch, new_patch, patch_site_areadis) + call mortality_litter_fluxes(currentSite, currentPatch, & + new_patch, patch_site_areadis,bc_in) endif + + ! Copy any means or timers from the original patch to the new patch + ! These values will inherit all info from the original patch + ! -------------------------------------------------------------------------- + call new_patch%tveg24%CopyFromDonor(currentPatch%tveg24) + call new_patch%tveg_lpa%CopyFromDonor(currentPatch%tveg_lpa) + + ! -------------------------------------------------------------------------- ! The newly formed patch from disturbance (new_patch), has now been given ! some litter from dead plants and pre-existing litter from the donor patches. @@ -674,7 +712,12 @@ subroutine spawn_patches( currentSite, bc_in) nc%prt => null() call InitPRTObject(nc%prt) call InitPRTBoundaryConditions(nc) - + + ! (Keeping as an example) + ! Allocate running mean functions + !allocate(nc%tveg_lpa) + !call nc%tveg_lpa%InitRMean(ema_lpa,init_value=new_patch%tveg_lpa%GetMean()) + call zero_cohort(nc) ! nc is the new cohort that goes in the disturbed patch (new_patch)... currentCohort @@ -1068,9 +1111,9 @@ subroutine spawn_patches( currentSite, bc_in) ! the first call to terminate cohorts removes sparse number densities, ! the second call removes for all other reasons (sparse culling must happen ! before fusion) - call terminate_cohorts(currentSite, currentPatch, 1,16) + call terminate_cohorts(currentSite, currentPatch, 1,16,bc_in) call fuse_cohorts(currentSite,currentPatch, bc_in) - call terminate_cohorts(currentSite, currentPatch, 2,16) + call terminate_cohorts(currentSite, currentPatch, 2,16,bc_in) call sort_cohorts(currentPatch) end if ! if ( new_patch%area > nearzero ) then @@ -1079,7 +1122,8 @@ subroutine spawn_patches( currentSite, bc_in) currentPatch%disturbance_rate = 0._r8 currentPatch%disturbance_rates = 0._r8 currentPatch%fract_ldist_not_harvested = 0._r8 - + + end if cp_nocomp_matches_2_if currentPatch => currentPatch%younger enddo ! currentPatch patch loop. @@ -1142,16 +1186,16 @@ subroutine spawn_patches( currentSite, bc_in) ! before fusion) if ( site_areadis_primary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_primary, 1,17) + call terminate_cohorts(currentSite, new_patch_primary, 1,17, bc_in) call fuse_cohorts(currentSite,new_patch_primary, bc_in) - call terminate_cohorts(currentSite, new_patch_primary, 2,17) + call terminate_cohorts(currentSite, new_patch_primary, 2,17, bc_in) call sort_cohorts(new_patch_primary) endif if ( site_areadis_secondary .gt. nearzero) then - call terminate_cohorts(currentSite, new_patch_secondary, 1,18) + call terminate_cohorts(currentSite, new_patch_secondary, 1,18,bc_in) call fuse_cohorts(currentSite,new_patch_secondary, bc_in) - call terminate_cohorts(currentSite, new_patch_secondary, 2,18) + call terminate_cohorts(currentSite, new_patch_secondary, 2,18,bc_in) call sort_cohorts(new_patch_secondary) endif @@ -1161,6 +1205,7 @@ subroutine spawn_patches( currentSite, bc_in) call check_patch_area(currentSite) call set_patchno(currentSite) + end do nocomp_pft_loop return end subroutine spawn_patches @@ -1213,7 +1258,7 @@ subroutine check_patch_area( currentSite ) end if if(debug) then - write(fates_log(),*) 'Total patch area precision being fixed, adjusting' + write(fates_log(),*) 'Total patch area precision being fixed, adjusting',(areatot-area_site) write(fates_log(),*) 'largest patch. This may have slight impacts on carbon balance.' end if @@ -1261,6 +1306,22 @@ subroutine set_patchno( currentSite ) currentPatch => currentPatch%younger enddo + if(hlm_use_sp.eq.itrue)then + patchno = 1 + currentPatch => currentSite%oldest_patch + do while(associated(currentPatch)) + if(currentPatch%nocomp_pft_label.eq.0)then + ! for bareground patch, we make the patch number 0 + ! we also do not count this in the veg. patch numbering scheme. + currentPatch%patchno = 0 + else + currentPatch%patchno = patchno + patchno = patchno + 1 + endif + currentPatch => currentPatch%younger + enddo + endif + end subroutine set_patchno ! ============================================================================ @@ -1376,12 +1437,12 @@ subroutine TransLitterNewPatch(currentSite, & new_litt%seed_decay(pft) = new_litt%seed_decay(pft) + & curr_litt%seed_decay(pft)*patch_site_areadis/newPatch%area - + new_litt%seed_germ_decay(pft) = new_litt%seed_germ_decay(pft) + & curr_litt%seed_germ_decay(pft)*patch_site_areadis/newPatch%area end do - + ! ----------------------------------------------------------------------------- ! Distribute the existing litter that was already in place on the donor ! patch. Some of this burns and is sent to the atmosphere, and some goes to the @@ -1509,7 +1570,8 @@ end subroutine TransLitterNewPatch ! ============================================================================ - subroutine fire_litter_fluxes(currentSite, currentPatch, newPatch, patch_site_areadis) + subroutine fire_litter_fluxes(currentSite, currentPatch, & + newPatch, patch_site_areadis, bc_in) ! ! !DESCRIPTION: ! CWD pool burned by a fire. @@ -1528,7 +1590,8 @@ subroutine fire_litter_fluxes(currentSite, currentPatch, newPatch, patch_site_ar type(ed_patch_type) , intent(inout), target :: currentPatch ! Donor Patch type(ed_patch_type) , intent(inout), target :: newPatch ! New Patch real(r8) , intent(in) :: patch_site_areadis ! Area being donated - ! by current patch + type(bc_in_type) , intent(in) :: bc_in + ! ! !LOCAL VARIABLES: @@ -1657,7 +1720,8 @@ subroutine fire_litter_fluxes(currentSite, currentPatch, newPatch, patch_site_ar site_mass%burn_flux_to_atm = site_mass%burn_flux_to_atm + burned_mass - call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil) + call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil, & + bc_in%max_rooting_depth_index_col) ! Contribution of dead trees to root litter (no root burn flux to atm) do dcmpy=1,ndcmpy @@ -1729,7 +1793,8 @@ end subroutine fire_litter_fluxes ! ============================================================================ - subroutine mortality_litter_fluxes(currentSite, currentPatch, newPatch, patch_site_areadis) + subroutine mortality_litter_fluxes(currentSite, currentPatch, & + newPatch, patch_site_areadis,bc_in) ! ! !DESCRIPTION: ! Carbon going from mortality associated with disturbance into CWD pools. @@ -1751,7 +1816,7 @@ subroutine mortality_litter_fluxes(currentSite, currentPatch, newPatch, patch_si type(ed_patch_type) , intent(inout), target :: currentPatch type(ed_patch_type) , intent(inout), target :: newPatch real(r8) , intent(in) :: patch_site_areadis - + type(bc_in_type) , intent(in) :: bc_in ! ! !LOCAL VARIABLES: type(ed_cohort_type), pointer :: currentCohort @@ -1866,7 +1931,8 @@ subroutine mortality_litter_fluxes(currentSite, currentPatch, newPatch, patch_si ag_wood = num_dead * (struct_m + sapw_m) * prt_params%allom_agb_frac(pft) bg_wood = num_dead * (struct_m + sapw_m) * (1.0_r8-prt_params%allom_agb_frac(pft)) - call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil) + call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil, & + bc_in%max_rooting_depth_index_col) do c=1,ncwd @@ -1946,8 +2012,10 @@ end subroutine mortality_litter_fluxes ! ============================================================================ - subroutine create_patch(currentSite, new_patch, age, areap, label) + subroutine create_patch(currentSite, new_patch, age, areap, label,nocomp_pft) + use FatesInterfaceTypesMod, only : hlm_current_tod,hlm_current_date,hlm_reference_date + ! ! !DESCRIPTION: ! Set default values for creating a new patch @@ -1960,6 +2028,12 @@ subroutine create_patch(currentSite, new_patch, age, areap, label) real(r8), intent(in) :: age ! notional age of this patch in years real(r8), intent(in) :: areap ! initial area of this patch in m2. integer, intent(in) :: label ! anthropogenic disturbance label + integer, intent(in) :: nocomp_pft + + + ! Until bc's are pointed to by sites give veg a default temp [K] + real(r8), parameter :: temp_init_veg = 15._r8+t_water_freeze_k_1atm + ! !LOCAL VARIABLES: !--------------------------------------------------------------------- @@ -1976,7 +2050,11 @@ subroutine create_patch(currentSite, new_patch, age, areap, label) allocate(new_patch%sabs_dif(hlm_numSWb)) allocate(new_patch%fragmentation_scaler(currentSite%nlevsoil)) - + allocate(new_patch%tveg24) + call new_patch%tveg24%InitRMean(fixed_24hr,init_value=temp_init_veg,init_offset=real(hlm_current_tod,r8) ) + allocate(new_patch%tveg_lpa) + call new_patch%tveg_lpa%InitRmean(ema_lpa,init_value=temp_init_veg) + ! Litter ! Allocate, Zero Fluxes, and Initialize to "unset" values @@ -2012,6 +2090,7 @@ subroutine create_patch(currentSite, new_patch, age, areap, label) else new_patch%age_since_anthro_disturbance = fates_unset_r8 endif + new_patch%nocomp_pft_label = nocomp_pft ! This new value will be generated when the calculate disturbance ! rates routine is called. This does not need to be remembered or in the restart file. @@ -2160,9 +2239,17 @@ subroutine zero_patch(cp_p) currentPatch%c_stomata = 0.0_r8 ! This is calculated immediately before use currentPatch%c_lblayer = 0.0_r8 currentPatch%fragmentation_scaler(:) = 0.0_r8 + currentPatch%radiation_error = 0.0_r8 + + ! diagnostic radiation profiles + currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 currentPatch%solar_zenith_flag = .false. currentPatch%solar_zenith_angle = nan + currentPatch%fcansno = nan currentPatch%gnd_alb_dir(:) = nan currentPatch%gnd_alb_dif(:) = nan @@ -2194,7 +2281,10 @@ subroutine fuse_patches( csite, bc_in ) integer :: iterate !switch of patch reduction iteration scheme. 1 to keep going, 0 to stop integer :: fuse_flag !do patches get fused (1) or not (0). integer :: i_disttype !iterator over anthropogenic disturbance categories + integer :: i_pftlabel !nocomp pft iterator real(r8) :: primary_land_fraction_beforefusion,primary_land_fraction_afterfusion + integer :: pftlabelmin, pftlabelmax + real(r8) :: maxpatches(n_anthro_disturbance_categories) ! !--------------------------------------------------------------------- @@ -2206,6 +2296,23 @@ subroutine fuse_patches( csite, bc_in ) primary_land_fraction_afterfusion = 0._r8 nopatches(1:n_anthro_disturbance_categories) = 0 + + ! Its possible that, in nocomp modes, there are more categorically distinct patches than we allow as + ! primary patches in non-nocomp mode. So if this is the case, bump up the maximum number of primary patches + ! to let there be one for each type of nocomp PFT on the site. this is likely to lead to problems + ! if anthropogenic disturance is enabled. + if (hlm_use_nocomp.eq.itrue) then + maxpatches(primaryforest) = max(maxPatchesPerSite_by_disttype(primaryforest), sum(csite%use_this_pft)) + maxpatches(secondaryforest) = maxPatchesPerSite - maxpatches(primaryforest) + if (maxPatchesPerSite .lt. maxpatches(primaryforest)) then + write(fates_log(),*) 'too many PFTs and not enough patches for nocomp w/o fixed biogeog' + write(fates_log(),*) 'maxPatchesPerSite,numpft',maxPatchesPerSite,numpft, sum(csite%use_this_pft) + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + else + maxpatches(:) = maxPatchesPerSite_by_disttype(:) + endif + currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) nopatches(currentPatch%anthro_disturbance_label) = & @@ -2219,11 +2326,18 @@ subroutine fuse_patches( csite, bc_in ) currentPatch => currentPatch%older enddo + pftlabelmin = 0 + if ( hlm_use_nocomp .eq. itrue ) then + pftlabelmax = numpft + else + pftlabelmax = 0 + endif + !---------------------------------------------------------------------! ! iterate over anthropogenic disturbance categories !---------------------------------------------------------------------! - do i_disttype = 1, n_anthro_disturbance_categories + disttype_loop: do i_disttype = 1, n_anthro_disturbance_categories !---------------------------------------------------------------------! ! We only really care about fusing patches if nopatches > 1 ! @@ -2235,7 +2349,14 @@ subroutine fuse_patches( csite, bc_in ) ! Keep doing this until nopatches <= maxPatchesPerSite ! !---------------------------------------------------------------------! - do while(iterate == 1) + iterate_eq_1_loop: do while(iterate == 1) + + !---------------------------------------------------------------------! + ! iterate over nocomp pft labels (if nocomp is false, then this isn't much of a loop) + !---------------------------------------------------------------------! + + pftlabel_loop: do i_pftlabel = pftlabelmin, pftlabelmax + !---------------------------------------------------------------------! ! Calculate the biomass profile of each patch ! !---------------------------------------------------------------------! @@ -2249,22 +2370,26 @@ subroutine fuse_patches( csite, bc_in ) ! Loop round current & target (currentPatch,tpp) patches to assess combinations ! !-------------------------------------------------------------------------------! currentPatch => currentSite%youngest_patch - do while(associated(currentPatch)) + currentpatch_loop: do while(associated(currentPatch)) tpp => currentSite%youngest_patch - do while(associated(tpp)) + tpp_loop: do while(associated(tpp)) if(.not.associated(currentPatch))then write(fates_log(),*) 'ED: issue with currentPatch' endif - if(associated(tpp).and.associated(currentPatch))then + both_associated_if: if(associated(tpp).and.associated(currentPatch))then !--------------------------------------------------------------------! ! only fuse patches whose anthropogenic disturbance category matches ! ! that of the outer loop that we are in ! !--------------------------------------------------------------------! - if ( tpp%anthro_disturbance_label .eq. i_disttype .and. & + anthro_dist_labels_match_if: if ( tpp%anthro_disturbance_label .eq. i_disttype .and. & currentPatch%anthro_disturbance_label .eq. i_disttype) then + nocomp_pft_labels_match_if: if (hlm_use_nocomp .eq. ifalse .or. & + (tpp%nocomp_pft_label .eq. i_pftlabel .and. & + currentPatch%nocomp_pft_label .eq. i_pftlabel)) then + !-------------------------------------------------------------------------------------------- ! The default is to fuse the patches, unless some criteria is met which keeps them separated. ! there are multiple criteria which all need to be met to keep them distinct: @@ -2275,13 +2400,13 @@ subroutine fuse_patches( csite, bc_in ) !-------------------------------------------------------------------------------------------- fuse_flag = 1 - if(currentPatch%patchno /= tpp%patchno) then !these should be the same patch + different_patches_if: if(currentPatch%patchno /= tpp%patchno) then !these should be the same patch !----------------------------------------------------------------------------------- ! check to see if both patches are older than the age at which we force them to fuse !----------------------------------------------------------------------------------- - if ( tpp%age .le. max_age_of_second_oldest_patch .or. & + maxage_if: if ( tpp%age .le. max_age_of_second_oldest_patch .or. & currentPatch%age .le. max_age_of_second_oldest_patch ) then @@ -2296,21 +2421,23 @@ subroutine fuse_patches( csite, bc_in ) ! oscillations in the patch dynamics and dependent variables. !------------------------------------------------------------ - if(sum(currentPatch%pft_agb_profile(:,:)) > force_patchfuse_min_biomass .or. & + patchfuse_min_biomass_if: if & + (sum(currentPatch%pft_agb_profile(:,:)) > force_patchfuse_min_biomass .or. & sum(tpp%pft_agb_profile(:,:)) > force_patchfuse_min_biomass ) then !---------------------------------------------------------------------! ! Calculate the difference criteria for each pft and dbh class ! !---------------------------------------------------------------------! - do ft = 1,numpft ! loop over pfts - do z = 1,n_dbh_bins ! loop over hgt bins + pft_loop: do ft = 1,numpft ! loop over pfts + hgt_bin_loop: do z = 1,n_dbh_bins ! loop over hgt bins !---------------------------------- ! is there biomass in this category? !---------------------------------- - if(currentPatch%pft_agb_profile(ft,z) > 0.0_r8 .or. & + agbprof_gt_zero_if: if & + (currentPatch%pft_agb_profile(ft,z) > 0.0_r8 .or. & tpp%pft_agb_profile(ft,z) > 0.0_r8)then !---------------------------------------------------------------------! @@ -2330,12 +2457,12 @@ subroutine fuse_patches( csite, bc_in ) fuse_flag = 0 !do not fuse - keep apart. - endif ! profile tol - endif ! biomass(ft,z) .gt. 0 - enddo !ht bins - enddo ! PFT - endif ! sum(biomass(:,:) .gt. force_patchfuse_min_biomass - endif ! maxage + endif + endif agbprof_gt_zero_if + enddo hgt_bin_loop + enddo pft_loop + endif patchfuse_min_biomass_if + endif maxage_if !-------------------------------------------------------------------------! ! Call the patch fusion routine if there is not a meaningful difference ! @@ -2343,7 +2470,7 @@ subroutine fuse_patches( csite, bc_in ) ! or both are older than forced fusion age ! !-------------------------------------------------------------------------! - if(fuse_flag == 1)then + fuseflagset_if: if(fuse_flag == 1)then !-----------------------! ! fuse the two patches ! @@ -2368,14 +2495,13 @@ subroutine fuse_patches( csite, bc_in ) profiletol = ED_val_patch_fusion_tol - else - ! write(fates_log(),*) 'patches not fused' - endif - endif !are both patches the same anthropogenic disturbance category as the disturbance type loop iterator? - endif !are both patches associated? - endif !are these different patches? + endif fuseflagset_if + endif different_patches_if + endif nocomp_pft_labels_match_if + endif anthro_dist_labels_match_if + endif both_associated_if tpp => tpp%older - enddo !tpp loop + enddo tpp_loop if(associated(currentPatch))then currentPatch => currentPatch%older @@ -2383,7 +2509,9 @@ subroutine fuse_patches( csite, bc_in ) currentPatch => null() endif !associated currentPatch - enddo ! currentPatch loop + enddo currentpatch_loop + + end do pftlabel_loop !---------------------------------------------------------------------! ! Is the number of patches larger than the maximum? ! @@ -2397,20 +2525,32 @@ subroutine fuse_patches( csite, bc_in ) currentPatch => currentPatch%older enddo - if(nopatches(i_disttype) > maxPatchesPerSite_by_disttype(i_disttype))then + if(nopatches(i_disttype) > maxpatches(i_disttype))then iterate = 1 profiletol = profiletol * patch_fusion_tolerance_relaxation_increment !---------------------------------------------------------------------! ! Making profile tolerance larger means that more fusion will happen ! !---------------------------------------------------------------------! + + ! its possible that there are too many categorical patch types and the tolerances + ! will never allow patch fusion to occur. In this case crash and let the user know. + ! the 100 is sort of a random number, in principle since profile tolerance is compared + ! against relative biomass size, it shoudnt ever get above 2 (which would mean fusing + ! a zero with a nonzero biomass in a given category) + if (profiletol .gt. 100._r8) then + write(fates_log(),*) 'profile tolerance is too big, this shouldnt happen.' + write(fates_log(),*) 'probably this means there are too many distinct categorical ' + write(fates_log(),*) 'patch types for the maximum number of patches' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif else iterate = 0 endif - enddo !do while nopatches>maxPatchesPerSite + enddo iterate_eq_1_loop ! iterate .eq. 1 ==> nopatches>maxPatchesPerSite - end do ! i_disttype loop + end do disttype_loop currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) @@ -2477,6 +2617,18 @@ subroutine fuse_2_patches(csite, dp, rp) write(fates_log(),*) 'trying to fuse patches with different anthro_disturbance_label values' call endrun(msg=errMsg(sourcefile, __LINE__)) endif + + if ( hlm_use_nocomp .eq. itrue .and. rp%nocomp_pft_label .ne. dp%nocomp_pft_label) then + write(fates_log(),*) 'trying to fuse patches with different nocomp_pft_label values' + write(fates_log(),*) 'rp%nocomp_pft_label, dp%nocomp_pft_label',rp%nocomp_pft_label, dp%nocomp_pft_label + write(fates_log(),*) 'rp%area, dp%area',rp%area, dp%area + write(fates_log(),*) 'sum(rp%pft_agb_profile(:,:), sum(dp%pft_agb_profile(:,:)',sum(rp%pft_agb_profile(:,:)), sum(dp%pft_agb_profile(:,:)) + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + ! Weighted mean of the running means + call rp%tveg24%FuseRMean(dp%tveg24,rp%area*inv_sum_area) + call rp%tveg_lpa%FuseRMean(dp%tveg_lpa,rp%area*inv_sum_area) rp%fuel_eff_moist = (dp%fuel_eff_moist*dp%area + rp%fuel_eff_moist*rp%area) * inv_sum_area rp%livegrass = (dp%livegrass*dp%area + rp%livegrass*rp%area) * inv_sum_area @@ -2499,7 +2651,8 @@ subroutine fuse_2_patches(csite, dp, rp) rp%zstar = (dp%zstar*dp%area + rp%zstar*rp%area) * inv_sum_area rp%c_stomata = (dp%c_stomata*dp%area + rp%c_stomata*rp%area) * inv_sum_area rp%c_lblayer = (dp%c_lblayer*dp%area + rp%c_lblayer*rp%area) * inv_sum_area - + rp%radiation_error = (dp%radiation_error*dp%area + rp%radiation_error*rp%area) * inv_sum_area + rp%area = rp%area + dp%area !THIS MUST COME AT THE END! !insert donor cohorts into recipient patch @@ -2609,6 +2762,7 @@ subroutine terminate_patches(currentSite) type(ed_patch_type), pointer :: currentPatch type(ed_patch_type), pointer :: olderPatch type(ed_patch_type), pointer :: youngerPatch + type(ed_patch_type), pointer :: patchpointer integer, parameter :: max_cycles = 10 ! After 10 loops through ! You should had fused integer :: count_cycles @@ -2621,21 +2775,46 @@ subroutine terminate_patches(currentSite) currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - - if(currentPatch%area <= min_patch_area)then + lessthan_min_patcharea_if: if(currentPatch%area <= min_patch_area)then + nocomp_if: if (hlm_use_nocomp .eq. itrue) then + + gotfused = .false. + patchpointer => currentSite%youngest_patch + do while(associated(patchpointer)) + if ( .not.associated(currentPatch,patchpointer) .and. & + patchpointer%nocomp_pft_label .eq. currentPatch%nocomp_pft_label .and. & + patchpointer%anthro_disturbance_label .eq. currentPatch%anthro_disturbance_label .and. & + .not. gotfused) then + + call fuse_2_patches(currentSite, patchpointer, currentPatch) + + gotfused = .true. + else + patchpointer => patchpointer%older + endif + end do + + if ( .not. gotfused ) then + !! somehow didn't find a patch to fuse with. + write(fates_log(),*) 'Warning. small nocomp patch wasnt able to find another patch to fuse with.', & + currentPatch%nocomp_pft_label, currentPatch%anthro_disturbance_label + endif + + else nocomp_if + ! Even if the patch area is small, avoid fusing it into its neighbor ! if it is the youngest of all patches. We do this in attempts to maintain ! a discrete patch for very young patches ! However, if the patch to be fused is excessivlely small, then fuse ! at all costs. If it is not fused, it will make - if ( .not.associated(currentPatch,currentSite%youngest_patch) .or. & + notyoungest_if: if ( .not.associated(currentPatch,currentSite%youngest_patch) .or. & currentPatch%area <= min_patch_area_forced ) then gotfused = .false. - if(associated(currentPatch%older) )then + associated_older_if: if(associated(currentPatch%older) )then if(debug) & write(fates_log(),*) 'fusing to older patch because this one is too small',& @@ -2647,7 +2826,7 @@ subroutine terminate_patches(currentSite) olderPatch => currentPatch%older - if (currentPatch%anthro_disturbance_label .eq. olderPatch%anthro_disturbance_label) then + distlabel_1_if: if (currentPatch%anthro_disturbance_label .eq. olderPatch%anthro_disturbance_label) then call fuse_2_patches(currentSite, olderPatch, currentPatch) @@ -2658,19 +2837,19 @@ subroutine terminate_patches(currentSite) ! patch. As mentioned earlier, we try not to fuse it. gotfused = .true. - else - if (count_cycles .gt. 0) then + else distlabel_1_if !i.e. anthro labels of two patches are not the same + countcycles_if: if (count_cycles .gt. 0) then ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its older sibling ! and then allow them to fuse together. currentPatch%anthro_disturbance_label = olderPatch%anthro_disturbance_label call fuse_2_patches(currentSite, olderPatch, currentPatch) gotfused = .true. - endif - endif - endif - - if( .not. gotfused .and. associated(currentPatch%younger) ) then + endif countcycles_if + endif distlabel_1_if + endif associated_older_if + + not_gotfused_if: if( .not. gotfused .and. associated(currentPatch%younger) ) then if(debug) & write(fates_log(),*) 'fusing to younger patch because oldest one is too small', & @@ -2678,25 +2857,26 @@ subroutine terminate_patches(currentSite) youngerPatch => currentPatch%younger - if (currentPatch%anthro_disturbance_label .eq. youngerPatch% anthro_disturbance_label) then + distlabel_2_if: if (currentPatch%anthro_disturbance_label .eq. youngerPatch% anthro_disturbance_label) then call fuse_2_patches(currentSite, youngerPatch, currentPatch) ! The fusion process has updated the "younger" pointer on currentPatch - else + else distlabel_2_if if (count_cycles .gt. 0) then ! if we're having an incredibly hard time fusing patches because of their differing anthropogenic disturbance labels, ! since the size is so small, let's sweep the problem under the rug and change the tiny patch's label to that of its younger sibling currentPatch%anthro_disturbance_label = youngerPatch%anthro_disturbance_label call fuse_2_patches(currentSite, youngerPatch, currentPatch) gotfused = .true. - endif - endif - endif - endif - endif - + endif ! count cycles + endif distlabel_2_if ! anthro labels + endif not_gotfused_if ! has an older patch + endif notyoungest_if ! is not the youngest patch + endif nocomp_if + endif lessthan_min_patcharea_if ! very small patch + ! It is possible that an incredibly small patch just fused into another incredibly ! small patch, resulting in an incredibly small patch. It is also possible that this ! resulting incredibly small patch is the oldest patch. If this was true than @@ -2704,8 +2884,9 @@ subroutine terminate_patches(currentSite) ! Think this is impossible? No, this really happens, especially when we have fires. ! So, we don't move forward until we have merged enough area into this thing. - if(currentPatch%area > min_patch_area_forced)then + if(currentPatch%area > min_patch_area_forced)then currentPatch => currentPatch%older + count_cycles = 0 else count_cycles = count_cycles + 1 @@ -2726,9 +2907,9 @@ subroutine terminate_patches(currentSite) ! an infinite loop. currentPatch => currentPatch%older count_cycles = 0 - end if - - enddo + end if !count cycles + + enddo ! current patch loop !check area is not exceeded call check_patch_area( currentSite ) @@ -2813,9 +2994,13 @@ subroutine dealloc_patch(cpatch) deallocate(cpatch%sabs_dir) deallocate(cpatch%sabs_dif) deallocate(cpatch%fragmentation_scaler) - end if + + ! Deallocate any running means + deallocate(cpatch%tveg24) + deallocate(cpatch%tveg_lpa) + return end subroutine dealloc_patch diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 9063a33c50..5d66f56d39 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -3,7 +3,7 @@ module EDPhysiologyMod #include "shr_assert.h" ! ============================================================================ - ! Miscellaneous physiology routines from ED. + ! Miscellaneous physiology routines from ED. ! ============================================================================ use FatesGlobals, only : fates_log @@ -15,6 +15,8 @@ module EDPhysiologyMod use FatesInterfaceTypesMod, only : nleafage use FatesInterfaceTypesMod, only : hlm_use_planthydro use FatesInterfaceTypesMod, only : hlm_parteh_mode + use FatesInterfaceTypesMod, only : hlm_use_fixed_biogeog + use FatesInterfaceTypesMod, only : hlm_use_nocomp use FatesInterfaceTypesMod, only : hlm_nitrogen_spec use FatesInterfaceTypesMod, only : hlm_phosphorus_spec use FatesConstantsMod, only : r8 => fates_r8 @@ -29,12 +31,14 @@ module EDPhysiologyMod use EDCohortDynamicsMod , only : InitPRTObject use FatesAllometryMod , only : tree_lai use FatesAllometryMod , only : tree_sai + use FatesAllometryMod , only : leafc_from_treelai use FatesAllometryMod , only : decay_coeff_kn use FatesLitterMod , only : litter_type use EDTypesMod , only : site_massbal_type use EDTypesMod , only : numlevsoil_max use EDTypesMod , only : numWaterMem - use EDTypesMod , only : dl_sf, dinc_ed, area_inv + use EDTypesMod , only : dl_sf, dinc_vai, dlower_vai, area_inv + use EDTypesMod , only : AREA use FatesLitterMod , only : ncwd use FatesLitterMod , only : ndcmpy use FatesLitterMod , only : ilabile @@ -59,6 +63,7 @@ module EDPhysiologyMod use EDTypesMod , only : phen_dstat_moistoff use EDTypesMod , only : phen_dstat_moiston use EDTypesMod , only : phen_dstat_timeon + use EDTypesMod , only : init_recruit_trim use shr_log_mod , only : errMsg => shr_log_errMsg use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun @@ -101,28 +106,30 @@ module EDPhysiologyMod use PRTLossFluxesMod, only : PRTPhenologyFlush use PRTLossFluxesMod, only : PRTDeciduousTurnover use PRTLossFluxesMod, only : PRTReproRelease + use PRTGenericMod, only : StorageNutrientTarget - + implicit none + private public :: trim_canopy public :: phenology + public :: satellite_phenology + public :: assign_cohort_SP_properties public :: recruitment public :: ZeroLitterFluxes - + public :: ZeroAllocationRates public :: PreDisturbanceLitterFluxes - public :: PreDisturbanceIntegrateLitter + public :: PreDisturbanceIntegrateLitter public :: SeedIn - + logical, parameter :: debug = .false. ! local debug flag character(len=*), parameter, private :: sourcefile = & - __FILE__ - - integer, parameter :: dleafon_drycheck = 100 ! Drought deciduous leaves max days on check parameter + __FILE__ + integer, parameter :: dleafon_drycheck = 100 ! Drought deciduous leaves max days on check parameter - ! ============================================================================ contains @@ -135,7 +142,7 @@ subroutine ZeroLitterFluxes( currentSite ) ! call sequence. - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type), pointer :: currentPatch @@ -148,7 +155,7 @@ subroutine ZeroLitterFluxes( currentSite ) end do currentPatch => currentPatch%older end do - + return end subroutine ZeroLitterFluxes @@ -157,20 +164,20 @@ end subroutine ZeroLitterFluxes subroutine ZeroAllocationRates( currentSite ) - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type), pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - + currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) ! This sets turnover and growth rates to zero call currentCohort%prt%ZeroRates() - + currentCohort => currentCohort%shorter enddo currentPatch => currentPatch%older @@ -185,7 +192,7 @@ end subroutine ZeroAllocationRates subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! ----------------------------------------------------------------------------------- - ! + ! ! This subroutine calculates all of the different litter input and output fluxes ! associated with seed turnover, seed influx, litterfall from live and ! dead plants, germination, and fragmentation. @@ -197,46 +204,44 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) ! with disturbance. Those fluxes are handled elsewhere (EDPatchDynamcisMod) ! because the fluxes are potentially cross patch, and also dealing ! patch areas that are changing. - ! + ! ! ----------------------------------------------------------------------------------- - - ! !ARGUMENTS + + ! !ARGUMENTS type(ed_site_type), intent(inout) :: currentSite type(ed_patch_type), intent(inout) :: currentPatch type(bc_in_type), intent(in) :: bc_in ! ! !LOCAL VARIABLES: - type(site_massbal_type), pointer :: site_mass - type(litter_type), pointer :: litt ! Points to the litter object for - ! the different element types + type(site_massbal_type), pointer :: site_mass + type(litter_type), pointer :: litt ! Points to the litter object for + ! the different element types integer :: el ! Litter element loop index integer :: nlev_eff_decomp ! Number of active layers over which - ! fragmentation fluxes are transfered + ! fragmentation fluxes are transfered !------------------------------------------------------------------------------------ - ! Calculate the fragmentation rates + ! Calculate the fragmentation rates call fragmentation_scaler(currentPatch, bc_in) - do el = 1, num_elements - + litt => currentPatch%litter(el) ! Calculate loss rate of viable seeds to litter call SeedDecay(litt) - + ! Calculate seed germination rate, the status flags prevent - ! germination from occuring when the site is in a drought + ! germination from occuring when the site is in a drought ! (for drought deciduous) or too cold (for cold deciduous) call SeedGermination(litt, currentSite%cstatus, currentSite%dstatus) - + ! Send fluxes from newly created litter into the litter pools ! This litter flux is from non-disturbance inducing mortality, as well ! as litter fluxes from live trees - call CWDInput(currentSite, currentPatch, litt) - + call CWDInput(currentSite, currentPatch, litt,bc_in) ! Only calculate fragmentation flux over layers that are active ! (RGK-Mar2019) SHOULD WE MAX THIS AT 1? DONT HAVE TO @@ -244,18 +249,17 @@ subroutine PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in ) nlev_eff_decomp = max(bc_in%max_rooting_depth_index_col, 1) call CWDOut(litt,currentPatch%fragmentation_scaler,nlev_eff_decomp) - site_mass => currentSite%mass_balance(el) - + ! Fragmentation flux to soil decomposition model [kg/site/day] site_mass%frag_out = site_mass%frag_out + currentPatch%area * & ( sum(litt%ag_cwd_frag) + sum(litt%bg_cwd_frag) + & sum(litt%leaf_fines_frag) + sum(litt%root_fines_frag) + & sum(litt%seed_decay) + sum(litt%seed_germ_decay)) - + end do - - + + return end subroutine PreDisturbanceLitterFluxes @@ -265,14 +269,14 @@ subroutine PreDisturbanceIntegrateLitter(currentPatch) ! ----------------------------------------------------------------------------------- ! - ! This step applies the litter fluxes to the prognostic state variables. + ! This step applies the litter fluxes to the prognostic state variables. ! This procedure is called in response to fluxes generated from: - ! 1) seed rain, + ! 1) seed rain, ! 2) non-disturbance generating turnover ! 3) litter fall from living plants ! 4) fragmentation ! - ! This routine does NOT accomodate the litter fluxes associated with + ! This routine does NOT accomodate the litter fluxes associated with ! disturbance generation. That will happen after this call. ! Fluxes associated with FIRE also happen after this step. ! @@ -287,7 +291,7 @@ subroutine PreDisturbanceIntegrateLitter(currentPatch) ! Locals - type(litter_type), pointer :: litt + type(litter_type), pointer :: litt integer :: el ! Loop counter for litter element type integer :: pft ! pft loop counter integer :: c ! CWD loop counter @@ -296,28 +300,28 @@ subroutine PreDisturbanceIntegrateLitter(currentPatch) integer :: dcmpy ! decomposability index do el = 1, num_elements - + litt => currentPatch%litter(el) - + ! Update the bank of viable seeds ! ----------------------------------------------------------------------------------- - + do pft = 1,numpft litt%seed(pft) = litt%seed(pft) + & - litt%seed_in_local(pft) + & - litt%seed_in_extern(pft) - & - litt%seed_decay(pft) - & - litt%seed_germ_in(pft) + litt%seed_in_local(pft) + & + litt%seed_in_extern(pft) - & + litt%seed_decay(pft) - & + litt%seed_germ_in(pft) ! Note that the recruitment scheme will use seed_germ ! for its construction costs. litt%seed_germ(pft) = litt%seed_germ(pft) + & - litt%seed_germ_in(pft) - & - litt%seed_germ_decay(pft) + litt%seed_germ_in(pft) - & + litt%seed_germ_decay(pft) enddo - + ! Update the Coarse Woody Debris pools (above and below) ! ----------------------------------------------------------------------------------- nlevsoil = size(litt%bg_cwd,dim=2) @@ -329,40 +333,40 @@ subroutine PreDisturbanceIntegrateLitter(currentPatch) - litt%bg_cwd_frag(c,ilyr) enddo end do - + ! Update the fine litter pools from leaves and fine-roots ! ----------------------------------------------------------------------------------- - + do dcmpy = 1,ndcmpy - litt%leaf_fines(dcmpy) = litt%leaf_fines(dcmpy) & - + litt%leaf_fines_in(dcmpy) & - - litt%leaf_fines_frag(dcmpy) - do ilyr=1,nlevsoil - litt%root_fines(dcmpy,ilyr) = litt%root_fines(dcmpy,ilyr) & - + litt%root_fines_in(dcmpy,ilyr) & - - litt%root_fines_frag(dcmpy,ilyr) - enddo + litt%leaf_fines(dcmpy) = litt%leaf_fines(dcmpy) & + + litt%leaf_fines_in(dcmpy) & + - litt%leaf_fines_frag(dcmpy) + do ilyr=1,nlevsoil + litt%root_fines(dcmpy,ilyr) = litt%root_fines(dcmpy,ilyr) & + + litt%root_fines_in(dcmpy,ilyr) & + - litt%root_fines_frag(dcmpy,ilyr) + enddo end do - + end do ! litter element loop - + return end subroutine PreDisturbanceIntegrateLitter - + ! ============================================================================ subroutine trim_canopy( currentSite ) ! ! !DESCRIPTION: - ! Canopy trimming / leaf optimisation. Removes leaves in negative annual carbon balance. + ! Canopy trimming / leaf optimisation. Removes leaves in negative annual carbon balance. ! ! !USES: - ! !ARGUMENTS + ! !ARGUMENTS type (ed_site_type),intent(inout), target :: currentSite ! ! !LOCAL VARIABLES: @@ -371,7 +375,7 @@ subroutine trim_canopy( currentSite ) integer :: z ! leaf layer integer :: ipft ! pft index - logical :: trimmed ! was this layer trimmed in this year? If not expand the canopy. + logical :: trimmed ! was this layer trimmed in this year? If not expand the canopy. real(r8) :: tar_bl ! target leaf biomass (leaves flushed, trimmed) real(r8) :: tar_bfr ! target fine-root biomass (leaves flushed, trimmed) real(r8) :: bfr_per_bleaf ! ratio of fine root per leaf biomass @@ -384,10 +388,10 @@ subroutine trim_canopy( currentSite ) real(r8) :: sapw_c ! sapwood carbon [kg] real(r8) :: store_c ! storage carbon [kg] real(r8) :: struct_c ! structure carbon [kg] - real(r8) :: leaf_inc ! LAI-only portion of the vegetation increment of dinc_ed + real(r8) :: leaf_inc ! LAI-only portion of the vegetation increment of dinc_vai real(r8) :: lai_canopy_above ! the LAI in the canopy layers above the layer of interest - real(r8) :: lai_layers_above ! the LAI in the leaf layers, within the current canopy, - ! above the leaf layer of interest + real(r8) :: lai_layers_above ! the LAI in the leaf layers, within the current canopy, + ! above the leaf layer of interest real(r8) :: lai_current ! the LAI in the current leaf layer real(r8) :: cumulative_lai ! whole canopy cumulative LAI, top down, to the leaf layer of interest real(r8) :: cumulative_lai_cohort ! cumulative LAI within the current cohort only @@ -398,15 +402,15 @@ subroutine trim_canopy( currentSite ) ! LAPACK linear least squares fit variables ! The standard equation for a linear fit, y = mx + b, is converted to a linear system, AX=B and has - ! the form: [n sum(x); sum(x) sum(x^2)] * [b; m] = [sum(y); sum(x*y)] where - ! n is the number of leaf layers + ! the form: [n sum(x); sum(x) sum(x^2)] * [b; m] = [sum(y); sum(x*y)] where + ! n is the number of leaf layers ! x is yearly_net_uptake minus the leaf cost aka the net-net uptake ! y is the cumulative lai for the current cohort ! b is the y-intercept i.e. the cumulative lai that has zero net-net uptake ! m is the slope of the linear fit integer :: nll = 3 ! Number of leaf layers to fit a regression to for calculating the optimum lai character(1) :: trans = 'N' ! Input matrix is not transposed - + integer, parameter :: m = 2, n = 2 ! Number of rows and columns, respectively, in matrix A integer, parameter :: nrhs = 1 ! Number of columns in matrix B and X integer, parameter :: workmax = 100 ! Maximum iterations to minimize work @@ -414,13 +418,13 @@ subroutine trim_canopy( currentSite ) integer :: lda = m, ldb = n ! Leading dimension of A and B, respectively integer :: lwork ! Dimension of work array integer :: info ! Procedure diagnostic ouput - + real(r8) :: nnu_clai_a(m,n) ! LHS of linear least squares fit, A matrix real(r8) :: nnu_clai_b(m,nrhs) ! RHS of linear least squares fit, B matrix real(r8) :: work(workmax) ! work array real(r8) :: initial_trim ! Initial trim - real(r8) :: optimum_trim ! Optimum trim value + real(r8) :: optimum_trim ! Optimum trim value real(r8) :: initial_laimem ! Initial laimemory real(r8) :: optimum_laimem ! Optimum laimemory @@ -430,28 +434,28 @@ subroutine trim_canopy( currentSite ) currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - + ! Add debug diagnstic output to determine which patch if (debug) then write(fates_log(),*) 'Current patch:', ipatch write(fates_log(),*) 'Current patch cohorts:', currentPatch%countcohorts endif - + icohort = 1 - + currentCohort => currentPatch%tallest - do while (associated(currentCohort)) + do while (associated(currentCohort)) - ! Save off the incoming trim and laimemory - initial_trim = currentCohort%canopy_trim - initial_laimem = currentCohort%laimemory + ! Save off the incoming trim and laimemory + initial_trim = currentCohort%canopy_trim + initial_laimem = currentCohort%laimemory ! Add debug diagnstic output to determine which cohort if (debug) then - write(fates_log(),*) 'Current cohort:', icohort - write(fates_log(),*) 'Starting canopy trim:', initial_trim - write(fates_log(),*) 'Starting laimemory:', currentCohort%laimemory - endif + write(fates_log(),*) 'Current cohort:', icohort + write(fates_log(),*) 'Starting canopy trim:', initial_trim + write(fates_log(),*) 'Starting laimemory:', currentCohort%laimemory + endif trimmed = .false. ipft = currentCohort%pft @@ -460,20 +464,20 @@ subroutine trim_canopy( currentSite ) leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) currentCohort%treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & - currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) + currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai,currentCohort%vcmax25top ) currentCohort%treesai = tree_sai(currentCohort%pft, currentCohort%dbh, currentCohort%canopy_trim, & - currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & - currentPatch%canopy_layer_tlai, currentCohort%treelai, & - currentCohort%vcmax25top,0 ) + currentCohort%c_area, currentCohort%n, currentCohort%canopy_layer, & + currentPatch%canopy_layer_tlai, currentCohort%treelai, & + currentCohort%vcmax25top,0 ) - currentCohort%nv = ceiling((currentCohort%treelai+currentCohort%treesai)/dinc_ed) + currentCohort%nv = count((currentCohort%treelai+currentCohort%treesai) .gt. dlower_vai(:)) + 1 if (currentCohort%nv > nlevleaf)then write(fates_log(),*) 'nv > nlevleaf',currentCohort%nv, & - currentCohort%treelai,currentCohort%treesai, & - currentCohort%c_area,currentCohort%n,leaf_c + currentCohort%treelai,currentCohort%treesai, & + currentCohort%c_area,currentCohort%n,leaf_c call endrun(msg=errMsg(sourcefile, __LINE__)) endif @@ -487,34 +491,34 @@ subroutine trim_canopy( currentSite ) ! Identify current canopy layer (cl) cl = currentCohort%canopy_layer - + ! PFT-level maximum SLA value, even if under a thick canopy (same units as slatop) sla_max = prt_params%slamax(ipft) ! Initialize nnu_clai_a nnu_clai_a(:,:) = 0._r8 nnu_clai_b(:,:) = 0._r8 - - !Leaf cost vs netuptake for each leaf layer. + + !Leaf cost vs netuptake for each leaf layer. do z = 1, currentCohort%nv ! Calculate the cumulative total vegetation area index (no snow occlusion, stems and leaves) - - leaf_inc = dinc_ed * & - currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) + leaf_inc = dinc_vai(z) * & + currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) ! Now calculate the cumulative top-down lai of the current layer's midpoint within the current cohort - lai_layers_above = leaf_inc * (z-1) + lai_layers_above = (dlower_vai(z) - dinc_vai(z)) * & + currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) lai_current = min(leaf_inc, currentCohort%treelai - lai_layers_above) cumulative_lai_cohort = lai_layers_above + 0.5*lai_current ! Now add in the lai above the current cohort for calculating the sla leaf level - lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) cumulative_lai = lai_canopy_above + cumulative_lai_cohort ! There was activity this year in this leaf layer. This should only occur for bottom most leaf layer - if (currentCohort%year_net_uptake(z) /= 999._r8)then - + if (currentCohort%year_net_uptake(z) /= 999._r8)then + ! Calculate sla_levleaf following the sla profile with overlying leaf area ! Scale for leaf nitrogen profile kn = decay_coeff_kn(ipft,currentCohort%vcmax25top) @@ -526,11 +530,11 @@ subroutine trim_canopy( currentSite ) if(sla_levleaf > sla_max)then sla_levleaf = sla_max end if - + !Leaf Cost kgC/m2/year-1 - !decidous costs. + !decidous costs. if (prt_params%season_decid(ipft) == itrue .or. & - prt_params%stress_decid(ipft) == itrue )then + prt_params%stress_decid(ipft) == itrue )then ! Leaf cost at leaf level z accounting for sla profile (kgC/m2) currentCohort%leaf_cost = 1._r8/(sla_levleaf*1000.0_r8) @@ -544,14 +548,14 @@ subroutine trim_canopy( currentSite ) endif currentCohort%leaf_cost = currentCohort%leaf_cost * & - (prt_params%grperc(ipft) + 1._r8) + (prt_params%grperc(ipft) + 1._r8) else !evergreen costs ! Leaf cost at leaf level z accounting for sla profile currentCohort%leaf_cost = 1.0_r8/(sla_levleaf* & sum(prt_params%leaf_long(ipft,:))*1000.0_r8) !convert from sla in m2g-1 to m2kg-1 - - + + if ( int(prt_params%allom_fmode(ipft)) .eq. 1 ) then ! if using trimmed leaf for fine root biomass allometry, add the cost of the root increment ! to the leaf increment; otherwise do not. @@ -560,26 +564,26 @@ subroutine trim_canopy( currentSite ) bfr_per_bleaf / prt_params%root_long(ipft) endif currentCohort%leaf_cost = currentCohort%leaf_cost * & - (prt_params%grperc(ipft) + 1._r8) + (prt_params%grperc(ipft) + 1._r8) endif ! Construct the arrays for a least square fit of the net_net_uptake versus the cumulative lai - ! if at least nll leaf layers are present in the current cohort and only for the bottom nll + ! if at least nll leaf layers are present in the current cohort and only for the bottom nll ! leaf layers. - if (currentCohort%nv > nll .and. currentCohort%nv - z < nll) then - - ! Build the A matrix for the LHS of the linear system. A = [n sum(x); sum(x) sum(x^2)] - ! where n = nll and x = yearly_net_uptake-leafcost - nnu_clai_a(1,1) = nnu_clai_a(1,1) + 1 ! Increment for each layer used - nnu_clai_a(1,2) = nnu_clai_a(1,2) + currentCohort%year_net_uptake(z) - currentCohort%leaf_cost - nnu_clai_a(2,1) = nnu_clai_a(1,2) - nnu_clai_a(2,2) = nnu_clai_a(2,2) + (currentCohort%year_net_uptake(z) - currentCohort%leaf_cost)**2 - - ! Build the B matrix for the RHS of the linear system. B = [sum(y); sum(x*y)] - ! where x = yearly_net_uptake-leafcost and y = cumulative_lai_cohort - nnu_clai_b(1,1) = nnu_clai_b(1,1) + cumulative_lai_cohort - nnu_clai_b(2,1) = nnu_clai_b(2,1) + (cumulative_lai_cohort * & - (currentCohort%year_net_uptake(z) - currentCohort%leaf_cost)) + if (currentCohort%nv > nll .and. currentCohort%nv - z < nll) then + + ! Build the A matrix for the LHS of the linear system. A = [n sum(x); sum(x) sum(x^2)] + ! where n = nll and x = yearly_net_uptake-leafcost + nnu_clai_a(1,1) = nnu_clai_a(1,1) + 1 ! Increment for each layer used + nnu_clai_a(1,2) = nnu_clai_a(1,2) + currentCohort%year_net_uptake(z) - currentCohort%leaf_cost + nnu_clai_a(2,1) = nnu_clai_a(1,2) + nnu_clai_a(2,2) = nnu_clai_a(2,2) + (currentCohort%year_net_uptake(z) - currentCohort%leaf_cost)**2 + + ! Build the B matrix for the RHS of the linear system. B = [sum(y); sum(x*y)] + ! where x = yearly_net_uptake-leafcost and y = cumulative_lai_cohort + nnu_clai_b(1,1) = nnu_clai_b(1,1) + cumulative_lai_cohort + nnu_clai_b(2,1) = nnu_clai_b(2,1) + (cumulative_lai_cohort * & + (currentCohort%year_net_uptake(z) - currentCohort%leaf_cost)) end if ! Check leaf cost against the yearly net uptake for that cohort leaf layer @@ -587,18 +591,18 @@ subroutine trim_canopy( currentSite ) ! Make sure the cohort trim fraction is great than the pft trim limit if (currentCohort%canopy_trim > EDPftvarcon_inst%trim_limit(ipft)) then - ! if ( debug ) then - ! write(fates_log(),*) 'trimming leaves', & - ! currentCohort%canopy_trim,currentCohort%leaf_cost - ! endif + ! if ( debug ) then + ! write(fates_log(),*) 'trimming leaves', & + ! currentCohort%canopy_trim,currentCohort%leaf_cost + ! endif - ! keep trimming until none of the canopy is in negative carbon balance. + ! keep trimming until none of the canopy is in negative carbon balance. if (currentCohort%hite > EDPftvarcon_inst%hgt_min(ipft)) then currentCohort%canopy_trim = currentCohort%canopy_trim - & - EDPftvarcon_inst%trim_inc(ipft) + EDPftvarcon_inst%trim_inc(ipft) if (prt_params%evergreen(ipft) /= 1)then currentCohort%laimemory = currentCohort%laimemory * & - (1.0_r8 - EDPftvarcon_inst%trim_inc(ipft)) + (1.0_r8 - EDPftvarcon_inst%trim_inc(ipft)) endif trimmed = .true. @@ -606,75 +610,75 @@ subroutine trim_canopy( currentSite ) endif ! hite check endif ! trim limit check endif ! net uptake check - endif ! leaf activity check + endif ! leaf activity check enddo ! z, leaf layer loop ! Compute the optimal cumulative lai based on the cohort net-net uptake profile if at least 2 leaf layers if (nnu_clai_a(1,1) > 1) then - ! Compute the optimum size of the work array - lwork = -1 ! Ask sgels to compute optimal number of entries for work - call dgels(trans, m, n, nrhs, nnu_clai_a, lda, nnu_clai_b, ldb, work, lwork, info) - lwork = int(work(1)) ! Pick the optimum. TBD, can work(1) come back with greater than work size? - - ! if (debug) then - ! write(fates_log(),*) 'LLSF lwork output (info, lwork):', info, lwork - ! endif - - ! Compute the minimum of 2-norm of of the least squares fit to solve for X - ! Note that dgels returns the solution by overwriting the nnu_clai_b array. - ! The result has the form: X = [b; m] - ! where b = y-intercept (i.e. the cohort lai that has zero yearly net-net uptake) - ! and m is the slope of the linear fit - call dgels(trans, m, n, nrhs, nnu_clai_a, lda, nnu_clai_b, ldb, work, lwork, info) - - if (info < 0) then - write(fates_log(),*) 'LLSF optimium LAI calculation returned illegal value' - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - - if (debug) then - write(fates_log(),*) 'LLSF optimium LAI (intercept,slope):', nnu_clai_b - write(fates_log(),*) 'LLSF optimium LAI:', nnu_clai_b(1,1) - write(fates_log(),*) 'LLSF optimium LAI info:', info - write(fates_log(),*) 'LAI fraction (optimum_lai/cumulative_lai):', nnu_clai_b(1,1) / cumulative_lai_cohort - endif - - ! Calculate the optimum trim based on the initial canopy trim value - if (cumulative_lai_cohort > 0._r8) then ! Sometime cumulative_lai comes in at 0.0? - - ! - optimum_trim = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_trim - optimum_laimem = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_laimem - - ! Determine if the optimum trim value makes sense. The smallest cohorts tend to have unrealistic fits. - if (optimum_trim > 0. .and. optimum_trim < 1.) then - currentCohort%canopy_trim = optimum_trim - - ! If the cohort pft is not evergreen we reduce the laimemory as well - if (prt_params%evergreen(ipft) /= 1) then - currentCohort%laimemory = optimum_laimem - endif + ! Compute the optimum size of the work array + lwork = -1 ! Ask sgels to compute optimal number of entries for work + call dgels(trans, m, n, nrhs, nnu_clai_a, lda, nnu_clai_b, ldb, work, lwork, info) + lwork = int(work(1)) ! Pick the optimum. TBD, can work(1) come back with greater than work size? + + ! if (debug) then + ! write(fates_log(),*) 'LLSF lwork output (info, lwork):', info, lwork + ! endif + + ! Compute the minimum of 2-norm of of the least squares fit to solve for X + ! Note that dgels returns the solution by overwriting the nnu_clai_b array. + ! The result has the form: X = [b; m] + ! where b = y-intercept (i.e. the cohort lai that has zero yearly net-net uptake) + ! and m is the slope of the linear fit + call dgels(trans, m, n, nrhs, nnu_clai_a, lda, nnu_clai_b, ldb, work, lwork, info) + + if (info < 0) then + write(fates_log(),*) 'LLSF optimium LAI calculation returned illegal value' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + if (debug) then + write(fates_log(),*) 'LLSF optimium LAI (intercept,slope):', nnu_clai_b + write(fates_log(),*) 'LLSF optimium LAI:', nnu_clai_b(1,1) + write(fates_log(),*) 'LLSF optimium LAI info:', info + write(fates_log(),*) 'LAI fraction (optimum_lai/cumulative_lai):', nnu_clai_b(1,1) / cumulative_lai_cohort + endif + + ! Calculate the optimum trim based on the initial canopy trim value + if (cumulative_lai_cohort > 0._r8) then ! Sometime cumulative_lai comes in at 0.0? + + ! + optimum_trim = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_trim + optimum_laimem = (nnu_clai_b(1,1) / cumulative_lai_cohort) * initial_laimem + + ! Determine if the optimum trim value makes sense. The smallest cohorts tend to have unrealistic fits. + if (optimum_trim > 0. .and. optimum_trim < 1.) then + currentCohort%canopy_trim = optimum_trim + + ! If the cohort pft is not evergreen we reduce the laimemory as well + if (prt_params%evergreen(ipft) /= 1) then + currentCohort%laimemory = optimum_laimem + endif - trimmed = .true. + trimmed = .true. - endif - endif - endif + endif + endif + endif ! Reset activity for the cohort for the start of the next year currentCohort%year_net_uptake(:) = 999.0_r8 - ! Add to trim fraction if cohort not trimmed at all + ! Add to trim fraction if cohort not trimmed at all if ( (.not.trimmed) .and.currentCohort%canopy_trim < 1.0_r8)then currentCohort%canopy_trim = currentCohort%canopy_trim + EDPftvarcon_inst%trim_inc(ipft) - endif + 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%canopy_trim = 1.0_r8 !FIX(RF,032414) this turns off ctrim for now. currentCohort => currentCohort%shorter icohort = icohort + 1 enddo @@ -688,14 +692,14 @@ end subroutine trim_canopy subroutine phenology( currentSite, bc_in ) ! ! !DESCRIPTION: - ! Phenology. + ! 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: @@ -722,7 +726,7 @@ subroutine phenology( currentSite, bc_in ) real(r8) :: struct_c ! structure carbon [kg] real(r8) :: gdd_threshold ! GDD accumulation function, integer :: ilayer_swater ! Layer index for soil water - ! which also depends on chilling days. + ! which also depends on chilling days. integer :: ncdstart ! beginning of counting period for chilling degree days. integer :: gddstart ! beginning of counting period for growing degree days. real(r8) :: temp_in_C ! daily averaged temperature in celcius @@ -730,16 +734,16 @@ subroutine phenology( currentSite, bc_in ) integer, parameter :: canopy_leaf_lifespan = 365 ! Maximum lifespan of drought decid leaves integer, parameter :: min_daysoff_dforcedflush = 30 ! THis is the number of days that must had elapsed - ! since leaves had dropped, in order to forcably - ! flush leaves again. This does not impact flushing - ! due to real moisture constraints, and will prevent - ! drought deciduous in perennially wet environments - ! that have been forced to drop their leaves, from - ! flushing them back immediately. + ! since leaves had dropped, in order to forcably + ! flush leaves again. This does not impact flushing + ! due to real moisture constraints, and will prevent + ! drought deciduous in perennially wet environments + ! that have been forced to drop their leaves, from + ! flushing them back immediately. real(r8),parameter :: dphen_soil_depth = 0.1 ! Use liquid soil water that is - ! closest to this depth [m] - + ! closest to this depth [m] + ! This is the integer model day. The first day of the simulation is 1, and it ! continues monotonically, indefinitely model_day_int = nint(hlm_model_day) @@ -749,31 +753,31 @@ subroutine phenology( currentSite, bc_in ) ilayer_swater = minloc(abs(bc_in%z_sisl(:)-dphen_soil_depth),dim=1) - ! Parameter of drought decid leaf loss in mm in top layer...FIX(RF,032414) + ! Parameter of drought decid leaf loss in mm in top layer...FIX(RF,032414) ! - this is arbitrary and poorly understood. Needs work. ED_ - !Parameters: defaults from Botta et al. 2000 GCB,6 709-725 + !Parameters: defaults from Botta et al. 2000 GCB,6 709-725 !Parameters, default from from SDGVM model of senesence temp_in_C = 0._r8 - cpatch => CurrentSite%oldest_patch - do while(associated(cpatch)) - temp_in_C = temp_in_C + bc_in%t_veg24_pa(cpatch%patchno)*cpatch%area + cpatch => CurrentSite%oldest_patch + do while(associated(cpatch)) + temp_in_C = temp_in_C + cpatch%tveg24%GetMean()*cpatch%area cpatch => cpatch%younger end do temp_in_C = temp_in_C * area_inv - tfrz - - - !-----------------Cold Phenology--------------------! + + + !-----------------Cold Phenology--------------------! !Zero growing degree and chilling day counters if (currentSite%lat > 0)then ncdstart = 270 !Northern Hemisphere begining November - gddstart = 1 !Northern Hemisphere begining January + gddstart = 1 !Northern Hemisphere begining January else ncdstart = 120 !Southern Hemisphere beginning May gddstart = 181 !Northern Hemisphere begining July endif - + ! Count the number of chilling days over a seasonal window. ! For comparing against GDD, we start calculating chilling ! in the late autumn. @@ -788,7 +792,7 @@ subroutine phenology( currentSite, bc_in ) endif !GDD accumulation function, which also depends on chilling days. - ! -68 + 638 * (-0.001 * ncd) + ! -68 + 638 * (-0.001 * ncd) gdd_threshold = ED_val_phen_a + ED_val_phen_b*exp(ED_val_phen_c*real(currentSite%nchilldays,r8)) !Accumulate temperature of last 10 days. @@ -815,28 +819,28 @@ subroutine phenology( currentSite, bc_in ) if (temp_in_C .gt. 0._r8 .and. currentSite%cstatus == phen_cstat_iscold) then currentSite%grow_deg_days = currentSite%grow_deg_days + temp_in_C endif - - !this logic is to prevent GDD accumulating after the leaves have fallen and before the - ! beginnning of the accumulation period, to prevend erroneous autumn leaf flushing. + + !this logic is to prevent GDD accumulating after the leaves have fallen and before the + ! beginnning of the accumulation period, to prevend erroneous autumn leaf flushing. if(model_day_int>365)then !only do this after the first year to prevent odd behaviour - if(currentSite%lat .gt. 0.0_r8)then !Northern Hemisphere - ! In the north, don't accumulate when we are past the leaf fall date. - ! Accumulation starts on day 1 of year in NH. - ! The 180 is to prevent going into an 'always off' state after initialization - if( model_day_int .gt. currentSite%cleafoffdate.and.hlm_day_of_year.gt.180)then ! - currentSite%grow_deg_days = 0._r8 - endif - else !Southern Hemisphere - ! In the South, don't accumulate after the leaf off date, and before the start of - ! the accumulation phase (day 181). - if(model_day_int .gt. currentSite%cleafoffdate.and.hlm_day_of_year.lt.gddstart) then! - currentSite%grow_deg_days = 0._r8 - endif - endif - endif !year1 + if(currentSite%lat .gt. 0.0_r8)then !Northern Hemisphere + ! In the north, don't accumulate when we are past the leaf fall date. + ! Accumulation starts on day 1 of year in NH. + ! The 180 is to prevent going into an 'always off' state after initialization + if( model_day_int .gt. currentSite%cleafoffdate.and.hlm_day_of_year.gt.180)then ! + currentSite%grow_deg_days = 0._r8 + endif + else !Southern Hemisphere + ! In the South, don't accumulate after the leaf off date, and before the start of + ! the accumulation phase (day 181). + if(model_day_int .gt. currentSite%cleafoffdate.and.hlm_day_of_year.lt.gddstart) then! + currentSite%grow_deg_days = 0._r8 + endif + endif + endif !year1 - ! Calculate the number of days since the leaves last came on + ! Calculate the number of days since the leaves last came on ! and off. If this is the beginning of the simulation, that day might ! not had occured yet, so set it to last year to get things rolling @@ -855,22 +859,22 @@ subroutine phenology( currentSite, bc_in ) !LEAF ON: COLD DECIDUOUS. Needs to - !1) have exceeded the growing degree day threshold + !1) have exceeded the growing degree day threshold !2) The leaves should not be on already - !3) There should have been at least one chilling day in the counting period. + !3) There should have been at least one chilling day in the counting period. ! this prevents tropical or warm climate plants that are "cold-deciduous" ! from ever re-flushing after they have reached their maximum age (thus ! preventing them from competing if ( (currentSite%cstatus == phen_cstat_iscold .or. & - currentSite%cstatus == phen_cstat_nevercold) .and. & + currentSite%cstatus == phen_cstat_nevercold) .and. & (currentSite%grow_deg_days > gdd_threshold) .and. & (dayssincecleafoff > ED_val_phen_mindayson) .and. & (currentSite%nchilldays >= 1)) then currentSite%cstatus = phen_cstat_notcold ! Set to not-cold status (leaves can come on) - currentSite%cleafondate = model_day_int - dayssincecleafon = 0 - currentSite%grow_deg_days = 0._r8 ! zero GDD for the rest of the year until counting season begins. + currentSite%cleafondate = model_day_int + dayssincecleafon = 0 + currentSite%grow_deg_days = 0._r8 ! zero GDD for the rest of the year until counting season begins. if ( debug ) write(fates_log(),*) 'leaves on' endif !GDD @@ -882,25 +886,25 @@ subroutine phenology( currentSite, bc_in ) !1) have exceeded the number of cold days threshold !2) have exceeded the minimum leafon time. !3) The leaves should not be off already - !4) The day of simulation should be larger than the counting period. + !4) The day of simulation should be larger than the counting period. + - if ( (currentSite%cstatus == phen_cstat_notcold) .and. & (model_day_int > num_vegtemp_mem) .and. & (ncolddays > ED_val_phen_ncolddayslim) .and. & (dayssincecleafon > ED_val_phen_mindayson) )then - + currentSite%grow_deg_days = 0._r8 ! The equations for Botta et al - ! are for calculations of - ! first flush, but if we dont - ! clear this value, it will cause - ! leaves to flush later in the year + ! are for calculations of + ! first flush, but if we dont + ! clear this value, it will cause + ! leaves to flush later in the year currentSite%cstatus = phen_cstat_iscold ! alter status of site to 'leaves off' - currentSite%cleafoffdate = model_day_int ! record leaf off date + currentSite%cleafoffdate = model_day_int ! record leaf off date if ( debug ) write(fates_log(),*) 'leaves off' endif - + ! LEAF OFF: COLD LIFESPAN THRESHOLD ! NOTE: Some areas of the planet will never generate a cold day ! and thus %nchilldays will never go from zero to 1. The following logic @@ -908,59 +912,59 @@ subroutine phenology( currentSite, bc_in ) ! plants from re-emerging in areas without at least some cold days if( (currentSite%cstatus == phen_cstat_notcold) .and. & - (dayssincecleafoff > 400)) then ! remove leaves after a whole year - ! when there is no 'off' period. + (dayssincecleafoff > 400)) then ! remove leaves after a whole year + ! when there is no 'off' period. currentSite%grow_deg_days = 0._r8 currentSite%cstatus = phen_cstat_nevercold ! alter status of site to imply that this - ! site is never really cold enough - ! for cold deciduous - currentSite%cleafoffdate = model_day_int ! record leaf off date - + ! site is never really cold enough + ! for cold deciduous + currentSite%cleafoffdate = model_day_int ! record leaf off date + if ( debug ) write(fates_log(),*) 'leaves off' endif !-----------------Drought Phenology--------------------! ! Principles of drought-deciduos phenology model... - ! The 'is_drought' flag is false when leaves are on, and true when leaves area off. - ! The following sets those site-level flags, which are acted on in phenology_deciduos. - ! A* The leaves live for either the length of time the soil moisture is over the threshold - ! or the lifetime of the leaves, whichever is shorter. + ! The 'is_drought' flag is false when leaves are on, and true when leaves area off. + ! The following sets those site-level flags, which are acted on in phenology_deciduos. + ! A* The leaves live for either the length of time the soil moisture is over the threshold + ! or the lifetime of the leaves, whichever is shorter. ! B*: If the soil is only wet for a very short time, then the leaves stay on for 100 days - ! C*: The leaves are only permitted to come ON for a 60 day window around when they last came on, + ! C*: The leaves are only permitted to come ON for a 60 day window around when they last came on, ! to prevent 'flickering' on in response to wet season storms - ! D*: We don't allow anything to happen in the first ten days to allow the water memory window - ! to come into equlibirium. - ! E*: If the soil is always wet, the leaves come on at the beginning of the window, and then - ! last for their lifespan. + ! D*: We don't allow anything to happen in the first ten days to allow the water memory window + ! to come into equlibirium. + ! E*: If the soil is always wet, the leaves come on at the beginning of the window, and then + ! last for their lifespan. ! ISSUES - ! 1. It's not clear what water content we should track. Here we are tracking the top layer, - ! but we probably should track something like BTRAN, but BTRAN is defined for each PFT, + ! 1. It's not clear what water content we should track. Here we are tracking the top layer, + ! but we probably should track something like BTRAN, but BTRAN is defined for each PFT, ! and there could potentially be more than one stress-dec PFT.... ? - ! 2. In the beginning, the window is set at an arbitrary time of the year, so the leaves + ! 2. In the beginning, the window is set at an arbitrary time of the year, so the leaves ! might come on in the dry season, using up stored reserves - ! for the stress-dec plants, and potentially killing them. To get around this, + ! for the stress-dec plants, and potentially killing them. To get around this, ! we need to read in the 'leaf on' date from some kind of start-up file - ! but we would need that to happen for every resolution, etc. + ! but we would need that to happen for every resolution, etc. ! 3. Will this methodology properly kill off the stress-dec trees where there is no - ! water stress? What about where the wet period coincides with the warm period? + ! water stress? What about where the wet period coincides with the warm period? ! We would just get them overlapping with the cold-dec trees, even though that isn't appropriate - ! Why don't the drought deciduous trees grow in the North? - ! Is cold decidousness maybe even the same as drought deciduosness there (and so does this - ! distinction actually matter??).... + ! Why don't the drought deciduous trees grow in the North? + ! Is cold decidousness maybe even the same as drought deciduosness there (and so does this + ! distinction actually matter??).... ! Accumulate surface water memory of last 10 days. ! Liquid volume in ground layer (m3/m3) do i_wmem = 1,numWaterMem-1 !shift memory along one currentSite%water_memory(numWaterMem+1-i_wmem) = currentSite%water_memory(numWaterMem-i_wmem) enddo - currentSite%water_memory(1) = bc_in%h2o_liqvol_sl(ilayer_swater) + currentSite%water_memory(1) = bc_in%h2o_liqvol_sl(ilayer_swater) ! Calculate the mean water content over the last 10 days (m3/m3) mean_10day_liqvol = sum(currentSite%water_memory(1:numWaterMem))/real(numWaterMem,r8) - ! In drought phenology, we often need to force the leaves to stay - ! on or off as moisture fluctuates... + ! In drought phenology, we often need to force the leaves to stay + ! on or off as moisture fluctuates... ! Calculate days since leaves have come off, but make a provision ! for the first year of simulation, we have to assume a leaf drop @@ -971,34 +975,34 @@ subroutine phenology( currentSite, bc_in ) else dayssincedleafoff = model_day_int - currentSite%dleafoffdate endif - - ! the leaves are on. How long have they been on? + + ! the leaves are on. How long have they been on? if (model_day_int < currentSite%dleafondate) then dayssincedleafon = model_day_int - (currentSite%dleafondate-365) else - dayssincedleafon = model_day_int - currentSite%dleafondate + dayssincedleafon = model_day_int - currentSite%dleafondate endif ! LEAF ON: DROUGHT DECIDUOUS WETNESS - ! Here, we used a window of oppurtunity to determine if we are + ! Here, we used a window of oppurtunity to determine if we are ! close to the time when then leaves came on last year - + ! Has it been ... - ! a) a year, plus or minus 1 month since we last had leaf-on? + ! a) a year, plus or minus 1 month since we last had leaf-on? ! b) Has there also been at least a nominaly short amount of "leaf-off" ! c) is the model day at least > 10 (let soil water spin-up) ! Note that cold-starts begin in the "leaf-on" ! status if ( (currentSite%dstatus == phen_dstat_timeoff .or. & - currentSite%dstatus == phen_dstat_moistoff) .and. & - (model_day_int > numWaterMem) .and. & - (dayssincedleafon >= 365-30 .and. dayssincedleafon <= 365+30 ) .and. & - (dayssincedleafoff > ED_val_phen_doff_time) ) then + currentSite%dstatus == phen_dstat_moistoff) .and. & + (model_day_int > numWaterMem) .and. & + (dayssincedleafon >= 365-30 .and. dayssincedleafon <= 365+30 ) .and. & + (dayssincedleafoff > ED_val_phen_doff_time) ) then ! If leaves are off, and have been off for at least a few days ! and the time is consistent with the correct ! time window... test if the moisture conditions allow for leaf-on - + if ( mean_10day_liqvol >= ED_val_phen_drought_threshold ) then currentSite%dstatus = phen_dstat_moiston ! set status to leaf-on currentSite%dleafondate = model_day_int ! save the model day we start flushing @@ -1009,9 +1013,9 @@ subroutine phenology( currentSite, bc_in ) ! LEAF ON: DROUGHT DECIDUOUS TIME EXCEEDANCE ! If we still haven't done budburst by end of window, then force it - ! If the status is "phen_dstat_moistoff", it means this site currently has - ! leaves off due to actual moisture limitations. - ! So we trigger bud-burst at the end of the month since + ! If the status is "phen_dstat_moistoff", it means this site currently has + ! leaves off due to actual moisture limitations. + ! So we trigger bud-burst at the end of the month since ! last year's bud-burst. If this is imposed, then we set the new ! status to indicate bud-burst was forced by timing @@ -1034,33 +1038,34 @@ subroutine phenology( currentSite, bc_in ) end if end if - ! LEAF OFF: DROUGHT DECIDUOUS LIFESPAN - if the leaf gets to - ! the end of its useful life. A*, E* - ! i.e. Are the leaves rouhgly at the end of their lives? + ! LEAF OFF: DROUGHT DECIDUOUS LIFESPAN - if the leaf gets to + ! the end of its useful life. A*, E* + ! i.e. Are the leaves rouhgly at the end of their lives? if ( (currentSite%dstatus == phen_dstat_moiston .or. & - currentSite%dstatus == phen_dstat_timeon ) .and. & - (dayssincedleafon > canopy_leaf_lifespan) )then - currentSite%dstatus = phen_dstat_timeoff !alter status of site to 'leaves off' - currentSite%dleafoffdate = model_day_int !record leaf on date + currentSite%dstatus == phen_dstat_timeon ) .and. & + (dayssincedleafon > canopy_leaf_lifespan) )then + currentSite%dstatus = phen_dstat_timeoff !alter status of site to 'leaves off' + currentSite%dleafoffdate = model_day_int !record leaf on date endif - ! LEAF OFF: DROUGHT DECIDUOUS DRYNESS - if the soil gets too dry, - ! and the leaves have already been on a while... + ! LEAF OFF: DROUGHT DECIDUOUS DRYNESS - if the soil gets too dry, + ! and the leaves have already been on a while... if ( (currentSite%dstatus == phen_dstat_moiston .or. & - currentSite%dstatus == phen_dstat_timeon ) .and. & + currentSite%dstatus == phen_dstat_timeon ) .and. & (model_day_int > numWaterMem) .and. & (mean_10day_liqvol <= ED_val_phen_drought_threshold) .and. & - (dayssincedleafon > dleafon_drycheck ) ) then + (dayssincedleafon > dleafon_drycheck ) ) then currentSite%dstatus = phen_dstat_moistoff ! alter status of site to 'leaves off' - currentSite%dleafoffdate = model_day_int ! record leaf on date + currentSite%dleafoffdate = model_day_int ! record leaf on date endif call phenology_leafonoff(currentSite) end subroutine phenology + ! ============================================================================ subroutine phenology_leafonoff(currentSite) ! @@ -1073,8 +1078,8 @@ subroutine phenology_leafonoff(currentSite) type(ed_site_type), intent(inout), target :: currentSite ! ! !LOCAL VARIABLES: - type(ed_patch_type) , pointer :: currentPatch - type(ed_cohort_type), pointer :: currentCohort + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort real(r8) :: leaf_c ! leaf carbon [kg] real(r8) :: sapw_c ! sapwood carbon [kg] @@ -1088,11 +1093,11 @@ subroutine phenology_leafonoff(currentSite) real(r8) :: stem_drop_fraction !------------------------------------------------------------------------ - currentPatch => CurrentSite%oldest_patch + currentPatch => CurrentSite%oldest_patch - do while(associated(currentPatch)) + do while(associated(currentPatch)) currentCohort => currentPatch%tallest - do while(associated(currentCohort)) + do while(associated(currentCohort)) ipft = currentCohort%pft @@ -1104,243 +1109,481 @@ subroutine phenology_leafonoff(currentSite) leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) sapw_c = currentCohort%prt%GetState(sapw_organ, all_carbon_elements) struct_c = currentCohort%prt%GetState(struct_organ, all_carbon_elements) - + stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(ipft) - + ! COLD LEAF ON ! The site level flags signify that it is no-longer too cold ! for leaves. Time to signal flushing if (prt_params%season_decid(ipft) == itrue)then - if ( currentSite%cstatus == phen_cstat_notcold )then ! we have just moved to leaves being on . - if (currentCohort%status_coh == leaves_off)then ! Are the leaves currently off? - currentCohort%status_coh = leaves_on ! Leaves are on, so change status to - ! stop flow of carbon out of bstore. - + if ( currentSite%cstatus == phen_cstat_notcold )then ! we have just moved to leaves being on . + if (currentCohort%status_coh == leaves_off)then ! Are the leaves currently off? + currentCohort%status_coh = leaves_on ! Leaves are on, so change status to + ! stop flow of carbon out of bstore. + if(store_c>nearzero) then - ! flush either the amount required from the laimemory, or -most- of the storage pool - ! RF: added a criterion to stop the entire store pool emptying and triggering termination mortality - ! n.b. this might not be necessary if we adopted a more gradual approach to leaf flushing... - store_c_transfer_frac = min((EDPftvarcon_inst%phenflush_fraction(ipft)* & - currentCohort%laimemory)/store_c,(1.0_r8-carbon_store_buffer)) + ! flush either the amount required from the laimemory, or -most- of the storage pool + ! RF: added a criterion to stop the entire store pool emptying and triggering termination mortality + ! n.b. this might not be necessary if we adopted a more gradual approach to leaf flushing... + store_c_transfer_frac = min((EDPftvarcon_inst%phenflush_fraction(ipft)* & + currentCohort%laimemory)/store_c,(1.0_r8-carbon_store_buffer)) + + if(prt_params%woody(ipft).ne.itrue)then + totalmemory=currentCohort%laimemory+currentCohort%sapwmemory+currentCohort%structmemory + store_c_transfer_frac = min((EDPftvarcon_inst%phenflush_fraction(ipft)* & + totalmemory)/store_c, (1.0_r8-carbon_store_buffer)) + endif - if(prt_params%woody(ipft).ne.itrue)then - totalmemory=currentCohort%laimemory+currentCohort%sapwmemory+currentCohort%structmemory - store_c_transfer_frac = min((EDPftvarcon_inst%phenflush_fraction(ipft)* & - totalmemory)/store_c, (1.0_r8-carbon_store_buffer)) - endif - else store_c_transfer_frac = 0.0_r8 end if - ! This call will request that storage carbon will be transferred to + ! This call will request that storage carbon will be transferred to ! leaf tissues. It is specified as a fraction of the available storage - if(prt_params%woody(ipft) == itrue) then + if(prt_params%woody(ipft) == itrue) then + + call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, store_c_transfer_frac) + currentCohort%laimemory = 0.0_r8 - call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, store_c_transfer_frac) - currentCohort%laimemory = 0.0_r8 + else + + ! Check that the stem drop fraction is set to non-zero amount otherwise flush all carbon store to leaves + if (stem_drop_fraction .gt. 0.0_r8) then + + call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & + store_c_transfer_frac*currentCohort%laimemory/totalmemory) - else - - ! Check that the stem drop fraction is set to non-zero amount otherwise flush all carbon store to leaves - if (stem_drop_fraction .gt. 0.0_r8) then + call PRTPhenologyFlush(currentCohort%prt, ipft, sapw_organ, & + store_c_transfer_frac*currentCohort%sapwmemory/totalmemory) - call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac*currentCohort%laimemory/totalmemory) + call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & + store_c_transfer_frac*currentCohort%structmemory/totalmemory) - call PRTPhenologyFlush(currentCohort%prt, ipft, sapw_organ, & - store_c_transfer_frac*currentCohort%sapwmemory/totalmemory) + else - call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & - store_c_transfer_frac*currentCohort%structmemory/totalmemory) + call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & + store_c_transfer_frac) - else + end if - call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac) + currentCohort%laimemory = 0.0_r8 + currentCohort%structmemory = 0.0_r8 + currentCohort%sapwmemory = 0.0_r8 - end if - - currentCohort%laimemory = 0.0_r8 - currentCohort%structmemory = 0.0_r8 - currentCohort%sapwmemory = 0.0_r8 - - endif + endif endif !pft phenology - endif ! growing season + endif ! growing season !COLD LEAF OFF if (currentSite%cstatus == phen_cstat_nevercold .or. & - currentSite%cstatus == phen_cstat_iscold) then ! past leaf drop day? Leaves still on tree? + currentSite%cstatus == phen_cstat_iscold) then ! past leaf drop day? Leaves still on tree? if (currentCohort%status_coh == leaves_on) then ! leaves have not dropped - ! leaf off occur on individuals bigger than specific size for grass - if (currentCohort%dbh > EDPftvarcon_inst%phen_cold_size_threshold(ipft) & - .or. prt_params%woody(ipft)==itrue) then - - ! This sets the cohort to the "leaves off" flag - currentCohort%status_coh = leaves_off + ! leaf off occur on individuals bigger than specific size for grass + if (currentCohort%dbh > EDPftvarcon_inst%phen_cold_size_threshold(ipft) & + .or. prt_params%woody(ipft)==itrue) then - ! Remember what the lai was (leaf mass actually) was for next year - ! the same amount back on in the spring... + ! This sets the cohort to the "leaves off" flag + currentCohort%status_coh = leaves_off - currentCohort%laimemory = leaf_c + ! Remember what the lai was (leaf mass actually) was for next year + ! the same amount back on in the spring... - ! Drop Leaves (this routine will update the leaf state variables, - ! for carbon and any other element that are prognostic. It will - ! also track the turnover masses that will be sent to litter later on) + currentCohort%laimemory = leaf_c - call PRTDeciduousTurnover(currentCohort%prt,ipft, & - leaf_organ, leaf_drop_fraction) - - if(prt_params%woody(ipft).ne.itrue)then - - currentCohort%sapwmemory = sapw_c * stem_drop_fraction - - currentCohort%structmemory = struct_c * stem_drop_fraction + ! Drop Leaves (this routine will update the leaf state variables, + ! for carbon and any other element that are prognostic. It will + ! also track the turnover masses that will be sent to litter later on) + + call PRTDeciduousTurnover(currentCohort%prt,ipft, & + leaf_organ, leaf_drop_fraction) + + if(prt_params%woody(ipft).ne.itrue)then + + currentCohort%sapwmemory = sapw_c * stem_drop_fraction + + currentCohort%structmemory = struct_c * stem_drop_fraction - call PRTDeciduousTurnover(currentCohort%prt,ipft, & + call PRTDeciduousTurnover(currentCohort%prt,ipft, & sapw_organ, stem_drop_fraction) - call PRTDeciduousTurnover(currentCohort%prt,ipft, & + call PRTDeciduousTurnover(currentCohort%prt,ipft, & struct_organ, stem_drop_fraction) - endif ! woody plant check - endif ! individual dbh size check - endif !leaf status - endif !currentSite status - endif !season_decid + endif ! woody plant check + endif ! individual dbh size check + endif !leaf status + endif !currentSite status + endif !season_decid ! DROUGHT LEAF ON ! Site level flag indicates it is no longer in drought condition ! deciduous plants can flush if (prt_params%stress_decid(ipft) == itrue )then - - if (currentSite%dstatus == phen_dstat_moiston .or. & - currentSite%dstatus == phen_dstat_timeon )then - ! we have just moved to leaves being on . - if (currentCohort%status_coh == leaves_off)then + if (currentSite%dstatus == phen_dstat_moiston .or. & + currentSite%dstatus == phen_dstat_timeon )then + + ! we have just moved to leaves being on . + if (currentCohort%status_coh == leaves_off)then - !is it the leaf-on day? Are the leaves currently off? + !is it the leaf-on day? Are the leaves currently off? - currentCohort%status_coh = leaves_on ! Leaves are on, so change status to - ! stop flow of carbon out of bstore. + currentCohort%status_coh = leaves_on ! Leaves are on, so change status to + ! stop flow of carbon out of bstore. - if(store_c>nearzero) then + if(store_c>nearzero) then - store_c_transfer_frac = & + store_c_transfer_frac = & min((EDPftvarcon_inst%phenflush_fraction(ipft)*currentCohort%laimemory)/store_c, & (1.0_r8-carbon_store_buffer)) if(prt_params%woody(ipft).ne.itrue)then - + totalmemory=currentCohort%laimemory+currentCohort%sapwmemory+currentCohort%structmemory store_c_transfer_frac = min(EDPftvarcon_inst%phenflush_fraction(ipft)*totalmemory/store_c, & (1.0_r8-carbon_store_buffer)) - endif + endif + + else + store_c_transfer_frac = 0.0_r8 + endif - else - store_c_transfer_frac = 0.0_r8 - endif - - ! This call will request that storage carbon will be transferred to + ! This call will request that storage carbon will be transferred to ! leaf tissues. It is specified as a fraction of the available storage - if(prt_params%woody(ipft) == itrue) then - - call PRTPhenologyFlush(currentCohort%prt, ipft, & - leaf_organ, store_c_transfer_frac) - - currentCohort%laimemory = 0.0_r8 - - else - - ! Check that the stem drop fraction is set to non-zero amount otherwise flush all carbon store to leaves - if (stem_drop_fraction .gt. 0.0_r8) then - - call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac*currentCohort%laimemory/totalmemory) - - call PRTPhenologyFlush(currentCohort%prt, ipft, sapw_organ, & - store_c_transfer_frac*currentCohort%sapwmemory/totalmemory) - - call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & - store_c_transfer_frac*currentCohort%structmemory/totalmemory) - - else - - call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & - store_c_transfer_frac) - - end if - - currentCohort%laimemory = 0.0_r8 - currentCohort%structmemory = 0.0_r8 - currentCohort%sapwmemory = 0.0_r8 - - endif ! woody plant check - endif !currentCohort status again? - endif !currentSite status - - !DROUGHT LEAF OFF - if (currentSite%dstatus == phen_dstat_moistoff .or. & - currentSite%dstatus == phen_dstat_timeoff) then - - if (currentCohort%status_coh == leaves_on) then ! leaves have not dropped - - ! This sets the cohort to the "leaves off" flag - currentCohort%status_coh = leaves_off - - ! Remember what the lai (leaf mass actually) was for next year - currentCohort%laimemory = leaf_c - - call PRTDeciduousTurnover(currentCohort%prt,ipft, & + if(prt_params%woody(ipft) == itrue) then + + call PRTPhenologyFlush(currentCohort%prt, ipft, & + leaf_organ, store_c_transfer_frac) + + currentCohort%laimemory = 0.0_r8 + + else + + ! Check that the stem drop fraction is set to non-zero amount otherwise flush all carbon store to leaves + if (stem_drop_fraction .gt. 0.0_r8) then + + call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & + store_c_transfer_frac*currentCohort%laimemory/totalmemory) + + call PRTPhenologyFlush(currentCohort%prt, ipft, sapw_organ, & + store_c_transfer_frac*currentCohort%sapwmemory/totalmemory) + + call PRTPhenologyFlush(currentCohort%prt, ipft, struct_organ, & + store_c_transfer_frac*currentCohort%structmemory/totalmemory) + + else + + call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, & + store_c_transfer_frac) + + end if + + currentCohort%laimemory = 0.0_r8 + currentCohort%structmemory = 0.0_r8 + currentCohort%sapwmemory = 0.0_r8 + + endif ! woody plant check + endif !currentCohort status again? + endif !currentSite status + + !DROUGHT LEAF OFF + if (currentSite%dstatus == phen_dstat_moistoff .or. & + currentSite%dstatus == phen_dstat_timeoff) then + + if (currentCohort%status_coh == leaves_on) then ! leaves have not dropped + + ! This sets the cohort to the "leaves off" flag + currentCohort%status_coh = leaves_off + + ! Remember what the lai (leaf mass actually) was for next year + currentCohort%laimemory = leaf_c + + call PRTDeciduousTurnover(currentCohort%prt,ipft, & leaf_organ, leaf_drop_fraction) - - if(prt_params%woody(ipft).ne.itrue)then - - currentCohort%sapwmemory = sapw_c * stem_drop_fraction - currentCohort%structmemory = struct_c * stem_drop_fraction - call PRTDeciduousTurnover(currentCohort%prt,ipft, & - sapw_organ, stem_drop_fraction) + if(prt_params%woody(ipft).ne.itrue)then + + currentCohort%sapwmemory = sapw_c * stem_drop_fraction + currentCohort%structmemory = struct_c * stem_drop_fraction + + call PRTDeciduousTurnover(currentCohort%prt,ipft, & + sapw_organ, stem_drop_fraction) - call PRTDeciduousTurnover(currentCohort%prt,ipft, & - struct_organ, stem_drop_fraction) - endif + call PRTDeciduousTurnover(currentCohort%prt,ipft, & + struct_organ, stem_drop_fraction) + endif - endif - endif !status - endif !drought dec. + endif + endif !status + endif !drought dec. - if(debug) call currentCohort%prt%CheckMassConservation(ipft,1) + if(debug) call currentCohort%prt%CheckMassConservation(ipft,1) - currentCohort => currentCohort%shorter - enddo !currentCohort + currentCohort => currentCohort%shorter + enddo !currentCohort - currentPatch => currentPatch%younger + currentPatch => currentPatch%younger - enddo !currentPatch + enddo !currentPatch end subroutine phenology_leafonoff + ! ===================================================================================== + + subroutine satellite_phenology(currentSite, bc_in) + + ! ----------------------------------------------------------------------------------- + ! Takes the daily inputs of leaf area index, stem area index and canopy height and + ! translates them into a FATES structure with one patch and one cohort per PFT + ! The leaf area of the cohort is modified each day to match that asserted by the HLM + ! ----------------------------------------------------------------------------------- + + ! !USES: + ! + ! !ARGUMENTS: + type(ed_site_type), intent(inout), target :: currentSite + type(bc_in_type), intent(in) :: bc_in + + class(prt_vartypes), pointer :: prt + + ! !LOCAL VARIABLES: + type(ed_patch_type) , pointer :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + real(r8) :: spread ! dummy value of canopy spread to estimate c_area + real(r8) :: leaf_c ! leaf carbon estimated to generate target tlai + real(r8) :: check_treelai + integer :: fates_pft ! fates pft numer for weighting loop + integer :: hlm_pft ! host land model pft number for weighting loop. + integer :: s ! site index + + + ! To Do in this routine. + ! Get access to HLM input varialbes. + ! Weight them by PFT + ! Loop around patches, and for each single cohort in each patch + ! call assign_cohort_SP_properties to determine cohort height, dbh, 'n', area, leafc from drivers. + + currentSite%sp_tlai(:) = 0._r8 + currentSite%sp_tsai(:) = 0._r8 + currentSite%sp_htop(:) = 0._r8 + + ! WEIGHTING OF FATES PFTs on to HLM_PFTs + ! 1. Add up the area associated with each FATES PFT + ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) + ! hlm_pft_map is the area of that land in each FATES PFT (from param file) + + ! 2. weight each fates PFT target for lai, sai and htop by the area of the + ! contrbuting HLM PFTs. + + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) + + fates_pft = currentPatch%nocomp_pft_label + if(fates_pft.ne.0)then + + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + + if(bc_in%pft_areafrac(hlm_pft) * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft).gt.0.0_r8)then + !leaf area index + currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) + & + bc_in%hlm_sp_tlai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & + * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) + !stem area index + currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) + & + bc_in%hlm_sp_tsai(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & + * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) + ! canopy height + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) + & + bc_in%hlm_sp_htop(hlm_pft) * bc_in%pft_areafrac(hlm_pft) & + * EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) + end if ! there is some area in this patch + end do !hlm_pft + + ! weight for total area in each patch/fates_pft + ! this is needed because the area of pft_areafrac does not need to sum to 1.0 + if(currentPatch%area.gt.0.0_r8)then + currentSite%sp_tlai(fates_pft) = currentSite%sp_tlai(fates_pft) & + /(currentPatch%area/area) + currentSite%sp_tsai(fates_pft) = currentSite%sp_tsai(fates_pft) & + /(currentPatch%area/area) + currentSite%sp_htop(fates_pft) = currentSite%sp_htop(fates_pft) & + /(currentPatch%area/area) + endif + + end if ! not bare patch + currentPatch => currentPatch%younger + end do ! patch loop + + ! ------------------------------------------------------------ + ! now we have the target lai, sai and htop for each PFT/patch + ! find properties of the cohort that go along with that + ! 1. Find canopy area from HTOP (height) + ! 2. Find 'n' associated with canopy area, given a closed canopy + ! 3. Find 'bleaf' associated with TLAI and canopy area. + ! These things happen in the catchily titled "assign_cohort_SP_properties" routine. + ! ------------------------------------------------------------ + + currentPatch => currentSite%oldest_patch + do while (associated(currentPatch)) + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) + + ! FIRST SOME CHECKS. + fates_pft =currentCohort%pft + if(fates_pft.ne.currentPatch%nocomp_pft_label)then ! does this cohort belong in this PFT patch? + write(fates_log(),*) 'wrong PFT label in cohort in SP mode',fates_pft,currentPatch%nocomp_pft_label + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(fates_pft.eq.0)then + write(fates_log(),*) 'PFT0 in SP mode' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Call routine to invert SP drivers into cohort properites. + call assign_cohort_SP_properties(currentCohort, currentSite%sp_htop(fates_pft), currentSite%sp_tlai(fates_pft) , currentSite%sp_tsai(fates_pft),currentPatch%area,ifalse,leaf_c) + + currentCohort => currentCohort%shorter + end do !cohort loop + currentPatch => currentPatch%younger + end do ! patch loop + + end subroutine satellite_phenology + + ! ===================================================================================== + + subroutine assign_cohort_SP_properties(currentCohort,htop,tlai,tsai,parea,init,leaf_c) + + ! -----------------------------------------------------------------------------------! + ! Takes the daily inputs of leaf area index, stem area index and canopy height and + ! translates them into a FATES structure with one patch and one cohort per PFT + ! The leaf area of the cohort is modified each day to match that asserted by the HLM + ! -----------------------------------------------------------------------------------! + use EDTypesMod , only : nclmax + + type(ed_cohort_type), intent(inout), target :: currentCohort + + real(r8), intent(in) :: tlai ! target leaf area index from SP inputs + real(r8), intent(in) :: tsai ! target stem area index from SP inputs + real(r8), intent(in) :: htop ! target tree height from SP inputs + real(r8), intent(in) :: parea ! patch area for this PFT + integer, intent(in) :: init ! are we in the initialization routine? if so do not set leaf_c + real(r8), intent(out) :: leaf_c ! leaf carbon estimated to generate target tlai + + real(r8) :: dummy_n ! set cohort n to a dummy value of 1.0 + integer :: fates_pft ! fates pft numer for weighting loop + real(r8) :: spread ! dummy value of canopy spread to estimate c_area + real(r8) :: check_treelai + real(r8) :: canopylai(1:nclmax) + real(r8) :: fracerr + real(r8) :: oldcarea + + ! Do some checks + if(associated(currentCohort%shorter))then + write(fates_log(),*) 'SP mode has >1 cohort' + write(fates_log(),*) "SP mode >1 cohort: PFT",currentCohort%pft, currentCohort%shorter%pft + write(fates_log(),*) "SP mode >1 cohort: CL",currentCohort%canopy_layer, currentCohort%shorter%canopy_layer + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + !------------------------------------------ + ! Calculate dbh from input height, and c_area from dbh + !------------------------------------------ + currentCohort%hite = htop + + fates_pft = currentCohort%pft + call h2d_allom(currentCohort%hite,fates_pft,currentCohort%dbh) + + dummy_n = 1.0_r8 ! make n=1 to get area of one tree. + spread = 1.0_r8 ! fix this to 0 to remove dynamics of canopy closure, assuming a closed canopy. + ! n.b. the value of this will only affect 'n', which isn't/shouldn't be a diagnostic in + ! SP mode. + call carea_allom(currentCohort%dbh,dummy_n,spread,currentCohort%pft,currentCohort%c_area) + + !------------------------------------------ + ! Calculate canopy N assuming patch area is full + !------------------------------------------ + currentCohort%n = parea / currentCohort%c_area + + ! correct c_area for the new nplant + call carea_allom(currentCohort%dbh,currentCohort%n,spread,currentCohort%pft,currentCohort%c_area) + + ! ------------------------------------------ + ! Calculate leaf carbon from target treelai + ! ------------------------------------------ + currentCohort%treelai = tlai + canopylai(:) = 0._r8 + if(init.eq.itrue)then + ! If we are initializing, the canopy layer has not been set yet, so just set to 1 + currentCohort%canopy_layer = 1 + ! We need to get the vcmax25top + currentCohort%vcmax25top = EDPftvarcon_inst%vcmax25top(currentCohort%pft,1) + endif + leaf_c = leafc_from_treelai( currentCohort%treelai, currentCohort%pft, currentCohort%c_area,& + currentCohort%n, currentCohort%canopy_layer, currentCohort%vcmax25top) + + !check that the inverse calculation of leafc from treelai is the same as the + ! standard calculation of treelai from leafc. Maybe can delete eventually? + + check_treelai = tree_lai(leaf_c, currentCohort%pft, currentCohort%c_area, & + currentCohort%n, currentCohort%canopy_layer, & + canopylai,currentCohort%vcmax25top ) + + if( abs(currentCohort%treelai-check_treelai).gt.1.0e-12)then !this is not as precise as nearzero + write(fates_log(),*) 'error in validate treelai',currentCohort%treelai,check_treelai,currentCohort%treelai-check_treelai + write(fates_log(),*) 'tree_lai inputs: ', currentCohort%pft, currentCohort%c_area, currentCohort%n, & + currentCohort%canopy_layer, currentCohort%vcmax25top + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! the carea_allom routine sometimes generates precision-tolerance level errors in the canopy area + ! these mean that the canopy area does not exactly add up to the patch area, which causes chaos in + ! the radiation routines. Correct both the area and the 'n' to remove error, and don't use + !! carea_allom in SP mode after this point. + + if(abs(currentCohort%c_area-parea).gt.nearzero)then ! there is an error + if(abs(currentCohort%c_area-parea).lt.10.e-9)then !correct this if it's a very small error + oldcarea = currentCohort%c_area + !generate new cohort area + currentCohort%c_area = currentCohort%c_area - (currentCohort%c_area- parea) + currentCohort%n = currentCohort%n * (currentCohort%c_area/oldcarea) + if(abs(currentCohort%c_area-parea).gt.nearzero)then + write(fates_log(),*) 'SPassign, c_area still broken',currentCohort%c_area-parea,currentCohort%c_area-oldcarea + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + else + write(fates_log(),*) 'SPassign, big error in c_area',currentCohort%c_area-parea,currentCohort%pft + end if ! still broken + end if !small error + + if(init.eq.ifalse)then + call SetState(currentCohort%prt, leaf_organ, carbon12_element, leaf_c, 1) + endif + + ! assert sai + currentCohort%treesai = tsai + + end subroutine assign_cohort_SP_properties ! ===================================================================================== subroutine SeedIn( currentSite, bc_in ) ! ----------------------------------------------------------------------------------- - ! Flux from plants into the seed pool. + ! Flux from plants into the seed pool. ! It is assumed that allocation to seed on living pools has already been calculated ! at the daily time step. ! Note: Some seed generation can occur during disturbance. It is assumed that ! some plants use their storage upon death to create seeds, but this in only - ! triggered during non-fire and non-logging events. See - ! subroutine mortality_litter_fluxes() and DistributeSeeds(), look for + ! triggered during non-fire and non-logging events. See + ! subroutine mortality_litter_fluxes() and DistributeSeeds(), look for ! parameter allom_frbstor_repro ! ----------------------------------------------------------------------------------- @@ -1350,7 +1593,7 @@ subroutine SeedIn( currentSite, bc_in ) use EDTypesMod, only : homogenize_seed_pfts !use FatesInterfaceTypesMod, only : hlm_use_fixed_biogeog ! For future reduced complexity? ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(bc_in_type), intent(in) :: bc_in @@ -1371,7 +1614,7 @@ subroutine SeedIn( currentSite, bc_in ) !------------------------------------------------------------------------------------ do el = 1, num_elements - + site_seed_rain(:) = 0._r8 element_id = element_list(el) @@ -1381,12 +1624,12 @@ subroutine SeedIn( currentSite, bc_in ) ! Loop over all patches and sum up the seed input for each PFT currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) - + currentCohort => currentPatch%tallest do while (associated(currentCohort)) - + pft = currentCohort%pft - + ! a certain fraction of bstore might go to clonal reproduction when plants die ! (since this is only applied to the dying portion of the cohort ! we do not actually pair down the storage via PARTEH, instead @@ -1394,8 +1637,8 @@ subroutine SeedIn( currentSite, bc_in ) ! to the litter in CWDInput) ! units = [kg/ha/day] = [kg] * [fraction] * [plants/ha/year] * [year/day] store_m_to_repro = -currentCohort%prt%GetState(store_organ,element_id) * & - EDPftvarcon_inst%allom_frbstor_repro(pft)*currentCohort%dndt*years_per_day - + EDPftvarcon_inst%allom_frbstor_repro(pft)*currentCohort%dndt*years_per_day + ! Transfer all reproductive tissues into seed production ! The following call to PRTReproRelease, will return the mass ! of seeds [kg] released by the plant, per the mass_fraction @@ -1403,18 +1646,18 @@ subroutine SeedIn( currentSite, bc_in ) ! from the parteh state-variable. call PRTReproRelease(currentCohort%prt,repro_organ,element_id, & - 1.0_r8, seed_prod) - + 1.0_r8, seed_prod) + if(element_id==carbon12_element)then - currentcohort%seed_prod = seed_prod + currentcohort%seed_prod = seed_prod end if site_seed_rain(pft) = site_seed_rain(pft) + & - (seed_prod * currentCohort%n + store_m_to_repro) - + (seed_prod * currentCohort%n + store_m_to_repro) + currentCohort => currentCohort%shorter enddo !cohort loop - + currentPatch => currentPatch%younger enddo @@ -1424,10 +1667,10 @@ subroutine SeedIn( currentSite, bc_in ) if ( homogenize_seed_pfts ) then site_seed_rain(1:numpft) = sum(site_seed_rain(:))/real(numpft,r8) end if - - + + ! Loop over all patches again and disperse the mixed seeds into the input flux - ! arrays + ! arrays ! Loop over all patches and sum up the seed input for each PFT currentPatch => currentSite%oldest_patch @@ -1437,51 +1680,51 @@ subroutine SeedIn( currentSite, bc_in ) do pft = 1,numpft if(currentSite%use_this_pft(pft).eq.itrue)then - ! Seed input from local sources (within site) - litt%seed_in_local(pft) = litt%seed_in_local(pft) + site_seed_rain(pft)/area - - ! If there is forced external seed rain, we calculate the input mass flux - ! from the different elements, usung the seed optimal stoichiometry - ! for non-carbon - select case(element_id) - case(carbon12_element) - seed_stoich = 1._r8 - case(nitrogen_element) - seed_stoich = prt_params%nitr_stoich_p2(pft,repro_organ) - case(phosphorus_element) - seed_stoich = prt_params%phos_stoich_p2(pft,repro_organ) - case default - write(fates_log(), *) 'undefined element specified' - write(fates_log(), *) 'while defining forced external seed mass flux' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - ! Seed input from external sources (user param seed rain, or dispersal model) - seed_in_external = seed_stoich*EDPftvarcon_inst%seed_suppl(pft)*years_per_day - litt%seed_in_extern(pft) = litt%seed_in_extern(pft) + seed_in_external + ! Seed input from local sources (within site) + litt%seed_in_local(pft) = litt%seed_in_local(pft) + site_seed_rain(pft)/area + + ! If there is forced external seed rain, we calculate the input mass flux + ! from the different elements, usung the seed optimal stoichiometry + ! for non-carbon + select case(element_id) + case(carbon12_element) + seed_stoich = 1._r8 + case(nitrogen_element) + seed_stoich = prt_params%nitr_recr_stoich(pft) + case(phosphorus_element) + seed_stoich = prt_params%phos_recr_stoich(pft) + case default + write(fates_log(), *) 'undefined element specified' + write(fates_log(), *) 'while defining forced external seed mass flux' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + ! Seed input from external sources (user param seed rain, or dispersal model) + seed_in_external = seed_stoich*EDPftvarcon_inst%seed_suppl(pft)*years_per_day + litt%seed_in_extern(pft) = litt%seed_in_extern(pft) + seed_in_external - ! Seeds entering externally [kg/site/day] - site_mass%seed_in = site_mass%seed_in + seed_in_external*currentPatch%area - end if !use this pft + ! Seeds entering externally [kg/site/day] + site_mass%seed_in = site_mass%seed_in + seed_in_external*currentPatch%area + end if !use this pft enddo - - + + currentPatch => currentPatch%younger enddo - + end do return end subroutine SeedIn - + ! ============================================================================ subroutine SeedDecay( litt ) ! ! !DESCRIPTION: - ! Flux from seed pool into leaf litter pool + ! Flux from seed pool into leaf litter pool ! - ! !ARGUMENTS + ! !ARGUMENTS type(litter_type) :: litt ! ! !LOCAL VARIABLES: @@ -1494,12 +1737,12 @@ subroutine SeedDecay( litt ) ! seed_decay is kg/day ! Assume that decay rates are same for all chemical species - do pft = 1,numpft + do pft = 1,numpft litt%seed_decay(pft) = litt%seed(pft) * & - EDPftvarcon_inst%seed_decay_rate(pft)*years_per_day + EDPftvarcon_inst%seed_decay_rate(pft)*years_per_day litt%seed_germ_decay(pft) = litt%seed_germ(pft) * & - EDPftvarcon_inst%seed_decay_rate(pft)*years_per_day + EDPftvarcon_inst%seed_decay_rate(pft)*years_per_day enddo @@ -1510,22 +1753,22 @@ end subroutine SeedDecay subroutine SeedGermination( litt, cold_stat, drought_stat ) ! ! !DESCRIPTION: - ! Flux from seed pool into sapling pool + ! Flux from seed pool into sapling pool ! ! !USES: - + ! ! !ARGUMENTS - type(litter_type) :: litt + type(litter_type) :: litt integer, intent(in) :: cold_stat ! Is the site in cold leaf-off status? integer, intent(in) :: drought_stat ! Is the site in drought leaf-off status? ! ! !LOCAL VARIABLES: integer :: pft - - real(r8), parameter :: max_germination = 1.0_r8 ! Cap on germination rates. - ! KgC/m2/yr Lishcke et al. 2009 + + real(r8), parameter :: max_germination = 1.0_r8 ! Cap on germination rates. + ! KgC/m2/yr Lishcke et al. 2009 ! Turning of this cap? because the cap will impose changes on proportionality ! of nutrients. (RGK 02-2019) @@ -1534,24 +1777,24 @@ subroutine SeedGermination( litt, cold_stat, drought_stat ) !---------------------------------------------------------------------- ! germination_rate is being pulled to PFT parameter; units are 1/yr - ! thus the mortality rate of seed -> recruit (in units of carbon) + ! thus the mortality rate of seed -> recruit (in units of carbon) ! is seed_decay_rate(p)/germination_rate(p) - ! and thus the mortality rate (in units of individuals) is the product of + ! and thus the mortality rate (in units of individuals) is the product of ! that times the ratio of (hypothetical) seed mass to recruit biomass do pft = 1,numpft litt%seed_germ_in(pft) = min(litt%seed(pft) * EDPftvarcon_inst%germination_rate(pft), & - max_germination)*years_per_day - + max_germination)*years_per_day + !set the germination only under the growing season...c.xu if ((prt_params%season_decid(pft) == itrue ) .and. & - (any(cold_stat == [phen_cstat_nevercold,phen_cstat_iscold]))) then - litt%seed_germ_in(pft) = 0.0_r8 + (any(cold_stat == [phen_cstat_nevercold,phen_cstat_iscold]))) then + litt%seed_germ_in(pft) = 0.0_r8 endif if ((prt_params%stress_decid(pft) == itrue ) .and. & - (any(drought_stat == [phen_dstat_timeoff,phen_dstat_moistoff]))) then - litt%seed_germ_in(pft) = 0.0_r8 + (any(drought_stat == [phen_dstat_timeoff,phen_dstat_moistoff]))) then + litt%seed_germ_in(pft) = 0.0_r8 end if @@ -1570,12 +1813,12 @@ end subroutine SeedGermination subroutine recruitment( currentSite, currentPatch, bc_in ) ! ! !DESCRIPTION: - ! spawn new cohorts of juveniles of each PFT + ! spawn new cohorts of juveniles of each PFT ! ! !USES: use FatesInterfaceTypesMod, only : hlm_use_ed_prescribed_phys ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type), intent(inout), pointer :: currentPatch type(bc_in_type), intent(in) :: bc_in @@ -1609,9 +1852,9 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) real(r8) :: m_repro ! reproductive mass (element agnostic) [kg] real(r8) :: mass_avail ! The mass of each nutrient/carbon available in the seed_germination pool [kg] real(r8) :: mass_demand ! Total mass demanded by the plant to achieve the stoichiometric targets - ! of all the organs in the recruits. Used for both [kg per plant] and [kg per cohort] - real(r8) :: stem_drop_fraction - + ! of all the organs in the recruits. Used for both [kg per plant] and [kg per cohort] + real(r8) :: stem_drop_fraction + !---------------------------------------------------------------------- allocate(temp_cohort) ! create temporary cohort @@ -1619,253 +1862,271 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) do ft = 1,numpft - if(currentSite%use_this_pft(ft).eq.itrue)then - temp_cohort%canopy_trim = 0.8_r8 !starting with the canopy not fully expanded - temp_cohort%pft = ft - temp_cohort%hite = EDPftvarcon_inst%hgt_min(ft) - temp_cohort%coage = 0.0_r8 - stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(ft) - - call h2d_allom(temp_cohort%hite,ft,temp_cohort%dbh) - - ! Initialize live pools - call bleaf(temp_cohort%dbh,ft,temp_cohort%canopy_trim,c_leaf) - call bfineroot(temp_cohort%dbh,ft,temp_cohort%canopy_trim,c_fnrt) - call bsap_allom(temp_cohort%dbh,ft,temp_cohort%canopy_trim,a_sapw, c_sapw) - call bagw_allom(temp_cohort%dbh,ft,c_agw) - call bbgw_allom(temp_cohort%dbh,ft,c_bgw) - call bdead_allom(c_agw,c_bgw,c_sapw,ft,c_struct) - call bstore_allom(temp_cohort%dbh,ft,temp_cohort%canopy_trim,c_store) - - ! Default assumption is that leaves are on - cohortstatus = leaves_on - temp_cohort%laimemory = 0.0_r8 - temp_cohort%sapwmemory = 0.0_r8 - temp_cohort%structmemory = 0.0_r8 - - - ! But if the plant is seasonally (cold) deciduous, and the site status is flagged - ! as "cold", then set the cohort's status to leaves_off, and remember the leaf biomass - if ((prt_params%season_decid(ft) == itrue) .and. & - (any(currentSite%cstatus == [phen_cstat_nevercold,phen_cstat_iscold]))) then - temp_cohort%laimemory = c_leaf - c_leaf = 0.0_r8 - - ! If plant is not woody then set sapwood and structural biomass as well - if (prt_params%woody(ft).ne.itrue) then - temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction - c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw - c_struct = (1.0_r8 - stem_drop_fraction) * c_struct - endif - cohortstatus = leaves_off - endif - - ! Or.. if the plant is drought deciduous, and the site status is flagged as - ! "in a drought", then likewise, set the cohort's status to leaves_off, and remember leaf - ! biomass - if ((prt_params%stress_decid(ft) == itrue) .and. & - (any(currentSite%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff]))) then - temp_cohort%laimemory = c_leaf - c_leaf = 0.0_r8 - - ! If plant is not woody then set sapwood and structural biomass as well - if(prt_params%woody(ft).ne.itrue)then - temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction - c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw - c_struct = (1.0_r8 - stem_drop_fraction) * c_struct - endif - cohortstatus = leaves_off - endif - - - ! Cycle through available carbon and nutrients, find the limiting element - ! to dictate the total number of plants that can be generated - - if ( (hlm_use_ed_prescribed_phys .eq. ifalse) .or. & - (EDPftvarcon_inst%prescribed_recruitment(ft) .lt. 0._r8) ) then - - temp_cohort%n = 1.e10_r8 - - do el = 1,num_elements - - element_id = element_list(el) - select case(element_id) - case(carbon12_element) - - mass_demand = (c_struct+c_leaf+c_fnrt+c_sapw+c_store) - - case(nitrogen_element) - - mass_demand = c_struct*prt_params%nitr_stoich_p1(ft,struct_organ) + & - c_leaf*prt_params%nitr_stoich_p1(ft,leaf_organ) + & - c_fnrt*prt_params%nitr_stoich_p1(ft,fnrt_organ) + & - c_sapw*prt_params%nitr_stoich_p1(ft,sapw_organ) + & - c_store*prt_params%nitr_stoich_p1(ft,store_organ) - - case(phosphorus_element) - - mass_demand = c_struct*prt_params%phos_stoich_p1(ft,struct_organ) + & - c_leaf*prt_params%phos_stoich_p1(ft,leaf_organ) + & - c_fnrt*prt_params%phos_stoich_p1(ft,fnrt_organ) + & - c_sapw*prt_params%phos_stoich_p1(ft,sapw_organ) + & - c_store*prt_params%phos_stoich_p1(ft,store_organ) - - case default + + ! The following if block is for the prescribed biogeography and/or nocomp modes. + ! Since currentSite%use_this_pft is a site-level quantity and thus only limits whether a given PFT + ! is permitted on a given gridcell or not, it applies to the prescribed biogeography case only. + ! If nocomp is enabled, then we must determine whether a given PFT is allowed on a given patch or not. + + if(currentSite%use_this_pft(ft).eq.itrue & + .and. ((hlm_use_nocomp .eq. ifalse) .or. (ft .eq. currentPatch%nocomp_pft_label)))then + + temp_cohort%canopy_trim = init_recruit_trim + temp_cohort%pft = ft + temp_cohort%hite = EDPftvarcon_inst%hgt_min(ft) + temp_cohort%coage = 0.0_r8 + stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(ft) + + call h2d_allom(temp_cohort%hite,ft,temp_cohort%dbh) + + ! Initialize live pools + call bleaf(temp_cohort%dbh,ft,temp_cohort%canopy_trim,c_leaf) + call bfineroot(temp_cohort%dbh,ft,temp_cohort%canopy_trim,c_fnrt) + call bsap_allom(temp_cohort%dbh,ft,temp_cohort%canopy_trim,a_sapw, c_sapw) + call bagw_allom(temp_cohort%dbh,ft,c_agw) + call bbgw_allom(temp_cohort%dbh,ft,c_bgw) + call bdead_allom(c_agw,c_bgw,c_sapw,ft,c_struct) + call bstore_allom(temp_cohort%dbh,ft,temp_cohort%canopy_trim,c_store) + + ! Default assumption is that leaves are on + cohortstatus = leaves_on + temp_cohort%laimemory = 0.0_r8 + temp_cohort%sapwmemory = 0.0_r8 + temp_cohort%structmemory = 0.0_r8 + + + ! But if the plant is seasonally (cold) deciduous, and the site status is flagged + ! as "cold", then set the cohort's status to leaves_off, and remember the leaf biomass + if ((prt_params%season_decid(ft) == itrue) .and. & + (any(currentSite%cstatus == [phen_cstat_nevercold,phen_cstat_iscold]))) then + temp_cohort%laimemory = c_leaf + c_leaf = 0.0_r8 + + ! If plant is not woody then set sapwood and structural biomass as well + if (prt_params%woody(ft).ne.itrue) then + temp_cohort%sapwmemory = c_sapw * stem_drop_fraction + temp_cohort%structmemory = c_struct * stem_drop_fraction + c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw + c_struct = (1.0_r8 - stem_drop_fraction) * c_struct + endif + cohortstatus = leaves_off + endif + + ! Or.. if the plant is drought deciduous, and the site status is flagged as + ! "in a drought", then likewise, set the cohort's status to leaves_off, and remember leaf + ! biomass + if ((prt_params%stress_decid(ft) == itrue) .and. & + (any(currentSite%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff]))) then + temp_cohort%laimemory = c_leaf + c_leaf = 0.0_r8 + + ! If plant is not woody then set sapwood and structural biomass as well + if(prt_params%woody(ft).ne.itrue)then + temp_cohort%sapwmemory = c_sapw * stem_drop_fraction + temp_cohort%structmemory = c_struct * stem_drop_fraction + c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw + c_struct = (1.0_r8 - stem_drop_fraction) * c_struct + endif + cohortstatus = leaves_off + endif + + + ! Cycle through available carbon and nutrients, find the limiting element + ! to dictate the total number of plants that can be generated + + if ( (hlm_use_ed_prescribed_phys .eq. ifalse) .or. & + (EDPftvarcon_inst%prescribed_recruitment(ft) .lt. 0._r8) ) then + + temp_cohort%n = 1.e20_r8 + + do el = 1,num_elements + + element_id = element_list(el) + select case(element_id) + case(carbon12_element) + + mass_demand = c_struct+c_leaf+c_fnrt+c_sapw+c_store + + case(nitrogen_element) + + mass_demand = & + c_struct*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + & + c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & + c_fnrt*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & + c_sapw*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) + & + StorageNutrientTarget(ft, element_id, & + c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)), & + c_fnrt*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)), & + c_sapw*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)), & + c_struct*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(struct_organ))) + + case(phosphorus_element) + + mass_demand = & + c_struct*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + & + c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & + c_fnrt*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & + c_sapw*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) + & + StorageNutrientTarget(ft, element_id, & + c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)), & + c_fnrt*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)), & + c_sapw*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)), & + c_struct*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(struct_organ))) + + case default write(fates_log(),*) 'Undefined element type in recruitment' call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - mass_avail = currentPatch%area * currentPatch%litter(el)%seed_germ(ft) + end select - ! ------------------------------------------------------------------------ - ! Update number density if this is the limiting mass - ! ------------------------------------------------------------------------ + mass_avail = currentPatch%area * currentPatch%litter(el)%seed_germ(ft) - temp_cohort%n = min(temp_cohort%n, mass_avail/mass_demand) + ! ------------------------------------------------------------------------ + ! Update number density if this is the limiting mass + ! ------------------------------------------------------------------------ - end do + temp_cohort%n = min(temp_cohort%n, mass_avail/mass_demand) + end do - else - ! prescribed recruitment rates. number per sq. meter per year - temp_cohort%n = currentPatch%area * & - EDPftvarcon_inst%prescribed_recruitment(ft) * & - hlm_freq_day - endif - ! Only bother allocating a new cohort if there is a reasonable amount of it + else + ! prescribed recruitment rates. number per sq. meter per year + temp_cohort%n = currentPatch%area * & + EDPftvarcon_inst%prescribed_recruitment(ft) * & + hlm_freq_day + endif + + ! Only bother allocating a new cohort if there is a reasonable amount of it any_recruits: if (temp_cohort%n > min_n_safemath )then - ! ----------------------------------------------------------------------------- - ! PART II. - ! Initialize the PARTEH object, and determine the initial masses of all - ! organs and elements. - ! ----------------------------------------------------------------------------- - prt => null() - call InitPRTObject(prt) - - do el = 1,num_elements - - element_id = element_list(el) - - ! If this is carbon12, then the initialization is straight forward - ! otherwise, we use stoichiometric ratios - select case(element_id) - case(carbon12_element) - - m_struct = c_struct - m_leaf = c_leaf - m_fnrt = c_fnrt - m_sapw = c_sapw - m_store = c_store - m_repro = 0._r8 - - case(nitrogen_element) - - m_struct = c_struct*prt_params%nitr_stoich_p1(ft,struct_organ) - m_leaf = c_leaf*prt_params%nitr_stoich_p1(ft,leaf_organ) - m_fnrt = c_fnrt*prt_params%nitr_stoich_p1(ft,fnrt_organ) - m_sapw = c_sapw*prt_params%nitr_stoich_p1(ft,sapw_organ) - m_store = c_store*prt_params%nitr_stoich_p1(ft,store_organ) - m_repro = 0._r8 - - case(phosphorus_element) - - m_struct = c_struct*prt_params%phos_stoich_p1(ft,struct_organ) - m_leaf = c_leaf*prt_params%phos_stoich_p1(ft,leaf_organ) - m_fnrt = c_fnrt*prt_params%phos_stoich_p1(ft,fnrt_organ) - m_sapw = c_sapw*prt_params%phos_stoich_p1(ft,sapw_organ) - m_store = c_store*prt_params%phos_stoich_p1(ft,store_organ) - m_repro = 0._r8 - - end select - - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp,prt_cnp_flex_allom_hyp ) - - ! Put all of the leaf mass into the first bin - call SetState(prt,leaf_organ, element_id,m_leaf,1) - do iage = 2,nleafage - call SetState(prt,leaf_organ, element_id,0._r8,iage) - end do - - call SetState(prt,fnrt_organ, element_id, m_fnrt) - call SetState(prt,sapw_organ, element_id, m_sapw) - call SetState(prt,store_organ, element_id, m_store) - call SetState(prt,struct_organ, element_id, m_struct) - call SetState(prt,repro_organ, element_id, m_repro) - - case default - write(fates_log(),*) 'Unspecified PARTEH module during create_cohort' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - site_mass => currentSite%mass_balance(el) - - ! Remove mass from the germination pool. However, if we are use prescribed physiology, - ! AND the forced recruitment model, then we are not realling using the prognostic - ! seed_germination model, so we have to short circuit things. We send all of the - ! seed germination mass to an outflux pool, and use an arbitrary generic input flux - ! to balance out the new recruits. - - if ( (hlm_use_ed_prescribed_phys .eq. itrue ) .and. & - (EDPftvarcon_inst%prescribed_recruitment(ft) .ge. 0._r8 )) then - - site_mass%flux_generic_in = site_mass%flux_generic_in + & + ! ----------------------------------------------------------------------------- + ! PART II. + ! Initialize the PARTEH object, and determine the initial masses of all + ! organs and elements. + ! ----------------------------------------------------------------------------- + prt => null() + call InitPRTObject(prt) + + do el = 1,num_elements + + element_id = element_list(el) + + ! If this is carbon12, then the initialization is straight forward + ! otherwise, we use stoichiometric ratios + select case(element_id) + case(carbon12_element) + + m_struct = c_struct + m_leaf = c_leaf + m_fnrt = c_fnrt + m_sapw = c_sapw + m_store = c_store + m_repro = 0._r8 + + case(nitrogen_element) + + m_struct = c_struct*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + m_leaf = c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + m_fnrt = c_fnrt*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + m_sapw = c_sapw*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) + m_store = StorageNutrientTarget(ft, element_id, m_leaf, m_fnrt, m_sapw, m_struct ) + m_repro = 0._r8 + + case(phosphorus_element) + + m_struct = c_struct*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + m_leaf = c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + m_fnrt = c_fnrt*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + m_sapw = c_sapw*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) + m_store = StorageNutrientTarget(ft, element_id, m_leaf, m_fnrt, m_sapw, m_struct ) + m_repro = 0._r8 + + end select + + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp,prt_cnp_flex_allom_hyp ) + + ! Put all of the leaf mass into the first bin + call SetState(prt,leaf_organ, element_id,m_leaf,1) + do iage = 2,nleafage + call SetState(prt,leaf_organ, element_id,0._r8,iage) + end do + + call SetState(prt,fnrt_organ, element_id, m_fnrt) + call SetState(prt,sapw_organ, element_id, m_sapw) + call SetState(prt,store_organ, element_id, m_store) + call SetState(prt,struct_organ, element_id, m_struct) + call SetState(prt,repro_organ, element_id, m_repro) + + case default + write(fates_log(),*) 'Unspecified PARTEH module during create_cohort' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + site_mass => currentSite%mass_balance(el) + + ! Remove mass from the germination pool. However, if we are use prescribed physiology, + ! AND the forced recruitment model, then we are not realling using the prognostic + ! seed_germination model, so we have to short circuit things. We send all of the + ! seed germination mass to an outflux pool, and use an arbitrary generic input flux + ! to balance out the new recruits. + + if ( (hlm_use_ed_prescribed_phys .eq. itrue ) .and. & + (EDPftvarcon_inst%prescribed_recruitment(ft) .ge. 0._r8 )) then + + site_mass%flux_generic_in = site_mass%flux_generic_in + & temp_cohort%n*(m_struct + m_leaf + m_fnrt + m_sapw + m_store + m_repro) - - site_mass%flux_generic_out = site_mass%flux_generic_out + & + + site_mass%flux_generic_out = site_mass%flux_generic_out + & currentPatch%area * currentPatch%litter(el)%seed_germ(ft) - - currentPatch%litter(el)%seed_germ(ft) = 0._r8 - - else + currentPatch%litter(el)%seed_germ(ft) = 0._r8 + - currentPatch%litter(el)%seed_germ(ft) = currentPatch%litter(el)%seed_germ(ft) - & - temp_cohort%n / currentPatch%area * & + else + + currentPatch%litter(el)%seed_germ(ft) = currentPatch%litter(el)%seed_germ(ft) - & + temp_cohort%n / currentPatch%area * & (m_struct + m_leaf + m_fnrt + m_sapw + m_store + m_repro) - - end if - - - - end do - - ! This call cycles through the initial conditions, and makes sure that they - ! are all initialized. - ! ----------------------------------------------------------------------------------- - - call prt%CheckInitialConditions() - - ! This initializes the cohort - call create_cohort(currentSite,currentPatch, temp_cohort%pft, temp_cohort%n, & - temp_cohort%hite, temp_cohort%coage, temp_cohort%dbh, prt, & - temp_cohort%laimemory, temp_cohort%sapwmemory, temp_cohort%structmemory, & - cohortstatus, recruitstatus, & - temp_cohort%canopy_trim, currentPatch%NCL_p, currentSite%spread, bc_in) - - ! Note that if hydraulics is on, the number of cohorts may had - ! changed due to hydraulic constraints. - ! This constaint is applied during "create_cohort" subroutine. - - ! keep track of how many individuals were recruited for passing to history - currentSite%recruitment_rate(ft) = currentSite%recruitment_rate(ft) + temp_cohort%n - + + end if + + + + end do + + ! This call cycles through the initial conditions, and makes sure that they + ! are all initialized. + ! ----------------------------------------------------------------------------------- + + call prt%CheckInitialConditions() + ! This initializes the cohort + call create_cohort(currentSite,currentPatch, temp_cohort%pft, temp_cohort%n, & + temp_cohort%hite, temp_cohort%coage, temp_cohort%dbh, prt, & + temp_cohort%laimemory, temp_cohort%sapwmemory, temp_cohort%structmemory, & + cohortstatus, recruitstatus, & + temp_cohort%canopy_trim,temp_cohort%c_area, & + currentPatch%NCL_p, currentSite%spread, bc_in) + + ! Note that if hydraulics is on, the number of cohorts may had + ! changed due to hydraulic constraints. + ! This constaint is applied during "create_cohort" subroutine. + + ! keep track of how many individuals were recruited for passing to history + currentSite%recruitment_rate(ft) = currentSite%recruitment_rate(ft) + temp_cohort%n + endif any_recruits - endif !use_this_pft - enddo !pft loop - - deallocate(temp_cohort) ! delete temporary cohort + endif !use_this_pft + enddo !pft loop + + deallocate(temp_cohort) ! delete temporary cohort end subroutine recruitment ! ============================================================================ - subroutine CWDInput( currentSite, currentPatch, litt) + subroutine CWDInput( currentSite, currentPatch, litt, bc_in) ! ! !DESCRIPTION: @@ -1879,11 +2140,11 @@ subroutine CWDInput( currentSite, currentPatch, litt) use SFParamsMod , only : SF_val_CWD_frac ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), target :: currentSite type(ed_patch_type),intent(inout), target :: currentPatch type(litter_type),intent(inout),target :: litt - + type(bc_in_type),intent(in) :: bc_in ! ! !LOCAL VARIABLES: @@ -1895,9 +2156,9 @@ subroutine CWDInput( currentSite, currentPatch, litt) real(r8) :: dead_n_dlogging ! direct logging understory dead-tree density real(r8) :: dead_n_ilogging ! indirect understory dead-tree density (logging) real(r8) :: dead_n_natural ! understory dead density not associated - ! with direct logging - real(r8) :: leaf_m ! mass of the element of interest in the - ! leaf [kg] + ! with direct logging + real(r8) :: leaf_m ! mass of the element of interest in the + ! leaf [kg] real(r8) :: fnrt_m ! fine-root [kg] real(r8) :: sapw_m ! sapwood [kg] real(r8) :: struct_m ! structural [kg] @@ -1912,9 +2173,9 @@ subroutine CWDInput( currentSite, currentPatch, litt) real(r8) :: dcmpy_frac ! Fraction of mass sent to decomposability pool real(r8) :: plant_dens ! Number of plants per m2 real(r8) :: bg_cwd_tot ! Total below-ground coarse woody debris - ! input flux + ! input flux real(r8) :: root_fines_tot ! Total below-ground fine root coarse - ! woody debris + ! woody debris integer :: element_id ! element id consistent with parteh/PRTGenericMod.F90 real(r8) :: trunk_wood ! carbon flux into trunk products kgC/day/site @@ -1925,279 +2186,280 @@ subroutine CWDInput( currentSite, currentPatch, litt) !---------------------------------------------------------------------- ! ----------------------------------------------------------------------------------- - ! Other direct litter fluxes happen in phenology and in spawn_patches. + ! Other direct litter fluxes happen in phenology and in spawn_patches. ! ----------------------------------------------------------------------------------- numlevsoil = currentSite%nlevsoil element_id = litt%element_id - + ! Object tracking flux diagnostics for each element flux_diags => currentSite%flux_diags(element_pos(element_id)) - + ! Object tracking site level mass balance for each element site_mass => currentSite%mass_balance(element_pos(element_id)) currentCohort => currentPatch%shortest do while(associated(currentCohort)) - pft = currentCohort%pft - - call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil) - - leaf_m_turnover = currentCohort%prt%GetTurnover(leaf_organ,element_id) - store_m_turnover = currentCohort%prt%GetTurnover(store_organ,element_id) - fnrt_m_turnover = currentCohort%prt%GetTurnover(fnrt_organ,element_id) - sapw_m_turnover = currentCohort%prt%GetTurnover(sapw_organ,element_id) - struct_m_turnover = currentCohort%prt%GetTurnover(struct_organ,element_id) - repro_m_turnover = currentCohort%prt%GetTurnover(repro_organ,element_id) - - leaf_m = currentCohort%prt%GetState(leaf_organ,element_id) - store_m = currentCohort%prt%GetState(store_organ,element_id) - fnrt_m = currentCohort%prt%GetState(fnrt_organ,element_id) - sapw_m = currentCohort%prt%GetState(sapw_organ,element_id) - struct_m = currentCohort%prt%GetState(struct_organ,element_id) - repro_m = currentCohort%prt%GetState(repro_organ,element_id) - - plant_dens = currentCohort%n/currentPatch%area - - ! --------------------------------------------------------------------------------- - ! PART 1 Litter fluxes from non-mortal tissue turnovers Kg/m2/day - ! Important note: Turnover has already been removed from the cohorts. - ! So, in the next part of this algorithm, when we send the biomass - ! from dying trees to the litter pools, we don't have to worry - ! about double counting. - ! --------------------------------------------------------------------------------- - - flux_diags%leaf_litter_input(pft) = & + pft = currentCohort%pft + + call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil, & + bc_in%max_rooting_depth_index_col) + + leaf_m_turnover = currentCohort%prt%GetTurnover(leaf_organ,element_id) + store_m_turnover = currentCohort%prt%GetTurnover(store_organ,element_id) + fnrt_m_turnover = currentCohort%prt%GetTurnover(fnrt_organ,element_id) + sapw_m_turnover = currentCohort%prt%GetTurnover(sapw_organ,element_id) + struct_m_turnover = currentCohort%prt%GetTurnover(struct_organ,element_id) + repro_m_turnover = currentCohort%prt%GetTurnover(repro_organ,element_id) + + leaf_m = currentCohort%prt%GetState(leaf_organ,element_id) + store_m = currentCohort%prt%GetState(store_organ,element_id) + fnrt_m = currentCohort%prt%GetState(fnrt_organ,element_id) + sapw_m = currentCohort%prt%GetState(sapw_organ,element_id) + struct_m = currentCohort%prt%GetState(struct_organ,element_id) + repro_m = currentCohort%prt%GetState(repro_organ,element_id) + + plant_dens = currentCohort%n/currentPatch%area + + ! --------------------------------------------------------------------------------- + ! PART 1 Litter fluxes from non-mortal tissue turnovers Kg/m2/day + ! Important note: Turnover has already been removed from the cohorts. + ! So, in the next part of this algorithm, when we send the biomass + ! from dying trees to the litter pools, we don't have to worry + ! about double counting. + ! --------------------------------------------------------------------------------- + + flux_diags%leaf_litter_input(pft) = & flux_diags%leaf_litter_input(pft) + & leaf_m_turnover * currentCohort%n - - root_fines_tot = (fnrt_m_turnover + store_m_turnover ) * & + + root_fines_tot = (fnrt_m_turnover + store_m_turnover ) * & plant_dens - do dcmpy=1,ndcmpy + do dcmpy=1,ndcmpy dcmpy_frac = GetDecompyFrac(pft,leaf_organ,dcmpy) litt%leaf_fines_in(dcmpy) = litt%leaf_fines_in(dcmpy) + & - (leaf_m_turnover+repro_m_turnover) * plant_dens * dcmpy_frac + (leaf_m_turnover+repro_m_turnover) * plant_dens * dcmpy_frac dcmpy_frac = GetDecompyFrac(pft,fnrt_organ,dcmpy) do ilyr = 1, numlevsoil - litt%root_fines_in(dcmpy,ilyr) = litt%root_fines_in(dcmpy,ilyr) + & - currentSite%rootfrac_scr(ilyr) * root_fines_tot * dcmpy_frac + litt%root_fines_in(dcmpy,ilyr) = litt%root_fines_in(dcmpy,ilyr) + & + currentSite%rootfrac_scr(ilyr) * root_fines_tot * dcmpy_frac end do - end do - - flux_diags%root_litter_input(pft) = & + end do + + flux_diags%root_litter_input(pft) = & flux_diags%root_litter_input(pft) + & (fnrt_m_turnover + store_m_turnover ) * currentCohort%n - - - ! Assumption: turnover from deadwood and sapwood are lumped together in CWD pool - - do c = 1,ncwd - litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + & - (sapw_m_turnover + struct_m_turnover) * & - SF_val_CWD_frac(c) * plant_dens * & - prt_params%allom_agb_frac(pft) - - flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & + + + ! Assumption: turnover from deadwood and sapwood are lumped together in CWD pool + + do c = 1,ncwd + litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + & + (sapw_m_turnover + struct_m_turnover) * & + SF_val_CWD_frac(c) * plant_dens * & + prt_params%allom_agb_frac(pft) + + flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & (struct_m_turnover + sapw_m_turnover) * SF_val_CWD_frac(c) * & prt_params%allom_agb_frac(pft) * currentCohort%n - bg_cwd_tot = (sapw_m_turnover + struct_m_turnover) * & - SF_val_CWD_frac(c) * plant_dens * & - (1.0_r8-prt_params%allom_agb_frac(pft)) + bg_cwd_tot = (sapw_m_turnover + struct_m_turnover) * & + SF_val_CWD_frac(c) * plant_dens * & + (1.0_r8-prt_params%allom_agb_frac(pft)) - do ilyr = 1, numlevsoil - litt%bg_cwd_in(c,ilyr) = litt%bg_cwd_in(c,ilyr) + & + do ilyr = 1, numlevsoil + litt%bg_cwd_in(c,ilyr) = litt%bg_cwd_in(c,ilyr) + & bg_cwd_tot * currentSite%rootfrac_scr(ilyr) - end do - - flux_diags%cwd_bg_input(c) = flux_diags%cwd_bg_input(c) + & + end do + + flux_diags%cwd_bg_input(c) = flux_diags%cwd_bg_input(c) + & bg_cwd_tot*currentPatch%area - - enddo + enddo - ! --------------------------------------------------------------------------------- - ! PART 2 Litter fluxes from non-disturbance inducing mortality. Kg/m2/day - ! --------------------------------------------------------------------------------- - ! Total number of dead (n/m2/day) - dead_n = -1.0_r8 * currentCohort%dndt/currentPatch%area*years_per_day + ! --------------------------------------------------------------------------------- + ! PART 2 Litter fluxes from non-disturbance inducing mortality. Kg/m2/day + ! --------------------------------------------------------------------------------- - if(currentCohort%canopy_layer > 1)then + ! Total number of dead (n/m2/day) + dead_n = -1.0_r8 * currentCohort%dndt/currentPatch%area*years_per_day - ! Total number of dead understory from direct logging - ! (it is possible that large harvestable trees are in the understory) - dead_n_dlogging = currentCohort%lmort_direct * & - currentCohort%n/currentPatch%area + if(currentCohort%canopy_layer > 1)then - ! Total number of dead understory from indirect logging - dead_n_ilogging = (currentCohort%lmort_collateral + currentCohort%lmort_infra) * & - currentCohort%n/currentPatch%area + ! Total number of dead understory from direct logging + ! (it is possible that large harvestable trees are in the understory) + dead_n_dlogging = currentCohort%lmort_direct * & + currentCohort%n/currentPatch%area - else + ! Total number of dead understory from indirect logging + dead_n_ilogging = (currentCohort%lmort_collateral + currentCohort%lmort_infra) * & + currentCohort%n/currentPatch%area - ! All mortality from logging in the canopy is - ! is disturbance generating + else - dead_n_dlogging = 0._r8 - dead_n_ilogging = 0._r8 + ! All mortality from logging in the canopy is + ! is disturbance generating - end if + dead_n_dlogging = 0._r8 + dead_n_ilogging = 0._r8 - dead_n_natural = dead_n - dead_n_dlogging - dead_n_ilogging + end if + dead_n_natural = dead_n - dead_n_dlogging - dead_n_ilogging - flux_diags%leaf_litter_input(pft) = & + + flux_diags%leaf_litter_input(pft) = & flux_diags%leaf_litter_input(pft) + & leaf_m * dead_n*currentPatch%area - ! %n has not been updated due to mortality yet, thus - ! the litter flux has already been counted since it captured - ! the losses of live trees and those flagged for death - - root_fines_tot = dead_n * (fnrt_m + & - store_m*(1._r8-EDPftvarcon_inst%allom_frbstor_repro(pft)) ) + ! %n has not been updated due to mortality yet, thus + ! the litter flux has already been counted since it captured + ! the losses of live trees and those flagged for death + + root_fines_tot = dead_n * (fnrt_m + & + store_m*(1._r8-EDPftvarcon_inst%allom_frbstor_repro(pft)) ) - do dcmpy=1,ndcmpy + do dcmpy=1,ndcmpy dcmpy_frac = GetDecompyFrac(pft,leaf_organ,dcmpy) litt%leaf_fines_in(dcmpy) = litt%leaf_fines_in(dcmpy) + & - (leaf_m+repro_m) * dead_n * dcmpy_frac + (leaf_m+repro_m) * dead_n * dcmpy_frac dcmpy_frac = GetDecompyFrac(pft,fnrt_organ,dcmpy) do ilyr = 1, numlevsoil - litt%root_fines_in(dcmpy,ilyr) = litt%root_fines_in(dcmpy,ilyr) + & - root_fines_tot * currentSite%rootfrac_scr(ilyr) * dcmpy_frac + litt%root_fines_in(dcmpy,ilyr) = litt%root_fines_in(dcmpy,ilyr) + & + root_fines_tot * currentSite%rootfrac_scr(ilyr) * dcmpy_frac end do - end do + end do - flux_diags%root_litter_input(pft) = & + flux_diags%root_litter_input(pft) = & flux_diags%root_litter_input(pft) + & root_fines_tot*currentPatch%area - ! Track CWD inputs from dead plants - - do c = 1,ncwd - - ! Below-ground - - bg_cwd_tot = (struct_m + sapw_m) * & - SF_val_CWD_frac(c) * dead_n * & - (1.0_r8-prt_params%allom_agb_frac(pft)) - - do ilyr = 1, numlevsoil - litt%bg_cwd_in(c,ilyr) = litt%bg_cwd_in(c,ilyr) + & + ! Track CWD inputs from dead plants + + do c = 1,ncwd + + ! Below-ground + + bg_cwd_tot = (struct_m + sapw_m) * & + SF_val_CWD_frac(c) * dead_n * & + (1.0_r8-prt_params%allom_agb_frac(pft)) + + do ilyr = 1, numlevsoil + litt%bg_cwd_in(c,ilyr) = litt%bg_cwd_in(c,ilyr) + & currentSite%rootfrac_scr(ilyr) * bg_cwd_tot - end do + end do - flux_diags%cwd_bg_input(c) = flux_diags%cwd_bg_input(c) + & + flux_diags%cwd_bg_input(c) = flux_diags%cwd_bg_input(c) + & bg_cwd_tot * currentPatch%area - ! Send AGB component of boles from logging activities into the litter. - ! This includes fluxes from indirect modes of death, as well as the - ! non-exported boles due to direct harvesting. + ! Send AGB component of boles from logging activities into the litter. + ! This includes fluxes from indirect modes of death, as well as the + ! non-exported boles due to direct harvesting. + + if (c==ncwd) then - if (c==ncwd) then - - trunk_wood = (struct_m + sapw_m) * & - SF_val_CWD_frac(c) * dead_n_dlogging * & - prt_params%allom_agb_frac(pft) - - site_mass%wood_product = site_mass%wood_product + & - trunk_wood * currentPatch%area * logging_export_frac + trunk_wood = (struct_m + sapw_m) * & + SF_val_CWD_frac(c) * dead_n_dlogging * & + prt_params%allom_agb_frac(pft) - ! Add AG wood to litter from the non-exported fraction of wood - ! from direct anthro sources + site_mass%wood_product = site_mass%wood_product + & + trunk_wood * currentPatch%area * logging_export_frac - litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + & - trunk_wood * (1._r8-logging_export_frac) + ! Add AG wood to litter from the non-exported fraction of wood + ! from direct anthro sources - flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & - trunk_wood * (1._r8-logging_export_frac) * currentPatch%area + litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + & + trunk_wood * (1._r8-logging_export_frac) - ! Add AG wood to litter from indirect anthro sources + flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & + trunk_wood * (1._r8-logging_export_frac) * currentPatch%area - litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & - SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & - prt_params%allom_agb_frac(pft) + ! Add AG wood to litter from indirect anthro sources - flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & + litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & + SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & + prt_params%allom_agb_frac(pft) + + flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & currentPatch%area * prt_params%allom_agb_frac(pft) - else + else - litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & - SF_val_CWD_frac(c) * dead_n * & - prt_params%allom_agb_frac(pft) + litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & + SF_val_CWD_frac(c) * dead_n * & + prt_params%allom_agb_frac(pft) - flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & + flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & SF_val_CWD_frac(c) * dead_n * (struct_m + sapw_m) * & currentPatch%area * prt_params%allom_agb_frac(pft) - - end if - - end do + + end if + + end do - ! Update diagnostics that track resource management + ! Update diagnostics that track resource management - if( element_id .eq. carbon12_element ) then - - currentSite%resources_management%delta_litter_stock = & - currentSite%resources_management%delta_litter_stock + & - (leaf_m + fnrt_m + store_m ) * & - (dead_n_ilogging+dead_n_dlogging) * currentPatch%area + if( element_id .eq. carbon12_element ) then - currentSite%resources_management%delta_biomass_stock = & - currentSite%resources_management%delta_biomass_stock + & - (leaf_m + fnrt_m + store_m ) * & - (dead_n_ilogging+dead_n_dlogging) *currentPatch%area + currentSite%resources_management%delta_litter_stock = & + currentSite%resources_management%delta_litter_stock + & + (leaf_m + fnrt_m + store_m ) * & + (dead_n_ilogging+dead_n_dlogging) * currentPatch%area - currentSite%resources_management%trunk_product_site = & + currentSite%resources_management%delta_biomass_stock = & + currentSite%resources_management%delta_biomass_stock + & + (leaf_m + fnrt_m + store_m ) * & + (dead_n_ilogging+dead_n_dlogging) *currentPatch%area + + currentSite%resources_management%trunk_product_site = & currentSite%resources_management%trunk_product_site + & trunk_wood * logging_export_frac * currentPatch%area - do c = 1,ncwd - currentSite%resources_management%delta_litter_stock = & + do c = 1,ncwd + currentSite%resources_management%delta_litter_stock = & currentSite%resources_management%delta_litter_stock + & (struct_m + sapw_m) * & - SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & + SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & currentPatch%area - - currentSite%resources_management%delta_biomass_stock = & + + currentSite%resources_management%delta_biomass_stock = & currentSite%resources_management%delta_biomass_stock + & (struct_m + sapw_m) * & SF_val_CWD_frac(c) * dead_n * currentPatch%area - end do - - ! Update diagnostics that track resource management - currentSite%resources_management%delta_individual = & + end do + + ! Update diagnostics that track resource management + currentSite%resources_management%delta_individual = & currentSite%resources_management%delta_individual + & (dead_n_dlogging+dead_n_ilogging) * hlm_freq_day * currentPatch%area - end if - - - currentCohort => currentCohort%taller - enddo ! end loop over cohorts - - - return + end if + + + currentCohort => currentCohort%taller + enddo ! end loop over cohorts + + + return end subroutine CWDInput ! ===================================================================================== - subroutine fragmentation_scaler( currentPatch, bc_in) + subroutine fragmentation_scaler( currentPatch, bc_in) ! ! !DESCRIPTION: ! Simple CWD fragmentation Model - ! FIX(SPM, 091914) this should be a function as it returns a value in + ! FIX(SPM, 091914) this should be a function as it returns a value in ! currentPatch%fragmentation_scaler ! ! !USES: @@ -2206,7 +2468,7 @@ subroutine fragmentation_scaler( currentPatch, bc_in) use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm use FatesConstantsMod, only : pi => pi_const ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_patch_type), intent(inout) :: currentPatch type(bc_in_type), intent(in) :: bc_in @@ -2215,7 +2477,6 @@ subroutine fragmentation_scaler( currentPatch, bc_in) logical :: use_century_tfunc = .false. logical :: use_hlm_soil_scalar = .true. ! Use hlm input decomp fraction scalars integer :: j - integer :: ifp ! Index of a FATES Patch "ifp" real(r8) :: t_scalar ! temperature scalar real(r8) :: w_scalar ! moisture scalar real(r8) :: catanf ! hyperbolic temperature function from CENTURY @@ -2225,68 +2486,69 @@ subroutine fragmentation_scaler( currentPatch, bc_in) catanf(t1) = 11.75_r8 +(29.7_r8 / pi) * atan( pi * 0.031_r8 * ( t1 - 15.4_r8 )) catanf_30 = catanf(30._r8) - - ifp = currentPatch%patchno - ! Use the hlm temp and moisture decomp fractions by default - if ( use_hlm_soil_scalar ) then - - ! Calculate the fragmentation_scaler - currentPatch%fragmentation_scaler = min(1.0_r8,max(0.0_r8,bc_in%t_scalar_sisl * bc_in%w_scalar_sisl)) + if(currentPatch%nocomp_pft_label.ne.0)then - else - - if ( .not. use_century_tfunc ) then - !calculate rate constant scalar for soil temperature,assuming that the base rate constants - !are assigned for non-moisture limiting conditions at 25C. - if (bc_in%t_veg24_pa(ifp) >= tfrz) then - t_scalar = q10_mr**((bc_in%t_veg24_pa(ifp)-(tfrz+25._r8))/10._r8) - ! Q10**((t_soisno(c,j)-(tfrz+25._r8))/10._r8) + ! Use the hlm temp and moisture decomp fractions by default + if ( use_hlm_soil_scalar ) then + + ! Calculate the fragmentation_scaler + currentPatch%fragmentation_scaler = min(1.0_r8,max(0.0_r8,bc_in%t_scalar_sisl * bc_in%w_scalar_sisl)) + + else + + if ( .not. use_century_tfunc ) then + !calculate rate constant scalar for soil temperature,assuming that the base rate constants + !are assigned for non-moisture limiting conditions at 25C. + if (currentPatch%tveg24%GetMean() >= tfrz) then + t_scalar = q10_mr**((currentPatch%tveg24%GetMean()-(tfrz+25._r8))/10._r8) + ! Q10**((t_soisno(c,j)-(tfrz+25._r8))/10._r8) + else + t_scalar = (q10_mr**(-25._r8/10._r8))*(q10_froz**((currentPatch%tveg24%GetMean()-tfrz)/10._r8)) + ! Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-tfrz)/10._r8) + endif else - t_scalar = (q10_mr**(-25._r8/10._r8))*(q10_froz**((bc_in%t_veg24_pa(ifp)-tfrz)/10._r8)) - !Q10**(-25._r8/10._r8))*(froz_q10**((t_soisno(c,j)-tfrz)/10._r8) + ! original century uses an arctangent function to calculate the + ! temperature dependence of decomposition + t_scalar = max(catanf(currentPatch%tveg24%GetMean()-tfrz)/catanf_30,0.01_r8) endif - else - ! original century uses an arctangent function to calculate the - ! temperature dependence of decomposition - t_scalar = max(catanf(bc_in%t_veg24_pa(ifp)-tfrz)/catanf_30,0.01_r8) - endif - - !Moisture Limitations - !BTRAN APPROACH - is quite simple, but max's out decomp at all unstressed - !soil moisture values, which is not realistic. - !litter decomp is proportional to water limitation on average... - w_scalar = sum(currentPatch%btran_ft(1:numpft))/real(numpft,r8) - - ! Calculate the fragmentation_scaler - currentPatch%fragmentation_scaler(:) = min(1.0_r8,max(0.0_r8,t_scalar * w_scalar)) - - endif - - + + !Moisture Limitations + !BTRAN APPROACH - is quite simple, but max's out decomp at all unstressed + !soil moisture values, which is not realistic. + !litter decomp is proportional to water limitation on average... + w_scalar = sum(currentPatch%btran_ft(1:numpft))/real(numpft,r8) + + ! Calculate the fragmentation_scaler + currentPatch%fragmentation_scaler(:) = min(1.0_r8,max(0.0_r8,t_scalar * w_scalar)) + + endif ! scalar + + endif ! not bare ground + end subroutine fragmentation_scaler - + ! ============================================================================ subroutine CWDOut( litt, fragmentation_scaler, nlev_eff_decomp ) ! ! !DESCRIPTION: ! Simple CWD fragmentation Model - ! spawn new cohorts of juveniles of each PFT + ! spawn new cohorts of juveniles of each PFT ! ! !USES: use SFParamsMod, only : SF_val_max_decomp ! - ! !ARGUMENTS + ! !ARGUMENTS type(litter_type),intent(inout),target :: litt real(r8),intent(in) :: fragmentation_scaler(:) ! This is not necessarily every soil layer, this is the number ! of effective layers that are active and can be sent ! to the soil decomposition model - integer,intent(in) :: nlev_eff_decomp - + integer,intent(in) :: nlev_eff_decomp + ! ! !LOCAL VARIABLES: integer :: c ! Fuel size class index @@ -2300,29 +2562,27 @@ subroutine CWDOut( litt, fragmentation_scaler, nlev_eff_decomp ) ! moisture scalars and fragmentation scalar associated with specified index value ! is used for ag_cwd_frag and root_fines_frag calculations. - do c = 1,ncwd + do c = 1,ncwd litt%ag_cwd_frag(c) = litt%ag_cwd(c) * SF_val_max_decomp(c) * & years_per_day * fragmentation_scaler(soil_layer_index) - + do ilyr = 1,nlev_eff_decomp - litt%bg_cwd_frag(c,ilyr) = litt%bg_cwd(c,ilyr) * SF_val_max_decomp(c) * & years_per_day * fragmentation_scaler(ilyr) - enddo end do - ! this is the rate at which dropped leaves stop being part of the burnable pool - ! and begin to be part of the decomposing pool. This should probably be highly - ! sensitive to moisture, but also to the type of leaf thick leaves can dry out - ! before they are decomposed, for example. This section needs further scientific input. + ! this is the rate at which dropped leaves stop being part of the burnable pool + ! and begin to be part of the decomposing pool. This should probably be highly + ! sensitive to moisture, but also to the type of leaf thick leaves can dry out + ! before they are decomposed, for example. This section needs further scientific input. do dcmpy = 1,ndcmpy litt%leaf_fines_frag(dcmpy) = litt%leaf_fines(dcmpy) * & years_per_day * SF_val_max_decomp(dl_sf) * fragmentation_scaler(soil_layer_index) - + do ilyr = 1,nlev_eff_decomp litt%root_fines_frag(dcmpy,ilyr) = litt%root_fines(dcmpy,ilyr) * & years_per_day * SF_val_max_decomp(dl_sf) * fragmentation_scaler(ilyr) diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index a24653e652..42264ca776 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -95,7 +95,7 @@ module FatesAllometryMod use shr_log_mod , only : errMsg => shr_log_errMsg use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun - use EDTypesMod , only : nlevleaf, dinc_ed + use EDTypesMod , only : nlevleaf, dinc_vai use EDTypesMod , only : nclmax @@ -123,11 +123,14 @@ module FatesAllometryMod public :: CrownDepth public :: set_root_fraction ! Generic wrapper to calculate normalized ! root profiles + public :: leafc_from_treelai ! Calculate target leaf carbon for a given treelai for SP mode logical , parameter :: verbose_logging = .false. character(len=*), parameter :: sourcefile = __FILE__ + logical, parameter :: debug = .false. + ! If testing b4b with older versions, do not remove sapwood ! Our old methods with saldarriaga did not remove sapwood from the ! bdead pool. But newer allometries are providing total agb @@ -728,7 +731,7 @@ real(r8) function tree_sai( pft, dbh, canopy_trim, c_area, nplant, cl, & tree_sai = prt_params%allom_sai_scaler(pft) * target_lai - if( (treelai + tree_sai) > (nlevleaf*dinc_ed) )then + if( (treelai + tree_sai) > (sum(dinc_vai)) )then call h_allom(dbh,pft,h) @@ -737,7 +740,8 @@ real(r8) function tree_sai( pft, dbh, canopy_trim, c_area, nplant, cl, & write(fates_log(),*) 'sai: ',tree_sai write(fates_log(),*) 'target_lai: ',target_lai write(fates_log(),*) 'lai+sai: ',treelai+tree_sai - write(fates_log(),*) 'nlevleaf,dinc_ed,nlevleaf*dinc_ed :',nlevleaf,dinc_ed,nlevleaf*dinc_ed + write(fates_log(),*) 'dinc_vai:',dinc_vai + write(fates_log(),*) 'nlevleaf,sum(dinc_vai):',nlevleaf,sum(dinc_vai) write(fates_log(),*) 'pft: ',pft write(fates_log(),*) 'call id: ',call_id write(fates_log(),*) 'n: ',nplant @@ -757,6 +761,95 @@ real(r8) function tree_sai( pft, dbh, canopy_trim, c_area, nplant, cl, & return end function tree_sai +! ===================================================================================== + + real(r8) function leafc_from_treelai( treelai, pft, c_area, nplant, cl, vcmax25top) + + ! ----------------------------------------------------------------------------------- + ! Calculates the amount of leaf carbon which is needed to generate a given treelai. + ! iss the inverse of the 'tree_lai function. + ! ---------------------------------------------------------------------------------- + + ! !ARGUMENTS + real(r8), intent(in) :: treelai ! desired tree lai m2/m2 + integer, intent(in) :: pft ! Plant Functional Type index + real(r8), intent(in) :: c_area ! areal extent of canopy (m2) + real(r8), intent(in) :: nplant ! number of individuals in cohort per ha + integer, intent(in) :: cl ! canopy layer index + real(r8), intent(in) :: vcmax25top ! maximum carboxylation rate at canopy + ! top, ref 25C + + ! !LOCAL VARIABLES: + real(r8) :: leaf_c ! plant leaf carbon [kg] + real(r8) :: leafc_per_unitarea ! KgC of leaf per m2 area of ground. + real(r8) :: slat ! the sla of the top leaf layer. m2/kgC + real(r8) :: vai_per_lai ! ratio of vegetation area index (ie. sai+lai) + ! to lai for individual tree + real(r8) :: kn ! coefficient for exponential decay of 1/sla and + ! vcmax with canopy depth + real(r8) :: sla_max ! Observational constraint on how large sla + ! (m2/gC) can become + real(r8) :: leafc_slamax ! Leafc_per_unitarea at which sla_max is reached + real(r8) :: clim ! Upper limit for leafc_per_unitarea in exponential + ! tree_lai function + real(r8) :: tree_lai_at_slamax ! lai at which we reach the maximum sla value. + real(r8) :: leafc_linear_phase ! amount of leaf carbon needed to get to the target treelai + ! when the slamax value has been reached (i.e. deep layers with unchanging sla) + + !---------------------------------------------------------------------- + + if( treelai < 0._r8.or. pft == 0 ) then + write(fates_log(),*) 'negative tree lai in leafc_from_treelai?' + write(fates_log(),*) 'or.. pft was zero?' + write(fates_log(),*) 'problem in leafc_from_treelai',treelai,pft + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + if(cl>1)then + write(fates_log(),*) 'in sub-canopy layer in leafc_from_treelai' + write(fates_log(),*) 'this is not set up to work for lower canopy layers.' + write(fates_log(),*) 'problem in leafc_from_treelai',cl,pft + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + ! convert PFT-level canopy top and maximum SLA values and convert from m2/gC to m2/kgC + slat = g_per_kg * prt_params%slatop(pft) + sla_max = g_per_kg * prt_params%slamax(pft) + ! Coefficient for exponential decay of 1/sla with canopy depth: + kn = decay_coeff_kn(pft,vcmax25top) + + if(treelai > 0.0_r8)then + ! Leafc_per_unitarea at which sla_max is reached due to exponential sla profile in canopy: + leafc_slamax = max(0.0_r8,(slat - sla_max) / (-1.0_r8 * kn * slat * sla_max)) + + ! treelai at which we reach maximum sla. + tree_lai_at_slamax = (log( 1.0_r8- kn * slat * leafc_slamax)) / (-1.0_r8 * kn) + + if(treelai < tree_lai_at_slamax)then + ! Inversion of the exponential phase calculation of treelai for a given leafc_per_unitarea + leafc_per_unitarea = (1.0_r8-exp(treelai*(-1.0_r8 * kn)))/(kn*slat) + else ! we exceed the maxumum sla + + ! Add exponential and linear portions of tree_lai + ! Exponential term for leafc = leafc_slamax; + leafc_linear_phase = (treelai-tree_lai_at_slamax)/sla_max + leafc_per_unitarea = leafc_slamax + leafc_linear_phase + end if + leafc_from_treelai = leafc_per_unitarea*(c_area/nplant) + else + leafc_from_treelai = 0.0_r8 + endif ! (leafc_per_unitarea > 0.0_r8) + + return + end function leafc_from_treelai + + ! ===================================================================================== + + + + + + ! ============================================================================ ! Generic sapwood biomass interface ! ============================================================================ @@ -1238,16 +1331,15 @@ subroutine d2blmax_2pwr(d,p1,p2,c2b,blmax,dblmaxdd) ! ====================================================================== ! This is a power function for leaf biomass from plant diameter. - ! - ! log(bl) = a2 + b2*log(h) - ! bl = exp(a2) * h**b2 ! ====================================================================== + ! p1 and p2 represent the parameters that govern total beaf dry biomass, + ! and the output argument blmax is the leaf carbon only real(r8),intent(in) :: d ! plant diameter [cm] real(r8),intent(in) :: p1 ! parameter 1 (slope) real(r8),intent(in) :: p2 ! parameter 2 (curvature, exponent) - real(r8),intent(in) :: c2b ! carbon to biomass multiplier + real(r8),intent(in) :: c2b ! carbon to biomass multiplier (~2) real(r8),intent(out) :: blmax ! plant leaf biomass [kgC] real(r8),intent(out),optional :: dblmaxdd ! change leaf bio per diameter [kgC/cm] @@ -1582,7 +1674,7 @@ subroutine dh2bagw_chave2014(d,h,dhdd,p1,p2,wood_density,c2b,bagw,dbagwdd) real(r8),intent(in) :: p2 ! allometry parameter 2 real(r8),intent(in) :: wood_density real(r8),intent(in) :: c2b - real(r8),intent(out) :: bagw ! plant height [m] + real(r8),intent(out) :: bagw ! plant aboveground biomass [kgC] real(r8),intent(out),optional :: dbagwdd ! change in agb per diameter [kgC/cm] real(r8) :: dbagwdd1,dbagwdd2,dbagwdd3 @@ -1638,10 +1730,10 @@ subroutine d2bagw_2pwr(d,p1,p2,c2b,bagw,dbagwdd) real(r8),intent(in) :: d ! plant diameter [cm] - real(r8),intent(in) :: p1 ! allometry parameter 1 - real(r8),intent(in) :: p2 ! allometry parameter 2 + real(r8),intent(in) :: p1 ! allometry parameter 1 + real(r8),intent(in) :: p2 ! allometry parameter 2 real(r8),intent(in) :: c2b ! carbon to biomass multiplier ~2 - real(r8),intent(out) :: bagw ! plant height [m] + real(r8),intent(out) :: bagw ! plant aboveground biomass [kg C] real(r8),intent(out),optional :: dbagwdd ! change in agb per diameter [kgC/cm] bagw = (p1 * d**p2)/c2b @@ -1891,7 +1983,7 @@ end subroutine h2d_martcano ! ===================================================================================== - subroutine CrownDepth(height,crown_depth) + subroutine CrownDepth(height,ft,crown_depth) ! ----------------------------------------------------------------------------------- ! This routine returns the depth of a plant's crown. Which is the length @@ -1901,14 +1993,20 @@ subroutine CrownDepth(height,crown_depth) ! optioned. ! ----------------------------------------------------------------------------------- - real(r8),intent(in) :: height ! The height of the plant [m] + real(r8),intent(in) :: height ! The height of the plant [m] + integer,intent(in) :: ft ! functional type index real(r8),intent(out) :: crown_depth ! The depth of the crown [m] - + ! Alternative Hypothesis: ! crown depth from Poorter, Bongers & Bongers ! crown_depth = exp(-1.169_r8)*cCohort%hite**1.098_r8 - - crown_depth = min(height,0.1_r8) + + ! Alternative Hypothesis: + ! Original FATES crown depth heigh used for hydraulics + ! crown_depth = min(height,0.1_r8) + + crown_depth = prt_params%crown(ft) * height + return end subroutine CrownDepth @@ -1968,7 +2066,7 @@ end subroutine carea_2pwr ! ========================================================================= - subroutine set_root_fraction(root_fraction, ft, zi) + subroutine set_root_fraction(root_fraction, ft, zi, max_nlevroot) ! ! !DESCRIPTION: @@ -1985,6 +2083,11 @@ subroutine set_root_fraction(root_fraction, ft, zi) integer, intent(in) :: ft ! functional typpe real(r8),intent(in) :: zi(0:) ! Center of depth [m] + ! The soil may not be active over the soil whole column due to things + ! like permafrost. If so, compress profile over the maximum depth + integer,optional, intent(in) :: max_nlevroot + + ! locals real(r8) :: a_par ! local temporary for "a" parameter real(r8) :: b_par ! "" "b" parameter @@ -2011,6 +2114,7 @@ subroutine set_root_fraction(root_fraction, ft, zi) integer :: root_profile_type integer :: corr_id(1) ! This is the bin with largest fraction ! add/subtract any corrections there + integer :: nlevroot real(r8) :: correction ! This correction ensures that root fractions ! sum to 1.0 @@ -2022,13 +2126,27 @@ subroutine set_root_fraction(root_fraction, ft, zi) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + nlevroot = ubound(zi,1) + + ! Set root fraction to zero in all layers, as some may be inactive + ! and we will only calculate the profiles over those + root_fraction(:) = 0._r8 + + if(present(max_nlevroot))then + if(debug .and. max_nlevroot<0)then + write(fates_log(),*) 'A maximum rooting layer depth <0 was specified' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + nlevroot = min(max_nlevroot,nlevroot) + end if + select case(nint(prt_params%fnrt_prof_mode(ft))) case ( exponential_1p_profile_type ) - call exponential_1p_root_profile(root_fraction, zi, prt_params%fnrt_prof_a(ft)) + call exponential_1p_root_profile(root_fraction(1:nlevroot), zi(0:nlevroot), prt_params%fnrt_prof_a(ft)) case ( jackson_beta_profile_type ) - call jackson_beta_root_profile(root_fraction, zi, prt_params%fnrt_prof_a(ft)) + call jackson_beta_root_profile(root_fraction(1:nlevroot), zi(0:nlevroot), prt_params%fnrt_prof_a(ft)) case ( exponential_2p_profile_type ) - call exponential_2p_root_profile(root_fraction, zi, & + call exponential_2p_root_profile(root_fraction(1:nlevroot), zi(0:nlevroot), & prt_params%fnrt_prof_a(ft),prt_params%fnrt_prof_b(ft)) case default diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 index c96728f661..d14ce7b005 100644 --- a/biogeochem/FatesSoilBGCFluxMod.F90 +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -31,6 +31,7 @@ module FatesSoilBGCFluxMod use PRTGenericMod , only : repro_organ use PRTGenericMod , only : struct_organ use PRTGenericMod , only : SetState + use PRTAllometricCNPMod,only : stoich_max use FatesAllometryMod, only : set_root_fraction use FatesAllometryMod , only : h_allom use FatesAllometryMod , only : h2d_allom @@ -53,6 +54,7 @@ module FatesSoilBGCFluxMod use FatesInterfaceTypesMod, only : numpft use FatesInterfaceTypesMod, only : hlm_nu_com use FatesInterfaceTypesMod, only : hlm_parteh_mode + use FatesInterfaceTypesMod, only : hlm_use_ch4 use FatesConstantsMod , only : prescribed_p_uptake use FatesConstantsMod , only : prescribed_n_uptake use FatesConstantsMod , only : coupled_p_uptake @@ -63,7 +65,12 @@ module FatesSoilBGCFluxMod use FatesConstantsMod, only : fates_np_comp_scaling use FatesConstantsMod, only : cohort_np_comp_scaling use FatesConstantsMod, only : pft_np_comp_scaling + use FatesConstantsMod, only : trivial_np_comp_scaling use FatesConstantsMod, only : rsnbl_math_prec + use FatesConstantsMod, only : days_per_year + use FatesConstantsMod, only : sec_per_day + use FatesConstantsMod, only : years_per_day + use FatesConstantsMod, only : itrue use FatesLitterMod, only : litter_type use FatesLitterMod , only : ncwd use FatesLitterMod , only : ndcmpy @@ -72,10 +79,12 @@ module FatesSoilBGCFluxMod use FatesLitterMod , only : icellulose use PRTParametersMod , only : prt_params use EDPftvarcon , only : EDPftvarcon_inst + use FatesUtilsMod, only : check_var_real implicit none private - + + public :: PrepCH4Bcs public :: PrepNutrientAquisitionBCs public :: UnPackNutrientAquisitionBCs public :: FluxIntoLitterPools @@ -114,8 +123,9 @@ function GetPlantDemand(ccohort,element_id) result(plant_demand) real(r8) :: plant_max_x ! Maximum mass for element of interest [kg] integer :: pft real(r8) :: dbh + real(r8) :: leafm,fnrtm,sapwm,structm,storem - real(r8), parameter :: smth_fac = 0.8_r8 ! Smoothing factor for updating + real(r8), parameter :: smth_fac = 0.1_r8 ! Smoothing factor for updating ! demand. real(r8), parameter :: init_demand_frac = 0.1_r8 ! Newly recruited plants ! will specify a demand @@ -130,31 +140,10 @@ function GetPlantDemand(ccohort,element_id) result(plant_demand) ! If the cohort has not experienced a day of integration - ! (and thus any allocation yet), we specify demand - ! based purely on a fraction of its starting nutrient content + ! (and thus any allocation yet), it has no deficit + ! in its storage to drive any need, so it thus has no demand if(ccohort%isnew) then - - if(element_id.eq.nitrogen_element) then - plant_max_x = & - ccohort%prt%GetState(leaf_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,leaf_organ) + & - ccohort%prt%GetState(fnrt_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,fnrt_organ) + & - ccohort%prt%GetState(store_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,store_organ) + & - ccohort%prt%GetState(sapw_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,sapw_organ) + & - ccohort%prt%GetState(struct_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,struct_organ) + & - ccohort%prt%GetState(repro_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,repro_organ) - - elseif(element_id.eq.phosphorus_element) then - plant_max_x = & - ccohort%prt%GetState(leaf_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,leaf_organ) + & - ccohort%prt%GetState(fnrt_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,fnrt_organ) + & - ccohort%prt%GetState(store_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,store_organ) + & - ccohort%prt%GetState(sapw_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,sapw_organ) + & - ccohort%prt%GetState(struct_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,struct_organ) + & - ccohort%prt%GetState(repro_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,repro_organ) - - end if - - plant_demand = init_demand_frac*plant_max_x + plant_demand = 0._r8 return end if @@ -165,11 +154,11 @@ function GetPlantDemand(ccohort,element_id) result(plant_demand) if(element_id.eq.nitrogen_element) then - plant_demand = smth_fac*ccohort%daily_n_demand + (1._r8-smth_fac)*ccohort%daily_n_need2 + plant_demand = smth_fac*ccohort%daily_n_demand + (1._r8-smth_fac)*max(0._r8,ccohort%daily_n_need) elseif(element_id.eq.phosphorus_element) then - plant_demand = smth_fac*ccohort%daily_p_demand + (1._r8-smth_fac)*ccohort%daily_p_need2 + plant_demand = smth_fac*ccohort%daily_p_demand + (1._r8-smth_fac)*max(0._r8,ccohort%daily_p_need) end if @@ -210,7 +199,6 @@ subroutine UnPackNutrientAquisitionBCs(sites, bc_in) real(r8) :: fnrt_c ! fine-root carbon [kg] real(r8) :: fnrt_c_pft(numpft) ! total mass of root for each PFT [kgC] - nsites = size(sites,dim=1) @@ -220,7 +208,8 @@ subroutine UnPackNutrientAquisitionBCs(sites, bc_in) do while (associated(cpatch)) ccohort => cpatch%tallest do while (associated(ccohort)) - ccohort%daily_n_uptake = 0._r8 + ccohort%daily_nh4_uptake = 0._r8 + ccohort%daily_no3_uptake = 0._r8 ccohort%daily_p_uptake = 0._r8 ccohort => ccohort%shorter end do @@ -233,13 +222,13 @@ subroutine UnPackNutrientAquisitionBCs(sites, bc_in) if(hlm_parteh_mode.eq.prt_carbon_allom_hyp) then ! These can now be zero'd do s = 1, nsites - bc_in(s)%plant_n_uptake_flux(:,:) = 0._r8 + bc_in(s)%plant_nh4_uptake_flux(:,:) = 0._r8 + bc_in(s)%plant_no3_uptake_flux(:,:) = 0._r8 bc_in(s)%plant_p_uptake_flux(:,:) = 0._r8 end do return end if - do s = 1, nsites ! If the plant is in "prescribed uptake mode" @@ -257,8 +246,9 @@ subroutine UnPackNutrientAquisitionBCs(sites, bc_in) pft = ccohort%pft ccohort%daily_n_demand = GetPlantDemand(ccohort,nitrogen_element) - ccohort%daily_n_uptake = EDPftvarcon_inst%prescribed_nuptake(pft) * ccohort%daily_n_demand - + ccohort%daily_nh4_uptake = EDPftvarcon_inst%prescribed_nuptake(pft) * ccohort%daily_n_demand + ccohort%daily_no3_uptake = 0._r8 + ccohort => ccohort%shorter end do cpatch => cpatch%younger @@ -331,9 +321,12 @@ subroutine UnPackNutrientAquisitionBCs(sites, bc_in) ccohort => cpatch%tallest do while (associated(ccohort)) icomp = icomp+1 + ! N Uptake: Convert g/m2/day -> kg/plant/day - ccohort%daily_n_uptake = ccohort%daily_n_uptake + & - sum(bc_in(s)%plant_n_uptake_flux(icomp,:))*kg_per_g*AREA/ccohort%n + + ccohort%daily_nh4_uptake = sum(bc_in(s)%plant_nh4_uptake_flux(icomp,:))*kg_per_g*AREA/ccohort%n + ccohort%daily_no3_uptake = sum(bc_in(s)%plant_no3_uptake_flux(icomp,:))*kg_per_g*AREA/ccohort%n + ccohort => ccohort%shorter end do cpatch => cpatch%younger @@ -352,8 +345,11 @@ subroutine UnPackNutrientAquisitionBCs(sites, bc_in) ! Loop through soil layers, add up the uptake this cohort gets from each layer do id = 1,bc_in(s)%nlevdecomp - ccohort%daily_n_uptake = ccohort%daily_n_uptake + & - bc_in(s)%plant_n_uptake_flux(pft,id) * & + ccohort%daily_nh4_uptake = ccohort%daily_nh4_uptake + & + bc_in(s)%plant_nh4_uptake_flux(pft,id) * & + (fnrt_c/fnrt_c_pft(pft))*kg_per_g*AREA/ccohort%n + ccohort%daily_no3_uptake = ccohort%daily_no3_uptake + & + bc_in(s)%plant_no3_uptake_flux(pft,id) * & (fnrt_c/fnrt_c_pft(pft))*kg_per_g*AREA/ccohort%n end do @@ -411,7 +407,8 @@ subroutine UnPackNutrientAquisitionBCs(sites, bc_in) end if n_or_p_coupled_if ! These can now be zero'd - bc_in(s)%plant_n_uptake_flux(:,:) = 0._r8 + bc_in(s)%plant_nh4_uptake_flux(:,:) = 0._r8 + bc_in(s)%plant_no3_uptake_flux(:,:) = 0._r8 bc_in(s)%plant_p_uptake_flux(:,:) = 0._r8 end do @@ -420,6 +417,153 @@ end subroutine UnPackNutrientAquisitionBCs ! ===================================================================================== + subroutine PrepCH4BCs(csite,bc_in,bc_out) + + ! + ! This routine prepares the output boundary conditions for methane calculations + ! in ELM/CLM. + ! ----------------------------------------------------------------------------------- + + + ! !ARGUMENTS + type(ed_site_type), intent(inout) :: csite + + type(bc_out_type), intent(inout) :: bc_out + type(bc_in_type), intent(in) :: bc_in + type(ed_patch_type), pointer :: cpatch ! current patch pointer + type(ed_cohort_type), pointer :: ccohort ! current cohort pointer + integer :: pft ! plant functional type + integer :: fp ! patch index of the site + real(r8) :: agnpp ! Above ground daily npp + real(r8) :: bgnpp ! Below ground daily npp + real(r8) :: plant_area ! crown area (m2) of all plants in patch + real(r8) :: woody_area ! corwn area (m2) of woody plants in patch + real(r8) :: fnrt_c ! Fine root carbon [kg/plant] + real(r8) :: sapw_net_alloc + real(r8) :: store_net_alloc + real(r8) :: fnrt_net_alloc + real(r8) :: leaf_net_alloc + real(r8) :: struct_net_alloc + real(r8) :: repro_net_alloc + + ! Exit if we need not communicate with the hlm's ch4 module + if(.not.(hlm_use_ch4==itrue)) return + + ! Initialize to zero + bc_out%annavg_agnpp_pa(:) = 0._r8 + bc_out%annavg_bgnpp_pa(:) = 0._r8 + bc_out%annsum_npp_pa(:) = 0._r8 + bc_out%rootfr_pa(:,:) = 0._r8 + bc_out%frootc_pa(:) = 0._r8 + bc_out%root_resp(:) = 0._r8 + bc_out%woody_frac_aere_pa(:) = 0._r8 + + fp = 0 + cpatch => csite%oldest_patch + do while (associated(cpatch)) + + ! Patch ordering when passing boundary conditions + ! always goes from oldest to youngest, following + ! the convention of EDPatchDynamics::set_patchno() + + fp = fp + 1 + + agnpp = 0._r8 + bgnpp = 0._r8 + woody_area = 0._r8 + plant_area = 0._r8 + + ccohort => cpatch%tallest + do while (associated(ccohort)) + + ! For consistency, only apply calculations to non-new + ! cohorts. New cohorts will not have respiration rates + ! at this point in the call sequence. + + if(.not.ccohort%isnew) then + + pft = ccohort%pft + + call set_root_fraction(csite%rootfrac_scr, pft, csite%zi_soil, & + bc_in%max_rooting_depth_index_col ) + + fnrt_c = ccohort%prt%GetState(fnrt_organ, carbon12_element) + + ! Fine root fraction over depth + + bc_out%rootfr_pa(fp,1:bc_in%nlevsoil) = & + bc_out%rootfr_pa(fp,1:bc_in%nlevsoil) + & + csite%rootfrac_scr(1:bc_in%nlevsoil) + + ! Fine root carbon, convert [kg/plant] -> [g/m2] + bc_out%frootc_pa(fp) = & + bc_out%frootc_pa(fp) + & + fnrt_c*ccohort%n/cpatch%area * g_per_kg + + ! [kgC/day] + sapw_net_alloc = ccohort%prt%GetNetAlloc(sapw_organ, carbon12_element) * days_per_sec + store_net_alloc = ccohort%prt%GetNetAlloc(store_organ, carbon12_element) * days_per_sec + leaf_net_alloc = ccohort%prt%GetNetAlloc(leaf_organ, carbon12_element) * days_per_sec + fnrt_net_alloc = ccohort%prt%GetNetAlloc(fnrt_organ, carbon12_element) * days_per_sec + struct_net_alloc = ccohort%prt%GetNetAlloc(struct_organ, carbon12_element) * days_per_sec + repro_net_alloc = ccohort%prt%GetNetAlloc(repro_organ, carbon12_element) * days_per_sec + + ! [kgC/plant/day] -> [gC/m2/s] + agnpp = agnpp + ccohort%n/cpatch%area * (leaf_net_alloc + repro_net_alloc + & + prt_params%allom_agb_frac(pft)*(sapw_net_alloc+store_net_alloc+struct_net_alloc)) * g_per_kg + + ! [kgC/plant/day] -> [gC/m2/s] + bgnpp = bgnpp + ccohort%n/cpatch%area * (fnrt_net_alloc + & + (1._r8-prt_params%allom_agb_frac(pft))*(sapw_net_alloc+store_net_alloc+struct_net_alloc)) * g_per_kg + + ! (gC/m2/s) root respiration (fine root MR + total root GR) + ! RGK: We do not save root respiration and average over the day. Until we do + ! this is a best (bad) guess at fine root MR + total root GR + ! (kgC/indiv/yr) -> gC/m2/s + bc_out%root_resp(1:bc_in%nlevsoil) = bc_out%root_resp(1:bc_in%nlevsoil) + & + ccohort%resp_acc_hold*years_per_day*g_per_kg*days_per_sec* & + ccohort%n*area_inv*(1._r8-prt_params%allom_agb_frac(pft)) * csite%rootfrac_scr(1:bc_in%nlevsoil) + + if( prt_params%woody(pft)==itrue ) then + woody_area = woody_area + ccohort%c_area + end if + plant_area = plant_area + ccohort%c_area + + + end if + + ccohort => ccohort%shorter + end do + + if( sum(bc_out%rootfr_pa(fp,1:bc_in%nlevsoil)) > nearzero) then + bc_out%rootfr_pa(fp,1:bc_in%nlevsoil) = & + bc_out%rootfr_pa(fp,1:bc_in%nlevsoil) / & + sum(bc_out%rootfr_pa(fp,1:bc_in%nlevsoil)) + end if + + ! RGK: These averages should switch to the new patch averaging methods + ! when available. Right now we are not doing any time averaging + ! because it would be mixing the memory of patches, which + ! would be arguably worse than just using the instantaneous value + + ! gC/m2/s + bc_out%annavg_agnpp_pa(fp) = agnpp + bc_out%annavg_bgnpp_pa(fp) = bgnpp + ! gc/m2/yr + bc_out%annsum_npp_pa(fp) = (bgnpp+agnpp)*days_per_year*sec_per_day + + if(plant_area>nearzero) then + bc_out%woody_frac_aere_pa(fp) = woody_area/plant_area + end if + + cpatch => cpatch%younger + end do + + return + end subroutine PrepCH4BCs + + ! ===================================================================================== + subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) ! ----------------------------------------------------------------------------------- @@ -440,7 +584,6 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) integer :: j ! soil layer index integer :: id ! decomp index (might == j) integer :: pft ! plant functional type - integer :: nlev_eff_soil ! number of active soil layers type(ed_patch_type), pointer :: cpatch ! current patch pointer type(ed_cohort_type), pointer :: ccohort ! current cohort pointer real(r8) :: fnrt_c ! fine-root carbon [kg] @@ -453,43 +596,50 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) real(r8) :: deficit_p_demand ! Phosphorus needed to get stoich back to ! optimal [kgP] real(r8) :: comp_per_pft(numpft) ! Competitors per PFT, used for averaging - - - ! Run the trivial case where we do not have a nutrient model - ! running in fates, send zero demands to the BGC model - if((hlm_parteh_mode.ne.prt_cnp_flex_allom_hyp)) then - bc_out%num_plant_comps = 1 - if(trim(hlm_nu_com).eq.'ECA')then - bc_out%ft_index(1) = 1 - bc_out%veg_rootc(1,:) = 0._r8 - bc_out%cn_scalar(1) = 0._r8 - bc_out%cp_scalar(1) = 0._r8 - bc_out%decompmicc(1) = 0._r8 - elseif(trim(hlm_nu_com).eq.'RD') then + real(r8) :: decompmicc_layer ! Microbial dedcomposer biomass for current layer + integer :: comp_scaling ! Flag that defines the boundary condition scaling method (includes trivial) + + real(r8), parameter :: decompmicc_lambda = 2.5_r8 ! Depth attenuation exponent for decomposer biomass + real(r8), parameter :: decompmicc_zmax = 7.0e-2_r8 ! Depth of maximum decomposer biomass + + ! Determine the scaling approach + if((hlm_parteh_mode.eq.prt_cnp_flex_allom_hyp) .and. & + ((n_uptake_mode.eq.coupled_n_uptake) .or. & + (p_uptake_mode.eq.coupled_p_uptake))) then + comp_scaling = fates_np_comp_scaling + + else + + comp_scaling = trivial_np_comp_scaling + + ! Note: With ECA, we still need to update the + ! decomp microbe density even if we are not + ! fully coupled, so can't exit yet + + if(trim(hlm_nu_com).eq.'RD') then + bc_out%num_plant_comps = 1 bc_out%n_demand(1) = 0._r8 bc_out%p_demand(1) = 0._r8 + return end if - return + end if - ! This is the number of effective soil layers to transfer from - nlev_eff_soil = max(bc_in%max_rooting_depth_index_col, 1) - ! ECA Specific Parameters ! -------------------------------------------------------------------------------- if(trim(hlm_nu_com).eq.'ECA')then bc_out%veg_rootc(:,:) = 0._r8 ! Zero this, it will be incremented + bc_out%decompmicc(:) = 0._r8 bc_out%cn_scalar(:) = 0._r8 bc_out%cp_scalar(:) = 0._r8 - bc_out%decompmicc(:) = 0._r8 bc_out%ft_index(:) = -1 ! Loop over all patches and sum up the seed input for each PFT icomp = 0 comp_per_pft(:) = 0 ! This counts how many competitors per + ! pft, used for averaging - ! pft, used for averaging cpatch => csite%oldest_patch do while (associated(cpatch)) @@ -497,43 +647,50 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) do while (associated(ccohort)) pft = ccohort%pft - - if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then + + ! If we are not coupling plant uptake + ! with ECA, then we send 1 token + ! competitor with plant root biomass, but no + ! uptake affinity + + if(comp_scaling.eq.cohort_np_comp_scaling) then icomp = icomp+1 + bc_out%ft_index(icomp) = pft else icomp = pft comp_per_pft(pft) = comp_per_pft(pft) + 1 + bc_out%ft_index(icomp) = pft end if - call set_root_fraction(csite%rootfrac_scr, pft, csite%zi_soil) + call set_root_fraction(csite%rootfrac_scr, pft, csite%zi_soil, & + bc_in%max_rooting_depth_index_col ) - fnrt_c = ccohort%prt%GetState(fnrt_organ, all_carbon_elements) + fnrt_c = ccohort%prt%GetState(fnrt_organ, carbon12_element) ! Map the soil layers to the decomposition layers ! (which may be synonomous) ! veg_rootc in units: [g/m3] = [kgC/plant] * [plant/ha] * [ha/ 10k m2] * [1000 g / kg] * [1/m] - - do j = 1, nlev_eff_soil + + do j = 1, bc_in%nlevdecomp id = bc_in%decomp_id(j) ! Map from soil layer to decomp layer veg_rootc = fnrt_c * ccohort%n * csite%rootfrac_scr(j) * AREA_INV * g_per_kg / csite%dz_soil(j) + bc_out%veg_rootc(icomp,id) = bc_out%veg_rootc(icomp,id) + veg_rootc - bc_out%decompmicc(id) = bc_out%decompmicc(id) + & - EDPftvarcon_inst%decompmicc(pft) * veg_rootc - end do - - bc_out%ft_index(icomp) = pft + ! We use a 3 parameter exponential attenuation function to estimate decomposer biomass + ! The parameter EDPftvarcon_inst%decompmicc(pft) is the maximum amount found at depth + ! decompmicc_zmax, and the profile attenuates with strength lambda + + decompmicc_layer = EDPftvarcon_inst%decompmicc(pft) * & + exp(-decompmicc_lambda*abs(csite%z_soil(j)-decompmicc_zmax)) + + bc_out%decompmicc(id) = bc_out%decompmicc(id) + decompmicc_layer * veg_rootc + end do ccohort => ccohort%shorter end do cpatch => cpatch%younger end do - - if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then - bc_out%num_plant_comps = icomp - else - bc_out%num_plant_comps = numpft - end if ! We calculate the decomposer microbial biomass by weighting with the ! root biomass. This is just the normalization step @@ -542,6 +699,17 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) max(nearzero,sum(bc_out%veg_rootc(:,id),dim=1)) end do + if(comp_scaling.eq.cohort_np_comp_scaling) then + bc_out%num_plant_comps = icomp + elseif(comp_scaling.eq.pft_np_comp_scaling) then + bc_out%num_plant_comps = numpft + elseif(comp_scaling.eq.trivial_np_comp_scaling) then + bc_out%num_plant_comps = 1 + ! Now that the microbial density is calculated + ! we can exit the trivial case + return + end if + coupled_n_if: if(n_uptake_mode.eq.coupled_n_uptake) then icomp = 0 cpatch => csite%oldest_patch @@ -571,9 +739,14 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) bc_out%cn_scalar(icomp) = bc_out%cn_scalar(icomp)/real(comp_per_pft(icomp),r8) end do end if + + else + + ! If we are not coupling N, then make sure to set affinity of plants to 0 + ! (it is possible to be here if P is coupled but N is not) + bc_out%cn_scalar(:) = 0._r8 end if coupled_n_if - coupled_p_if: if(p_uptake_mode.eq.coupled_p_uptake) then @@ -603,6 +776,11 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) bc_out%cp_scalar(icomp) = bc_out%cp_scalar(icomp)/real(comp_per_pft(icomp),r8) end do end if + else + + ! If we are not coupling P, then make sure to set affinity of plants to 0 + ! (it is possible to be here if N is coupled but P is not) + bc_out%cp_scalar(:) = 0._r8 end if coupled_p_if @@ -624,6 +802,7 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) end do cpatch => cpatch%younger end do + end if if(p_uptake_mode .eq. coupled_p_uptake ) then @@ -654,7 +833,6 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) ccohort => cpatch%tallest do while (associated(ccohort)) pft = ccohort%pft - dbh = ccohort%dbh if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then icomp = icomp+1 else @@ -676,7 +854,6 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) ccohort => cpatch%tallest do while (associated(ccohort)) pft = ccohort%pft - dbh = ccohort%dbh if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then icomp = icomp+1 else @@ -690,17 +867,12 @@ subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) end do end if - if( (n_uptake_mode.eq.coupled_n_uptake) .or. & - (p_uptake_mode.eq.coupled_p_uptake)) then - if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then - bc_out%num_plant_comps = icomp - else - bc_out%num_plant_comps = numpft - end if - + if(comp_scaling.eq.cohort_np_comp_scaling) then + bc_out%num_plant_comps = icomp + elseif(comp_scaling.eq.pft_np_comp_scaling) then + bc_out%num_plant_comps = numpft else bc_out%num_plant_comps = 1 - end if end if @@ -743,7 +915,6 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) use FatesConstantsMod, only : sec_per_day use FatesInterfaceTypesMod, only : bc_in_type, bc_out_type use FatesInterfaceTypesMod, only : hlm_use_vertsoilc - use FatesInterfaceTypesMod, only : hlm_numlevgrnd use FatesConstantsMod, only : itrue use FatesGlobals, only : endrun => fates_endrun use EDParamsMod , only : ED_val_cwd_flig, ED_val_cwd_fcel @@ -767,7 +938,7 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) ! element's root efflux type(litter_type), pointer :: litt - real(r8) :: surface_prof(1:hlm_numlevgrnd) ! this array is used to distribute + real(r8) :: surface_prof(bc_in%nlevsoil) ! this array is used to distribute ! fragmented litter on the surface ! into the soil/decomposition ! layers. It exponentially decays @@ -787,7 +958,6 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) ! how steep profile is for surface components (1/ e_folding depth) (1/m) real(r8), parameter :: surfprof_exp = 10. - ! This is the number of effective soil layers to transfer from nlev_eff_soil = max(bc_in%max_rooting_depth_index_col, 1) @@ -816,7 +986,7 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) do id = 1,nlev_eff_decomp surface_prof(id) = surface_prof(id)/surface_prof_tot end do - + ! Loop over the different elements. do el = 1, num_elements @@ -840,11 +1010,6 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) flux_cel_si => bc_out%litt_flux_cel_n_si(:) flux_lab_si => bc_out%litt_flux_lab_n_si(:) flux_lig_si => bc_out%litt_flux_lig_n_si(:) - - ! If we have prescribed boundary conditions - ! we do not take N out of the BGC model's - ! stores, so nor do we send any back - if(n_uptake_mode.eq.prescribed_n_uptake) cycle case (phosphorus_element) bc_out%litt_flux_cel_p_si(:) = 0._r8 @@ -853,20 +1018,18 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) flux_cel_si => bc_out%litt_flux_cel_p_si(:) flux_lab_si => bc_out%litt_flux_lab_p_si(:) flux_lig_si => bc_out%litt_flux_lig_p_si(:) - - ! If we have prescribed boundary conditions - ! we do not take N out of the BGC model's - ! stores, so nor do we send any back - if(p_uptake_mode.eq.prescribed_p_uptake) cycle end select - ! Add efflux to the litter pool. kg/ha/day -> kg/m2/day + + ! If there is any efflux (from stores overflowing) + ! than pass that to the labile litter pool + do id = 1,nlev_eff_decomp flux_lab_si(id) = flux_lab_si(id) + & - sum(csite%flux_diags(el)%nutrient_efflux_scpf)*surface_prof(id)*area_inv + sum(csite%flux_diags(el)%nutrient_efflux_scpf(:)) * & + area_inv * surface_prof(id) end do - currentPatch => csite%oldest_patch do while (associated(currentPatch)) @@ -876,7 +1039,7 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) ! patch litt => currentPatch%litter(el) area_frac = currentPatch%area/area - + do ic = 1, ncwd do id = 1,nlev_eff_decomp @@ -938,7 +1101,6 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) do j = 1, nlev_eff_soil id = bc_in%decomp_id(j) - flux_lab_si(id) = flux_lab_si(id) + & litt%root_fines_frag(ilabile,j) * area_frac flux_cel_si(id) = flux_cel_si(id) + & @@ -962,10 +1124,8 @@ subroutine FluxIntoLitterPools(csite, bc_in, bc_out) flux_lab_si(id) / bc_in%dz_decomp_sisl(id) end do - end do ! do elements - return end subroutine FluxIntoLitterPools @@ -995,105 +1155,76 @@ function ECACScalar(ccohort, element_id) result(c_scalar) real(r8) :: c_scalar ! Locals + real(r8) :: store_frac ! Current nutrient storage relative to max + real(r8) :: store_max ! Maximum nutrient storable by plant + real(r8) :: store_c ! Current storage carbon + real(r8) :: store_c_max ! Current maximum storage carbon + integer :: icode ! real variable checking code + + integer, parameter :: downreg_linear = 1 + integer, parameter :: downreg_logi = 2 + integer, parameter :: downreg_CN_logi = 3 + + integer, parameter :: downreg_type = downreg_linear - real(r8) :: target_leaf_c ! maximum leaf C for this dbh [kg] - real(r8) :: target_store_c ! maximum store C for this dbh [kg] - ! - ! Where X is the element of interest: - real(r8) :: leaf_store_x ! Mass of current element in leaf and storage - real(r8) :: xc_actual ! Actual X:C ratio of plant - real(r8) :: xc_min ! Minimum allowable X:C ratio to build tissue - real(r8) :: xc_ideal ! Plant's ideal X:C ratio - real(r8) :: cx_actual ! Actual C:X ratio of plant - real(r8) :: cx_ideal ! Ideal C:X ratio of plant - real(r8) :: c_stoich_var ! effective variance of the CN or CP ratio - - ! We are still testing different functional relationships for c_scalar, thus - ! three methods. Methods 1 and 2 are subtly different, but both increase neediness - ! as a plants NC or PC ratio decreases, and vice versa. The variance - ! parameter acts as a buffer on the steepness of the relationship. - ! Method 3 turns off neediness and sets it to 1 (always fully needy) - ! - ! method 1: cn_scalar = (nc_ideal - nc_actual + variance*nc_min)/(nc_ideal - nc_min + variance*nc_min) - ! - ! method 2: cn_scalar = (1/nc_actual - (1-variance)/nc_ideal)/(variance/nc_ideal) - - integer, parameter :: cnp_scalar_method1 = 1 - integer, parameter :: cnp_scalar_method2 = 2 - integer, parameter :: cnp_scalar_method3 = 3 - integer, parameter :: cnp_scalar_method = cnp_scalar_method3 - - real(r8), parameter :: cn_stoich_var=0.2 ! variability of CN ratio - real(r8), parameter :: cp_stoich_var=0.4 ! variability of CP ratio - - - ! Target leaf biomass according to allometry and trimming - call bleaf(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,target_leaf_c) - call bstore_allom(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,target_store_c) - - leaf_store_x = max(rsnbl_math_prec,ccohort%prt%GetState(leaf_organ, element_id) + & - ccohort%prt%GetState(store_organ, element_id)) - - ! Calculate the ideal CN or CP ratio for leaves and storage organs - - if(element_id==nitrogen_element)then - - xc_ideal = ((target_leaf_c*prt_params%nitr_stoich_p2(ccohort%pft,leaf_organ)) + & - (target_store_c*prt_params%nitr_stoich_p2(ccohort%pft,store_organ))) / & - (target_leaf_c+target_store_c) - xc_min = ((target_leaf_c*prt_params%nitr_stoich_p1(ccohort%pft,leaf_organ)) + & - (target_store_c*prt_params%nitr_stoich_p1(ccohort%pft,store_organ))) / & - (target_leaf_c+target_store_c) - - xc_actual = max(leaf_store_x/(target_leaf_c+target_store_c),rsnbl_math_prec) + + real(r8), parameter :: logi_k = 25.0_r8 ! logistic function k + real(r8), parameter :: store_x0 = 1.0_r8 ! storage fraction inflection point + real(r8), parameter :: logi_min = 0.0_r8 ! minimum cn_scalar for logistic - c_stoich_var = cn_stoich_var + ! This is the storage fraction where downregulation starts if using + ! a linear function + real(r8), parameter :: store_frac0 = 0.5_r8 - elseif(element_id==phosphorus_element) then + real(r8), parameter :: c_max = 1.0_r8 + real(r8), parameter :: c_min = 1.e-3_r8 + + + store_max = ccohort%prt%GetNutrientTarget(element_id,store_organ,stoich_max) + store_frac = min(2.0_r8,ccohort%prt%GetState(store_organ, element_id)/store_max) + + if(downreg_type == downreg_linear) then - xc_ideal = ((target_leaf_c*prt_params%phos_stoich_p2(ccohort%pft,leaf_organ)) + & - (target_store_c*prt_params%phos_stoich_p2(ccohort%pft,store_organ))) / & - (target_leaf_c+target_store_c) - xc_min = ((target_leaf_c*prt_params%phos_stoich_p1(ccohort%pft,leaf_organ)) + & - (target_store_c*prt_params%phos_stoich_p1(ccohort%pft,store_organ))) / & - (target_leaf_c+target_store_c) + c_scalar = min(c_max,max(c_min,1.0 - (store_frac - store_frac0)/(1.0_r8-store_frac0))) + + elseif(downreg_type == downreg_logi) then + + ! In this method, we define the c_scalar term + ! with a logistic function that goes to 1 (full need) + ! as the plant's nutrien storage hits a low threshold + ! and goes to 0, no demand, as the plant's nutrient + ! storage approaches it's maximum holding capacity - xc_actual = max(leaf_store_x/(target_leaf_c+target_store_c),rsnbl_math_prec) + + + c_scalar = max(c_min,min(c_max,logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))))) - c_stoich_var = cp_stoich_var + call check_var_real(c_scalar,'c_scalar',icode) + if (icode .ne. 0) then + write(fates_log(),*) 'c_scalar is invalid, element: ',element_id + write(fates_log(),*) 'ending' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif else - write(fates_log(), *) 'attempted to call ECACScalar() for unknown element',element_id - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - select case(cnp_scalar_method) - case(cnp_scalar_method1) + store_c = ccohort%prt%GetState(store_organ, carbon12_element) + call bstore_allom(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,store_c_max) - ! To-do: Add a logistic function here, with a - ! shape parameter so that 95%tile of - ! nutrient concentration matches 95%tile of scalar - ! 0.95 = 1._r8/(1._r8 + exp(-logi_k*( 0.95*(nc_ideal-x0) ))) - ! logi_k = -log(1._r8-0.95/0.95)/ ( 0.95*(nc_ideal-x0) ) - ! bc_out%cn_scalar(icomp) = 1._r8/(1._r8 + exp(-logi_k*(nc_actual-x0))) - - c_scalar = min(1._r8,max(0._r8, & - (xc_ideal - xc_actual + c_stoich_var*xc_min) / & - (xc_ideal - xc_min + c_stoich_var*xc_min))) - - case(cnp_scalar_method2) - - cx_ideal = 1._r8/xc_ideal - cx_actual = 1._r8/xc_actual - c_scalar = min(1._r8,max(0._r8, & - (cx_actual - cx_ideal*(1._r8-c_stoich_var))/(cx_ideal*c_stoich_var))) - - case(cnp_scalar_method3) + ! Fraction of N per fraction of C + ! If this is greater than 1, then we have more N in storage than + ! we have C, so we downregulate. If this is less than 1, then + ! we have less N in storage than we have C, so up-regulate + + store_frac = store_frac / (store_c/store_c_max) - c_scalar = 1 + c_scalar = max(c_min,min(c_max,logi_min + (1.0_r8-logi_min)/(1.0_r8 + exp(logi_k*(store_frac-store_x0))))) - end select + + + + end if + end function ECACScalar diff --git a/biogeophys/EDAccumulateFluxesMod.F90 b/biogeophys/EDAccumulateFluxesMod.F90 index 4d873cca85..a0fe4dd7df 100644 --- a/biogeophys/EDAccumulateFluxesMod.F90 +++ b/biogeophys/EDAccumulateFluxesMod.F90 @@ -23,8 +23,8 @@ module EDAccumulateFluxesMod logical :: debug = .false. ! for debugging this module character(len=*), parameter, private :: sourcefile = & - __FILE__ - + __FILE__ + contains !------------------------------------------------------------------------------ @@ -36,9 +36,9 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) ! see above ! ! !USES: - + use EDTypesMod , only : ed_patch_type, ed_cohort_type, & - ed_site_type, AREA + ed_site_type, AREA use FatesInterfaceTypesMod , only : bc_in_type,bc_out_type ! @@ -59,57 +59,59 @@ subroutine AccumulateFluxes_ED(nsites, sites, bc_in, bc_out, dt_time) !---------------------------------------------------------------------- do s = 1, nsites - + ifp = 0 cpatch => sites(s)%oldest_patch do while (associated(cpatch)) - ifp = ifp+1 - - if( bc_in(s)%filter_photo_pa(ifp) == 3 ) then - ccohort => cpatch%shortest - do while(associated(ccohort)) - - ! Accumulate fluxes from hourly to daily values. - ! _tstep fluxes are KgC/indiv/timestep _acc are KgC/indiv/day - - if ( debug ) then - - write(fates_log(),*) 'EDAccumFlux 64 ',ccohort%npp_tstep - write(fates_log(),*) 'EDAccumFlux 66 ',ccohort%gpp_tstep - write(fates_log(),*) 'EDAccumFlux 67 ',ccohort%resp_tstep - - endif - - ccohort%npp_acc = ccohort%npp_acc + ccohort%npp_tstep - ccohort%gpp_acc = ccohort%gpp_acc + ccohort%gpp_tstep - ccohort%resp_acc = ccohort%resp_acc + ccohort%resp_tstep - - ! weighted mean of D13C by gpp - if((ccohort%gpp_acc + ccohort%gpp_tstep) .eq. 0.0_r8) then - ccohort%c13disc_acc = 0.0_r8 - else - ccohort%c13disc_acc = ((ccohort%c13disc_acc * ccohort%gpp_acc) + & - (ccohort%c13disc_clm * ccohort%gpp_tstep)) / & - (ccohort%gpp_acc + ccohort%gpp_tstep) - endif - - do iv=1,ccohort%nv - if(ccohort%year_net_uptake(iv) == 999._r8)then ! note that there were leaves in this layer this year. - ccohort%year_net_uptake(iv) = 0._r8 - end if - ccohort%year_net_uptake(iv) = ccohort%year_net_uptake(iv) + ccohort%ts_net_uptake(iv) - enddo - - ccohort => ccohort%taller - enddo ! while(associated(ccohort)) - end if + if(cpatch%nocomp_pft_label.ne.0)then + ifp = ifp+1 + + if( bc_in(s)%filter_photo_pa(ifp) == 3 ) then + ccohort => cpatch%shortest + do while(associated(ccohort)) + + ! Accumulate fluxes from hourly to daily values. + ! _tstep fluxes are KgC/indiv/timestep _acc are KgC/indiv/day + + if ( debug ) then + + write(fates_log(),*) 'EDAccumFlux 64 ',ccohort%npp_tstep + write(fates_log(),*) 'EDAccumFlux 66 ',ccohort%gpp_tstep + write(fates_log(),*) 'EDAccumFlux 67 ',ccohort%resp_tstep + + endif + + ccohort%npp_acc = ccohort%npp_acc + ccohort%npp_tstep + ccohort%gpp_acc = ccohort%gpp_acc + ccohort%gpp_tstep + ccohort%resp_acc = ccohort%resp_acc + ccohort%resp_tstep + + ! weighted mean of D13C by gpp + if((ccohort%gpp_acc + ccohort%gpp_tstep) .eq. 0.0_r8) then + ccohort%c13disc_acc = 0.0_r8 + else + ccohort%c13disc_acc = ((ccohort%c13disc_acc * ccohort%gpp_acc) + & + (ccohort%c13disc_clm * ccohort%gpp_tstep)) / & + (ccohort%gpp_acc + ccohort%gpp_tstep) + endif + + do iv=1,ccohort%nv + if(ccohort%year_net_uptake(iv) == 999._r8)then ! note that there were leaves in this layer this year. + ccohort%year_net_uptake(iv) = 0._r8 + end if + ccohort%year_net_uptake(iv) = ccohort%year_net_uptake(iv) + ccohort%ts_net_uptake(iv) + enddo + + ccohort => ccohort%taller + enddo ! while(associated(ccohort)) + end if + end if ! not bare ground cpatch => cpatch%younger end do ! while(associated(cpatch)) end do return - - end subroutine AccumulateFluxes_ED + + end subroutine AccumulateFluxes_ED end module EDAccumulateFluxesMod diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index e7faac9cc3..e36642447e 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -1,44 +1,44 @@ module EDBtranMod - - !------------------------------------------------------------------------------------- - ! Description: - ! - ! ------------------------------------------------------------------------------------ - - use EDPftvarcon , only : EDPftvarcon_inst - use FatesConstantsMod , only : tfrz => t_water_freeze_k_1atm - use FatesConstantsMod , only : itrue,ifalse,nearzero - use EDTypesMod , only : ed_site_type, & - ed_patch_type, & - ed_cohort_type, & - maxpft - use shr_kind_mod , only : r8 => shr_kind_r8 - use FatesInterfaceTypesMod , only : bc_in_type, & - bc_out_type, & - numpft - use FatesInterfaceTypesMod , only : hlm_use_planthydro - use FatesGlobals , only : fates_log - use FatesAllometryMod , only : set_root_fraction - - ! - implicit none - private - - public :: btran_ed - public :: get_active_suction_layers - public :: check_layer_water - + + !------------------------------------------------------------------------------------- + ! Description: + ! + ! ------------------------------------------------------------------------------------ + + use EDPftvarcon , only : EDPftvarcon_inst + use FatesConstantsMod , only : tfrz => t_water_freeze_k_1atm + use FatesConstantsMod , only : itrue,ifalse,nearzero + use EDTypesMod , only : ed_site_type, & + ed_patch_type, & + ed_cohort_type, & + maxpft + use shr_kind_mod , only : r8 => shr_kind_r8 + use FatesInterfaceTypesMod , only : bc_in_type, & + bc_out_type, & + numpft + use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesGlobals , only : fates_log + use FatesAllometryMod , only : set_root_fraction + + ! + implicit none + private + + public :: btran_ed + public :: get_active_suction_layers + public :: check_layer_water + contains - + ! ==================================================================================== logical function check_layer_water(h2o_liq_vol, tempk) - + implicit none ! Arguments real(r8),intent(in) :: h2o_liq_vol real(r8),intent(in) :: tempk - + check_layer_water = .false. if ( h2o_liq_vol .gt. 0._r8 ) then @@ -50,205 +50,207 @@ logical function check_layer_water(h2o_liq_vol, tempk) end function check_layer_water ! ===================================================================================== - + subroutine get_active_suction_layers(nsites, sites, bc_in, bc_out) - + ! Arguments - + integer,intent(in) :: nsites type(ed_site_type),intent(inout),target :: sites(nsites) type(bc_in_type),intent(in) :: bc_in(nsites) type(bc_out_type),intent(inout) :: bc_out(nsites) - + ! !LOCAL VARIABLES: integer :: s ! site integer :: j ! soil layer !------------------------------------------------------------------------------ - - do s = 1,nsites - if (bc_in(s)%filter_btran) then - do j = 1,bc_in(s)%nlevsoil - bc_out(s)%active_suction_sl(j) = check_layer_water( bc_in(s)%h2o_liqvol_sl(j),bc_in(s)%tempk_sl(j) ) - end do - else - bc_out(s)%active_suction_sl(:) = .false. - end if - end do + + do s = 1,nsites + if (bc_in(s)%filter_btran) then + do j = 1,bc_in(s)%nlevsoil + bc_out(s)%active_suction_sl(j) = check_layer_water( bc_in(s)%h2o_liqvol_sl(j),bc_in(s)%tempk_sl(j) ) + end do + else + bc_out(s)%active_suction_sl(:) = .false. + end if + end do end subroutine get_active_suction_layers - + ! ===================================================================================== subroutine btran_ed( nsites, sites, bc_in, bc_out) use FatesPlantHydraulicsMod, only : BTranForHLMDiagnosticsFromCohortHydr - - ! --------------------------------------------------------------------------------- - ! Calculate the transpiration wetness function (BTRAN) and the root uptake - ! distribution (ROOTR). - ! Boundary conditions in: bc_in(s)%eff_porosity_sl(j) unfrozen porosity - ! bc_in(s)%watsat_sl(j) porosity - ! bc_in(s)%active_uptake_sl(j) frozen/not frozen - ! bc_in(s)%smp_sl(j) suction - ! Boundary conditions out: bc_out(s)%rootr_pasl root uptake distribution - ! bc_out(s)%btran_pa wetness factor - ! --------------------------------------------------------------------------------- - - ! Arguments - - integer,intent(in) :: nsites - type(ed_site_type),intent(inout),target :: sites(nsites) - type(bc_in_type),intent(in) :: bc_in(nsites) - type(bc_out_type),intent(inout) :: bc_out(nsites) - - ! - ! !LOCAL VARIABLES: - type(ed_patch_type),pointer :: cpatch ! Current Patch Pointer - type(ed_cohort_type),pointer :: ccohort ! Current cohort pointer - integer :: s ! site - integer :: j ! soil layer - integer :: ifp ! patch vector index for the site - integer :: ft ! plant functional type index - real(r8) :: smp_node ! matrix potential - real(r8) :: rresis ! suction limitation to transpiration independent - ! of root density - real(r8) :: pftgs(maxpft) ! pft weighted stomatal conductance m/s - real(r8) :: temprootr - real(r8) :: sum_pftgs ! sum of weighted conductances (for normalization) - real(r8), allocatable :: root_resis(:,:) ! Root resistance in each pft x layer - !------------------------------------------------------------------------------ - - associate( & - smpsc => EDPftvarcon_inst%smpsc , & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS - smpso => EDPftvarcon_inst%smpso & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS - ) - - do s = 1,nsites - - allocate(root_resis(numpft,bc_in(s)%nlevsoil)) - - bc_out(s)%rootr_pasl(:,:) = 0._r8 - - ifp = 0 - cpatch => sites(s)%oldest_patch - do while (associated(cpatch)) - ifp=ifp+1 - - ! THIS SHOULD REALLY BE A COHORT LOOP ONCE WE HAVE rootfr_ft FOR COHORTS (RGK) - - do ft = 1,numpft - - call set_root_fraction(sites(s)%rootfrac_scr, ft, sites(s)%zi_soil ) - - cpatch%btran_ft(ft) = 0.0_r8 - do j = 1,bc_in(s)%nlevsoil - - ! Calculations are only relevant where liquid water exists - ! see clm_fates%wrap_btran for calculation with CLM/ALM - - if ( check_layer_water(bc_in(s)%h2o_liqvol_sl(j),bc_in(s)%tempk_sl(j)) ) then - - smp_node = max(smpsc(ft), bc_in(s)%smp_sl(j)) - - rresis = min( (bc_in(s)%eff_porosity_sl(j)/bc_in(s)%watsat_sl(j))* & - (smp_node - smpsc(ft)) / (smpso(ft) - smpsc(ft)), 1._r8) - - root_resis(ft,j) = sites(s)%rootfrac_scr(j)*rresis - - ! root water uptake is not linearly proportional to root density, - ! to allow proper deep root funciton. Replace with equations from SPA/Newman. FIX(RF,032414) - - cpatch%btran_ft(ft) = cpatch%btran_ft(ft) + root_resis(ft,j) - - else - root_resis(ft,j) = 0._r8 - end if - - end do !j - - ! Normalize root resistances to get layer contribution to ET - do j = 1,bc_in(s)%nlevsoil - if (cpatch%btran_ft(ft) > nearzero) then - root_resis(ft,j) = root_resis(ft,j)/cpatch%btran_ft(ft) - else - root_resis(ft,j) = 0._r8 - end if - end do - - end do !PFT - - ! PFT-averaged point level root fraction for extraction purposese. - ! The cohort's conductance g_sb_laweighted, contains a weighting factor - ! based on the cohort's leaf area. units: [m/s] * [m2] - - pftgs(1:maxpft) = 0._r8 - ccohort => cpatch%tallest - do while(associated(ccohort)) - pftgs(ccohort%pft) = pftgs(ccohort%pft) + ccohort%g_sb_laweight - ccohort => ccohort%shorter - enddo - - ! Process the boundary output, this is necessary for calculating the soil-moisture - ! sink term across the different layers in driver/host. Photosynthesis will - ! pass the host a total transpiration for the patch. This needs rootr to be - ! distributed over the soil layers. - sum_pftgs = sum(pftgs(1:numpft)) - - do j = 1, bc_in(s)%nlevsoil - bc_out(s)%rootr_pasl(ifp,j) = 0._r8 - do ft = 1,numpft - if( sum_pftgs > 0._r8)then !prevent problem with the first timestep - might fail - !bit-retart test as a result? FIX(RF,032414) - bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j) + & - root_resis(ft,j) * pftgs(ft)/sum_pftgs - else - bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j) + & - root_resis(ft,j) * 1._r8/real(numpft,r8) - end if - enddo - enddo - - ! Calculate the BTRAN that is passed back to the HLM - ! used only for diagnostics. If plant hydraulics is turned off - ! we are using the patchxpft level btran calculation - - if(hlm_use_planthydro.eq.ifalse) then - !weight patch level output BTRAN for the - bc_out(s)%btran_pa(ifp) = 0.0_r8 - do ft = 1,numpft - if( sum_pftgs > 0._r8)then !prevent problem with the first timestep - might fail - !bit-retart test as a result? FIX(RF,032414) - bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * pftgs(ft)/sum_pftgs - else - bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * 1./numpft - end if - enddo - end if - - temprootr = sum(bc_out(s)%rootr_pasl(ifp,1:bc_in(s)%nlevsoil)) - - if(abs(1.0_r8-temprootr) > 1.0e-10_r8 .and. temprootr > 1.0e-10_r8)then - write(fates_log(),*) 'error with rootr in canopy fluxes',temprootr,sum_pftgs - do j = 1,bc_in(s)%nlevsoil - bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j)/temprootr - enddo - end if - - cpatch => cpatch%younger - end do - - deallocate(root_resis) - - end do - - if(hlm_use_planthydro.eq.itrue) then - call BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) - end if - - end associate - - end subroutine btran_ed + + ! --------------------------------------------------------------------------------- + ! Calculate the transpiration wetness function (BTRAN) and the root uptake + ! distribution (ROOTR). + ! Boundary conditions in: bc_in(s)%eff_porosity_sl(j) unfrozen porosity + ! bc_in(s)%watsat_sl(j) porosity + ! bc_in(s)%active_uptake_sl(j) frozen/not frozen + ! bc_in(s)%smp_sl(j) suction + ! Boundary conditions out: bc_out(s)%rootr_pasl root uptake distribution + ! bc_out(s)%btran_pa wetness factor + ! --------------------------------------------------------------------------------- + + ! Arguments + + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + + ! + ! !LOCAL VARIABLES: + type(ed_patch_type),pointer :: cpatch ! Current Patch Pointer + type(ed_cohort_type),pointer :: ccohort ! Current cohort pointer + integer :: s ! site + integer :: j ! soil layer + integer :: ifp ! patch vector index for the site + integer :: ft ! plant functional type index + real(r8) :: smp_node ! matrix potential + real(r8) :: rresis ! suction limitation to transpiration independent + ! of root density + real(r8) :: pftgs(maxpft) ! pft weighted stomatal conductance m/s + real(r8) :: temprootr + real(r8) :: sum_pftgs ! sum of weighted conductances (for normalization) + real(r8), allocatable :: root_resis(:,:) ! Root resistance in each pft x layer + !------------------------------------------------------------------------------ + + associate( & + smpsc => EDPftvarcon_inst%smpsc , & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS + smpso => EDPftvarcon_inst%smpso & ! INTERF-TODO: THESE SHOULD BE FATES PARAMETERS + ) + + do s = 1,nsites + + allocate(root_resis(numpft,bc_in(s)%nlevsoil)) + + bc_out(s)%rootr_pasl(:,:) = 0._r8 + + ifp = 0 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + if(cpatch%nocomp_pft_label.ne.0)then ! only for veg patches + ifp=ifp+1 + + ! THIS SHOULD REALLY BE A COHORT LOOP ONCE WE HAVE rootfr_ft FOR COHORTS (RGK) + + do ft = 1,numpft + + call set_root_fraction(sites(s)%rootfrac_scr, ft, sites(s)%zi_soil, & + bc_in(s)%max_rooting_depth_index_col ) + + cpatch%btran_ft(ft) = 0.0_r8 + do j = 1,bc_in(s)%nlevsoil + + ! Calculations are only relevant where liquid water exists + ! see clm_fates%wrap_btran for calculation with CLM/ALM + + if ( check_layer_water(bc_in(s)%h2o_liqvol_sl(j),bc_in(s)%tempk_sl(j)) ) then + + smp_node = max(smpsc(ft), bc_in(s)%smp_sl(j)) + + rresis = min( (bc_in(s)%eff_porosity_sl(j)/bc_in(s)%watsat_sl(j))* & + (smp_node - smpsc(ft)) / (smpso(ft) - smpsc(ft)), 1._r8) + + root_resis(ft,j) = sites(s)%rootfrac_scr(j)*rresis + + ! root water uptake is not linearly proportional to root density, + ! to allow proper deep root funciton. Replace with equations from SPA/Newman. FIX(RF,032414) + + cpatch%btran_ft(ft) = cpatch%btran_ft(ft) + root_resis(ft,j) + + else + root_resis(ft,j) = 0._r8 + end if + + end do !j + + ! Normalize root resistances to get layer contribution to ET + do j = 1,bc_in(s)%nlevsoil + if (cpatch%btran_ft(ft) > nearzero) then + root_resis(ft,j) = root_resis(ft,j)/cpatch%btran_ft(ft) + else + root_resis(ft,j) = 0._r8 + end if + end do + + end do !PFT + + ! PFT-averaged point level root fraction for extraction purposese. + ! The cohort's conductance g_sb_laweighted, contains a weighting factor + ! based on the cohort's leaf area. units: [m/s] * [m2] + + pftgs(1:maxpft) = 0._r8 + ccohort => cpatch%tallest + do while(associated(ccohort)) + pftgs(ccohort%pft) = pftgs(ccohort%pft) + ccohort%g_sb_laweight + ccohort => ccohort%shorter + enddo + + ! Process the boundary output, this is necessary for calculating the soil-moisture + ! sink term across the different layers in driver/host. Photosynthesis will + ! pass the host a total transpiration for the patch. This needs rootr to be + ! distributed over the soil layers. + sum_pftgs = sum(pftgs(1:numpft)) + + do j = 1, bc_in(s)%nlevsoil + bc_out(s)%rootr_pasl(ifp,j) = 0._r8 + do ft = 1,numpft + if( sum_pftgs > 0._r8)then !prevent problem with the first timestep - might fail + !bit-retart test as a result? FIX(RF,032414) + bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j) + & + root_resis(ft,j) * pftgs(ft)/sum_pftgs + else + bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j) + & + root_resis(ft,j) * 1._r8/real(numpft,r8) + end if + enddo + enddo + + ! Calculate the BTRAN that is passed back to the HLM + ! used only for diagnostics. If plant hydraulics is turned off + ! we are using the patchxpft level btran calculation + + if(hlm_use_planthydro.eq.ifalse) then + !weight patch level output BTRAN for the + bc_out(s)%btran_pa(ifp) = 0.0_r8 + do ft = 1,numpft + if( sum_pftgs > 0._r8)then !prevent problem with the first timestep - might fail + !bit-retart test as a result? FIX(RF,032414) + bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * pftgs(ft)/sum_pftgs + else + bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + cpatch%btran_ft(ft) * 1./numpft + end if + enddo + end if + + temprootr = sum(bc_out(s)%rootr_pasl(ifp,1:bc_in(s)%nlevsoil)) + + if(abs(1.0_r8-temprootr) > 1.0e-10_r8 .and. temprootr > 1.0e-10_r8)then + write(fates_log(),*) 'error with rootr in canopy fluxes',temprootr,sum_pftgs + do j = 1,bc_in(s)%nlevsoil + bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j)/temprootr + enddo + end if + endif ! not bare ground + cpatch => cpatch%younger + end do + + deallocate(root_resis) + + end do + + if(hlm_use_planthydro.eq.itrue) then + call BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) + end if + + end associate + +end subroutine btran_ed end module EDBtranMod diff --git a/biogeophys/EDSurfaceAlbedoMod.F90 b/biogeophys/EDSurfaceAlbedoMod.F90 index 4e5309ea61..7799ee4333 100644 --- a/biogeophys/EDSurfaceAlbedoMod.F90 +++ b/biogeophys/EDSurfaceAlbedoMod.F90 @@ -1,15 +1,15 @@ module EDSurfaceRadiationMod - - !------------------------------------------------------------------------------------- - ! EDSurfaceRadiation - ! - ! This module contains function and type definitions for all things related - ! to radiative transfer in ED modules at the land surface. - ! - !------------------------------------------------------------------------------------- + + !------------------------------------------------------------------------------------- + ! EDSurfaceRadiation + ! + ! This module contains function and type definitions for all things related + ! to radiative transfer in ED modules at the land surface. + ! + !------------------------------------------------------------------------------------- #include "shr_assert.h" - + use EDTypesMod , only : ed_patch_type, ed_site_type use EDTypesMod , only : maxPatchesPerSite use EDTypesMod , only : maxpft @@ -42,130 +42,150 @@ module EDSurfaceRadiationMod public :: ED_Norman_Radiation ! Surface albedo and two-stream fluxes public :: PatchNormanRadiation public :: ED_SunShadeFracs - + logical :: debug = .false. ! for debugging this module - - real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) - (/ 0.80_r8, 0.55_r8 /) + ! real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + ! (/ 0.80_r8, 0.55_r8 /) + + !parameters of canopy snow reflectance model. + ! the parameters in the 2-stream model are not directly analagous to those here + ! and so they are stored here for now in common with the ice parameters above. + ! in principle these could be moved to the parameter file. + + real(r8), public :: albice(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + (/ 0.80_r8, 0.55_r8 /) + real(r8), public :: rho_snow(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + (/ 0.80_r8, 0.55_r8 /) + real(r8), public :: tau_snow(maxSWb) = & ! albedo land ice by waveband (1=vis, 2=nir) + (/ 0.01_r8, 0.01_r8 /) contains - + subroutine ED_Norman_Radiation (nsites, sites, bc_in, bc_out ) - ! - - ! - ! !USES: - use EDPftvarcon , only : EDPftvarcon_inst - use EDtypesMod , only : ed_patch_type - use EDTypesMod , only : ed_site_type - - - ! !ARGUMENTS: - - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) ! FATES site vector - type(bc_in_type), intent(in) :: bc_in(nsites) - type(bc_out_type), intent(inout) :: bc_out(nsites) - - - ! !LOCAL VARIABLES: - integer :: s ! site loop counter - integer :: ifp ! patch loop counter - integer :: ib ! radiation broad band counter - type(ed_patch_type), pointer :: currentPatch ! patch pointer - - !----------------------------------------------------------------------- - ! ------------------------------------------------------------------------------- - ! TODO (mv, 2014-10-29) the filter here is different than below - ! this is needed to have the VOC's be bfb - this needs to be - ! re-examined int he future - ! RGK,2016-08-06: FATES is still incompatible with VOC emission module - ! ------------------------------------------------------------------------------- - - - do s = 1, nsites - - ifp = 0 - currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) - ifp = ifp+1 - - currentPatch%f_sun (:,:,:) = 0._r8 - currentPatch%fabd_sun_z (:,:,:) = 0._r8 - currentPatch%fabd_sha_z (:,:,:) = 0._r8 - currentPatch%fabi_sun_z (:,:,:) = 0._r8 - currentPatch%fabi_sha_z (:,:,:) = 0._r8 - currentPatch%fabd (:) = 0._r8 - currentPatch%fabi (:) = 0._r8 - - ! zero diagnostic radiation profiles - currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 - currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 - - currentPatch%solar_zenith_flag = bc_in(s)%filter_vegzen_pa(ifp) - currentPatch%solar_zenith_angle = bc_in(s)%coszen_pa(ifp) - currentPatch%gnd_alb_dif(1:hlm_numSWb) = bc_in(s)%albgr_dif_rb(1:hlm_numSWb) - currentPatch%gnd_alb_dir(1:hlm_numSWb) = bc_in(s)%albgr_dir_rb(1:hlm_numSWb) - - if(currentPatch%solar_zenith_flag )then - - bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%fabd_parb(ifp,:) = 0._r8 ! output HLM - bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM - bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM - bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM - - if (maxval(currentPatch%nrad(1,:))==0)then - !there are no leaf layers in this patch. it is effectively bare ground. - ! no radiation is absorbed - bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 - bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 - do ib = 1,hlm_numSWb - bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) - bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) - bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 - bc_out(s)%ftid_parb(ifp,ib)= 1.0_r8 - bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 - enddo - - else - - call PatchNormanRadiation (currentPatch, & - bc_out(s)%albd_parb(ifp,:), & - bc_out(s)%albi_parb(ifp,:), & - bc_out(s)%fabd_parb(ifp,:), & - bc_out(s)%fabi_parb(ifp,:), & - bc_out(s)%ftdd_parb(ifp,:), & - bc_out(s)%ftid_parb(ifp,:), & - bc_out(s)%ftii_parb(ifp,:)) - - - endif ! is there vegetation? - - end if ! if the vegetation and zenith filter is active - currentPatch => currentPatch%younger - end do ! Loop linked-list patches - enddo ! Loop Sites - - return - end subroutine ED_Norman_Radiation - - - ! ====================================================================================== + ! + + ! + ! !USES: + use EDPftvarcon , only : EDPftvarcon_inst + use EDtypesMod , only : ed_patch_type + use EDTypesMod , only : ed_site_type + + + ! !ARGUMENTS: + + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) ! FATES site vector + type(bc_in_type), intent(in) :: bc_in(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + + ! !LOCAL VARIABLES: + integer :: s ! site loop counter + integer :: ifp ! patch loop counter + integer :: ib ! radiation broad band counter + type(ed_patch_type), pointer :: currentPatch ! patch pointer + + !----------------------------------------------------------------------- + ! ------------------------------------------------------------------------------- + ! TODO (mv, 2014-10-29) the filter here is different than below + ! this is needed to have the VOC's be bfb - this needs to be + ! re-examined int he future + ! RGK,2016-08-06: FATES is still incompatible with VOC emission module + ! ------------------------------------------------------------------------------- + + + do s = 1, nsites + + ifp = 0 + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + if(currentpatch%nocomp_pft_label.ne.0)then + ! do not do albedo calculations for bare ground patch in SP mode + ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein + ! ifp=1 is the first vegetated patch. + ifp = ifp+1 + + currentPatch%f_sun (:,:,:) = 0._r8 + currentPatch%fabd_sun_z (:,:,:) = 0._r8 + currentPatch%fabd_sha_z (:,:,:) = 0._r8 + currentPatch%fabi_sun_z (:,:,:) = 0._r8 + currentPatch%fabi_sha_z (:,:,:) = 0._r8 + currentPatch%fabd (:) = 0._r8 + currentPatch%fabi (:) = 0._r8 + + ! zero diagnostic radiation profiles + currentPatch%nrmlzd_parprof_pft_dir_z(:,:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 + currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 + + currentPatch%solar_zenith_flag = bc_in(s)%filter_vegzen_pa(ifp) + currentPatch%solar_zenith_angle = bc_in(s)%coszen_pa(ifp) + currentPatch%gnd_alb_dif(1:hlm_numSWb) = bc_in(s)%albgr_dif_rb(1:hlm_numSWb) + currentPatch%gnd_alb_dir(1:hlm_numSWb) = bc_in(s)%albgr_dir_rb(1:hlm_numSWb) + currentPatch%fcansno = bc_in(s)%fcansno_pa(ifp) + + if(currentPatch%solar_zenith_flag )then + + bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%fabd_parb(ifp,:) = 0._r8 ! output HLM + bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM + bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM + + if (maxval(currentPatch%nrad(1,:))==0)then + !there are no leaf layers in this patch. it is effectively bare ground. + ! no radiation is absorbed + bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 + bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 + currentPatch%radiation_error = 0.0_r8 + + do ib = 1,hlm_numSWb + bc_out(s)%albd_parb(ifp,ib) = bc_in(s)%albgr_dir_rb(ib) + bc_out(s)%albi_parb(ifp,ib) = bc_in(s)%albgr_dif_rb(ib) + bc_out(s)%ftdd_parb(ifp,ib)= 1.0_r8 + !bc_out(s)%ftid_parb(ifp,ib)= 1.0_r8 + bc_out(s)%ftid_parb(ifp,ib)= 0.0_r8 + bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 + enddo + + else + + call PatchNormanRadiation (currentPatch, & + bc_out(s)%albd_parb(ifp,:), & + bc_out(s)%albi_parb(ifp,:), & + bc_out(s)%fabd_parb(ifp,:), & + bc_out(s)%fabi_parb(ifp,:), & + bc_out(s)%ftdd_parb(ifp,:), & + bc_out(s)%ftid_parb(ifp,:), & + bc_out(s)%ftii_parb(ifp,:)) + + + endif ! is there vegetation? + + end if ! if the vegetation and zenith filter is active + endif ! not bare ground + currentPatch => currentPatch%younger + end do ! Loop linked-list patches + enddo ! Loop Sites + + return + end subroutine ED_Norman_Radiation + + + ! ====================================================================================== subroutine PatchNormanRadiation (currentPatch, & - albd_parb_out, & ! (ifp,ib) - albi_parb_out, & ! (ifp,ib) - fabd_parb_out, & ! (ifp,ib) - fabi_parb_out, & ! (ifp,ib) - ftdd_parb_out, & ! (ifp,ib) - ftid_parb_out, & ! (ifp,ib) - ftii_parb_out) ! (ifp,ib) + albd_parb_out, & ! (ifp,ib) + albi_parb_out, & ! (ifp,ib) + fabd_parb_out, & ! (ifp,ib) + fabi_parb_out, & ! (ifp,ib) + ftdd_parb_out, & ! (ifp,ib) + ftid_parb_out, & ! (ifp,ib) + ftii_parb_out) ! (ifp,ib) ! ----------------------------------------------------------------------------------- ! @@ -181,7 +201,7 @@ subroutine PatchNormanRadiation (currentPatch, & ! ----------------------------------------------------------------------------------- ! !ARGUMENTS: ! ----------------------------------------------------------------------------------- - + type(ed_patch_type), intent(inout), target :: currentPatch real(r8), intent(inout) :: albd_parb_out(hlm_numSWb) real(r8), intent(inout) :: albi_parb_out(hlm_numSWb) @@ -215,7 +235,13 @@ subroutine PatchNormanRadiation (currentPatch, & real(r8) :: Dif_dn(nclmax,maxpft,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) real(r8) :: Dif_up(nclmax,maxpft,nlevleaf) ! Upward diffuse flux above canopy layer J (W/m**2 ground area) real(r8) :: lai_change(nclmax,maxpft,nlevleaf) ! Forward diffuse flux onto canopy layer J (W/m**2 ground area) - real(r8) :: f_not_abs(maxpft,maxSWb) ! Fraction reflected + transmitted. 1-absorbtion. + + real(r8) :: frac_lai ! Fraction of lai in each layer + real(r8) :: frac_sai ! Fraction of sai in each layer + real(r8) :: f_abs(nclmax,maxpft,nlevleaf,maxSWb) ! Fraction of light absorbed by surfaces. + real(r8) :: rho_layer(nclmax,maxpft,nlevleaf,maxSWb)! Weighted verage reflectance of layer + real(r8) :: tau_layer(nclmax,maxpft,nlevleaf,maxSWb)! Weighted average transmittance of layer + real(r8) :: f_abs_leaf(nclmax,maxpft,nlevleaf,maxSWb) real(r8) :: Abs_dir_z(maxpft,nlevleaf) real(r8) :: Abs_dif_z(maxpft,nlevleaf) real(r8) :: abs_rad(maxSWb) !radiation absorbed by soil @@ -225,988 +251,1040 @@ subroutine PatchNormanRadiation (currentPatch, & real(r8) :: phi2b(maxpft) real(r8) :: laisum ! cumulative lai+sai for canopy layer (at middle of layer) real(r8) :: angle - + real(r8),parameter :: tolerance = 0.000000001_r8 - - + + integer, parameter :: max_diag_nlevleaf = 4 integer, parameter :: diag_nlevleaf = min(nlevleaf,max_diag_nlevleaf) ! for diagnostics, write a small number of leaf layers - + real(r8) :: denom real(r8) :: lai_reduction(nclmax) - + integer :: fp,iv,s ! array indices integer :: ib ! waveband number real(r8) :: cosz ! 0.001 <= coszen <= 1.000 real(r8) :: chil real(r8) :: gdir - + real(r8), parameter :: forc_dir(n_rad_stream_types) = (/ 1.0_r8, 0.0_r8 /) ! These are binary switches used real(r8), parameter :: forc_dif(n_rad_stream_types) = (/ 0.0_r8, 1.0_r8 /) ! to turn off and on radiation streams - + associate(& rhol => EDPftvarcon_inst%rhol , & ! Input: [real(r8) (:) ] leaf reflectance: 1=vis, 2=nir rhos => EDPftvarcon_inst%rhos , & ! Input: [real(r8) (:) ] stem reflectance: 1=vis, 2=nir taul => EDPftvarcon_inst%taul , & ! Input: [real(r8) (:) ] leaf transmittance: 1=vis, 2=nir taus => EDPftvarcon_inst%taus , & ! Input: [real(r8) (:) ] stem transmittance: 1=vis, 2=nir xl => EDPftvarcon_inst%xl , & ! Input: [real(r8) (:) ] ecophys const - leaf/stem orientation index - clumping_index => EDPftvarcon_inst%clumping_index) + clumping_index => EDPftvarcon_inst%clumping_index) + ! Initialize local arrays - weighted_dir_tr(:) = 0._r8 - weighted_dif_down(:) = 0._r8 - weighted_dif_up(:) = 0._r8 - - tr_dir_z(:,:,:) = 0._r8 - tr_dif_z(:,:,:) = 0._r8 - lai_change(:,:,:) = 0._r8 - Dif_up(:,:,:) = 0._r8 - Dif_dn(:,:,:) = 0._r8 - refl_dif(:,:,:,:) = 0.0_r8 - tran_dif(:,:,:,:) = 0.0_r8 - dif_ratio(:,:,:,:) = 0.0_r8 - - - ! Initialize the ouput arrays - ! --------------------------------------------------------------------------------- - albd_parb_out(1:hlm_numSWb) = 0.0_r8 - albi_parb_out(1:hlm_numSWb) = 0.0_r8 - fabd_parb_out(1:hlm_numSWb) = 0.0_r8 - fabi_parb_out(1:hlm_numSWb) = 0.0_r8 - ftdd_parb_out(1:hlm_numSWb) = 1.0_r8 - ftid_parb_out(1:hlm_numSWb) = 1.0_r8 - ftii_parb_out(1:hlm_numSWb) = 1.0_r8 - - ! Is this pft/canopy layer combination present in this patch? - - do L = 1,nclmax - do ft = 1,numpft - currentPatch%canopy_mask(L,ft) = 0 - do iv = 1, currentPatch%nrad(L,ft) - if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then - currentPatch%canopy_mask(L,ft) = 1 - !I think 'present' is only used here... - endif - end do !iv - end do !ft - end do !L - - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Direct beam extinction coefficient, k_dir. PFT specific. - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - cosz = max(0.001_r8, currentPatch%solar_zenith_angle ) !copied from previous radiation code... - do ft = 1,numpft - sb = (90._r8 - (acos(cosz)*180._r8/pi_const)) * (pi_const / 180._r8) - chil = xl(ft) !min(max(xl(ft), -0.4_r8), 0.6_r8 ) - if ( abs(chil) <= 0.01_r8) then - chil = 0.01_r8 - end if - phi1b(ft) = 0.5_r8 - 0.633_r8*chil - 0.330_r8*chil*chil - phi2b(ft) = 0.877_r8 * (1._r8 - 2._r8*phi1b(ft)) !0 = horiz leaves, 1 - vert leaves. - gdir = phi1b(ft) + phi2b(ft) * sin(sb) - !how much direct light penetrates a singleunit of lai? - k_dir(ft) = clumping_index(ft) * gdir / sin(sb) - end do !FT - - - - - !do this once for one unit of diffuse, and once for one unit of direct radiation - do radtype = 1, n_rad_stream_types - - ! Extract information that needs to be provided by ED into local array. - ! RGK: NOT SURE WHY WE NEED FTWEIGHT ... - ! ------------------------------------------------------------------------------ - - ftweight(:,:,:) = 0._r8 - do L = 1,currentPatch%NCL_p - do ft = 1,numpft - do iv = 1, currentPatch%nrad(L,ft) - !this is already corrected for area in CLAP - ftweight(L,ft,iv) = currentPatch%canopy_area_profile(L,ft,iv) - end do !iv - end do !ft1 - end do !L - if (sum(ftweight(1,:,1))<0.999_r8)then - write(fates_log(),*) 'canopy not full',ftweight(1,:,1) - endif - if (sum(ftweight(1,:,1))>1.0001_r8)then - write(fates_log(),*) 'canopy too full',ftweight(1,:,1) - endif - - do L = 1,currentPatch%NCL_p !start at the top canopy layer (1 is the top layer.) - - weighted_dir_tr(L) = 0.0_r8 - weighted_fsun(L) = 0._r8 - weighted_dif_ratio(L,1:hlm_numSWb) = 0._r8 - - !Each canopy layer (canopy, understorey) has multiple 'parallel' pft's - - do ft =1,numpft - - if (currentPatch%canopy_mask(L,ft) == 1)then !only do calculation if there are the appropriate leaves. - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Diffuse transmittance, tr_dif, do each layer with thickness elai_z. - ! Estimated do nine sky angles in increments of 10 degrees - ! PFT specific... - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - tr_dif_z(L,ft,:) = 0._r8 - do iv = 1,currentPatch%nrad(L,ft) - do j = 1,9 - angle = (5._r8 + real(j - 1,r8) * 10._r8) * pi_const / 180._r8 - gdir = phi1b(ft) + phi2b(ft) * sin(angle) - tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-clumping_index(ft) * & - gdir / sin(angle) * & - (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))) * & - sin(angle)*cos(angle) - end do - - tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) * 2._r8 * (10._r8 * pi_const / 180._r8) - - end do - - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Direct beam transmittance, tr_dir_z, uses cumulative LAI above layer J to give - ! unscattered direct beam onto layer J. do each PFT section. - ! This is just an decay curve based on k_dir. (leaf & sun angle) - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - if (L==1)then - tr_dir_z(L,ft,1) = 1._r8 - else - tr_dir_z(L,ft,1) = weighted_dir_tr(L-1) - endif - laisum = 0.00_r8 - !total direct beam getting to the bottom of the top canopy. - do iv = 1,currentPatch%nrad(L,ft) - laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) - lai_change(L,ft,iv) = 0.0_r8 - if (( ftweight(L,ft,iv+1) > 0.0_r8 ) .and. ( ftweight(L,ft,iv+1) < ftweight(L,ft,iv) ))then - !where there is a partly empty leaf layer, some fluxes go straight through. - lai_change(L,ft,iv) = ftweight(L,ft,iv)-ftweight(L,ft,iv+1) - endif - if (ftweight(L,ft,iv+1) - ftweight(L,ft,iv) > 1.e-10_r8)then - write(fates_log(),*) 'lower layer has more coverage. This is wrong' , & - ftweight(L,ft,iv),ftweight(L,ft,iv+1),ftweight(L,ft,iv+1)-ftweight(L,ft,iv) - endif - - !n.b. in theory lai_change could be calculated daily in the ED code. - !This is light coming striaght through the canopy. - if (L==1)then - tr_dir_z(L,ft,iv+1) = exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - else - tr_dir_z(L,ft,iv+1) = weighted_dir_tr(L-1)*exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - endif - - if (iv == 1)then - !this is the top layer. - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & - ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) - else - !the lai_change(iv) affects the light incident on layer iv+2 not iv+1 - ! light coming from the layer above (iv-1) goes through iv and onto iv+1. - if (lai_change(L,ft,iv-1) > 0.0_r8)then - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv)* & - lai_change(L,ft,iv-1) / ftweight(L,ft,1) - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv-1)* & - (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) - else - !account fot the light that comes striaght down from unfilled layers above. - tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & - ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) - endif - endif - - end do - - !add up all the weighted contributions from the different PFT columns. - weighted_dir_tr(L) = weighted_dir_tr(L) + tr_dir_z(L,ft,currentPatch%nrad(L,ft)+1)*ftweight(L,ft,1) - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Sunlit and shaded fraction of leaf layer - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - - !laisum = 0._r8 - do iv = 1,currentPatch%nrad(L,ft) - ! Cumulative leaf area. Original code uses cumulative lai do layer. - ! Now use cumulative lai at center of layer. - ! Same as tr_dir_z calcualtions, but in the middle of the layer? FIX(RF,032414)-WHY? - if (iv == 1) then - laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) - else - laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) - end if - - - if (L == 1)then !top canopy layer - currentPatch%f_sun(L,ft,iv) = exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - else - currentPatch%f_sun(L,ft,iv) = weighted_fsun(L-1)* exp(-k_dir(ft) * laisum)* & - (ftweight(L,ft,iv)/ftweight(L,ft,1)) - endif - - if ( iv > 1 ) then ! becasue we are looking at this layer (not the next) - ! we only ever add fluxes if iv>1 - if (lai_change(L,ft,iv-1) > 0.0_r8)then - currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & - currentPatch%f_sun(L,ft,iv) * & - lai_change(L,ft,iv-1)/ftweight(L,ft,1) - currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & - currentPatch%f_sun(L,ft,iv-1) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) - else - currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & - currentPatch%f_sun(L,ft,iv-1) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - endif - endif - - end do !iv - - weighted_fsun(L) = weighted_fsun(L) + currentPatch%f_sun(L,ft,currentPatch%nrad(L,ft))* & - ftweight(L,ft,1) - - ! instance where the first layer ftweight is used a proxy for the whole column. FTWA - ! this is possibly a source of slight error. If we use the ftweight at the top of the PFT column, - ! then we willl underestimate fsun, but if we use ftweight at the bottom of the column, we will - ! underestimate it. Really, we should be tracking the release of direct light from the column as it tapers - ! towards the ground. Is that necessary to get energy closure? It would be quite hard... - endif !present. - end do!pft loop - end do !L - - - do L = currentPatch%NCL_p,1, -1 !start at the bottom and work up. - do ft = 1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - - !==============================================================================! - ! Iterative solution do scattering - !==============================================================================! - - do ib = 1,hlm_numSWb !vis, nir - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Leaf scattering coefficient and terms do diffuse radiation reflected - ! and transmitted by a layer - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - f_not_abs(ft,ib) = rhol(ft,ib) + taul(ft,ib) !leaf level fraction NOT absorbed. - !tr_dif_z is a term that uses the LAI in each layer, whereas rhol and taul do not, - !because they are properties of leaf surfaces and not of the leaf matrix. - do iv = 1,currentPatch%nrad(L,ft) - !How much diffuse light is intercepted and then reflected? - refl_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * rhol(ft,ib) - !How much diffuse light in this layer is transmitted? - tran_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * & - taul(ft,ib) + tr_dif_z(L,ft,iv) - end do - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Ratio of upward to forward diffuse fluxes, dif_ratio - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! Soil diffuse reflectance (ratio of down to up radiation). - iv = currentPatch%nrad(L,ft) + 1 - if (L == currentPatch%NCL_p)then !nearest the soil - dif_ratio(L,ft,iv,ib) = currentPatch%gnd_alb_dif(ib) !bc_in(s)%albgr_dif_rb(ib) - else - dif_ratio(L,ft,iv,ib) = weighted_dif_ratio(L+1,ib) - end if - ! Canopy layers, working upwardfrom soil with dif_ratio(iv+1) known - ! FIX(RF,032414) ray tracing eqution - need to find derivation of this... - ! for each unit going down, there are x units going up. - do iv = currentPatch%nrad(L,ft),1, -1 - dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv+1,ib) * & - tran_dif(L,ft,iv,ib)*tran_dif(L,ft,iv,ib) / & - (1._r8 - dif_ratio(L,ft,iv+1,ib) * refl_dif(L,ft,iv,ib)) & - + refl_dif(L,ft,iv,ib) - dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) * & - ftweight(L,ft,iv)/ftweight(L,ft,1) - dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) + dif_ratio(L,ft,iv+1,ib) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - end do - weighted_dif_ratio(L,ib) = weighted_dif_ratio(L,ib) + & - dif_ratio(L,ft,1,ib) * ftweight(L,ft,1) - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - end do!hlm_numSWb - endif ! currentPatch%canopy_mask - end do!ft - end do!L - - - do ib = 1,hlm_numSWb - Dif_dn(:,:,:) = 0.00_r8 - Dif_up(:,:,:) = 0.00_r8 - do L = 1, currentPatch%NCL_p !work down from the top of the canopy. - weighted_dif_down(L) = 0._r8 - do ft = 1, numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! First estimates do downward and upward diffuse flux - ! - ! Dif_dn = forward diffuse flux onto layer J - ! Dif_up = Upward diffuse flux above layer J - ! - ! Solved here without direct beam radiation and using dif_ratio = Dif_up / Dif_dn - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! downward diffuse flux onto the top surface of the canopy - - if (L == 1)then - Dif_dn(L,ft,1) = forc_dif(radtype) - else - Dif_dn(L,ft,1) = weighted_dif_down(L-1) - end if - ! forward diffuse flux within the canopy and at soil, working forward through canopy - do iv = 1,currentPatch%nrad(L,ft) - denom = refl_dif(L,ft,iv,ib) * dif_ratio(L,ft,iv,ib) - denom = 1._r8 - denom - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) / & - denom *ftweight(L,ft,iv)/ftweight(L,ft,1) - if (iv > 1)then - if (lai_change(L,ft,iv-1) > 0.0_r8)then - !here we are thinking about whether the layer above had an laichange, - !but calculating the flux onto the layer below. - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv)* & - lai_change(L,ft,iv-1)/ftweight(L,ft,1) - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv-1)* & - (ftweight(L,ft,1)-ftweight(L,ft,iv-1)/ftweight(L,ft,1)) - else - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - endif - else - Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - endif - end do - - weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & - ftweight(L,ft,1) - - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - endif !present - end do !ft - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is the the (incomplete) understorey? - !Add on the radiation going through the canopy gaps. - weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1)*(1.0-sum(ftweight(L,:,1))) - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - endif - end do !L - - do L = currentPatch%NCL_p,1 ,-1 !work up from the bottom. - weighted_dif_up(L) = 0._r8 - do ft = 1, numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - !Bounce diffuse radiation off soil surface. - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%NCL_p)then !is this the bottom layer ? - Dif_up(L,ft,iv) = currentPatch%gnd_alb_dif(ib) * Dif_dn(L,ft,iv) - else - Dif_up(L,ft,iv) = weighted_dif_up(L+1) - end if - ! Upward diffuse flux within the canopy and above the canopy, working upward through canopy - - do iv = currentPatch%nrad(L,ft), 1, -1 - if (lai_change(L,ft,iv) > 0.0_r8)then - Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * & - ftweight(L,ft,iv) / ftweight(L,ft,1) - Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & - tran_dif(L,ft,iv,ib) * lai_change(L,ft,iv)/ftweight(L,ft,1) - Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & - (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - !nb is this the right constuction? - ! the radiation that hits the empty space is not reflected. - else - Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * ftweight(L,ft,iv) - Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * (1.0_r8-ftweight(L,ft,iv)) - endif - end do - - weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) - !instance where the first layer ftweight is used a proxy for the whole column. FTWA - endif !present - end do !ft - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? - !Add on the radiation coming up through the canopy gaps. - !diffuse to diffuse - weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & - weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) - !direct to diffuse - weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & - weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) * currentPatch%gnd_alb_dir(ib) - endif - end do !L - - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - ! 3. Iterative calculation of forward and upward diffuse fluxes, iNCL_puding - ! scattered direct beam - !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! - - ! Flag to exit iteration loop: 0 = exit and 1 = iterate - irep = 1 - ! Iteration loop - iter = 0 - do while(irep ==1 .and. iter<50) - - iter = iter + 1 - irep = 0 - do L = 1,currentPatch%NCL_p !working from the top down - weighted_dif_down(L) = 0._r8 - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - ! forward diffuse flux within the canopy and at soil, working forward through canopy - ! with Dif_up -from previous iteration-. Dif_dn(1) is the forward diffuse flux onto the canopy. - ! Note: down = forward flux onto next layer - if (L == 1)then !is this the top layer? - Dif_dn(L,ft,1) = forc_dif(radtype) - else - Dif_dn(L,ft,1) = weighted_dif_down(L-1) - end if - down_rad = 0._r8 - - do iv = 1, currentPatch%nrad(L,ft) - - down_rad = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) + & - Dif_up(L,ft,iv+1) * refl_dif(L,ft,iv,ib) + & - forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - & - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & - currentPatch%esai_profile(L,ft,iv)))) * taul(ft,ib) - down_rad = down_rad *(ftweight(L,ft,iv)/ftweight(L,ft,1)) - - if (iv > 1)then - if (lai_change(L,ft,iv-1) > 0.0_r8)then - down_rad = down_rad + Dif_dn(L,ft,iv) * lai_change(L,ft,iv-1)/ftweight(L,ft,1) - down_rad = down_rad + Dif_dn(L,ft,iv-1) * (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ & - ftweight(L,ft,1) - else - down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & - ftweight(L,ft,1) - endif - else - down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & - ftweight(L,ft,1) - endif - - !this is just Dif down, plus refl up, plus dir intercepted and turned into dif... , - if (abs(down_rad - Dif_dn(L,ft,iv+1)) > tolerance)then - irep = 1 - end if - Dif_dn(L,ft,iv+1) = down_rad - - end do !iv - - weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & - ftweight(L,ft,1) - - endif !present - end do!ft - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? - weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1) * & - (1.0_r8-sum(ftweight(L,1:numpft,1))) - end if - end do ! do L loop - - do L = 1, currentPatch%NCL_p ! working from the top down. - weighted_dif_up(L) = 0._r8 - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - ! Upward diffuse flux at soil or from lower canopy (forward diffuse and unscattered direct beam) - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%NCL_p)then !In the bottom canopy layer, reflect off the soil - Dif_up(L,ft,iv) = Dif_dn(L,ft,iv) * currentPatch%gnd_alb_dif(ib) + & - forc_dir(radtype) * tr_dir_z(L,ft,iv) * currentPatch%gnd_alb_dir(ib) - else !In the other canopy layers, reflect off the underlying vegetation. - Dif_up(L,ft,iv) = weighted_dif_up(L+1) - end if - - ! Upward diffuse flux within and above the canopy, working upward through canopy - ! with Dif_dn from previous interation. Note: up = upward flux above current layer - do iv = currentPatch%nrad(L,ft),1,-1 - !this is radiation up, by layer transmittance, by - - !reflection of the lower layer, - up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) - up_rad = up_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - exp(-k_dir(ft) * & - (currentPatch%elai_profile(L,ft,iv) + currentPatch%esai_profile(L,ft,iv)))) * & - rhol(ft,ib) - up_rad = up_rad + Dif_up(L,ft,iv+1) * tran_dif(L,ft,iv,ib) - up_rad = up_rad * ftweight(L,ft,iv)/ftweight(L,ft,1) - up_rad = up_rad + Dif_up(L,ft,iv+1) *(ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) - ! THE LOWER LAYER FLUX IS HOMOGENIZED, SO WE DON"T CONSIDER THE LAI_CHANGE HERE... - - if (abs(up_rad - Dif_up(L,ft,iv)) > tolerance) then !are we close to the tolerance level? - irep = 1 - end if - Dif_up(L,ft,iv) = up_rad - - end do !iv - weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) - end if !present - end do!ft - - if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? - !Add on the radiation coming up through the canopy gaps. - weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & - weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) - weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & - weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1)))*currentPatch%gnd_alb_dir(ib) - end if - end do!L - end do ! do while over iter - - abs_rad(ib) = 0._r8 - tr_soili = 0._r8 - tr_soild = 0._r8 - - do L = 1, currentPatch%NCL_p !working from the top down. - abs_dir_z(:,:) = 0._r8 - abs_dif_z(:,:) = 0._r8 - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - !==============================================================================! - ! Compute absorbed flux densities - !==============================================================================! - - ! Absorbed direct beam and diffuse do leaf layers - do iv = 1, currentPatch%nrad(L,ft) - Abs_dir_z(ft,iv) = ftweight(L,ft,iv)* forc_dir(radtype) * tr_dir_z(L,ft,iv) * & - (1.00_r8 - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & - currentPatch%esai_profile(L,ft,iv)))) * (1.00_r8 - f_not_abs(ft,ib)) - Abs_dif_z(ft,iv) = ftweight(L,ft,iv)* ((Dif_dn(L,ft,iv) + & - Dif_up(L,ft,iv+1)) * (1.00_r8 - tr_dif_z(L,ft,iv)) * & - (1.00_r8 - f_not_abs(ft,ib))) - end do - - ! Absorbed direct beam and diffuse do soil - if (L == currentPatch%NCL_p)then - iv = currentPatch%nrad(L,ft) + 1 - Abs_dif_z(ft,iv) = ftweight(L,ft,1)*Dif_dn(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dif(ib) ) - Abs_dir_z(ft,iv) = ftweight(L,ft,1)*forc_dir(radtype) * & - tr_dir_z(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dir(ib) ) - tr_soild = tr_soild + ftweight(L,ft,1)*forc_dir(radtype) * tr_dir_z(L,ft,iv) - tr_soili = tr_soili + ftweight(L,ft,1)*Dif_dn(L,ft,iv) - end if - - ! Absorbed radiation, shaded and sunlit portions of leaf layers - !here we get one unit of diffuse radiation... how much of - !it is absorbed? - if (ib == ivis) then ! only set the absorbed PAR for the visible light band. - do iv = 1, currentPatch%nrad(L,ft) - if (radtype==idirect) then - if ( debug ) then - write(fates_log(),*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) - write(fates_log(),*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & - currentPatch%fabd_sun_z(L,ft,iv) - endif - currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - (1._r8 - currentPatch%f_sun(L,ft,iv)) - currentPatch%fabd_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - currentPatch%f_sun(L,ft,iv) + & - Abs_dir_z(ft,iv) - else - currentPatch%fabi_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - (1._r8 - currentPatch%f_sun(L,ft,iv)) - currentPatch%fabi_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & - currentPatch%f_sun(L,ft,iv) - endif - if ( debug ) then - write(fates_log(),*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & - currentPatch%fabd_sun_z(L,ft,iv) - endif - end do - endif ! ib - - - !==============================================================================! - ! Sum fluxes - !==============================================================================! - ! Solar radiation absorbed by ground - iv = currentPatch%nrad(L,ft) + 1 - if (L==currentPatch%NCL_p)then - abs_rad(ib) = abs_rad(ib) + (Abs_dir_z(ft,iv) + Abs_dif_z(ft,iv)) - end if - ! Solar radiation absorbed by vegetation and sunlit/shaded leaves - do iv = 1,currentPatch%nrad(L,ft) - if (radtype == idirect)then - currentPatch%fabd(ib) = currentPatch%fabd(ib) + & - Abs_dir_z(ft,iv)+Abs_dif_z(ft,iv) - ! bc_out(s)%fabd_parb_out(ib) = currentPatch%fabd(ib) - else - currentPatch%fabi(ib) = currentPatch%fabi(ib) + Abs_dif_z(ft,iv) - ! bc_out(s)%fabi_parb_out(ib) = currentPatch%fabi(ib) - endif - end do - - ! Albefor - if (L==1)then !top canopy layer. - if (radtype == idirect)then - albd_parb_out(ib) = albd_parb_out(ib) + & - Dif_up(L,ft,1) * ftweight(L,ft,1) - else - albi_parb_out(ib) = albi_parb_out(ib) + & - Dif_up(L,ft,1) * ftweight(L,ft,1) - end if - end if - - ! pass normalized PAR profiles for use in diagnostic averaging for history fields - if (ib == ivis) then ! only diagnose PAR profiles for the visible band - do iv = 1, currentPatch%nrad(L,ft) - currentPatch%nrmlzd_parprof_pft_dir_z(radtype,L,ft,iv) = & - forc_dir(radtype) * tr_dir_z(L,ft,iv) - currentPatch%nrmlzd_parprof_pft_dif_z(radtype,L,ft,iv) = & - Dif_dn(L,ft,iv) + Dif_up(L,ft,iv) - ! - currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) = & - currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) + & - (forc_dir(radtype) * tr_dir_z(L,ft,iv)) * & - (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) - currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) = & - currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) + & - (Dif_dn(L,ft,iv) + Dif_up(L,ft,iv)) * & - (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) - end do - end if ! ib = visible - end if ! present - end do !ft - if (radtype == idirect)then - fabd_parb_out(ib) = currentPatch%fabd(ib) - else - fabi_parb_out(ib) = currentPatch%fabi(ib) - endif - - - !radiation absorbed from fluxes through unfilled part of lower canopy. - if (currentPatch%NCL_p > 1.and.L == currentPatch%NCL_p)then - abs_rad(ib) = abs_rad(ib) + weighted_dif_down(L-1) * & - (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dif(ib) ) - abs_rad(ib) = abs_rad(ib) + forc_dir(radtype) * weighted_dir_tr(L-1) * & - (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dir(ib) ) - tr_soili = tr_soili + weighted_dif_down(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) - tr_soild = tr_soild + forc_dir(radtype) * weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) - endif - - if (radtype == idirect)then - currentPatch%tr_soil_dir(ib) = tr_soild - currentPatch%tr_soil_dir_dif(ib) = tr_soili - currentPatch%sabs_dir(ib) = abs_rad(ib) - ftdd_parb_out(ib) = tr_soild - ftid_parb_out(ib) = tr_soili + weighted_dir_tr(:) = 0._r8 + weighted_dif_down(:) = 0._r8 + weighted_dif_up(:) = 0._r8 + + tr_dir_z(:,:,:) = 0._r8 + tr_dif_z(:,:,:) = 0._r8 + lai_change(:,:,:) = 0._r8 + Dif_up(:,:,:) = 0._r8 + Dif_dn(:,:,:) = 0._r8 + refl_dif(:,:,:,:) = 0.0_r8 + tran_dif(:,:,:,:) = 0.0_r8 + dif_ratio(:,:,:,:) = 0.0_r8 + + + ! Initialize the ouput arrays + ! --------------------------------------------------------------------------------- + albd_parb_out(1:hlm_numSWb) = 0.0_r8 + albi_parb_out(1:hlm_numSWb) = 0.0_r8 + fabd_parb_out(1:hlm_numSWb) = 0.0_r8 + fabi_parb_out(1:hlm_numSWb) = 0.0_r8 + ftdd_parb_out(1:hlm_numSWb) = 1.0_r8 + ftid_parb_out(1:hlm_numSWb) = 1.0_r8 + ftii_parb_out(1:hlm_numSWb) = 1.0_r8 + + ! Is this pft/canopy layer combination present in this patch? + rho_layer(:,:,:,:)=0.0_r8 + tau_layer(:,:,:,:)=0.0_r8 + f_abs(:,:,:,:)=0.0_r8 + f_abs_leaf(:,:,:,:)=0._r8 + do L = 1,nclmax + do ft = 1,numpft + currentPatch%canopy_mask(L,ft) = 0 + do iv = 1, currentPatch%nrad(L,ft) + if (currentPatch%canopy_area_profile(L,ft,iv) > 0._r8)then + currentPatch%canopy_mask(L,ft) = 1 + + if(currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv).gt.0.0_r8) then + frac_lai = currentPatch%elai_profile(L,ft,iv)/& + (currentPatch%elai_profile(L,ft,iv)+ currentPatch%esai_profile(L,ft,iv)) else - currentPatch%tr_soil_dif(ib) = tr_soili - currentPatch%sabs_dif(ib) = abs_rad(ib) - ftii_parb_out(ib) = tr_soili - end if - - end do!l - - - !==============================================================================! - ! Conservation check - !==============================================================================! - ! Total radiation balance: absorbed = incoming - outgoing - - if (radtype == idirect)then - error = abs(currentPatch%sabs_dir(ib) - (currentPatch%tr_soil_dir(ib) * & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + & - currentPatch%tr_soil_dir_dif(ib) * (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) - if ( abs(error) > 0.0001)then - write(fates_log(),*)'dir ground absorption error',error,currentPatch%sabs_dir(ib), & - currentPatch%tr_soil_dir(ib)* & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) - write(fates_log(),*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & - (1.0_r8-currentPatch%gnd_alb_dir(ib) ) - - do ft =1,3 - iv = currentPatch%nrad(1,ft) + 1 - write(fates_log(),*) 'abs soil fluxes', Abs_dir_z(ft,iv),Abs_dif_z(ft,iv) - end do - - end if - else - if ( abs(currentPatch%sabs_dif(ib)-(currentPatch%tr_soil_dif(ib) * & - (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) > 0.0001_r8)then - write(fates_log(),*)'dif ground absorption error',currentPatch%sabs_dif(ib) , & - (currentPatch%tr_soil_dif(ib)* & - (1.0_r8-currentPatch%gnd_alb_dif(ib) )),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) + frac_lai = 1.0_r8 endif - endif - - if (radtype == idirect)then - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) - else - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) - endif - lai_reduction(:) = 0.0_r8 - do L = 1, currentPatch%NCL_p - do ft =1,numpft - if (currentPatch%canopy_mask(L,ft) == 1)then - do iv = 1, currentPatch%nrad(L,ft) - if (lai_change(L,ft,iv) > 0.0_r8)then - lai_reduction(L) = max(lai_reduction(L),lai_change(L,ft,iv)) - endif - enddo - endif - enddo - enddo - - if (radtype == idirect)then - !here we are adding a within-ED radiation scheme tolerance, and then adding the diffrence onto the albedo - !it is important that the lower boundary for this is ~1000 times smaller than the tolerance in surface albedo. - if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then - albd_parb_out(ib) = albd_parb_out(ib) + error - !this terms adds the error back on to the albedo. While this is partly inexcusable, it is - ! in the medium term a solution that - ! prevents the model from crashing with small and occasional energy balances issues. - ! These are extremely difficult to debug, many have been solved already, leading - ! to the complexity of this code, but where the system generates occasional errors, we - ! will deal with them for now. - end if - if (abs(error) > 0.15_r8)then - write(fates_log(),*) 'Large Dir Radn consvn error',error ,ib - write(fates_log(),*) 'diags', albd_parb_out(ib), ftdd_parb_out(ib), & - ftid_parb_out(ib), fabd_parb_out(ib) - write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno - write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) - - albd_parb_out(ib) = albd_parb_out(ib) + error - end if - else - - if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then - albi_parb_out(ib) = albi_parb_out(ib) + error - end if - - if (abs(error) > 0.15_r8)then - write(fates_log(),*) '>5% Dif Radn consvn error',error ,ib - write(fates_log(),*) 'diags', albi_parb_out(ib), ftii_parb_out(ib), & - fabi_parb_out(ib) - write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) - write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno - write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) - write(fates_log(),*) 'rhol',rhol(1:numpft,:) - write(fates_log(),*) 'ftw',sum(ftweight(1,1:numpft,1)),ftweight(1,1:numpft,1) - write(fates_log(),*) 'present',currentPatch%canopy_mask(1,1:numpft) - write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:numpft,1) - - albi_parb_out(ib) = albi_parb_out(ib) + error - end if - - if (radtype == idirect)then - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) - else - error = (forc_dir(radtype) + forc_dif(radtype)) - & - (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) - endif - - if (abs(error) > 0.00000001_r8)then - write(fates_log(),*) 'there is still error after correction',error ,ib - end if - - end if - - end do !hlm_numSWb - - enddo ! rad-type - - - end associate - return - end subroutine PatchNormanRadiation - - ! ====================================================================================== - - subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) - - implicit none - - ! Arguments - integer,intent(in) :: nsites - type(ed_site_type),intent(inout),target :: sites(nsites) - type(bc_in_type),intent(in) :: bc_in(nsites) - type(bc_out_type),intent(inout) :: bc_out(nsites) - - - ! locals - type (ed_patch_type),pointer :: cpatch ! c"urrent" patch - real(r8) :: sunlai - real(r8) :: shalai - real(r8) :: elai - integer :: CL - integer :: FT - integer :: iv - integer :: s - integer :: ifp - - - do s = 1,nsites + !frac_lai = 1.0_r8 ! make the same as previous codebase, in theory. + frac_sai = 1.0_r8 - frac_lai + + ! layer level reflectance qualities + do ib = 1,hlm_numSWb !vis, nir + + rho_layer(L,ft,iv,ib)=frac_lai*rhol(ft,ib)+frac_sai*rhos(ft,ib) + tau_layer(L,ft,iv,ib)=frac_lai*taul(ft,ib)+frac_sai*taus(ft,ib) + + ! adjust reflectance and transmittance for canopy snow + rho_layer(L,ft,iv,ib)=rho_layer(L,ft,iv,ib)*(1.0_r8- currentPatch%fcansno) & + + rho_snow(ib) * currentPatch%fcansno + tau_layer(L,ft,iv,ib)=tau_layer(L,ft,iv,ib)*(1.0_r8- currentPatch%fcansno) & + + tau_snow(ib) * currentPatch%fcansno + + ! fraction of incoming light absorbed by leaves or stems. + f_abs(L,ft,iv,ib) = 1.0_r8 - tau_layer(L,ft,iv,ib) - rho_layer(L,ft,iv,ib) + + ! the fraction of the vegetation absorbed light which is absorbed by leaves + f_abs_leaf(L,ft,iv,ib) = (1.0_r8- currentPatch%fcansno) * frac_lai* & + (1.0_r8 - rhol(ft,ib) - taul(ft,ib))/f_abs(L,ft,iv,ib) + + end do !ib + endif + end do !iv + end do !ft + end do !L + + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Direct beam extinction coefficient, k_dir. PFT specific. + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + cosz = max(0.001_r8, currentPatch%solar_zenith_angle ) !copied from previous radiation code... + do ft = 1,numpft + sb = (90._r8 - (acos(cosz)*180._r8/pi_const)) * (pi_const / 180._r8) + chil = xl(ft) !min(max(xl(ft), -0.4_r8), 0.6_r8 ) + if ( abs(chil) <= 0.01_r8) then + chil = 0.01_r8 + end if + phi1b(ft) = 0.5_r8 - 0.633_r8*chil - 0.330_r8*chil*chil + phi2b(ft) = 0.877_r8 * (1._r8 - 2._r8*phi1b(ft)) !0 = horiz leaves, 1 - vert leaves. + gdir = phi1b(ft) + phi2b(ft) * sin(sb) + !how much direct light penetrates a singleunit of lai? + k_dir(ft) = clumping_index(ft) * gdir / sin(sb) + end do !FT + + + + + !do this once for one unit of diffuse, and once for one unit of direct radiation + do radtype = 1, n_rad_stream_types + + ! Extract information that needs to be provided by ED into local array. + ! RGK: NOT SURE WHY WE NEED FTWEIGHT ... + ! ------------------------------------------------------------------------------ + + ftweight(:,:,:) = 0._r8 + do L = 1,currentPatch%NCL_p + do ft = 1,numpft + do iv = 1, currentPatch%nrad(L,ft) + !this is already corrected for area in CLAP + ftweight(L,ft,iv) = currentPatch%canopy_area_profile(L,ft,iv) + end do !iv + end do !ft1 + end do !L + if (sum(ftweight(1,:,1))<0.999_r8)then + write(fates_log(),*) 'canopy not full',ftweight(1,:,1) + endif + if (sum(ftweight(1,:,1))>1.0001_r8)then + write(fates_log(),*) 'canopy too full',ftweight(1,:,1) + endif + + do L = 1,currentPatch%NCL_p !start at the top canopy layer (1 is the top layer.) + + weighted_dir_tr(L) = 0.0_r8 + weighted_fsun(L) = 0._r8 + weighted_dif_ratio(L,1:hlm_numSWb) = 0._r8 + + !Each canopy layer (canopy, understorey) has multiple 'parallel' pft's + + do ft =1,numpft + + if (currentPatch%canopy_mask(L,ft) == 1)then !only do calculation if there are the appropriate leaves. + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Diffuse transmittance, tr_dif, do each layer with thickness elai_z. + ! Estimated do nine sky angles in increments of 10 degrees + ! PFT specific... + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + tr_dif_z(L,ft,:) = 0._r8 + do iv = 1,currentPatch%nrad(L,ft) + do j = 1,9 + angle = (5._r8 + real(j - 1,r8) * 10._r8) * pi_const / 180._r8 + gdir = phi1b(ft) + phi2b(ft) * sin(angle) + tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) + exp(-clumping_index(ft) * & + gdir / sin(angle) * & + (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))) * & + sin(angle)*cos(angle) + end do + + tr_dif_z(L,ft,iv) = tr_dif_z(L,ft,iv) * 2._r8 * (10._r8 * pi_const / 180._r8) - 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 - - ! zero out various datas - cpatch%ed_parsun_z(:,:,:) = 0._r8 - cpatch%ed_parsha_z(:,:,:) = 0._r8 - cpatch%ed_laisun_z(:,:,:) = 0._r8 - cpatch%ed_laisha_z(:,:,:) = 0._r8 - - bc_out(s)%fsun_pa(ifp) = 0._r8 - - sunlai = 0._r8 - shalai = 0._r8 - - cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 - cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 - cpatch%parprof_dir_z(:,:) = 0._r8 - cpatch%parprof_dif_z(:,:) = 0._r8 - - ! Loop over patches to calculate laisun_z and laisha_z for each layer. - ! Derive canopy laisun, laisha, and fsun from layer sums. - ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from - ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. - - ! cpatch%f_sun is calculated in the surface_albedo routine... - - do CL = 1, cpatch%NCL_p - do FT = 1,numpft - - if( debug ) write(fates_log(),*) 'edsurfRad_5601',CL,FT,cpatch%nrad(CL,ft) - - do iv = 1, cpatch%nrad(CL,ft) !NORMAL CASE. - - ! FIX(SPM,040114) - existing comment - ! ** Should this be elai or tlai? Surely we only do radiation for elai? - - cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & - cpatch%f_sun(CL,ft,iv) - - if ( debug ) write(fates_log(),*) 'edsurfRad 570 ',cpatch%elai_profile(CL,ft,iv) - if ( debug ) write(fates_log(),*) 'edsurfRad 571 ',cpatch%f_sun(CL,ft,iv) - - cpatch%ed_laisha_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & - (1._r8 - cpatch%f_sun(CL,ft,iv)) - end do - - !needed for the VOC emissions, etc. - sunlai = sunlai + sum(cpatch%ed_laisun_z(CL,ft,1:cpatch%nrad(CL,ft))) - shalai = shalai + sum(cpatch%ed_laisha_z(CL,ft,1:cpatch%nrad(CL,ft))) - - end do - end do - - if(sunlai+shalai > 0._r8)then - bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) + + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Direct beam transmittance, tr_dir_z, uses cumulative LAI above layer J to give + ! unscattered direct beam onto layer J. do each PFT section. + ! This is just an decay curve based on k_dir. (leaf & sun angle) + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + if (L==1)then + tr_dir_z(L,ft,1) = 1._r8 + else + tr_dir_z(L,ft,1) = weighted_dir_tr(L-1) + endif + laisum = 0.00_r8 + !total direct beam getting to the bottom of the top canopy. + do iv = 1,currentPatch%nrad(L,ft) + laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) + lai_change(L,ft,iv) = 0.0_r8 + if (( ftweight(L,ft,iv+1) > 0.0_r8 ) .and. ( ftweight(L,ft,iv+1) < ftweight(L,ft,iv) ))then + !where there is a partly empty leaf layer, some fluxes go straight through. + lai_change(L,ft,iv) = ftweight(L,ft,iv)-ftweight(L,ft,iv+1) + endif + if (ftweight(L,ft,iv+1) - ftweight(L,ft,iv) > 1.e-10_r8)then + write(fates_log(),*) 'lower layer has more coverage. This is wrong' , & + ftweight(L,ft,iv),ftweight(L,ft,iv+1),ftweight(L,ft,iv+1)-ftweight(L,ft,iv) + endif + + !n.b. in theory lai_change could be calculated daily in the ED code. + !This is light coming striaght through the canopy. + if (L==1)then + tr_dir_z(L,ft,iv+1) = exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + else + tr_dir_z(L,ft,iv+1) = weighted_dir_tr(L-1)*exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + endif + + if (iv == 1)then + !this is the top layer. + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & + ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) + else + !the lai_change(iv) affects the light incident on layer iv+2 not iv+1 + ! light coming from the layer above (iv-1) goes through iv and onto iv+1. + if (lai_change(L,ft,iv-1) > 0.0_r8)then + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv)* & + lai_change(L,ft,iv-1) / ftweight(L,ft,1) + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv-1)* & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) + else + !account fot the light that comes striaght down from unfilled layers above. + tr_dir_z(L,ft,iv+1) = tr_dir_z(L,ft,iv+1) + tr_dir_z(L,ft,iv) * & + ((ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1)) + endif + endif + + end do + + !add up all the weighted contributions from the different PFT columns. + weighted_dir_tr(L) = weighted_dir_tr(L) + tr_dir_z(L,ft,currentPatch%nrad(L,ft)+1)*ftweight(L,ft,1) + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Sunlit and shaded fraction of leaf layer + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + + !laisum = 0._r8 + do iv = 1,currentPatch%nrad(L,ft) + ! Cumulative leaf area. Original code uses cumulative lai do layer. + ! Now use cumulative lai at center of layer. + ! Same as tr_dir_z calcualtions, but in the middle of the layer? FIX(RF,032414)-WHY? + if (iv == 1) then + laisum = 0.5_r8 * (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv)) + else + laisum = laisum + currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv) + end if + + + if (L == 1)then !top canopy layer + currentPatch%f_sun(L,ft,iv) = exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + else + currentPatch%f_sun(L,ft,iv) = weighted_fsun(L-1)* exp(-k_dir(ft) * laisum)* & + (ftweight(L,ft,iv)/ftweight(L,ft,1)) + endif + + if ( iv > 1 ) then ! becasue we are looking at this layer (not the next) + ! we only ever add fluxes if iv>1 + if (lai_change(L,ft,iv-1) > 0.0_r8)then + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv) * & + lai_change(L,ft,iv-1)/ftweight(L,ft,1) + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv-1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ftweight(L,ft,1) + else + currentPatch%f_sun(L,ft,iv) = currentPatch%f_sun(L,ft,iv) + & + currentPatch%f_sun(L,ft,iv-1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + endif + + end do !iv + + weighted_fsun(L) = weighted_fsun(L) + currentPatch%f_sun(L,ft,currentPatch%nrad(L,ft))* & + ftweight(L,ft,1) + + ! instance where the first layer ftweight is used a proxy for the whole column. FTWA + ! this is possibly a source of slight error. If we use the ftweight at the top of the PFT column, + ! then we willl underestimate fsun, but if we use ftweight at the bottom of the column, we will + ! underestimate it. Really, we should be tracking the release of direct light from the column as it tapers + ! towards the ground. Is that necessary to get energy closure? It would be quite hard... + endif !present. + end do!pft loop + end do !L + + + do L = currentPatch%NCL_p,1, -1 !start at the bottom and work up. + do ft = 1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + + !==============================================================================! + ! Iterative solution do scattering + !==============================================================================! + + do ib = 1,hlm_numSWb !vis, nir + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Leaf scattering coefficient and terms do diffuse radiation reflected + ! and transmitted by a layer + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + + do iv = 1,currentPatch%nrad(L,ft) + !How much diffuse light is intercepted and then reflected? + refl_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * rho_layer(L,ft,iv,ib) + !How much diffuse light in this layer is transmitted? + tran_dif(L,ft,iv,ib) = (1._r8 - tr_dif_z(L,ft,iv)) * & + tau_layer(L,ft,iv,ib) + tr_dif_z(L,ft,iv) + end do + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Ratio of upward to forward diffuse fluxes, dif_ratio + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! Soil diffuse reflectance (ratio of down to up radiation). + iv = currentPatch%nrad(L,ft) + 1 + if (L == currentPatch%NCL_p)then !nearest the soil + dif_ratio(L,ft,iv,ib) = currentPatch%gnd_alb_dif(ib) !bc_in(s)%albgr_dif_rb(ib) + else + dif_ratio(L,ft,iv,ib) = weighted_dif_ratio(L+1,ib) + end if + ! Canopy layers, working upwardfrom soil with dif_ratio(iv+1) known + ! FIX(RF,032414) ray tracing eqution - need to find derivation of this... + ! for each unit going down, there are x units going up. + do iv = currentPatch%nrad(L,ft),1, -1 + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv+1,ib) * & + tran_dif(L,ft,iv,ib)*tran_dif(L,ft,iv,ib) / & + (1._r8 - dif_ratio(L,ft,iv+1,ib) * refl_dif(L,ft,iv,ib)) & + + refl_dif(L,ft,iv,ib) + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) * & + ftweight(L,ft,iv)/ftweight(L,ft,1) + dif_ratio(L,ft,iv,ib) = dif_ratio(L,ft,iv,ib) + dif_ratio(L,ft,iv+1,ib) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + end do + weighted_dif_ratio(L,ib) = weighted_dif_ratio(L,ib) + & + dif_ratio(L,ft,1,ib) * ftweight(L,ft,1) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + end do!hlm_numSWb + endif ! currentPatch%canopy_mask + end do!ft + end do!L + + ! Zero out the radiation error for the current patch before conducting the conservation check + currentPatch%radiation_error = 0.0_r8 + + do ib = 1,hlm_numSWb + Dif_dn(:,:,:) = 0.00_r8 + Dif_up(:,:,:) = 0.00_r8 + do L = 1, currentPatch%NCL_p !work down from the top of the canopy. + weighted_dif_down(L) = 0._r8 + do ft = 1, numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! First estimates do downward and upward diffuse flux + ! + ! Dif_dn = forward diffuse flux onto layer J + ! Dif_up = Upward diffuse flux above layer J + ! + ! Solved here without direct beam radiation and using dif_ratio = Dif_up / Dif_dn + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! downward diffuse flux onto the top surface of the canopy + + if (L == 1)then + Dif_dn(L,ft,1) = forc_dif(radtype) + else + Dif_dn(L,ft,1) = weighted_dif_down(L-1) + end if + ! forward diffuse flux within the canopy and at soil, working forward through canopy + do iv = 1,currentPatch%nrad(L,ft) + denom = refl_dif(L,ft,iv,ib) * dif_ratio(L,ft,iv,ib) + denom = 1._r8 - denom + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) / & + denom *ftweight(L,ft,iv)/ftweight(L,ft,1) + if (iv > 1)then + if (lai_change(L,ft,iv-1) > 0.0_r8)then + !here we are thinking about whether the layer above had an laichange, + !but calculating the flux onto the layer below. + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv)* & + lai_change(L,ft,iv-1)/ftweight(L,ft,1) + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1)+ Dif_dn(L,ft,iv-1)* & + (ftweight(L,ft,1)-ftweight(L,ft,iv-1)/ftweight(L,ft,1)) + else + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + else + Dif_dn(L,ft,iv+1) = Dif_dn(L,ft,iv+1) + Dif_dn(L,ft,iv) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + endif + end do + + weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & + ftweight(L,ft,1) + + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif !present + end do !ft + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is the the (incomplete) understorey? + !Add on the radiation going through the canopy gaps. + weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1)*(1.0-sum(ftweight(L,:,1))) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif + end do !L + + do L = currentPatch%NCL_p,1 ,-1 !work up from the bottom. + weighted_dif_up(L) = 0._r8 + do ft = 1, numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + !Bounce diffuse radiation off soil surface. + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then !is this the bottom layer ? + Dif_up(L,ft,iv) = currentPatch%gnd_alb_dif(ib) * Dif_dn(L,ft,iv) + else + Dif_up(L,ft,iv) = weighted_dif_up(L+1) + end if + ! Upward diffuse flux within the canopy and above the canopy, working upward through canopy + + do iv = currentPatch%nrad(L,ft), 1, -1 + if (lai_change(L,ft,iv) > 0.0_r8)then + Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * & + ftweight(L,ft,iv) / ftweight(L,ft,1) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & + tran_dif(L,ft,iv,ib) * lai_change(L,ft,iv)/ftweight(L,ft,1) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * & + (ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + !nb is this the right constuction? + ! the radiation that hits the empty space is not reflected. + else + Dif_up(L,ft,iv) = dif_ratio(L,ft,iv,ib) * Dif_dn(L,ft,iv) * ftweight(L,ft,iv) + Dif_up(L,ft,iv) = Dif_up(L,ft,iv) + Dif_up(L,ft,iv+1) * (1.0_r8-ftweight(L,ft,iv)) + endif + end do + + weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) + !instance where the first layer ftweight is used a proxy for the whole column. FTWA + endif !present + end do !ft + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? + !Add on the radiation coming up through the canopy gaps. + !diffuse to diffuse + weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & + weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) + !direct to diffuse + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & + weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) * currentPatch%gnd_alb_dir(ib) + endif + end do !L + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + ! 3. Iterative calculation of forward and upward diffuse fluxes, iNCL_puding + ! scattered direct beam + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! + + ! Flag to exit iteration loop: 0 = exit and 1 = iterate + irep = 1 + ! Iteration loop + iter = 0 + do while(irep ==1 .and. iter<50) + + iter = iter + 1 + irep = 0 + do L = 1,currentPatch%NCL_p !working from the top down + weighted_dif_down(L) = 0._r8 + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + ! forward diffuse flux within the canopy and at soil, working forward through canopy + ! with Dif_up -from previous iteration-. Dif_dn(1) is the forward diffuse flux onto the canopy. + ! Note: down = forward flux onto next layer + if (L == 1)then !is this the top layer? + Dif_dn(L,ft,1) = forc_dif(radtype) + else + Dif_dn(L,ft,1) = weighted_dif_down(L-1) + end if + down_rad = 0._r8 + + do iv = 1, currentPatch%nrad(L,ft) + ! down rad'n is the sum of the down and upwards reflected diffuse fluxes... + down_rad = Dif_dn(L,ft,iv) * tran_dif(L,ft,iv,ib) + & + Dif_up(L,ft,iv+1) * refl_dif(L,ft,iv,ib) + + !... plus the direct beam intercepted and intransmitted by this layer. + down_rad = down_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - & + exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv)) )) * tau_layer(L,ft,iv,ib) + + + !... plus the direct beam intercepted and intransmitted by this layer. + ! modified to spread it out over the whole of incomplete layers. + + down_rad = down_rad *(ftweight(L,ft,iv)/ftweight(L,ft,1)) + + if (iv > 1)then + if (lai_change(L,ft,iv-1) > 0.0_r8)then + down_rad = down_rad + Dif_dn(L,ft,iv) * lai_change(L,ft,iv-1)/ftweight(L,ft,1) + down_rad = down_rad + Dif_dn(L,ft,iv-1) * (ftweight(L,ft,1)-ftweight(L,ft,iv-1))/ & + ftweight(L,ft,1) + else + down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & + ftweight(L,ft,1) + endif + else + down_rad = down_rad + Dif_dn(L,ft,iv) * (ftweight(L,ft,1)-ftweight(L,ft,iv))/ & + ftweight(L,ft,1) + endif + + !this is just Dif down, plus refl up, plus dir intercepted and turned into dif... , + if (abs(down_rad - Dif_dn(L,ft,iv+1)) > tolerance)then + irep = 1 + end if + Dif_dn(L,ft,iv+1) = down_rad + + end do !iv + + weighted_dif_down(L) = weighted_dif_down(L) + Dif_dn(L,ft,currentPatch%nrad(L,ft)+1) * & + ftweight(L,ft,1) + + endif !present + end do!ft + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? + weighted_dif_down(L) = weighted_dif_down(L) + weighted_dif_down(L-1) * & + (1.0_r8-sum(ftweight(L,1:numpft,1))) + end if + end do ! do L loop + + do L = 1, currentPatch%NCL_p ! working from the top down. + weighted_dif_up(L) = 0._r8 + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + ! Upward diffuse flux at soil or from lower canopy (forward diffuse and unscattered direct beam) + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then !In the bottom canopy layer, reflect off the soil + Dif_up(L,ft,iv) = Dif_dn(L,ft,iv) * currentPatch%gnd_alb_dif(ib) + & + forc_dir(radtype) * tr_dir_z(L,ft,iv) * currentPatch%gnd_alb_dir(ib) + else !In the other canopy layers, reflect off the underlying vegetation. + Dif_up(L,ft,iv) = weighted_dif_up(L+1) + end if + + ! Upward diffuse flux within and above the canopy, working upward through canopy + ! with Dif_dn from previous interation. Note: up = upward flux above current layer + do iv = currentPatch%nrad(L,ft),1,-1 + !this is radiation up, by layer transmittance, by + + !reflection of the lower layer, + up_rad = Dif_dn(L,ft,iv) * refl_dif(L,ft,iv,ib) + up_rad = up_rad + forc_dir(radtype) * tr_dir_z(L,ft,iv) * (1.00_r8 - exp(-k_dir(ft) * & + (currentPatch%elai_profile(L,ft,iv)+currentPatch%esai_profile(L,ft,iv))))* & + rho_layer(L,ft,iv,ib) + up_rad = up_rad + Dif_up(L,ft,iv+1) * tran_dif(L,ft,iv,ib) + up_rad = up_rad * ftweight(L,ft,iv)/ftweight(L,ft,1) + up_rad = up_rad + Dif_up(L,ft,iv+1) *(ftweight(L,ft,1)-ftweight(L,ft,iv))/ftweight(L,ft,1) + ! THE LOWER LAYER FLUX IS HOMOGENIZED, SO WE DON"T CONSIDER THE LAI_CHANGE HERE... + + if (abs(up_rad - Dif_up(L,ft,iv)) > tolerance) then !are we close to the tolerance level? + irep = 1 + end if + Dif_up(L,ft,iv) = up_rad + + end do !iv + weighted_dif_up(L) = weighted_dif_up(L) + Dif_up(L,ft,1) * ftweight(L,ft,1) + end if !present + end do!ft + + if (L == currentPatch%NCL_p.and.currentPatch%NCL_p > 1)then !is this the (incomplete) understorey? + !Add on the radiation coming up through the canopy gaps. + weighted_dif_up(L) = weighted_dif_up(L) +(1.0_r8-sum(ftweight(L,1:numpft,1))) * & + weighted_dif_down(L-1) * currentPatch%gnd_alb_dif(ib) + weighted_dif_up(L) = weighted_dif_up(L) + forc_dir(radtype) * & + weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1)))*currentPatch%gnd_alb_dir(ib) + end if + end do!L + end do ! do while over iter + + abs_rad(ib) = 0._r8 + tr_soili = 0._r8 + tr_soild = 0._r8 + + do L = 1, currentPatch%NCL_p !working from the top down. + abs_dir_z(:,:) = 0._r8 + abs_dif_z(:,:) = 0._r8 + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + !==============================================================================! + ! Compute absorbed flux densities + !==============================================================================! + + ! Absorbed direct beam and diffuse do leaf layers + do iv = 1, currentPatch%nrad(L,ft) + Abs_dir_z(ft,iv) = ftweight(L,ft,iv)* forc_dir(radtype) * tr_dir_z(L,ft,iv) * & + (1.00_r8 - exp(-k_dir(ft) * (currentPatch%elai_profile(L,ft,iv)+ & + currentPatch%esai_profile(L,ft,iv)) )) * f_abs(L,ft,iv,ib) + Abs_dif_z(ft,iv) = ftweight(L,ft,iv)* ((Dif_dn(L,ft,iv) + & + Dif_up(L,ft,iv+1)) * (1.00_r8 - tr_dif_z(L,ft,iv)) * f_abs(L,ft,iv,ib)) + end do + + ! Absorbed direct beam and diffuse do soil + if (L == currentPatch%NCL_p)then + iv = currentPatch%nrad(L,ft) + 1 + Abs_dif_z(ft,iv) = ftweight(L,ft,1)*Dif_dn(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dif(ib) ) + Abs_dir_z(ft,iv) = ftweight(L,ft,1)*forc_dir(radtype) * & + tr_dir_z(L,ft,iv) * (1.0_r8 - currentPatch%gnd_alb_dir(ib) ) + tr_soild = tr_soild + ftweight(L,ft,1)*forc_dir(radtype) * tr_dir_z(L,ft,iv) + tr_soili = tr_soili + ftweight(L,ft,1)*Dif_dn(L,ft,iv) + end if + + ! Absorbed radiation, shaded and sunlit portions of leaf layers + !here we get one unit of diffuse radiation... how much of + !it is absorbed? + if (ib == ivis) then ! only set the absorbed PAR for the visible light band. + do iv = 1, currentPatch%nrad(L,ft) + if (radtype==idirect) then + if ( debug ) then + write(fates_log(),*) 'EDsurfAlb 730 ',Abs_dif_z(ft,iv),currentPatch%f_sun(L,ft,iv) + write(fates_log(),*) 'EDsurfAlb 731 ', currentPatch%fabd_sha_z(L,ft,iv), & + currentPatch%fabd_sun_z(L,ft,iv) + endif + currentPatch%fabd_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv))*f_abs_leaf(L,ft,iv,ib) + currentPatch%fabd_sun_z(L,ft,iv) =( Abs_dif_z(ft,iv) * & + currentPatch%f_sun(L,ft,iv) + & + Abs_dir_z(ft,iv))*f_abs_leaf(L,ft,iv,ib) + else + currentPatch%fabi_sha_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + (1._r8 - currentPatch%f_sun(L,ft,iv))*f_abs_leaf(L,ft,iv,ib) + currentPatch%fabi_sun_z(L,ft,iv) = Abs_dif_z(ft,iv) * & + currentPatch%f_sun(L,ft,iv)*f_abs_leaf(L,ft,iv,ib) + endif + if ( debug ) then + write(fates_log(),*) 'EDsurfAlb 740 ', currentPatch%fabd_sha_z(L,ft,iv), & + currentPatch%fabd_sun_z(L,ft,iv) + endif + end do + endif ! ib + + + !==============================================================================! + ! Sum fluxes + !==============================================================================! + ! Solar radiation absorbed by ground + iv = currentPatch%nrad(L,ft) + 1 + if (L==currentPatch%NCL_p)then + abs_rad(ib) = abs_rad(ib) + (Abs_dir_z(ft,iv) + Abs_dif_z(ft,iv)) + end if + ! Solar radiation absorbed by vegetation and sunlit/shaded leaves + do iv = 1,currentPatch%nrad(L,ft) + if (radtype == idirect)then + currentPatch%fabd(ib) = currentPatch%fabd(ib) + & + Abs_dir_z(ft,iv)+Abs_dif_z(ft,iv) + ! bc_out(s)%fabd_parb_out(ib) = currentPatch%fabd(ib) + else + currentPatch%fabi(ib) = currentPatch%fabi(ib) + Abs_dif_z(ft,iv) + ! bc_out(s)%fabi_parb_out(ib) = currentPatch%fabi(ib) + endif + end do + + ! Albefor + if (L==1)then !top canopy layer. + if (radtype == idirect)then + albd_parb_out(ib) = albd_parb_out(ib) + & + Dif_up(L,ft,1) * ftweight(L,ft,1) + else + albi_parb_out(ib) = albi_parb_out(ib) + & + Dif_up(L,ft,1) * ftweight(L,ft,1) + end if + end if + + ! pass normalized PAR profiles for use in diagnostic averaging for history fields + if (ib == ivis) then ! only diagnose PAR profiles for the visible band + do iv = 1, currentPatch%nrad(L,ft) + currentPatch%nrmlzd_parprof_pft_dir_z(radtype,L,ft,iv) = & + forc_dir(radtype) * tr_dir_z(L,ft,iv) + currentPatch%nrmlzd_parprof_pft_dif_z(radtype,L,ft,iv) = & + Dif_dn(L,ft,iv) + Dif_up(L,ft,iv) + ! + currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) = & + currentPatch%nrmlzd_parprof_dir_z(radtype,L,iv) + & + (forc_dir(radtype) * tr_dir_z(L,ft,iv)) * & + (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) + currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) = & + currentPatch%nrmlzd_parprof_dif_z(radtype,L,iv) + & + (Dif_dn(L,ft,iv) + Dif_up(L,ft,iv)) * & + (ftweight(L,ft,iv) / sum(ftweight(L,1:numpft,iv))) + end do + end if ! ib = visible + end if ! present + end do !ft + if (radtype == idirect)then + fabd_parb_out(ib) = currentPatch%fabd(ib) + else + fabi_parb_out(ib) = currentPatch%fabi(ib) + endif + + + !radiation absorbed from fluxes through unfilled part of lower canopy. + if (currentPatch%NCL_p > 1.and.L == currentPatch%NCL_p)then + abs_rad(ib) = abs_rad(ib) + weighted_dif_down(L-1) * & + (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dif(ib) ) + abs_rad(ib) = abs_rad(ib) + forc_dir(radtype) * weighted_dir_tr(L-1) * & + (1.0_r8-sum(ftweight(L,1:numpft,1)))*(1.0_r8-currentPatch%gnd_alb_dir(ib) ) + tr_soili = tr_soili + weighted_dif_down(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) + tr_soild = tr_soild + forc_dir(radtype) * weighted_dir_tr(L-1) * (1.0_r8-sum(ftweight(L,1:numpft,1))) + endif + + if (radtype == idirect)then + currentPatch%tr_soil_dir(ib) = tr_soild + currentPatch%tr_soil_dir_dif(ib) = tr_soili + currentPatch%sabs_dir(ib) = abs_rad(ib) + ftdd_parb_out(ib) = tr_soild + ftid_parb_out(ib) = tr_soili + else + currentPatch%tr_soil_dif(ib) = tr_soili + currentPatch%sabs_dif(ib) = abs_rad(ib) + ftii_parb_out(ib) = tr_soili + end if + + end do!l + + + !==============================================================================! + ! Conservation check + !==============================================================================! + ! Total radiation balance: absorbed = incoming - outgoing + + if (radtype == idirect)then + error = abs(currentPatch%sabs_dir(ib) - (currentPatch%tr_soil_dir(ib) * & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + & + currentPatch%tr_soil_dir_dif(ib) * (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) + if ( abs(error) > 0.0001)then + write(fates_log(),*)'dir ground absorption error',error,currentPatch%sabs_dir(ib), & + currentPatch%tr_soil_dir(ib)* & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) + write(fates_log(),*) 'albedos',currentPatch%sabs_dir(ib) ,currentPatch%tr_soil_dir(ib), & + (1.0_r8-currentPatch%gnd_alb_dir(ib) ) + + do ft =1,3 + iv = currentPatch%nrad(1,ft) + 1 + write(fates_log(),*) 'abs soil fluxes', Abs_dir_z(ft,iv),Abs_dif_z(ft,iv) + end do + + end if else - bc_out(s)%fsun_pa(ifp) = 0._r8 + if ( abs(currentPatch%sabs_dif(ib)-(currentPatch%tr_soil_dif(ib) * & + (1.0_r8-currentPatch%gnd_alb_dif(ib) ))) > 0.0001_r8)then + write(fates_log(),*)'dif ground absorption error',currentPatch%sabs_dif(ib) , & + (currentPatch%tr_soil_dif(ib)* & + (1.0_r8-currentPatch%gnd_alb_dif(ib) )),currentPatch%NCL_p,ib,sum(ftweight(1,1:numpft,1)) + endif endif - - if(bc_out(s)%fsun_pa(ifp) > 1._r8)then - write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & - sunlai,shalai + + if (radtype == idirect)then + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) + else + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) endif - elai = calc_areaindex(cpatch,'elai') - - bc_out(s)%laisun_pa(ifp) = elai*bc_out(s)%fsun_pa(ifp) - bc_out(s)%laisha_pa(ifp) = elai*(1.0_r8-bc_out(s)%fsun_pa(ifp)) - - ! Absorbed PAR profile through canopy - ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo - ! are canopy integrated so that layer values equal big leaf values. - - if ( debug ) write(fates_log(),*) 'edsurfRad 645 ',cpatch%NCL_p,numpft - - do CL = 1, cpatch%NCL_p - do FT = 1,numpft - - if ( debug ) write(fates_log(),*) 'edsurfRad 649 ',cpatch%nrad(CL,ft) - - do iv = 1, cpatch%nrad(CL,ft) - - if ( debug ) then - write(fates_log(),*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) - write(fates_log(),*) 'edsurfRad 654 ', bc_in(s)%solad_parb(ifp,ipar) - write(fates_log(),*) 'edsurfRad 655 ', bc_in(s)%solai_parb(ifp,ipar) - write(fates_log(),*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) - write(fates_log(),*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) - endif - - cpatch%ed_parsun_z(CL,ft,iv) = & - bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(CL,ft,iv) + & - bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(CL,ft,iv) - - if ( debug )write(fates_log(),*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) - - cpatch%ed_parsha_z(CL,ft,iv) = & - bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(CL,ft,iv) + & - bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(CL,ft,iv) - - if ( debug ) write(fates_log(),*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) - - end do !iv - end do !FT - end do !CL - - ! output the actual PAR profiles through the canopy for diagnostic purposes - - do CL = 1, cpatch%NCL_p - do FT = 1,numpft - do iv = 1, cpatch%nrad(CL,ft) - cpatch%parprof_pft_dir_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dir_z(idirect,CL,FT,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dir_z(idiffuse,CL,FT,iv)) - cpatch%parprof_pft_dif_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dif_z(idirect,CL,FT,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_pft_dif_z(idiffuse,CL,FT,iv)) - end do ! iv - end do ! FT - end do ! CL - - do CL = 1, cpatch%NCL_p - do iv = 1, maxval(cpatch%nrad(CL,:)) - cpatch%parprof_dir_z(CL,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dir_z(idirect,CL,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dir_z(idiffuse,CL,iv)) - cpatch%parprof_dif_z(CL,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dif_z(idirect,CL,iv)) + & - (bc_in(s)%solai_parb(ifp,ipar) * & - cpatch%nrmlzd_parprof_dif_z(idiffuse,CL,iv)) - end do ! iv - end do ! CL - - cpatch => cpatch%younger - enddo - - - enddo - return - + ! ignore the current patch radiation error if the veg-covered fraction of the patch is really small + if ( (currentPatch%total_canopy_area / currentPatch%area) .gt. tolerance ) then + ! normalize rad error by the veg-covered fraction of the patch because that is + ! the only part that this code applies to + currentPatch%radiation_error = currentPatch%radiation_error + error & + * currentPatch%total_canopy_area / currentPatch%area + endif + + lai_reduction(:) = 0.0_r8 + do L = 1, currentPatch%NCL_p + do ft =1,numpft + if (currentPatch%canopy_mask(L,ft) == 1)then + do iv = 1, currentPatch%nrad(L,ft) + if (lai_change(L,ft,iv) > 0.0_r8)then + lai_reduction(L) = max(lai_reduction(L),lai_change(L,ft,iv)) + endif + enddo + endif + enddo + enddo + + if (radtype == idirect)then + !here we are adding a within-ED radiation scheme tolerance, and then adding the diffrence onto the albedo + !it is important that the lower boundary for this is ~1000 times smaller than the tolerance in surface albedo. + if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then + albd_parb_out(ib) = albd_parb_out(ib) + error + !this terms adds the error back on to the albedo. While this is partly inexcusable, it is + ! in the medium term a solution that + ! prevents the model from crashing with small and occasional energy balances issues. + ! These are extremely difficult to debug, many have been solved already, leading + ! to the complexity of this code, but where the system generates occasional errors, we + ! will deal with them for now. + end if + if (abs(error) > 0.15_r8)then + write(fates_log(),*) 'Large Dir Radn consvn error',error ,ib + write(fates_log(),*) 'diags', albd_parb_out(ib), ftdd_parb_out(ib), & + ftid_parb_out(ib), fabd_parb_out(ib) + write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'ftweight',ftweight(1,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) + + albd_parb_out(ib) = albd_parb_out(ib) + error + end if + else + + if (abs(error) > 1.e-9_r8 .and. abs(error) < 0.15_r8)then + albi_parb_out(ib) = albi_parb_out(ib) + error + end if + + if (abs(error) > 0.15_r8)then + write(fates_log(),*) 'lg Dif Radn consvn error',error ,ib + write(fates_log(),*) 'diags', albi_parb_out(ib), ftii_parb_out(ib), & + fabi_parb_out(ib) + !write(fates_log(),*) 'lai_change',lai_change(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'elai',currentpatch%elai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'esai',currentpatch%esai_profile(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + !write(fates_log(),*) 'ftweight',ftweight(currentpatch%ncl_p,1:numpft,1:diag_nlevleaf) + write(fates_log(),*) 'cp',currentPatch%area, currentPatch%patchno + write(fates_log(),*) 'ground albedo diffuse (ib)', currentPatch%gnd_alb_dir(ib) + !write(fates_log(),*) 'rhol',rhol(1:numpft,:) + !write(fates_log(),*) 'ftw',sum(ftweight(1,1:numpft,1)),ftweight(1,1:numpft,1) + !write(fates_log(),*) 'present',currentPatch%canopy_mask(1,1:numpft) + !write(fates_log(),*) 'CAP',currentPatch%canopy_area_profile(1,1:numpft,1) + + albi_parb_out(ib) = albi_parb_out(ib) + error + end if + + if (radtype == idirect)then + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabd_parb_out(ib) + albd_parb_out(ib) + currentPatch%sabs_dir(ib)) + else + error = (forc_dir(radtype) + forc_dif(radtype)) - & + (fabi_parb_out(ib) + albi_parb_out(ib) + currentPatch%sabs_dif(ib)) + endif + + if (abs(error) > 0.00000001_r8)then + write(fates_log(),*) 'there is still error after correction',error ,ib + end if + + end if + end do !hlm_numSWb + + enddo ! rad-type + + + end associate + return +end subroutine PatchNormanRadiation + +! ====================================================================================== + +subroutine ED_SunShadeFracs(nsites, sites,bc_in,bc_out) + + implicit none + + ! Arguments + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + + + ! locals + type (ed_patch_type),pointer :: cpatch ! c"urrent" patch + real(r8) :: sunlai + real(r8) :: shalai + real(r8) :: elai + integer :: CL + integer :: FT + integer :: iv + integer :: s + integer :: ifp + + + do s = 1,nsites + + ifp = 0 + cpatch => sites(s)%oldest_patch + + do while (associated(cpatch)) + if(cpatch%nocomp_pft_label.ne.0)then !only for veg patches + ! do not do albedo calculations for bare ground patch in SP mode + ! and (more impotantly) do not iterate ifp or it will mess up the indexing wherein + ! ifp=1 is the first vegetated patch. + ifp=ifp+1 + + if( debug ) write(fates_log(),*) 'edsurfRad_5600',ifp,s,cpatch%NCL_p,numpft + + ! zero out various datas + cpatch%ed_parsun_z(:,:,:) = 0._r8 + cpatch%ed_parsha_z(:,:,:) = 0._r8 + cpatch%ed_laisun_z(:,:,:) = 0._r8 + cpatch%ed_laisha_z(:,:,:) = 0._r8 + + bc_out(s)%fsun_pa(ifp) = 0._r8 + + sunlai = 0._r8 + shalai = 0._r8 + + cpatch%parprof_pft_dir_z(:,:,:) = 0._r8 + cpatch%parprof_pft_dif_z(:,:,:) = 0._r8 + cpatch%parprof_dir_z(:,:) = 0._r8 + cpatch%parprof_dif_z(:,:) = 0._r8 + + ! Loop over patches to calculate laisun_z and laisha_z for each layer. + ! Derive canopy laisun, laisha, and fsun from layer sums. + ! If sun/shade big leaf code, nrad=1 and fsun_z(p,1) and tlai_z(p,1) from + ! SurfaceAlbedo is canopy integrated so that layer value equals canopy value. + + ! cpatch%f_sun is calculated in the surface_albedo routine... + + do CL = 1, cpatch%NCL_p + do FT = 1,numpft + + if( debug ) write(fates_log(),*) 'edsurfRad_5601',CL,FT,cpatch%nrad(CL,ft) + + do iv = 1, cpatch%nrad(CL,ft) !NORMAL CASE. + + ! FIX(SPM,040114) - existing comment + ! ** Should this be elai or tlai? Surely we only do radiation for elai? + + cpatch%ed_laisun_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + cpatch%f_sun(CL,ft,iv) + + if ( debug ) write(fates_log(),*) 'edsurfRad 570 ',cpatch%elai_profile(CL,ft,iv) + if ( debug ) write(fates_log(),*) 'edsurfRad 571 ',cpatch%f_sun(CL,ft,iv) + + cpatch%ed_laisha_z(CL,ft,iv) = cpatch%elai_profile(CL,ft,iv) * & + (1._r8 - cpatch%f_sun(CL,ft,iv)) + + end do + + !needed for the VOC emissions, etc. + sunlai = sunlai + sum(cpatch%ed_laisun_z(CL,ft,1:cpatch%nrad(CL,ft))) + shalai = shalai + sum(cpatch%ed_laisha_z(CL,ft,1:cpatch%nrad(CL,ft))) + + end do + end do + + if(sunlai+shalai > 0._r8)then + bc_out(s)%fsun_pa(ifp) = sunlai / (sunlai+shalai) + else + bc_out(s)%fsun_pa(ifp) = 0._r8 + endif + + if(bc_out(s)%fsun_pa(ifp) > 1._r8)then + write(fates_log(),*) 'too much leaf area in profile', bc_out(s)%fsun_pa(ifp), & + sunlai,shalai + endif + + elai = calc_areaindex(cpatch,'elai') + + bc_out(s)%laisun_pa(ifp) = elai*bc_out(s)%fsun_pa(ifp) + bc_out(s)%laisha_pa(ifp) = elai*(1.0_r8-bc_out(s)%fsun_pa(ifp)) + + ! Absorbed PAR profile through canopy + ! If sun/shade big leaf code, nrad=1 and fluxes from SurfaceAlbedo + ! are canopy integrated so that layer values equal big leaf values. + + if ( debug ) write(fates_log(),*) 'edsurfRad 645 ',cpatch%NCL_p,numpft + + do CL = 1, cpatch%NCL_p + do FT = 1,numpft + + if ( debug ) write(fates_log(),*) 'edsurfRad 649 ',cpatch%nrad(CL,ft) + + do iv = 1, cpatch%nrad(CL,ft) + + if ( debug ) then + write(fates_log(),*) 'edsurfRad 653 ', cpatch%ed_parsun_z(CL,ft,iv) + write(fates_log(),*) 'edsurfRad 654 ', bc_in(s)%solad_parb(ifp,ipar) + write(fates_log(),*) 'edsurfRad 655 ', bc_in(s)%solai_parb(ifp,ipar) + write(fates_log(),*) 'edsurfRad 656 ', cpatch%fabd_sun_z(CL,ft,iv) + write(fates_log(),*) 'edsurfRad 657 ', cpatch%fabi_sun_z(CL,ft,iv) + endif + + cpatch%ed_parsun_z(CL,ft,iv) = & + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sun_z(CL,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sun_z(CL,ft,iv) + + if ( debug )write(fates_log(),*) 'edsurfRad 663 ', cpatch%ed_parsun_z(CL,ft,iv) + + cpatch%ed_parsha_z(CL,ft,iv) = & + bc_in(s)%solad_parb(ifp,ipar)*cpatch%fabd_sha_z(CL,ft,iv) + & + bc_in(s)%solai_parb(ifp,ipar)*cpatch%fabi_sha_z(CL,ft,iv) + + if ( debug ) write(fates_log(),*) 'edsurfRad 669 ', cpatch%ed_parsha_z(CL,ft,iv) + + end do !iv + end do !FT + end do !CL + + ! Convert normalized radiation error units from fraction of radiation to W/m2 + cpatch%radiation_error = cpatch%radiation_error * (bc_in(s)%solad_parb(ifp,ipar) + & + bc_in(s)%solai_parb(ifp,ipar)) + + ! output the actual PAR profiles through the canopy for diagnostic purposes + do CL = 1, cpatch%NCL_p + do FT = 1,numpft + do iv = 1, cpatch%nrad(CL,ft) + cpatch%parprof_pft_dir_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dir_z(idirect,CL,FT,iv)) + & + (bc_in(s)%solai_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dir_z(idiffuse,CL,FT,iv)) + cpatch%parprof_pft_dif_z(CL,FT,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dif_z(idirect,CL,FT,iv)) + & + (bc_in(s)%solai_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_pft_dif_z(idiffuse,CL,FT,iv)) + end do ! iv + end do ! FT + end do ! CL + + do CL = 1, cpatch%NCL_p + do iv = 1, maxval(cpatch%nrad(CL,:)) + cpatch%parprof_dir_z(CL,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_dir_z(idirect,CL,iv)) + & + (bc_in(s)%solai_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_dir_z(idiffuse,CL,iv)) + cpatch%parprof_dif_z(CL,iv) = (bc_in(s)%solad_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_dif_z(idirect,CL,iv)) + & + (bc_in(s)%solai_parb(ifp,ipar) * & + cpatch%nrmlzd_parprof_dif_z(idiffuse,CL,iv)) + end do ! iv + end do ! CL + endif ! not bareground patch + cpatch => cpatch%younger + enddo + + + enddo + return + end subroutine ED_SunShadeFracs @@ -1221,7 +1299,7 @@ end subroutine ED_SunShadeFracs ! real(r8),intent(in),dimension(:,:) :: forc_solad ! => atm2lnd_inst%forc_solad_grc, direct radiation (W/m**2 ! real(r8),intent(in),dimension(:,:) :: forc_solai ! => atm2lnd_inst%forc_solai_grc, diffuse radiation (W/m**2) ! real(r8),intent(in),dimension(:,:) :: fsa ! => solarabs_inst%fsa_patch, solar radiation absorbed (total) (W/m**2) -! real(r8),intent(in),dimension(:,:) :: fsr ! => solarabs_inst%fsr_patch, solar radiation reflected (W/m**2) +! real(r8),intent(in),dimension(:,:) :: fsr ! => solarabs_inst%fsr_patch, solar radiation reflected (W/m**2) ! integer :: p ! integer :: fp @@ -1238,6 +1316,6 @@ end subroutine ED_SunShadeFracs ! end do ! return ! end subroutine ED_CheckSolarBalance - + end module EDSurfaceRadiationMod diff --git a/biogeophys/FatesBstressMod.F90 b/biogeophys/FatesBstressMod.F90 index 46f30f434b..c56b4930f5 100644 --- a/biogeophys/FatesBstressMod.F90 +++ b/biogeophys/FatesBstressMod.F90 @@ -63,12 +63,12 @@ subroutine btran_sal_stress_fates( nsites, sites, bc_in) cpatch => sites(s)%oldest_patch do while (associated(cpatch)) - ! THIS SHOULD REALLY BE A COHORT LOOP ONCE WE HAVE rootfr_ft FOR COHORTS (RGK) - do ft = 1,numpft cpatch%bstress_sal_ft(ft) = 0.0_r8 - call set_root_fraction(sites(s)%rootfrac_scr, ft, sites(s)%zi_soil ) + call set_root_fraction(sites(s)%rootfrac_scr, ft, & + sites(s)%zi_soil, & + bc_in(s)%max_rooting_depth_index_col ) do j = 1,bc_in(s)%nlevsoil diff --git a/biogeophys/FatesHydroWTFMod.F90 b/biogeophys/FatesHydroWTFMod.F90 index cda65a12ae..8356b2b165 100644 --- a/biogeophys/FatesHydroWTFMod.F90 +++ b/biogeophys/FatesHydroWTFMod.F90 @@ -1,4 +1,4 @@ -module FatesHydroWTFMod + module FatesHydroWTFMod use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : fates_unset_r8 @@ -29,13 +29,13 @@ module FatesHydroWTFMod real(r8), parameter :: min_ftc = 0.00001_r8 ! Minimum allowed fraction of total conductance - + ! Bounds on saturated fraction, outside of which we use linear PV or stop flow ! In this context, the saturated fraction is defined by the volumetric WC "th" ! and the volumetric residual and saturation "th_res" and "th_sat": (th-th_r)/(th_sat-th_res) - real(r8), parameter :: min_sf_interp = 0.02 ! Linear interpolation below this saturated frac - real(r8), parameter :: max_sf_interp = 0.99 ! Linear interpolation above this saturated frac + real(r8), parameter :: min_sf_interp = 0.01 ! Linear interpolation below this saturated frac + real(r8), parameter :: max_sf_interp = 0.998 ! Linear interpolation above this saturated frac real(r8), parameter :: quad_a1 = 0.80_r8 ! smoothing factor "A" term ! in the capillary-elastic region @@ -57,16 +57,16 @@ module FatesHydroWTFMod ! into these linear regions, and they only exist reall to handle ! strange cases where the solvers overshoot and predict above and below ! saturation and residual respectively. - + real(r8) :: psi_max ! psi matching max_sf_interp where we start linear interp real(r8) :: psi_min ! psi matching min_sf_interp real(r8) :: dpsidth_max ! dpsi_dth where we start linear interp real(r8) :: dpsidth_min ! dpsi_dth where we start min interp real(r8) :: th_min ! vwc matching min_sf_interp where we start linear interp real(r8) :: th_max ! vwc matching max_sf_interp where we start linear interp - + contains - + procedure :: th_from_psi => th_from_psi_base procedure :: psi_from_th => psi_from_th_base procedure :: dpsidth_from_th => dpsidth_from_th_base @@ -80,7 +80,8 @@ module FatesHydroWTFMod procedure, non_overridable :: th_linear_sat procedure, non_overridable :: th_linear_res procedure, non_overridable :: set_min_max - + procedure, non_overridable :: get_thmin + end type wrf_type @@ -112,7 +113,8 @@ module FatesHydroWTFMod ! Water Retention Function type, public, extends(wrf_type) :: wrf_type_vg real(r8) :: alpha ! Inverse air entry parameter [m3/Mpa] - real(r8) :: psd ! Inverse width of pore size distribution parameter + real(r8) :: n_vg ! pore size distribution parameter, psd in original code + real(r8) :: m_vg ! m in van Genuchten 1980, also a pore size distribtion parameter , 1-m in original code real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] real(r8) :: th_res ! Residual volumetric water content [m3/m3] contains @@ -126,7 +128,8 @@ module FatesHydroWTFMod ! Water Conductivity Function type, public, extends(wkf_type) :: wkf_type_vg real(r8) :: alpha ! Inverse air entry parameter [m3/Mpa] - real(r8) :: psd ! Inverse width of pore size distribution parameter + real(r8) :: n_vg ! pore size distribution parameter + real(r8) :: m_vg ! m in van Genuchten 1980, also a pore size distribtion parameter real(r8) :: tort ! Tortuosity parameter (sometimes "l") real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] real(r8) :: th_res ! Residual volumetric water content [m3/m3] @@ -163,6 +166,42 @@ module FatesHydroWTFMod procedure :: dftcdpsi_from_psi => dftcdpsi_from_psi_cch procedure :: set_wkf_param => set_wkf_param_cch end type wkf_type_cch + ! ===================================================================================== + ! Type1 Smooth approximation of Clapp-Hornberger and Campbell (CCH) water retention and conductivity functions + ! Bisht et al. Geosci. Model Dev., 11, 4085–4102, 2018 + ! ===================================================================================== + + ! Water Retention Function + type, public, extends(wrf_type) :: wrf_type_smooth_cch + real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] + real(r8) :: psi_sat ! Bubbling pressure (potential at saturation) [Mpa] + real(r8) :: beta ! Clapp-Hornberger "beta" parameter [-] + real(r8) :: scch_pu ! An estimated breakpoint capillary pressure, below which the specified water retention curve is applied. It is also the lower limit when the smoothing function is applied. [Mpa] + real(r8) :: scch_ps ! An estimated breakpoint capillary pressure, an upper limit where smoothing funciton is applied. [Mpa] + real(r8) :: scch_b2 ! constant coefficient of the quadratic term in the smoothing polynomial function [-] + real(r8) :: scch_b3 ! constant coefficient of the cubic term in the smoothing polynomial function [-] + contains + procedure :: th_from_psi => th_from_psi_smooth_cch + procedure :: psi_from_th => psi_from_th_smooth_cch + procedure :: dpsidth_from_th => dpsidth_from_th_smooth_cch + procedure :: set_wrf_param => set_wrf_param_smooth_cch + procedure :: get_thsat => get_thsat_smooth_cch + end type wrf_type_smooth_cch + + ! Water Conductivity Function + type, public, extends(wkf_type) :: wkf_type_smooth_cch + real(r8) :: th_sat ! Saturation volumetric water content [m3/m3] + real(r8) :: psi_sat ! Bubbling pressure (potential at saturation) [Mpa] + real(r8) :: beta ! Clapp-Hornberger "beta" parameter [-] + real(r8) :: scch_pu ! An estimated breakpoint capillary pressure, below which the specified water retention curve is applied. It is also the lower limit when the smoothing function is applied. [Mpa] + real(r8) :: scch_ps ! An estimated breakpoint capillary pressure, an upper limit where smoothing funciton is applied. [Mpa] + real(r8) :: scch_b2 ! constant coefficient of the quadratic term in the smoothing polynomial function [-] + real(r8) :: scch_b3 ! constant coefficient of the cubic term in the smoothing polynomial function [-] + contains + procedure :: ftc_from_psi => ftc_from_psi_smooth_cch + procedure :: dftcdpsi_from_psi => dftcdpsi_from_psi_smooth_cch + procedure :: set_wkf_param => set_wkf_param_smooth_cch + end type wkf_type_smooth_cch ! ===================================================================================== ! TFS functions @@ -210,89 +249,99 @@ module FatesHydroWTFMod ! ===================================================================================== ! Generic Functions usable by all - ! Note that these are linear extrapolations, and are not scientifically - ! valid. They should only be used with the expectation that they will allow + ! Note that these are linear extrapolations. + ! They should only be used with the expectation that they will allow ! for solutions outside the expected range, with the understanding these ! are temporary pertubations, probably through fluctuations in precision ! of numerical integration. ! ============================================================================ - + subroutine set_min_max(this,th_res,th_sat) ! This routine uses max_sf_interp and min_sft_interp ! to define the bounds of where the linear ranges start and stop - + class(wrf_type) :: this real(r8),intent(in) :: th_res real(r8),intent(in) :: th_sat - + this%th_max = max_sf_interp*(th_sat-th_res)+th_res this%th_min = min_sf_interp*(th_sat-th_res)+th_res this%psi_max = this%psi_from_th(this%th_max-tiny(this%th_max)) this%dpsidth_max = this%dpsidth_from_th(this%th_max-tiny(this%th_max)) this%psi_min = this%psi_from_th(this%th_min+tiny(this%th_min)) this%dpsidth_min = this%dpsidth_from_th(this%th_min+tiny(this%th_min)) - + end subroutine set_min_max - + ! ============================================================================ - + function psi_linear_res(this,th) result(psi) ! Calculate psi in linear range below residual - + class(wrf_type) :: this real(r8),intent(in) :: th ! vol. wat. cont [m3/m3] real(r8) :: psi ! Matric potential [MPa] - + psi = this%psi_min + this%dpsidth_min * (th-this%th_min) - + end function psi_linear_res - + + ! =========================================================================== + + function get_thmin(this) result(th_min) + + class(wrf_type) :: this + real(r8) :: th_min + + th_min = this%th_min + + end function get_thmin + ! =========================================================================== function psi_linear_sat(this,th) result(psi) ! Calculate psi in linear range above saturation - + class(wrf_type) :: this real(r8),intent(in) :: th ! vol. wat. cont [m3/m3] real(r8) :: psi ! Matric potential [MPa] - - psi = this%psi_max + this%dpsidth_max * (th-this%th_max) - + + psi = this%psi_max + this%dpsidth_max * (th-this%th_max) + end function psi_linear_sat ! =========================================================================== - + function th_linear_sat(this,psi) result(th) ! Calculate th from psi in linear range above saturation - + class(wrf_type) :: this real(r8),intent(in) :: psi ! Matric potential [MPa] real(r8) :: th ! vol. wat. cont [m3/m3] - - th = this%th_max + (psi-this%psi_max)/this%dpsidth_max + th = this%th_max + (psi-this%psi_max)/this%dpsidth_max end function th_linear_sat ! =========================================================================== - + function th_linear_res(this,psi) result(th) ! Calculate th from psi in linear range above saturation - + class(wrf_type) :: this real(r8),intent(in) :: psi ! Matric potential [MPa] real(r8) :: th ! vol. wat. cont [m3/m3] - + th = this%th_min + (psi-this%psi_min)/this%dpsidth_min end function th_linear_res - + ! =========================================================================== - + subroutine set_wrf_param_base(this,params_in) class(wrf_type) :: this real(r8),intent(in) :: params_in(:) @@ -379,12 +428,13 @@ subroutine set_wrf_param_vg(this,params_in) real(r8), intent(in) :: params_in(:) this%alpha = params_in(1) - this%psd = params_in(2) - this%th_sat = params_in(3) - this%th_res = params_in(4) + this%n_vg = params_in(2) + this%m_vg = params_in(3) + this%th_sat = params_in(4) + this%th_res = params_in(5) call this%set_min_max(this%th_res,this%th_sat) - + return end subroutine set_wrf_param_vg @@ -396,10 +446,11 @@ subroutine set_wkf_param_vg(this,params_in) real(r8), intent(in) :: params_in(:) this%alpha = params_in(1) - this%psd = params_in(2) - this%th_sat = params_in(3) - this%th_res = params_in(4) - this%tort = params_in(5) + this%n_vg = params_in(2) + this%m_vg = params_in(3) + this%th_sat = params_in(4) + this%th_res = params_in(5) + this%tort = params_in(6) return end subroutine set_wkf_param_vg @@ -409,43 +460,48 @@ end subroutine set_wkf_param_vg function get_thsat_vg(this) result(th_sat) class(wrf_type_vg) :: this real(r8) :: th_sat - + th_sat = this%th_sat - + end function get_thsat_vg - + ! ===================================================================================== + + + ! ===================================================================================== + function th_from_psi_vg(this,psi) result(th) ! Van Genuchten (1980) calculation of volumetric water content (theta) ! from matric potential. class(wrf_type_vg) :: this - real(r8), intent(in) :: psi ! Matric potential [MPa] - real(r8) :: satfrac ! Saturated fraction [-] - real(r8) :: th ! Volumetric Water Cont [m3/m3] - - real(r8) :: dpsidth_interp ! change in psi during lin interp (slope) - real(r8) :: m ! pore size distribution param (1/n) - - m = 1._r8/this%psd - + real(r8), intent(in) :: psi ! Matric potential [MPa] + real(r8) :: satfrac ! Saturated fraction [-] + real(r8) :: th ! Volumetric Water Cont [m3/m3] + real(r8) :: dpsidth_interp ! change in psi during lin interp (slope) + real(r8) :: m ! pore size distribution param 1 + real(r8) :: n ! pore size distribution param 2 + + m = this%m_vg + n = this%n_vg + if(psi>this%psi_max) then ! Linear range for extreme values th = this%th_linear_sat(psi) - + elseif(psithis%th_max)then psi = this%psi_linear_sat(th) - + elseif(th this%th_max) then @@ -533,15 +587,14 @@ function dpsidth_from_th_vg(this,th) result(dpsidth) satfrac = (th-this%th_res)/(this%th_sat-this%th_res) dsatfrac_dth = 1._r8/(this%th_sat-this%th_res) - ! psi = -(1._r8/this%alpha)*(satfrac**(1._r8/(m-1._r8)) - 1._r8 )**m + ! psi = -(1._r8/this%alpha)*(satfrac**(1._r8/(-m)) - 1._r8 )**(1/n) ! psi = -a1 * (satfrac**m2 - 1)** m1 ! dpsi dth = -(m1)*a1*(satfrac**m2-1)**(m1-1) * m2*(satfrac)**(m2-1)*dsatfracdth - ! f(x) = satfrac**m2 -1 ! g(x) = a1*f(x)**m1 ! dpsidth = g'(f(x)) f'(x) - dpsidth = -m1*a1*(satfrac**m2 - 1._r8)**(m1-1._r8) * m2*satfrac**(m2-1._r8)*dsatfrac_dth + end if end function dpsidth_from_th_vg @@ -556,18 +609,19 @@ function ftc_from_psi_vg(this,psi) result(ftc) real(r8) :: den ! denominator term real(r8) :: ftc real(r8) :: psi_eff - real(r8) :: m ! inverse pore size distribution param (1/psd) + real(r8) :: m ! pore size distribution param () + real(r8) :: n ! pore size distribution param (psd) + + n = this%n_vg + m = this%m_vg - m = 1._r8/this%psd - if(psi<0._r8) then ! VG 1980 assumes a postive pressure convention... psi_eff = -psi - - num = (1._r8 - (this%alpha*psi_eff)**(this%psd-1._r8) * & - (1._r8 + (this%alpha*psi_eff)**this%psd)**(-(1._r8-m)))**2._r8 - den = (1._r8 + (this%alpha*psi_eff)**this%psd)**(this%tort*(1._r8-m)) + num = (1._r8 - ((this%alpha*psi_eff)**(n) / & + (1._r8 + (this%alpha*psi_eff)**n))**m)**2._r8 + den = (1._r8 + (this%alpha*psi_eff)**n)**(this%tort*(m)) ! Make sure this is well behaved ftc = min(1._r8,max(min_ftc,num/den)) @@ -599,8 +653,10 @@ function dftcdpsi_from_psi_vg(this,psi) result(dftcdpsi) real(r8) :: ftc ! calculate current ftc to see if we are at min real(r8) :: dftcdpsi ! change in frac total cond wrt psi real(r8) :: m ! pore size distribution param (1/psd) - - m = 1._r8/this%psd + real(r8) :: n + + n =this%n_vg + m =this%m_vg if(psi>=0._r8) then dftcdpsi = 0._r8 @@ -613,19 +669,19 @@ function dftcdpsi_from_psi_vg(this,psi) result(dftcdpsi) dftcdpsi = 0._r8 ! We cap ftc, so derivative is zero else - t1 = (this%alpha*psi_eff)**(this%psd-1._r8) - dt1 = this%alpha*(this%psd-1._r8)*(this%alpha*psi_eff)**(this%psd-2._r8) + t1 = (this%alpha*psi_eff)**(n*m) + dt1 = this%alpha*(n*m)*(this%alpha*psi_eff)**(n*m-1._r8) - t2 = (1._r8 + (this%alpha*psi_eff)**this%psd)**(m-1._r8) - dt2 = (m-1._r8) * & - (1._r8 + (this%alpha*psi_eff)**this%psd)**(m-2._r8) * & - this%psd * (this%alpha*psi_eff)**(this%psd-1._r8) * this%alpha - - t3 = (1._r8 + (this%alpha*psi_eff)**this%psd)**(this%tort*( 1._r8-m)) - dt3 = this%tort*(1._r8-m) * & - (1._r8 + (this%alpha*psi_eff)**this%psd )**(this%tort*(1._r8-m)-1._r8) * & - this%psd * (this%alpha*psi_eff)**(this%psd-1._r8) * this%alpha + t2 = (1._r8 + (this%alpha*psi_eff)**n)**(-m) + dt2 = (-m) * & + (1._r8 + (this%alpha*psi_eff)**n)**(-m-1._r8) * & + n * (this%alpha*psi_eff)**(n-1._r8) * this%alpha + t3 = (1._r8 + (this%alpha*psi_eff)**n)**(this%tort*(m)) + dt3 = this%tort*(m) * & + (1._r8 + (this%alpha*psi_eff)**n )**(this%tort*(m)-1._r8) * & + n * (this%alpha*psi_eff)**(n-1._r8) * this%alpha + dftcdpsi = 2._r8*(1._r8-t1*t2)*(t1*dt2 + t2*dt1)/t3 - & t3**(-2._r8)*dt3*(1._r8-t1*t2)**2._r8 end if @@ -633,7 +689,6 @@ function dftcdpsi_from_psi_vg(this,psi) result(dftcdpsi) end if end function dftcdpsi_from_psi_vg - ! ===================================================================================== ! ===================================================================================== ! Campbell, Clapp-Hornberger Water Retention Functions @@ -644,7 +699,7 @@ subroutine set_wrf_param_cch(this,params_in) class(wrf_type_cch) :: this real(r8), intent(in) :: params_in(:) - real(r8) :: th_max + real(r8) :: th_max ! saturated water content this%th_sat = params_in(1) this%psi_sat = params_in(2) @@ -658,7 +713,7 @@ subroutine set_wrf_param_cch(this,params_in) this%th_min = fates_unset_r8 this%psi_min = fates_unset_r8 this%dpsidth_min = fates_unset_r8 - + return end subroutine set_wrf_param_cch @@ -680,13 +735,13 @@ end subroutine set_wkf_param_cch function get_thsat_cch(this) result(th_sat) class(wrf_type_cch) :: this real(r8) :: th_sat - + th_sat = this%th_sat - + end function get_thsat_cch - + ! ===================================================================================== - + function th_from_psi_cch(this,psi) result(th) class(wrf_type_cch) :: this @@ -782,6 +837,628 @@ function dftcdpsi_from_psi_cch(this,psi) result(dftcdpsi) end function dftcdpsi_from_psi_cch + ! ===================================================================================== + ! ===================================================================================== + ! Type1 Smooth approximation Campbell, Clapp-Hornberger Water Retention Functions + ! ===================================================================================== + ! ===================================================================================== + subroutine set_wrf_param_smooth_cch(this,params_in) + + class(wrf_type_smooth_cch) :: this + real(r8), intent(in) :: params_in(:) + integer :: styp ! an option to force constant coefficient of the quadratic + ! term 0 (styp = 1) or to force the constant coefficient of + ! the cubic term 0 (styp/=2) + real(r8) :: th_max ! saturated water content [-] + + ! !LOCAL VARIABLES: + real(r8) :: pu ! an estimated breakpoint at which the constant + ! coefficient of the quadratic term (styp=2) + ! or the cubic term (styp/=2) is 0 [Mpa] + real(r8) :: bcAtPu ! working local + real(r8) :: lambdaDeltaPuOnPu ! working local + real(r8) :: oneOnDeltaPu ! working local + real(r8) :: lambda ! working local, inverse of Clapp and Hornberger "b" + real(r8) :: alpha ! working local + real(r8) :: ps ! working local, 90% of entry pressure [Mpa] + + + + this%th_sat = params_in(1) + this%psi_sat = params_in(2) + this%beta = params_in(3) + styp = int(params_in(4)) + + + alpha = -1._r8/this%psi_sat + lambda = 1.0_r8/this%beta + ps = -0.9_r8/alpha + this%scch_ps = ps + ! Choose `pu` that forces `scch_b2 = 0`. + if(styp == 1) then + pu = findGu_SBC_zeroCoeff(lambda, 3, -alpha*ps) / (-alpha) + this%scch_pu = pu + + ! Find helper constants. + bcAtPu = (-alpha*pu)**(-lambda) + lambdaDeltaPuOnPu = lambda * (1.d0 - ps/pu) + oneOnDeltaPu = 1.d0 / (pu - ps) + + ! Store coefficients for cubic function. + this%scch_b2 = 0.d0 + this%scch_b3 = (2.d0 - bcAtPu*(2.d0+lambdaDeltaPuOnPu)) * oneOnDeltaPu * oneOnDeltaPu * oneOnDeltaPu + if( this%scch_b3 <= 0.d0 ) then + write(fates_log(),*) 'set_wrf_param_smooth_cch b3 <=0',pu,ps,alpha,lambda,oneOnDeltaPu,lambdaDeltaPuOnPu,bcAtPu,this%psi_sat + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + else + ! Choose `pu` that forces `sbc_b3 = 0`. + pu = findGu_SBC_zeroCoeff(lambda, 2, -alpha*ps) / (-alpha) + this%scch_pu = pu + + ! Find helper constants. + bcAtPu = (-alpha*pu)**(-lambda) + lambdaDeltaPuOnPu = lambda * (1.d0 - ps/pu) + oneOnDeltaPu = 1.d0 / (pu - ps) + + ! Store coefficients for cubic function. + this%scch_b2 = -(3.d0 - bcAtPu*(3.d0+lambdaDeltaPuOnPu)) * oneOnDeltaPu* oneOnDeltaPu + if( this%scch_b2 >= 0.d0 ) then + write(fates_log(),*) 'set_wrf_param_smooth_cch b2 <= 0' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + this%scch_b3 = 0.d0 + + endif + ! Set DERIVED constants + ! used for interpolating in extreme ranges + this%th_max = max_sf_interp*this%th_sat + this%psi_max = this%psi_from_th(this%th_max-tiny(this%th_max)) + this%dpsidth_max = this%dpsidth_from_th(this%th_max-tiny(this%th_max)) + this%th_min = 1.e-8_r8 + this%psi_min = fates_unset_r8 + this%dpsidth_min = fates_unset_r8 + + return + end subroutine set_wrf_param_smooth_cch + + + + ! ===================================================================================== + + subroutine set_wkf_param_smooth_cch(this,params_in) + + class(wkf_type_smooth_cch) :: this + real(r8), intent(in) :: params_in(:) + integer :: styp ! an option to force constant coefficient of the + ! quadratic term 0 (styp = 1) or to force the constant + ! coefficient of the cubic term 0 (styp/=2) + real(r8) :: pu ! an estimated breakpoint at which the constant + ! coefficient of the quadratic term (styp=2) or + ! the cubic term (styp/=2) is 0 [Mpa] + real(r8) :: bcAtPu ! working local + real(r8) :: lambdaDeltaPuOnPu ! working local + real(r8) :: oneOnDeltaPu ! working local + real(r8) :: lambda ! working local + real(r8) :: alpha ! working local + real(r8) :: ps ! working local, 90% of entry pressure [Mpa] + + this%th_sat = params_in(1) + this%psi_sat = params_in(2) + this%beta = params_in(3) + styp = int(params_in(4)) + + + alpha = -1._r8/this%psi_sat + lambda = 1.0_r8/this%beta + ps = -0.9_r8/alpha + this%scch_ps = ps + ! Choose `pu` that forces `scch_b2 = 0`. + if(styp == 1) then + pu = findGu_SBC_zeroCoeff(lambda, 3, -alpha*ps) / (-alpha) + this%scch_pu = pu + + ! Find helper constants. + bcAtPu = (-alpha*pu)**(-lambda) + lambdaDeltaPuOnPu = lambda * (1.d0 - ps/pu) + oneOnDeltaPu = 1.d0 / (pu - ps) + + ! Store coefficients for cubic function. + this%scch_b2 = 0.d0 + this%scch_b3 = (2.d0 - bcAtPu*(2.d0+lambdaDeltaPuOnPu)) * oneOnDeltaPu * oneOnDeltaPu * oneOnDeltaPu + if( this%scch_b3 <= 0.d0 ) then + write(fates_log(),*) 'set_wrf_param_smooth_cch b3 <=0',pu,ps,alpha,lambda,oneOnDeltaPu,lambdaDeltaPuOnPu,bcAtPu,this%psi_sat + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + else + ! Choose `pu` that forces `sbc_b3 = 0`. + pu = findGu_SBC_zeroCoeff(lambda, 2, -alpha*ps) / (-alpha) + this%scch_pu = pu + + ! Find helper constants. + bcAtPu = (-alpha*pu)**(-lambda) + lambdaDeltaPuOnPu = lambda * (1.d0 - ps/pu) + oneOnDeltaPu = 1.d0 / (pu - ps) + + ! Store coefficients for cubic function. + this%scch_b2 = -(3.d0 - bcAtPu*(3.d0+lambdaDeltaPuOnPu)) * oneOnDeltaPu* oneOnDeltaPu + if( this%scch_b2 >= 0.d0 ) then + write(fates_log(),*) 'set_wrf_param_smooth_cch b2 <= 0' + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + this%scch_b3 = 0.d0 + + endif + return + end subroutine set_wkf_param_smooth_cch + + ! ===================================================================================== + + function get_thsat_smooth_cch(this) result(th_sat) + class(wrf_type_smooth_cch) :: this + real(r8) :: th_sat + + th_sat = this%th_sat + + end function get_thsat_smooth_cch + + ! ===================================================================================== + + function th_from_psi_smooth_cch(this,psi) result(th) + + class(wrf_type_smooth_cch) :: this + real(r8), intent(in) :: psi + real(r8) :: th + + real(r8) :: alpha + real(r8) :: lambda + real(r8) :: sat + real(r8) :: pc + real(r8) :: ps + real(r8) :: deltaPc + real(r8) :: dSe_dpc + + alpha = -1._r8/this%psi_sat + lambda = 1._r8/this%beta + pc = psi + + if( pc <= this%scch_pu ) then + ! Unsaturated full Brooks-Corey regime. + ! Here, `pc <= pu < 0`. + sat = (-alpha*pc)**(-lambda) + elseif( pc < this%scch_ps ) then + ! Cubic smoothing regime. + ! Here, `pu < pc < ps <= 0`. + deltaPc = pc - this%scch_ps + sat = 1.d0 + deltaPc*deltaPc*(this%scch_b2 + deltaPc*this%scch_b3) + else + ! Saturated regime. + ! Here, `pc >= ps`. + sat = 1.d0 + endif + th = sat * this%th_sat + + + return + end function th_from_psi_smooth_cch + + ! ===================================================================================== + + function psi_from_th_smooth_cch(this,th) result(psi) + + class(wrf_type_smooth_cch) :: this + real(r8),intent(in) :: th + real(r8) :: psi + + real(r8) :: sat_res + real(r8) :: alpha + real(r8) :: lambda + real(r8) :: Se + real(r8) :: sat + real(r8) :: pc + real(r8) :: xL + real(r8) :: xc + real(r8) :: xR + real(r8) :: resid + real(r8) :: dx + real(r8), parameter :: relTol = 1.d-9 + integer :: iter + + sat_res = 0._r8 + alpha = -1._r8/this%psi_sat + lambda = 1._r8/this%beta + + sat = max(1.e-6,th/this%th_sat) + if( sat < 1.d0 ) then + ! Find the `pc` that satisfies the unmodified Brooks-Corey function. + Se = sat + pc = -(Se**(-1.d0/lambda)) / alpha + if( pc > this%scch_pu ) then + ! Here, solution is in the cubic smoothing regime. + if( this%scch_b2 == 0.d0 ) then + ! Note know `b3 > 0`. + pc = this%scch_ps - ((1.d0 - Se) / this%scch_b3)**(1.d0/3.d0) + elseif( this%scch_b3 == 0.d0 ) then + ! Note know `b2 < 0`. + pc = this%scch_ps - sqrt((Se - 1.d0) / this%scch_b2) + else + ! Here, want to solve general cubic + ! `1 + b2*x^2 + b3*x^3 = Se` + ! where `x = pc - pu`. + ! Write as residual function + ! `r = x^2 * (b2 + b3*x) + (1 - Se)`. + ! Perform a Newton-Raphson search on `x`. + ! Have + ! `dr/dx = x*(2*b2 + 3*b3*x)` + ! And Newton-Raphson sets + ! `x[i+1] = x[i] - r[i]/(dr/dx[i])`. + ! Note that r{0} = 1 - Se > 0. + ! Therefore maintain the right bracket as having a positive + ! residual, and the left bracket as having a negative residual. + ! Note that it is possible, due to numerical effects with `pc` + ! very close to `pu`, to get an `xL` with a positive residual. + ! However, in this case also have `xc` very close to `xL`, and + ! the Newton-Raphson search will converge after a single step. + ! Therefore do not insert a special test to catch the case here. + xL = this%scch_pu - this%scch_ps + xR = 0.d0 + xc = pc - this%scch_ps + ! write(unit=*, fmt='("SatFunc_SatToPc_SBC: NR search:", + ! 6(a,g15.6))') & + ! ' pu', scch_pu, ' ps', scch_ps, & + ! ' xL', xL, ' xR', xR, & + ! ' r{xL}', xL*xL*(scch_b2 + scch_b3*xL) + + ! 1.d0 - Se, & + ! ' r{xR}', xR*xR*(scch_b2 + scch_b3*xR) + + ! 1.d0 - Se + + iter = 0 + dx = 1.e20_r8 ! something large + do while( abs(dx) >= -relTol*this%scch_pu ) + + ! Here, assume: + ! + Have a bracket on the root, between `xL` and `xR`. + ! + The residual `r{xL} < 0` and `r{xR} > 0`. + ! + Have a current guess `xc` at the root. However, that guess + ! might not lie in the bracket. + + iter=iter+1 + + ! Reset `xc` using bisection if necessary. + if( xc<=xL .or. xc>=xR ) then + ! write(unit=*, fmt='("Bisecting")') + xc = xL + 0.5d0*(xR - xL) + endif + + ! Find NR step. + dx = this%scch_b3 * xc + resid = xc*xc*(this%scch_b2 + dx) + 1.d0 - Se + dx = resid / (xc*(2.d0*this%scch_b2 + 3.d0*dx)) + + ! Update bracket. + if( resid > 0.d0 ) then + xR = xc + else + xL = xc + endif + + ! Take the Newton-Raphson step. + xc = xc - dx + ! write(unit=*, fmt='(6(a,g15.6))') & + ! ' xL', xL, ' xc', xc, ' xR', xR, & + ! ' r{xL}', xL*xL*(scch_b2 + scch_b3*xL) + + ! 1.d0 - Se, & + ! ' r{xc}', xc*xc*(scch_b2 + scch_b3*xc) + + ! 1.d0 - Se, & + ! ' r{xR}', xR*xR*(scch_b2 + scch_b3*xR) + + ! 1.d0 - Se + + if( iter>10000) then + write(fates_log(),*) "psi_from_th_smooth_cch iteration not converging" + call endrun(msg=errMsg(__FILE__, __LINE__)) + endif + enddo + + ! Here, have `xc = pc - ps`. + pc = xc + this%scch_ps + endif + endif + else + pc = 0.d0 + endif + psi = pc + + + end function psi_from_th_smooth_cch + + ! ===================================================================================== + + function dpsidth_from_th_smooth_cch(this,th) result(dpsidth) + + class(wrf_type_smooth_cch) :: this + real(r8),intent(in) :: th + real(r8) :: dpsidth + + + real(r8) :: pc + real(r8) :: sat + real(r8) :: dsat_dP + ! + ! !LOCAL VARIABLES: + real(r8) :: sat_res + real(r8) :: alpha + real(r8) :: lambda + real(r8) :: Se + real(r8) :: deltaPc + real(r8) :: dSe_dpc + + sat_res = 0._r8 + alpha = -1._r8/this%psi_sat + lambda = 1._r8/this%beta + + pc = 1._r8 * this%psi_from_th(th) + if( pc <= this%scch_pu ) then + ! Unsaturated full Brooks-Corey regime. + ! Here, `pc <= pu < 0`. + Se = (-alpha*pc)**(-lambda) + sat = sat_res + (1.d0 - sat_res)*Se + + dSe_dpc = -lambda*Se/pc + dsat_dp = (1.d0 - sat_res)*dSe_dpc + dpsidth = 1._r8/(dsat_dp * this%th_sat) + elseif( pc < this%scch_ps ) then + ! Cubic smoothing regime. + ! Here, `pu < pc < ps <= 0`. + deltaPc = pc - this%scch_ps + Se = 1.d0 + deltaPc*deltaPc*(this%scch_b2 + deltaPc*this%scch_b3) + sat = sat_res + (1.d0 - sat_res)*Se + + dSe_dpc = deltaPc*(2*this%scch_b2 + 3*deltaPc*this%scch_b3) + dsat_dp = (1.d0 - sat_res)*dSe_dpc + dpsidth = 1._r8/(dsat_dp * this%th_sat) + else + ! Saturated regime. + ! Here, `pc >= ps`. + + dpsidth = this%dpsidth_max + endif + + + end function dpsidth_from_th_smooth_cch + + ! ===================================================================================== + + function ftc_from_psi_smooth_cch(this,psi) result(ftc) + + class(wkf_type_smooth_cch) :: this + real(r8),intent(in) :: psi + real(r8) :: ftc + + real(r8) :: pc + real(r8) :: kr + real(r8) :: dkr_dP + ! + real(r8) :: sat_res + real(r8) :: alpha + real(r8) :: lambda + real(r8) :: Se + real(r8) :: deltaPc + real(r8) :: dSe_dpc + real(r8) :: dkr_dSe + + pc = psi + sat_res = 0._r8 + alpha = -1._r8/this%psi_sat + lambda = 1._r8/this%beta + + if( pc <= this%scch_pu ) then + ! Unsaturated full Brooks-Corey regime. + ! Here, `pc <= pu < 0`. + Se = (-alpha*pc)**(-lambda) + kr = Se ** (3._r8+2._r8/lambda) + + elseif( pc < this%scch_ps ) then + ! Cubic smoothing regime. + ! Here, `pu < pc < ps <= 0`. + deltaPc = pc - this%scch_ps + Se = 1.d0 + deltaPc*deltaPc*(this%scch_b2 + deltaPc*this%scch_b3) + kr = Se ** (3._r8+2._r8/lambda) + + else + ! Saturated regime. + ! Here, `pc >= ps`. + kr = 1.d0 + endif + ftc = max(kr, min_ftc) + + + end function ftc_from_psi_smooth_cch + + ! ==================================================================================== + + function dftcdpsi_from_psi_smooth_cch(this,psi) result(dftcdpsi) + + class(wkf_type_smooth_cch) :: this + real(r8),intent(in) :: psi + real(r8) :: dftcdpsi ! change in frac total cond wrt psi + + real(r8) :: pc + real(r8) :: kr + real(r8) :: dkr_dP + ! + real(r8) :: sat_res + real(r8) :: alpha + real(r8) :: lambda + real(r8) :: Se + real(r8) :: deltaPc + real(r8) :: dSe_dpc + real(r8) :: dkr_dSe + + pc = psi + sat_res = 0._r8 + alpha = -1._r8/this%psi_sat + lambda = 1._r8/this%beta + + if( pc <= this%scch_pu ) then + ! Unsaturated full Brooks-Corey regime. + ! Here, `pc <= pu < 0`. + Se = (-alpha*pc)**(-lambda) + + dSe_dpc = -lambda*Se/pc + + kr = Se ** (3.d0 + 2.d0/lambda) + + dkr_dSe = (3.d0 + 2.d0/lambda)*kr/Se + dkr_dp = dkr_dSe*dSe_dpc + elseif( pc < this%scch_ps ) then + ! Cubic smoothing regime. + ! Here, `pu < pc < ps <= 0`. + deltaPc = pc - this%scch_ps + Se = 1.d0 + deltaPc*deltaPc*(this%scch_b2 + deltaPc*this%scch_b3) + + dSe_dpc = deltaPc*(2*this%scch_b2 + 3*deltaPc*this%scch_b3) + + kr = Se ** (2.5d0 + 2.d0/lambda) + + dkr_dSe = (2.5d0 + 2.d0/lambda)*kr/Se + dkr_dp = dkr_dSe*dSe_dpc + else + ! Saturated regime. + ! Here, `pc >= ps`. + kr = 1.d0 + dkr_dP = 0.d0 + endif + dftcdpsi = dkr_dP + if(kr<=min_ftc) then + dftcdpsi = 0._r8 + endif + + + end function dftcdpsi_from_psi_smooth_cch + + + !------------------------------------------------------------------------ + ! Find `pu` that forces a coefficient of the smoothing cubic polynomial to zero. + ! Bisht et al. Geosci. Model Dev., 11, 4085–4102, 2018, coded in VSFM + ! + ! Work in terms of multipliers of `pc0`: + ! + ! + Argument `gs` satisfies `ps = gs*pc0`. + ! + Return `gu` such that `pu = gu*pc0`. + ! + ! Argument `AA`: + ! + ! + To set `b2 = 0`, let `A = 3`. + ! + To set `b3 = 0`, let `A = 2`. + ! + real(r8) function findGu_SBC_zeroCoeff(lambda, AA, gs) + ! + ! !DESCRIPTION: + ! + ! + implicit none + ! + ! !ARGUMENTS + real(r8) , intent(in) :: lambda + real(r8) , intent(in) :: gs + integer , intent(in) :: AA + ! + ! !LOCAL VARIABLES: + real(r8) :: guLeft, gu, guRight ! Bracketed search. + real(r8) :: deltaGu, resid, dr_dGu ! Newton-Raphson search. + real(r8) :: guInv, guToMinusLam, gsOnGu ! Helper variables. + real(r8), parameter :: relTol = 1.d-12 + integer :: iter + + ! Check arguments. + ! Note this is more for documentation than anything else-- this + ! fcn should only get used internally, by trusted callers. + if( lambda<=0.d0 .or. lambda>=2.d0 & + .or. (AA/=2 .and. AA/=3) & + .or. gs>=1.d0 .or. gs<0.d0 ) then + write(fates_log(),*) 'findGu_SBC_zeroCoeff: bad param' + call endrun(msg=errMsg(__FILE__, __LINE__)) + endif + + ! Approach: + ! + Bracketed Newton-Raphson search. + ! + Note expect `1 < gu <= gu{gs=0}`. + ! + Note if this was a critical inner loop, could try solving for + ! `gui == 1/gu`, rather than for `gu`, in order to avoid division. + ! Could also try using Ridder's method, since the residual here + ! has a strong exponential component. + + ! Initialize. + gu = (AA / (AA + lambda))**(-1.d0/lambda) ! Solution if `gs = 0`. + + ! Search for root, using bracketed Newton-Raphson. + ! Not necessary if `gs = 0`. + if( gs > 0.d0 ) then + guLeft = 1.d0 + guRight = gu + + ! Test for convergence. + ! Note this test implicitly also tests `resid == 0`. + iter = 0 + deltaGu=1.e20_r8 ! something large + do while( abs(deltaGu) >= relTol*abs(gu) ) + + ! Here, assume: + ! + Have an bracket on the root, between `guLeft` and `guRight`. + ! + The derivative `dr/d{gu} > 0`. + ! + The residual `r{guLeft} < 0`, and `r{guRight} > 0`. + ! + Have a current guess `gu` at the root. However, that guess + ! might not lie in the bracket (and does not at first iteration). + + iter=iter+1 + + ! Reset `gu` using bisection if necessary. + if( gu<=guLeft .or. gu>=guRight ) then + gu = guLeft + 0.5d0*(guRight - guLeft) + endif + + ! Find residual. + guInv = 1.d0 / gu + guToMinusLam = gu**(-lambda) ! Could also do `guInv**lambda`; not sure if any numerical consequences. + gsOnGu = gs * guInv + resid = AA - guToMinusLam*(AA + lambda - lambda*gsOnGu) + + ! Update bracket. + if( resid < 0.d0 ) then + guLeft = gu + else + guRight = gu + endif + + ! Find next guess using Newton-Raphson's method. + dr_dGu = (1.d0 + lambda) * (1.d0 - gsOnGu) + (AA - 1) + dr_dGu = lambda * guToMinusLam * guInv * dr_dGu + deltaGu = resid / dr_dGu + ! write(unit=*, fmt='("findGu_SBC_zeroCoeff, NR step: ", 6(a,g15.6))') & + ! 'guLeft', guLeft, 'gu', gu, 'guRight', guRight, & + ! 'deltaGu', deltaGu, 'resid', resid, 'dr_dGu', dr_dGu + gu = gu - deltaGu + + if( iter>10000) then + write(fates_log(),*) "findGu_SBC_zeroCoeff iteration not converging" + call endrun(msg=errMsg(__FILE__, __LINE__)) + endif + + enddo + endif + + ! Finish up. + ! Note assuming the last Newton-Raphson step landed in the bracket, + ! and had a smaller residual than either of the bracket points. This + ! seems a safe enough assumption, compared to cost of tracking residuals. + findGu_SBC_zeroCoeff = gu + if(gu /= gu) then + write(fates_log(),*)'gu = nan in findGu_SBC_zeroCoeff: ',AA,gs + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + + end function findGu_SBC_zeroCoeff + ! ===================================================================================== ! TFS style functions ! ===================================================================================== @@ -813,7 +1490,7 @@ subroutine set_wrf_param_tfs(this,params_in) this%pmedia = int(params_in(9)) call this%set_min_max(this%th_res,this%th_sat) - + return end subroutine set_wrf_param_tfs @@ -822,13 +1499,13 @@ end subroutine set_wrf_param_tfs function get_thsat_tfs(this) result(th_sat) class(wrf_type_tfs) :: this real(r8) :: th_sat - + th_sat = this%th_sat - + end function get_thsat_tfs - + ! ===================================================================================== - + function th_from_psi_tfs(this,psi) result(th) class(wrf_type_tfs) :: this @@ -860,9 +1537,8 @@ function th_from_psi_tfs(this,psi) result(th) ! The bisection scheme performs a search via method of bisection, ! we need to define bounds with which to start - lower = this%th_min - - upper = this%th_max + lower = this%th_min-1.e-9_r8 + upper = this%th_max+1.e-9_r8 call this%bisect_pv(lower, upper, psi, th) psi_check = this%psi_from_th(th) @@ -907,43 +1583,43 @@ function psi_from_th_tfs(this,th) result(psi) else th_corr = th * this%cap_corr - + ! Perform two rounds of quadratic smoothing, 1st smooth ! the elastic and capilary, and then smooth their ! combined with the caviation - + call solutepsi(th_corr,this%rwc_ft,this%th_sat,this%th_res,this%pinot,psi_sol) call pressurepsi(th_corr,this%rwc_ft,this%th_sat,this%th_res,this%pinot,this%epsil,psi_press) - + psi_elastic = psi_sol + psi_press - + if(this%pmedia == 1) then ! leaves have no capillary region in their PV curves - + psi_capelast = psi_elastic - + else if(this%pmedia <= 4) then ! sapwood has a capillary region - + call capillarypsi(th_corr,this%th_sat,this%cap_int,this%cap_slp,psi_capillary) - + b = -1._r8*(psi_capillary + psi_elastic) c = psi_capillary*psi_elastic psi_capelast = (-b - sqrt(b*b - 4._r8*quad_a1*c))/(2._r8*quad_a1) - + else write(fates_log(),*) 'TFS WRF was called for an inelligable porous media' call endrun(msg=errMsg(sourcefile, __LINE__)) - + end if !porous media - + ! Now lets smooth the result of capilary elastic with cavitation - + psi_cavitation = psi_sol b = -1._r8*(psi_capelast + psi_cavitation) c = psi_capelast*psi_cavitation - + psi = (-b + sqrt(b*b - 4._r8*quad_a2*c))/(2._r8*quad_a2) end if - + return end function psi_from_th_tfs @@ -983,62 +1659,62 @@ function dpsidth_from_th_tfs(this,th) result(dpsidth) else th_corr = th*this%cap_corr - + ! Perform two rounds of quadratic smoothing, 1st smooth ! the elastic and capilary, and then smooth their ! combined with the caviation - + call solutepsi(th_corr,this%rwc_ft,this%th_sat,this%th_res,this%pinot,psi_sol) call pressurepsi(th_corr,this%rwc_ft,this%th_sat,this%th_res,this%pinot,this%epsil,psi_press) - + call dsolutepsidth(th,this%th_sat,this%th_res,this%rwc_ft,this%pinot,dsol_dth) call dpressurepsidth(this%th_sat,this%th_res,this%rwc_ft,this%epsil,dpress_dth) - + delast_dth = dsol_dth + dpress_dth psi_elastic = psi_sol + psi_press - - + + if(this%pmedia == 1) then ! leaves have no capillary region in their PV curves - + psi_capelast = psi_elastic dcapelast_dth = delast_dth - + else if(this%pmedia <= 4) then ! sapwood has a capillary region - + call capillarypsi(th,this%th_sat,this%cap_int,this%cap_slp,psi_capillary) - + b = -1._r8*(psi_capillary + psi_elastic) c = psi_capillary*psi_elastic psi_capelast = (-b - sqrt(b*b - 4._r8*quad_a1*c))/(2._r8*quad_a1) - + call dcapillarypsidth(this%cap_slp,this%th_sat,dcap_dth) - + dbdth = -1._r8*(delast_dth + dcap_dth) dcdth = psi_elastic*dcap_dth + delast_dth*psi_capillary - - + + dcapelast_dth = 1._r8/(2._r8*quad_a1) * & (-dbdth - 0.5_r8*((b*b - 4._r8*quad_a1*c)**(-0.5_r8)) * & (2._r8*b*dbdth - 4._r8*quad_a1*dcdth)) - + else write(fates_log(),*) 'TFS WRF was called for an ineligible porous media' call endrun(msg=errMsg(sourcefile, __LINE__)) - + end if !porous media - + ! Now lets smooth the result of capilary elastic with cavitation - + psi_cavitation = psi_sol - + b = -1._r8*(psi_capelast + psi_cavitation) c = psi_capelast*psi_cavitation - + dcav_dth = dsol_dth - + dbdth = -1._r8*(dcapelast_dth + dcav_dth) dcdth = psi_capelast*dcav_dth + dcapelast_dth*psi_cavitation - + dpsidth = 1._r8/(2._r8*quad_a2)*(-dbdth + 0.5_r8*((b*b - 4._r8*quad_a2*c)**(-0.5_r8)) * & (2._r8*b*dbdth - 4._r8*quad_a2*dcdth)) end if @@ -1055,7 +1731,7 @@ function ftc_from_psi_tfs(this,psi) result(ftc) real(r8) :: ftc real(r8) :: psi_eff - psi_eff = min(0._r8,psi) + psi_eff = min(-nearzero,psi) ftc = max(min_ftc,1._r8/(1._r8 + (psi_eff/this%p50)**this%avuln)) @@ -1111,15 +1787,15 @@ subroutine solutepsi(th,rwc_ft,th_sat,th_res,pinot,psi) ! ----------------------------------------------------------------------------------- ! From eq 8, Christopherson et al: ! - ! psi = pino/RWC*, where RWC*=(rwc-rwc_res)/(rwc_ft-rwc_res) - ! psi = pino * (rwc_ft-rwc_res)/(rwc-rwc_res) + ! psi = pinot/RWC*, where RWC*=(rwc-rwc_res)/(rwc_ft-rwc_res) + ! psi = pinot * (rwc_ft-rwc_res)/(rwc-rwc_res) ! ! if rwc_res = th_res/th_sat ! - ! = pino * (rwc_ft - th_res/th_sat)/(th/th_sat - th_res/th_sat ) - ! = pino * (th_sat*rwc_ft - th_res)/(th - th_res) + ! = pinot * (rwc_ft - th_res/th_sat)/(th/th_sat - th_res/th_sat ) + ! = pinot * (th_sat*rwc_ft - th_res)/(th - th_res) ! ----------------------------------------------------------------------------------- - + psi = pinot * (th_sat*rwc_ft - th_res) / (th - th_res) return @@ -1147,7 +1823,7 @@ subroutine dsolutepsidth(th,th_sat,th_res,rwc_ft,pinot,dpsi_dth) ! psi = pinot * (th_sat*rwc_ft - th_res) * (th - th_res)^-1 ! dpsi_dth = -pinot * (th_sat*rwc_ft - th_res) * (th - th_res)^-2 ! ----------------------------------------------------------------------------------- - + dpsi_dth = -1._r8*pinot*(th_sat*rwc_ft - th_res )*(th - th_res)**(-2._r8) return @@ -1236,7 +1912,7 @@ subroutine dcapillarypsidth(cap_slp,th_sat,y) end subroutine dcapillarypsidth ! ===================================================================================== - + subroutine bisect_pv(this,lower, upper, psi, th) ! ! !DESCRIPTION: Bisection routine for getting the inverse of the plant PV curve. diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index a3389cdd61..5571adc089 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -5,18 +5,18 @@ module FatesPlantHydraulicsMod ! is available. Other methods of estimating plant hydraulics may become available in future ! releases. For now, please cite the following reference if this module is used to generate ! published research: - ! - ! Christoffersen, B.O., Gloor, M., Fauset, S., Fyllas, N. M., Galbraith, D. R., Baker, - ! T. R., Kruijt, B., Rowland, L., Fisher, R. A., Binks, O. J., Sevanto, S., Xu, C., Jansen, - ! S., Choat, B., Mencuccini, M., McDowell, N. G., Meir, P. Linking hydraulic traits to - ! tropical forest function in a size-structured and trait-driven model (TFS~v.1-Hydro). - ! Geoscientific Model Development, 9(11), 2016, pp: 4227-4255, + ! + ! Christoffersen, B.O., Gloor, M., Fauset, S., Fyllas, N. M., Galbraith, D. R., Baker, + ! T. R., Kruijt, B., Rowland, L., Fisher, R. A., Binks, O. J., Sevanto, S., Xu, C., Jansen, + ! S., Choat, B., Mencuccini, M., McDowell, N. G., Meir, P. Linking hydraulic traits to + ! tropical forest function in a size-structured and trait-driven model (TFS~v.1-Hydro). + ! Geoscientific Model Development, 9(11), 2016, pp: 4227-4255, ! https://www.geosci-model-dev.net/9/4227/2016/, DOI = 10.5194/gmd-9-4227-2016. ! ! WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ! - ! PLANT HYDRAULICS IS AN EXPERIMENTAL OPTION THAT IS STILL UNDERGOING TESTING. - ! + ! PLANT HYDRAULICS IS AN EXPERIMENTAL OPTION THAT IS STILL UNDERGOING TESTING. + ! ! WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ! ! ============================================================================================== @@ -47,7 +47,9 @@ module FatesPlantHydraulicsMod use EDParamsMod , only : hydr_kmax_rsurf2 use EDParamsMod , only : hydr_psi0 use EDParamsMod , only : hydr_psicap - + use EDParamsMod , only : hydr_htftype_node + use EDParamsMod , only : hydr_solver_type + use EDTypesMod , only : ed_site_type use EDTypesMod , only : ed_patch_type use EDTypesMod , only : ed_cohort_type @@ -65,8 +67,9 @@ module FatesPlantHydraulicsMod use FatesAllometryMod, only : bleaf use FatesAllometryMod, only : bsap_allom use FatesAllometryMod, only : CrownDepth - use FatesAllometryMod , only : set_root_fraction - use FatesHydraulicsMemMod, only: use_2d_hydrosolve + use FatesHydraulicsMemMod, only: hydr_solver_1DTaylor + use FatesHydraulicsMemMod, only: hydr_solver_2DNewton + use FatesHydraulicsMemMod, only: hydr_solver_2DPicard use FatesHydraulicsMemMod, only: ed_site_hydr_type use FatesHydraulicsMemMod, only: ed_cohort_hydr_type use FatesHydraulicsMemMod, only: n_hypool_plant @@ -85,17 +88,15 @@ module FatesPlantHydraulicsMod use FatesHydraulicsMemMod, only: aroot_p_media use FatesHydraulicsMemMod, only: rhiz_p_media use FatesHydraulicsMemMod, only: nlevsoi_hyd_max - use FatesHydraulicsMemMod, only: cohort_recruit_water_layer - use FatesHydraulicsMemMod, only: recruit_water_avail_layer use FatesHydraulicsMemMod, only: rwccap, rwcft - use FatesHydraulicsMemMod, only: ignore_layer1 - + + use PRTGenericMod, only : carbon12_element use PRTGenericMod, only : leaf_organ, fnrt_organ, sapw_organ use PRTGenericMod, only : store_organ, repro_organ, struct_organ use PRTGenericMod, only : num_elements use PRTGenericMod, only : element_list - + use clm_time_manager , only : get_step_size, get_nstep use EDPftvarcon, only : EDPftvarcon_inst @@ -106,6 +107,7 @@ module FatesPlantHydraulicsMod use FatesHydroWTFMod, only : wkf_arr_type use FatesHydroWTFMod, only : wrf_type, wrf_type_vg, wrf_type_cch, wrf_type_tfs use FatesHydroWTFMod, only : wkf_type, wkf_type_vg, wkf_type_cch, wkf_type_tfs + use FatesHydroWTFMod, only : wrf_type_smooth_cch, wkf_type_smooth_cch ! CIME Globals @@ -120,22 +122,22 @@ module FatesPlantHydraulicsMod ! 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; + ! 1 => use BC hydraulics; ! 2 => use CX hydraulics ! The following options are temporarily unavailable (RGK 09-06-19) ! ---------------------------------------------------------------------------------- ! logical, public :: do_dqtopdth_leaf = .false. ! should a nonzero dqtopdth_leaf - ! term be applied to the plant + ! term be applied to the plant ! hydraulics numerical solution? - ! logical, public :: do_dyn_xylemrefill = .false. ! should the dynamics of xylem refilling - ! (i.e., non-instantaneous) be considered + ! logical, public :: do_dyn_xylemrefill = .false. ! should the dynamics of xylem refilling + ! (i.e., non-instantaneous) be considered ! within plant hydraulics? - ! logical, public :: do_kbound_upstream = .true. ! should the hydraulic conductance at the - ! boundary between nodes be taken to be a - ! function of the upstream loss of - ! conductivity (flc)? + ! logical, public :: do_kbound_upstream = .true. ! should the hydraulic conductance at the + ! boundary between nodes be taken to be a + ! function of the upstream loss of + ! conductivity (flc)? ! DO NOT TURN THIS ON. LEAVING THIS ONLY IF THE HLMS START HAVING ! TROUBLE RESPONDING TO SUPERSATURATION @@ -144,19 +146,19 @@ module FatesPlantHydraulicsMod ! past saturation, should we attempt to help ! fix the situation by assigning some ! of the water to a runoff term? - - logical, public :: do_growthrecruiteffects = .true. ! should size- or root length-dependent - ! hydraulic properties and states be - ! updated every day when trees grow or + + logical, public :: do_growthrecruiteffects = .true. ! should size- or root length-dependent + ! hydraulic properties and states be + ! updated every day when trees grow or ! when recruitment happens? ! If this is set to true, then the conductance over a path between nodes, is defined - ! by the side of the path with higher potential only. + ! by the side of the path with higher potential only. logical, parameter :: do_upstream_k = .true. - + logical :: do_parallel_stem = .true. ! If this mode is active, we treat the conduit through ! the plant (in 1D solves) as closed from root layer ! to the stomata. The effect of this, is that @@ -166,14 +168,13 @@ module FatesPlantHydraulicsMod ! proceeds over the entire time-step. - ! These switches are for developers who which to understand if there simulations ! are ever entering regimes where water contents go negative (yes physically impossible) ! or water pressures exceed that at saturation (maybe, maybe not likely) ! These situations are possible/likely due to the nature of the constant flux boundary condition ! of transpiration, due to the loosely-coupled nature of the hydro-land-energy-photosynthesis ! system - + logical, parameter :: trap_neg_wc = .false. logical, parameter :: trap_supersat_psi = .false. @@ -181,9 +182,9 @@ module FatesPlantHydraulicsMod ! (mm = kg/m2) real(r8), parameter :: thsat_buff = 0.001_r8 ! Ensure that this amount of buffer - ! is left between soil moisture and saturation [m3/m3] - ! (if we are going to help purge super-saturation) - + ! is left between soil moisture and saturation [m3/m3] + ! (if we are going to help purge super-saturation) + logical,parameter :: debug = .false. ! flag to report warning in hydro @@ -191,40 +192,56 @@ module FatesPlantHydraulicsMod __FILE__ - integer, public, parameter :: van_genuchten_type = 1 - integer, public, parameter :: campbell_type = 2 - integer, public, parameter :: tfs_type = 3 - - integer, parameter :: plant_wrf_type = tfs_type - integer, parameter :: plant_wkf_type = tfs_type + ! These index flags specify which pressure-volumen and pressure + ! conductivity relationship are available. + ! For plants: Users can option between useing tfs and van_genuchten + ! by specifying their choice in the parameter file, + ! with the model parameter hydr_htftype_node, + ! the value should be 1 for TFS or 2 for VG (as shown below). + ! Campbell, could technically be used, but the parameters for + ! that hypothesis are not in the parameter file, so it not currently available. + ! For soil: The soil hypothesis should follow the hypothesis for water transfer + ! in the Host Land Model. At this time campbell is the default for both + ! ELM and ALM. However, if alternatives arise (like VG), we still need to write + ! interface routines to transfer over parameters. Right now we just hard-code + ! the use of campbell_type for the soil (see a few lines below). + + integer, public, parameter :: van_genuchten_type = 2 + integer, public, parameter :: campbell_type = 3 + integer, public, parameter :: smooth1_campbell_type = 31 + integer, public, parameter :: smooth2_campbell_type = 32 + integer, public, parameter :: tfs_type = 1 + integer, parameter :: soil_wrf_type = campbell_type integer, parameter :: soil_wkf_type = campbell_type - - + + ! Define the global object that holds the water retention functions ! for plants of each different porous media type, and plant functional type - + class(wrf_arr_type),pointer :: wrf_plant(:,:) - + ! Define the global object that holds the water conductance functions ! for plants of each different porous media type, and plant functional type - + class(wkf_arr_type), pointer :: wkf_plant(:,:) ! Testing parameters for Van Genuchten soil WRTs ! unused unless van_genuchten_type is selected, also ! it would be much better to use the native parameters passed in ! from the HLM's soil model - real(r8), parameter :: alpha_vg = 0.001_r8 - real(r8), parameter :: th_sat_vg = 0.65_r8 - real(r8), parameter :: th_res_vg = 0.15_r8 - real(r8), parameter :: psd_vg = 2.7_r8 - real(r8), parameter :: tort_vg = 0.5_r8 - + real(r8), parameter :: alpha_vg = 0.001_r8 + real(r8), parameter :: th_sat_vg = 0.65_r8 + real(r8), parameter :: th_res_vg = 0.15_r8 + real(r8), parameter :: psd_vg = 2.7_r8 + real(r8), parameter :: m_vg = 0.62963_r8 + real(r8), parameter :: soil_tort_vg = 0.5_r8 + real(r8), parameter :: plant_tort_vg = 0.0_r8 + ! The maximum allowable water balance error over a plant-soil continuum - ! for a given step [kgs] (0.1 mg) - real(r8), parameter :: max_wb_step_err = 1.e-7_r8 - + ! for a given step [kgs] (2 mg) + real(r8), parameter :: max_wb_step_err = 2.e-6_r8 ! original is 1.e-7_r8, Junyan changed to 2.e-6_r8 + ! ! !PUBLIC MEMBER FUNCTIONS: public :: AccumulateMortalityWaterStorage @@ -243,7 +260,6 @@ module FatesPlantHydraulicsMod public :: UpdatePlantPsiFTCFromTheta public :: InitPlantHydStates public :: UpdateSizeDepRhizHydProps - public :: UpdateSizeDepRhizHydStates public :: RestartHydrStates public :: SavePreviousCompartmentVolumes public :: SavePreviousRhizVolumes @@ -253,6 +269,10 @@ module FatesPlantHydraulicsMod public :: ConstrainRecruitNumber public :: InitHydroGlobals + ! RGK 12-2021: UpdateSizeDepRhizHydStates was removed + ! this code can be found in tags prior to + ! sci.1.52.0_api.20.0.0 + !------------------------------------------------------------------------------ ! 01/18/16: Created by Brad Christoffersen ! 02/xx/17: Refactoring by Ryan Knox and Brad Christoffersen @@ -294,7 +314,7 @@ end subroutine Hydraulics_Drive subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ! It is assumed that the following state variables have been read in by - ! the restart machinery. + ! the restart machinery. ! ! co_hydr%th_ag ! co_hydr%th_troot @@ -317,31 +337,37 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ! locals ! ---------------------------------------------------------------------------------- ! LL pointers - type(ed_patch_type),pointer :: cpatch ! current patch - type(ed_cohort_type),pointer :: ccohort ! current cohort - type(ed_cohort_hydr_type),pointer :: ccohort_hydr - type(ed_site_hydr_type),pointer :: csite_hydr - integer :: s ! site loop counter - integer :: j ! soil layer index - integer :: j_bc ! soil layer index of boundary condition - class(wrf_type_vg), pointer :: wrf_vg - class(wkf_type_vg), pointer :: wkf_vg - class(wrf_type_cch), pointer :: wrf_cch - class(wkf_type_cch), pointer :: wkf_cch + type(ed_patch_type),pointer :: cpatch ! current patch + type(ed_cohort_type),pointer :: ccohort ! current cohort + type(ed_cohort_hydr_type),pointer :: ccohort_hydr + type(ed_site_hydr_type),pointer :: csite_hydr + integer :: s ! site loop counter + integer :: j ! soil layer index + integer :: j_bc ! soil layer index of boundary condition + class(wrf_type_vg), pointer :: wrf_vg + class(wkf_type_vg), pointer :: wkf_vg + class(wrf_type_cch), pointer :: wrf_cch + class(wkf_type_cch), pointer :: wkf_cch + class(wrf_type_smooth_cch), pointer :: wrf_smooth_cch + class(wkf_type_smooth_cch), pointer :: wkf_smooth_cch + real(r8) :: watsat ! Mean wsat across soil layers contributing to current root layer + real(r8) :: sucsat ! Mean sucsat across soil layers contributing to current root layer + real(r8) :: bsw ! Mean bsw across soil layers contributing to current root layer + do s = 1,nsites csite_hydr=>sites(s)%si_hydr - + cpatch => sites(s)%oldest_patch do while(associated(cpatch)) ccohort => cpatch%shortest - do while(associated(ccohort)) + do while(associated(ccohort)) ccohort_hydr => ccohort%co_hydr ! This calculates node heights - call UpdatePlantHydrNodes(ccohort_hydr,ccohort%pft,ccohort%hite, & + call UpdatePlantHydrNodes(ccohort,ccohort%pft,ccohort%hite, & sites(s)%si_hydr) ! This calculates volumes and lengths @@ -352,7 +378,7 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ! Since this is a newly initialized plant, we set the previous compartment-size ! equal to the ones we just calculated. - call SavePreviousCompartmentVolumes(ccohort_hydr) + call SavePreviousCompartmentVolumes(ccohort_hydr) ccohort => ccohort%taller enddo @@ -372,57 +398,107 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) ! -------------------------------------------------------------------------------- ! Initialize the Water Retention Functions ! ----------------------------------------------------------------------------------- - + select case(soil_wrf_type) case(van_genuchten_type) do j=1,sites(s)%si_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) allocate(wrf_vg) sites(s)%si_hydr%wrf_soil(j)%p => wrf_vg - call wrf_vg%set_wrf_param([alpha_vg, psd_vg, bc_in(s)%watsat_sisl(j_bc), th_res_vg]) + call wrf_vg%set_wrf_param([alpha_vg, psd_vg, m_vg, watsat, th_res_vg]) end do case(campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) allocate(wrf_cch) sites(s)%si_hydr%wrf_soil(j)%p => wrf_cch - call wrf_cch%set_wrf_param([bc_in(s)%watsat_sisl(j_bc), & - (-1.0_r8)*bc_in(s)%sucsat_sisl(j_bc)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & - bc_in(s)%bsw_sisl(j_bc)]) + call wrf_cch%set_wrf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw]) + end do + case(smooth1_campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + allocate(wrf_smooth_cch) + sites(s)%si_hydr%wrf_soil(j)%p => wrf_smooth_cch + call wrf_smooth_cch%set_wrf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw,1._r8]) + end do + case(smooth2_campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + allocate(wrf_smooth_cch) + sites(s)%si_hydr%wrf_soil(j)%p => wrf_smooth_cch + call wrf_smooth_cch%set_wrf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw,2._r8]) end do case(tfs_type) write(fates_log(),*) 'TFS water retention curves not available for soil' call endrun(msg=errMsg(sourcefile, __LINE__)) + case default + write(fates_log(),*) 'undefined water retention type for soil:',soil_wrf_type + call endrun(msg=errMsg(sourcefile, __LINE__)) end select - + ! ----------------------------------------------------------------------------------- ! Initialize the Water Conductance (K) Functions ! ----------------------------------------------------------------------------------- - + select case(soil_wkf_type) case(van_genuchten_type) do j=1,sites(s)%si_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 allocate(wkf_vg) sites(s)%si_hydr%wkf_soil(j)%p => wkf_vg - call wkf_vg%set_wkf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg, tort_vg]) + call wkf_vg%set_wkf_param([alpha_vg, psd_vg, m_vg, th_sat_vg, th_res_vg, soil_tort_vg]) end do case(campbell_type) do j=1,sites(s)%si_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) allocate(wkf_cch) sites(s)%si_hydr%wkf_soil(j)%p => wkf_cch - call wkf_cch%set_wkf_param([bc_in(s)%watsat_sisl(j_bc), & - (-1.0_r8)*bc_in(s)%sucsat_sisl(j_bc)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & - bc_in(s)%bsw_sisl(j_bc)]) + call wkf_cch%set_wkf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw]) + end do + case(smooth1_campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + allocate(wkf_smooth_cch) + sites(s)%si_hydr%wkf_soil(j)%p => wkf_smooth_cch + call wkf_smooth_cch%set_wkf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw,1._r8]) + end do + case(smooth2_campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + allocate(wkf_smooth_cch) + sites(s)%si_hydr%wkf_soil(j)%p => wkf_smooth_cch + call wkf_smooth_cch%set_wkf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw,2._r8]) end do case(tfs_type) write(fates_log(),*) 'TFS conductance not used in soil' call endrun(msg=errMsg(sourcefile, __LINE__)) + case default + write(fates_log(),*) 'undefined water conductance type for soil:',soil_wkf_type + call endrun(msg=errMsg(sourcefile, __LINE__)) end select - - - ! Update static quantities related to the rhizosphere call UpdateSizeDepRhizVolLenCon(sites(s), bc_in(s)) @@ -435,9 +511,9 @@ subroutine RestartHydrStates(sites,nsites,bc_in,bc_out) call UpdateH2OVeg(sites(s),bc_out(s)) - + end do - + return end subroutine RestartHydrStates @@ -451,8 +527,8 @@ subroutine InitPlantHydStates(site, cohort) ! ccohort_hydr%z_node_troot(:) ! ccohort_hydr%z_node_aroot ! ccohort_hydr%z_node_ag - ! - ! !DESCRIPTION: + ! + ! !DESCRIPTION: ! ! !USES: @@ -461,7 +537,7 @@ subroutine InitPlantHydStates(site, cohort) type(ed_cohort_type), intent(inout), target :: cohort ! current cohort pointer ! ! !LOCAL VARIABLES: - type(ed_site_hydr_type), pointer :: site_hydr + type(ed_site_hydr_type), pointer :: csite_hydr type(ed_cohort_hydr_type), pointer :: cohort_hydr integer :: j,k ! layer and node indices integer :: ft ! functional type index @@ -470,8 +546,8 @@ subroutine InitPlantHydStates(site, cohort) real(r8) :: h_aroot_mean ! minimum total potential of absorbing roots real(r8), parameter :: psi_aroot_init = -0.2_r8 ! Initialize aroots with -0.2 MPa real(r8), parameter :: dh_dz = 0.02_r8 ! amount to decrease downstream - ! compartment total potentials [MPa/meter] - + ! compartment total potentials [MPa/meter] + ! In init mode = 1, set absorbing roots to -0.2 MPa ! = 2, use soil as starting point, match total potentials ! and then reduce plant compartment total potential by 1KPa @@ -480,8 +556,8 @@ subroutine InitPlantHydStates(site, cohort) integer, parameter :: init_mode = 2 class(wrf_arr_type),pointer :: wrfa,wrft class(wkf_arr_type),pointer :: wkfa,wkft - - site_hydr => site%si_hydr + + csite_hydr => site%si_hydr cohort_hydr => cohort%co_hydr ft = cohort%pft wrfa => wrf_plant(aroot_p_media,ft) @@ -492,37 +568,52 @@ subroutine InitPlantHydStates(site, cohort) ! Set abosrbing root if(init_mode == 2) then - -! h_aroot_mean = 0._r8 - do j=1, site_hydr%nlevrhiz - - ! Match the potential of the absorbing root to the inner rhizosphere shell - cohort_hydr%psi_aroot(j) = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1)) + ! h_aroot_mean = 0._r8 - ! Calculate the mean total potential (include height) of absorbing roots -! h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(j)) - - cohort_hydr%th_aroot(j) = wrfa%p%th_from_psi(cohort_hydr%psi_aroot(j)) - cohort_hydr%ftc_aroot(j) = wkfa%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) + do j=1, csite_hydr%nlevrhiz + + ! Checking apperance of roots. Only proceed if there are roots in that layer + if(cohort_hydr%l_aroot_layer(j) > nearzero) then + + ! Match the potential of the absorbing root to the inner rhizosphere shell + cohort_hydr%psi_aroot(j) = csite_hydr%wrf_soil(j)%p%psi_from_th(csite_hydr%h2osoi_liqvol_shell(j,1)) + + ! Calculate the mean total potential (include height) of absorbing roots + ! h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + + ! mpa_per_pa*denh2o*grav_earth*(-csite_hydr%zi_rhiz(j)) + + cohort_hydr%th_aroot(j) = max(wrfa%p%th_from_psi(cohort_hydr%psi_aroot(j)),wrfa%p%get_thmin()) + cohort_hydr%ftc_aroot(j) = wkfa%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) + else + cohort_hydr%psi_aroot(j) = psi_aroot_init + cohort_hydr%th_aroot(j) = 0 + + end if + end do - + else - - do j=1, site_hydr%nlevrhiz + + do j=1, csite_hydr%nlevrhiz cohort_hydr%psi_aroot(j) = psi_aroot_init ! Calculate the mean total potential (include height) of absorbing roots -! h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(j)) - cohort_hydr%th_aroot(j) = wrfa%p%th_from_psi(cohort_hydr%psi_aroot(j)) + ! h_aroot_mean = h_aroot_mean + cohort_hydr%psi_aroot(j) + + ! mpa_per_pa*denh2o*grav_earth*(-csite_hydr%zi_rhiz(j)) + cohort_hydr%th_aroot(j) = max(wrfa%p%th_from_psi(cohort_hydr%psi_aroot(j)), & + wrfa%p%get_thmin()) + cohort_hydr%ftc_aroot(j) = wkfa%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) end do end if - - !h_aroot_mean = h_aroot_mean/real(site_hydr%nlevrhiz,r8) - h_aroot_mean = minval(cohort_hydr%psi_aroot(:) + mpa_per_pa*denh2o*grav_earth*(-site_hydr%zi_rhiz(:))) + + !h_aroot_mean = h_aroot_mean/real(csite_hydr%nlevrhiz,r8) + + h_aroot_mean = minval(cohort_hydr%psi_aroot(:) + mpa_per_pa*denh2o*grav_earth* & + ( -csite_hydr%zi_rhiz(:)+0.5*csite_hydr%dz_rhiz(:) )) ! Get layer centers ! initialize plant water potentials with slight potential gradient (or zero) (dh/dz = C) - ! the assumption is made here that initial conditions for soil water will + ! the assumption is made here that initial conditions for soil water will ! be in (or at least close to) hydrostatic equilibrium as well, so that ! it doesn't matter which absorbing root layer the transporting root water @@ -533,7 +624,8 @@ subroutine InitPlantHydStates(site, cohort) cohort_hydr%psi_troot = h_aroot_mean - & mpa_per_pa*denh2o*grav_earth*cohort_hydr%z_node_troot - dh_dz - cohort_hydr%th_troot = wrft%p%th_from_psi(cohort_hydr%psi_troot) + cohort_hydr%th_troot = max(wrft%p%th_from_psi(cohort_hydr%psi_troot), & + wrft%p%get_thmin()) cohort_hydr%ftc_troot = wkft%p%ftc_from_psi(cohort_hydr%psi_troot) @@ -545,18 +637,19 @@ subroutine InitPlantHydStates(site, cohort) mpa_per_pa*denh2o*grav_earth*dz - dh_dz - cohort_hydr%th_ag(n_hypool_ag) = wrf_plant(stem_p_media,ft)%p%th_from_psi(cohort_hydr%psi_ag(n_hypool_ag)) + cohort_hydr%th_ag(n_hypool_ag) = max(wrf_plant(stem_p_media,ft)%p%get_thmin(), & + wrf_plant(stem_p_media,ft)%p%th_from_psi(cohort_hydr%psi_ag(n_hypool_ag))) cohort_hydr%ftc_ag(n_hypool_ag) = wkf_plant(stem_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_ag(n_hypool_ag)) - + do k=n_hypool_ag-1, 1, -1 dz = cohort_hydr%z_node_ag(k) - cohort_hydr%z_node_ag(k+1) cohort_hydr%psi_ag(k) = cohort_hydr%psi_ag(k+1) - & mpa_per_pa*denh2o*grav_earth*dz - & dh_dz - - cohort_hydr%th_ag(k) = wrf_plant(site_hydr%pm_node(k),ft)%p%th_from_psi(cohort_hydr%psi_ag(k)) - cohort_hydr%ftc_ag(k) = wkf_plant(site_hydr%pm_node(k),ft)%p%ftc_from_psi(cohort_hydr%psi_ag(k)) + cohort_hydr%th_ag(k) = max(wrf_plant(csite_hydr%pm_node(k),ft)%p%th_from_psi(cohort_hydr%psi_ag(k)), & + wrf_plant(csite_hydr%pm_node(k),ft)%p%get_thmin()) + cohort_hydr%ftc_ag(k) = wkf_plant(csite_hydr%pm_node(k),ft)%p%ftc_from_psi(cohort_hydr%psi_ag(k)) end do !initialize cohort-level btran @@ -565,11 +658,11 @@ subroutine InitPlantHydStates(site, cohort) !flc_gs_from_psi(cohort_hydr%psi_ag(1),cohort%pft) - + ! We do allow for positive pressures. ! But starting off with positive pressures is something we try to avoid if ( (cohort_hydr%psi_troot>0.0_r8) .or. & - any(cohort_hydr%psi_ag(:)>0._r8) .or. & + any(cohort_hydr%psi_ag(:)>0._r8) .or. & any(cohort_hydr%psi_aroot(:)>0._r8) ) then write(fates_log(),*) 'Initialized plant compartments with positive pressure?' write(fates_log(),*) 'psi troot: ',cohort_hydr%psi_troot @@ -578,14 +671,14 @@ subroutine InitPlantHydStates(site, cohort) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + end subroutine InitPlantHydStates - + ! ===================================================================================== subroutine UpdatePlantPsiFTCFromTheta(ccohort,csite_hydr) - + ! This subroutine updates the potential and the fractional ! of total conductivity based on the relative water ! content @@ -600,18 +693,18 @@ subroutine UpdatePlantPsiFTCFromTheta(ccohort,csite_hydr) type(ed_cohort_hydr_type), pointer :: ccohort_hydr - + ccohort_hydr => ccohort%co_hydr ft = ccohort%pft - + ! Update Psi and FTC in above-ground compartments ! ----------------------------------------------------------------------------------- do k = 1,n_hypool_leaf - ccohort_hydr%psi_ag(k) = wrf_plant(leaf_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) - ccohort_hydr%ftc_ag(k) = wkf_plant(leaf_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) + ccohort_hydr%psi_ag(k) = wrf_plant(leaf_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) + ccohort_hydr%ftc_ag(k) = wkf_plant(leaf_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) end do - do k = n_hypool_leaf+1, n_hypool_ag + do k = n_hypool_leaf+1, n_hypool_ag ccohort_hydr%psi_ag(k) = wrf_plant(stem_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) ccohort_hydr%ftc_ag(k) = wkf_plant(stem_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) end do @@ -622,7 +715,7 @@ subroutine UpdatePlantPsiFTCFromTheta(ccohort,csite_hydr) ! Update the Psi and FTC for the absorbing roots do j = 1, csite_hydr%nlevrhiz - ccohort_hydr%psi_aroot(j) = wrf_plant(aroot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_aroot(j)) + ccohort_hydr%psi_aroot(j) = wrf_plant(aroot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_aroot(j)) ccohort_hydr%ftc_aroot(j) = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_aroot(j)) end do @@ -633,7 +726,7 @@ end subroutine UpdatePlantPsiFTCFromTheta ! ===================================================================================== - subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) + subroutine UpdatePlantHydrNodes(ccohort,ft,plant_height,csite_hydr) ! -------------------------------------------------------------------------------- ! This subroutine calculates the nodal heights critical to hydraulics in the plant @@ -642,7 +735,7 @@ subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) ! Plant functional type ! Number of soil hydraulic layers ! - ! Outputs: cohort_hydr%z_node_ag(:) + ! Outputs: cohort_hydr%z_node_ag(:) ! %z_lower_ag(:) ! %z_upper_ag(:) ! %z_node_troot @@ -650,13 +743,14 @@ subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) ! -------------------------------------------------------------------------------- ! Arguments - type(ed_cohort_hydr_type), intent(inout) :: ccohort_hydr - integer,intent(in) :: ft ! plant functional type index - real(r8), intent(in) :: plant_height ! [m] - type(ed_site_hydr_type), intent(in) :: csite_hydr + type(ed_cohort_type), intent(inout) :: ccohort + integer,intent(in) :: ft ! plant functional type index + real(r8), intent(in) :: plant_height ! [m] + type(ed_site_hydr_type), intent(in) :: csite_hydr ! Locals + type(ed_cohort_hydr_type), pointer :: ccohort_hydr integer :: nlevrhiz ! number of rhizosphere layers real(r8) :: roota ! root profile parameter a zeng2001_crootfr real(r8) :: rootb ! root profile parameter b zeng2001_crootfr @@ -668,15 +762,21 @@ subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) real(r8) :: cumul_rf ! cumulative root distribution where depth is determined [-] real(r8) :: z_cumul_rf ! depth at which cumul_rf occurs [m] integer :: k ! Loop counter for compartments + real(r8) :: z_fr ! Maximum rooting depth of the plant [m] + ccohort_hydr => ccohort%co_hydr + + ! Crown Nodes ! in special case where n_hypool_leaf = 1, the node height of the canopy ! water pool is 1/2 the distance from the bottom of the canopy to the top of the tree roota = prt_params%fnrt_prof_a(ft) rootb = prt_params%fnrt_prof_b(ft) nlevrhiz = csite_hydr%nlevrhiz - call CrownDepth(plant_height,crown_depth) + !call CrownDepth(plant_height,ft,crown_depth) + crown_depth = min(plant_height,0.1_r8) + dz_canopy = crown_depth / real(n_hypool_leaf,r8) do k=1,n_hypool_leaf ccohort_hydr%z_lower_ag(k) = plant_height - dz_canopy*real(k,r8) @@ -696,13 +796,21 @@ subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) ccohort_hydr%z_lower_ag(k) = ccohort_hydr%z_upper_ag(k) - dz_stem enddo + call MaximumRootingDepth(ccohort%dbh,ft,csite_hydr%zi_rhiz(nlevrhiz),z_fr) + ! Transporting Root Node depth [m] (negative from surface) - call bisect_rootfr(roota, rootb, 0._r8, 1.E10_r8, & + call bisect_rootfr(roota, rootb, z_fr, 0._r8, 1.E10_r8, & 0.001_r8, 0.001_r8, 0.5_r8, z_cumul_rf) + + if(z_cumul_rf > csite_hydr%zi_rhiz(nlevrhiz) ) then + write(fates_log(),*) 'z_cumul_rf > zi_rhiz(nlevrhiz)?',z_cumul_rf,csite_hydr%zi_rhiz(nlevrhiz) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + z_cumul_rf = min(z_cumul_rf, abs(csite_hydr%zi_rhiz(nlevrhiz))) ccohort_hydr%z_node_troot = -z_cumul_rf - + return end subroutine UpdatePlantHydrNodes @@ -756,9 +864,9 @@ subroutine UpdateSizeDepPlantHydProps(currentSite,ccohort,bc_in) call SavePreviousCompartmentVolumes(ccohort_hydr) ! This updates all of the z_node positions - call UpdatePlantHydrNodes(ccohort_hydr,ft,ccohort%hite,currentSite%si_hydr) + call UpdatePlantHydrNodes(ccohort,ft,ccohort%hite,currentSite%si_hydr) - ! This updates plant compartment volumes, lengths and + ! This updates plant compartment volumes, lengths and ! maximum conductances. Make sure for already ! initialized vegetation, that SavePreviousCompartment ! volumes, and UpdatePlantHydrNodes is called prior to this. @@ -772,12 +880,12 @@ end subroutine UpdateSizeDepPlantHydProps ! ===================================================================================== - subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) + subroutine UpdatePlantHydrLenVol(ccohort,csite_hydr) ! ----------------------------------------------------------------------------------- ! This subroutine calculates two attributes of a plant: ! 1) the volumes of storage compartments in the plants - ! 2) the lenghts of the organs + ! 2) the lenghts of the organs ! These are not dependent on the hydraulic state of the ! plant, it is more about the structural characteristics and how much biomass ! is present in the different tissues. @@ -788,11 +896,11 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! Arguments type(ed_cohort_type),intent(inout) :: ccohort - type(ed_site_hydr_type),intent(in) :: site_hydr - + type(ed_site_hydr_type),intent(in) :: csite_hydr + type(ed_cohort_hydr_type),pointer :: ccohort_hydr ! Plant hydraulics structure integer :: j,k - integer :: ft ! Plant functional type index + integer :: ft ! Plant functional type index real(r8) :: roota ! root profile parameter a zeng2001_crootfr real(r8) :: rootb ! root profile parameter b zeng2001_crootfr real(r8) :: leaf_c ! Current amount of leaf carbon in the plant [kg] @@ -805,7 +913,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) real(r8) :: sla ! specific leaf area [cm2/g] real(r8) :: v_aroot_tot ! total compartment volume of all absorbing roots for cohort [m3] real(r8) :: l_aroot_tot ! total length of absorbing roots for cohrot [m] - real(r8) :: denleaf ! leaf dry mass per unit fresh leaf volume [kg/m3] + real(r8) :: denleaf ! leaf dry mass per unit fresh leaf volume [kg/m3] real(r8) :: a_sapwood ! sapwood area [m2] real(r8) :: a_sapwood_target ! sapwood cross-section area at reference height, at target biomass [m2] real(r8) :: sapw_c_target ! sapwood carbon, at target [kgC] @@ -815,41 +923,43 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) real(r8) :: crown_depth ! Depth of the plant's crown [m] real(r8) :: norm ! total root fraction used <1 integer :: nlevrhiz ! number of rhizosphere levels - - + real(r8) :: dbh ! the dbh of current cohort [cm] + real(r8) :: z_fr ! rooting depth of a cohort [cm] + ! We allow the transporting root to donate a fraction of its volume to the absorbing ! roots to help mitigate numerical issues due to very small volumes. This is the ! fraction the transporting roots donate to those layers real(r8), parameter :: t2aroot_vol_donate_frac = 0.65_r8 real(r8), parameter :: min_leaf_frac = 0.1_r8 ! Fraction of maximum leaf carbon that - ! we set as our lower cap on leaf volume + ! we set as our lower cap on leaf volume real(r8), parameter :: min_trim = 0.1_r8 ! The lower cap on trimming function used - ! to estimate maximum leaf carbon - + ! to estimate maximum leaf carbon + ccohort_hydr => ccohort%co_hydr ft = ccohort%pft - nlevrhiz = site_hydr%nlevrhiz - leaf_c = ccohort%prt%GetState(leaf_organ, carbon12_element) - sapw_c = ccohort%prt%GetState(sapw_organ, carbon12_element) - fnrt_c = ccohort%prt%GetState(fnrt_organ, carbon12_element) - struct_c = ccohort%prt%GetState(struct_organ, carbon12_element) + nlevrhiz = csite_hydr%nlevrhiz + leaf_c = ccohort%prt%GetState(leaf_organ, carbon12_element) + sapw_c = ccohort%prt%GetState(sapw_organ, carbon12_element) + fnrt_c = ccohort%prt%GetState(fnrt_organ, carbon12_element) + struct_c = ccohort%prt%GetState(struct_organ, carbon12_element) + roota = prt_params%fnrt_prof_a(ft) + rootb = prt_params%fnrt_prof_b(ft) - roota = prt_params%fnrt_prof_a(ft) - rootb = prt_params%fnrt_prof_b(ft) + ! Leaf Volumes ! ----------------------------------------------------------------------------------- ! NOTE: SLATOP currently does not use any vertical scaling functions ! but that may not be so forever. ie sla = slatop (RGK-082017) ! m2/gC * cm2/m2 -> cm2/gC - - sla = prt_params%slatop(ft) * cm2_per_m2 - + + sla = prt_params%slatop(ft) * cm2_per_m2 + ! empirical regression data from leaves at Caxiuana (~ 8 spp) - denleaf = -2.3231_r8*sla/prt_params%c2b(ft) + 781.899_r8 - + denleaf = -2.3231_r8*sla/prt_params%c2b(ft) + 781.899_r8 + ! Leaf volumes ! Note: Leaf volumes of zero is problematic for two reasons. Zero volumes create ! numerical difficulties, and they could also create problems when a leaf is trying @@ -863,7 +973,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! We also place a lower bound on how low the leaf volume is allowed to go, which is 10% ! of the plant's carrying capacity. - + ! [kgC] * [kg/kgC] / [kg/m3] -> [m3] ! Get the target, or rather, maximum leaf carrying capacity of plant @@ -875,12 +985,12 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ccohort_hydr%v_ag(1:n_hypool_leaf) = max(leaf_c,min_leaf_frac*leaf_c_target) * & prt_params%c2b(ft) / denleaf/ real(n_hypool_leaf,r8) end if - + ! Step sapwood volume ! ----------------------------------------------------------------------------------- - ! BOC...may be needed for testing/comparison w/ v_sapwood - ! kg / ( g cm-3 * cm3/m3 * kg/g ) -> m3 + ! BOC...may be needed for testing/comparison w/ v_sapwood + ! kg / ( g cm-3 * cm3/m3 * kg/g ) -> m3 ! v_stem = c_stem_biom / (prt_params%wood_density(ft) * kg_per_g * cm3_per_m3 ) ! calculate the sapwood cross-sectional area @@ -893,57 +1003,73 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! alternative cross section calculation ! a_sapwood = a_leaf_tot / ( 0.001_r8 + 0.025_r8 * ccohort%hite ) * 1.e-4_r8 - call CrownDepth(ccohort%hite,crown_depth) + !call CrownDepth(ccohort%hite,ft,crown_depth) + crown_depth = min(ccohort%hite,0.1_r8) z_stem = ccohort%hite - crown_depth v_sapwood = a_sapwood * z_stem ! + 0.333_r8*a_sapwood*crown_depth ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag) = v_sapwood / n_hypool_stem - ! Determine belowground biomass as a function of total (sapwood, heartwood, - ! leaf, fine root) biomass then subtract out the fine root biomass to get + ! Determine belowground biomass as a function of total (sapwood, heartwood, + ! leaf, fine root) biomass then subtract out the fine root biomass to get ! coarse (transporting) root biomass woody_bg_c = (1.0_r8-prt_params%allom_agb_frac(ft)) * (sapw_c + struct_c) - - v_troot = woody_bg_c * prt_params%c2b(ft) / & - (prt_params%wood_density(ft)*kg_per_g*cm3_per_m3) - - + + v_troot = woody_bg_c * prt_params%c2b(ft) / & + (prt_params%wood_density(ft)*kg_per_g*cm3_per_m3) + + ! Estimate absorbing root total length (all layers) ! SRL is in m/g ! [m] = [kgC]*1000[g/kg]*[kg/kgC]*[m/g] ! ------------------------------------------------------------------------------ l_aroot_tot = fnrt_c*g_per_kg*prt_params%c2b(ft)*EDPftvarcon_inst%hydr_srl(ft) - - + + ! Estimate absorbing root volume (all layers) ! ------------------------------------------------------------------------------ v_aroot_tot = pi_const * (EDPftvarcon_inst%hydr_rs2(ft)**2._r8) * l_aroot_tot - ! The transporting root donates some of its volume - ! to the layer-by-layer absorbing root (which is now a hybrid compartment) + ! (old method) The transporting root donates some of its volume + ! to the layer-by-layer absorbing root + ! (new method) Each compartment (absorbing & transporting) get 50% of the sum of both ! ------------------------------------------------------------------------------ - ccohort_hydr%v_troot = (1._r8-t2aroot_vol_donate_frac) * v_troot + !ccohort_hydr%v_troot = (1._r8-t2aroot_vol_donate_frac) * v_troot + + ccohort_hydr%v_troot = 0.5_r8*(v_troot + v_aroot_tot) ! Partition the total absorbing root lengths and volumes into the active soil layers ! We have a condition, where we may ignore the first layer ! ------------------------------------------------------------------------------ - - norm = 1._r8 - & - zeng2001_crootfr(roota, rootb,site_hydr%zi_rhiz(1)-site_hydr%dz_rhiz(1), site_hydr%zi_rhiz(nlevrhiz)) + ! Further, incorporate maximum rooting depth parameterization into these + ! calculations. + + + call MaximumRootingDepth(ccohort%dbh,ft,csite_hydr%zi_rhiz(nlevrhiz),z_fr) do j=1,nlevrhiz - - rootfr = norm*(zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j),site_hydr%zi_rhiz(nlevrhiz)) - & - zeng2001_crootfr(roota, rootb, site_hydr%zi_rhiz(j)-site_hydr%dz_rhiz(j),site_hydr%zi_rhiz(nlevrhiz))) - - ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot - - ! This is a hybrid absorbing root and transporting root volume - ccohort_hydr%v_aroot_layer(j) = rootfr*(v_aroot_tot + t2aroot_vol_donate_frac*v_troot) + + rootfr = zeng2001_crootfr(roota, rootb, csite_hydr%zi_rhiz(j),z_fr) - & + zeng2001_crootfr(roota, rootb, csite_hydr%zi_rhiz(j)-csite_hydr%dz_rhiz(j),z_fr) + + if(debug)then + write(fates_log(),*) 'check rooting depth of cohort ' + write(fates_log(),*) 'dbh: ',ccohort%dbh,' sice class: ',ccohort%size_class + write(fates_log(),*) 'csite_hydr%dz_rhiz(j) is: ', csite_hydr%dz_rhiz(j) + write(fates_log(),*) 'z_max cohort: ',z_fr + write(fates_log(),*) 'layer: ',j,' bottom depth (m): ',csite_hydr%zi_rhiz(j),' rooting fraction:',rootfr + write(fates_log(),*) 'End of Junyan check' + end if + + ccohort_hydr%l_aroot_layer(j) = rootfr*l_aroot_tot - end do + ! This is a hybrid absorbing root and transporting root volume + ! ccohort_hydr%v_aroot_layer(j) = rootfr*(v_aroot_tot + t2aroot_vol_donate_frac*v_troot) + ccohort_hydr%v_aroot_layer(j) = rootfr*0.5_r8*(v_aroot_tot + v_troot) + end do + return end subroutine UpdatePlantHydrLenVol @@ -951,7 +1077,7 @@ end subroutine UpdatePlantHydrLenVol subroutine UpdateSizeDepPlantHydStates(currentSite,ccohort) ! - ! !DESCRIPTION: + ! !DESCRIPTION: ! ! !USES: use FatesUtilsMod , only : check_var_real @@ -974,15 +1100,15 @@ subroutine UpdateSizeDepPlantHydStates(currentSite,ccohort) ccohort_hydr => ccohort%co_hydr FT = cCohort%pft csite_hydr =>currentSite%si_hydr - + associate(pm_node => currentSite%si_hydr%pm_node) - - ! MAYBE ADD A NAN CATCH? If UpdateSizeDepPlantHydProps() was not called twice prior to the first - ! time this routine is called for a new cohort, then v_ag_init(k) will be a nan. - ! It should be ok, but may be vulnerable if code is changed (RGK 02-2017) - ! UPDATE WATER CONTENTS (assume water for growth comes from within tissue itself - ! -- apply water mass conservation) + ! MAYBE ADD A NAN CATCH? If UpdateSizeDepPlantHydProps() was not called twice prior to the first + ! time this routine is called for a new cohort, then v_ag_init(k) will be a nan. + ! It should be ok, but may be vulnerable if code is changed (RGK 02-2017) + + ! UPDATE WATER CONTENTS (assume water for growth comes from within tissue itself + ! -- apply water mass conservation) do k=1,n_hypool_leaf if( ccohort_hydr%v_ag(k) > nearzero ) then @@ -990,9 +1116,9 @@ subroutine UpdateSizeDepPlantHydStates(currentSite,ccohort) ccohort_hydr%v_ag_init(k) /ccohort_hydr%v_ag(k) ccohort_hydr%th_ag(k) = constrain_water_contents(th_uncorr, small_theta_num, ft, leaf_p_media) else - th_uncorr = ccohort_hydr%th_ag(k) + th_uncorr = ccohort_hydr%th_ag(k) end if - + csite_hydr%h2oveg_growturn_err = csite_hydr%h2oveg_growturn_err + & denh2o*cCohort%n*AREA_INV*(ccohort_hydr%th_ag(k)-th_uncorr)*ccohort_hydr%v_ag(k) end do @@ -1011,513 +1137,684 @@ subroutine UpdateSizeDepPlantHydStates(currentSite,ccohort) csite_hydr%h2oveg_growturn_err = csite_hydr%h2oveg_growturn_err + & denh2o*cCohort%n*AREA_INV*(ccohort_hydr%th_troot-th_uncorr)*ccohort_hydr%v_troot - + do j=1,currentSite%si_hydr%nlevrhiz - th_uncorr = ccohort_hydr%th_aroot(j) * & - ccohort_hydr%v_aroot_layer_init(j)/ccohort_hydr%v_aroot_layer(j) - ccohort_hydr%th_aroot(j) = constrain_water_contents(th_uncorr, small_theta_num, ft, aroot_p_media) - - csite_hydr%h2oveg_growturn_err = csite_hydr%h2oveg_growturn_err + & - denh2o*cCohort%n*AREA_INV*(ccohort_hydr%th_aroot(j)-th_uncorr)*ccohort_hydr%v_aroot_layer(j) - + if (ccohort_hydr%v_aroot_layer(j) > nearzero) then + th_uncorr = ccohort_hydr%th_aroot(j) * & + ccohort_hydr%v_aroot_layer_init(j)/ccohort_hydr%v_aroot_layer(j) + ccohort_hydr%th_aroot(j) = constrain_water_contents(th_uncorr, small_theta_num, ft, aroot_p_media) + + csite_hydr%h2oveg_growturn_err = csite_hydr%h2oveg_growturn_err + & + denh2o*cCohort%n*AREA_INV*(ccohort_hydr%th_aroot(j)-th_uncorr)*ccohort_hydr%v_aroot_layer(j) + + end if enddo - end associate + end associate - end subroutine UpdateSizeDepPlantHydStates +end subroutine UpdateSizeDepPlantHydStates - ! ===================================================================================== +! ===================================================================================== - function constrain_water_contents(th_uncorr, delta, ft, pm_type) result(th_corr) +function constrain_water_contents(th_uncorr, delta, ft, pm_type) result(th_corr) - ! !ARGUMENTS: - real(r8) , intent(in) :: th_uncorr ! uncorrected water content (m3 m-3) - real(r8) , intent(in) :: delta - integer , intent(in) :: ft - integer , intent(in) :: pm_type - ! - ! !Local: - real(r8) :: thr ! residual water content (m3 m-3) - real(r8) :: ths ! saturated water content (m3 m-3) - ! - ! !RESULT - real(r8) :: th_corr ! corrected water content - ! - !------------------------------------------------------------------------ - ths = EDPftvarcon_inst%hydr_thetas_node(ft,pm_type) - thr = EDPftvarcon_inst%hydr_resid_node(ft,pm_type) - th_corr = max((thr+delta),min((ths-delta),th_uncorr)) + ! !ARGUMENTS: + real(r8) , intent(in) :: th_uncorr ! uncorrected water content (m3 m-3) + real(r8) , intent(in) :: delta + integer , intent(in) :: ft + integer , intent(in) :: pm_type + ! + ! !Local: + real(r8) :: thr ! residual water content (m3 m-3) + real(r8) :: ths ! saturated water content (m3 m-3) + ! + ! !RESULT + real(r8) :: th_corr ! corrected water content + ! + !------------------------------------------------------------------------ + ths = EDPftvarcon_inst%hydr_thetas_node(ft,pm_type) + thr = EDPftvarcon_inst%hydr_resid_node(ft,pm_type) + th_corr = max((thr+delta),min((ths-delta),th_uncorr)) - return + return - end function constrain_water_contents +end function constrain_water_contents - ! ===================================================================================== +! ===================================================================================== - subroutine CopyCohortHydraulics(newCohort, oldCohort) +subroutine CopyCohortHydraulics(newCohort, oldCohort) - ! Arguments - type(ed_cohort_type), intent(inout), target :: newCohort - type(ed_cohort_type), intent(inout), target :: oldCohort + ! Arguments + type(ed_cohort_type), intent(inout), target :: newCohort + type(ed_cohort_type), intent(inout), target :: oldCohort - ! Locals - type(ed_cohort_hydr_type), pointer :: ncohort_hydr - type(ed_cohort_hydr_type), pointer :: ocohort_hydr - - - ncohort_hydr => newCohort%co_hydr - ocohort_hydr => oldCohort%co_hydr - - ! Node heights - ncohort_hydr%z_node_ag = ocohort_hydr%z_node_ag - ncohort_hydr%z_upper_ag = ocohort_hydr%z_upper_ag - ncohort_hydr%z_lower_ag = ocohort_hydr%z_lower_ag - ncohort_hydr%z_node_troot = ocohort_hydr%z_node_troot - - ! Compartment kmax's - ncohort_hydr%kmax_petiole_to_leaf = ocohort_hydr%kmax_petiole_to_leaf - ncohort_hydr%kmax_stem_lower = ocohort_hydr%kmax_stem_lower - ncohort_hydr%kmax_stem_upper = ocohort_hydr%kmax_stem_upper - ncohort_hydr%kmax_troot_upper = ocohort_hydr%kmax_troot_upper - ncohort_hydr%kmax_troot_lower = ocohort_hydr%kmax_troot_lower - ncohort_hydr%kmax_aroot_upper = ocohort_hydr%kmax_aroot_upper - ncohort_hydr%kmax_aroot_lower = ocohort_hydr%kmax_aroot_lower - ncohort_hydr%kmax_aroot_radial_in = ocohort_hydr%kmax_aroot_radial_in - ncohort_hydr%kmax_aroot_radial_out = ocohort_hydr%kmax_aroot_radial_out - - ! Compartment volumes - ncohort_hydr%v_ag_init = ocohort_hydr%v_ag_init - ncohort_hydr%v_ag = ocohort_hydr%v_ag - ncohort_hydr%v_troot_init = ocohort_hydr%v_troot_init - ncohort_hydr%v_troot = ocohort_hydr%v_troot - ncohort_hydr%v_aroot_layer_init = ocohort_hydr%v_aroot_layer_init - ncohort_hydr%v_aroot_layer = ocohort_hydr%v_aroot_layer - ncohort_hydr%l_aroot_layer = ocohort_hydr%l_aroot_layer - - ! State Variables - ncohort_hydr%th_ag = ocohort_hydr%th_ag - ncohort_hydr%th_troot = ocohort_hydr%th_troot - ncohort_hydr%th_aroot = ocohort_hydr%th_aroot - ncohort_hydr%psi_ag = ocohort_hydr%psi_ag - ncohort_hydr%psi_troot = ocohort_hydr%psi_troot - ncohort_hydr%psi_aroot = ocohort_hydr%psi_aroot - ncohort_hydr%ftc_ag = ocohort_hydr%ftc_ag - ncohort_hydr%ftc_troot = ocohort_hydr%ftc_troot - ncohort_hydr%ftc_aroot = ocohort_hydr%ftc_aroot - - ! Other - ncohort_hydr%btran = ocohort_hydr%btran - ncohort_hydr%supsub_flag = ocohort_hydr%supsub_flag - ncohort_hydr%iterh1 = ocohort_hydr%iterh1 - ncohort_hydr%iterh2 = ocohort_hydr%iterh2 - ncohort_hydr%iterlayer = ocohort_hydr%iterlayer - ncohort_hydr%errh2o = ocohort_hydr%errh2o - + ! Locals + type(ed_cohort_hydr_type), pointer :: ncohort_hydr + type(ed_cohort_hydr_type), pointer :: ocohort_hydr - ! BC PLANT HYDRAULICS - flux terms - ncohort_hydr%qtop = ocohort_hydr%qtop - ncohort_hydr%is_newly_recruited = ocohort_hydr%is_newly_recruited + ncohort_hydr => newCohort%co_hydr + ocohort_hydr => oldCohort%co_hydr - end subroutine CopyCohortHydraulics + ! Node heights + ncohort_hydr%z_node_ag = ocohort_hydr%z_node_ag + ncohort_hydr%z_upper_ag = ocohort_hydr%z_upper_ag + ncohort_hydr%z_lower_ag = ocohort_hydr%z_lower_ag + ncohort_hydr%z_node_troot = ocohort_hydr%z_node_troot - ! ===================================================================================== - subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, newn) + ! Compartment kmax's + ncohort_hydr%kmax_petiole_to_leaf = ocohort_hydr%kmax_petiole_to_leaf + ncohort_hydr%kmax_stem_lower = ocohort_hydr%kmax_stem_lower + ncohort_hydr%kmax_stem_upper = ocohort_hydr%kmax_stem_upper + ncohort_hydr%kmax_troot_upper = ocohort_hydr%kmax_troot_upper + ncohort_hydr%kmax_troot_lower = ocohort_hydr%kmax_troot_lower + ncohort_hydr%kmax_aroot_upper = ocohort_hydr%kmax_aroot_upper + ncohort_hydr%kmax_aroot_lower = ocohort_hydr%kmax_aroot_lower + ncohort_hydr%kmax_aroot_radial_in = ocohort_hydr%kmax_aroot_radial_in + ncohort_hydr%kmax_aroot_radial_out = ocohort_hydr%kmax_aroot_radial_out + ! Compartment volumes + ncohort_hydr%v_ag_init = ocohort_hydr%v_ag_init + ncohort_hydr%v_ag = ocohort_hydr%v_ag + ncohort_hydr%v_troot_init = ocohort_hydr%v_troot_init + ncohort_hydr%v_troot = ocohort_hydr%v_troot + ncohort_hydr%v_aroot_layer_init = ocohort_hydr%v_aroot_layer_init + ncohort_hydr%v_aroot_layer = ocohort_hydr%v_aroot_layer + ncohort_hydr%l_aroot_layer = ocohort_hydr%l_aroot_layer - type(ed_cohort_type), intent(inout), target :: currentCohort ! current cohort - type(ed_cohort_type), intent(inout), target :: nextCohort ! next (donor) cohort - type(ed_site_type), intent(inout), target :: currentSite ! current site + ! State Variables + ncohort_hydr%th_ag = ocohort_hydr%th_ag + ncohort_hydr%th_troot = ocohort_hydr%th_troot + ncohort_hydr%th_aroot = ocohort_hydr%th_aroot + ncohort_hydr%psi_ag = ocohort_hydr%psi_ag + ncohort_hydr%psi_troot = ocohort_hydr%psi_troot + ncohort_hydr%psi_aroot = ocohort_hydr%psi_aroot + ncohort_hydr%ftc_ag = ocohort_hydr%ftc_ag + ncohort_hydr%ftc_troot = ocohort_hydr%ftc_troot + ncohort_hydr%ftc_aroot = ocohort_hydr%ftc_aroot - type(bc_in_type), intent(in) :: bc_in - real(r8), intent(in) :: newn + ! Other + ncohort_hydr%btran = ocohort_hydr%btran + ncohort_hydr%supsub_flag = ocohort_hydr%supsub_flag + ncohort_hydr%iterh1 = ocohort_hydr%iterh1 + ncohort_hydr%iterh2 = ocohort_hydr%iterh2 + ncohort_hydr%iterlayer = ocohort_hydr%iterlayer + ncohort_hydr%errh2o = ocohort_hydr%errh2o - ! !LOCAL VARIABLES: - type(ed_site_hydr_type), pointer :: site_hydr - type(ed_cohort_hydr_type), pointer :: ccohort_hydr ! current cohort hydraulics derived type - type(ed_cohort_hydr_type), pointer :: ncohort_hydr ! donor (next) cohort hydraulics d type - real(r8) :: vol_c1,vol_c2 ! Total water volume in the each cohort - integer :: j,k ! indices - integer :: ft - site_hydr => currentSite%si_hydr + ! BC PLANT HYDRAULICS - flux terms + ncohort_hydr%qtop = ocohort_hydr%qtop - ccohort_hydr => currentCohort%co_hydr - ncohort_hydr => nextCohort%co_hydr + ncohort_hydr%is_newly_recruited = ocohort_hydr%is_newly_recruited - ft = currentCohort%pft - - ! At this point in the call sequence, we can assume the fused cohort (currentCohort) has - ! and updated size, shape and biomass, make sure this is called after parteh, and the - ! dbh and height are uppdated +end subroutine CopyCohortHydraulics - ! Save the old volumes because we need the old volume to calculate the pre-fusion water - ! volume of each cohort - call SavePreviousCompartmentVolumes(ccohort_hydr) +! ===================================================================================== +subroutine FuseCohortHydraulics(currentSite,currentCohort, nextCohort, bc_in, newn) - ! This updates all of the z_node positions - call UpdatePlantHydrNodes(ccohort_hydr,ft,currentCohort%hite,site_hydr) - ! This updates plant compartment volumes, lengths and - ! maximum conductances. Make sure for already - ! initialized vegetation, that SavePreviousCompartment - ! volumes, and UpdatePlantHydrNodes is called prior to this. - call UpdatePlantHydrLenVol(currentCohort,site_hydr) - - - ! Conserve the total water volume + type(ed_cohort_type), intent(inout), target :: currentCohort ! current cohort + type(ed_cohort_type), intent(inout), target :: nextCohort ! next (donor) cohort + type(ed_site_type), intent(inout), target :: currentSite ! current site - do k=1,n_hypool_ag - vol_c1 = currentCohort%n*ccohort_hydr%th_ag(k)*ccohort_hydr%v_ag_init(k) - vol_c2 = nextCohort%n*ncohort_hydr%th_ag(k)*ncohort_hydr%v_ag(k) - ccohort_hydr%th_ag(k) = (vol_c1+vol_c2)/(ccohort_hydr%v_ag(k)*newn) - end do + type(bc_in_type), intent(in) :: bc_in + real(r8), intent(in) :: newn - vol_c1 = currentCohort%n*ccohort_hydr%th_troot*ccohort_hydr%v_troot_init - vol_c2 = nextCohort%n*ncohort_hydr%th_troot*ncohort_hydr%v_troot - ccohort_hydr%th_troot = (vol_c1+vol_c2)/(ccohort_hydr%v_troot*newn) + ! !LOCAL VARIABLES: + type(ed_site_hydr_type), pointer :: csite_hydr + type(ed_cohort_hydr_type), pointer :: ccohort_hydr ! current cohort hydraulics derived type + type(ed_cohort_hydr_type), pointer :: ncohort_hydr ! donor (next) cohort hydraulics d type + real(r8) :: vol_c1,vol_c2 ! Total water volume in the each cohort + integer :: j,k ! indices + integer :: ft - do j=1,site_hydr%nlevrhiz - vol_c1 = currentCohort%n*ccohort_hydr%th_aroot(j)*ccohort_hydr%v_aroot_layer_init(j) - vol_c2 = nextCohort%n*ncohort_hydr%th_aroot(j)*ncohort_hydr%v_aroot_layer(j) - ccohort_hydr%th_aroot(j) = (vol_c1+vol_c2)/(ccohort_hydr%v_aroot_layer(j)*newn) - end do - - ccohort_hydr%supsub_flag = 0 + csite_hydr => currentSite%si_hydr - ! Only save the iteration counters for the worse of the two cohorts - if(ncohort_hydr%iterh1 > ccohort_hydr%iterh1)then - ccohort_hydr%iterh1 = ncohort_hydr%iterh1 - ccohort_hydr%iterh2 = ncohort_hydr%iterh2 - ccohort_hydr%iterlayer = ncohort_hydr%iterlayer - end if + ccohort_hydr => currentCohort%co_hydr + ncohort_hydr => nextCohort%co_hydr - - do k=1,n_hypool_leaf - ccohort_hydr%psi_ag(k) = wrf_plant(leaf_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) - ccohort_hydr%ftc_ag(k) = wkf_plant(leaf_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) - end do + ft = currentCohort%pft - do k = n_hypool_leaf+1,n_hypool_ag - ccohort_hydr%psi_ag(k) = wrf_plant(stem_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) - ccohort_hydr%ftc_ag(k) = wkf_plant(stem_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) - end do + ! At this point in the call sequence, we can assume the fused cohort (currentCohort) has + ! and updated size, shape and biomass, make sure this is called after parteh, and the + ! dbh and height are uppdated - ccohort_hydr%psi_troot = wrf_plant(troot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_troot) - ccohort_hydr%ftc_troot = wkf_plant(troot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_troot) + ! Save the old volumes because we need the old volume to calculate the pre-fusion water + ! volume of each cohort + call SavePreviousCompartmentVolumes(ccohort_hydr) + + ! This updates all of the z_node positions + call UpdatePlantHydrNodes(currentCohort,ft,currentCohort%hite,csite_hydr) + + ! This updates plant compartment volumes, lengths and + ! maximum conductances. Make sure for already + ! initialized vegetation, that SavePreviousCompartment + ! volumes, and UpdatePlantHydrNodes is called prior to this. + call UpdatePlantHydrLenVol(currentCohort,csite_hydr) + + + ! Conserve the total water volume + + do k=1,n_hypool_ag + vol_c1 = currentCohort%n*ccohort_hydr%th_ag(k)*ccohort_hydr%v_ag_init(k) + vol_c2 = nextCohort%n*ncohort_hydr%th_ag(k)*ncohort_hydr%v_ag(k) + ccohort_hydr%th_ag(k) = (vol_c1+vol_c2)/(ccohort_hydr%v_ag(k)*newn) + end do - do j=1,site_hydr%nlevrhiz - ccohort_hydr%psi_aroot(j) = wrf_plant(aroot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_aroot(j)) - ccohort_hydr%ftc_aroot(j) = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_aroot(j)) - end do + vol_c1 = currentCohort%n*ccohort_hydr%th_troot*ccohort_hydr%v_troot_init + vol_c2 = nextCohort%n*ncohort_hydr%th_troot*ncohort_hydr%v_troot + ccohort_hydr%th_troot = (vol_c1+vol_c2)/(ccohort_hydr%v_troot*newn) + do j=1,csite_hydr%nlevrhiz + vol_c1 = currentCohort%n*ccohort_hydr%th_aroot(j)*ccohort_hydr%v_aroot_layer_init(j) + vol_c2 = nextCohort%n*ncohort_hydr%th_aroot(j)*ncohort_hydr%v_aroot_layer(j) + ccohort_hydr%th_aroot(j) = (vol_c1+vol_c2)/(ccohort_hydr%v_aroot_layer(j)*newn) + end do - ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) + ccohort_hydr%supsub_flag = 0 - ccohort_hydr%qtop = (currentCohort%n*ccohort_hydr%qtop + & - nextCohort%n*ncohort_hydr%qtop)/newn + ! Only save the iteration counters for the worse of the two cohorts + if(ncohort_hydr%iterh1 > ccohort_hydr%iterh1)then + ccohort_hydr%iterh1 = ncohort_hydr%iterh1 + ccohort_hydr%iterh2 = ncohort_hydr%iterh2 + ccohort_hydr%iterlayer = ncohort_hydr%iterlayer + end if - ccohort_hydr%errh2o = (currentCohort%n*ccohort_hydr%errh2o + & - nextCohort%n*ncohort_hydr%errh2o)/newn - return - end subroutine FuseCohortHydraulics + do k=1,n_hypool_leaf + ccohort_hydr%psi_ag(k) = wrf_plant(leaf_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) + ccohort_hydr%ftc_ag(k) = wkf_plant(leaf_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) + end do - ! ===================================================================================== - ! Initialization Routines - ! ===================================================================================== + do k = n_hypool_leaf+1,n_hypool_ag + ccohort_hydr%psi_ag(k) = wrf_plant(stem_p_media,ft)%p%psi_from_th(ccohort_hydr%th_ag(k)) + ccohort_hydr%ftc_ag(k) = wkf_plant(stem_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(k)) + end do - subroutine InitHydrCohort(currentSite,currentCohort) + ccohort_hydr%psi_troot = wrf_plant(troot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_troot) + ccohort_hydr%ftc_troot = wkf_plant(troot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_troot) - ! Arguments - type(ed_site_type), target :: currentSite - type(ed_cohort_type), target :: currentCohort - type(ed_cohort_hydr_type), pointer :: ccohort_hydr + do j=1,csite_hydr%nlevrhiz + ccohort_hydr%psi_aroot(j) = wrf_plant(aroot_p_media,ft)%p%psi_from_th(ccohort_hydr%th_aroot(j)) + ccohort_hydr%ftc_aroot(j) = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_aroot(j)) + end do - if ( hlm_use_planthydro.eq.ifalse ) return - allocate(ccohort_hydr) - currentCohort%co_hydr => ccohort_hydr - call ccohort_hydr%AllocateHydrCohortArrays(currentSite%si_hydr%nlevrhiz) - ccohort_hydr%is_newly_recruited = .false. + ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) - end subroutine InitHydrCohort + ccohort_hydr%qtop = (currentCohort%n*ccohort_hydr%qtop + & + nextCohort%n*ncohort_hydr%qtop)/newn - ! ===================================================================================== - subroutine DeallocateHydrCohort(currentCohort) + ccohort_hydr%errh2o = (currentCohort%n*ccohort_hydr%errh2o + & + nextCohort%n*ncohort_hydr%errh2o)/newn - ! Arguments - type(ed_cohort_type), target :: currentCohort - type(ed_cohort_hydr_type), pointer :: ccohort_hydr + return + end subroutine FuseCohortHydraulics - if ( hlm_use_planthydro.eq.ifalse ) return +! ===================================================================================== +! Initialization Routines +! ===================================================================================== - ccohort_hydr => currentCohort%co_hydr - call ccohort_hydr%DeAllocateHydrCohortArrays() - deallocate(ccohort_hydr) +subroutine InitHydrCohort(currentSite,currentCohort) - return - end subroutine DeallocateHydrCohort + ! Arguments + type(ed_site_type), target :: currentSite + type(ed_cohort_type), target :: currentCohort + type(ed_cohort_hydr_type), pointer :: ccohort_hydr - ! ===================================================================================== + if ( hlm_use_planthydro.eq.ifalse ) return + allocate(ccohort_hydr) + currentCohort%co_hydr => ccohort_hydr + call ccohort_hydr%AllocateHydrCohortArrays(currentSite%si_hydr%nlevrhiz) - subroutine InitHydrSites(sites,bc_in) + ccohort_hydr%is_newly_recruited = .false. - ! Arguments - type(ed_site_type),intent(inout),target :: sites(:) - type(bc_in_type),intent(in) :: bc_in(:) +end subroutine InitHydrCohort - ! Locals - integer :: nsites - integer :: s - integer :: j - integer :: jj - type(ed_site_hydr_type),pointer :: csite_hydr +! ===================================================================================== +subroutine DeallocateHydrCohort(currentCohort) + ! Arguments + type(ed_cohort_type), target :: currentCohort + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + if ( hlm_use_planthydro.eq.ifalse ) return - if ( hlm_use_planthydro.eq.ifalse ) return + ccohort_hydr => currentCohort%co_hydr + call ccohort_hydr%DeAllocateHydrCohortArrays() + deallocate(ccohort_hydr) - ! Initialize any derived hydraulics parameters + return +end subroutine DeallocateHydrCohort - nsites = ubound(sites,1) - do s=1,nsites - allocate(csite_hydr) - sites(s)%si_hydr => csite_hydr - if ( bc_in(s)%nlevsoil > nlevsoi_hyd_max ) then - write(fates_log(),*) 'The host land model has defined soil with' - write(fates_log(),*) bc_in(s)%nlevsoil,' layers, for one of its columns.' - write(fates_log(),*) 'Fates-hydro temporary array spaces with size' - write(fates_log(),*) 'nlevsoi_hyd_max = ',nlevsoi_hyd_max,' must be larger' - write(fates_log(),*) 'see main/FatesHydraulicsMemMod.F90' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if +! ===================================================================================== - ! Calculate the number of rhizosphere - ! layers used - if(ignore_layer1) then - csite_hydr%i_rhiz_t = 2 - csite_hydr%i_rhiz_b = bc_in(s)%nlevsoil - else - csite_hydr%i_rhiz_t = 1 - csite_hydr%i_rhiz_b = bc_in(s)%nlevsoil - end if - - csite_hydr%nlevrhiz = csite_hydr%i_rhiz_b-csite_hydr%i_rhiz_t+1 - call sites(s)%si_hydr%InitHydrSite(numpft,nlevsclass) - - jj=1 - do j=csite_hydr%i_rhiz_t,csite_hydr%i_rhiz_b - csite_hydr%zi_rhiz(jj) = bc_in(s)%zi_sisl(j) - csite_hydr%dz_rhiz(jj) = bc_in(s)%dz_sisl(j) - jj=jj+1 - end do - - end do +subroutine InitHydrSites(sites,bc_in) - end subroutine InitHydrSites + ! Arguments + type(ed_site_type),intent(inout),target :: sites(:) + type(bc_in_type),intent(in) :: bc_in(:) - ! =================================================================================== - subroutine HydrSiteColdStart(sites, bc_in )! , bc_out) + ! Locals + integer :: nsites + integer :: s + integer :: j + integer :: j_bc,j_t,j_b + integer,allocatable :: ns_per_rhiz(:) + integer :: ntoagg + type(ed_site_hydr_type),pointer :: csite_hydr + integer :: aggmeth ! Aggregation method + integer :: aggN ! Number of resulting rhizosphere layers + ! if using a scheme that uses aggN - ! Arguments - type(ed_site_type),intent(inout),target :: sites(:) - type(bc_in_type),intent(in) :: bc_in(:) + ! Different aggregation method flags, see explanation below + integer, parameter :: rhizlayer_aggmeth_none = 1 + integer, parameter :: rhizlayer_aggmeth_combine12 = 2 + integer, parameter :: rhizlayer_aggmeth_balN = 3 - ! Local - type(ed_site_hydr_type), pointer :: site_hydr - real(r8) :: smp ! matric potential temp - real(r8) :: h2osoi_liqvol ! liquid water content (m3/m3) - integer :: s - integer :: j,j_bc - integer :: nsites - integer :: nlevrhiz - class(wrf_type_vg), pointer :: wrf_vg - class(wkf_type_vg), pointer :: wkf_vg - class(wrf_type_cch), pointer :: wrf_cch - class(wkf_type_cch), pointer :: wkf_cch + if ( hlm_use_planthydro.eq.ifalse ) return + ! Initialize any derived hydraulics parameters - nsites = ubound(sites,1) + nsites = ubound(sites,1) + do s=1,nsites - do s = 1,nsites + allocate(csite_hydr) + sites(s)%si_hydr => csite_hydr + if ( bc_in(s)%nlevsoil > nlevsoi_hyd_max ) then + write(fates_log(),*) 'The host land model has defined soil with' + write(fates_log(),*) bc_in(s)%nlevsoil,' layers, for one of its columns.' + write(fates_log(),*) 'Fates-hydro temporary array spaces with size' + write(fates_log(),*) 'nlevsoi_hyd_max = ',nlevsoi_hyd_max,' must be larger' + write(fates_log(),*) 'see main/FatesHydraulicsMemMod.F90' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - site_hydr => sites(s)%si_hydr - nlevrhiz = site_hydr%nlevrhiz - - do j = 1,nlevrhiz - j_bc=j+site_hydr%i_rhiz_t-1 - h2osoi_liqvol = min(bc_in(s)%eff_porosity_sl(j_bc), & - bc_in(s)%h2o_liq_sisl(j_bc)/(site_hydr%dz_rhiz(j)*denh2o)) - - site_hydr%h2osoi_liqvol_shell(j,1:nshell) = h2osoi_liqvol - site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j_bc) - end do - + ! ---------------------------------------------------------------------------------- + ! Create the rhizosphere layers + ! + ! These layers are allowed to aggregate soil layers. Note that these layers + ! currently do not allow partial overlap of soil layers, the layer boundaries + ! should always match soil layer boundaries. We only allow root layers to contain + ! multiple soil layers. + ! + ! rhizlayer_aggmeth_none - perform no aggregation, root layers match + ! soil layers + ! + ! rhizlayer_aggmeth_combine12 - aggregate the 1st and 2nd layers, thats it + ! + ! rhizlayer_aggmeth_gt5cm - aggregate all layers that are thinner than 5cm + ! + ! rhizlayer_aggmeth_balN - aggregate all layers such that N layers are + ! left, balancing aggregations so that they are performed + ! in equal intervals over depth, which should maintain + ! the exponential layering + ! rhizlayer_aggmeth_eqN - aggregate all layers such that N layers are left, + ! but attempt to approach a more equal depth layering + ! rhizlayer_aggmeth_Nx - simply aggregate every N layers together + ! + ! where: N = aggN + ! ---------------------------------------------------------------------------------- + + + aggmeth = rhizlayer_aggmeth_combine12 + aggN = 10 + + select case(aggmeth) + + case(rhizlayer_aggmeth_none) - site_hydr%l_aroot_layer(1:site_hydr%nlevrhiz) = 0.0_r8 + csite_hydr%nlevrhiz = bc_in(s)%nlevsoil + call sites(s)%si_hydr%InitHydrSite(numpft,nlevsclass,hydr_solver_type,bc_in(s)%nlevsoil) + do j=1,csite_hydr%nlevrhiz + csite_hydr%map_r2s(j,1) = j + csite_hydr%map_r2s(j,2) = j + csite_hydr%zi_rhiz(j) = bc_in(s)%zi_sisl(j) + csite_hydr%dz_rhiz(j) = bc_in(s)%dz_sisl(j) + end do - ! -------------------------------------------------------------------------------- - ! Initialize water transfer functions - ! which include both water retention functions (WRFs) - ! as well as the water conductance (K) functions (WKFs) - ! But, this is only for soil! - ! -------------------------------------------------------------------------------- - ! Initialize the Water Retention Functions - ! ----------------------------------------------------------------------------------- + case(rhizlayer_aggmeth_combine12) - select case(soil_wrf_type) - case(van_genuchten_type) - do j=1,sites(s)%si_hydr%nlevrhiz - j_bc=j+site_hydr%i_rhiz_t-1 - allocate(wrf_vg) - site_hydr%wrf_soil(j)%p => wrf_vg - call wrf_vg%set_wrf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg]) - end do - case(campbell_type) - do j=1,site_hydr%nlevrhiz - j_bc=j+site_hydr%i_rhiz_t-1 - allocate(wrf_cch) - site_hydr%wrf_soil(j)%p => wrf_cch - call wrf_cch%set_wrf_param([bc_in(s)%watsat_sisl(j_bc), & - (-1.0_r8)*bc_in(s)%sucsat_sisl(j_bc)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & - bc_in(s)%bsw_sisl(j_bc)]) - end do - case(tfs_type) - write(fates_log(),*) 'TFS water retention curves not available for soil' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select + csite_hydr%nlevrhiz = max(1,bc_in(s)%nlevsoil-1) + call sites(s)%si_hydr%InitHydrSite(numpft,nlevsclass,hydr_solver_type,bc_in(s)%nlevsoil) + + csite_hydr%map_r2s(1,1) = 1 + j_bc = min(2,bc_in(s)%nlevsoil) ! this protects 1 soil layer + csite_hydr%map_r2s(1,2) = j_bc + csite_hydr%zi_rhiz(1) = bc_in(s)%zi_sisl(j_bc) + csite_hydr%dz_rhiz(1) = sum(bc_in(s)%dz_sisl(1:j_bc)) + + do j=2,csite_hydr%nlevrhiz + csite_hydr%map_r2s(j,1) = j+1 + csite_hydr%map_r2s(j,2) = j+1 + csite_hydr%zi_rhiz(j) = bc_in(s)%zi_sisl(j+1) + csite_hydr%dz_rhiz(j) = bc_in(s)%dz_sisl(j+1) + end do - ! ----------------------------------------------------------------------------------- - ! Initialize the Water Conductance (K) Functions - ! ----------------------------------------------------------------------------------- - - select case(soil_wkf_type) - case(van_genuchten_type) - do j=1,sites(s)%si_hydr%nlevrhiz - allocate(wkf_vg) - site_hydr%wkf_soil(j)%p => wkf_vg - call wkf_vg%set_wkf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg, tort_vg]) - end do - case(campbell_type) - do j=1,sites(s)%si_hydr%nlevrhiz - j_bc=j+site_hydr%i_rhiz_t-1 - allocate(wkf_cch) - site_hydr%wkf_soil(j)%p => wkf_cch - call wkf_cch%set_wkf_param([bc_in(s)%watsat_sisl(j_bc), & - (-1.0_r8)*bc_in(s)%sucsat_sisl(j_bc)*denh2o*grav_earth*mpa_per_pa*m_per_mm , & - bc_in(s)%bsw_sisl(j_bc)]) - end do - case(tfs_type) - write(fates_log(),*) 'TFS conductance not used in soil' + case(rhizlayer_aggmeth_balN) + + csite_hydr%nlevrhiz = min(aggN,bc_in(s)%nlevsoil) + call sites(s)%si_hydr%InitHydrSite(numpft,nlevsclass,hydr_solver_type,bc_in(s)%nlevsoil) + + ntoagg = int(ceiling(real(bc_in(s)%nlevsoil)/real(csite_hydr%nlevrhiz)-nearzero)) + + if(ntoagg<1)then + write(fates_log(),*) 'rhizosphere balancing method rhizlayer_aggmeth_balN' + write(fates_log(),*) 'is failing to get a starting estimate of soil layers per rhiz layers:',ntoagg call endrun(msg=errMsg(sourcefile, __LINE__)) - end select + end if - end do + ! This array defines the number of soil layers + ! in each rhiz layer, start off with a max value + ! then we incrementally work our way from bottom up + ! reducing this number, until the number of soil + ! layers in the array matches the total actual + + allocate(ns_per_rhiz(csite_hydr%nlevrhiz)) + ns_per_rhiz(:) = ntoagg - ! -------------------------------------------------------------------------------- - ! All other ed_Hydr_site_type variables are initialized elsewhere: - ! - ! init_patch() -> UpdateSizeDepRhizHydProps -> shellgeom() - ! this%v_shell - ! this%r_node_shell - ! this%r_out_shell - ! - ! init_patch() -> UpdateSizeDepRhizHydProps() - ! this%l_aroot_layer_init - ! this%l_aroot_1D - ! this%kmax_upper_shell - ! this%kmax_lower_shell - ! - ! hydraulics_bc() - ! this%supsub_flag - ! this%errh2o_hyd = ! hydraulics_bc - ! this%dwat_veg = ! hydraulics_bc - ! - ! ed_update_site() -> update_h2oveg() - ! this%h2oveg - ! -------------------------------------------------------------------------------- + do while( sum(ns_per_rhiz(:)) > bc_in(s)%nlevsoil ) + do j = csite_hydr%nlevrhiz,1,-1 + + ns_per_rhiz(j) = ns_per_rhiz(j) - 1 + if(sum(ns_per_rhiz(:))<=bc_in(s)%nlevsoil)then + exit + end if + if(ns_per_rhiz(j)==0)then + write(fates_log(),*) 'rhizosphere balancing method rhizlayer_aggmeth_balN' + write(fates_log(),*) 'produced a rhizosphere layer with 0 soil layers...exiting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do + end do - return - end subroutine HydrSiteColdStart + ! Assign the mapping + csite_hydr%map_r2s(1,1) = 1 + do j=1,csite_hydr%nlevrhiz-1 + j_t = csite_hydr%map_r2s(j,1) + j_b = j_t + ns_per_rhiz(j) - 1 + csite_hydr%map_r2s(j,2) = j_b + csite_hydr%map_r2s(j+1,1) = j_b + 1 + csite_hydr%zi_rhiz(j) = bc_in(s)%zi_sisl(j_b) + csite_hydr%dz_rhiz(j) = sum(bc_in(s)%dz_sisl(j_t:j_b)) + end do + j_t = csite_hydr%map_r2s(csite_hydr%nlevrhiz,1) + j_b = j_t + ns_per_rhiz(csite_hydr%nlevrhiz) - 1 + csite_hydr%map_r2s(csite_hydr%nlevrhiz,2) = j_b + csite_hydr%zi_rhiz(csite_hydr%nlevrhiz) = bc_in(s)%zi_sisl(j_b) + csite_hydr%dz_rhiz(csite_hydr%nlevrhiz) = sum(bc_in(s)%dz_sisl(j_t:j_b)) + + deallocate(ns_per_rhiz) - ! ===================================================================================== + case default + + write(fates_log(),*) 'You specified an undefined rhizosphere layer aggregation method' + write(fates_log(),*) 'aggmeth: ',aggmeth + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end select + + end do + +end subroutine InitHydrSites + +! =================================================================================== + +subroutine HydrSiteColdStart(sites, bc_in ) + + + ! Arguments + type(ed_site_type),intent(inout),target :: sites(:) + type(bc_in_type),intent(in) :: bc_in(:) + + ! Local + type(ed_site_hydr_type), pointer :: csite_hydr + real(r8) :: smp ! matric potential temp + real(r8) :: h2osoi_liqvol ! liquid water content (m3/m3) + real(r8) :: eff_por ! effective porosity (m3/m3) + real(r8) :: watsat,sucsat,bsw + integer :: s + integer :: j,j_t,j_b + integer :: nsites + integer :: nlevrhiz + class(wrf_type_vg), pointer :: wrf_vg + class(wkf_type_vg), pointer :: wkf_vg + class(wrf_type_cch), pointer :: wrf_cch + class(wkf_type_cch), pointer :: wkf_cch + class(wrf_type_smooth_cch), pointer :: wrf_smooth_cch + class(wkf_type_smooth_cch), pointer :: wkf_smooth_cch + + nsites = ubound(sites,1) + + do s = 1,nsites + + csite_hydr => sites(s)%si_hydr + nlevrhiz = csite_hydr%nlevrhiz + + do j = 1,nlevrhiz + j_t = csite_hydr%map_r2s(j,1) ! top soil layer matching rhiz layer + j_b = csite_hydr%map_r2s(j,2) ! bottom soil layer matching rhiz layer + eff_por = csite_hydr%AggBCToRhiz(bc_in(s)%eff_porosity_sl,j,bc_in(s)%dz_sisl) + + ! [kg/m2] / ([m] * [kg/m3]) = [m3/m3] + h2osoi_liqvol = min(eff_por, & + sum(bc_in(s)%h2o_liq_sisl(j_t:j_b))/(csite_hydr%dz_rhiz(j)*denh2o)) + csite_hydr%h2osoi_liqvol_shell(j,1:nshell) = h2osoi_liqvol + + end do + + + csite_hydr%l_aroot_layer(1:csite_hydr%nlevrhiz) = 0.0_r8 + + + ! -------------------------------------------------------------------------------- + ! Initialize water transfer functions + ! which include both water retention functions (WRFs) + ! as well as the water conductance (K) functions (WKFs) + ! But, this is only for soil! + ! -------------------------------------------------------------------------------- + ! Initialize the Water Retention Functions + ! ----------------------------------------------------------------------------------- + + select case(soil_wrf_type) + case(van_genuchten_type) + do j=1,sites(s)%si_hydr%nlevrhiz + allocate(wrf_vg) + csite_hydr%wrf_soil(j)%p => wrf_vg + call wrf_vg%set_wrf_param([alpha_vg, psd_vg, m_vg, th_sat_vg, th_res_vg]) + end do + case(campbell_type) + do j=1,csite_hydr%nlevrhiz + allocate(wrf_cch) + csite_hydr%wrf_soil(j)%p => wrf_cch + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + call wrf_cch%set_wrf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw]) + end do + case(smooth1_campbell_type) + do j=1,csite_hydr%nlevrhiz + allocate(wrf_smooth_cch) + csite_hydr%wrf_soil(j)%p => wrf_smooth_cch + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + call wrf_smooth_cch%set_wrf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw,1._r8]) + end do + case(smooth2_campbell_type) + do j=1,csite_hydr%nlevrhiz + allocate(wrf_smooth_cch) + csite_hydr%wrf_soil(j)%p => wrf_smooth_cch + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + call wrf_smooth_cch%set_wrf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw,2._r8]) + end do + case(tfs_type) + write(fates_log(),*) 'TFS water retention curves not available for soil' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + ! ----------------------------------------------------------------------------------- + ! Initialize the Water Conductance (K) Functions + ! ----------------------------------------------------------------------------------- + + select case(soil_wkf_type) + case(van_genuchten_type) + do j=1,sites(s)%si_hydr%nlevrhiz + allocate(wkf_vg) + csite_hydr%wkf_soil(j)%p => wkf_vg + call wkf_vg%set_wkf_param([alpha_vg, psd_vg, m_vg, th_sat_vg, th_res_vg, soil_tort_vg]) + end do + case(campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + allocate(wkf_cch) + csite_hydr%wkf_soil(j)%p => wkf_cch + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + call wkf_cch%set_wkf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw]) + end do + case(smooth1_campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + allocate(wkf_smooth_cch) + csite_hydr%wkf_soil(j)%p => wkf_smooth_cch + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + call wkf_smooth_cch%set_wkf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw,1._r8]) + end do + case(smooth2_campbell_type) + do j=1,sites(s)%si_hydr%nlevrhiz + allocate(wkf_smooth_cch) + csite_hydr%wkf_soil(j)%p => wkf_smooth_cch + watsat = csite_hydr%AggBCToRhiz(bc_in(s)%watsat_sisl,j,bc_in(s)%dz_sisl) + sucsat = csite_hydr%AggBCToRhiz(bc_in(s)%sucsat_sisl,j,bc_in(s)%dz_sisl) + bsw = csite_hydr%AggBCToRhiz(bc_in(s)%bsw_sisl,j,bc_in(s)%dz_sisl) + call wkf_smooth_cch%set_wkf_param([watsat, & + (-1.0_r8)*sucsat*denh2o*grav_earth*mpa_per_pa*m_per_mm , & + bsw,2._r8]) + end do + case(tfs_type) + write(fates_log(),*) 'TFS conductance not used in soil' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + end do + + ! -------------------------------------------------------------------------------- + ! All other ed_Hydr_site_type variables are initialized elsewhere: + ! + ! init_patch() -> UpdateSizeDepRhizHydProps -> shellgeom() + ! this%v_shell + ! this%r_node_shell + ! this%r_out_shell + ! + ! init_patch() -> UpdateSizeDepRhizHydProps() + ! this%l_aroot_layer_init + ! this%l_aroot_1D + ! this%kmax_upper_shell + ! this%kmax_lower_shell + ! + ! hydraulics_bc() + ! this%supsub_flag + ! this%errh2o_hyd = ! hydraulics_bc + ! this%dwat_veg = ! hydraulics_bc + ! + ! ed_update_site() -> update_h2oveg() + ! this%h2oveg + ! -------------------------------------------------------------------------------- + + return +end subroutine HydrSiteColdStart + +! ===================================================================================== subroutine UpdateH2OVeg(csite,bc_out,prev_site_h2o,icall) - ! ---------------------------------------------------------------------------------- - ! 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. - ! ---------------------------------------------------------------------------------- + ! ---------------------------------------------------------------------------------- + ! This subroutine is called following dynamics. After growth has been updated + ! there needs to be a re-assesment of the how much liquid water is bound in the + ! plants. This value is necessary for water balancing in the HLM. + ! ---------------------------------------------------------------------------------- - ! Arguments - type(ed_site_type), intent(inout), target :: csite - type(bc_out_type), intent(inout) :: bc_out + ! Arguments + type(ed_site_type), intent(inout), target :: csite + type(bc_out_type), intent(inout) :: bc_out - ! The total site water balance at a previous point in time. - ! In some cases, like during dynamics - ! we want to conserve total site water, so we check - - real(r8), intent(in),optional :: prev_site_h2o - integer, intent(in), optional :: icall + ! The total site water balance at a previous point in time. + ! In some cases, like during dynamics + ! we want to conserve total site water, so we check - - ! Locals - type(ed_cohort_type), pointer :: currentCohort - type(ed_patch_type), pointer :: currentPatch - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - type(ed_site_hydr_type), pointer :: csite_hydr - integer :: s - real(r8) :: balive_patch - integer :: nstep !number of time steps + real(r8), intent(in),optional :: prev_site_h2o + integer, intent(in), optional :: icall - !for debug only - nstep = get_nstep() + + ! Locals + type(ed_cohort_type), pointer :: currentCohort + type(ed_patch_type), pointer :: currentPatch + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + type(ed_site_hydr_type), pointer :: csite_hydr + integer :: s + real(r8) :: balive_patch + integer :: nstep !number of time steps + + !for debug only + nstep = get_nstep() bc_out%plant_stored_h2o_si = 0.0_r8 - if( hlm_use_planthydro.eq.ifalse ) return + if( hlm_use_planthydro.eq.ifalse ) return csite_hydr => csite%si_hydr - csite_hydr%h2oveg = 0.0_r8 + csite_hydr%h2oveg = 0.0_r8 currentPatch => csite%oldest_patch - do while(associated(currentPatch)) - currentCohort=>currentPatch%tallest - do while(associated(currentCohort)) - ccohort_hydr => currentCohort%co_hydr - !only account for the water for not newly recruit for mass balance - if(.not.ccohort_hydr%is_newly_recruited) then - csite_hydr%h2oveg = csite_hydr%h2oveg + & - (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - ccohort_hydr%th_troot*ccohort_hydr%v_troot + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o*currentCohort%n - endif - - currentCohort => currentCohort%shorter - enddo !cohort - currentPatch => currentPatch%younger - enddo !end patch loop - - csite_hydr%h2oveg = csite_hydr%h2oveg*AREA_INV - - ! Note that h2oveg_dead is incremented wherever we have litter fluxes - ! and it will be reduced via an evaporation term + do while(associated(currentPatch)) + currentCohort=>currentPatch%tallest + do while(associated(currentCohort)) + ccohort_hydr => currentCohort%co_hydr + !only account for the water for not newly recruit for mass balance + if(.not.ccohort_hydr%is_newly_recruited) then + csite_hydr%h2oveg = csite_hydr%h2oveg + & + (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & + ccohort_hydr%th_troot*ccohort_hydr%v_troot + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + denh2o*currentCohort%n + endif + + currentCohort => currentCohort%shorter + enddo !cohort + currentPatch => currentPatch%younger + enddo !end patch loop + + csite_hydr%h2oveg = csite_hydr%h2oveg*AREA_INV + + ! Note that h2oveg_dead is incremented wherever we have litter fluxes + ! and it will be reduced via an evaporation term ! growturn_err is a term to accomodate error in growth or - ! turnover. need to be improved for future(CX) + ! turnover. need to be improved for future(CX) bc_out%plant_stored_h2o_si = csite_hydr%h2oveg + csite_hydr%h2oveg_dead - & - csite_hydr%h2oveg_growturn_err - & - csite_hydr%h2oveg_hydro_err + csite_hydr%h2oveg_growturn_err - & + csite_hydr%h2oveg_hydro_err ! Perform a conservation check if desired if(present(prev_site_h2o)) then - + if(abs(bc_out%plant_stored_h2o_si-prev_site_h2o)>error_thresh ) then write(fates_log(),*) 'Total FATES site level water was not conserved during' write(fates_log(),*) 'a check where it was supposed to be conserved.' @@ -1528,3920 +1825,4600 @@ subroutine UpdateH2OVeg(csite,bc_out,prev_site_h2o,icall) write(fates_log(),*) 'diff: ',bc_out%plant_stored_h2o_si-prev_site_h2o call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + end if - return - end subroutine UpdateH2OVeg + return +end subroutine UpdateH2OVeg - !===================================================================================== - subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) +!===================================================================================== +subroutine RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) - ! ---------------------------------------------------------------------------------- - ! This subroutine is called to calculate the water requirement for newly recruited cohorts - ! The water update is allocated proportionally to the root biomass, which could be updated - ! to accomodate the soil moisture and rooting depth for small seedlings (Chonggang XU). - ! After the root water uptake, is_newly_recruited flag is set to false. - ! Note, this routine is not accounting for the normal water uptake of new plants - ! going forward, this routine accounts for the water that needs to be accounted for - ! as the plants pop into existance. - ! ---------------------------------------------------------------------------------- + ! ---------------------------------------------------------------------------------- + ! This subroutine is called to calculate the water requirement for newly recruited cohorts + ! The water update is allocated proportionally to the root biomass, which could be updated + ! to accomodate the soil moisture and rooting depth for small seedlings (Chonggang XU). + ! After the root water uptake, is_newly_recruited flag is set to false. + ! Note, this routine is not accounting for the normal water uptake of new plants + ! going forward, this routine accounts for the water that needs to be accounted for + ! as the plants pop into existance. + ! ---------------------------------------------------------------------------------- - ! Arguments - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) - type(bc_in_type), intent(in) :: bc_in(nsites) - real(r8), intent(in) :: dtime !time (seconds) - logical, intent(out) :: recruitflag !flag to check if there is newly recruited cohorts + ! Arguments + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + type(bc_in_type), intent(in) :: bc_in(nsites) + real(r8), intent(in) :: dtime !time (seconds) + logical, intent(out) :: recruitflag !flag to check if there is newly recruited cohorts + + ! Locals + type(ed_cohort_type), pointer :: currentCohort + type(ed_patch_type), pointer :: currentPatch + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + type(ed_site_hydr_type), pointer :: csite_hydr + integer :: s, j, ft + integer :: nstep !number of time steps + real(r8) :: rootfr !fraction of root in different soil layer + real(r8) :: recruitw !water for newly recruited cohorts (kg water/m2/s) + real(r8) :: recruitw_total ! total water for newly recruited cohorts (kg water/m2/s) + real(r8) :: err !mass error of water for newly recruited cohorts (kg water/m2/s) + real(r8) :: sumrw_uptake !sum of water take for newly recruited cohorts (kg water/m2/s) + real(r8) :: sum_l_aroot !sum of absorbing root lenghts + recruitflag = .false. + do s = 1,nsites + csite_hydr => sites(s)%si_hydr + csite_hydr%recruit_w_uptake = 0.0_r8 + currentPatch => sites(s)%oldest_patch + recruitw_total = 0.0_r8 + do while(associated(currentPatch)) + currentCohort=>currentPatch%tallest + do while(associated(currentCohort)) + ccohort_hydr => currentCohort%co_hydr + ft = currentCohort%pft + !----------------------------------------------------------- + ! recruitment water uptake + if(ccohort_hydr%is_newly_recruited) then + recruitflag = .true. + recruitw = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & + ccohort_hydr%th_troot*ccohort_hydr%v_troot + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + denh2o*currentCohort%n*AREA_INV/dtime + recruitw_total = recruitw_total + recruitw + sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) + do j=1,csite_hydr%nlevrhiz + rootfr = ccohort_hydr%l_aroot_layer(j)/sum_l_aroot + csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & + recruitw*rootfr + end do + ccohort_hydr%is_newly_recruited = .false. + endif + currentCohort=>currentCohort%shorter + end do !cohort loop + currentPatch => currentPatch%younger + end do !patch + !balance check + sumrw_uptake = sum(csite_hydr%recruit_w_uptake) + err = recruitw_total - sumrw_uptake + if(abs(err)>1.0e-10_r8)then + do j=1,csite_hydr%nlevrhiz + csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & + err*csite_hydr%recruit_w_uptake(j)/sumrw_uptake + enddo + write(fates_log(),*) 'math check on recruit water failed with err= ', err, sumrw_uptake, recruitw_total + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + end do ! site loop + + if (debug) then + write(fates_log(),*) 'Calculating recruit uptake' + write(fates_log(),*) sum(csite_hydr%recruit_w_uptake(:)) + endif + + +end subroutine RecruitWUptake + +!===================================================================================== + +subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) + + ! --------------------------------------------------------------------------- + ! This subroutine constrains the number of plants so that there is enought water + ! for newly recruited individuals from the soil + ! --------------------------------------------------------------------------- + + ! Arguments + type(ed_site_type), intent(inout), target :: csite + type(ed_cohort_type) , intent(inout), target :: ccohort + type(bc_in_type) , intent(in) :: bc_in + + ! Locals + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + type(ed_site_hydr_type), pointer :: csite_hydr + type(ed_patch_type), pointer :: cpatch + real(r8) :: tmp1 + real(r8) :: watres_local ! minum water content [m3/m3] + real(r8) :: total_water ! total water in rhizosphere at a specific layer (m^3 ha-1) + real(r8) :: total_water_min ! total minimum water in rhizosphere at a specific layer (m^3) + real(r8) :: rootfr ! fraction of root in different soil layer + real(r8) :: recruitw ! water for newly recruited cohorts (kg water/m2/individual) + real(r8) :: n, nmin ! number of individuals in cohorts + real(r8) :: sum_l_aroot + integer :: s, j, ft + + integer :: el ! element loop index + integer :: element_id ! global element identifier index + real(r8) :: leaf_m, store_m, sapw_m ! Element mass in organ tissues + real(r8) :: fnrt_m, struct_m, repro_m ! Element mass in organ tissues + + cpatch => ccohort%patchptr + csite_hydr => csite%si_hydr + ccohort_hydr =>ccohort%co_hydr + recruitw = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & + ccohort_hydr%th_troot*ccohort_hydr%v_troot + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + denh2o + + sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) + do j=1,csite_hydr%nlevrhiz + csite_hydr%cohort_recruit_water_layer(j) = recruitw*ccohort_hydr%l_aroot_layer(j)/sum_l_aroot + end do - ! Locals - type(ed_cohort_type), pointer :: currentCohort - type(ed_patch_type), pointer :: currentPatch - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - type(ed_site_hydr_type), pointer :: csite_hydr - integer :: s, j, ft - integer :: nstep !number of time steps - real(r8) :: rootfr !fraction of root in different soil layer - real(r8) :: recruitw !water for newly recruited cohorts (kg water/m2/s) - real(r8) :: recruitw_total ! total water for newly recruited cohorts (kg water/m2/s) - real(r8) :: err !mass error of water for newly recruited cohorts (kg water/m2/s) - real(r8) :: sumrw_uptake !sum of water take for newly recruited cohorts (kg water/m2/s) - real(r8) :: sum_l_aroot !sum of absorbing root lenghts - recruitflag = .false. - do s = 1,nsites - csite_hydr => sites(s)%si_hydr - csite_hydr%recruit_w_uptake = 0.0_r8 - currentPatch => sites(s)%oldest_patch - recruitw_total = 0.0_r8 - do while(associated(currentPatch)) - currentCohort=>currentPatch%tallest - do while(associated(currentCohort)) - ccohort_hydr => currentCohort%co_hydr - ft = currentCohort%pft - !----------------------------------------------------------- - ! recruitment water uptake - if(ccohort_hydr%is_newly_recruited) then - recruitflag = .true. - recruitw = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - ccohort_hydr%th_troot*ccohort_hydr%v_troot + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o*currentCohort%n*AREA_INV/dtime - recruitw_total = recruitw_total + recruitw - sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) - do j=1,csite_hydr%nlevrhiz - rootfr = ccohort_hydr%l_aroot_layer(j)/sum_l_aroot - csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & - recruitw*rootfr - end do - ccohort_hydr%is_newly_recruited = .false. - endif - currentCohort=>currentCohort%shorter - end do !cohort loop - currentPatch => currentPatch%younger - end do !patch - !balance check - sumrw_uptake = sum(csite_hydr%recruit_w_uptake) - err = recruitw_total - sumrw_uptake - if(abs(err)>1.0e-10_r8)then - do j=1,csite_hydr%nlevrhiz - csite_hydr%recruit_w_uptake(j) = csite_hydr%recruit_w_uptake(j) + & - err*csite_hydr%recruit_w_uptake(j)/sumrw_uptake - enddo - write(fates_log(),*) 'math check on recruit water failed.' - call endrun(msg=errMsg(sourcefile, __LINE__)) - endif - end do ! site loop - - !write(fates_log(),*) 'Calculating recruit water' - !write(fates_log(),*) csite_hydr%recruit_w_uptake + do j=1,csite_hydr%nlevrhiz + + watres_local = csite_hydr%wrf_soil(j)%p%th_from_psi(bc_in%smpmin_si*denh2o*grav_earth*m_per_mm*mpa_per_pa) + + total_water = sum(csite_hydr%v_shell(j,:)*csite_hydr%h2osoi_liqvol_shell(j,:)) + total_water_min = sum(csite_hydr%v_shell(j,:)*watres_local) + + !assumes that only 50% is available for recruit water.... + csite_hydr%recruit_water_avail_layer(j)=0.5_r8*max(0.0_r8,total_water-total_water_min) + + end do + + nmin = 1.0e+36 + do j=1,csite_hydr%nlevrhiz + if(csite_hydr%cohort_recruit_water_layer(j)>nearzero) then + n = csite_hydr%recruit_water_avail_layer(j)/csite_hydr%cohort_recruit_water_layer(j) + nmin = min(n, nmin) + endif + end do + ! Prevent recruitment when temperatures are freezing or below + if (cpatch%tveg24%GetMean() <= 273.15_r8) then + nmin = 0._r8 + end if - end subroutine RecruitWUptake + ! If the minimum number of plants that are recruitable due to water + ! limitations, is less than what is currently recruitable (due to + ! carbon-nitrogen-phosphorus availability), then we apply a reduction. + ! We also have to add back in what had been taken, to the germination + ! seed pool + if(nmin < ccohort%n) then - !===================================================================================== - subroutine ConstrainRecruitNumber(csite,ccohort, bc_in) + do el = 1,num_elements - ! --------------------------------------------------------------------------- - ! This subroutine constrains the number of plants so that there is enought water - ! for newly recruited individuals from the soil - ! --------------------------------------------------------------------------- + element_id = element_list(el) - ! Arguments - type(ed_site_type), intent(inout), target :: csite - type(ed_cohort_type) , intent(inout), target :: ccohort - type(bc_in_type) , intent(in) :: bc_in + leaf_m = ccohort%prt%GetState(leaf_organ, element_id) + store_m = ccohort%prt%GetState(store_organ, element_id) + sapw_m = ccohort%prt%GetState(sapw_organ, element_id) + fnrt_m = ccohort%prt%GetState(fnrt_organ, element_id) + struct_m = ccohort%prt%GetState(struct_organ, element_id) + repro_m = ccohort%prt%GetState(repro_organ, element_id) - ! Locals - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - type(ed_site_hydr_type), pointer :: csite_hydr - type(ed_patch_type), pointer :: cpatch - real(r8) :: tmp1 - real(r8) :: watres_local ! minum water content [m3/m3] - real(r8) :: total_water ! total water in rhizosphere at a specific layer (m^3 ha-1) - real(r8) :: total_water_min ! total minimum water in rhizosphere at a specific layer (m^3) - real(r8) :: rootfr ! fraction of root in different soil layer - real(r8) :: recruitw ! water for newly recruited cohorts (kg water/m2/individual) - real(r8) :: n, nmin ! number of individuals in cohorts - real(r8) :: sum_l_aroot - integer :: s, j, ft - - integer :: el ! element loop index - integer :: element_id ! global element identifier index - real(r8) :: leaf_m, store_m, sapw_m ! Element mass in organ tissues - real(r8) :: fnrt_m, struct_m, repro_m ! Element mass in organ tissues + cpatch%litter(el)%seed_germ(ccohort%pft) = cpatch%litter(el)%seed_germ(ccohort%pft) + & + (ccohort%n-nmin)/cpatch%area * & + (leaf_m+store_m+sapw_m+fnrt_m+struct_m+repro_m) - - cpatch => ccohort%patchptr - csite_hydr => csite%si_hydr - ccohort_hydr =>ccohort%co_hydr - recruitw = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - ccohort_hydr%th_troot*ccohort_hydr%v_troot + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o - sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) - do j=1,csite_hydr%nlevrhiz - cohort_recruit_water_layer(j) = recruitw*ccohort_hydr%l_aroot_layer(j)/sum_l_aroot - end do + end do + ccohort%n = nmin + end if - do j=1,csite_hydr%nlevrhiz - watres_local = csite_hydr%wrf_soil(j)%p%th_from_psi(bc_in%smpmin_si*denh2o*grav_earth*m_per_mm*mpa_per_pa) + return +end subroutine ConstrainRecruitNumber - total_water = sum(csite_hydr%v_shell(j,:)*csite_hydr%h2osoi_liqvol_shell(j,:)) - total_water_min = sum(csite_hydr%v_shell(j,:)*watres_local) - !assumes that only 50% is available for recruit water.... - recruit_water_avail_layer(j)=0.5_r8*max(0.0_r8,total_water-total_water_min) +! ===================================================================================== - end do +subroutine SavePreviousRhizVolumes(currentSite) - nmin = 1.0e+36 - do j=1,csite_hydr%nlevrhiz - if(cohort_recruit_water_layer(j)>0.0_r8) then - n = recruit_water_avail_layer(j)/cohort_recruit_water_layer(j) - nmin = min(n, nmin) - endif - end do + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + type(ed_site_hydr_type), pointer :: csite_hydr - ! If the minimum number of plants that are recruitable due to water - ! limitations, is less than what is currently recruitable (due to - ! carbon-nitrogen-phosphorus availability), then we apply a reduction. - ! We also have to add back in what had been taken, to the germination - ! seed pool - if(nmin < ccohort%n) then + csite_hydr => currentSite%si_hydr + csite_hydr%l_aroot_layer_init(:) = csite_hydr%l_aroot_layer(:) + csite_hydr%r_node_shell_init(:,:) = csite_hydr%r_node_shell(:,:) + csite_hydr%v_shell_init(:,:) = csite_hydr%v_shell(:,:) - do el = 1,num_elements + return +end subroutine SavePreviousRhizVolumes - element_id = element_list(el) - - leaf_m = ccohort%prt%GetState(leaf_organ, element_id) - store_m = ccohort%prt%GetState(store_organ, element_id) - sapw_m = ccohort%prt%GetState(sapw_organ, element_id) - fnrt_m = ccohort%prt%GetState(fnrt_organ, element_id) - struct_m = ccohort%prt%GetState(struct_organ, element_id) - repro_m = ccohort%prt%GetState(repro_organ, element_id) - - cpatch%litter(el)%seed_germ(ccohort%pft) = cpatch%litter(el)%seed_germ(ccohort%pft) + & - (ccohort%n-nmin)/cpatch%area * & - (leaf_m+store_m+sapw_m+fnrt_m+struct_m+repro_m) - - end do - ccohort%n = nmin - end if - - return - end subroutine ConstrainRecruitNumber +! ====================================================================================== +subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) - ! ===================================================================================== + ! + ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes of the site. + ! As fine root biomass (and thus absorbing root length) increases, this characteristic + ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains + ! the same. + ! + ! !USES: - subroutine SavePreviousRhizVolumes(currentSite) - ! !ARGUMENTS: - type(ed_site_type) , intent(inout), target :: currentSite - type(ed_site_hydr_type), pointer :: csite_hydr + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type) , intent(in) :: bc_in - csite_hydr => currentSite%si_hydr - csite_hydr%l_aroot_layer_init(:) = csite_hydr%l_aroot_layer(:) - csite_hydr%r_node_shell_init(:,:) = csite_hydr%r_node_shell(:,:) - csite_hydr%v_shell_init(:,:) = csite_hydr%v_shell(:,:) + ! + ! !LOCAL VARIABLES: + type(ed_site_hydr_type), pointer :: csite_hydr + type(ed_patch_type) , pointer :: cPatch + type(ed_cohort_type) , pointer :: cCohort + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + real(r8) :: hksat_s ! hksat converted to units of 10^6sec + ! which is equiv to [kg m-1 s-1 MPa-1] + integer :: j,k ! gridcell, soil layer, rhizosphere shell indices + integer :: j_bc ! soil layer index of boundary condition + real(r8) :: large_kmax_bound = 1.e4_r8 ! for replacing kmax_bound_shell wherever the + ! innermost shell radius is less than the assumed + ! absorbing root radius rs1 + ! 1.e-5_r8 from Rudinger et al 1994 + integer :: nlevrhiz + integer, parameter :: k_inner = 1 ! innermost rhizosphere shell + !----------------------------------------------------------------------- + + csite_hydr => currentSite%si_hydr + nlevrhiz = csite_hydr%nlevrhiz + + ! Note, here is where the site level soil depth/layer is set + ! update cohort-level root length density and accumulate it across cohorts and patches to the column level + + csite_hydr%l_aroot_layer(:) = 0._r8 + cPatch => currentSite%youngest_patch + do while(associated(cPatch)) + cCohort => cPatch%tallest + do while(associated(cCohort)) + ccohort_hydr => cCohort%co_hydr + csite_hydr%l_aroot_layer(:) = csite_hydr%l_aroot_layer(:) + ccohort_hydr%l_aroot_layer(:)*cCohort%n + cCohort => cCohort%shorter + enddo !cohort + cPatch => cPatch%older + enddo !patch + + ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) + ! Provisions are made inside shellGeom() for layers with no roots + do j = 1,nlevrhiz + + call shellGeom( csite_hydr%l_aroot_layer(j), csite_hydr%rs1(j), AREA, csite_hydr%dz_rhiz(j), & + csite_hydr%r_out_shell(j,:), csite_hydr%r_node_shell(j,:),csite_hydr%v_shell(j,:)) - return - end subroutine SavePreviousRhizVolumes + enddo - ! ====================================================================================== - subroutine UpdateSizeDepRhizVolLenCon(currentSite, bc_in) + do j = 1,nlevrhiz + + ! bc_in%hksat_sisl(j_bc): hydraulic conductivity at saturation (mm H2O /s) + ! + ! converted from [mm H2O s-1] -> [kg s-1 MPa-1 m-1] + ! + ! Conversion of Pascals: 1 Pa = 1 kg m-1 s-2 + ! + ! [mm s-1] * 1e-3 [m mm-1] + ! * 1 [kg m-1 s-2 Pa-1] + ! * 9.8-1 [s2 m-1] + ! * 1e6 [Pa MPa-1] + ! = [kg s-1 m-1 MPa-1] + + hksat_s = csite_hydr%AggBCToRhiz(bc_in%hksat_sisl,j,bc_in%dz_sisl) * & + m_per_mm * 1._r8/grav_earth * pa_per_mpa + + ! proceed only if the total absorbing root length (site-level) has changed in this layer + if( (csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j)) .and. & + csite_hydr%l_aroot_layer(j)>nearzero ) then + + ! Set the max conductance on the inner shell first. If the node radius + ! on the shell is smaller than the root radius, just set the max conductance + ! to something extremely high. + + if( csite_hydr%r_node_shell(j,k_inner) <= csite_hydr%rs1(j) ) then + csite_hydr%kmax_upper_shell(j,k_inner) = large_kmax_bound + else + csite_hydr%kmax_upper_shell(j,k_inner) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & + log(csite_hydr%r_node_shell(j,k_inner)/csite_hydr%rs1(j))*hksat_s + end if - ! - ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. - ! As fine root biomass (and thus absorbing root length) increases, this characteristic - ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains - ! the same. - ! - ! !USES: + csite_hydr%kmax_lower_shell(j,k_inner) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & + log(csite_hydr%r_out_shell(j,k_inner)/csite_hydr%r_node_shell(j,k_inner) )*hksat_s + do k = 2,nshell + csite_hydr%kmax_upper_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & + log(csite_hydr%r_node_shell(j,k)/csite_hydr%r_out_shell(j,k-1))*hksat_s - ! !ARGUMENTS: - type(ed_site_type) , intent(inout), target :: currentSite - type(bc_in_type) , intent(in) :: bc_in + csite_hydr%kmax_lower_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & + log(csite_hydr%r_out_shell(j,k)/csite_hydr%r_node_shell(j,k ))*hksat_s + enddo ! loop over rhizosphere shells - ! - ! !LOCAL VARIABLES: - type(ed_site_hydr_type), pointer :: csite_hydr - type(ed_patch_type) , pointer :: cPatch - type(ed_cohort_type) , pointer :: cCohort - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - real(r8) :: hksat_s ! hksat converted to units of 10^6sec - ! which is equiv to [kg m-1 s-1 MPa-1] - integer :: j,k ! gridcell, soil layer, rhizosphere shell indices - integer :: j_bc ! soil layer index of boundary condition - real(r8) :: large_kmax_bound = 1.e4_r8 ! for replacing kmax_bound_shell wherever the - ! innermost shell radius is less than the assumed - ! absorbing root radius rs1 - ! 1.e-5_r8 from Rudinger et al 1994 - integer :: nlevrhiz - integer, parameter :: k_inner = 1 ! innermost rhizosphere shell - !----------------------------------------------------------------------- + end if !has l_aroot_layer changed? + enddo ! loop over soil layers - csite_hydr => currentSite%si_hydr - nlevrhiz = csite_hydr%nlevrhiz - - ! update cohort-level root length density and accumulate it across cohorts and patches to the column level - csite_hydr%l_aroot_layer(:) = 0._r8 - cPatch => currentSite%youngest_patch - do while(associated(cPatch)) - cCohort => cPatch%tallest - do while(associated(cCohort)) - ccohort_hydr => cCohort%co_hydr - csite_hydr%l_aroot_layer(:) = csite_hydr%l_aroot_layer(:) + ccohort_hydr%l_aroot_layer(:)*cCohort%n - cCohort => cCohort%shorter - enddo !cohort - cPatch => cPatch%older - enddo !patch - - ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) - do j = 1,nlevrhiz - ! proceed only if l_aroot_coh has changed - ! if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - call shellGeom( csite_hydr%l_aroot_layer(j), csite_hydr%rs1(j), AREA, csite_hydr%dz_rhiz(j), & - csite_hydr%r_out_shell(j,:), csite_hydr%r_node_shell(j,:),csite_hydr%v_shell(j,:)) -! end if !has l_aroot_layer changed? - enddo + return +end subroutine UpdateSizeDepRhizVolLenCon - do j = 1,nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 +! ===================================================================================== - ! bc_in%hksat_sisl(j): hydraulic conductivity at saturation (mm H2O /s) - ! - ! converted from [mm H2O s-1] -> [kg s-1 MPa-1 m-1] - ! - ! Conversion of Pascals: 1 Pa = 1 kg m-1 s-2 - ! - ! [mm s-1] * 1e-3 [m mm-1] - ! * 1 [kg m-1 s-2 Pa-1] - ! * 9.8-1 [s2 m-1] - ! * 1e6 [Pa MPa-1] - ! = [kg s-1 m-1 MPa-1] - hksat_s = bc_in%hksat_sisl(j_bc) * m_per_mm * 1._r8/grav_earth * pa_per_mpa - - ! proceed only if the total absorbing root length (site-level) has changed in this layer - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then +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: - ! Set the max conductance on the inner shell first. If the node radius - ! on the shell is smaller than the root radius, just set the max conductance - ! to something extremely high. - - if( csite_hydr%r_node_shell(j,k_inner) <= csite_hydr%rs1(j) ) then - csite_hydr%kmax_upper_shell(j,k_inner) = large_kmax_bound - else - csite_hydr%kmax_upper_shell(j,k_inner) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & - log(csite_hydr%r_node_shell(j,k_inner)/csite_hydr%rs1(j))*hksat_s - end if - - csite_hydr%kmax_lower_shell(j,k_inner) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & - log(csite_hydr%r_out_shell(j,k_inner)/csite_hydr%r_node_shell(j,k_inner) )*hksat_s - - do k = 2,nshell - csite_hydr%kmax_upper_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & - log(csite_hydr%r_node_shell(j,k)/csite_hydr%r_out_shell(j,k-1))*hksat_s - - csite_hydr%kmax_lower_shell(j,k) = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & - log(csite_hydr%r_out_shell(j,k)/csite_hydr%r_node_shell(j,k ))*hksat_s - enddo ! loop over rhizosphere shells - - + ! !ARGUMENTS: + type(ed_site_type) , intent(inout), target :: currentSite + type(bc_in_type) , intent(in) :: bc_in - end if !has l_aroot_layer changed? - enddo ! loop over soil layers + ! Save current volumes, lenghts and nodes to an "initial" + ! used to calculate effects in states later on. - return - end subroutine UpdateSizeDepRhizVolLenCon + call SavePreviousRhizVolumes(currentSite) + ! Update the properties of the vegetation-soil hydraulic environment + ! these are independent on the water state - ! ===================================================================================== + call UpdateSizeDepRhizVolLenCon(currentSite, bc_in) + return +end subroutine UpdateSizeDepRhizHydProps - 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: - ! !ARGUMENTS: - type(ed_site_type) , intent(inout), target :: currentSite - type(bc_in_type) , intent(in) :: bc_in +! ==================================================================================== +subroutine BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) - ! Save current volumes, lenghts and nodes to an "initial" - ! used to calculate effects in states later on. + ! Arguments + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) - call SavePreviousRhizVolumes(currentSite) + ! Locals + integer :: s + integer :: ifp + real(r8) :: balive_patch + type(ed_patch_type),pointer :: cpatch + type(ed_cohort_type),pointer :: ccohort - ! Update the properties of the vegetation-soil hydraulic environment - ! these are independent on the water state + do s = 1,nsites - call UpdateSizeDepRhizVolLenCon(currentSite, bc_in) + ifp = 0 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ifp=ifp+1 + + balive_patch = 0._r8 + ccohort=>cpatch%tallest + do while(associated(ccohort)) + balive_patch = balive_patch + & + (cCohort%prt%GetState(fnrt_organ, carbon12_element) + & + cCohort%prt%GetState(sapw_organ, carbon12_element) + & + cCohort%prt%GetState(leaf_organ, carbon12_element))* ccohort%n + ccohort => ccohort%shorter + enddo !cohort + + bc_out(s)%btran_pa(ifp) = 0.0_r8 + ccohort=>cpatch%tallest + do while(associated(ccohort)) + bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + & + ccohort%co_hydr%btran * & + (cCohort%prt%GetState(fnrt_organ, carbon12_element) + & + cCohort%prt%GetState(sapw_organ, carbon12_element) + & + cCohort%prt%GetState(leaf_organ, carbon12_element)) * & + ccohort%n / balive_patch + ccohort => ccohort%shorter + enddo !cohort + cpatch => cpatch%younger + enddo !end patch loop + end do + return +end subroutine BTranForHLMDiagnosticsFromCohortHydr + +! ========================================================================== + +subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) + ! + ! Created by Brad Christoffersen, Jan 2016 + ! + ! !DESCRIPTION: + ! Parses out mean vertical water fluxes resulting from infiltration, + ! drainage, and vertical water movement (dwat_kgm2) over radially stratified + ! rhizosphere shells. + ! + ! The approach used is heuristic, but based on the principle that water + ! fluxing out of a layer will preferentially come from rhizosphere + ! shells with higher water contents/potentials within that layer, and + ! alternatively, that water fluxing into a layer will preferentially go + ! into shells with lower water contents/potentials. + ! + ! This principle is implemented by filling (draining) the rhizosphere + ! shells in order from the driest (wettest) shell to the wettest (driest). + ! Each shell is filled (drained) up (down) to the next wettest (driest) + ! shell until the change in mean layer water (dwat_kgm2) is accounted for. + ! + ! !USES: + ! + ! !ARGUMENTS: + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + type(bc_in_type), intent(in) :: bc_in(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + ! Locals + type(ed_site_hydr_type), pointer :: csite_hydr ! pointer to site hydraulics object + real(r8) :: dwat_kgm2 ! change in layer water content [kg/m2] + integer :: s,j,k ! site, soil layer, rhizosphere shell indicies + integer :: i,f,ff,kk ! indicies + integer :: j_t,j_b ! top and bottom soil layer indices for currenth rhiz layer + integer :: j_bc ! layer index for matching boundary condition soil layers + integer :: indexj ! column and layer indices where there is a water balance error + integer :: ordered(nshell) = (/(i,i=1,nshell,1)/) ! array of rhizosphere indices which have been ordered + real(r8) :: area_col ! column area [m2] + real(r8) :: v_cum ! cumulative shell volume from driest/wettest shell to kth shell [m3] + real(r8) :: dwat_kg ! water remaining to be distributed across shells [kg] + real(r8) :: thdiff ! water content difference between ordered adjacent rhiz shells [m3 m-3] + real(r8) :: wdiff ! mass of water represented by thdiff over previous k shells [kg] + real(r8) :: errh2o(nlevsoi_hyd_max) ! water budget error after updating [kg/m2] + real(r8) :: cumShellH2O ! sum of water in all the shells of a specific layer [kg/m2] + real(r8) :: h2osoi_liq_shell(nlevsoi_hyd_max,nshell) ! water in the rhizosphere shells [kg] + integer :: tmp ! temporary + logical :: found ! flag in search loop + !----------------------------------------------------------------------- + + do s = 1,nsites + + ! First step, identify how the liquid water in each layer has changed + ! since the last time it was updated. This should be due to drainage. + ! The drainage component should be the total change in liquid water content from the last time + ! the hydraulics driver was called, and then adding back in the losses due to root uptake + ! (which was already taken out). + + ! BOC: This was previously in HydrologyDrainage: + + csite_hydr => sites(s)%si_hydr + + ! If there are just no plants in this site, don't bother shuffling water + if( sum(csite_hydr%l_aroot_layer) <= nearzero ) cycle + + do j = 1,csite_hydr%nlevrhiz + j_t = csite_hydr%map_r2s(j,1) ! top soil layer matching rhiz layer + j_b = csite_hydr%map_r2s(j,2) ! bottom soil layer matching rhiz layer - return - end subroutine UpdateSizeDepRhizHydProps + if (csite_hydr%l_aroot_layer(j) <= nearzero ) cycle + + cumShellH2O=sum(csite_hydr%h2osoi_liqvol_shell(j,:) *csite_hydr%v_shell(j,:)) * denh2o*AREA_INV + + ! [kg/m2] + dwat_kgm2 = sum(bc_in(s)%h2o_liq_sisl(j_t:j_b)) - cumShellH2O + + dwat_kg = dwat_kgm2 * AREA + + ! order shells in terms of increasing or decreasing volumetric water content + ! algorithm same as that used in histFileMod.F90 to alphabetize history tape contents + if(nshell > 1) then + do k = nshell-1,1,-1 + do kk = 1,k + if (csite_hydr%h2osoi_liqvol_shell(j,ordered(kk)) > & + csite_hydr%h2osoi_liqvol_shell(j,ordered(kk+1))) then + if (dwat_kg > 0._r8) then !order increasing + tmp = ordered(kk) + ordered(kk) = ordered(kk+1) + ordered(kk+1) = tmp + end if + else + if (dwat_kg < 0._r8) then !order decreasing + tmp = ordered(kk) + ordered(kk) = ordered(kk+1) + ordered(kk+1) = tmp + end if + end if + enddo + enddo + end if - ! ================================================================================= + ! fill shells with water up to the water content of the next-wettest shell, + ! in order from driest to wettest (dwat_kg > 0) + ! ------ OR ------ + ! drain shells' water down to the water content of the next-driest shell, + ! in order from wettest to driest (dwat_kg < 0) + k = 1 + do while ( (dwat_kg /= 0._r8) .and. (k < nshell) ) + thdiff = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) - & + csite_hydr%h2osoi_liqvol_shell(j,ordered(k)) + v_cum = sum(csite_hydr%v_shell(j,ordered(1:k))) + wdiff = thdiff * v_cum * denh2o ! change in h2o [kg / ha] for shells ordered(1:k) + if(abs(dwat_kg) >= abs(wdiff)) then + csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) + dwat_kg = dwat_kg - wdiff + else + csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = & + csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) + dwat_kg/denh2o/v_cum + dwat_kg = 0._r8 + end if + k = k + 1 + enddo + + if (dwat_kg /= 0._r8) then + v_cum = sum(csite_hydr%v_shell(j,ordered(1:nshell))) + thdiff = dwat_kg / v_cum / denh2o + do k = nshell, 1, -1 + csite_hydr%h2osoi_liqvol_shell(j,k) = csite_hydr%h2osoi_liqvol_shell(j,k) + thdiff + end do + end if - subroutine UpdateSizeDepRhizHydStates(currentSite, bc_in) - ! - ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. - ! As fine root biomass (and thus absorbing root length) increases, this characteristic - ! rhizosphere shrinks even though the total volume of soil tapped by fine roots remains - ! the same. - ! - ! !USES: - ! - ! !ARGUMENTS: - type(ed_site_type), intent(inout), target :: currentSite - type(bc_in_type), intent(in) :: bc_in - ! - ! !LOCAL VARIABLES: - real(r8) :: v_rhiz(nlevsoi_hyd_max) ! updated volume of all rhizosphere compartments [m3] - real(r8) :: r_delta ! change in radius of innermost rhizosphere compartment [m] - real(r8) :: dpsidr ! water potential gradient near root surface [MPa/m] - real(r8) :: w_shell_new ! updated water volume in rhizosphere compartment [m3] - real(r8) :: w_layer_init(nlevsoi_hyd_max) ! initial water mass by layer [kg] - real(r8) :: w_layer_interp(nlevsoi_hyd_max) ! water mass after interpolating to new rhizosphere [kg] - real(r8) :: w_layer_new(nlevsoi_hyd_max) ! water mass by layer after interpolation and fudging [kg] - real(r8) :: h2osoi_liq_col_new(nlevsoi_hyd_max) ! water mass per area after interpolating to new rhizosphere [kg/m2] - real(r8) :: s_shell_init(nlevsoi_hyd_max,nshell) ! initial saturation fraction in rhizosphere compartment [0-1] - real(r8) :: s_shell_interp(nlevsoi_hyd_max,nshell) ! interpolated saturation fraction in rhizosphere compartment [0-1] - real(r8) :: psi_shell_init(nlevsoi_hyd_max,nshell) ! initial water potential in rhizosphere compartment [MPa] - real(r8) :: psi_shell_interp(nlevsoi_hyd_max,nshell) ! interpolated psi_shell to new r_node_shell [MPa] - real(r8) :: delta_s(nlevsoi_hyd_max) ! change in saturation fraction needed to ensure water bal [0-1] - real(r8) :: errh2o(nlevsoi_hyd_max) ! water budget error after updating [kg/m2] - integer :: j,k ! gridcell, column, soil layer, rhizosphere shell indicies - integer :: j_bc ! level index for boundary conditions - integer :: indexc,indexj ! column and layer indices where there is a water balance error - logical :: found ! flag in search loop - type(ed_site_hydr_type), pointer :: csite_hydr - !----------------------------------------------------------------------- + ! m3/m3 * Total volume m3 * kg/m3 = kg + h2osoi_liq_shell(j,:) = csite_hydr%h2osoi_liqvol_shell(j,:) * & + csite_hydr%v_shell(j,:) * denh2o - s_shell_init(:,:) = 0._r8 - psi_shell_init(:,:) = 0._r8 - psi_shell_interp(:,:) = 0._r8 - s_shell_interp(:,:) = 0._r8 - csite_hydr => currentSite%si_hydr + errh2o(j) = sum(h2osoi_liq_shell(j,:))*AREA_INV - sum(bc_in(s)%h2o_liq_sisl(j_t:j_b)) - if(.false.) then + if (abs(errh2o(j)) > 1.e-9_r8) then + write(fates_log(),*)'WARNING: water balance error in FillDrainRhizShells' + write(fates_log(),*)'errh2o= ',errh2o(j), ' [kg/m2]' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do - do j = 1, csite_hydr%nlevrhiz - ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then + end do + return +end subroutine FillDrainRhizShells - do k = 1,nshell - psi_shell_init(j,k) = csite_hydr%wrf_soil(j)%p%psi_from_th(csite_hydr%h2osoi_liqvol_shell(j,k)) - end do +! ==================================================================================== - end if !has l_aroot_coh changed? - enddo +subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) - ! interpolate initial psi values by layer and shell - ! BOC...To-Do: need to constrain psi to be within realistic limits (i.e., < 0) - do j = 1,csite_hydr%nlevrhiz - ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - - ! fine root length increased, thus shrinking the rhizosphere size - if(csite_hydr%r_node_shell(j,nshell) < csite_hydr%r_node_shell_init(j,nshell)) then - r_delta = csite_hydr%r_node_shell(j,1) - csite_hydr%r_node_shell_init(j,1) - !dpsidr = (psi_shell_init(j,2) - psi_shell_init(j,1)) / & - ! (csite_hydr%r_node_shell_init(j,2) - csite_hydr%r_node_shell_init(j,1)) - - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! HACK for special case of nshell = 1 -- compiler throws error because of index 2 in above line, - ! even though at run-time the code should skip over this section: MUST FIX - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - dpsidr = (psi_shell_init(j,1) - psi_shell_init(j,1)) / & - (csite_hydr%r_node_shell_init(j,1) - csite_hydr%r_node_shell_init(j,1)) - psi_shell_interp(j,1) = dpsidr * r_delta - do k = 2,nshell - r_delta = csite_hydr%r_node_shell(j,k) - csite_hydr%r_node_shell_init(j,k) - dpsidr = (psi_shell_init(j,k) - psi_shell_init(j,k-1)) / & - (csite_hydr%r_node_shell_init(j,k) - csite_hydr%r_node_shell_init(j,k-1)) - psi_shell_interp(j,k) = dpsidr * r_delta - enddo - else - ! fine root length decreased, thus increasing the rhizosphere size - do k = 1,(nshell-1) - r_delta = csite_hydr%r_node_shell(j,k) - csite_hydr%r_node_shell_init(j,k) - dpsidr = (psi_shell_init(j,k+1) - psi_shell_init(j,k)) / & - (csite_hydr%r_node_shell_init(j,k+1) - csite_hydr%r_node_shell_init(j,k)) - psi_shell_interp(j,k) = dpsidr * r_delta - enddo - r_delta = csite_hydr%r_node_shell(j,nshell) - csite_hydr%r_node_shell_init(j,nshell) - !dpsidr = (psi_shell_init(j,nshell) - psi_shell_init(j,nshell-1)) / & - ! (csite_hydr%r_node_shell_init(j,nshell) - csite_hydr%r_node_shell_init(j,nshell-1)) - - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - ! HACK for special case of nshell = 1 -- compiler throws error because of index nshell-1 in - ! above line, even though at run-time the code should skip over this section: MUST FIX - ! XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX - - dpsidr = (psi_shell_init(j,nshell) - psi_shell_init(j,nshell)) / & - (csite_hydr%r_node_shell_init(j,nshell) - csite_hydr%r_node_shell_init(j,nshell)) - - psi_shell_interp(j,k) = dpsidr * r_delta - end if - end if !has l_aroot_coh changed? - enddo + ! ---------------------------------------------------------------------------------- + ! added by Brad Christoffersen Jan 2016 for use in ED hydraulics + ! van Genuchten (1980)-specific functions for the swc (soil water characteristic) + ! and for the kunsat (unsaturated hydraulic conductivity) curves. Test mod 06/20/2016 - ! 1st guess at new s based on interpolated psi - do j = 1,csite_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 - - ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - - s_shell_interp(j,k) = ( csite_hydr%wrf_soil(j)%p%th_from_psi(psi_shell_interp(j,k)) - bc_in%watres_sisl(j_bc)) / & - (bc_in%watres_sisl(j_bc)+bc_in%watres_sisl(j_bc)) + ! resolved the mass-balance bugs and tested Jan, 2018 by C. XU + ! + ! BOC...for quick implementation avoided JT's abstract interface, + ! but these should be converted to interfaces in the future + ! ---------------------------------------------------------------------------------- - end if !has l_aroot_coh changed? - enddo + ! + ! !DESCRIPTION: + !s + ! !USES: + use FatesUtilsMod , only : check_var_real + + ! ARGUMENTS: + ! ----------------------------------------------------------------------------------- + integer,intent(in) :: nsites + type(ed_site_type),intent(inout),target :: sites(nsites) + type(bc_in_type),intent(in) :: bc_in(nsites) + type(bc_out_type),intent(inout) :: bc_out(nsites) + real(r8),intent(in) :: dtime - ! accumlate water across shells for each layer (initial and interpolated) - do j = 1,csite_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 - ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - w_layer_init(j) = 0._r8 - w_layer_interp(j) = 0._r8 - v_rhiz(j) = 0._r8 - do k = 1,nshell - w_layer_init(j) = w_layer_init(j) + denh2o * & - (csite_hydr%v_shell_init(j,k)*csite_hydr%h2osoi_liqvol_shell(j,k) ) - w_layer_interp(j) = w_layer_interp(j) + denh2o * & - (csite_hydr%v_shell(j,k) * & - (s_shell_interp(j,k)*(bc_in%watsat_sisl(j_bc)-bc_in%watres_sisl(j_bc))+bc_in%watres_sisl(j_bc)) ) - v_rhiz(j) = v_rhiz(j) + csite_hydr%v_shell(j,k) - enddo - end if !has l_aroot_coh changed? - enddo + ! + ! !LOCAL VARIABLES: + integer :: s ! index of FATES site + integer :: i ! shell index + integer :: j ! soil layer + integer :: ifp ! boundary condition, patch index + integer :: j_bc ! soil layer index for boundary conditions + integer :: j_b,j_t ! bottom and top soil layers for the current rhiz layer + integer :: k ! 1D plant-soil continuum array + integer :: ft ! plant functional type index - ! estimate delta_s across all shells needed to ensure total water in each layer doesn't change - ! BOC...FIX: need to handle special cases where delta_s causes s_shell to go above or below 1 or 0, respectively. - do j = 1,csite_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 - ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - delta_s(j) = (( w_layer_init(j) - w_layer_interp(j) )/( v_rhiz(j) * denh2o ) - bc_in%watres_sisl(j_bc)) / & - (bc_in%watsat_sisl(j_bc)-bc_in%watres_sisl(j_bc)) - end if !has l_aroot_coh changed? - enddo + !---------------------------------------------------------------------- - ! update h2osoi_liqvol_shell and h2osoi_liq_shell - do j = 1,csite_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 - ! proceed only if l_aroot_coh has changed - if( csite_hydr%l_aroot_layer(j) /= csite_hydr%l_aroot_layer_init(j) ) then - w_layer_new(j) = 0._r8 - do k = 1,nshell - s_shell_interp(j,k) = s_shell_interp(j,k) + delta_s(j) - csite_hydr%h2osoi_liqvol_shell(j,k) = s_shell_interp(j,k) * & - ( bc_in%watsat_sisl(j_bc)-bc_in%watres_sisl(j_bc) ) + bc_in%watres_sisl(j_bc) - w_shell_new = csite_hydr%h2osoi_liqvol_shell(j,k) * & - csite_hydr%v_shell(j,k) - w_layer_new(j) = w_layer_new(j) + w_shell_new - enddo - h2osoi_liq_col_new(j) = w_layer_new(j)/ v_rhiz(j) - end if !has l_aroot_coh changed? - enddo + type (ed_patch_type), pointer :: cpatch ! current patch pointer + type (ed_cohort_type), pointer :: ccohort ! current cohort pointer + type(ed_site_hydr_type), pointer :: csite_hydr ! site hydraulics pointer + type(ed_cohort_hydr_type), pointer :: ccohort_hydr ! cohort hydraulics pointer - ! balance check - do j = 1,csite_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 - errh2o(j) = h2osoi_liq_col_new(j) - bc_in%h2o_liq_sisl(j_bc) - if (abs(errh2o(j)) > 1.e-4_r8) then - write(fates_log(),*)'WARNING: water balance error ',& - ' updating rhizosphere shells: ',j,errh2o(j) - write(fates_log(),*)'errh2o= ',errh2o(j), ' [kg/m2]' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - enddo + ! Local arrays - end if !nshell > 1 + ! accumulated water content change over all cohorts in a column [m3 m-3] + real(r8) :: dth_layershell_col(nlevsoi_hyd_max,nshell) - end subroutine UpdateSizeDepRhizHydStates + ! array of soil layer indices which have been ordered + integer :: ordered(nlevsoi_hyd_max) = (/(j,j=1,nlevsoi_hyd_max,1)/) - ! ==================================================================================== + real(r8) :: weight_sl(nlevsoi_hyd_max) ! Weighting factor for disaggregation + ! on the soil grid (not rhizoshere grid) + + ! total absorbing root & rhizosphere conductance (over all shells) by soil layer [MPa] + real(r8) :: kbg_layer(nlevsoi_hyd_max) + real(r8) :: rootuptake(nlevsoi_hyd_max) ! mass-flux from 1st rhizosphere to absorbing roots [kg/indiv/layer/step] + + real(r8) :: site_runoff ! If plants are pushing water into saturated soils, we create + ! runoff. This is either banked, or sent to the correct flux pool [kg/m2] + real(r8) :: wb_err_plant ! Solve error for a single plant [kg] + real(r8) :: wb_check_site ! the water balance error we get from summing fluxes + ! and changes in storage + ! and is just a double check on our error accounting). [kg/m2] + real(r8) :: dwat_plant ! change in water mass in the whole plant [kg] + real(r8) :: qflx_tran_veg_indiv ! individiual transpiration rate [kgh2o indiv-1 s-1] + real(r8) :: qflx_soil2root_rhiz ! soil into root water flux at this rhiz layer + real(r8) :: gscan_patch ! sum of ccohort%gscan across all cohorts within a patch + real(r8) :: sapflow ! mass-flux for the cohort between transporting root and stem [kg/indiv/step] + real(r8) :: prev_h2oveg ! plant water storage at start of timestep (kg/m2) + real(r8) :: prev_h2osoil ! soil water storage at start of timestep (kg/m2) + logical :: recruitflag ! flag to check if there is newly recruited cohorts + real(r8) :: root_flux ! total water flux into roots [kg/m2] + real(r8) :: transp_flux ! total transpiration flux from plants [kg/m2] + real(r8) :: delta_plant_storage ! change in plant water storage over the step [kg/m2] + real(r8) :: delta_soil_storage ! change in soil water storage over the step [kg/m2] + real(r8) :: sumcheck ! used to debug mass balance in soil horizon diagnostics + integer :: nlevrhiz ! local for number of rhizosphere levels + integer :: sc ! size class index + real(r8) :: lat,lon ! latitude and longitude of site + real(r8) :: eff_por ! effective porosity + real(r8) :: h2osoi_liqvol ! liquid water content [m3/m3] + real(r8) :: psi_layer ! matric potential [Mpa] + real(r8) :: ftc_layer ! fraction of maximum conductance [-] + real(r8) :: weight ! weighting function for each layer when disaggregating rhiz->soil + real(r8) :: sumweight ! sum of weighting functions for disaggregating rhiz -> soil + real(r8) :: sum_l_aroot ! sum of root length of cohort, for disaggregation + real(r8) :: rootfr ! fraction of root mass in soil layer, for disaggregation + real(r8) :: z_fr ! Maximum fine root depth, used in disaggregation - subroutine BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) + integer, parameter :: soilz_disagg = 0 ! disaggregate rhizosphere layers based on depth + integer, parameter :: soilk_disagg = 1 ! disaggregate rhizosphere layers based on conductance - ! Arguments - integer,intent(in) :: nsites - type(ed_site_type),intent(inout),target :: sites(nsites) - type(bc_out_type),intent(inout) :: bc_out(nsites) + integer, parameter :: rootflux_disagg = soilk_disagg - ! Locals - integer :: s - integer :: ifp - real(r8) :: balive_patch - type(ed_patch_type),pointer :: cpatch - type(ed_cohort_type),pointer :: ccohort + + ! ---------------------------------------------------------------------------------- + ! Important note: We are interested in calculating the total fluxes in and out of the + ! site/column. Usually, when we do things like this, we acknowledge that FATES + ! does not consider the bare ground patch. However, since this routine + ! calculates "column level" fluxes, we have to factor in that patch-level fluxes + ! are only accounting for a portion of the area. + ! ---------------------------------------------------------------------------------- - do s = 1,nsites + !For newly recruited cohorts, add the water uptake demand to csite_hydr%recruit_w_uptake + call RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) - ifp = 0 - cpatch => sites(s)%oldest_patch - do while (associated(cpatch)) - ifp=ifp+1 + !update water storage in veg after incorporating newly recuited cohorts + if(recruitflag)then + do s = 1, nsites + call UpdateH2OVeg(sites(s),bc_out(s)) + end do + end if - balive_patch = 0._r8 - ccohort=>cpatch%tallest - do while(associated(ccohort)) - balive_patch = balive_patch + & - (cCohort%prt%GetState(fnrt_organ, carbon12_element) + & - cCohort%prt%GetState(sapw_organ, carbon12_element) + & - cCohort%prt%GetState(leaf_organ, carbon12_element))* ccohort%n - ccohort => ccohort%shorter - enddo !cohort + do s = 1, nsites - bc_out(s)%btran_pa(ifp) = 0.0_r8 - ccohort=>cpatch%tallest - do while(associated(ccohort)) - bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + & - ccohort%co_hydr%btran * & - (cCohort%prt%GetState(fnrt_organ, carbon12_element) + & - cCohort%prt%GetState(sapw_organ, carbon12_element) + & - cCohort%prt%GetState(leaf_organ, carbon12_element)) * & - ccohort%n / balive_patch - ccohort => ccohort%shorter - enddo !cohort - cpatch => cpatch%younger - enddo !end patch loop - end do - return - end subroutine BTranForHLMDiagnosticsFromCohortHydr + csite_hydr => sites(s)%si_hydr - ! ========================================================================== + if( sum(csite_hydr%l_aroot_layer) == 0._r8 ) then + bc_out(s)%qflx_soil2root_sisl(:) = 0._r8 + cycle + end if - subroutine FillDrainRhizShells(nsites, sites, bc_in, bc_out) - ! - ! Created by Brad Christoffersen, Jan 2016 - ! - ! !DESCRIPTION: - ! Parses out mean vertical water fluxes resulting from infiltration, - ! drainage, and vertical water movement (dwat_kgm2) over radially stratified - ! rhizosphere shells. - ! - ! The approach used is heuristic, but based on the principle that water - ! fluxing out of a layer will preferentially come from rhizosphere - ! shells with higher water contents/potentials within that layer, and - ! alternatively, that water fluxing into a layer will preferentially go - ! into shells with lower water contents/potentials. - ! - ! This principle is implemented by filling (draining) the rhizosphere - ! shells in order from the driest (wettest) shell to the wettest (driest). - ! Each shell is filled (drained) up (down) to the next wettest (driest) - ! shell until the change in mean layer water (dwat_kgm2) is accounted for. - ! - ! !USES: - ! - ! !ARGUMENTS: - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) - type(bc_in_type), intent(in) :: bc_in(nsites) - type(bc_out_type), intent(inout) :: bc_out(nsites) + + lat = sites(s)%lat + lon = sites(s)%lon + + nlevrhiz = csite_hydr%nlevrhiz + + ! AVERAGE ROOT WATER UPTAKE (BY RHIZOSPHERE SHELL) ACROSS ALL COHORTS WITHIN A COLUMN + dth_layershell_col(:,:) = 0._r8 + csite_hydr%dwat_veg = 0._r8 + csite_hydr%errh2o_hyd = 0._r8 + prev_h2oveg = csite_hydr%h2oveg + prev_h2osoil = sum(csite_hydr%h2osoi_liqvol_shell(:,:) * & + csite_hydr%v_shell(:,:)) * denh2o * AREA_INV + + bc_out(s)%qflx_ro_sisl(:) = 0._r8 + + ! Zero out diagnotsics that rely on accumulation + csite_hydr%sapflow_scpf(:,:) = 0._r8 + csite_hydr%rootuptake_sl(:) = 0._r8 + csite_hydr%rootuptake0_scpf(:,:) = 0._r8 + csite_hydr%rootuptake10_scpf(:,:) = 0._r8 + csite_hydr%rootuptake50_scpf(:,:) = 0._r8 + csite_hydr%rootuptake100_scpf(:,:) = 0._r8 + + ! Initialize water mass balancing terms [kg h2o / m2] + ! -------------------------------------------------------------------------------- + transp_flux = 0._r8 + root_flux = 0._r8 + + ! Initialize the delta in soil water and plant water storage + ! with the initial condition. + + !err_soil = delta_soil_storage - root_flux + !err_plot = delta_plant_storage - (root_flux - transp_flux) + + ifp = 0 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + if(cpatch%nocomp_pft_label.ne.0)then + ifp = ifp + 1 + + ! ---------------------------------------------------------------------------- + ! Objective: Partition the transpiration flux + ! specfied by the land model to the cohorts. The weighting + ! factor we use to downscale is the cohort combo term: g_sb_laweight + ! This term is the stomatal conductance multiplied by total leaf + ! area. gscan_patch is the sum over all cohorts, used to normalize. + ! ---------------------------------------------------------------------------- + + gscan_patch = 0.0_r8 + ccohort=>cpatch%tallest + do while(associated(ccohort)) + ccohort_hydr => ccohort%co_hydr + ccohort_hydr%psi_ag(1) = wrf_plant(leaf_p_media,ccohort%pft)%p%psi_from_th(ccohort_hydr%th_ag(1)) + gscan_patch = gscan_patch + ccohort%g_sb_laweight + ccohort => ccohort%shorter + enddo !cohort + + ! The HLM predicted transpiration flux even though no leaves are present? + if(bc_in(s)%qflx_transp_pa(ifp) > 1.e-10_r8 .and. gscan_patchcpatch%tallest + do while(associated(ccohort)) - do s = 1,nsites + ccohort_hydr => ccohort%co_hydr + ft = ccohort%pft + ! Relative transpiration of this cohort from the whole patch + ! Note that g_sb_laweight / gscan_patch is the weighting that gives cohort contribution per area + ! [mm H2O/plant/s] = [mm H2O/ m2 / s] * [m2 / patch] * [cohort/plant] * [patch/cohort] - ! First step, identify how the liquid water in each layer has changed - ! since the last time it was updated. This should be due to drainage. - ! The drainage component should be the total change in liquid water content from the last time - ! the hydraulics driver was called, and then adding back in the losses due to root uptake - ! (which was already taken out). + ! This can cause large transpiration due to small g_sb_laweight + if(ccohort%g_sb_laweight>nearzero) then + qflx_tran_veg_indiv = bc_in(s)%qflx_transp_pa(ifp) * cpatch%total_canopy_area * & + (ccohort%g_sb_laweight/gscan_patch)/ccohort%n + else + qflx_tran_veg_indiv = 0._r8 + end if - ! BOC: This was previously in HydrologyDrainage: + ! Save the transpiration flux for diagnostics (currently its a constant boundary condition) + ccohort_hydr%qtop = qflx_tran_veg_indiv*dtime + + transp_flux = transp_flux + (qflx_tran_veg_indiv*dtime)*ccohort%n*AREA_INV + + ! VERTICAL LAYER CONTRIBUTION TO TOTAL ROOT WATER UPTAKE OR LOSS + ! _____ + ! | | + ! |leaf | + ! |_____| + ! / + ! \ + ! / + ! __\__ + ! | | + ! |stem | + ! |_____| + !------/----------------_____--------------------------------- + ! \ | | | | | | | + ! / _/\/\|aroot| | |shell | shell | shell | layer j-1 + ! \ _/ |_____| | | k-1 | k | k+1 | + !------/------_/--------_____-------------------------------------- + ! \ _/ | | | | | | | + ! __/__ / _/\/\/\/\/|aroot| | | shell | shell | shell | layer j + ! | |_/ |_____| | | k-1 | k | k+1 | + !---|troot|-------------_____---------------------------------------------- + ! |_____|\_ | | | | | | | + ! \/\/\/\/\/|aroot| | | shell | shell | shell | layer j+1 + ! |_____| | | k-1 | k | k+1 | + !--------------------------------------------------------------------------- + + ! This routine will update the theta values for 1 cohort's flow-path + ! from leaf to the current soil layer. This does NOT + ! update cohort%th_* + + if(hydr_solver_type == hydr_solver_2DNewton) then - csite_hydr => sites(s)%si_hydr + call MatSolve2D(csite_hydr,ccohort,ccohort_hydr, & + dtime,qflx_tran_veg_indiv, & + sapflow,rootuptake(1:nlevrhiz),wb_err_plant,dwat_plant, & + dth_layershell_col) + + elseif(hydr_solver_type == hydr_solver_2DPicard) then - do j = 1,csite_hydr%nlevrhiz - j_bc = j+csite_hydr%i_rhiz_t-1 + call PicardSolve2D(csite_hydr,ccohort,ccohort_hydr, & + dtime,qflx_tran_veg_indiv, & + sapflow,rootuptake(1:nlevrhiz),wb_err_plant,dwat_plant, & + dth_layershell_col,csite_hydr%num_nodes) + + elseif(hydr_solver_type == hydr_solver_1DTaylor ) then + + ! --------------------------------------------------------------------------------- + ! Approach: do nlevsoi_hyd sequential solutions to Richards' equation, + ! each of which encompass all plant nodes and soil nodes for a given soil layer j, + ! with the timestep fraction for each layer-specific solution proportional to each + ! layer's contribution to the total root-soil conductance + ! Water potential in plant nodes is updated after each solution + ! As such, the order across soil layers in which the solution is conducted matters. + ! For now, the order proceeds across soil layers in order of decreasing root-soil conductance + ! NET EFFECT: total water removed from plant-soil system remains the same: it + ! sums up to total transpiration (qflx_tran_veg_indiv*dtime) + ! root water uptake in each layer is proportional to each layer's total + ! root length density and soil matric potential + ! root hydraulic redistribution emerges within this sequence when a + ! layers have transporting-to-absorbing root water potential gradients of opposite sign + ! ----------------------------------------------------------------------------------- + + call OrderLayersForSolve1D(csite_hydr, ccohort, ccohort_hydr, ordered, kbg_layer) + + call ImTaylorSolve1D(lat,lon,recruitflag,csite_hydr,ccohort,ccohort_hydr, & + dtime,qflx_tran_veg_indiv,ordered, kbg_layer, & + sapflow,rootuptake(1:nlevrhiz), & + wb_err_plant,dwat_plant, & + dth_layershell_col) - cumShellH2O=sum(csite_hydr%h2osoi_liqvol_shell(j,:) *csite_hydr%v_shell(j,:)) * denh2o*AREA_INV - - dwat_kgm2 = bc_in(s)%h2o_liq_sisl(j_bc) - cumShellH2O - - dwat_kg = dwat_kgm2 * AREA - - ! order shells in terms of increasing or decreasing volumetric water content - ! algorithm same as that used in histFileMod.F90 to alphabetize history tape contents - if(nshell > 1) then - do k = nshell-1,1,-1 - do kk = 1,k - if (csite_hydr%h2osoi_liqvol_shell(j,ordered(kk)) > & - csite_hydr%h2osoi_liqvol_shell(j,ordered(kk+1))) then - if (dwat_kg > 0._r8) then !order increasing - tmp = ordered(kk) - ordered(kk) = ordered(kk+1) - ordered(kk+1) = tmp - end if - else - if (dwat_kg < 0._r8) then !order decreasing - tmp = ordered(kk) - ordered(kk) = ordered(kk+1) - ordered(kk+1) = tmp - end if - end if - enddo - enddo - end if - - ! fill shells with water up to the water content of the next-wettest shell, - ! in order from driest to wettest (dwat_kg > 0) - ! ------ OR ------ - ! drain shells' water down to the water content of the next-driest shell, - ! in order from wettest to driest (dwat_kg < 0) - k = 1 - do while ( (dwat_kg /= 0._r8) .and. (k < nshell) ) - thdiff = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) - & - csite_hydr%h2osoi_liqvol_shell(j,ordered(k)) - v_cum = sum(csite_hydr%v_shell(j,ordered(1:k))) - wdiff = thdiff * v_cum * denh2o ! change in h2o [kg / ha] for shells ordered(1:k) - if(abs(dwat_kg) >= abs(wdiff)) then - csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = csite_hydr%h2osoi_liqvol_shell(j,ordered(k+1)) - dwat_kg = dwat_kg - wdiff - else - csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) = & - csite_hydr%h2osoi_liqvol_shell(j,ordered(1:k)) + dwat_kg/denh2o/v_cum - dwat_kg = 0._r8 - end if - k = k + 1 - enddo - - if (dwat_kg /= 0._r8) then - v_cum = sum(csite_hydr%v_shell(j,ordered(1:nshell))) - thdiff = dwat_kg / v_cum / denh2o - do k = nshell, 1, -1 - csite_hydr%h2osoi_liqvol_shell(j,k) = csite_hydr%h2osoi_liqvol_shell(j,k) + thdiff - end do - end if - - ! m3/m3 * Total volume m3 * kg/m3 = kg - h2osoi_liq_shell(j,:) = csite_hydr%h2osoi_liqvol_shell(j,:) * & - csite_hydr%v_shell(j,:) * denh2o - - - errh2o(j) = sum(h2osoi_liq_shell(j,:))*AREA_INV - bc_in(s)%h2o_liq_sisl(j_bc) - - if (abs(errh2o(j)) > 1.e-9_r8) then - write(fates_log(),*)'WARNING: water balance error in FillDrainRhizShells' - write(fates_log(),*)'errh2o= ',errh2o(j), ' [kg/m2]' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end do + end if - end do - return - end subroutine FillDrainRhizShells + ! Remember the error for the cohort + ccohort_hydr%errh2o = ccohort_hydr%errh2o + wb_err_plant - ! ==================================================================================== + ! Update total error in [kg/m2 ground] + csite_hydr%errh2o_hyd = csite_hydr%errh2o_hyd + wb_err_plant*ccohort%n*AREA_INV - subroutine hydraulics_bc ( nsites, sites, bc_in, bc_out, dtime) + ! Accumulate site level diagnostic of plant water change [kg/m2] + ! (this is zerod) + csite_hydr%dwat_veg = csite_hydr%dwat_veg + dwat_plant*ccohort%n*AREA_INV - ! ---------------------------------------------------------------------------------- - ! added by Brad Christoffersen Jan 2016 for use in ED hydraulics - ! van Genuchten (1980)-specific functions for the swc (soil water characteristic) - ! and for the kunsat (unsaturated hydraulic conductivity) curves. Test mod 06/20/2016 + ! Update total site-level stored plant water [kg/m2] + ! (this is not zerod, but incremented) + csite_hydr%h2oveg = csite_hydr%h2oveg + dwat_plant*ccohort%n*AREA_INV - ! resolved the mass-balance bugs and tested Jan, 2018 by C. XU - ! - ! BOC...for quick implementation avoided JT's abstract interface, - ! but these should be converted to interfaces in the future - ! ---------------------------------------------------------------------------------- + sc = ccohort%size_class - ! - ! !DESCRIPTION: - !s - ! !USES: - use FatesUtilsMod , only : check_var_real + ! Sapflow diagnostic [kg/ha/s] + csite_hydr%sapflow_scpf(sc,ft) = csite_hydr%sapflow_scpf(sc,ft) + sapflow*ccohort%n/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 + ! Root uptake per pft x size class, over set layer depths [kg/ha/m/s] + ! These are normalized by depth (in case the desired horizon extends + ! beyond the actual rhizosphere) - ! - ! !LOCAL VARIABLES: - integer :: iv ! leaf layer - integer :: ifp ! index of FATES patch - integer :: s ! index of FATES site - integer :: i ! shell index - integer :: j,jj ! soil layer - integer :: j_bc ! soil layer index for boundary conditions - integer :: k ! 1D plant-soil continuum array - integer :: ft ! plant functional type index - integer :: sz ! plant's size class index - integer :: t ! previous timesteps (for lwp stability calculation) - integer :: nstep !number of time steps + csite_hydr%rootuptake0_scpf(sc,ft) = csite_hydr%rootuptake0_scpf(sc,ft) + & + SumBetweenDepths(csite_hydr,0._r8,0.1_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - !---------------------------------------------------------------------- + csite_hydr%rootuptake10_scpf(sc,ft) = csite_hydr%rootuptake10_scpf(sc,ft) + & + SumBetweenDepths(csite_hydr,0.1_r8,0.5_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - type (ed_patch_type), pointer :: cpatch ! current patch pointer - type (ed_cohort_type), pointer :: ccohort ! current cohort pointer - type(ed_site_hydr_type), pointer :: site_hydr ! site hydraulics pointer - type(ed_cohort_hydr_type), pointer :: ccohort_hydr ! cohort hydraulics pointer + csite_hydr%rootuptake50_scpf(sc,ft) = csite_hydr%rootuptake50_scpf(sc,ft) + & + SumBetweenDepths(csite_hydr,0.5_r8,1.0_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - ! Local arrays + csite_hydr%rootuptake100_scpf(sc,ft) = csite_hydr%rootuptake100_scpf(sc,ft) + & + SumBetweenDepths(csite_hydr,1.0_r8,1.e10_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - ! accumulated water content change over all cohorts in a column [m3 m-3] - real(r8) :: dth_layershell_col(nlevsoi_hyd_max,nshell) + ! --------------------------------------------------------- + ! Update water potential and frac total conductivity + ! of plant compartments + ! --------------------------------------------------------- - ! array of soil layer indices which have been ordered - integer :: ordered(nlevsoi_hyd_max) = (/(j,j=1,nlevsoi_hyd_max,1)/) + call UpdatePlantPsiFTCFromTheta(ccohort,csite_hydr) - ! total absorbing root & rhizosphere conductance (over all shells) by soil layer [MPa] - real(r8) :: kbg_layer(nlevsoi_hyd_max) - real(r8) :: rootuptake(nlevsoi_hyd_max) ! mass-flux from 1st rhizosphere to absorbing roots [kg/indiv/layer/step] - - real(r8) :: site_runoff ! If plants are pushing water into saturated soils, we create - ! runoff. This is either banked, or sent to the correct flux pool [kg/m2] - real(r8) :: aroot_frac_plant ! The fraction of the total length of absorbing roots contained in one soil layer - ! that are devoted to a single plant - real(r8) :: wb_err_plant ! Solve error for a single plant [kg] - real(r8) :: wb_check_site ! the water balance error we get from summing fluxes - ! and changes in storage - ! and is just a double check on our error accounting). [kg/m2] - real(r8) :: dwat_plant ! change in water mass in the whole plant [kg] - real(r8) :: qflx_tran_veg_indiv ! individiual transpiration rate [kgh2o indiv-1 s-1] - real(r8) :: gscan_patch ! sum of ccohort%gscan across all cohorts within a patch - real(r8) :: sapflow ! mass-flux for the cohort between transporting root and stem [kg/indiv/step] - real(r8) :: prev_h2oveg ! plant water storage at start of timestep (kg/m2) - real(r8) :: prev_h2osoil ! soil water storage at start of timestep (kg/m2) - logical :: recruitflag ! flag to check if there is newly recruited cohorts - real(r8) :: root_flux ! total water flux into roots [kg/m2] - real(r8) :: transp_flux ! total transpiration flux from plants [kg/m2] - real(r8) :: delta_plant_storage ! change in plant water storage over the step [kg/m2] - real(r8) :: delta_soil_storage ! change in soil water storage over the step [kg/m2] - real(r8) :: sumcheck ! used to debug mass balance in soil horizon diagnostics - integer :: nlevrhiz ! local for number of rhizosphere levels - integer :: sc ! size class index + ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) - - - ! ---------------------------------------------------------------------------------- - ! Important note: We are interested in calculating the total fluxes in and out of the - ! site/column. Usually, when we do things like this, we acknowledge that FATES - ! does not consider the bare ground patch. However, since this routine - ! calculates "column level" fluxes, we have to factor in that patch-level fluxes - ! are only accounting for a portion of the area. - ! ---------------------------------------------------------------------------------- - !For newly recruited cohorts, add the water uptake demand to csite_hydr%recruit_w_uptake - call RecruitWUptake(nsites,sites,bc_in,dtime,recruitflag) + ccohort => ccohort%shorter + enddo !cohort + endif ! not bareground patch + cpatch => cpatch%younger + enddo !patch - !update water storage in veg after incorporating newly recuited cohorts - if(recruitflag)then - do s = 1, nsites - call UpdateH2OVeg(sites(s),bc_out(s)) - end do - end if - - do s = 1, nsites + ! -------------------------------------------------------------------------------- + ! The cohort level water fluxes are complete, the remainder of this subroutine + ! is dedicated to doing site level resulting mass balance calculations and checks + ! -------------------------------------------------------------------------------- - site_hydr => sites(s)%si_hydr + ! Calculate the amount of water fluxing through the roots. It is the sum + ! of the change in thr rhizosphere shells. Note that following this calculation + ! we may adjust the change in soil water to avoid super-saturation and sub-residual + ! water contents. But the pre-adjusted value is the actual amount of root flux. + ! [kg/m2] - nlevrhiz = site_hydr%nlevrhiz - - ! AVERAGE ROOT WATER UPTAKE (BY RHIZOSPHERE SHELL) ACROSS ALL COHORTS WITHIN A COLUMN - dth_layershell_col(:,:) = 0._r8 - site_hydr%dwat_veg = 0._r8 - site_hydr%errh2o_hyd = 0._r8 - prev_h2oveg = site_hydr%h2oveg - prev_h2osoil = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & - site_hydr%v_shell(:,:)) * denh2o * AREA_INV - - bc_out(s)%qflx_ro_sisl(:) = 0._r8 - - ! Zero out diagnotsics that rely on accumulation - site_hydr%sapflow_scpf(:,:) = 0._r8 - site_hydr%rootuptake_sl(:) = 0._r8 - site_hydr%rootuptake0_scpf(:,:) = 0._r8 - site_hydr%rootuptake10_scpf(:,:) = 0._r8 - site_hydr%rootuptake50_scpf(:,:) = 0._r8 - site_hydr%rootuptake100_scpf(:,:) = 0._r8 - - ! Initialize water mass balancing terms [kg h2o / m2] - ! -------------------------------------------------------------------------------- - transp_flux = 0._r8 - root_flux = 0._r8 - - ! Initialize the delta in soil water and plant water storage - ! with the initial condition. - - !err_soil = delta_soil_storage - root_flux - !err_plot = delta_plant_storage - (root_flux - transp_flux) + root_flux = -sum(dth_layershell_col(1:csite_hydr%nlevrhiz,:)*csite_hydr%v_shell(:,:))*denh2o*AREA_INV - ifp = 0 - cpatch => sites(s)%oldest_patch - do while (associated(cpatch)) - ifp = ifp + 1 - - ! ---------------------------------------------------------------------------- - ! Objective: Partition the transpiration flux - ! specfied by the land model to the cohorts. The weighting - ! factor we use to downscale is the cohort combo term: g_sb_laweight - ! This term is the stomatal conductance multiplied by total leaf - ! area. gscan_patch is the sum over all cohorts, used to normalize. - ! ---------------------------------------------------------------------------- - - gscan_patch = 0.0_r8 - ccohort=>cpatch%tallest - do while(associated(ccohort)) - ccohort_hydr => ccohort%co_hydr - gscan_patch = gscan_patch + ccohort%g_sb_laweight - ccohort => ccohort%shorter - enddo !cohort - - ! The HLM predicted transpiration flux even though no leaves are present? - if(bc_in(s)%qflx_transp_pa(ifp) > 1.e-10_r8 .and. gscan_patchcpatch%tallest - do while(associated(ccohort)) + if(debug)then + write(fates_log(),*) 'root_flux: ', root_flux + end if - ccohort_hydr => ccohort%co_hydr - ft = ccohort%pft + ! Since not all layers have roots, we filter, therefore zero fluxes + bc_out(s)%qflx_soil2root_sisl(:) = 0._r8 + bc_out(s)%qflx_ro_sisl(:) = 0._r8 - ! Relative transpiration of this cohort from the whole patch - ! Note that g_sb_laweight / gscan_patch is the weighting that gives cohort contribution per area - ! [mm H2O/plant/s] = [mm H2O/ m2 / s] * [m2 / patch] * [cohort/plant] * [patch/cohort] + ! To disaggregate, we need the root density (length) on the soil layer + csite_hydr%rootl_sl(:) = 0._r8 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ccohort=>cpatch%tallest + do while(associated(ccohort)) - if(ccohort%g_sb_laweight>nearzero) then - qflx_tran_veg_indiv = bc_in(s)%qflx_transp_pa(ifp) * cpatch%total_canopy_area * & - (ccohort%g_sb_laweight/gscan_patch)/ccohort%n - else - qflx_tran_veg_indiv = 0._r8 - end if + sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) + ft = ccohort%pft + + call MaximumRootingDepth(ccohort%dbh,ft,bc_in(s)%zi_sisl(bc_in(s)%nlevsoil),z_fr) - ! Save the transpiration flux for diagnostics (currently its a constant boundary condition) - ccohort_hydr%qtop = qflx_tran_veg_indiv*dtime - - transp_flux = transp_flux + (qflx_tran_veg_indiv*dtime)*ccohort%n*AREA_INV - - ! VERTICAL LAYER CONTRIBUTION TO TOTAL ROOT WATER UPTAKE OR LOSS - ! _____ - ! | | - ! |leaf | - ! |_____| - ! / - ! \ - ! / - ! __\__ - ! | | - ! |stem | - ! |_____| - !------/----------------_____--------------------------------- - ! \ | | | | | | | - ! / _/\/\|aroot| | |shell | shell | shell | layer j-1 - ! \ _/ |_____| | | k-1 | k | k+1 | - !------/------_/--------_____-------------------------------------- - ! \ _/ | | | | | | | - ! __/__ / _/\/\/\/\/|aroot| | | shell | shell | shell | layer j - ! | |_/ |_____| | | k-1 | k | k+1 | - !---|troot|-------------_____---------------------------------------------- - ! |_____|\_ | | | | | | | - ! \/\/\/\/\/|aroot| | | shell | shell | shell | layer j+1 - ! |_____| | | k-1 | k | k+1 | - !--------------------------------------------------------------------------- - - - if(use_2d_hydrosolve) then - - call MatSolve2D(bc_in(s),site_hydr,ccohort,ccohort_hydr, & - dtime,qflx_tran_veg_indiv, & - sapflow,rootuptake(1:nlevrhiz),wb_err_plant,dwat_plant, & - dth_layershell_col) - - else + do j_bc = 1,bc_in(s)%nlevsoil + + rootfr = zeng2001_crootfr(prt_params%fnrt_prof_a(ft),prt_params%fnrt_prof_b(ft),bc_in(s)%zi_sisl(j_bc),z_fr) - & + zeng2001_crootfr(prt_params%fnrt_prof_a(ft),prt_params%fnrt_prof_b(ft), bc_in(s)%zi_sisl(j_bc)-bc_in(s)%dz_sisl(j_bc),z_fr) - ! --------------------------------------------------------------------------------- - ! Approach: do nlevsoi_hyd sequential solutions to Richards' equation, - ! each of which encompass all plant nodes and soil nodes for a given soil layer j, - ! with the timestep fraction for each layer-specific solution proportional to each - ! layer's contribution to the total root-soil conductance - ! Water potential in plant nodes is updated after each solution - ! As such, the order across soil layers in which the solution is conducted matters. - ! For now, the order proceeds across soil layers in order of decreasing root-soil conductance - ! NET EFFECT: total water removed from plant-soil system remains the same: it - ! sums up to total transpiration (qflx_tran_veg_indiv*dtime) - ! root water uptake in each layer is proportional to each layer's total - ! root length density and soil matric potential - ! root hydraulic redistribution emerges within this sequence when a - ! layers have transporting-to-absorbing root water potential gradients of opposite sign - ! ----------------------------------------------------------------------------------- - - call OrderLayersForSolve1D(site_hydr, ccohort, ccohort_hydr, ordered, kbg_layer) - - call ImTaylorSolve1D(site_hydr,ccohort,ccohort_hydr, & - dtime,qflx_tran_veg_indiv,ordered, kbg_layer, & - sapflow,rootuptake(1:nlevrhiz), & - wb_err_plant,dwat_plant, & - dth_layershell_col) + csite_hydr%rootl_sl(j_bc) = csite_hydr%rootl_sl(j_bc) + sum_l_aroot*rootfr*ccohort%n*prt_params%c2b(ft)*EDPftvarcon_inst%hydr_srl(ft) + + end do + + ccohort => ccohort%shorter + enddo !cohort + cpatch => cpatch%younger + enddo !patch + + + do j=1,csite_hydr%nlevrhiz + + + ! loginfo + if (debug) then + write(fates_log(),*) 'hydraulics_bc() position I' + write(fates_log(),*) 'layer: ', j + write(fates_log(),*) 'dth_layershell_col(j,:):', dth_layershell_col(j,:) + write(fates_log(),*) 'csite_hydr%v_shell(j,:):', csite_hydr%v_shell(j,:) + write(fates_log(),*) 'csite_hydr%h2osoi_liqvol_shell: ', csite_hydr%h2osoi_liqvol_shell(j,:) + write(fates_log(),*) 'dth_layershell_col(j,:) ', dth_layershell_col(j,:) + write(fates_log(),*) 'csite_hydr%l_aroot_layer(j): ' , csite_hydr%l_aroot_layer(j) + endif + + if (csite_hydr%l_aroot_layer(j) > nearzero) then - end if - ! Remember the error for the cohort - ccohort_hydr%errh2o = ccohort_hydr%errh2o + wb_err_plant - - ! Update total error in [kg/m2 ground] - site_hydr%errh2o_hyd = site_hydr%errh2o_hyd + wb_err_plant*ccohort%n*AREA_INV + ! Update the site-level state variable + ! rhizosphere shell water content [m3/m3] + csite_hydr%h2osoi_liqvol_shell(j,:) = csite_hydr%h2osoi_liqvol_shell(j,:) + & + dth_layershell_col(j,:) - ! Accumulate site level diagnostic of plant water change [kg/m2] - ! (this is zerod) - site_hydr%dwat_veg = site_hydr%dwat_veg + dwat_plant*ccohort%n*AREA_INV - - ! Update total site-level stored plant water [kg/m2] - ! (this is not zerod, but incremented) - site_hydr%h2oveg = site_hydr%h2oveg + dwat_plant*ccohort%n*AREA_INV + ! Total root uptake flux at the rhizosphere layer [mm h2o/s] = [kg h2o/m2/s] + qflx_soil2root_rhiz = & + -(sum(dth_layershell_col(j,:)*csite_hydr%v_shell(j,:))*denh2o*AREA_INV/dtime) + & + csite_hydr%recruit_w_uptake(j) - sc = ccohort%size_class - - ! Sapflow diagnostic [kg/ha/s] - site_hydr%sapflow_scpf(sc,ft) = site_hydr%sapflow_scpf(sc,ft) + sapflow*ccohort%n/dtime + + ! -------------------------- Disaggregation --------------------------------- + ! Partition the uptake flux into the soil layers + + j_t = csite_hydr%map_r2s(j,1) + j_b = csite_hydr%map_r2s(j,2) + + sumweight = 0._r8 + do j_bc = j_t,j_b + if(rootflux_disagg == soilk_disagg)then + ! Weight disaggregation by K*dz, but only for flux + ! into the root, othersize weight by depth + if(qflx_soil2root_rhiz>0._r8)then + ! h2osoi_liqvol: [kg/m2] / [m] / [kg/m3] = [m3/m3] + eff_por = bc_in(s)%eff_porosity_sl(j_bc) + h2osoi_liqvol = min(eff_por, bc_in(s)%h2o_liq_sisl(j_bc)/(bc_in(s)%dz_sisl(j_bc)*denh2o)) + psi_layer = csite_hydr%wrf_soil(j)%p%psi_from_th(h2osoi_liqvol) + ftc_layer = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_layer) + weight_sl(j_bc) = bc_in(s)%hksat_sisl(j_bc)*ftc_layer*csite_hydr%rootl_sl(j_bc) + else + weight_sl(j_bc) = csite_hydr%rootl_sl(j_bc) + end if + elseif(rootflux_disagg == soilz_disagg) then + ! weight by depth + weight_sl(j_bc) = csite_hydr%rootl_sl(j_bc) + else + write(fates_log(),*) 'Unknown rhiz->soil disaggregation method',rootflux_disagg + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + sumweight = sumweight + weight_sl(j_bc) + end do - ! Root uptake per rhiz layer [kg/ha/s] - site_hydr%rootuptake_sl(1:nlevrhiz) = site_hydr%rootuptake_sl(1:nlevrhiz) + & - rootuptake(1:nlevrhiz)*ccohort%n/dtime + ! Second pass, apply normalized weighting factors for fluxes + do j_bc = j_t,j_b + + ! Fill the output array to the HLM + bc_out(s)%qflx_soil2root_sisl(j_bc) = qflx_soil2root_rhiz * weight_sl(j_bc)/sumweight - ! Root uptake per pft x size class, over set layer depths [kg/ha/m/s] - ! These are normalized by depth (in case the desired horizon extends - ! beyond the actual rhizosphere) + ! Save root uptake for history diagnostics [kg/m/s] + csite_hydr%rootuptake_sl(j_bc) = qflx_soil2root_rhiz * weight_sl(j_bc)/sumweight + + end do - site_hydr%rootuptake0_scpf(sc,ft) = site_hydr%rootuptake0_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,0._r8,0.1_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime + end if + + enddo + + ! Removed supersaturation purge because + ! calculation is messier now that roots are on + ! different layering system. + ! see tags prior to 1.52.0_api.20.0.0 + ! to revive old code (RGK 12-2021) + bc_out(s)%qflx_ro_sisl(:) = 0._r8 + + ! Note that the cohort-level solvers are expected to update + ! csite_hydr%h2oveg + + ! Calculate site total kg's of runoff + site_runoff = sum(bc_out(s)%qflx_ro_sisl(:))*dtime + + delta_plant_storage = csite_hydr%h2oveg - prev_h2oveg + + delta_soil_storage = sum(csite_hydr%h2osoi_liqvol_shell(:,:) * & + csite_hydr%v_shell(:,:)) * denh2o * AREA_INV - prev_h2osoil + + if(abs(delta_plant_storage - (root_flux - transp_flux)) > error_thresh ) then + write(fates_log(),*) 'Site plant water balance does not close' + write(fates_log(),*) 'delta plant storage: ',delta_plant_storage,' [kg/m2]' + write(fates_log(),*) 'integrated root flux: ',root_flux,' [kg/m2]' + write(fates_log(),*) 'transpiration flux: ',transp_flux,' [kg/m2]' + write(fates_log(),*) 'end storage: ',csite_hydr%h2oveg + write(fates_log(),*) 'pre_h2oveg', prev_h2oveg + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - site_hydr%rootuptake10_scpf(sc,ft) = site_hydr%rootuptake10_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,0.1_r8,0.5_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime + !----------------------------------------------------------------------- + ! mass balance check and pass the total stored vegetation water to HLM + ! in order for it to fill its balance checks - site_hydr%rootuptake50_scpf(sc,ft) = site_hydr%rootuptake50_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,0.5_r8,1.0_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - site_hydr%rootuptake100_scpf(sc,ft) = site_hydr%rootuptake100_scpf(sc,ft) + & - SumBetweenDepths(site_hydr,1.0_r8,1.e10_r8,rootuptake(1:nlevrhiz))*ccohort%n/dtime - - ! --------------------------------------------------------- - ! Update water potential and frac total conductivity - ! of plant compartments - ! --------------------------------------------------------- - - call UpdatePlantPsiFTCFromTheta(ccohort,site_hydr) + ! Compare the integrated error to the site mass balance + ! error sign is positive towards transpiration overestimation + ! Loss fluxes should = decrease in storage + ! (transp_flux + site_runoff) = -(delta_plant_storage+delta_soil_storage ) - ccohort_hydr%btran = wkf_plant(stomata_p_media,ft)%p%ftc_from_psi(ccohort_hydr%psi_ag(1)) - + wb_check_site = delta_plant_storage+delta_soil_storage+site_runoff+transp_flux - ccohort => ccohort%shorter - enddo !cohort + ! Now check on total error + if( abs(wb_check_site) > 1.e-4_r8 ) then + write(fates_log(),*) 'FATES hydro water balance does not add up [kg/m2]' + write(fates_log(),*) 'csite_hydr%errh2o_hyd: ',wb_check_site + write(fates_log(),*) 'delta_plant_storage: ',delta_plant_storage + write(fates_log(),*) 'delta_soil_storage: ',delta_soil_storage + write(fates_log(),*) 'site_runoff: ',site_runoff + write(fates_log(),*) 'transp_flux: ',transp_flux + end if - cpatch => cpatch%younger - enddo !patch - ! -------------------------------------------------------------------------------- - ! The cohort level water fluxes are complete, the remainder of this subroutine - ! is dedicated to doing site level resulting mass balance calculations and checks - ! -------------------------------------------------------------------------------- + csite_hydr%h2oveg_hydro_err = csite_hydr%h2oveg_hydro_err + csite_hydr%errh2o_hyd - ! Calculate the amount of water fluxing through the roots. It is the sum - ! of the change in thr rhizosphere shells. Note that following this calculation - ! we may adjust the change in soil water to avoid super-saturation and sub-residual - ! water contents. But the pre-adjusted value is the actual amount of root flux. - ! [kg/m2] - root_flux = -sum(dth_layershell_col(1:site_hydr%nlevrhiz,:)*site_hydr%v_shell(:,:))*denh2o*AREA_INV + call UpdateH2OVeg(sites(s),bc_out(s)) - - do j=1,site_hydr%nlevrhiz - j_bc = j+site_hydr%i_rhiz_t-1 - - ! Update the site-level state variable - ! rhizosphere shell water content [m3/m3] - site_hydr%h2osoi_liqvol_shell(j,:) = site_hydr%h2osoi_liqvol_shell(j,:) + & - dth_layershell_col(j,:) + enddo !site + return +end subroutine Hydraulics_BC - bc_out(s)%qflx_soil2root_sisl(j_bc) = & - -(sum(dth_layershell_col(j,:)*site_hydr%v_shell(j,:))*denh2o*AREA_INV/dtime) + & - site_hydr%recruit_w_uptake(j) - - - ! Save the amount of liquid soil water known to the model after root uptake - ! This calculation also assumes that 1mm of water is 1kg - site_hydr%h2osoi_liq_prev(j) = bc_in(s)%h2o_liq_sisl(j_bc) - & - dtime*bc_out(s)%qflx_soil2root_sisl(j_bc) - - - ! We accept that it is possible for gravity to push - ! water into saturated soils, particularly at night when - ! transpiration has stopped. In the real world, the water - ! would be driven out of the layer, although we have no - ! boundary flux on the rhizospheres in these substeps. To accomodate - ! this, if soils are pushed beyond saturation minus a small buffer - ! then we remove that excess, send it to a runoff pool, and - ! fix the node's water content to the saturation minus buffer value - - site_runoff = 0._r8 - if(purge_supersaturation) then - do i = 1,nshell - if(site_hydr%h2osoi_liqvol_shell(j,i)>(bc_in(s)%watsat_sisl(j_bc)-thsat_buff)) then - - ! [m3/m3] * [kg/m3] * [m3/site] * [site/m2] => [kg/m2] - site_runoff = site_runoff + & - (site_hydr%h2osoi_liqvol_shell(j,i)-(bc_in(s)%watsat_sisl(j_bc)-thsat_buff)) * & - site_hydr%v_shell(j,i)*AREA_INV*denh2o - - site_hydr%h2osoi_liqvol_shell(j,i) = bc_in(s)%watsat_sisl(j_bc)-thsat_buff - - end if - end do - - bc_out(s)%qflx_ro_sisl(j_bc) = site_runoff/dtime - end if - enddo +! ===================================================================================== - - ! Note that the cohort-level solvers are expected to update - ! site_hydr%h2oveg - ! Calculate site total kg's of runoff - site_runoff = sum(bc_out(s)%qflx_ro_sisl(:))*dtime - - delta_plant_storage = site_hydr%h2oveg - prev_h2oveg - - delta_soil_storage = sum(site_hydr%h2osoi_liqvol_shell(:,:) * & - site_hydr%v_shell(:,:)) * denh2o * AREA_INV - prev_h2osoil - - if(abs(delta_plant_storage - (root_flux - transp_flux)) > error_thresh ) then - - write(fates_log(),*) 'Site plant water balance does not close' - write(fates_log(),*) 'balance error: ',abs(delta_plant_storage - (root_flux - transp_flux)) - write(fates_log(),*) 'delta plant storage: ',delta_plant_storage,' [kg/m2]' - write(fates_log(),*) 'integrated root flux: ',root_flux,' [kg/m2]' - write(fates_log(),*) 'transpiration flux: ',transp_flux,' [kg/m2]' - write(fates_log(),*) 'end storage: ',site_hydr%h2oveg - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - if(abs(delta_soil_storage + root_flux + site_runoff) > 1.e-3_r8 ) then - write(fates_log(),*) 'Site soil water balance does not close' - write(fates_log(),*) 'delta soil storage: ',delta_soil_storage,' [kg/m2]' - write(fates_log(),*) 'integrated root flux (pos into root): ',root_flux,' [kg/m2]' - write(fates_log(),*) 'site runoff: ',site_runoff,' [kg/m2]' - write(fates_log(),*) 'end storage: ',sum(site_hydr%h2osoi_liqvol_shell(:,:) * & - site_hydr%v_shell(:,:)) * denh2o * AREA_INV, & - ' [kg/m2]' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if +subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr) - !----------------------------------------------------------------------- - ! mass balance check and pass the total stored vegetation water to HLM - ! in order for it to fill its balance checks + ! --------------------------------------------------------------------------------- + ! + ! This routine sets the maximum conductance of all compartments in the plant, from + ! leaves, to stem, to transporting root, to the absorbing roots. + ! These properties are dependent only on the materials (conductivity) and the + ! geometry of the compartments. + ! The units of all K_max values are [kg H2O s-1 MPa-1] + ! + ! There are some different ways to represent overall conductance from node-to-node + ! throughout the hydraulic system. Universally, all can make use of a system + ! where we separate the hydraulic compartments of the nodes into the upper (closer + ! to the sky) and lower (away from the sky) portions of the compartment. It is + ! possible that due to things like xylem taper, the two portions may have different + ! conductivity, and therefore differnet conductances. + ! + ! Assumption 0. This routine calculates maximum conductivity for 1 plant. + ! Assumption 1. The compartment volumes, heights and lengths have all been + ! determined, probably called just before this routine. + ! + ! Steudle, E. Water uptake by roots: effects of water deficit. + ! J Exp Bot 51, 1531-1542, doi:DOI 10.1093/jexbot/51.350.1531 (2000). + ! --------------------------------------------------------------------------------- + + ! Arguments + + type(ed_cohort_hydr_type),intent(inout),target :: ccohort_hydr + type(ed_cohort_type),intent(in),target :: ccohort + type(ed_site_hydr_type),intent(in),target :: csite_hydr + + ! Locals + integer :: k ! Compartment (node) index + integer :: j ! Soil layer index + integer :: k_ag ! Compartment index for above-ground indexed array + integer :: pft ! Plant Functional Type index + real(r8) :: c_sap_dummy ! Dummy variable (unused) with sapwood carbon [kg] + real(r8) :: z_lower ! distance between lower edge and mean petiole height [m] + real(r8) :: z_upper ! distance between upper edge and mean petiole height [m] + real(r8) :: z_node ! distance between compartment center and mph [m] + real(r8) :: kmax_lower ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] + real(r8) :: kmax_node ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] + real(r8) :: kmax_upper ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] + real(r8) :: a_sapwood ! Mean cross section area of sapwood [m2] + real(r8) :: rmin_ag ! Minimum total resistance of all above ground pathways + ! [kg-1 s MPa] + real(r8) :: kmax_bg ! Total maximum conductance of all below-ground pathways + ! from the absorbing roots center nodes to the + ! transporting root center node + real(r8) :: rootfr ! fraction of absorbing root in each soil layer + ! assumes propotion of absorbing root is equal + ! to proportion of total root + real(r8) :: kmax_layer ! max conductance between transporting root node + ! and absorbing root node in each layer [kg s-1 MPa-1] + real(r8) :: surfarea_aroot_layer ! Surface area of absorbing roots in each + ! soil layer [m2] + real(r8) :: sum_l_aroot ! sum of plant's total root length + real(r8),parameter :: min_pet_stem_dz = 0.00001_r8 ! Force at least a small difference + ! in the top of stem and petiole + + + pft = ccohort%pft + + ! Get the cross-section of the plant's sapwood area [m2] + call bsap_allom(ccohort%dbh,pft,ccohort%canopy_trim,a_sapwood,c_sap_dummy) + + ! Leaf Maximum Hydraulic Conductance + ! The starting hypothesis is that there is no resistance inside the + ! leaf, between the petiole and the center of storage. To override + ! this, make provisions by changing the kmax to a not-absurdly high + ! value. It is assumed that the conductance in this default case, + ! is regulated completely by the stem conductance from the stem's + ! center of storage, to the petiole. + + ccohort_hydr%kmax_petiole_to_leaf = 1.e8_r8 + + + ! Stem Maximum Hydraulic Conductance + + do k=1, n_hypool_stem + + ! index for "above-ground" arrays, that contain stem and leaf + ! in one vector + k_ag = k+n_hypool_leaf + + ! Depth from the petiole to the lower, node and upper compartment edges + + z_lower = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_lower_ag(k_ag) + z_node = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_node_ag(k_ag) + z_upper = max( min_pet_stem_dz,ccohort_hydr%z_node_ag(n_hypool_leaf) - & + ccohort_hydr%z_upper_ag(k_ag)) + + + ! Then we calculate the maximum conductance from each the lower, node and upper + ! edges of the compartment to the petiole. The xylem taper factor requires + ! that the kmax it is scaling is from the point of interest to the mean height + ! of the petioles. Then we can back out the conductance over just the path + ! of the upper and lower compartments, but subtracting them as resistors in + ! series. + + ! max conductance from upper edge to mean petiole height + ! If there is no height difference between the upper compartment edge and + ! the petiole, at least give it some nominal amount to void FPE's + kmax_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_upper) * & + a_sapwood / z_upper + + ! max conductance from node to mean petiole height + kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_node) * & + a_sapwood / z_node + + ! max conductance from lower edge to mean petiole height + kmax_lower = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_lower) * & + a_sapwood / z_lower + + ! Max conductance over the path of the upper side of the compartment + ccohort_hydr%kmax_stem_upper(k) = (1._r8/kmax_node - 1._r8/kmax_upper)**(-1._r8) + + ! Max conductance over the path on the loewr side of the compartment + ccohort_hydr%kmax_stem_lower(k) = (1._r8/kmax_lower - 1._r8/kmax_node)**(-1._r8) + + if(debug) then + ! The following clauses should never be true: + if( (z_lower < z_node) .or. & + (z_node < z_upper) ) then + write(fates_log(),*) 'Problem calculating stem Kmax' + write(fates_log(),*) z_lower, z_node, z_upper + write(fates_log(),*) kmax_lower*z_lower, kmax_node*z_node, kmax_upper*z_upper + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + enddo - ! Compare the integrated error to the site mass balance - ! error sign is positive towards transpiration overestimation - ! Loss fluxes should = decrease in storage - ! (transp_flux + site_runoff) = -(delta_plant_storage+delta_soil_storage ) + ! Maximum conductance of the upper compartment in the transporting root + ! that connects to the lowest stem (btw: z_lower_ag(n_hypool_ag) == 0) - wb_check_site = delta_plant_storage+delta_soil_storage+site_runoff+transp_flux + z_upper = ccohort_hydr%z_lower_ag(n_hypool_leaf) + z_node = ccohort_hydr%z_lower_ag(n_hypool_leaf)-ccohort_hydr%z_node_troot - ! Now check on total error - if( abs(wb_check_site) > 1.e-4_r8 ) then - write(fates_log(),*) 'FATES hydro water balance is not so great [kg/m2]' - write(fates_log(),*) 'site_hydr%errh2o_hyd: ',wb_check_site - write(fates_log(),*) 'delta_plant_storage: ',delta_plant_storage - write(fates_log(),*) 'delta_soil_storage: ',delta_soil_storage - write(fates_log(),*) 'site_runoff: ',site_runoff - write(fates_log(),*) 'transp_flux: ',transp_flux - end if + kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_node) * & + a_sapwood / z_node + kmax_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & + xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_upper) * & + a_sapwood / z_upper - site_hydr%h2oveg_hydro_err = site_hydr%h2oveg_hydro_err + site_hydr%errh2o_hyd + ccohort_hydr%kmax_troot_upper = (1._r8/kmax_node - 1._r8/kmax_upper)**(-1._r8) - - call UpdateH2OVeg(sites(s),bc_out(s)) - - enddo !site - - return - end subroutine Hydraulics_BC + ! The maximum conductance between the center node of the transporting root + ! compartment, and the center node of the absorbing root compartment, is calculated + ! as a residual. Specifically, we look at the total resistance the plant has in + ! the stem so far, by adding those resistances in series. + ! Then we use a parameter to specify what fraction of the resistance + ! should be below-ground between the transporting root node and the absorbing roots. + ! After that total is calculated, we then convert to a conductance, and split the + ! conductance in parallel between root layers, based on the root fraction. + ! Note* The inverse of max conductance (KMax) is minimum resistance: - ! ===================================================================================== + rmin_ag = 1._r8/ccohort_hydr%kmax_petiole_to_leaf + & + sum(1._r8/ccohort_hydr%kmax_stem_upper(1:n_hypool_stem)) + & + sum(1._r8/ccohort_hydr%kmax_stem_lower(1:n_hypool_stem)) + & + 1._r8/ccohort_hydr%kmax_troot_upper + ! Calculate the residual resistance below ground, as a resistor + ! in series with the existing above ground + ! Invert to find below-ground kmax + ! (rmin_ag+rmin_bg)*fr = rmin_ag + ! rmin_ag + rmin_bg = rmin_ag/fr + ! rmin_bg = (1/fr-1) * rmin_ag + ! + ! if kmax_bg = 1/rmin_bg : + ! + ! kmax_bg = 1/((1/fr-1) * rmin_ag) - subroutine UpdatePlantKmax(ccohort_hydr,ccohort,csite_hydr) + kmax_bg = 1._r8/(rmin_ag*(1._r8/EDPftvarcon_inst%hydr_rfrac_stem(pft) - 1._r8)) - ! --------------------------------------------------------------------------------- - ! - ! This routine sets the maximum conductance of all compartments in the plant, from - ! leaves, to stem, to transporting root, to the absorbing roots. - ! These properties are dependent only on the materials (conductivity) and the - ! geometry of the compartments. - ! The units of all K_max values are [kg H2O s-1 MPa-1] - ! - ! There are some different ways to represent overall conductance from node-to-node - ! throughout the hydraulic system. Universally, all can make use of a system - ! where we separate the hydraulic compartments of the nodes into the upper (closer - ! to the sky) and lower (away from the sky) portions of the compartment. It is - ! possible that due to things like xylem taper, the two portions may have different - ! conductivity, and therefore differnet conductances. - ! - ! Assumption 0. This routine calculates maximum conductivity for 1 plant. - ! Assumption 1. The compartment volumes, heights and lengths have all been - ! determined, probably called just before this routine. - ! - ! Steudle, E. Water uptake by roots: effects of water deficit. - ! J Exp Bot 51, 1531-1542, doi:DOI 10.1093/jexbot/51.350.1531 (2000). - ! --------------------------------------------------------------------------------- - ! Arguments + ! The max conductance of each layer is in parallel, therefore + ! the kmax terms of each layer, should sum to kmax_bg + sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) + do j=1,csite_hydr%nlevrhiz - type(ed_cohort_hydr_type),intent(inout),target :: ccohort_hydr - type(ed_cohort_type),intent(in),target :: ccohort - type(ed_site_hydr_type),intent(in),target :: csite_hydr + kmax_layer = kmax_bg*ccohort_hydr%l_aroot_layer(j)/sum_l_aroot - ! Locals - integer :: k ! Compartment (node) index - integer :: j ! Soil layer index - integer :: k_ag ! Compartment index for above-ground indexed array - integer :: pft ! Plant Functional Type index - real(r8) :: c_sap_dummy ! Dummy variable (unused) with sapwood carbon [kg] - real(r8) :: z_lower ! distance between lower edge and mean petiole height [m] - real(r8) :: z_upper ! distance between upper edge and mean petiole height [m] - real(r8) :: z_node ! distance between compartment center and mph [m] - real(r8) :: kmax_lower ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] - real(r8) :: kmax_node ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] - real(r8) :: kmax_upper ! Max conductance from compartment edge to mph [kg s-1 Mpa-1] - real(r8) :: a_sapwood ! Mean cross section area of sapwood [m2] - real(r8) :: rmin_ag ! Minimum total resistance of all above ground pathways - ! [kg-1 s MPa] - real(r8) :: kmax_bg ! Total maximum conductance of all below-ground pathways - ! from the absorbing roots center nodes to the - ! transporting root center node - real(r8) :: rootfr ! fraction of absorbing root in each soil layer - ! assumes propotion of absorbing root is equal - ! to proportion of total root - real(r8) :: kmax_layer ! max conductance between transporting root node - ! and absorbing root node in each layer [kg s-1 MPa-1] - real(r8) :: surfarea_aroot_layer ! Surface area of absorbing roots in each - ! soil layer [m2] - real(r8) :: sum_l_aroot ! sum of plant's total root length - real(r8),parameter :: min_pet_stem_dz = 0.00001_r8 ! Force at least a small difference - ! in the top of stem and petiole - - - pft = ccohort%pft - - ! Get the cross-section of the plant's sapwood area [m2] - call bsap_allom(ccohort%dbh,pft,ccohort%canopy_trim,a_sapwood,c_sap_dummy) - - ! Leaf Maximum Hydraulic Conductance - ! The starting hypothesis is that there is no resistance inside the - ! leaf, between the petiole and the center of storage. To override - ! this, make provisions by changing the kmax to a not-absurdly high - ! value. It is assumed that the conductance in this default case, - ! is regulated completely by the stem conductance from the stem's - ! center of storage, to the petiole. - - ccohort_hydr%kmax_petiole_to_leaf = 1.e8_r8 - - - ! Stem Maximum Hydraulic Conductance - - do k=1, n_hypool_stem - - ! index for "above-ground" arrays, that contain stem and leaf - ! in one vector - k_ag = k+n_hypool_leaf - - ! Depth from the petiole to the lower, node and upper compartment edges - - z_lower = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_lower_ag(k_ag) - z_node = ccohort_hydr%z_node_ag(n_hypool_leaf) - ccohort_hydr%z_node_ag(k_ag) - z_upper = max( min_pet_stem_dz,ccohort_hydr%z_node_ag(n_hypool_leaf) - & - ccohort_hydr%z_upper_ag(k_ag)) - - - ! Then we calculate the maximum conductance from each the lower, node and upper - ! edges of the compartment to the petiole. The xylem taper factor requires - ! that the kmax it is scaling is from the point of interest to the mean height - ! of the petioles. Then we can back out the conductance over just the path - ! of the upper and lower compartments, but subtracting them as resistors in - ! series. - - ! max conductance from upper edge to mean petiole height - ! If there is no height difference between the upper compartment edge and - ! the petiole, at least give it some nominal amount to void FPE's - kmax_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_upper) * & - a_sapwood / z_upper - - ! max conductance from node to mean petiole height - kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_node) * & - a_sapwood / z_node - - ! max conductance from lower edge to mean petiole height - kmax_lower = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_lower) * & - a_sapwood / z_lower - - ! Max conductance over the path of the upper side of the compartment - ccohort_hydr%kmax_stem_upper(k) = (1._r8/kmax_node - 1._r8/kmax_upper)**(-1._r8) - - ! Max conductance over the path on the loewr side of the compartment - ccohort_hydr%kmax_stem_lower(k) = (1._r8/kmax_lower - 1._r8/kmax_node)**(-1._r8) - - if(debug) then - ! The following clauses should never be true: - if( (z_lower < z_node) .or. & - (z_node < z_upper) ) then - write(fates_log(),*) 'Problem calculating stem Kmax' - write(fates_log(),*) z_lower, z_node, z_upper - write(fates_log(),*) kmax_lower*z_lower, kmax_node*z_node, kmax_upper*z_upper - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - enddo + ! Two transport pathways, in two compartments exist in each layer. + ! These pathways are connected in serial. + ! For simplicity, we simply split the resistance between the two. + ! Mathematically, this results in simply doubling the conductance + ! and applying to both paths. Here are the two paths: + ! 1) is the path between the transporting root's center node, to + ! the boundary of the transporting root with the boundary of + ! the absorbing root (kmax_troot_lower) + ! 2) is the path between the boundary of the absorbing root and + ! transporting root, with the absorbing root's center node + ! (kmax_aroot_upper) - ! Maximum conductance of the upper compartment in the transporting root - ! that connects to the lowest stem (btw: z_lower_ag(n_hypool_ag) == 0) + ccohort_hydr%kmax_troot_lower(j) = 3.0_r8 * kmax_layer + ccohort_hydr%kmax_aroot_upper(j) = 3.0_r8 * kmax_layer + ccohort_hydr%kmax_aroot_lower(j) = 3.0_r8 * kmax_layer - z_upper = ccohort_hydr%z_lower_ag(n_hypool_leaf) - z_node = ccohort_hydr%z_lower_ag(n_hypool_leaf)-ccohort_hydr%z_node_troot + end do - kmax_node = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_node) * & - a_sapwood / z_node + ! Finally, we calculate maximum radial conductance from the root + ! surface to its center node. This transport is not a xylem transport + ! like the calculations prior to this. This transport is through the + ! exodermis, cortex, casparian strip and endodermis. The actual conductance + ! will possibly depend on the potential gradient (whether out-of the root, + ! or in-to the root). So we calculate the kmax's for both cases, + ! and save them for the final conductance calculation. - kmax_upper = EDPftvarcon_inst%hydr_kmax_node(pft,2) * & - xylemtaper(EDPftvarcon_inst%hydr_p_taper(pft), z_upper) * & - a_sapwood / z_upper + do j=1,csite_hydr%nlevrhiz - ccohort_hydr%kmax_troot_upper = (1._r8/kmax_node - 1._r8/kmax_upper)**(-1._r8) + ! Surface area of the absorbing roots for a single plant in this layer [m2] + surfarea_aroot_layer = 2._r8 * pi_const * & + EDPftvarcon_inst%hydr_rs2(ccohort%pft) * ccohort_hydr%l_aroot_layer(j) - ! The maximum conductance between the center node of the transporting root - ! compartment, and the center node of the absorbing root compartment, is calculated - ! as a residual. Specifically, we look at the total resistance the plant has in - ! the stem so far, by adding those resistances in series. - ! Then we use a parameter to specify what fraction of the resistance - ! should be below-ground between the transporting root node and the absorbing roots. - ! After that total is calculated, we then convert to a conductance, and split the - ! conductance in parallel between root layers, based on the root fraction. - ! Note* The inverse of max conductance (KMax) is minimum resistance: + ! Convert from surface conductivity [kg H2O m-2 s-1 MPa-1] to [kg H2O s-1 MPa-1] + ccohort_hydr%kmax_aroot_radial_in(j) = hydr_kmax_rsurf1 * surfarea_aroot_layer + ccohort_hydr%kmax_aroot_radial_out(j) = hydr_kmax_rsurf2 * surfarea_aroot_layer - rmin_ag = 1._r8/ccohort_hydr%kmax_petiole_to_leaf + & - sum(1._r8/ccohort_hydr%kmax_stem_upper(1:n_hypool_stem)) + & - sum(1._r8/ccohort_hydr%kmax_stem_lower(1:n_hypool_stem)) + & - 1._r8/ccohort_hydr%kmax_troot_upper + end do - ! Calculate the residual resistance below ground, as a resistor - ! in series with the existing above ground - ! Invert to find below-ground kmax - ! (rmin_ag+rmin_bg)*fr = rmin_ag - ! rmin_ag + rmin_bg = rmin_ag/fr - ! rmin_bg = (1/fr-1) * rmin_ag - ! - ! if kmax_bg = 1/rmin_bg : - ! - ! kmax_bg = 1/((1/fr-1) * rmin_ag) - - kmax_bg = 1._r8/(rmin_ag*(1._r8/EDPftvarcon_inst%hydr_rfrac_stem(pft) - 1._r8)) - + return +end subroutine UpdatePlantKmax - ! The max conductance of each layer is in parallel, therefore - ! the kmax terms of each layer, should sum to kmax_bg - sum_l_aroot = sum(ccohort_hydr%l_aroot_layer(:)) - do j=1,csite_hydr%nlevrhiz - - kmax_layer = kmax_bg*ccohort_hydr%l_aroot_layer(j)/sum_l_aroot - - ! Two transport pathways, in two compartments exist in each layer. - ! These pathways are connected in serial. - ! For simplicity, we simply split the resistance between the two. - ! Mathematically, this results in simply doubling the conductance - ! and applying to both paths. Here are the two paths: - ! 1) is the path between the transporting root's center node, to - ! the boundary of the transporting root with the boundary of - ! the absorbing root (kmax_troot_lower) - ! 2) is the path between the boundary of the absorbing root and - ! transporting root, with the absorbing root's center node - ! (kmax_aroot_upper) - - ccohort_hydr%kmax_troot_lower(j) = 3.0_r8 * kmax_layer - ccohort_hydr%kmax_aroot_upper(j) = 3.0_r8 * kmax_layer - ccohort_hydr%kmax_aroot_lower(j) = 3.0_r8 * kmax_layer +! =================================================================================== - end do +subroutine OrderLayersForSolve1D(csite_hydr,cohort,cohort_hydr,ordered, kbg_layer) - ! Finally, we calculate maximum radial conductance from the root - ! surface to its center node. This transport is not a xylem transport - ! like the calculations prior to this. This transport is through the - ! exodermis, cortex, casparian strip and endodermis. The actual conductance - ! will possibly depend on the potential gradient (whether out-of the root, - ! or in-to the root). So we calculate the kmax's for both cases, - ! and save them for the final conductance calculation. + ! Arguments (IN) + type(ed_site_hydr_type), intent(in),target :: csite_hydr + type(ed_cohort_type), intent(in),target :: cohort + type(ed_cohort_hydr_type),intent(in),target :: cohort_hydr - do j=1,csite_hydr%nlevrhiz - ! Surface area of the absorbing roots for a single plant in this layer [m2] - surfarea_aroot_layer = 2._r8 * pi_const * & - EDPftvarcon_inst%hydr_rs2(ccohort%pft) * ccohort_hydr%l_aroot_layer(j) + ! Arguments (INOUT) + integer, intent(inout) :: ordered(:) + real(r8), intent(out) :: kbg_layer(:) - ! Convert from surface conductivity [kg H2O m-2 s-1 MPa-1] to [kg H2O s-1 MPa-1] - ccohort_hydr%kmax_aroot_radial_in(j) = hydr_kmax_rsurf1 * surfarea_aroot_layer + ! Locals - ccohort_hydr%kmax_aroot_radial_out(j) = hydr_kmax_rsurf2 * surfarea_aroot_layer + real(r8) :: kbg_tot ! total absorbing root & rhizosphere conductance (over all shells and soil layers [MPa] + real(r8) :: psi_inner_shell ! matric potential of the inner shell, used for calculating + ! which kmax to use when forecasting uptake layer ordering [MPa] + real(r8) :: psi_aroot ! matric potential of absorbing root [MPa] + real(r8) :: kmax_aroot ! max conductance of the absorbing root [kg s-1 Mpa-1] + real(r8) :: ftc_aroot ! fraction of total conductivity of abs root + real(r8) :: r_bg ! total estimated resistance in below ground compartments + ! for each soil layer [s Mpa kg-1] (used to predict order in 1d solve) + real(r8) :: aroot_frac_plant ! This is the fraction of absorbing root from one plant + real(r8) :: kmax_lo ! maximum conductance of lower (away from atm) half of path [kg s-1 Mpa-1] + real(r8) :: kmax_up ! maximum conductance of upper (close to atm) half of path [kg s-1 MPa-1] + real(r8) :: psi_shell ! matric potential of a given shell [-] + real(r8) :: ftc_shell ! fraction of total cond. of a given rhiz shell [-] + integer :: tmp ! temporarily holds a soil layer index + integer :: ft ! functional type index of plant + integer :: j,jj,k ! layer and shell indices - end do - return - end subroutine UpdatePlantKmax + kbg_tot = 0._r8 + kbg_layer(:) = 0._r8 - ! =================================================================================== + ft = cohort%pft - subroutine OrderLayersForSolve1D(site_hydr,cohort,cohort_hydr,ordered, kbg_layer) - - ! Arguments (IN) - type(ed_site_hydr_type), intent(in),target :: site_hydr - type(ed_cohort_type), intent(in),target :: cohort - type(ed_cohort_hydr_type),intent(in),target :: cohort_hydr + do j=1,csite_hydr%nlevrhiz + if(cohort_hydr%l_aroot_layer(j)>nearzero)then - ! Arguments (INOUT) - integer, intent(inout) :: ordered(:) - real(r8), intent(out) :: kbg_layer(:) - - ! Locals - - real(r8) :: kbg_tot ! total absorbing root & rhizosphere conductance (over all shells and soil layers [MPa] - real(r8) :: psi_inner_shell ! matric potential of the inner shell, used for calculating - ! which kmax to use when forecasting uptake layer ordering [MPa] - real(r8) :: psi_aroot ! matric potential of absorbing root [MPa] - real(r8) :: kmax_aroot ! max conductance of the absorbing root [kg s-1 Mpa-1] - real(r8) :: ftc_aroot ! fraction of total conductivity of abs root - real(r8) :: r_bg ! total estimated resistance in below ground compartments - ! for each soil layer [s Mpa kg-1] (used to predict order in 1d solve) - real(r8) :: aroot_frac_plant ! This is the fraction of absorbing root from one plant - real(r8) :: kmax_lo ! maximum conductance of lower (away from atm) half of path [kg s-1 Mpa-1] - real(r8) :: kmax_up ! maximum conductance of upper (close to atm) half of path [kg s-1 MPa-1] - real(r8) :: psi_shell ! matric potential of a given shell [-] - real(r8) :: ftc_shell ! fraction of total cond. of a given rhiz shell [-] - integer :: tmp ! temporarily holds a soil layer index - integer :: ft ! functional type index of plant - integer :: j,jj,k ! layer and shell indices - - - kbg_tot = 0._r8 - kbg_layer(:) = 0._r8 + ! Path is between the absorbing root + ! and the first rhizosphere shell nodes + ! Special case. Maximum conductance depends on the + ! potential gradient (same elevation, no geopotential + ! required. - ft = cohort%pft - - do j=1,site_hydr%nlevrhiz + psi_inner_shell = csite_hydr%wrf_soil(j)%p%psi_from_th(csite_hydr%h2osoi_liqvol_shell(j,1)) - ! Path is between the absorbing root - ! and the first rhizosphere shell nodes - ! Special case. Maximum conductance depends on the - ! potential gradient (same elevation, no geopotential - ! required. - - psi_inner_shell = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,1)) - - ! Note, since their is no elevation difference between - ! the absorbing root and its layer, no need to calc - ! diff in total, just matric is fine [MPa] - if(cohort_hydr%psi_aroot(j) < psi_inner_shell) then - kmax_aroot = cohort_hydr%kmax_aroot_radial_in(j) - else - kmax_aroot = cohort_hydr%kmax_aroot_radial_out(j) - end if - - ! Get matric potential [Mpa] of the absorbing root - psi_aroot = wrf_plant(aroot_p_media,ft)%p%psi_from_th(cohort_hydr%th_aroot(j)) - - ! Get Fraction of Total Conductivity [-] of the absorbing root - ftc_aroot = wkf_plant(aroot_p_media,ft)%p%ftc_from_psi(cohort_hydr%psi_aroot(j)) + ! Note, since their is no elevation difference between + ! the absorbing root and its layer, no need to calc + ! diff in total, just matric is fine [MPa] + if(cohort_hydr%psi_aroot(j) < psi_inner_shell) then + kmax_aroot = cohort_hydr%kmax_aroot_radial_in(j) + else + kmax_aroot = cohort_hydr%kmax_aroot_radial_out(j) + end if - ! Calculate total effective conductance over path [kg s-1 MPa-1] - ! from absorbing root node to 1st rhizosphere shell - r_bg = 1._r8/(kmax_aroot*ftc_aroot) - - ! Path is across the upper an lower rhizosphere comparment - ! on each side of the nodes. Since there is no flow across the outer - ! node to the edge, we ignore that last half compartment - aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) - - do k = 1,nshell - - kmax_up = site_hydr%kmax_upper_shell(j,k)*aroot_frac_plant - kmax_lo = site_hydr%kmax_lower_shell(j,k)*aroot_frac_plant - - psi_shell = site_hydr%wrf_soil(j)%p%psi_from_th(site_hydr%h2osoi_liqvol_shell(j,k)) - - ftc_shell = site_hydr%wkf_soil(j)%p%ftc_from_psi(psi_shell) - - r_bg = r_bg + 1._r8/(kmax_up*ftc_shell) - if(k site_hydr%pm_node) + else + ! no roots? no conductance, don't prioritize + kbg_layer(j) = 0._r8 - ! This is the maximum number of iterations needed for this cohort - ! (each soil layer has a different number, this saves the max) - cohort_hydr%iterh1 = 0 - cohort_hydr%iterh2 = 0 - - ! Initialize plant water error (integrated flux-storage) - wb_err_plant = 0._r8 + end if - ! Initialize integrated change in total plant water - dwat_plant = 0._r8 - - ! These are diagnostics that must be calculated. - ! in this routine (uses differentials and actual fluxes) - ! So we need to zero them, as they are incremented - ! over the sub-steps - sapflow = 0._r8 - rootuptake(:) = 0._r8 - - ft = cohort%pft + kbg_tot = kbg_tot + kbg_layer(j) + + enddo !soil layer - ! Total length of roots per plant for this cohort - sum_l_aroot = sum(cohort_hydr%l_aroot_layer(:)) - - ! ----------------------------------------------------------------------------------- - ! As mentioned when calling this routine, we calculate a solution to the flux - ! equations, sequentially, for the plant and each soil layer. - ! Go through soil layers in order of decreasing total root-soil conductance - ! ----------------------------------------------------------------------------------- - do jj=1,site_hydr%nlevrhiz - - ilayer = ordered(jj) - - if(do_parallel_stem) then - ! If we do "parallel" stem - ! conduits, we integrate - ! each layer over the whole time, but - ! reduce the conductance cross section - ! according to what fraction of root is active - dt_step = dtime - else - if(weight_serial_dt)then - dt_step = dtime*kbg_layer(ilayer) - else - dt_step = dtime/real(site_hydr%nlevrhiz,r8) - end if + ! This is called within a cohort loop. A cohort should at least have + ! some amount of root, somewhere, and thus kbg_tot should be nonzero + + kbg_layer = kbg_layer/kbg_tot + + ! order soil layers in terms of decreasing total hydraulic conductance + ! algorithm same as that used in histFileMod.F90 to alphabetize history tape contents + do j = csite_hydr%nlevrhiz-1,1,-1 + do jj = 1,j + if (kbg_layer(ordered(jj)) <= kbg_layer(ordered(jj+1))) then + tmp = ordered(jj) + ordered(jj) = ordered(jj+1) + ordered(jj+1) = tmp end if - - ! ------------------------------------------------------------------------------- - ! Part 1. Calculate node quantities: - ! matric potential: psi_node - ! fraction of total conductance: ftc_node - ! total potential (matric + elevatio) h_node - ! deriv. ftc wrt theta: dftc_dtheta_node - ! deriv. psi wrt theta: dpsi_dtheta_node - ! ------------------------------------------------------------------------------- - - - ! This is the fraction of total absorbing root length that a single - ! plant for this cohort takes up, relative to ALL cohorts at the site. Note: - ! cohort_hydr%l_aroot_layer(ilayer) is units [m/plant] - ! site_hydr%l_aroot_layer(ilayer) is units [m/site] - - aroot_frac_plant = cohort_hydr%l_aroot_layer(ilayer)/site_hydr%l_aroot_layer(ilayer) - - wb_err_layer = 0._r8 + enddo + enddo - ! If in "spatially parallel" mode, scale down cross section - ! of flux through top by the root fraction of this layer - if(do_parallel_stem)then - rootfr_scaler = cohort_hydr%l_aroot_layer(ilayer)/sum_l_aroot - else - rootfr_scaler = 1.0_r8 - end if + return +end subroutine OrderLayersForSolve1D - q_top_eff = q_top * rootfr_scaler +! ================================================================================= - ! For all nodes leaf through rhizosphere - ! Send node heights and compartment volumes to a node-based array - - do i = 1,n_hypool_tot - - if (i<=n_hypool_ag) then - z_node(i) = cohort_hydr%z_node_ag(i) - v_node(i) = cohort_hydr%v_ag(i) - th_node_init(i) = cohort_hydr%th_ag(i) - elseif (i==n_hypool_ag+1) then - z_node(i) = cohort_hydr%z_node_troot - v_node(i) = cohort_hydr%v_troot - th_node_init(i) = cohort_hydr%th_troot - elseif (i==n_hypool_ag+2) then - z_node(i) = -site_hydr%zi_rhiz(ilayer) - v_node(i) = cohort_hydr%v_aroot_layer(ilayer) - th_node_init(i) = cohort_hydr%th_aroot(ilayer) - else - ishell = i-(n_hypool_ag+2) - z_node(i) = -site_hydr%zi_rhiz(ilayer) - ! The volume of the Rhizosphere for a single plant - v_node(i) = site_hydr%v_shell(ilayer,ishell)*aroot_frac_plant - th_node_init(i) = site_hydr%h2osoi_liqvol_shell(ilayer,ishell) - end if - end do - - ! Outer iteration loop - ! This cuts timestep in half and resolve the solution with smaller substeps - ! This loop is cleared when the model has found a solution - - solution_found = .false. - iter = 0 - do while( .not.solution_found ) +subroutine ImTaylorSolve1D(slat, slon,recruitflag,csite_hydr,cohort,cohort_hydr,dtime,q_top, & + ordered,kbg_layer, sapflow,rootuptake,& + wb_err_plant,dwat_plant,dth_layershell_col) - ! Gracefully quit if too many iterations have been used - if(iter>max_iter)then - call Report1DError(cohort,site_hydr,ilayer,z_node,v_node, & - th_node_init,q_top_eff,dt_step,w_tot_beg,w_tot_end,& - rootfr_scaler,aroot_frac_plant,error_code,error_arr) + ! ------------------------------------------------------------------------------- + ! Calculate the hydraulic conductances across a list of paths. The list is a 1D vector, and + ! the list need not be across the whole path from stomata to the last rhizosphere shell, but + ! it can only be 1d, which is part of a path through the plant and into 1 soil layer. + ! + ! Note on conventions: + ! "Up" upper, refers to the compartment that is closer to the atmosphere + ! "lo" lower, refers to the compartment that is further from the atmosphere + ! Weird distinction: since flow from one node to another, will include half of + ! a compartment on a upper node, and half a compartment of a lower node. The upp + ! compartment will be contributing its lower compartment, and the lower node + ! will be presenting it upper compartment. Yes, confusing, but non-the-less + ! accurate. + ! ------------------------------------------------------------------------------- + + ! Arguments (IN) + real(r8), intent(in) :: slat ! latitidue of the site + real(r8), intent(in) :: slon ! longitidue of the site + logical, intent(in) :: recruitflag + type(ed_cohort_type),intent(in),target :: cohort + type(ed_cohort_hydr_type),intent(inout),target :: cohort_hydr + type(ed_site_hydr_type), intent(in),target :: csite_hydr + real(r8), intent(in) :: dtime + real(r8), intent(in) :: q_top ! transpiration flux rate at upper boundary [kg -s] + integer,intent(in) :: ordered(:) ! Layer solution order + real(r8), intent(in) :: kbg_layer(:) ! relative conductance of each layer + + ! Arguments (OUT) + + real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] + real(r8),intent(out) :: rootuptake(:) ! time integrated mass flux between rhizosphere and aroot [kg] + real(r8),intent(out) :: wb_err_plant ! total error from the plant, transpiration + ! should match change in storage [kg] + real(r8),intent(out) :: dwat_plant ! Change in plant stored water [kg] + real(r8),intent(inout) :: dth_layershell_col(:,:) ! accumulated water content change over all cohorts in a column [m3 m-3]) + + ! Locals + integer :: i ! node index "i" + integer :: j ! path index "j" + integer :: jj ! alt path index + integer :: nsteps ! number of sub-steps in any given iteration loop, starts at 1 and grows + integer :: ilayer ! soil layer index of interest + integer :: itest ! node index used for testing and reporting errors + integer :: ishell ! rhizosphere shell index of the node + integer :: ishell_up ! rhizosphere shell index on the upstream side of flow path (towards soil) + integer :: ishell_dn ! rhizosphere shell index on the downstream side of flow path (towards atm) + integer :: i_up ! node index on the upstream side of flow path (towards soil) + integer :: i_dn ! node index on the downstream side of flow path (towards atm) + integer :: istep ! sub-step count index + integer :: tri_ierr ! error flag for the tri-diagonal solver 0=passed, 1=failed + logical :: solution_found ! logical set to true if a solution was found within error tolerance + real(r8) :: dt_step ! time [seconds] over-which to calculate solution + real(r8) :: q_top_eff ! effective water flux through stomata [kg s-1 plant-1] + real(r8) :: rootfr_scaler ! Factor to scale down cross-section areas based on what + ! fraction of root is in current layer [-] + real(r8) :: kmax_dn ! maximum conductance of downstream half of path [kg s-1 Mpa-1] + real(r8) :: kmax_up ! maximum conductance of upstream half of path [kg s-1 MPa-1] + real(r8) :: wb_step_err ! water balance error over substep [kg] + real(r8) :: w_tot_beg ! total plant water prior to solve [kg] + real(r8) :: w_tot_end ! total plant water at end of solve [kg] + real(r8) :: dt_substep ! timestep length of substeps [s] + real(r8) :: leaf_water ! kg of water in the leaf + real(r8) :: stem_water ! kg of water in the stem + real(r8) :: root_water ! kg of water in the transp and absorbing roots + real(r8) :: sapflow_lyr ! sapflow flux [kg] per layer per timestep + real(r8) :: rootuptake_lyr! rootuptake flux [kg] per layer per timestep + real(r8) :: wb_err_layer ! balance error for the layer [kg/cohort] + real(r8) :: l_aroot_layer ! total root lengh of a given soil layer of the site + + real(r8) :: dth_node(n_hypool_tot) ! change in theta over the timestep + real(r8) :: th_node_init(n_hypool_tot) ! "theta" i.e. water content of node [m3 m-3] + ! before the solve + real(r8) :: th_node(n_hypool_tot) ! "theta" during the solve (dynamic) [m3 m-3] + real(r8) :: z_node(n_hypool_tot) ! elevation of node [m] + real(r8) :: v_node(n_hypool_tot) ! volume of the node, ie single plant compartments [m3] + real(r8) :: psi_node(n_hypool_tot) ! matric potential on node [Mpa] + real(r8) :: ftc_node(n_hypool_tot) ! frac total conductance on node [-] + real(r8) :: h_node(n_hypool_tot) ! total potential on node [Mpa] + real(r8) :: error_arr(n_hypool_tot) ! array that saves problematic diagnostics for reporting + real(r8) :: dftc_dtheta_node(n_hypool_tot) ! deriv FTC w.r.t. theta + real(r8) :: dpsi_dtheta_node(n_hypool_tot) ! deriv psi w.r.t. theta + real(r8) :: k_eff(n_hypool_tot-1) ! effective (used) conductance over path [kg s-1 MPa-1] + real(r8) :: a_term(n_hypool_tot-1) ! "A" term in the tri-diagonal implicit solve [-] + real(r8) :: b_term(n_hypool_tot-1) ! "B" term in the tri-diagonal implicit solve [-] + real(r8) :: k_diag(n_hypool_tot-1) ! mean time-averaged K over the paths (diagnostic) [kg s-1 Mpa-1] + real(r8) :: flux_diag(n_hypool_tot-1) ! time-integrated mass flux over sub-steps [kg] + real(r8) :: h_diag, psi_diag ! total and matric potential for error reporting [Mpa] + real(r8) :: tris_a(n_hypool_tot) ! left of diagonal terms for tri-diagonal matrix solving delta theta + real(r8) :: tris_b(n_hypool_tot) ! center diagonal terms for tri-diagonal matrix solving delta theta + real(r8) :: tris_c(n_hypool_tot) ! right of diaongal terms for tri-diagonal matrix solving delta theta + real(r8) :: tris_r(n_hypool_tot) ! off (constant coefficients) matrix terms + real(r8) :: sum_l_aroot ! + real(r8) :: aroot_frac_plant ! This is the fraction of absorbing root from one plant + real(r8) :: dftc_dpsi ! Change in fraction of total conductance wrt change + ! in potential [- MPa-1] + integer :: error_code ! flag that specifies which check tripped a failed solution + integer :: ft ! plant functional type + real(r8) :: q_flow ! flow diagnostic [kg] + real(r8) :: rootfr ! rooting fraction of this layer (used for diagnostics) + ! out of the total absorbing roots from the whole community of plants + integer :: iter ! iteration count for sub-step loops + + integer, parameter :: imult = 3 ! With each iteration, increase the number of substeps + ! by this much + integer, parameter :: max_iter = 20 ! Maximum number of iterations with which we reduce timestep + + real(r8), parameter :: max_wb_err = 2.e-5_r8 ! threshold for water balance error (stop model) [kg h2o] + + + logical, parameter :: no_ftc_radialk = .false. + logical, parameter :: weight_serial_dt = .true. ! if this is true, and we are not doing spatial parallelism + ! then we give the fraction of time as a function of how + ! much conductance the layer has + + associate(pm_node => csite_hydr%pm_node) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + ! This is the maximum number of iterations needed for this cohort + ! (each soil layer has a different number, this saves the max) + cohort_hydr%iterh1 = 0 + cohort_hydr%iterh2 = 0 - ! If debugging, then lets re-initialize our diagnostics of - ! time integrated K and flux across the paths - if(debug)then - k_diag = 0._r8 - flux_diag = 0._r8 - end if + ! Initialize plant water error (integrated flux-storage) + wb_err_plant = 0._r8 - sapflow_lyr = 0._r8 - rootuptake_lyr = 0._r8 - - ! For each attempt, we want to reset theta with the initial value - th_node(:) = th_node_init(:) - - ! Determine how many substeps, and how long they are + ! Initialize integrated change in total plant water + dwat_plant = 0._r8 - nsteps = max(imult*iter,1) ! Factor by which we divide through the timestep - ! start with full step (ie dt_fac = 1) - ! Then increase per the "imult" value. - - dt_substep = dt_step/real(nsteps,r8) ! This is the sub-stem length in seconds - - ! Walk through sub-steps - do istep = 1,nsteps + ! These are diagnostics that must be calculated. + ! in this routine (uses differentials and actual fluxes) + ! So we need to zero them, as they are incremented + ! over the sub-steps + sapflow = 0._r8 + rootuptake(:) = 0._r8 - ! Total water mass in the plant at the beginning of this solve [kg h2o] - w_tot_beg = sum(th_node(:)*v_node(:))*denh2o + ft = cohort%pft - ! Calculate on-node quantities: potential, and derivatives - do i = 1,n_hypool_plant + ! Total length of roots per plant for this cohort + sum_l_aroot = sum(cohort_hydr%l_aroot_layer(:)) - ! Get matric potential [Mpa] - psi_node(i) = wrf_plant(pm_node(i),ft)%p%psi_from_th(th_node(i)) + ! ----------------------------------------------------------------------------------- + ! As mentioned when calling this routine, we calculate a solution to the flux + ! equations, sequentially, for the plant and each soil layer. + ! Go through soil layers in order of decreasing total root-soil conductance + ! ----------------------------------------------------------------------------------- - ! Get total potential [Mpa] - h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) + loop_root_layers: do jj=1,csite_hydr%nlevrhiz - ! Get Fraction of Total Conductivity [-] - ftc_node(i) = wkf_plant(pm_node(i),ft)%p%ftc_from_psi(psi_node(i)) + ilayer = ordered(jj) - ! deriv psi wrt theta - dpsi_dtheta_node(i) = wrf_plant(pm_node(i),ft)%p%dpsidth_from_th(th_node(i)) + ! Trivial condition: No roots in this layer, no fluxes + if ( cohort_hydr%l_aroot_layer(ilayer) <= nearzero ) cycle - ! deriv ftc wrt psi + + if(do_parallel_stem) then + ! If we do "parallel" stem + ! conduits, we integrate + ! each layer over the whole time, but + ! reduce the conductance cross section + ! according to what fraction of root is active + dt_step = dtime + else + if(weight_serial_dt)then + dt_step = dtime*kbg_layer(ilayer) + else + dt_step = dtime/real(csite_hydr%nlevrhiz,r8) + end if + end if - dftc_dpsi = wkf_plant(pm_node(i),ft)%p%dftcdpsi_from_psi(psi_node(i)) + ! ------------------------------------------------------------------------------- + ! Part 1. Calculate node quantities: + ! matric potential: psi_node + ! fraction of total conductance: ftc_node + ! total potential (matric + elevatio) h_node + ! deriv. ftc wrt theta: dftc_dtheta_node + ! deriv. psi wrt theta: dpsi_dtheta_node + ! ------------------------------------------------------------------------------- - dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) + ! This is the fraction of total absorbing root length that a single + ! plant for this cohort takes up, relative to ALL cohorts at the site. Note: + ! cohort_hydr%l_aroot_layer(ilayer) is units [m/plant] + ! csite_hydr%l_aroot_layer(ilayer) is units [m/site] - ! We have two ways to calculate radial absorbing root conductance - ! 1) Assume that water potential does not effect conductance - ! 2) The standard FTC function applies + aroot_frac_plant = cohort_hydr%l_aroot_layer(ilayer)/csite_hydr%l_aroot_layer(ilayer) - if(i==n_hypool_ag+2)then - if(no_ftc_radialk) then - ftc_node(i) = 1.0_r8 - dftc_dtheta_node(i) = 0.0_r8 - end if - end if + wb_err_layer = 0._r8 - end do - - - ! Same updates as loop above, but for rhizosphere shells - - do i = n_hypool_plant+1,n_hypool_tot - psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) - h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) - ftc_node(i) = site_hydr%wkf_soil(ilayer)%p%ftc_from_psi(psi_node(i)) - dpsi_dtheta_node(i) = site_hydr%wrf_soil(ilayer)%p%dpsidth_from_th(th_node(i)) - dftc_dpsi = site_hydr%wkf_soil(ilayer)%p%dftcdpsi_from_psi(psi_node(i)) - dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) - end do - - !-------------------------------------------------------------------------------- - ! Part 2. Effective conductances over the path-length and Flux terms - ! over the node-to-node paths - !-------------------------------------------------------------------------------- - - ! Path is between the leaf node and first stem node - ! ------------------------------------------------------------------------------- - - j = 1 - i_up = 2 ! upstream node index - i_dn = 1 ! downstream node index - kmax_dn = rootfr_scaler*cohort_hydr%kmax_petiole_to_leaf - kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_upper(1) - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & - dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & - k_eff(j), & - A_term(j), & - B_term(j)) - - - ! Path is between stem nodes - ! ------------------------------------------------------------------------------- - - do j=2,n_hypool_ag-1 - - i_up = j+1 - i_dn = j - - ! "Up" is the "upstream" node, which also uses - ! the "upper" side of its compartment for the calculation. - ! "dn" is the "downstream" node, which uses the lower - ! side of its compartment - ! This compartment is the "lower" node, but uses - ! the "higher" side of its compartment. - - kmax_dn = rootfr_scaler*cohort_hydr%kmax_stem_lower(i_dn-n_hypool_leaf) - kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_upper(i_up-n_hypool_leaf) - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & - dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & - k_eff(j), & - A_term(j), & - B_term(j)) - - end do - - - ! Path is between lowest stem and transporting root - - j = n_hypool_ag - i_up = j+1 - i_dn = j - kmax_dn = rootfr_scaler*cohort_hydr%kmax_stem_lower(n_hypool_stem) - kmax_up = rootfr_scaler*cohort_hydr%kmax_troot_upper - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & - dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & - k_eff(j), & - A_term(j), & - B_term(j)) - - ! Path is between the transporting root - ! and the absorbing root for this layer - ! NOTE: No need to scale by root fraction - ! even if in parallel mode, already parallel! - - j = n_hypool_ag+1 - i_up = j+1 - i_dn = j - kmax_dn = cohort_hydr%kmax_troot_lower(ilayer) - kmax_up = cohort_hydr%kmax_aroot_upper(ilayer) - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & - dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & - k_eff(j), & - A_term(j), & - B_term(j)) - - ! Path is between the absorbing root - ! and the first rhizosphere shell nodes - - j = n_hypool_ag+2 - i_up = j+1 - i_dn = j - - ! Special case. Maximum conductance depends on the - ! potential gradient. - if(h_node(i_up) > h_node(i_dn) ) then - kmax_dn = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & - 1._r8/cohort_hydr%kmax_aroot_radial_in(ilayer)) - else - kmax_dn = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & - 1._r8/cohort_hydr%kmax_aroot_radial_out(ilayer)) - end if - - kmax_up = site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & - dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & - k_eff(j), & - A_term(j), & - B_term(j)) - - ! Path is between rhizosphere shells - - do j = n_hypool_ag+3,n_hypool_tot-1 - - i_up = j+1 - i_dn = j - ishell_up = i_up - (n_hypool_tot-nshell) - ishell_dn = i_dn - (n_hypool_tot-nshell) - - kmax_dn = site_hydr%kmax_lower_shell(ilayer,ishell_dn)*aroot_frac_plant - kmax_up = site_hydr%kmax_upper_shell(ilayer,ishell_up)*aroot_frac_plant - - call GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_node(i_up),ftc_node(i_dn), & - h_node(i_up),h_node(i_dn), & - dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & - dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & - k_eff(j), & - A_term(j), & - B_term(j)) - - end do - - ! ------------------------------------------------------------------------------- - ! Part 3. - ! Loop through nodes again, build matrix - ! ------------------------------------------------------------------------------- - - tris_a(1) = 0._r8 - tris_b(1) = A_term(1) - denh2o*v_node(1)/dt_substep - tris_c(1) = B_term(1) - tris_r(1) = q_top_eff - k_eff(1)*(h_node(2)-h_node(1)) - - - do i = 2,n_hypool_tot-1 - j = i - tris_a(i) = -A_term(j-1) - tris_b(i) = A_term(j) - B_term(j-1) - denh2o*v_node(i)/dt_substep - tris_c(i) = B_term(j) - tris_r(i) = -k_eff(j)*(h_node(i+1)-h_node(i)) + & - k_eff(j-1)*(h_node(i)-h_node(i-1)) - - end do - - i = n_hypool_tot - j = n_hypool_tot - tris_a(i) = -A_term(j-1) - tris_b(i) = -B_term(j-1) - denh2o*v_node(i)/dt_substep - tris_c(i) = 0._r8 - tris_r(i) = k_eff(j-1)*(h_node(i)-h_node(i-1)) - - - ! Calculate the change in theta - - call Hydraulics_Tridiagonal(tris_a, tris_b, tris_c, tris_r, dth_node, tri_ierr) - - if(tri_ierr == 1) then - solution_found = .false. - error_code = 2 - error_arr(:) = 0._r8 - exit - end if - - ! If we have not broken from the substep loop, - ! that means this sub-step has been acceptable, and we may - ! go ahead and update the water content for the integrator - - th_node(:) = th_node(:) + dth_node(:) - - ! Mass error (flux - change) - ! Total water mass in the plant at the beginning of this solve [kg h2o] - w_tot_end = sum(th_node(:)*v_node(:))*denh2o - - wb_step_err = (q_top_eff*dt_substep) - (w_tot_beg-w_tot_end) - - if(abs(wb_step_err)>max_wb_step_err .or. any(dth_node(:).ne.dth_node(:)) )then - solution_found = .false. - error_code = 1 - error_arr(:) = 0._r8 - exit - else - ! Note: this is somewhat of a default true. And the sub-steps - ! will keep going unless its changed and broken out of - ! the loop. - solution_found = .true. - error_code = 0 - end if - - ! If desired, check and trap water contents - ! that are negative - if(trap_neg_wc) then - if( any(th_node(:)<0._r8) ) then - solution_found = .false. - error_code = 3 - error_arr(:) = th_node(:) - exit - end if - end if - - ! Calculate new psi for checks - do i = 1,n_hypool_plant - psi_node(i) = wrf_plant(pm_node(i),ft)%p%psi_from_th(th_node(i)) - end do - do i = n_hypool_plant+1,n_hypool_tot - psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) - end do - - ! If desired, check and trap pressures that are supersaturated - if(trap_supersat_psi) then - do i = 1,n_hypool_plant - if(psi_node(i)>wrf_plant(pm_node(i),ft)%p%get_thsat()) then - solution_found = .false. - error_code = 4 - end if - end do - do i = n_hypool_plant+1,n_hypool_tot - if(psi_node(i)>site_hydr%wrf_soil(ilayer)%p%get_thsat()) then - solution_found = .false. - error_code = 4 - end if - end do - if(error_code==4) then - error_arr(:) = th_node(:) - end if - end if - - ! Accumulate the water balance error of the layer over the sub-steps - ! for diagnostic purposes - ! [kg/m2] - wb_err_layer = wb_err_layer + wb_step_err - - ! ------------------------------------------------------------------------- - ! Diagnostics - ! ------------------------------------------------------------------------- - - ! Sapflow at the base of the tree is the flux rate - ! between the transporting root node and the first stem node - ! (note: a path j is between node i and i+1) - ! [kg] = [kg/s] * [s] - - i = n_hypool_ag - sapflow_lyr = sapflow_lyr + dt_substep * & - (k_eff(i)*(h_node(i+1)-h_node(i)) + & ! flux at (t) - A_term(i)*dth_node(i) + & ! dq at node i - B_term(i)*dth_node(i+1)) ! dq at node i+1 - - ! Root uptake is the integrated flux between the first rhizosphere - ! shell and the absorbing root - - i = n_hypool_ag+2 - rootuptake_lyr = rootuptake_lyr + dt_substep * & - (k_eff(i)*(h_node(i+1)-h_node(i)) + & ! flux at (t) - A_term(i)*dth_node(i) + & ! dq at node i - B_term(i)*dth_node(i+1)) ! dq at node i+1 - - ! If debug mode is on, lets also track the mass fluxes across each - ! path, and keep a running average of the effective conductances - if(debug)then - do j=1,n_hypool_tot-1 - k_diag(j) = k_diag(j) + k_eff(j)*dt_substep/dt_step - flux_diag(j) = flux_diag(j) + dt_substep * ( & - k_eff(j)*(h_node(j+1)-h_node(j)) + & - A_term(j)*dth_node(j)+ B_term(j)*dth_node(j+1)) - end do - end if - - end do ! do istep = 1,nsteps (substep loop) - - iter=iter+1 - - end do - - ! ----------------------------------------------------------- - ! Do a final check on water balance error sumed over sub-steps - ! ------------------------------------------------------------ - if ( abs(wb_err_layer) > max_wb_err ) then - - write(fates_log(),*)'EDPlantHydraulics water balance error exceeds threshold of = ', max_wb_err - write(fates_log(),*)'transpiration demand: ', dt_step*q_top_eff,' kg/step/plant' - - leaf_water = cohort_hydr%th_ag(1)*cohort_hydr%v_ag(1)*denh2o - stem_water = sum(cohort_hydr%th_ag(2:n_hypool_ag) * & - cohort_hydr%v_ag(2:n_hypool_ag))*denh2o - root_water = ( cohort_hydr%th_troot*cohort_hydr%v_troot + & - sum(cohort_hydr%th_aroot(:)*cohort_hydr%v_aroot_layer(:))) * denh2o - - write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' - write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' - write(fates_log(),*) 'root_water: ',root_water,' kg/plant' - write(fates_log(),*) 'LWP: ',cohort_hydr%psi_ag(1) - write(fates_log(),*) 'dbh: ',cohort%dbh - write(fates_log(),*) 'pft: ',cohort%pft - write(fates_log(),*) 'tree lai: ',cohort%treelai,' m2/m2 crown' - call endrun(msg=errMsg(sourcefile, __LINE__)) + ! If in "spatially parallel" mode, scale down cross section + ! of flux through top by the root fraction of this layer + + if(do_parallel_stem)then + rootfr_scaler = cohort_hydr%l_aroot_layer(ilayer)/sum_l_aroot + else + rootfr_scaler = 1.0_r8 + end if + + q_top_eff = q_top * rootfr_scaler + + ! For all nodes leaf through rhizosphere + ! Send node heights and compartment volumes to a node-based array + + do i = 1,n_hypool_tot + + if (i<=n_hypool_ag) then ! leaf and stem, n_hypool_ag = 2 + z_node(i) = cohort_hydr%z_node_ag(i) + v_node(i) = cohort_hydr%v_ag(i) + th_node_init(i) = cohort_hydr%th_ag(i) + elseif (i==n_hypool_ag+1) then ! i=3, transport root + z_node(i) = cohort_hydr%z_node_troot + v_node(i) = cohort_hydr%v_troot + th_node_init(i) = cohort_hydr%th_troot + elseif (i==n_hypool_ag+2) then ! i=4, fine roots + z_node(i) = -csite_hydr%zi_rhiz(ilayer)+0.5*csite_hydr%dz_rhiz(ilayer) + v_node(i) = cohort_hydr%v_aroot_layer(ilayer) + th_node_init(i) = cohort_hydr%th_aroot(ilayer) + else + ishell = i-(n_hypool_ag+2) ! i>=5, rhizosphere + z_node(i) = -csite_hydr%zi_rhiz(ilayer)+0.5*csite_hydr%dz_rhiz(ilayer) + ! The volume of the Rhizosphere for a single plant + v_node(i) = csite_hydr%v_shell(ilayer,ishell)*aroot_frac_plant + th_node_init(i) = csite_hydr%h2osoi_liqvol_shell(ilayer,ishell) + if (th_node_init(i) < -nearzero) then + write(fates_log(),*) 'ImTaylorSolve1D(), print out shell theta' + write(fates_log(),*) 'layer: ',ilayer, 'shell:', ishell + write(fates_log(),*) 'th_node_init(i) is: ', th_node_init(i) + write(fates_log(),*) 'th_node_init(i) is: ', th_node_init(i) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if end if + end do - ! If we have made it to this point, supposedly we have completed the whole time-step - ! for this cohort x layer combination. It is now safe to save the delta theta - ! value and pass it back to the calling routine. The value passed back is the - ! change in theta over all sub-steps. - - dth_node(:) = th_node(:)-th_node_init(:) + ! Outer iteration loop + ! This cuts timestep in half and resolve the solution with smaller substeps + ! This loop is cleared when the model has found a solution + solution_found = .false. + iter = 0 + solution_iteration: do while( .not.solution_found ) - ! Add the current soil layer's contribution to total - ! sap and root flux [kg] - sapflow = sapflow + sapflow_lyr - rootuptake(ilayer) = rootuptake_lyr - - - ! Record the layer with the most iterations, but only - ! if it greater than 1. It will default to zero - ! if no layers took extra iterations. - if( (real(iter)>cohort_hydr%iterh1) .and. (iter>1) )then - cohort_hydr%iterlayer = real(ilayer) + ! Gracefully quit if too many iterations have been used + if(iter>max_iter)then + call Report1DError(cohort,csite_hydr,ilayer,z_node,v_node, & + th_node_init,q_top_eff,dt_step,w_tot_beg,w_tot_end,& + rootfr_scaler,aroot_frac_plant,error_code,error_arr, & + slat, slon,recruitflag) + + call endrun(msg=errMsg(sourcefile, __LINE__)) end if - - ! Save the number of times we refined our sub-step counts (iterh1) - cohort_hydr%iterh1 = max(cohort_hydr%iterh1,real(iter,r8)) - ! Save the number of sub-steps we ultimately used - cohort_hydr%iterh2 = max(cohort_hydr%iterh2,real(nsteps,r8)) - - ! Update water contents in the relevant plant compartments [m3/m3] - ! ------------------------------------------------------------------------------- - - ! Leaf and above-ground stems - cohort_hydr%th_ag(1:n_hypool_ag) = cohort_hydr%th_ag(1:n_hypool_ag) + dth_node(1:n_hypool_ag) - ! Transporting root - cohort_hydr%th_troot = cohort_hydr%th_troot + dth_node(n_hypool_ag+1) - ! Absorbing root - cohort_hydr%th_aroot(ilayer) = cohort_hydr%th_aroot(ilayer) + dth_node(n_hypool_ag+2) - - ! Change in water per plant [kg/plant] - dwat_plant = dwat_plant + & - (sum(dth_node(1:n_hypool_ag)*cohort_hydr%v_ag(1:n_hypool_ag)) + & - dth_node(n_hypool_ag+1)*cohort_hydr%v_troot + & - dth_node(n_hypool_ag+2)*cohort_hydr%v_aroot_layer(ilayer))*denh2o - - ! Remember the error for the cohort - wb_err_plant = wb_err_plant + wb_err_layer - - ! Save the change in water mass in the rhizosphere. Note that we did - ! not immediately update the state variables upon completing each - ! plant-layer solve. We accumulate the difference, and apply them - ! after all cohort-layers are complete. This allows each cohort - ! to experience the same water conditions (for good or bad). - - if(site_hydr%l_aroot_layer(ilayer) ilayer) - end associate - return - end subroutine ImTaylorSolve1D + sapflow_lyr = 0._r8 + rootuptake_lyr = 0._r8 - ! ===================================================================================== + ! For each attempt, we want to reset theta with the initial value + th_node(:) = th_node_init(:) - subroutine Report1DError(cohort, site_hydr, ilayer, z_node, v_node, & - th_node, q_top_eff, dt_step, w_tot_beg, w_tot_end, & - rootfr_scaler, aroot_frac_plant, err_code, err_arr) - - ! This routine reports what the initial condition to the 1D solve looks - ! like, and then quits. - - ! Arguments (IN) - type(ed_cohort_type),intent(in),target :: cohort - type(ed_site_hydr_type),intent(in), target :: site_hydr - integer, intent(in) :: ilayer ! soil layer index of interest - real(r8), intent(in) :: z_node(:) ! elevation of nodes - real(r8), intent(in) :: v_node(:) ! volume of nodes - real(r8), intent(in) :: th_node(:) ! water content of node - real(r8), intent(in) :: dt_step ! time [seconds] over-which to calculate solution - real(r8), intent(in) :: q_top_eff ! transpiration flux rate at upper boundary [kg -s] - real(r8), intent(in) :: w_tot_beg ! total water mass at beginning of step [kg] - real(r8), intent(in) :: w_tot_end ! total water mass at end of step [kg] - real(r8), intent(in) :: rootfr_scaler ! What is the root fraction in this layer? - real(r8), intent(in) :: aroot_frac_plant ! What fraction of total absorbring roots - ! in the soil continuum is from current plant? - integer, intent(in) :: err_code ! error code - real(r8), intent(in) :: err_arr(:) ! error diagnostic - - type(ed_cohort_hydr_type),pointer :: cohort_hydr - integer :: i - integer :: ft - real(r8) :: leaf_water - real(r8) :: stem_water - real(r8) :: troot_water - real(r8) :: aroot_water - real(r8), allocatable :: psi_node(:) - real(r8), allocatable :: h_node(:) + ! Determine how many substeps, and how long they are - cohort_hydr => cohort%co_hydr - ft = cohort%pft + nsteps = max(imult*iter,1) ! Factor by which we divide through the timestep + ! start with full step (ie dt_fac = 1) + ! Then increase per the "imult" value. - allocate(psi_node(size(z_node))) - allocate(h_node(size(z_node))) + dt_substep = dt_step/real(nsteps,r8) ! This is the sub-stem length in seconds - write(fates_log(),*) 'Could not find a stable solution for hydro 1D solve' - write(fates_log(),*) '' - write(fates_log(),*) 'error code: ',err_code - write(fates_log(),*) 'error diag: ',err_arr(:) + ! Walk through sub-steps + do istep = 1,nsteps - do i = 1,n_hypool_plant - psi_node(i) = wrf_plant(site_hydr%pm_node(i),ft)%p%psi_from_th(th_node(i)) - h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) - end do - do i = n_hypool_plant+1,n_hypool_tot - psi_node(i) = site_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) - h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) - end do + ! Total water mass in the plant at the beginning of this solve [kg h2o] + w_tot_beg = sum(th_node(:)*v_node(:))*denh2o + ! Calculate on-node quantities: potential, and derivatives + do i = 1,n_hypool_plant - leaf_water = sum(cohort_hydr%th_ag(1:n_hypool_leaf)* & - cohort_hydr%v_ag(1:n_hypool_leaf))*denh2o - stem_water = sum(cohort_hydr%th_ag(n_hypool_leaf+1:n_hypool_ag) * & - cohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o - troot_water = (cohort_hydr%th_troot*cohort_hydr%v_troot) * denh2o - aroot_water = sum(cohort_hydr%th_aroot(:)*cohort_hydr%v_aroot_layer(:)) * denh2o - - write(fates_log(),*) 'layer: ',ilayer - write(fates_log(),*) 'wb_step_err = ',(q_top_eff*dt_step) - (w_tot_beg-w_tot_end) - write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' - write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' - write(fates_log(),*) 'troot_water: ',troot_water - write(fates_log(),*) 'aroot_water: ',aroot_water - write(fates_log(),*) 'LWP: ',cohort_hydr%psi_ag(1) - write(fates_log(),*) 'dbh: ',cohort%dbh - write(fates_log(),*) 'pft: ',cohort%pft - write(fates_log(),*) 'z nodes: ',z_node(:) - write(fates_log(),*) 'psi_z: ',h_node(:)-psi_node(:) - write(fates_log(),*) 'vol, theta, H, kmax-' - write(fates_log(),*) 'flux: ', q_top_eff*dt_step - write(fates_log(),*) 'l:',v_node(1),th_node(1),h_node(1),psi_node(1) - write(fates_log(),*) ' ',cohort_hydr%kmax_stem_upper(1)*rootfr_scaler - write(fates_log(),*) 's:',v_node(2),th_node(2),h_node(2),psi_node(2) - write(fates_log(),*) ' ',1._r8/(1._r8/(cohort_hydr%kmax_stem_lower(1)*rootfr_scaler) + 1._r8/(cohort_hydr%kmax_troot_upper*rootfr_scaler)) - write(fates_log(),*) 't:',v_node(3),th_node(3),h_node(3) - write(fates_log(),*) ' ',1._r8/(1._r8/cohort_hydr%kmax_troot_lower(ilayer)+ 1._r8/cohort_hydr%kmax_aroot_upper(ilayer)) - write(fates_log(),*) 'a:',v_node(4),th_node(4),h_node(4) - write(fates_log(),*) ' in:',1._r8/(1._r8/cohort_hydr%kmax_aroot_radial_in(ilayer) + & - 1._r8/(site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant) + & - 1._r8/cohort_hydr%kmax_aroot_upper(ilayer)) - write(fates_log(),*) ' out:',1._r8/(1._r8/cohort_hydr%kmax_aroot_radial_out(ilayer) + & - 1._r8/(site_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant) + & - 1._r8/cohort_hydr%kmax_aroot_upper(ilayer)) - write(fates_log(),*) 'r1:',v_node(5),th_node(5),h_node(5) - write(fates_log(),*) ' ',1._r8/(1._r8/(site_hydr%kmax_lower_shell(ilayer,1)*aroot_frac_plant) + 1._r8/(site_hydr%kmax_upper_shell(ilayer,2)*aroot_frac_plant)) - write(fates_log(),*) 'r2:',v_node(6),th_node(6),h_node(6) - write(fates_log(),*) ' ',1._r8/(1._r8/(site_hydr%kmax_lower_shell(ilayer,2)*aroot_frac_plant) + 1._r8/(site_hydr%kmax_upper_shell(ilayer,3)*aroot_frac_plant)) - write(fates_log(),*) 'r3:',v_node(7),th_node(7),h_node(7) - write(fates_log(),*) ' ',1._r8/(1._r8/(site_hydr%kmax_lower_shell(ilayer,3)*aroot_frac_plant) + 1._r8/(site_hydr%kmax_upper_shell(ilayer,4)*aroot_frac_plant)) - write(fates_log(),*) 'r4:',v_node(8),th_node(8),h_node(8) - write(fates_log(),*) ' ',1._r8/(1._r8/(site_hydr%kmax_lower_shell(ilayer,4)*aroot_frac_plant) + 1._r8/(site_hydr%kmax_upper_shell(ilayer,5)*aroot_frac_plant)) - write(fates_log(),*) 'r5:',v_node(9),th_node(9),h_node(9) - write(fates_log(),*) 'kmax_aroot_radial_out: ',cohort_hydr%kmax_aroot_radial_out(ilayer) - write(fates_log(),*) 'surf area of root: ',2._r8 * pi_const * EDPftvarcon_inst%hydr_rs2(ft) * cohort_hydr%l_aroot_layer(ilayer) - write(fates_log(),*) 'aroot_frac_plant: ',aroot_frac_plant,cohort_hydr%l_aroot_layer(ilayer),site_hydr%l_aroot_layer(ilayer) - write(fates_log(),*) 'kmax_upper_shell: ',site_hydr%kmax_lower_shell(ilayer,:)*aroot_frac_plant - write(fates_log(),*) 'kmax_lower_shell: ',site_hydr%kmax_upper_shell(ilayer,:)*aroot_frac_plant - write(fates_log(),*) '' - write(fates_log(),*) 'tree lai: ',cohort%treelai,' m2/m2 crown' - write(fates_log(),*) 'area and area to volume ratios' - write(fates_log(),*) '' - write(fates_log(),*) 'a:',v_node(4) - write(fates_log(),*) ' ',2._r8 * pi_const * EDPftvarcon_inst%hydr_rs2(ft) * cohort_hydr%l_aroot_layer(ilayer) - write(fates_log(),*) 'r1:',v_node(5) - write(fates_log(),*) ' ',2._r8 * pi_const * site_hydr%r_out_shell(ilayer,1) * cohort_hydr%l_aroot_layer(ilayer) - write(fates_log(),*) 'r2:',v_node(6) - write(fates_log(),*) ' ' - write(fates_log(),*) 'r3:',v_node(7) - write(fates_log(),*) ' ' - write(fates_log(),*) 'r4:',v_node(8) - write(fates_log(),*) ' ' - write(fates_log(),*) 'r5:',v_node(9) - - write(fates_log(),*) 'inner shell kmaxs: ',site_hydr%kmax_lower_shell(:,1)*aroot_frac_plant - + ! Get matric potential [Mpa] + psi_node(i) = wrf_plant(pm_node(i),ft)%p%psi_from_th(th_node(i)) + ! Get total potential [Mpa] + h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) + ! Get Fraction of Total Conductivity [-] + ftc_node(i) = wkf_plant(pm_node(i),ft)%p%ftc_from_psi(psi_node(i)) + ! deriv psi wrt theta + dpsi_dtheta_node(i) = wrf_plant(pm_node(i),ft)%p%dpsidth_from_th(th_node(i)) - deallocate(psi_node) - deallocate(h_node) + ! deriv ftc wrt psi + dftc_dpsi = wkf_plant(pm_node(i),ft)%p%dftcdpsi_from_psi(psi_node(i)) - ! Most likely you will want to end-run after this routine, but maybe not... + dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) - return - end subroutine Report1DError - - ! ================================================================================= - - subroutine GetImTaylorKAB(kmax_up,kmax_dn, & - ftc_up,ftc_dn, & - h_up,h_dn, & - dftc_dtheta_up, dftc_dtheta_dn, & - dpsi_dtheta_up, dpsi_dtheta_dn, & - k_eff, & - a_term, & - b_term) - - ! ----------------------------------------------------------------------------- - ! This routine will return the effective conductance "K", as well - ! as two terms needed to calculate the implicit solution (using taylor - ! first order expansion). The two terms are generically named A & B. - ! Thus the name "KAB". These quantities are specific not to the nodes - ! themselves, but to the path between the nodes, defined as positive - ! direction towards atmosphere, from "up"stream side (closer to soil) - ! and the "d"ow"n" stream side (closer to air) - ! ----------------------------------------------------------------------------- - ! Arguments - real(r8),intent(in) :: kmax_dn, kmax_up ! max conductance [kg s-1 Mpa-1] - real(r8),intent(inout) :: ftc_dn, ftc_up ! frac total conductance [-] - real(r8),intent(in) :: h_dn, h_up ! total potential [Mpa] - real(r8),intent(inout) :: dftc_dtheta_dn, dftc_dtheta_up ! Derivative - ! of FTC wrt relative water content - real(r8),intent(in) :: dpsi_dtheta_dn, dpsi_dtheta_up ! Derivative of matric potential - ! wrt relative water content - real(r8),intent(out) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] - real(r8),intent(out) :: a_term ! "A" term for path (See tech note) - real(r8),intent(out) :: b_term ! "B" term for path (See tech note) - - ! Locals - real(r8) :: h_diff ! Total potential difference [MPa] - - - ! Calculate difference in total potential over the path [MPa] - h_diff = h_up - h_dn - - ! If we do enable "upstream K", then we are saying that - ! the fractional loss of conductivity is dictated - ! by the upstream side of the flow. In this case, - ! the change in ftc is only non-zero on that side, and is - ! zero'd otherwise. - - if(do_upstream_k) then - - if (h_diff>0._r8) then - ftc_dn = ftc_up - dftc_dtheta_dn = 0._r8 - else - ftc_up = ftc_dn - dftc_dtheta_up = 0._r8 - end if + ! We have two ways to calculate radial absorbing root conductance + ! 1) Assume that water potential does not effect conductance + ! 2) The standard FTC function applies - end if + if(i==n_hypool_ag+2)then + if(no_ftc_radialk) then + ftc_node(i) = 1.0_r8 + dftc_dtheta_node(i) = 0.0_r8 + end if + end if - ! Calculate total effective conductance over path [kg s-1 MPa-1] - k_eff = 1._r8/(1._r8/(ftc_up*kmax_up)+1._r8/(ftc_dn*kmax_dn)) + end do - ! "A" term, which operates on the downstream node (closer to atm) - a_term = k_eff**2.0_r8 * h_diff * kmax_dn**(-1.0_r8) * ftc_dn**(-2.0_r8) & - * dftc_dtheta_dn - k_eff * dpsi_dtheta_dn - - ! "B" term, which operates on the upstream node (further from atm) - b_term = k_eff**2.0_r8 * h_diff * kmax_up**(-1.0_r8) * ftc_up**(-2.0_r8) & - * dftc_dtheta_up + k_eff * dpsi_dtheta_up - - + ! Same updates as loop above, but for rhizosphere shells - return - end subroutine GetImTaylorKAB + do i = n_hypool_plant+1,n_hypool_tot + psi_node(i) = csite_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) + h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) + ftc_node(i) = csite_hydr%wkf_soil(ilayer)%p%ftc_from_psi(psi_node(i)) + dpsi_dtheta_node(i) = csite_hydr%wrf_soil(ilayer)%p%dpsidth_from_th(th_node(i)) + dftc_dpsi = csite_hydr%wkf_soil(ilayer)%p%dftcdpsi_from_psi(psi_node(i)) + dftc_dtheta_node(i) = dftc_dpsi * dpsi_dtheta_node(i) + end do + + !-------------------------------------------------------------------------------- + ! Part 2. Effective conductances over the path-length and Flux terms + ! over the node-to-node paths + !-------------------------------------------------------------------------------- + + ! Path is between the leaf node and first stem node + ! ------------------------------------------------------------------------------- + + j = 1 + i_up = 2 ! upstream node index + i_dn = 1 ! downstream node index + kmax_dn = rootfr_scaler*cohort_hydr%kmax_petiole_to_leaf + kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_upper(1) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & + dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & + k_eff(j), & + A_term(j), & + B_term(j)) + + + ! Path is between stem nodes + ! ------------------------------------------------------------------------------- + + do j=2,n_hypool_ag-1 + + i_up = j+1 + i_dn = j + + ! "Up" is the "upstream" node, which also uses + ! the "upper" side of its compartment for the calculation. + ! "dn" is the "downstream" node, which uses the lower + ! side of its compartment + ! This compartment is the "lower" node, but uses + ! the "higher" side of its compartment. + + kmax_dn = rootfr_scaler*cohort_hydr%kmax_stem_lower(i_dn-n_hypool_leaf) + kmax_up = rootfr_scaler*cohort_hydr%kmax_stem_upper(i_up-n_hypool_leaf) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & + dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & + k_eff(j), & + A_term(j), & + B_term(j)) - ! ===================================================================================== + end do - subroutine GetKAndDKDPsi(kmax_dn,kmax_up, & - h_dn,h_up, & - ftc_dn,ftc_up, & - dftc_dpsi_dn, & - dftc_dpsi_up, & - dk_dpsi_dn, & - dk_dpsi_up, & - k_eff) - - ! ----------------------------------------------------------------------------- - ! This routine will return the effective conductance "K", as well - ! as two terms needed to calculate the implicit solution (using taylor - ! first order expansion). The two terms are generically named A & B. - ! Thus the name "KAB". These quantities are specific not to the nodes - ! themselves, but to the path between the nodes, defined as positive - ! direction from "up"per (closer to atm) and "lo"wer (further from atm). - ! ----------------------------------------------------------------------------- - - real(r8),intent(in) :: kmax_dn ! max conductance (downstream) [kg s-1 Mpa-1] - real(r8),intent(in) :: kmax_up ! max conductance (upstream) [kg s-1 Mpa-1] - real(r8),intent(in) :: h_dn ! total potential (downstream) [MPa] - real(r8),intent(in) :: h_up ! total potential (upstream) [Mpa] - real(r8),intent(in) :: ftc_dn ! frac total cond (downstream) [-] - real(r8),intent(in) :: ftc_up ! frac total cond (upstream) [-] - real(r8),intent(in) :: dftc_dpsi_dn ! derivative ftc / theta (downstream) - real(r8),intent(in) :: dftc_dpsi_up ! derivative ftc / theta (upstream) - ! of FTC wrt relative water content - real(r8),intent(out) :: dk_dpsi_dn ! change in effective conductance from the - ! downstream pressure node - real(r8),intent(out) :: dk_dpsi_up ! change in effective conductance from the - ! upstream pressure node - real(r8),intent(out) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] - ! Locals - real(r8) :: h_diff ! Total potential difference [MPa] - ! the effective fraction of total - ! conductivity is either governed - ! by the upstream node, or by both - ! with a harmonic average - real(r8) :: ftc_dnx ! frac total cond (downstream) [-] (local copy) - real(r8) :: ftc_upx ! frac total cond (upstream) [-] (local copy) - real(r8) :: dftc_dpsi_dnx ! derivative ftc / theta (downstream) (local copy) - real(r8) :: dftc_dpsi_upx ! derivative ftc / theta (upstream) (local copy) + ! Path is between lowest stem and transporting root + + j = n_hypool_ag + i_up = j+1 + i_dn = j + kmax_dn = rootfr_scaler*cohort_hydr%kmax_stem_lower(n_hypool_stem) + kmax_up = rootfr_scaler*cohort_hydr%kmax_troot_upper + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & + dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & + k_eff(j), & + A_term(j), & + B_term(j)) + + ! Path is between the transporting root + ! and the absorbing root for this layer + ! NOTE: No need to scale by root fraction + ! even if in parallel mode, already parallel! + + j = n_hypool_ag+1 + i_up = j+1 + i_dn = j + kmax_dn = cohort_hydr%kmax_troot_lower(ilayer) + kmax_up = cohort_hydr%kmax_aroot_upper(ilayer) + + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & + dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & + k_eff(j), & + A_term(j), & + B_term(j)) + + ! Path is between the absorbing root + ! and the first rhizosphere shell nodes + + j = n_hypool_ag+2 + i_up = j+1 + i_dn = j + + ! Special case. Maximum conductance depends on the + ! potential gradient. + if(h_node(i_up) > h_node(i_dn) ) then + kmax_dn = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & + 1._r8/cohort_hydr%kmax_aroot_radial_in(ilayer)) + else + kmax_dn = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(ilayer) + & + 1._r8/cohort_hydr%kmax_aroot_radial_out(ilayer)) + end if + kmax_up = csite_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & + dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & + k_eff(j), & + A_term(j), & + B_term(j)) - ! We use the local copies of the FTC in our calculations - ! because we don't want to over-write the global values. This prevents - ! us from overwriting FTC on nodes that have more than one connection - - ftc_dnx = ftc_dn - ftc_upx = ftc_up - dftc_dpsi_dnx = dftc_dpsi_dn - dftc_dpsi_upx = dftc_dpsi_up - - ! Calculate difference in total potential over the path [MPa] - - h_diff = h_up - h_dn + ! Path is between rhizosphere shells - ! If we do enable "upstream K", then we are saying that - ! the fractional loss of conductivity is dictated - ! by the upstream side of the flow. In this case, - ! the change in ftc is only non-zero on that side, and is - ! zero'd otherwise. + do j = n_hypool_ag+3,n_hypool_tot-1 - if(do_upstream_k) then + i_up = j+1 + i_dn = j + ishell_up = i_up - (n_hypool_tot-nshell) + ishell_dn = i_dn - (n_hypool_tot-nshell) - if (h_diff>0._r8) then - ftc_dnx = ftc_up - dftc_dpsi_dnx = 0._r8 - else - ftc_upx = ftc_dn - dftc_dpsi_upx = 0._r8 - end if + kmax_dn = csite_hydr%kmax_lower_shell(ilayer,ishell_dn)*aroot_frac_plant + kmax_up = csite_hydr%kmax_upper_shell(ilayer,ishell_up)*aroot_frac_plant - end if + call GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_node(i_up),ftc_node(i_dn), & + h_node(i_up),h_node(i_dn), & + dftc_dtheta_node(i_up), dftc_dtheta_node(i_dn), & + dpsi_dtheta_node(i_up), dpsi_dtheta_node(i_dn), & + k_eff(j), & + A_term(j), & + B_term(j)) - ! Calculate total effective conductance over path [kg s-1 MPa-1] - k_eff = 1._r8/(1._r8/(ftc_upx*kmax_up)+1._r8/(ftc_dnx*kmax_dn)) + end do - dk_dpsi_dn = k_eff**2._r8 * kmax_dn**(-1._r8) * ftc_dnx**(-2._r8) * dftc_dpsi_dnx + ! ------------------------------------------------------------------------------- + ! Part 3. + ! Loop through nodes again, build matrix + ! ------------------------------------------------------------------------------- - dk_dpsi_up = k_eff**2._r8 * kmax_up**(-1._r8) * ftc_upx**(-2._r8) * dftc_dpsi_upx - + tris_a(1) = 0._r8 + tris_b(1) = A_term(1) - denh2o*v_node(1)/dt_substep + tris_c(1) = B_term(1) + tris_r(1) = q_top_eff - k_eff(1)*(h_node(2)-h_node(1)) - return - end subroutine GetKAndDKDPsi - - subroutine AccumulateMortalityWaterStorage(csite,ccohort,delta_n) + do i = 2,n_hypool_tot-1 + j = i + tris_a(i) = -A_term(j-1) + tris_b(i) = A_term(j) - B_term(j-1) - denh2o*v_node(i)/dt_substep + tris_c(i) = B_term(j) + tris_r(i) = -k_eff(j)*(h_node(i+1)-h_node(i)) + & + k_eff(j-1)*(h_node(i)-h_node(i-1)) - ! --------------------------------------------------------------------------- - ! This subroutine accounts for the water bound in plants that have - ! just died. This water is accumulated at the site level for all plants - ! that die. - ! In another routine, this pool is reduced as water vapor flux, and - ! passed to the HLM. - ! --------------------------------------------------------------------------- + end do - ! Arguments + i = n_hypool_tot + j = n_hypool_tot + tris_a(i) = -A_term(j-1) + tris_b(i) = -B_term(j-1) - denh2o*v_node(i)/dt_substep + tris_c(i) = 0._r8 + tris_r(i) = k_eff(j-1)*(h_node(i)-h_node(i-1)) - type(ed_site_type), intent(inout), target :: csite - type(ed_cohort_type) , intent(inout), target :: ccohort - real(r8), intent(in) :: delta_n ! Loss in number density - ! for this cohort /ha/day - real(r8) :: delta_w !water change due to mortality Kg/m2 - ! Locals - type(ed_site_hydr_type), pointer :: csite_hydr - type(ed_cohort_hydr_type), pointer :: ccohort_hydr + ! Calculate the change in theta - ccohort_hydr => ccohort%co_hydr - csite_hydr => csite%si_hydr - delta_w = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - ccohort_hydr%th_troot*ccohort_hydr%v_troot + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o*delta_n*AREA_INV + call Hydraulics_Tridiagonal(tris_a, tris_b, tris_c, tris_r, dth_node, tri_ierr) - csite_hydr%h2oveg_dead = csite_hydr%h2oveg_dead + delta_w + if(tri_ierr == 1) then + solution_found = .false. + error_code = 2 + error_arr(:) = 0._r8 + exit + end if + ! If we have not broken from the substep loop, + ! that means this sub-step has been acceptable, and we may + ! go ahead and update the water content for the integrator - csite_hydr%h2oveg = csite_hydr%h2oveg - delta_w + th_node(:) = th_node(:) + dth_node(:) - return - end subroutine AccumulateMortalityWaterStorage + ! Mass error (flux - change) + ! Total water mass in the plant at the beginning of this solve [kg h2o] + w_tot_end = sum(th_node(:)*v_node(:))*denh2o - !-------------------------------------------------------------------------------! + wb_step_err = (q_top_eff*dt_substep) - (w_tot_beg-w_tot_end) - subroutine RecruitWaterStorage(nsites,sites,bc_out) + if(abs(wb_step_err)>max_wb_step_err .or. any(dth_node(:).ne.dth_node(:)) )then + solution_found = .false. + error_code = 1 + error_arr(:) = 0._r8 + exit + else + ! Note: this is somewhat of a default true. And the sub-steps + ! will keep going unless its changed and broken out of + ! the loop. + solution_found = .true. + error_code = 0 + end if - ! --------------------------------------------------------------------------- - ! This subroutine accounts for the water bound in plants that have - ! just recruited. This water is accumulated at the site level for all plants - ! that recruit. - ! *Note that no mass is moved in this call, this routine is only for - ! generating diagnostics. Water fluxes will be calculated during - ! again during RecruitWUptake() the next time the hydraulics routine is run, - ! and water will be removed from the soil to accomodate. - ! --------------------------------------------------------------------------- + ! If desired, check and trap water contents + ! that are negative + if(trap_neg_wc) then + if( any(th_node(:)<0._r8) ) then + solution_found = .false. + error_code = 3 + error_arr(:) = th_node(:) + exit + end if + end if - ! Arguments - integer, intent(in) :: nsites - type(ed_site_type), intent(inout), target :: sites(nsites) - type(bc_out_type), intent(inout) :: bc_out(nsites) + ! Calculate new psi for checks + do i = 1,n_hypool_plant + psi_node(i) = wrf_plant(pm_node(i),ft)%p%psi_from_th(th_node(i)) + end do + do i = n_hypool_plant+1,n_hypool_tot + psi_node(i) = csite_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) + end do - ! Locals - type(ed_cohort_type), pointer :: currentCohort - type(ed_patch_type), pointer :: currentPatch - type(ed_cohort_hydr_type), pointer :: ccohort_hydr - type(ed_site_hydr_type), pointer :: csite_hydr - integer :: s + ! If desired, check and trap pressures that are supersaturated + if(trap_supersat_psi) then + do i = 1,n_hypool_plant + if(psi_node(i)>wrf_plant(pm_node(i),ft)%p%get_thsat()) then + solution_found = .false. + error_code = 4 + end if + end do + do i = n_hypool_plant+1,n_hypool_tot + if(psi_node(i)>csite_hydr%wrf_soil(ilayer)%p%get_thsat()) then + solution_found = .false. + error_code = 4 + end if + end do + if(error_code==4) then + error_arr(:) = th_node(:) + end if + end if - if( hlm_use_planthydro.eq.ifalse ) return + ! Accumulate the water balance error of the layer over the sub-steps + ! for diagnostic purposes + ! [kg/m2] + wb_err_layer = wb_err_layer + wb_step_err + + ! ------------------------------------------------------------------------- + ! Diagnostics + ! ------------------------------------------------------------------------- + + ! Sapflow at the base of the tree is the flux rate + ! between the transporting root node and the first stem node + ! (note: a path j is between node i and i+1) + ! [kg] = [kg/s] * [s] + + i = n_hypool_ag + sapflow_lyr = sapflow_lyr + dt_substep * & + (k_eff(i)*(h_node(i+1)-h_node(i)) + & ! flux at (t) + A_term(i)*dth_node(i) + & ! dq at node i + B_term(i)*dth_node(i+1)) ! dq at node i+1 + + ! Root uptake is the integrated flux between the first rhizosphere + ! shell and the absorbing root + + i = n_hypool_ag+2 + rootuptake_lyr = rootuptake_lyr + dt_substep * & + (k_eff(i)*(h_node(i+1)-h_node(i)) + & ! flux at (t) + A_term(i)*dth_node(i) + & ! dq at node i + B_term(i)*dth_node(i+1)) ! dq at node i+1 + + ! If debug mode is on, lets also track the mass fluxes across each + ! path, and keep a running average of the effective conductances + if(debug)then + do j=1,n_hypool_tot-1 + k_diag(j) = k_diag(j) + k_eff(j)*dt_substep/dt_step + flux_diag(j) = flux_diag(j) + dt_substep * ( & + k_eff(j)*(h_node(j+1)-h_node(j)) + & + A_term(j)*dth_node(j)+ B_term(j)*dth_node(j+1)) + end do + end if - do s = 1,nsites + end do ! do istep = 1,nsteps (substep loop) - csite_hydr => sites(s)%si_hydr - csite_hydr%h2oveg_recruit = 0.0_r8 - currentPatch => sites(s)%oldest_patch - do while(associated(currentPatch)) - currentCohort=>currentPatch%tallest - do while(associated(currentCohort)) - ccohort_hydr => currentCohort%co_hydr - if(ccohort_hydr%is_newly_recruited) then - csite_hydr%h2oveg_recruit = csite_hydr%h2oveg_recruit + & - (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & - ccohort_hydr%th_troot*ccohort_hydr%v_troot + & - sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & - denh2o*currentCohort%n - end if - currentCohort => currentCohort%shorter - enddo !cohort - currentPatch => currentPatch%younger - enddo !end patch loop + iter=iter+1 - csite_hydr%h2oveg_recruit = csite_hydr%h2oveg_recruit * AREA_INV + end do solution_iteration - end do + ! ----------------------------------------------------------- + ! Do a final check on water balance error sumed over sub-steps + ! ------------------------------------------------------------ + if ( abs(wb_err_layer) > max_wb_err ) then - return - end subroutine RecruitWaterStorage + write(fates_log(),*)'EDPlantHydraulics water balance error exceeds threshold of = ', max_wb_err + write(fates_log(),*)'transpiration demand: ', dt_step*q_top_eff,' kg/step/plant' - ! ===================================================================================== + leaf_water = cohort_hydr%th_ag(1)*cohort_hydr%v_ag(1)*denh2o + stem_water = sum(cohort_hydr%th_ag(2:n_hypool_ag) * & + cohort_hydr%v_ag(2:n_hypool_ag))*denh2o + root_water = ( cohort_hydr%th_troot*cohort_hydr%v_troot + & + sum(cohort_hydr%th_aroot(:)*cohort_hydr%v_aroot_layer(:))) * denh2o - ! ===================================================================================== - ! Utility Functions - ! ===================================================================================== + write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' + write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' + write(fates_log(),*) 'root_water: ',root_water,' kg/plant' + write(fates_log(),*) 'LWP: ',cohort_hydr%psi_ag(1) + write(fates_log(),*) 'dbh: ',cohort%dbh + write(fates_log(),*) 'pft: ',cohort%pft + write(fates_log(),*) 'tree lai: ',cohort%treelai,' m2/m2 crown' + write(fates_log(),*) 'recruitflag: ',recruitflag + write(fates_log(),*) 'lat:', slat, 'lon:', slon + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if - subroutine bisect_rootfr(a, b, lower_init, upper_init, xtol, ytol, crootfr, x_new) - ! - ! !DESCRIPTION: Bisection routine for getting the inverse of the cumulative root - ! distribution. No analytical soln bc crootfr ~ exp(ax) + exp(bx). - ! - ! !USES: - ! - ! !ARGUMENTS - real(r8) , intent(in) :: a, b ! pft root distribution constants - real(r8) , intent(in) :: lower_init ! lower bound of initial x estimate [m] - real(r8) , intent(in) :: upper_init ! upper bound of initial x estimate [m] - real(r8) , intent(in) :: xtol ! error tolerance for x_new [m] - real(r8) , intent(in) :: ytol ! error tolerance for crootfr [-] - real(r8) , intent(in) :: crootfr ! cumulative root fraction at x_new [-] - real(r8) , intent(out) :: x_new ! soil depth [m] - ! - ! !LOCAL VARIABLES: - real(r8) :: lower ! lower bound x estimate [m] - real(r8) :: upper ! upper bound x estimate [m] - real(r8) :: y_lo ! corresponding y value at lower - real(r8) :: f_lo ! y difference between lower bound guess and target y - real(r8) :: y_hi ! corresponding y value at upper - real(r8) :: f_hi ! y difference between upper bound guess and target y - real(r8) :: y_new ! corresponding y value at x.new - real(r8) :: f_new ! y difference between new y guess at x.new and target y - real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) - !---------------------------------------------------------------------- - - lower = lower_init - upper = upper_init - f_lo = zeng2001_crootfr(a, b, lower) - crootfr - f_hi = zeng2001_crootfr(a, b, upper) - crootfr - chg = upper - lower - do while(abs(chg) .gt. xtol) - x_new = 0.5_r8*(lower + upper) - f_new = zeng2001_crootfr(a, b, x_new) - crootfr - if(abs(f_new) .le. ytol) then - EXIT - end if - if((f_lo * f_new) .lt. 0._r8) upper = x_new - if((f_hi * f_new) .lt. 0._r8) lower = x_new - chg = upper - lower - end do - end subroutine bisect_rootfr - ! ===================================================================================== + ! If we have made it to this point, supposedly we have completed the whole time-step + ! for this cohort x layer combination. It is now safe to save the delta theta + ! value and pass it back to the calling routine. The value passed back is the + ! change in theta over all sub-steps. - function zeng2001_crootfr(a, b, z, z_max) result(crootfr) + dth_node(:) = th_node(:)-th_node_init(:) - ! !ARGUMENTS: - real(r8) , intent(in) :: a,b ! pft parameters - real(r8) , intent(in) :: z ! soil depth (m) - real(r8) , intent(in), optional :: z_max ! max soil depth (m) - ! - real(r8) :: crootfr_max - ! !RESULT - real(r8) :: crootfr ! cumulative root fraction - ! - !------------------------------------------------------------------------ - crootfr = 1._r8 - .5_r8*(exp(-a*z) + exp(-b*z)) + ! Add the current soil layer's contribution to total + ! sap and root flux [kg] + sapflow = sapflow + sapflow_lyr + rootuptake(ilayer) = rootuptake_lyr - ! If a maximum rooting depth is provided, then - ! we force everything to sum to unity. We do this by - ! simply dividing through by the maximum possible - ! root fraction. + ! Record the layer with the most iterations, but only + ! if it greater than 1. It will default to zero + ! if no layers took extra iterations. + if( (real(iter)>cohort_hydr%iterh1) .and. (iter>1) )then + cohort_hydr%iterlayer = real(ilayer) + end if - if(present(z_max))then - crootfr_max = 1._r8 - .5_r8*(exp(-a*z_max) + exp(-b*z_max)) - crootfr = crootfr/crootfr_max - end if + ! Save the number of times we refined our sub-step counts (iterh1) + cohort_hydr%iterh1 = max(cohort_hydr%iterh1,real(iter,r8)) + ! Save the number of sub-steps we ultimately used + cohort_hydr%iterh2 = max(cohort_hydr%iterh2,real(nsteps,r8)) + + ! Update water contents in the relevant plant compartments [m3/m3] + ! ------------------------------------------------------------------------------- + + ! Leaf and above-ground stems + cohort_hydr%th_ag(1:n_hypool_ag) = cohort_hydr%th_ag(1:n_hypool_ag) + dth_node(1:n_hypool_ag) + ! Transporting root + cohort_hydr%th_troot = cohort_hydr%th_troot + dth_node(n_hypool_ag+1) + ! Absorbing root + cohort_hydr%th_aroot(ilayer) = cohort_hydr%th_aroot(ilayer) + dth_node(n_hypool_ag+2) + + ! Change in water per plant [kg/plant] + dwat_plant = dwat_plant + & + (sum(dth_node(1:n_hypool_ag)*cohort_hydr%v_ag(1:n_hypool_ag)) + & + dth_node(n_hypool_ag+1)*cohort_hydr%v_troot + & + dth_node(n_hypool_ag+2)*cohort_hydr%v_aroot_layer(ilayer))*denh2o + + ! Remember the error for the cohort + wb_err_plant = wb_err_plant + wb_err_layer + + ! Save the change in water mass in the rhizosphere. Note that we did + ! not immediately update the state variables upon completing each + ! plant-layer solve. We accumulate the difference, and apply them + ! after all cohort-layers are complete. This allows each cohort + ! to experience the same water conditions (for good or bad). + + dth_layershell_col(ilayer,:) = dth_layershell_col(ilayer,:) + & + dth_node((n_hypool_tot-nshell+1):n_hypool_tot) * & + cohort_hydr%l_aroot_layer(ilayer) * & + cohort%n / csite_hydr%l_aroot_layer(ilayer) + + enddo loop_root_layers + +end associate +return +end subroutine ImTaylorSolve1D + +! ===================================================================================== + +subroutine Report1DError(cohort, csite_hydr, ilayer, z_node, v_node, & + th_node, q_top_eff, dt_step, w_tot_beg, w_tot_end, & + rootfr_scaler, aroot_frac_plant, err_code, err_arr,slat,slon, recruitflag) + + ! This routine reports what the initial condition to the 1D solve looks + ! like, and then quits. + + ! Arguments (IN) + type(ed_cohort_type),intent(in),target :: cohort + type(ed_site_hydr_type),intent(in), target :: csite_hydr + integer, intent(in) :: ilayer ! soil layer index of interest + real(r8), intent(in) :: z_node(:) ! elevation of nodes + real(r8), intent(in) :: v_node(:) ! volume of nodes + real(r8), intent(in) :: th_node(:) ! water content of node + real(r8), intent(in) :: dt_step ! time [seconds] over-which to calculate solution + real(r8), intent(in) :: q_top_eff ! transpiration flux rate at upper boundary [kg -s] + real(r8), intent(in) :: w_tot_beg ! total water mass at beginning of step [kg] + real(r8), intent(in) :: w_tot_end ! total water mass at end of step [kg] + real(r8), intent(in) :: rootfr_scaler ! What is the root fraction in this layer? + real(r8), intent(in) :: aroot_frac_plant ! What fraction of total absorbring roots + ! in the soil continuum is from current plant? + integer, intent(in) :: err_code ! error code + real(r8), intent(in) :: err_arr(:) ! error diagnostic + real(r8), intent(in) :: slat ! site latitude + real(r8), intent(in) :: slon ! site longitude + logical, intent(in) :: recruitflag + + type(ed_cohort_hydr_type),pointer :: cohort_hydr + integer :: i + integer :: ft + real(r8) :: leaf_water + real(r8) :: stem_water + real(r8) :: troot_water + real(r8) :: aroot_water + real(r8), allocatable :: psi_node(:) + real(r8), allocatable :: h_node(:) + + cohort_hydr => cohort%co_hydr + ft = cohort%pft + + allocate(psi_node(size(z_node))) + allocate(h_node(size(z_node))) + + write(fates_log(),*) 'Could not find a stable solution for hydro 1D solve' + write(fates_log(),*) '' + write(fates_log(),*) 'error code: ',err_code + write(fates_log(),*) 'error diag: ',err_arr(:) + + do i = 1,n_hypool_plant + psi_node(i) = wrf_plant(csite_hydr%pm_node(i),ft)%p%psi_from_th(th_node(i)) + h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) + end do + do i = n_hypool_plant+1,n_hypool_tot + psi_node(i) = csite_hydr%wrf_soil(ilayer)%p%psi_from_th(th_node(i)) + h_node(i) = mpa_per_pa*denh2o*grav_earth*z_node(i) + psi_node(i) + end do - if(debug)then - if(present(z_max))then - if((crootfr_max1.0_r8) )then - write(fates_log(),*) 'problem scaling crootfr in zeng2001' - write(fates_log(),*) 'z_max: ',z_max - write(fates_log(),*) 'crootfr_max: ',crootfr_max - end if - end if - end if + leaf_water = sum(cohort_hydr%th_ag(1:n_hypool_leaf)* & + cohort_hydr%v_ag(1:n_hypool_leaf))*denh2o + stem_water = sum(cohort_hydr%th_ag(n_hypool_leaf+1:n_hypool_ag) * & + cohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag))*denh2o + troot_water = (cohort_hydr%th_troot*cohort_hydr%v_troot) * denh2o + aroot_water = sum(cohort_hydr%th_aroot(:)*cohort_hydr%v_aroot_layer(:)) * denh2o + write(fates_log(),*) 'lat: ',slat, 'longitidue:', slon + write(fates_log(),*) 'is recruitment: ', recruitflag + write(fates_log(),*) 'layer: ',ilayer + write(fates_log(),*) 'wb_step_err = ',(q_top_eff*dt_step) - (w_tot_beg-w_tot_end) + write(fates_log(),*) 'q_top_eff*dt_step = ',q_top_eff*dt_step + write(fates_log(),*) 'w_tot_beg = ',w_tot_beg + write(fates_log(),*) 'w_tot_end = ',w_tot_end + write(fates_log(),*) 'leaf water: ',leaf_water,' kg/plant' + write(fates_log(),*) 'stem_water: ',stem_water,' kg/plant' + write(fates_log(),*) 'troot_water: ',troot_water + write(fates_log(),*) 'aroot_water: ',aroot_water + write(fates_log(),*) 'LWP: ',cohort_hydr%psi_ag(1) + write(fates_log(),*) 'dbh: ',cohort%dbh + write(fates_log(),*) 'pft: ',cohort%pft + write(fates_log(),*) 'z nodes: ',z_node(:) + write(fates_log(),*) 'psi_z: ',h_node(:)-psi_node(:) + write(fates_log(),*) 'vol, theta, H, Psi, kmax-' + write(fates_log(),*) 'flux: ', q_top_eff*dt_step + write(fates_log(),*) 'l:',v_node(1),th_node(1),h_node(1),psi_node(1) + write(fates_log(),*) ' ',cohort_hydr%kmax_stem_upper(1)*rootfr_scaler + write(fates_log(),*) 's:',v_node(2),th_node(2),h_node(2),psi_node(2) + write(fates_log(),*) ' ',1._r8/(1._r8/(cohort_hydr%kmax_stem_lower(1)*rootfr_scaler) + 1._r8/(cohort_hydr%kmax_troot_upper*rootfr_scaler)) + write(fates_log(),*) 't:',v_node(3),th_node(3),h_node(3) + write(fates_log(),*) ' ',1._r8/(1._r8/cohort_hydr%kmax_troot_lower(ilayer)+ 1._r8/cohort_hydr%kmax_aroot_upper(ilayer)) + write(fates_log(),*) 'a:',v_node(4),th_node(4),h_node(4) + write(fates_log(),*) ' in:',1._r8/(1._r8/cohort_hydr%kmax_aroot_radial_in(ilayer) + & + 1._r8/(csite_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant) + & + 1._r8/cohort_hydr%kmax_aroot_upper(ilayer)) + write(fates_log(),*) ' out:',1._r8/(1._r8/cohort_hydr%kmax_aroot_radial_out(ilayer) + & + 1._r8/(csite_hydr%kmax_upper_shell(ilayer,1)*aroot_frac_plant) + & + 1._r8/cohort_hydr%kmax_aroot_upper(ilayer)) + write(fates_log(),*) 'r1:',v_node(5),th_node(5),h_node(5) + write(fates_log(),*) ' ',1._r8/(1._r8/(csite_hydr%kmax_lower_shell(ilayer,1)*aroot_frac_plant) + 1._r8/(csite_hydr%kmax_upper_shell(ilayer,2)*aroot_frac_plant)) + write(fates_log(),*) 'r2:',v_node(6),th_node(6),h_node(6) + write(fates_log(),*) ' ',1._r8/(1._r8/(csite_hydr%kmax_lower_shell(ilayer,2)*aroot_frac_plant) + 1._r8/(csite_hydr%kmax_upper_shell(ilayer,3)*aroot_frac_plant)) + write(fates_log(),*) 'r3:',v_node(7),th_node(7),h_node(7) + write(fates_log(),*) ' ',1._r8/(1._r8/(csite_hydr%kmax_lower_shell(ilayer,3)*aroot_frac_plant) + 1._r8/(csite_hydr%kmax_upper_shell(ilayer,4)*aroot_frac_plant)) + write(fates_log(),*) 'r4:',v_node(8),th_node(8),h_node(8) + write(fates_log(),*) ' ',1._r8/(1._r8/(csite_hydr%kmax_lower_shell(ilayer,4)*aroot_frac_plant) + 1._r8/(csite_hydr%kmax_upper_shell(ilayer,5)*aroot_frac_plant)) + write(fates_log(),*) 'r5:',v_node(9),th_node(9),h_node(9) + write(fates_log(),*) 'kmax_aroot_radial_out: ',cohort_hydr%kmax_aroot_radial_out(ilayer) + write(fates_log(),*) 'surf area of root: ',2._r8 * pi_const * EDPftvarcon_inst%hydr_rs2(ft) * cohort_hydr%l_aroot_layer(ilayer) + write(fates_log(),*) 'aroot_frac_plant: ',aroot_frac_plant,cohort_hydr%l_aroot_layer(ilayer),csite_hydr%l_aroot_layer(ilayer) + write(fates_log(),*) 'kmax_upper_shell: ',csite_hydr%kmax_lower_shell(ilayer,:)*aroot_frac_plant + write(fates_log(),*) 'kmax_lower_shell: ',csite_hydr%kmax_upper_shell(ilayer,:)*aroot_frac_plant + write(fates_log(),*) '' + write(fates_log(),*) 'tree lai: ',cohort%treelai,' m2/m2 crown' + write(fates_log(),*) 'area and area to volume ratios' + write(fates_log(),*) '' + write(fates_log(),*) 'a:',v_node(4) + write(fates_log(),*) ' ',2._r8 * pi_const * EDPftvarcon_inst%hydr_rs2(ft) * cohort_hydr%l_aroot_layer(ilayer) + write(fates_log(),*) 'r1:',v_node(5) + write(fates_log(),*) ' ',2._r8 * pi_const * csite_hydr%r_out_shell(ilayer,1) * cohort_hydr%l_aroot_layer(ilayer) + write(fates_log(),*) 'r2:',v_node(6) + write(fates_log(),*) ' ' + write(fates_log(),*) 'r3:',v_node(7) + write(fates_log(),*) ' ' + write(fates_log(),*) 'r4:',v_node(8) + write(fates_log(),*) ' ' + write(fates_log(),*) 'r5:',v_node(9) + write(fates_log(),*) 'inner shell kmaxs: ',csite_hydr%kmax_lower_shell(:,1)*aroot_frac_plant + + deallocate(psi_node) + deallocate(h_node) + + + ! Most likely you will want to end-run after this routine, but maybe not... + + return +end subroutine Report1DError + +! ================================================================================= + +subroutine GetImTaylorKAB(kmax_up,kmax_dn, & + ftc_up,ftc_dn, & + h_up,h_dn, & + dftc_dtheta_up, dftc_dtheta_dn, & + dpsi_dtheta_up, dpsi_dtheta_dn, & + k_eff, & + a_term, & + b_term) + + ! ----------------------------------------------------------------------------- + ! This routine will return the effective conductance "K", as well + ! as two terms needed to calculate the implicit solution (using taylor + ! first order expansion). The two terms are generically named A & B. + ! Thus the name "KAB". These quantities are specific not to the nodes + ! themselves, but to the path between the nodes, defined as positive + ! direction towards atmosphere, from "up"stream side (closer to soil) + ! and the "d"ow"n" stream side (closer to air) + ! ----------------------------------------------------------------------------- + ! Arguments + real(r8),intent(in) :: kmax_dn, kmax_up ! max conductance [kg s-1 Mpa-1] + real(r8),intent(inout) :: ftc_dn, ftc_up ! frac total conductance [-] + real(r8),intent(in) :: h_dn, h_up ! total potential [Mpa] + real(r8),intent(inout) :: dftc_dtheta_dn, dftc_dtheta_up ! Derivative + ! of FTC wrt relative water content + real(r8),intent(in) :: dpsi_dtheta_dn, dpsi_dtheta_up ! Derivative of matric potential + ! wrt relative water content + real(r8),intent(out) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] + real(r8),intent(out) :: a_term ! "A" term for path (See tech note) + real(r8),intent(out) :: b_term ! "B" term for path (See tech note) + + ! Locals + real(r8) :: h_diff ! Total potential difference [MPa] + real(r8) :: ftc_dn_tmp, ftc_up_tmp ! working frac total conductance [-] + + + ! Store ftc before changing it + ftc_dn_tmp = ftc_dn + ftc_up_tmp = ftc_up - return + + ! Calculate difference in total potential over the path [MPa] + h_diff = h_up - h_dn + + ! If we do enable "upstream K", then we are saying that + ! the fractional loss of conductivity is dictated + ! by the upstream side of the flow. In this case, + ! the change in ftc is only non-zero on that side, and is + ! zero'd otherwise. + + if(do_upstream_k) then + + if (h_diff>0._r8) then + ftc_dn = ftc_up + dftc_dtheta_dn = 0._r8 + else + ftc_up = ftc_dn + dftc_dtheta_up = 0._r8 + end if - end function zeng2001_crootfr + end if + + ! Calculate total effective conductance over path [kg s-1 MPa-1] + k_eff = 1._r8/(1._r8/(ftc_up*kmax_up)+1._r8/(ftc_dn*kmax_dn)) + + ! "A" term, which operates on the downstream node (closer to atm) + a_term = k_eff**2.0_r8 * h_diff * kmax_dn**(-1.0_r8) * ftc_dn**(-2.0_r8) & + * dftc_dtheta_dn - k_eff * dpsi_dtheta_dn + + + ! "B" term, which operates on the upstream node (further from atm) + b_term = k_eff**2.0_r8 * h_diff * kmax_up**(-1.0_r8) * ftc_up**(-2.0_r8) & + * dftc_dtheta_up + k_eff * dpsi_dtheta_up + + ! Restore ftc + ftc_dn = ftc_dn_tmp + ftc_up = ftc_up_tmp + + return +end subroutine GetImTaylorKAB + +! ===================================================================================== + +subroutine GetKAndDKDPsi(kmax_dn,kmax_up, & + h_dn,h_up, & + ftc_dn,ftc_up, & + dftc_dpsi_dn, & + dftc_dpsi_up, & + dk_dpsi_dn, & + dk_dpsi_up, & + k_eff) + + ! ----------------------------------------------------------------------------- + ! This routine will return the effective conductance "K", as well + ! as two terms needed to calculate the implicit solution (using taylor + ! first order expansion). The two terms are generically named A & B. + ! Thus the name "KAB". These quantities are specific not to the nodes + ! themselves, but to the path between the nodes, defined as positive + ! direction from "up"per (closer to atm) and "lo"wer (further from atm). + ! ----------------------------------------------------------------------------- + + real(r8),intent(in) :: kmax_dn ! max conductance (downstream) [kg s-1 Mpa-1] + real(r8),intent(in) :: kmax_up ! max conductance (upstream) [kg s-1 Mpa-1] + real(r8),intent(in) :: h_dn ! total potential (downstream) [MPa] + real(r8),intent(in) :: h_up ! total potential (upstream) [Mpa] + real(r8),intent(in) :: ftc_dn ! frac total cond (downstream) [-] + real(r8),intent(in) :: ftc_up ! frac total cond (upstream) [-] + real(r8),intent(in) :: dftc_dpsi_dn ! derivative ftc / theta (downstream) + real(r8),intent(in) :: dftc_dpsi_up ! derivative ftc / theta (upstream) + ! of FTC wrt relative water content + real(r8),intent(out) :: dk_dpsi_dn ! change in effective conductance from the + ! downstream pressure node + real(r8),intent(out) :: dk_dpsi_up ! change in effective conductance from the + ! upstream pressure node + real(r8),intent(out) :: k_eff ! effective conductance over path [kg s-1 Mpa-1] + + ! Locals + real(r8) :: h_diff ! Total potential difference [MPa] + ! the effective fraction of total + ! conductivity is either governed + ! by the upstream node, or by both + ! with a harmonic average + real(r8) :: ftc_dnx ! frac total cond (downstream) [-] (local copy) + real(r8) :: ftc_upx ! frac total cond (upstream) [-] (local copy) + real(r8) :: dftc_dpsi_dnx ! derivative ftc / theta (downstream) (local copy) + real(r8) :: dftc_dpsi_upx ! derivative ftc / theta (upstream) (local copy) + + + + ! We use the local copies of the FTC in our calculations + ! because we don't want to over-write the global values. This prevents + ! us from overwriting FTC on nodes that have more than one connection + + ftc_dnx = ftc_dn + ftc_upx = ftc_up + dftc_dpsi_dnx = dftc_dpsi_dn + dftc_dpsi_upx = dftc_dpsi_up + + ! Calculate difference in total potential over the path [MPa] + + h_diff = h_up - h_dn + + ! If we do enable "upstream K", then we are saying that + ! the fractional loss of conductivity is dictated + ! by the upstream side of the flow. In this case, + ! the change in ftc is only non-zero on that side, and is + ! zero'd otherwise. + + if(do_upstream_k) then + + if (h_diff>0._r8) then + ftc_dnx = ftc_up + dftc_dpsi_dnx = 0._r8 + else + ftc_upx = ftc_dn + dftc_dpsi_upx = 0._r8 + end if - ! ===================================================================================== + end if - subroutine shellGeom(l_aroot, rs1, area_site, dz, r_out_shell, r_node_shell, v_shell) - ! - ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. - ! As fine root biomass (and thus absorbing root length) increases, this characteristic - ! rhizosphere shrinks even though the total volume of soil surrounding fine roots remains - ! the same. - ! - ! !USES: + ! Calculate total effective conductance over path [kg s-1 MPa-1] + k_eff = 1._r8/(1._r8/(ftc_upx*kmax_up)+1._r8/(ftc_dnx*kmax_dn)) - ! - ! !ARGUMENTS: - real(r8) , intent(in) :: l_aroot ! Total length of absorbing roots - ! for the whole site, this layer (m) - real(r8) , intent(in) :: rs1 ! Fine root radius (m) - real(r8) , intent(in) :: area_site ! Area of site (10,000 m2) - real(r8) , intent(in) :: dz ! Width of current soil layer (m) - real(r8) , intent(out) :: r_out_shell(:) ! Outer radius of each shell (m) - real(r8) , intent(out) :: r_node_shell(:) ! Radius of the shell's midpoint - real(r8) , intent(out) :: v_shell(:) ! volume of the rhizosphere shells (m3/ha) - ! for this layer - ! - ! !LOCAL VARIABLES: - integer :: k ! rhizosphere shell indicies - integer :: nshells ! We don't use the global because of unit testing - !----------------------------------------------------------------------- + dk_dpsi_dn = k_eff**2._r8 * kmax_dn**(-1._r8) * ftc_dnx**(-2._r8) * dftc_dpsi_dnx - - nshells = size(r_out_shell,dim=1) - - ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) - r_out_shell(nshells) = (pi_const*l_aroot/(area_site*dz))**(-0.5_r8) ! eqn(8) S98 - if(nshells > 1) then - do k = 1,nshells-1 - r_out_shell(k) = rs1*(r_out_shell(nshells)/rs1)**((real(k,r8))/real(nshells,r8)) ! eqn(7) S98 - enddo - end if - - ! set nodal (midpoint) radii of these shells - ! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level - r_node_shell(1) = 0.5_r8*(rs1 + r_out_shell(1)) - !r_node_shell(1) = 0.5_r8*(r_out_shell(1)) - - do k = 2,nshells - r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) - enddo - - ! update volumes - do k = 1,nshells - if(k == 1) then - v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - rs1**2._r8) - else - v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) - end if - enddo + dk_dpsi_up = k_eff**2._r8 * kmax_up**(-1._r8) * ftc_upx**(-2._r8) * dftc_dpsi_upx - return - end subroutine shellGeom - ! ===================================================================================== + return +end subroutine GetKAndDKDPsi - function xylemtaper(p, dz) result(chi_tapnotap) - ! !ARGUMENTS: - real(r8) , intent(in) :: p ! Taper exponent (see EDPftvar hydr_p_taper) [-] - real(r8) , intent(in) :: dz ! hydraulic distance from petiole to node of interest [m] - ! - ! !LOCAL VARIABLES: - real(r8) :: atap,btap ! scaling exponents for total conductance ~ tree size (ratio of stem radius to terminal twig radius) - real(r8) :: anotap,bnotap ! same as atap, btap, but not acounting for xylem taper (Savage et al. (2010) p = 0) - ! NOTE: these scaling exponents were digitized from Fig 2a of Savage et al. (2010) - ! Savage VM, Bentley LP, Enquist BJ, Sperry JS, Smith DD, Reich PB, von Allmen EI. 2010. - ! Hydraulic trade-offs and space filling enable better predictions of vascular structure - ! and function in plants. Proceedings of the National Academy of Sciences 107(52): 22722-22727. - real(r8) :: lN=0.04_r8 ! petiole length [m] - real(r8) :: little_n=2._r8 ! number of daughter branches per parent branch, assumed constant throughout tree (self-similarity) [-] - real(r8) :: big_n ! number of branching levels (allowed here to take on non-integer values): increases with tree size [-] - real(r8) :: ktap ! hydraulic conductance along the pathway, accounting for xylem taper [kg s-1 MPa-1] - real(r8) :: knotap ! hydraulic conductance along the pathway, not accounting for xylem taper [kg s-1 MPa-1] - real(r8) :: num ! temporary - real(r8) :: den ! temporary - ! - ! !RESULT - real(r8) :: chi_tapnotap ! ratio of total tree conductance accounting for xylem taper to that without, over interval dz - ! - !------------------------------------------------------------------------ - - anotap = 7.19903e-13_r8 - bnotap = 1.326105578_r8 - if (p >= 1.0_r8) then - btap = 2.00586217_r8 - atap = 1.82513E-12_r8 - else if (p >= (1._r8/3._r8) .AND. p < 1._r8) then - btap = 1.854812819_r8 - atap = 6.66908E-13_r8 - else if (p >= (1._r8/6._r8) .AND. p < (1._r8/3._r8)) then - btap = 1.628179741_r8 - atap = 6.58345E-13_r8 - else - btap = bnotap - atap = anotap - end if +subroutine AccumulateMortalityWaterStorage(csite,ccohort,delta_n) - num = 3._r8*log(1._r8 - dz/lN * (1._r8-little_n**(1._r8/3._r8))) - den = log(little_n) - big_n = num/den - 1._r8 - ktap = atap * (little_n**(big_N* btap/2._r8)) - knotap = anotap * (little_n**(big_N*bnotap/2._r8)) - chi_tapnotap = ktap / knotap + ! --------------------------------------------------------------------------- + ! This subroutine accounts for the water bound in plants that have + ! just died. This water is accumulated at the site level for all plants + ! that die. + ! In another routine, this pool is reduced as water vapor flux, and + ! passed to the HLM. + ! --------------------------------------------------------------------------- - return + ! Arguments - end function xylemtaper - - ! ===================================================================================== - - subroutine Hydraulics_Tridiagonal(a, b, c, r, u, ierr) - ! - ! !DESCRIPTION: An abbreviated version of biogeophys/TridiagonalMod.F90 - ! - ! This solves the form: - ! - ! a(i)*u(i-1) + b(i)*u(i) + c(i)*u(i+1) = r(i) - ! - ! It assumed that coefficient a(1) and c(N) DNE as there is - ! no u(0) or u(N-1). - ! - ! !USES: - ! - ! !ARGUMENTS - real(r8), intent(in) :: a(:) ! "a" left off diagonal of tridiagonal matrix - real(r8), intent(in) :: b(:) ! "b" diagonal column of tridiagonal matrix - real(r8), intent(in) :: c(:) ! "c" right off diagonal of tridiagonal matrix - real(r8), intent(in) :: r(:) ! "r" forcing term of tridiagonal matrix - real(r8), intent(out) :: u(:) ! solution - integer, intent(out) :: ierr ! flag: 0=passed, 1=failed - ! - ! !LOCAL VARIABLES: - real(r8) :: bet ! temporary - real(r8) :: gam(10) ! temporary - integer :: k ! index - integer :: N ! Size of the matrix - real(r8) :: err ! solution error, in units of [m3/m3] - real(r8) :: rel_err ! relative error, normalized by delta theta - real(r8), parameter :: allowable_rel_err = 0.0001_r8 - - !---------------------------------------------------------------------- - N=size(r,dim=1) - bet = b(1) - do k=1,N - if(k == 1) then - u(k) = r(k) / bet - else - gam(k) = c(k-1) / bet - bet = b(k) - a(k) * gam(k) - u(k) = (r(k) - a(k)*u(k-1)) / bet - end if - enddo + type(ed_site_type), intent(inout), target :: csite + type(ed_cohort_type) , intent(inout), target :: ccohort + real(r8), intent(in) :: delta_n ! Loss in number density + ! for this cohort /ha/day - do k=N-1,1,-1 - u(k) = u(k) - gam(k+1) * u(k+1) - enddo + real(r8) :: delta_w !water change due to mortality Kg/m2 + ! Locals + type(ed_site_hydr_type), pointer :: csite_hydr + type(ed_cohort_hydr_type), pointer :: ccohort_hydr - ! If debug mode, calculate error on the forward solution - ierr = 0 - if(debug)then - do k=1,N - if(k==1)then - err = abs(r(k) - (b(k)*u(k)+c(k)*u(k+1))) - elseif(knearzero)then - rel_err = abs(err/u(k)) - if( ((rel_err > allowable_rel_err) .and. (err > max_wb_step_err)) .or. & - (err /= err) )then - write(fates_log(),*) 'Tri-diagonal solve produced solution with' - write(fates_log(),*) 'non-negligable error.' - write(fates_log(),*) 'Compartment: ',k - write(fates_log(),*) 'Error in forward solution: ',err - write(fates_log(),*) 'Estimated delta theta: ',u(k) - write(fates_log(),*) 'Rel Error: ',rel_err - write(fates_log(),*) 'Reducing time-step' - ierr = 1 - end if - end if - end do - end if + ccohort_hydr => ccohort%co_hydr + csite_hydr => csite%si_hydr + delta_w = (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & + ccohort_hydr%th_troot*ccohort_hydr%v_troot + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + denh2o*delta_n*AREA_INV - end subroutine Hydraulics_Tridiagonal + csite_hydr%h2oveg_dead = csite_hydr%h2oveg_dead + delta_w - ! ===================================================================================== - subroutine MatSolve2D(bc_in,site_hydr,cohort,cohort_hydr, & - tmx,qtop, & - sapflow,rootuptake,wb_err_plant , dwat_plant, & - dth_layershell_site) - - - ! --------------------------------------------------------------------------------- - ! This solution to the plant water flux equations casts all the fluxes through a - ! cohort, and the rhizosphere shells in ALL layers as a single system of equations. - ! If thinking of the plant's above ground components as one dimension, and the soil - ! layers as another, this is a somewhat 2D system (hence "Matrix" in the name). - ! To improve the quality of the solution and reduce solver error, this also - ! uses a Newton iteration. See technical documentation for a full derivation - ! of the mathematics. However, in brief, we can describe the flux balance through - ! any node, considering flux paths labeled j, through that node in set J. - ! This is an implicit solve, so we balance the change in water mass (defined by - ! volume V, density rho, and water content theta) with the flux (q) esitmated - ! at the next time-step q^(t+1). Note that we continue to solve this equation, using - ! updated values of water content and pressure (psi), by balancing our fluxes with - ! the total of previous (theta_p) and remaining (theta_r) water contents. - ! - ! rho V rho V - ! ----- Del theta_p + ----- Del theta_r = Sum ( q^(t+1) ) - ! Del t Del t J - ! - ! The flux at t+1, is simply the current flux (q) and a first order Taylor - ! expanion (i.e. forward-euler) estimate with the current derivative based - ! on the current value of theta and psi. - ! Note also, that the solution is in terms of the matric potential, psi. This - ! conversion from theta to psi, requires this derivative (Jacobian) to also - ! contain not just the rate of change of flux wrt psi, but the change in theta - ! wrt psi (self term, no cross node terms). - ! - ! ----------------------------------------------------------------------------------- + csite_hydr%h2oveg = csite_hydr%h2oveg - delta_w - - ! ARGUMENTS: - ! ----------------------------------------------------------------------------------- - type(bc_in_type),intent(in) :: bc_in - type(ed_site_hydr_type), intent(inout),target :: site_hydr ! ED site_hydr structure - type(ed_cohort_hydr_type), target :: cohort_hydr - type(ed_cohort_type) , intent(inout), target :: cohort - real(r8),intent(in) :: tmx ! time interval to integrate over [s] - real(r8),intent(in) :: qtop - real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] - real(r8),intent(out) :: rootuptake(:) ! time integrated mass flux between rhizosphere and aroot [kg] - - - real(r8),intent(out) :: wb_err_plant ! total error over plant, transpiration - ! should match change in storage [kg/m2] - real(r8),intent(out) :: dwat_plant ! total change in water mass for the plant [kg] - real(r8),intent(inout) :: dth_layershell_site(:,:) - - integer :: nsteps ! Number of rounds of attempts we have made - integer :: i ! generic index (sometimes node index) - integer :: inode ! node index - integer :: k ! generic node index - integer :: j_bc ! layer of bc - integer :: j, icnx ! soil layer and connection indices - integer :: id_dn, id_up ! Node indices on each side of flux path - integer :: ishell ! rhizosphere shell index - - integer :: icnv ! Convergence flag for each solve, see flag definitions - ! below. - - real(r8) :: aroot_frac_plant ! Fraction of rhizosphere this plant "owns" - - real(r8) :: dqflx_dpsi_dn ! Derivative, change in mass flux per change - ! in matric potential of the down-stream node - ! [kg s-1 Mpa-1] - - real(r8) :: dqflx_dpsi_up ! Derivative, change in mass flux per change - ! in matric potential of the up-stream node - ! [kg s-1 Mpa-1] - - real(r8) :: dk_dpsi_dn ! change in effective conductance from the - ! downstream pressure node - real(r8) :: dk_dpsi_up ! change in effective conductance from the - ! upstream pressure node - - real(r8) :: residual_amax ! maximum absolute mass balance residual over all - ! nodes, - ! used for determining convergence. At the point - - real(r8) :: rsdx ! Temporary residual while determining max value - - - real(r8) :: rlfx_soil ! Pressure update reduction factor for soil compartments - real(r8) :: rlfx_plnt ! Pressure update reduction factor for plant comparmtents - real(r8) :: rlfx_soil0 ! Base relaxation factor for the current iteration round - real(r8) :: rlfx_plnt0 ! "" - - real(r8) :: tm ! Total time integrated after each substep [s] - real(r8) :: dtime ! Total time to be integrated this step [s] - real(r8) :: w_tot_beg ! total plant water prior to solve [kg] - real(r8) :: w_tot_end ! total plant water at end of solve [kg] - logical :: continue_search - real(r8) :: k_eff ! Effective conductivity over the current pathway - ! between two nodes. Factors in fractional - ! loss of conductivity on each side of the pathway, and the material maximum - ! conductivity on each side [kg/s/MPa] - integer :: icnx_ar ! Connection index of the aroot <-> rhizosphere shell - - integer :: nsd ! node index of highest residual - integer :: nwtn_iter ! number of (Newton) iterations on each substep + return +end subroutine AccumulateMortalityWaterStorage - ! to get a succesfull Newton solve. - integer :: kshell ! rhizosphere shell index, 1->nshell - - integer :: info - integer :: nstep !number of time steps +!-------------------------------------------------------------------------------! +subroutine RecruitWaterStorage(nsites,sites,bc_out) - ! This is a convergence test. This is the maximum difference - ! allowed between the flux balance and the change in storage - ! on a node. [kg/s] *Note, 1.e-9 = 1 ug/s - real(r8), parameter :: max_allowed_residual = 1.e-8_r8 + ! --------------------------------------------------------------------------- + ! This subroutine accounts for the water bound in plants that have + ! just recruited. This water is accumulated at the site level for all plants + ! that recruit. + ! *Note that no mass is moved in this call, this routine is only for + ! generating diagnostics. Water fluxes will be calculated during + ! again during RecruitWUptake() the next time the hydraulics routine is run, + ! and water will be removed from the soil to accomodate. + ! --------------------------------------------------------------------------- + + ! Arguments + integer, intent(in) :: nsites + type(ed_site_type), intent(inout), target :: sites(nsites) + type(bc_out_type), intent(inout) :: bc_out(nsites) + + ! Locals + type(ed_cohort_type), pointer :: currentCohort + type(ed_patch_type), pointer :: currentPatch + type(ed_cohort_hydr_type), pointer :: ccohort_hydr + type(ed_site_hydr_type), pointer :: csite_hydr + integer :: s + + if( hlm_use_planthydro.eq.ifalse ) return + + do s = 1,nsites + + csite_hydr => sites(s)%si_hydr + csite_hydr%h2oveg_recruit = 0.0_r8 + currentPatch => sites(s)%oldest_patch + do while(associated(currentPatch)) + currentCohort=>currentPatch%tallest + do while(associated(currentCohort)) + ccohort_hydr => currentCohort%co_hydr + if(ccohort_hydr%is_newly_recruited) then + csite_hydr%h2oveg_recruit = csite_hydr%h2oveg_recruit + & + (sum(ccohort_hydr%th_ag(:)*ccohort_hydr%v_ag(:)) + & + ccohort_hydr%th_troot*ccohort_hydr%v_troot + & + sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)))* & + denh2o*currentCohort%n + end if + currentCohort => currentCohort%shorter + enddo !cohort + currentPatch => currentPatch%younger + enddo !end patch loop - ! Maximum number of times we re-try a round of Newton - ! iterations, each time decreasing the time-step and - ! potentially reducing relaxation factors - integer, parameter :: max_newton_rounds = 10 - - ! dtime will shrink at the following rate (halving) [s]: - ! 1800,900,450,225,112.5,56.25,28.125,14.0625,7.03125,3.515625, - ! 1.7578125,0.87890625,0.439453125,0.2197265625,0.10986328125, - ! 0.054931640625,0.0274658203125,0.01373291015625,0.006866455078125, - ! 0.0034332275390625,0.00171661376953125, + csite_hydr%h2oveg_recruit = csite_hydr%h2oveg_recruit * AREA_INV + end do - ! Maximum number of Newton iterations in each round - integer, parameter :: max_newton_iter = 100 + return +end subroutine RecruitWaterStorage - ! Flag definitions for convergence flag (icnv) - ! icnv = 1 fail the round due to either wacky math, or - ! too many Newton iterations - ! icnv = 2 continue onto next iteration, - ! icnv = 3 acceptable solution +! ===================================================================================== - - integer, parameter :: icnv_fail_round = 1 - integer, parameter :: icnv_pass_round = 2 +! ===================================================================================== +! Utility Functions +! ===================================================================================== - ! Timestep reduction factor when a round of - ! newton iterations fail. - - real(r8), parameter :: dtime_rf = 0.5_r8 - - ! These are the initial relaxation factors at the beginning - ! of the large time-step. These may or may not shrink on - ! subsequent rounds, and may or may not grow over subsequent - ! iterations within rounds - real(r8), parameter :: rlfx_soil_init = 1.0 ! Initial Pressure update - ! reduction factor for soil compartments - real(r8), parameter :: rlfx_plnt_init = 1.0 ! Initial Pressure update - ! reduction factor for plant comparmtents - real(r8), parameter :: dpsi_scap = 0.2 ! Changes in psi (for soil) larger than this - ! will be subject to a capping routine - real(r8), parameter :: dpsi_pcap = 0.3 ! Change sin psi (for plants) larger than this - ! will be subject to a capping routine - real(r8), parameter :: rlfx_plnt_shrink = 1.0 ! Shrink the starting plant relaxtion factor - ! by this multipliler each round - real(r8), parameter :: rlfx_soil_shrink = 1.0 ! Shrink the starting soil relaxtion factor - ! by this multipliler each round - logical, parameter :: reset_on_fail = .false. ! If a round of Newton iterations is unable - ! to find a solution, you can either reset - ! to the beginning of the large timestep (true), or - ! to the beginning of the current substep (false) - - logical, parameter :: allow_lenient_lastiter = .true. ! If this is true, when the newton iteration - ! reaches its last allowed attempt, the - ! error tolerance will be increased (the bar lowered) by 10x +subroutine MaximumRootingDepth(dbh,ft,z_max_soil,z_fr) - - - associate(conn_up => site_hydr%conn_up, & - conn_dn => site_hydr%conn_dn, & - kmax_up => site_hydr%kmax_up, & - kmax_dn => site_hydr%kmax_dn, & - q_flux => site_hydr%q_flux, & - residual => site_hydr%residual, & - ajac => site_hydr%ajac, & - ipiv => site_hydr%ipiv, & - th_node => site_hydr%th_node, & - th_node_prev => site_hydr%th_node_prev, & - th_node_init => site_hydr%th_node_init, & - psi_node => site_hydr%psi_node, & - pm_node => site_hydr%pm_node, & - ftc_node => site_hydr%ftc_node, & - z_node => site_hydr%z_node, & - v_node => site_hydr%v_node, & - dth_node => site_hydr%dth_node, & - node_layer => site_hydr%node_layer, & - h_node => site_hydr%h_node, & - dftc_dpsi_node => site_hydr%dftc_dpsi_node, & - ft => cohort%pft) - - - !for debug only - nstep = get_nstep() - + ! --------------------------------------------------------------------------------- + ! Calculate the maximum rooting depth of the plant. + ! + ! This is an exponential which is constrained by the maximum soil depth: + ! csite_hydr%zi_rhiz(nlevrhiz) + ! The dynamic root growth model by Junyan Ding, June 9, 2021 + ! --------------------------------------------------------------------------------- - ! This NaN's the scratch arrays - call site_hydr%FlushSiteScratch() + real(r8),intent(in) :: dbh ! Plant dbh + integer,intent(in) :: ft ! Funtional type index + real(r8),intent(in) :: z_max_soil ! Maximum depth of soil (pos convention) [m] + real(r8),intent(out) :: z_fr ! Maximum depth of plant's roots + ! (pos convention) [m] - ! This is the maximum number of iterations needed for this cohort - ! (each soil layer has a different number, this saves the max) - cohort_hydr%iterh1 = 0 - cohort_hydr%iterh2 = 0 + real(r8) :: dbh_rel ! Relative dbh of plant between the diameter at which we + ! define the shallowest rooting depth (dbh_0) and the diameter + ! at which we define the deepest rooting depth (dbh_max) - ! These are output fluxes from the subroutine, total integrated - ! mass fluxes [kg] over the time-step. sapflow is the integrated - ! flux between the transporting root and the 1st stem compartment. - ! The rootuptake is the integrated flux between the 1st rhizosphere - ! and absorbing roots - sapflow = 0._r8 - rootuptake(:) = 0._r8 + associate( & + dbh_max => prt_params%allom_zroot_max_dbh(ft), & + dbh_0 => prt_params%allom_zroot_min_dbh(ft), & + z_fr_max => prt_params%allom_zroot_max_z(ft), & + z_fr_0 => prt_params%allom_zroot_min_z(ft), & + frk => prt_params%allom_zroot_k(ft)) - ! Chnage in water content, over all substeps [m3/m3] - dth_node(:) = 0._r8 - - ! Transfer node heights, volumes and initial water contents for - ! the transporting root and above ground compartments to the - ! complete node vector - - do i = 1,n_hypool_ag+n_hypool_troot - if (i<=n_hypool_ag) then - z_node(i) = cohort_hydr%z_node_ag(i) - v_node(i) = cohort_hydr%v_ag(i) - th_node_init(i) = cohort_hydr%th_ag(i) - elseif (i>n_hypool_ag) then - z_node(i) = cohort_hydr%z_node_troot - v_node(i) = cohort_hydr%v_troot - th_node_init(i) = cohort_hydr%th_troot + dbh_rel = min(1._r8,(max(dbh,dbh_0) - dbh_0)/(dbh_max - dbh_0)) + + z_fr = min(z_max_soil, z_fr_max/(1._r8 + ((z_fr_max-z_fr_0)/z_fr_0)*exp(-frk*dbh_rel))) + + end associate + return +end subroutine MaximumRootingDepth + + +subroutine bisect_rootfr(a, b, z_max, lower_init, upper_init, xtol, ytol, crootfr, x_new) + ! + ! !DESCRIPTION: Bisection routine for getting the inverse of the cumulative root + ! distribution. No analytical soln bc crootfr ~ exp(ax) + exp(bx). + ! + ! !USES: + ! + ! !ARGUMENTS + real(r8) , intent(in) :: a, b ! pft root distribution constants + real(r8) , intent(in) :: z_max ! maximum rooting depth + real(r8) , intent(in) :: lower_init ! lower bound of initial x estimate [m] + real(r8) , intent(in) :: upper_init ! upper bound of initial x estimate [m] + real(r8) , intent(in) :: xtol ! error tolerance for x_new [m] + real(r8) , intent(in) :: ytol ! error tolerance for crootfr [-] + real(r8) , intent(in) :: crootfr ! cumulative root fraction at x_new [-] + real(r8) , intent(out) :: x_new ! soil depth [m] + ! + ! !LOCAL VARIABLES: + real(r8) :: lower ! lower bound x estimate [m] + real(r8) :: upper ! upper bound x estimate [m] + real(r8) :: y_lo ! corresponding y value at lower + real(r8) :: f_lo ! y difference between lower bound guess and target y + real(r8) :: y_hi ! corresponding y value at upper + real(r8) :: f_hi ! y difference between upper bound guess and target y + real(r8) :: y_new ! corresponding y value at x.new + real(r8) :: f_new ! y difference between new y guess at x.new and target y + real(r8) :: chg ! difference between x upper and lower bounds (approach 0 in bisection) + integer :: nitr ! number of iterations + !---------------------------------------------------------------------- + + lower = lower_init + upper = upper_init + f_lo = zeng2001_crootfr(a, b, lower, z_max) - crootfr + f_hi = zeng2001_crootfr(a, b, upper, z_max) - crootfr + chg = upper - lower + nitr = 0 + do while(abs(chg) .gt. xtol) + x_new = 0.5_r8*(lower + upper) + f_new = zeng2001_crootfr(a, b, x_new, z_max) - crootfr + if(abs(f_new) .le. ytol) then + EXIT + end if + if((f_lo * f_new) .lt. 0._r8) upper = x_new + if((f_hi * f_new) .lt. 0._r8) lower = x_new + chg = upper - lower + nitr = nitr + 1 + end do + if(nitr> 100)then + write(fates_log(),*)'Warning: number of iteraction exceeds 100 for bisect_rootfr' + endif +end subroutine bisect_rootfr + +! ===================================================================================== + +function zeng2001_crootfr(a, b, z, z_max) result(crootfr) + + ! !ARGUMENTS: + real(r8) , intent(in) :: a,b ! pft parameters + real(r8) , intent(in) :: z ! soil depth (m) + real(r8) , intent(in), optional :: z_max ! max soil depth (m) + ! + real(r8) :: crootfr_max + + ! !RESULT + real(r8) :: crootfr ! cumulative root fraction + ! + !------------------------------------------------------------------------ + crootfr = 1._r8 - .5_r8*(exp(-a*z) + exp(-b*z)) + + + ! If a maximum rooting depth is provided, then + ! we force everything to sum to unity. We do this by + ! simply dividing through by the maximum possible + ! root fraction. + + if(present(z_max))then + ! If the soil depth is larger than the maximum rooting depth of the cohort, + ! then the cumulative root fraction of that layer equals that of the maximum rooting depth + crootfr = 1._r8 - .5_r8*(exp(-a*min(z,z_max)) + exp(-b*min(z,z_max))) + crootfr_max = 1._r8 - .5_r8*(exp(-a*z_max) + exp(-b*z_max)) + crootfr = crootfr/crootfr_max + end if + + if(debug)then + if(present(z_max))then + if((crootfr_max1.0_r8) )then + write(fates_log(),*) 'problem scaling crootfr in zeng2001' + write(fates_log(),*) 'z_max: ',z_max + write(fates_log(),*) 'crootfr_max: ',crootfr_max end if - end do - - ! Transfer node-heights, volumes and intiial water contents - ! for below-ground components, - ! from the cohort structures, into the complete node vector - i = n_hypool_ag + n_hypool_troot - - do j = 1,site_hydr%nlevrhiz - - ! Calculate the fraction of the soil layer - ! folume that this plant's rhizosphere accounts forPath is across the upper an lower rhizosphere comparment - ! on each side of the nodes. Since there is no flow across the outer - ! node to the edge, we ignore that last half compartment - aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) - - do k = 1, n_hypool_aroot + nshell - i = i + 1 - if (k==1) then - z_node(i) = -site_hydr%zi_rhiz(j) - v_node(i) = cohort_hydr%v_aroot_layer(j) - th_node_init(i) = cohort_hydr%th_aroot(j) - else - kshell = k-1 - z_node(i) = -site_hydr%zi_rhiz(j) - ! The volume of the Rhizosphere for a single plant - v_node(i) = site_hydr%v_shell(j,kshell)*aroot_frac_plant - th_node_init(i) = site_hydr%h2osoi_liqvol_shell(j,kshell) - end if - enddo + end if + end if - enddo + return - ! Total water mass in the plant at the beginning of this solve [kg h2o] - w_tot_beg = sum(th_node_init(:)*v_node(:))*denh2o +end function zeng2001_crootfr - - ! Initialize variables and flags that track - ! the progress of the solve - - tm = 0 - nsteps = 0 - th_node_prev(:) = th_node_init(:) - th_node(:) = th_node_init(:) - dtime = tmx - rlfx_plnt0 = rlfx_plnt_init - rlfx_soil0 = rlfx_soil_init - rlfx_plnt = rlfx_plnt0 - rlfx_soil = rlfx_soil0 - - outerloop: do while( tm < tmx ) - - ! The solve may reduce the time-step, the shorter - ! time-steps may not be perfectly divisible into - ! the remaining time. If so, then make sure we - ! don't overshoot - - dtime = min(dtime,tmx-tm) - - ! Advance time forward - tm = tm + dtime - ! If we have not exceeded our max number - ! of retrying rounds of Newton iterations, reduce - ! time and try a new round - - if( nsteps > max_newton_rounds ) then - - ! Complete failure to converge even with re-trying - ! iterations with smaller timesteps - - write(fates_log(),*) 'Newton hydraulics solve' - write(fates_log(),*) 'could not converge on a solution.' - write(fates_log(),*) 'Perhaps try increasing iteration cap,' - write(fates_log(),*) 'and decreasing relaxation factors.' - write(fates_log(),*) 'pft: ',ft,' dbh: ',cohort%dbh - call endrun(msg=errMsg(sourcefile, __LINE__)) - - endif +! ===================================================================================== +subroutine shellGeom(l_aroot_in, rs1_in, area_site, dz, r_out_shell, r_node_shell, v_shell) + ! + ! !DESCRIPTION: Updates size of 'representative' rhizosphere -- node radii, volumes. + ! As fine root biomass (and thus absorbing root length) increases, this characteristic + ! rhizosphere shrinks even though the total volume of soil surrounding fine roots remains + ! the same. + ! + ! !USES: - ! This is the newton search loop + ! + ! !ARGUMENTS: + real(r8) , intent(in) :: l_aroot_in ! Total length of absorbing roots + ! for the whole site, this layer (m) + real(r8) , intent(in) :: rs1_in ! Fine root radius (m) + real(r8) , intent(in) :: area_site ! Area of site (10,000 m2) + real(r8) , intent(in) :: dz ! Width of current soil layer (m) + real(r8) , intent(out) :: r_out_shell(:) ! Outer radius of each shell (m) + real(r8) , intent(out) :: r_node_shell(:) ! Radius of the shell's midpoint + real(r8) , intent(out) :: v_shell(:) ! volume of the rhizosphere shells (m3/ha) + ! for this layer + ! + ! !LOCAL VARIABLES: + real(r8) :: l_aroot ! effective length of absorbing root (m/layer) + real(r8) :: rs1 ! effective fine root ratius (m) + integer :: k ! rhizosphere shell indicies + integer :: nshells ! We don't use the global because of unit testing - continue_search = .true. - nwtn_iter = 0 - newtonloop: do while(continue_search) + + ! When we have no roots, we may choose to use a nominal + ! value of 1cm per cubic meter to define the rhizosphere shells + ! this "should" help with the transition when roots grow into a layer + ! real(r8), parameter :: nominal_l_aroot = 0.01_r8 ! m/m3 - nwtn_iter = nwtn_iter + 1 + + !----------------------------------------------------------------------- - ! The Jacobian and the residual are incremented, - ! and the Jacobian is sparse, thus they both need - ! to be zerod. - ajac(:,:) = 0._r8 - residual(:) = 0._r8 - - do k=1,site_hydr%num_nodes - - ! This is the storage gained from previous newton iterations. - residual(k) = residual(k) + denh2o*v_node(k)*(th_node(k) - th_node_prev(k))/dtime - - if(pm_node(k) == rhiz_p_media) then - - j = node_layer(k) - psi_node(k) = site_hydr%wrf_soil(j)%p%psi_from_th(th_node(k)) - - ! Get total potential [Mpa] - h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) - ! Get Fraction of Total Conductivity [-] - ftc_node(k) = site_hydr%wkf_soil(j)%p%ftc_from_psi(psi_node(k)) - ! deriv ftc wrt psi - dftc_dpsi_node(k) = site_hydr%wkf_soil(j)%p%dftcdpsi_from_psi(psi_node(k)) - - else - - psi_node(k) = wrf_plant(pm_node(k),ft)%p%psi_from_th(th_node(k)) - ! Get total potential [Mpa] - h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) - ! Get Fraction of Total Conductivity [-] - ftc_node(k) = wkf_plant(pm_node(k),ft)%p%ftc_from_psi(psi_node(k)) - ! deriv ftc wrt psi - dftc_dpsi_node(k) = wkf_plant(pm_node(k),ft)%p%dftcdpsi_from_psi(psi_node(k)) - - end if - - ! Fill the self-term on the Jacobian's diagonal with the - ! the change in storage wrt change in psi. - - if(pm_node(k) == rhiz_p_media) then - j = node_layer(k) - ajac(k,k) = -denh2o*v_node(k)/(site_hydr%wrf_soil(j)%p%dpsidth_from_th(th_node(k))*dtime) - else - ajac(k,k) = -denh2o*v_node(k)/(wrf_plant(pm_node(k),ft)%p%dpsidth_from_th(th_node(k))*dtime) - endif - - enddo - - ! Calculations of maximum conductance for upstream and downstream sides - ! of each connection. This IS dependant on total potential h_node - ! because of the root-soil radial conductance. - - call SetMaxCondConnections(site_hydr, cohort_hydr, h_node, kmax_dn, kmax_up) - - ! calculate boundary fluxes - do icnx=1,site_hydr%num_connections - - id_dn = conn_dn(icnx) - id_up = conn_up(icnx) - - ! The row (first index) of the Jacobian (ajac) represents the - ! the node for which we are calculating the water balance - ! The column (second index) of the Jacobian represents the nodes - ! on which the pressure differentials effect the water balance - ! of the node of the first index. - ! This will get the effective K, and may modify FTC depending - ! on the flow direction - - call GetKAndDKDPsi(kmax_dn(icnx), & - kmax_up(icnx), & - h_node(id_dn), & - h_node(id_up), & - ftc_node(id_dn), & - ftc_node(id_up), & - dftc_dpsi_node(id_dn), & - dftc_dpsi_node(id_up), & - dk_dpsi_dn, & - dk_dpsi_up, & - k_eff) - - q_flux(icnx) = k_eff*(h_node(id_up)-h_node(id_dn)) - - ! See equation (22) in technical documentation - ! Add fluxes at current time to the residual - residual(id_dn) = residual(id_dn) - q_flux(icnx) - residual(id_up) = residual(id_up) + q_flux(icnx) - - ! This is the Jacobian term related to the pressure changes on the down-stream side - ! and these are applied to both the up and downstream sides (oppositely) - ! This should be used for the down-stream on thr second index) - dqflx_dpsi_dn = -k_eff + (h_node(id_up)-h_node(id_dn)) * dk_dpsi_dn - - ! This is the Jacobian term related to the pressure changes on the up-stream side - ! and these are applied to both the up and downstream sides (oppositely) - dqflx_dpsi_up = k_eff + (h_node(id_up)-h_node(id_dn)) * dk_dpsi_up - - ! Down-stream node's contribution to the down-stream node's mass balance - ajac(id_dn,id_dn) = ajac(id_dn,id_dn) + dqflx_dpsi_dn - - ! Down-stream node's contribution to the up-stream node's mass balance - ajac(id_up,id_dn) = ajac(id_up,id_dn) - dqflx_dpsi_dn - - ! Up-stream node's contribution to the down-stream node's mass balance - ajac(id_dn,id_up) = ajac(id_dn,id_up) + dqflx_dpsi_up - - ! Up-stream node's contribution to the up-stream node's mass balance - ajac(id_up,id_up) = ajac(id_up,id_up) - dqflx_dpsi_up + nshells = size(r_out_shell,dim=1) + + if( l_aroot_in <= nearzero ) then + + ! Generate some nominal values for cases where we have no roots + ! The rational for this is to maintain shells and water contents in those + ! shells similar to what will be experienced when roots start to emerge + ! in these layers, so there will not be a shock to the system + ! Note! All root radii are currently the fine_root_radius const anyway (RGK 10-2021) + ! rs1 = fine_root_radius_const + ! l_aroot = nominal_l_aroot*dz + + r_out_shell(:) = 0._r8 + r_node_shell(:) = 0._r8 + v_shell(:) = 0._r8 + return + + else + rs1 = rs1_in + l_aroot = l_aroot_in + end if + + ! update outer radii of column-level rhizosphere shells (same across patches and cohorts) + r_out_shell(nshells) = (pi_const*l_aroot/(area_site*dz))**(-0.5_r8) ! eqn(8) S98 + if(nshells > 1) then + do k = 1,nshells-1 + r_out_shell(k) = rs1*(r_out_shell(nshells)/rs1)**((real(k,r8))/real(nshells,r8)) ! eqn(7) S98 + enddo + end if + + ! set nodal (midpoint) radii of these shells + ! BOC...not doing this as it requires PFT-specific fine root thickness, but this is at column level + r_node_shell(1) = 0.5_r8*(rs1 + r_out_shell(1)) + !r_node_shell(1) = 0.5_r8*(r_out_shell(1)) + + do k = 2,nshells + r_node_shell(k) = 0.5_r8*(r_out_shell(k-1) + r_out_shell(k)) + enddo + + ! update volumes + do k = 1,nshells + if(k == 1) then + v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - rs1**2._r8) + else + v_shell(k) = pi_const*l_aroot*(r_out_shell(k)**2._r8 - r_out_shell(k-1)**2._r8) + end if + enddo + + return +end subroutine shellGeom + +! ===================================================================================== + +function xylemtaper(p, dz) result(chi_tapnotap) + + ! !ARGUMENTS: + real(r8) , intent(in) :: p ! Savage et al. (2010) taper exponent + real(r8) , intent(in) :: dz ! hydraulic distance from petiole to node of interest [m] + ! + ! !LOCAL VARIABLES: + real(r8) :: atap,btap ! scaling exponents for total conductance ~ tree size (ratio of stem radius to terminal twig radius) + real(r8) :: anotap,bnotap ! same as atap, btap, but not acounting for xylem taper (Savage et al. (2010) p = 0) + ! NOTE: these scaling exponents were digitized from Fig 2a of Savage et al. (2010) + ! Savage VM, Bentley LP, Enquist BJ, Sperry JS, Smith DD, Reich PB, von Allmen EI. 2010. + ! Hydraulic trade-offs and space filling enable better predictions of vascular structure + ! and function in plants. Proceedings of the National Academy of Sciences 107(52): 22722-22727. + real(r8) :: lN=0.04_r8 ! petiole length [m] + real(r8) :: little_n=2._r8 ! number of daughter branches per parent branch, assumed constant throughout tree (self-similarity) [-] + real(r8) :: big_n ! number of branching levels (allowed here to take on non-integer values): increases with tree size [-] + real(r8) :: ktap ! hydraulic conductance along the pathway, accounting for xylem taper [kg s-1 MPa-1] + real(r8) :: knotap ! hydraulic conductance along the pathway, not accounting for xylem taper [kg s-1 MPa-1] + real(r8) :: num ! temporary + real(r8) :: den ! temporary + ! + ! !RESULT + real(r8) :: chi_tapnotap ! ratio of total tree conductance accounting for xylem taper to that without, over interval dz + ! + !------------------------------------------------------------------------ + + anotap = 7.19903e-13_r8 + bnotap = 1.326105578_r8 + if (p >= 1.0_r8) then + btap = 2.00586217_r8 + atap = 1.82513E-12_r8 + else if (p >= (1._r8/3._r8) .AND. p < 1._r8) then + btap = 1.854812819_r8 + atap = 6.66908E-13_r8 + else if (p >= (1._r8/6._r8) .AND. p < (1._r8/3._r8)) then + btap = 1.628179741_r8 + atap = 6.58345E-13_r8 + else + btap = bnotap + atap = anotap + end if + + num = 3._r8*log(1._r8 - dz/lN * (1._r8-little_n**(1._r8/3._r8))) + den = log(little_n) + big_n = num/den - 1._r8 + ktap = atap * (little_n**(big_N* btap/2._r8)) + knotap = anotap * (little_n**(big_N*bnotap/2._r8)) + chi_tapnotap = ktap / knotap + + return + +end function xylemtaper + +! ===================================================================================== + +subroutine Hydraulics_Tridiagonal(a, b, c, r, u, ierr) + ! + ! !DESCRIPTION: An abbreviated version of biogeophys/TridiagonalMod.F90 + ! + ! This solves the form: + ! + ! a(i)*u(i-1) + b(i)*u(i) + c(i)*u(i+1) = r(i) + ! + ! It assumed that coefficient a(1) and c(N) DNE as there is + ! no u(0) or u(N-1). + ! + ! !USES: + ! + ! !ARGUMENTS + real(r8), intent(in) :: a(:) ! "a" left off diagonal of tridiagonal matrix + real(r8), intent(in) :: b(:) ! "b" diagonal column of tridiagonal matrix + real(r8), intent(in) :: c(:) ! "c" right off diagonal of tridiagonal matrix + real(r8), intent(in) :: r(:) ! "r" forcing term of tridiagonal matrix + real(r8), intent(out) :: u(:) ! solution + integer, intent(out) :: ierr ! flag: 0=passed, 1=failed + ! + ! !LOCAL VARIABLES: + real(r8) :: bet ! temporary + real(r8) :: gam(10) ! temporary + integer :: k ! index + integer :: N ! Size of the matrix + real(r8) :: err ! solution error, in units of [m3/m3] + real(r8) :: rel_err ! relative error, normalized by delta theta + real(r8), parameter :: allowable_rel_err = 0.0001_r8 + + !---------------------------------------------------------------------- + N=size(r,dim=1) + bet = b(1) + do k=1,N + if(k == 1) then + u(k) = r(k) / bet + else + gam(k) = c(k-1) / bet + bet = b(k) - a(k) * gam(k) + u(k) = (r(k) - a(k)*u(k-1)) / bet + end if + enddo + + do k=N-1,1,-1 + u(k) = u(k) - gam(k+1) * u(k+1) + enddo + + ! If debug mode, calculate error on the forward solution + ierr = 0 + if(debug)then + do k=1,N + if(k==1)then + err = abs(r(k) - (b(k)*u(k)+c(k)*u(k+1))) + elseif(knearzero)then + rel_err = abs(err/u(k)) + if( ((rel_err > allowable_rel_err) .and. (err > max_wb_step_err)) .or. & + (err /= err) )then + write(fates_log(),*) 'Tri-diagonal solve produced solution with' + write(fates_log(),*) 'non-negligable error.' + write(fates_log(),*) 'Compartment: ',k + write(fates_log(),*) 'Error in forward solution: ',err + write(fates_log(),*) 'Estimated delta theta: ',u(k) + write(fates_log(),*) 'Rel Error: ',rel_err + write(fates_log(),*) 'Reducing time-step' + ierr = 1 + end if + end if + end do + end if + +end subroutine Hydraulics_Tridiagonal + +! ===================================================================================== + +subroutine MatSolve2D(csite_hydr,cohort,cohort_hydr, & + tmx,qtop, & + sapflow,rootuptake,wb_err_plant , dwat_plant, & + dth_layershell_site) + + + ! --------------------------------------------------------------------------------- + ! This solution to the plant water flux equations casts all the fluxes through a + ! cohort, and the rhizosphere shells in ALL layers as a single system of equations. + ! If thinking of the plant's above ground components as one dimension, and the soil + ! layers as another, this is a somewhat 2D system (hence "Matrix" in the name). + ! To improve the quality of the solution and reduce solver error, this also + ! uses a Newton iteration. See technical documentation for a full derivation + ! of the mathematics. However, in brief, we can describe the flux balance through + ! any node, considering flux paths labeled j, through that node in set J. + ! This is an implicit solve, so we balance the change in water mass (defined by + ! volume V, density rho, and water content theta) with the flux (q) esitmated + ! at the next time-step q^(t+1). Note that we continue to solve this equation, using + ! updated values of water content and pressure (psi), by balancing our fluxes with + ! the total of previous (theta_p) and remaining (theta_r) water contents. + ! + ! rho V rho V + ! ----- Del theta_p + ----- Del theta_r = Sum ( q^(t+1) ) + ! Del t Del t J + ! + ! The flux at t+1, is simply the current flux (q) and a first order Taylor + ! expanion (i.e. forward-euler) estimate with the current derivative based + ! on the current value of theta and psi. + ! Note also, that the solution is in terms of the matric potential, psi. This + ! conversion from theta to psi, requires this derivative (Jacobian) to also + ! contain not just the rate of change of flux wrt psi, but the change in theta + ! wrt psi (self term, no cross node terms). + ! + ! ----------------------------------------------------------------------------------- - - enddo - ! Add the transpiration flux (known, retrieved from photosynthesis scheme) - ! to the mass balance on the leaf (1st) node. This is constant over - ! the time-step, so no Jacobian term needed (yet) - - residual(1) = residual(1) + qtop - - - ! Start off assuming things will pass, then find numerous - ! ways to see if it failed - icnv = icnv_pass_round - - - ! If we have performed any Newton iterations, then the residual - ! may reflect a flux that balances (equals) the change in storage. If this is - ! true, then the residual is zero, and we are done with the sub-step. If it is - ! not nearly zero, then we must continue our search and perform another solve. - - residual_amax = 0._r8 - nsd = 0 - do k = 1, site_hydr%num_nodes - rsdx = abs(residual(k)) - ! check NaNs - if( rsdx /= rsdx ) then - icnv = icnv_fail_round - exit - endif - if( rsdx > residual_amax ) then - residual_amax = rsdx - nsd = k - endif - enddo - if ( nwtn_iter > max_newton_iter) then - icnv = icnv_fail_round - write(fates_log(),*) 'Newton hydraulics solve failed',residual_amax,nsd,tm - endif - - ! Three scenarios: - ! 1) the residual is 0, everything is great, leave iteration loop - ! 2) the residual is not 0, but we have not taken too many steps - ! and the matrix solve did not fail. Perform an inversion and keep - ! searching. - ! 3) the residual is not 0, and either - ! we have taken too many newton steps or the solver won't return - ! a real solution. - ! Shorten time-step, reset time to 0, reset relaxation factors - ! and try a new round of newton (if not exceeded) - - - if( icnv == icnv_fail_round ) then - - ! If the newton iteration fails, we go back - ! to restart the time-stepping loop with shorter sub-steps. - ! Therefore, we set the time elapsed (tm) to zero, - ! shorten the timstep (dtime) and re-initialize the water - ! contents to the starting amount. - - if(reset_on_fail) then - tm = 0._r8 - th_node(:) = th_node_init(:) - th_node_prev(:) = th_node_init(:) - cohort_hydr%iterh1 = 0 - else - tm = tm - dtime - th_node(:) = th_node_prev(:) - !* No need to update the th_node_prev, it is the - ! same since we are just re-starting the current - ! step - end if - nsteps = nsteps + 1 - dtime = dtime * dtime_rf - rlfx_plnt0 = rlfx_plnt_init*rlfx_plnt_shrink**real(nsteps,r8) - rlfx_soil0 = rlfx_soil_init*rlfx_soil_shrink**real(nsteps,r8) - rlfx_plnt = rlfx_plnt0 - rlfx_soil = rlfx_soil0 - nwtn_iter = 0 - cohort_hydr%iterh1 = cohort_hydr%iterh1 + 1 - cycle outerloop + ! ARGUMENTS: + ! ----------------------------------------------------------------------------------- + type(ed_site_hydr_type), intent(inout),target :: csite_hydr ! ED csite_hydr structure + type(ed_cohort_hydr_type), target :: cohort_hydr + type(ed_cohort_type) , intent(inout), target :: cohort + real(r8),intent(in) :: tmx ! time interval to integrate over [s] + real(r8),intent(in) :: qtop + real(r8),intent(out) :: sapflow ! time integrated mass flux between transp-root and stem [kg] + real(r8),intent(out) :: rootuptake(:) ! time integrated mass flux between rhizosphere and aroot [kg] - else - ! On the last iteration, we temporarily lower the bar (if opted for) - ! and allow a pass if the residual is within 10x of the typical allowed residual - if ( allow_lenient_lastiter ) then - if ( nwtn_iter == max_newton_iter .and. residual_amax < 10*max_allowed_residual ) then - exit newtonloop - end if - end if - - if( sum(residual(:)) < max_allowed_residual .and. residual_amax < max_allowed_residual ) then - - ! We have succesffully found a solution - ! in this newton iteration. - exit newtonloop - else - ! Move ahead and calculate another solution - ! and continue the search. Residual isn't zero - ! but no reason not to continue searching - - ! Record that we performed a solve (this is total iterations) - cohort_hydr%iterh2 = cohort_hydr%iterh2 + 1 - - ! --------------------------------------------------------------------------- - ! From Lapack documentation - ! - ! subroutine dgesv(integer N (in), - ! integer NRHS (in), - ! real(r8), dimension( lda, * ) A (in/out), - ! integer LDA (in), - ! integer, dimension( * ) IPIV (out), - ! real(r8), dimension( ldb, * ) B (in/out), - ! integer LDB (in), - ! integer INFO (out) ) - ! - ! DGESV computes the solution to a real system of linear equations - ! A * X = B, where A is an N-by-N matrix and X and B are N-by-NRHS matrices. - ! The LU decomposition with partial pivoting and row interchanges is - ! used to factor A as A = P * L * U, - ! where P is a permutation matrix, L is unit lower triangular, and U is - ! upper triangular. The factored form of A is then used to solve the - ! system of equations A * X = B. - ! - ! N is the number of linear equations, i.e., the order of the - ! matrix A. N >= 0. - ! - ! NRHS is the number of right hand sides, i.e., the number of columns - ! of the matrix B. NRHS >= 0. - ! - ! A: - ! On entry, the N-by-N coefficient matrix A. - ! On exit, the factors L and U from the factorization - ! A = P*L*U; the unit diagonal elements of L are not stored. - ! - ! LDA is the leading dimension of the array A. LDA >= max(1,N). - ! - ! IPIV is the pivot indices that define the permutation matrix P; - ! row i of the matrix was interchanged with row IPIV(i). - ! - ! B - ! On entry, the N-by-NRHS matrix of right hand side matrix B. - ! On exit, if INFO = 0, the N-by-NRHS solution matrix X. - ! - ! LDB is the leading dimension of the array B. LDB >= max(1,N). - ! - ! INFO: - ! = 0: successful exit - ! < 0: if INFO = -i, the i-th argument had an illegal value - ! > 0: if INFO = i, U(i,i) is exactly zero. The factorization - ! has been completed, but the factor U is exactly - ! singular, so the solution could not be computed. - ! --------------------------------------------------------------------------- - !cohort_hydr%iterh2 = cohort_hydr%iterh2 - - call DGESV(site_hydr%num_nodes,1,ajac,site_hydr%num_nodes,ipiv,residual,site_hydr%num_nodes,info) - - - if ( info < 0 ) then - write(fates_log(),*) 'illegal value generated in DGESV() linear' - write(fates_log(),*) 'system solver, see node: ',-info - call endrun(msg=errMsg(sourcefile, __LINE__)) - END IF - if ( info > 0 ) then - write(fates_log(),*) 'the factorization of linear system in DGESV() generated' - write(fates_log(),*) 'a singularity at node: ',info - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Update the previous water content state to be the current - ! th_node_prev(:) = th_node(:) - - ! If info == 0, then - ! lapack was able to generate a solution. - ! For A * X = B, - ! Where the residual() was B, DGESV() returns - ! the solution X into the residual array. - - ! Update the matric potential of each node. Since this is a search - ! we update matric potential as only a fraction of delta psi (residual) - - do k = 1, site_hydr%num_nodes - - if(pm_node(k) == rhiz_p_media) then - j = node_layer(k) - if(abs(residual(k)) < dpsi_scap) then - psi_node(k) = psi_node(k) + residual(k) * rlfx_soil - else - psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_scap,residual(k)) - dpsi_scap*dpsi_scap/residual(k) - endif - th_node(k) = site_hydr%wrf_soil(j)%p%th_from_psi(psi_node(k)) - else - if(abs(residual(k)) < dpsi_pcap) then - psi_node(k) = psi_node(k) + residual(k) * rlfx_plnt - else - psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_pcap,residual(k)) - dpsi_pcap*dpsi_pcap/residual(k) - endif - th_node(k) = wrf_plant(pm_node(k),ft)%p%th_from_psi(psi_node(k)) - endif - - enddo - - ! Increase relaxation factors for next iteration - rlfx_plnt = min(1._r8,rlfx_plnt0 + & - (1.0-rlfx_plnt0)*real(nwtn_iter,r8)/real(max_newton_iter-3,r8)) - rlfx_soil = min(1._r8,rlfx_soil0 + & - (1.0-rlfx_soil0)*real(nwtn_iter,r8)/real(max_newton_iter-3,r8)) + real(r8),intent(out) :: wb_err_plant ! total error over plant, transpiration + ! should match change in storage [kg/m2] + real(r8),intent(out) :: dwat_plant ! total change in water mass for the plant [kg] + real(r8),intent(inout) :: dth_layershell_site(:,:) - end if - end if + integer :: nsteps ! Number of rounds of attempts we have made + integer :: i ! generic index (sometimes node index) + integer :: inode ! node index + integer :: k ! generic node index + integer :: j_bc ! layer of bc + integer :: j, icnx ! soil layer and connection indices + integer :: id_dn, id_up ! Node indices on each side of flux path + integer :: ishell ! rhizosphere shell index + + integer :: icnv ! Convergence flag for each solve, see flag definitions + ! below. + + real(r8) :: aroot_frac_plant ! Fraction of rhizosphere this plant "owns" + + real(r8) :: dqflx_dpsi_dn ! Derivative, change in mass flux per change + ! in matric potential of the down-stream node + ! [kg s-1 Mpa-1] + + real(r8) :: dqflx_dpsi_up ! Derivative, change in mass flux per change + ! in matric potential of the up-stream node + ! [kg s-1 Mpa-1] + + real(r8) :: dk_dpsi_dn ! change in effective conductance from the + ! downstream pressure node + real(r8) :: dk_dpsi_up ! change in effective conductance from the + ! upstream pressure node + + real(r8) :: residual_amax ! maximum absolute mass balance residual over all + ! nodes, + ! used for determining convergence. At the point + + real(r8) :: rsdx ! Temporary residual while determining max value + + + real(r8) :: rlfx_soil ! Pressure update reduction factor for soil compartments + real(r8) :: rlfx_plnt ! Pressure update reduction factor for plant comparmtents + real(r8) :: rlfx_soil0 ! Base relaxation factor for the current iteration round + real(r8) :: rlfx_plnt0 ! "" + + real(r8) :: tm ! Total time integrated after each substep [s] + real(r8) :: dtime ! Total time to be integrated this step [s] + real(r8) :: w_tot_beg ! total plant water prior to solve [kg] + real(r8) :: w_tot_end ! total plant water at end of solve [kg] + logical :: continue_search + real(r8) :: k_eff ! Effective conductivity over the current pathway + ! between two nodes. Factors in fractional + ! loss of conductivity on each side of the pathway, and the material maximum + ! conductivity on each side [kg/s/MPa] + integer :: icnx_ar ! Connection index of the aroot <-> rhizosphere shell + + integer :: nsd ! node index of highest residual + integer :: nwtn_iter ! number of (Newton) iterations on each substep + + ! to get a succesfull Newton solve. + integer :: kshell ! rhizosphere shell index, 1->nshell + + integer :: info + integer :: nstep !number of time steps + + + ! This is a convergence test. This is the maximum difference + ! allowed between the flux balance and the change in storage + ! on a node. [kg/s] *Note, 1.e-9 = 1 ug/s + real(r8), parameter :: max_allowed_residual = 1.e-8_r8 + + ! Maximum number of times we re-try a round of Newton + ! iterations, each time decreasing the time-step and + ! potentially reducing relaxation factors + integer, parameter :: max_newton_rounds = 10 + + ! dtime will shrink at the following rate (halving) [s]: + ! 1800,900,450,225,112.5,56.25,28.125,14.0625,7.03125,3.515625, + ! 1.7578125,0.87890625,0.439453125,0.2197265625,0.10986328125, + ! 0.054931640625,0.0274658203125,0.01373291015625,0.006866455078125, + ! 0.0034332275390625,0.00171661376953125, + + + ! Maximum number of Newton iterations in each round + integer, parameter :: max_newton_iter = 100 + + ! Flag definitions for convergence flag (icnv) + ! icnv = 1 fail the round due to either wacky math, or + ! too many Newton iterations + ! icnv = 2 continue onto next iteration, + ! icnv = 3 acceptable solution + + + integer, parameter :: icnv_fail_round = 1 + integer, parameter :: icnv_pass_round = 2 + + ! Timestep reduction factor when a round of + ! newton iterations fail. + + real(r8), parameter :: dtime_rf = 0.5_r8 + + ! These are the initial relaxation factors at the beginning + ! of the large time-step. These may or may not shrink on + ! subsequent rounds, and may or may not grow over subsequent + ! iterations within rounds + real(r8), parameter :: rlfx_soil_init = 1.0 ! Initial Pressure update + ! reduction factor for soil compartments + real(r8), parameter :: rlfx_plnt_init = 1.0 ! Initial Pressure update + ! reduction factor for plant comparmtents + real(r8), parameter :: dpsi_scap = 0.1 ! Changes in psi (for soil) larger than this + ! will be subject to a capping routine + real(r8), parameter :: dpsi_pcap = 0.1 ! Change sin psi (for plants) larger than this + ! will be subject to a capping routine + real(r8), parameter :: rlfx_plnt_shrink = 1.0 ! Shrink the starting plant relaxtion factor + ! by this multipliler each round + real(r8), parameter :: rlfx_soil_shrink = 1.0 ! Shrink the starting soil relaxtion factor + ! by this multipliler each round + logical, parameter :: reset_on_fail = .false. ! If a round of Newton iterations is unable + ! to find a solution, you can either reset + ! to the beginning of the large timestep (true), or + ! to the beginning of the current substep (false) + + logical, parameter :: allow_lenient_lastiter = .true. ! If this is true, when the newton iteration + ! reaches its last allowed attempt, the + ! error tolerance will be increased (the bar lowered) by 10x + + + + associate(conn_up => csite_hydr%conn_up, & + conn_dn => csite_hydr%conn_dn, & + kmax_up => csite_hydr%kmax_up, & + kmax_dn => csite_hydr%kmax_dn, & + q_flux => csite_hydr%q_flux, & + residual => csite_hydr%residual, & + ajac => csite_hydr%ajac, & + ipiv => csite_hydr%ipiv, & + th_node => csite_hydr%th_node, & + th_node_prev => csite_hydr%th_node_prev, & + th_node_init => csite_hydr%th_node_init, & + psi_node => csite_hydr%psi_node, & + pm_node => csite_hydr%pm_node, & + ftc_node => csite_hydr%ftc_node, & + z_node => csite_hydr%z_node, & + v_node => csite_hydr%v_node, & + dth_node => csite_hydr%dth_node, & + node_layer => csite_hydr%node_layer, & + h_node => csite_hydr%h_node, & + dftc_dpsi_node => csite_hydr%dftc_dpsi_node, & + ft => cohort%pft) + + + !for debug only + nstep = get_nstep() + + + ! This NaN's the scratch arrays + call csite_hydr%FlushSiteScratch(hydr_solver_type) + + ! This is the maximum number of iterations needed for this cohort + ! (each soil layer has a different number, this saves the max) + cohort_hydr%iterh1 = 0 + cohort_hydr%iterh2 = 0 + + ! These are output fluxes from the subroutine, total integrated + ! mass fluxes [kg] over the time-step. sapflow is the integrated + ! flux between the transporting root and the 1st stem compartment. + ! The rootuptake is the integrated flux between the 1st rhizosphere + ! and absorbing roots + sapflow = 0._r8 + rootuptake(:) = 0._r8 + + ! Chnage in water content, over all substeps [m3/m3] + dth_node(:) = 0._r8 + + ! Transfer node heights, volumes and initial water contents for + ! the transporting root and above ground compartments to the + ! complete node vector + + do i = 1,n_hypool_ag+n_hypool_troot + if (i<=n_hypool_ag) then + z_node(i) = cohort_hydr%z_node_ag(i) + v_node(i) = cohort_hydr%v_ag(i) + th_node_init(i) = cohort_hydr%th_ag(i) + elseif (i>n_hypool_ag) then + z_node(i) = cohort_hydr%z_node_troot + v_node(i) = cohort_hydr%v_troot + th_node_init(i) = cohort_hydr%th_troot + end if + end do - end do newtonloop + ! Transfer node-heights, volumes and intiial water contents + ! for below-ground components, + ! from the cohort structures, into the complete node vector + i = n_hypool_ag + n_hypool_troot + + do j = 1,csite_hydr%nlevrhiz + + ! Calculate the fraction of the soil layer + ! folume that this plant's rhizosphere accounts forPath is across the upper an lower rhizosphere comparment + ! on each side of the nodes. Since there is no flow across the outer + ! node to the edge, we ignore that last half compartment + if(cohort_hydr%l_aroot_layer(j)>nearzero)then + aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/csite_hydr%l_aroot_layer(j) + else + aroot_frac_plant = 0._r8 + end if - ! If we are here, that means we succesfully finished - ! a solve with minimal error. More substeps may be required though - ! ------------------------------------------------------------------------------ + do k = 1, n_hypool_aroot + nshell + i = i + 1 + if (k==1) then + z_node(i) = -csite_hydr%zi_rhiz(j)+0.5*csite_hydr%dz_rhiz(j) + v_node(i) = cohort_hydr%v_aroot_layer(j) + th_node_init(i) = cohort_hydr%th_aroot(j) + else + kshell = k-1 + z_node(i) = -csite_hydr%zi_rhiz(j)+0.5*csite_hydr%dz_rhiz(j) + ! The volume of the Rhizosphere for a single plant + v_node(i) = csite_hydr%v_shell(j,kshell)*aroot_frac_plant + th_node_init(i) = csite_hydr%h2osoi_liqvol_shell(j,kshell) + end if + enddo - ! If there are any sub-steps left, we need to update - ! the initial water content - th_node_prev(:) = th_node(:) - + enddo - ! Reset relaxation factors - rlfx_plnt = rlfx_plnt0 - rlfx_soil = rlfx_soil0 - end do outerloop + ! Total water mass in the plant at the beginning of this solve [kg h2o] + w_tot_beg = sum(th_node_init(:)*v_node(:))*denh2o - if(cohort_hydr%iterh1>1._r8) then - write(fates_log(),*) "hydro solve info: i1: ",cohort_hydr%iterh1,"i2: ",cohort_hydr%iterh2 - end if - ! Save flux diagnostics - ! ------------------------------------------------------ - - sapflow = sapflow + q_flux(n_hypool_ag)*tmx + ! Initialize variables and flags that track + ! the progress of the solve - do j = 1,site_hydr%nlevrhiz - ! Connection betwen the 1st rhizosphere and absorbing roots - icnx_ar = n_hypool_ag + (j-1)*(nshell+1)+2 - rootuptake(j) = q_flux(icnx_ar)*tmx - enddo + tm = 0 + nsteps = 0 + th_node_prev(:) = th_node_init(:) + th_node(:) = th_node_init(:) + dtime = tmx + rlfx_plnt0 = rlfx_plnt_init + rlfx_soil0 = rlfx_soil_init + rlfx_plnt = rlfx_plnt0 + rlfx_soil = rlfx_soil0 + + outerloop: do while( tm < tmx ) + + ! The solve may reduce the time-step, the shorter + ! time-steps may not be perfectly divisible into + ! the remaining time. If so, then make sure we + ! don't overshoot + + dtime = min(dtime,tmx-tm) + + ! Advance time forward + tm = tm + dtime + ! If we have not exceeded our max number + ! of retrying rounds of Newton iterations, reduce + ! time and try a new round + + if( nsteps > max_newton_rounds ) then + + ! Complete failure to converge even with re-trying + ! iterations with smaller timesteps + + write(fates_log(),*) 'Newton hydraulics solve' + write(fates_log(),*) 'could not converge on a solution.' + write(fates_log(),*) 'Perhaps try increasing iteration cap,' + write(fates_log(),*) 'and decreasing relaxation factors.' + write(fates_log(),*) 'pft: ',ft,' dbh: ',cohort%dbh + call endrun(msg=errMsg(sourcefile, __LINE__)) + + endif + + + ! This is the newton search loop + + continue_search = .true. + nwtn_iter = 0 + newtonloop: do while(continue_search) + + nwtn_iter = nwtn_iter + 1 + + ! The Jacobian and the residual are incremented, + ! and the Jacobian is sparse, thus they both need + ! to be zerod. + ajac(:,:) = 0._r8 + residual(:) = 0._r8 + + do k=1,csite_hydr%num_nodes + + ! This is the storage gained from previous newton iterations. + residual(k) = residual(k) + denh2o*v_node(k)*(th_node(k) - th_node_prev(k))/dtime + + if(pm_node(k) == rhiz_p_media) then + + j = node_layer(k) + psi_node(k) = csite_hydr%wrf_soil(j)%p%psi_from_th(th_node(k)) + + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_node(k)) + ! deriv ftc wrt psi + dftc_dpsi_node(k) = csite_hydr%wkf_soil(j)%p%dftcdpsi_from_psi(psi_node(k)) - - ! Update the total change in water content - dth_node(:) = dth_node(:) + (th_node(:) - th_node_init(:)) - - ! Update state variables in plant compartments - cohort_hydr%th_ag(1:n_hypool_ag) = cohort_hydr%th_ag(1:n_hypool_ag) + dth_node(1:n_hypool_ag) - cohort_hydr%th_troot = cohort_hydr%th_troot + dth_node(n_hypool_ag+1) - - ! Change in water per plant [kg/plant] - dwat_plant = sum(dth_node(1:n_hypool_ag+n_hypool_troot)*v_node(1:n_hypool_ag+n_hypool_troot))*denh2o - - inode = n_hypool_ag+n_hypool_troot - do j = 1,site_hydr%nlevrhiz - do k = 1, 1 + nshell - inode = inode + 1 - if(k==1) then - cohort_hydr%th_aroot(j) = cohort_hydr%th_aroot(j)+dth_node(inode) - dwat_plant = dwat_plant + (dth_node(inode) * v_node(inode))*denh2o else - ishell = k-1 - dth_layershell_site(j,ishell) = dth_layershell_site(j,ishell) + & - dth_node(inode) * cohort_hydr%l_aroot_layer(j) * & - cohort%n / site_hydr%l_aroot_layer(j) - + + psi_node(k) = wrf_plant(pm_node(k),ft)%p%psi_from_th(th_node(k)) + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = wkf_plant(pm_node(k),ft)%p%ftc_from_psi(psi_node(k)) + ! deriv ftc wrt psi + dftc_dpsi_node(k) = wkf_plant(pm_node(k),ft)%p%dftcdpsi_from_psi(psi_node(k)) + + end if + + ! Fill the self-term on the Jacobian's diagonal with the + ! the change in storage wrt change in psi. + + if(pm_node(k) == rhiz_p_media) then + j = node_layer(k) + ajac(k,k) = -denh2o*v_node(k)/(csite_hydr%wrf_soil(j)%p%dpsidth_from_th(th_node(k))*dtime) + else + ajac(k,k) = -denh2o*v_node(k)/(wrf_plant(pm_node(k),ft)%p%dpsidth_from_th(th_node(k))*dtime) endif + enddo + + + ! Calculations of maximum conductance for upstream and downstream sides + ! of each connection. This IS dependant on total potential h_node + ! because of the root-soil radial conductance. + + call SetMaxCondConnections(csite_hydr, cohort_hydr, h_node, kmax_dn, kmax_up) + + ! calculate boundary fluxes + do icnx=1,csite_hydr%num_connections + + id_dn = conn_dn(icnx) + id_up = conn_up(icnx) + + ! The row (first index) of the Jacobian (ajac) represents the + ! the node for which we are calculating the water balance + ! The column (second index) of the Jacobian represents the nodes + ! on which the pressure differentials effect the water balance + ! of the node of the first index. + ! This will get the effective K, and may modify FTC depending + ! on the flow direction + + call GetKAndDKDPsi(kmax_dn(icnx), & + kmax_up(icnx), & + h_node(id_dn), & + h_node(id_up), & + ftc_node(id_dn), & + ftc_node(id_up), & + dftc_dpsi_node(id_dn), & + dftc_dpsi_node(id_up), & + dk_dpsi_dn, & + dk_dpsi_up, & + k_eff) + + q_flux(icnx) = k_eff*(h_node(id_up)-h_node(id_dn)) + + ! See equation (22) in technical documentation + ! Add fluxes at current time to the residual + residual(id_dn) = residual(id_dn) - q_flux(icnx) + residual(id_up) = residual(id_up) + q_flux(icnx) + + ! This is the Jacobian term related to the pressure changes on the down-stream side + ! and these are applied to both the up and downstream sides (oppositely) + ! This should be used for the down-stream on thr second index) + dqflx_dpsi_dn = -k_eff + (h_node(id_up)-h_node(id_dn)) * dk_dpsi_dn + + ! This is the Jacobian term related to the pressure changes on the up-stream side + ! and these are applied to both the up and downstream sides (oppositely) + dqflx_dpsi_up = k_eff + (h_node(id_up)-h_node(id_dn)) * dk_dpsi_up + + ! Down-stream node's contribution to the down-stream node's mass balance + ajac(id_dn,id_dn) = ajac(id_dn,id_dn) + dqflx_dpsi_dn + + ! Down-stream node's contribution to the up-stream node's mass balance + ajac(id_up,id_dn) = ajac(id_up,id_dn) - dqflx_dpsi_dn + + ! Up-stream node's contribution to the down-stream node's mass balance + ajac(id_dn,id_up) = ajac(id_dn,id_up) + dqflx_dpsi_up + + ! Up-stream node's contribution to the up-stream node's mass balance + ajac(id_up,id_up) = ajac(id_up,id_up) - dqflx_dpsi_up + + + + enddo + + ! Add the transpiration flux (known, retrieved from photosynthesis scheme) + ! to the mass balance on the leaf (1st) node. This is constant over + ! the time-step, so no Jacobian term needed (yet) + + residual(1) = residual(1) + qtop + + + ! Start off assuming things will pass, then find numerous + ! ways to see if it failed + icnv = icnv_pass_round + + + ! If we have performed any Newton iterations, then the residual + ! may reflect a flux that balances (equals) the change in storage. If this is + ! true, then the residual is zero, and we are done with the sub-step. If it is + ! not nearly zero, then we must continue our search and perform another solve. + + residual_amax = 0._r8 + nsd = 0 + do k = 1, csite_hydr%num_nodes + rsdx = abs(residual(k)) + ! check NaNs + if( rsdx /= rsdx ) then + icnv = icnv_fail_round + exit + endif + if( rsdx > residual_amax ) then + residual_amax = rsdx + nsd = k + endif + enddo + if ( nwtn_iter > max_newton_iter) then + icnv = icnv_fail_round + write(fates_log(),*) 'Newton hydraulics solve failed',residual_amax,nsd,tm + endif + + ! Three scenarios: + ! 1) the residual is 0, everything is great, leave iteration loop + ! 2) the residual is not 0, but we have not taken too many steps + ! and the matrix solve did not fail. Perform an inversion and keep + ! searching. + ! 3) the residual is not 0, and either + ! we have taken too many newton steps or the solver won't return + ! a real solution. + ! Shorten time-step, reset time to 0, reset relaxation factors + ! and try a new round of newton (if not exceeded) + + + if( icnv == icnv_fail_round ) then + + ! If the newton iteration fails, we go back + ! to restart the time-stepping loop with shorter sub-steps. + ! Therefore, we set the time elapsed (tm) to zero, + ! shorten the timstep (dtime) and re-initialize the water + ! contents to the starting amount. + + if(reset_on_fail) then + tm = 0._r8 + th_node(:) = th_node_init(:) + th_node_prev(:) = th_node_init(:) + cohort_hydr%iterh1 = 0 + else + tm = tm - dtime + th_node(:) = th_node_prev(:) + !* No need to update the th_node_prev, it is the + ! same since we are just re-starting the current + ! step + end if + nsteps = nsteps + 1 + dtime = dtime * dtime_rf + rlfx_plnt0 = rlfx_plnt_init*rlfx_plnt_shrink**real(nsteps,r8) + rlfx_soil0 = rlfx_soil_init*rlfx_soil_shrink**real(nsteps,r8) + rlfx_plnt = rlfx_plnt0 + rlfx_soil = rlfx_soil0 + nwtn_iter = 0 + cohort_hydr%iterh1 = cohort_hydr%iterh1 + 1 + cycle outerloop + + else + + ! On the last iteration, we temporarily lower the bar (if opted for) + ! and allow a pass if the residual is within 10x of the typical allowed residual + if ( allow_lenient_lastiter ) then + if ( nwtn_iter == max_newton_iter .and. residual_amax < 10*max_allowed_residual ) then + exit newtonloop + end if + end if + + if( sum(residual(:)) < max_allowed_residual .and. residual_amax < max_allowed_residual ) then + + ! We have succesffully found a solution + ! in this newton iteration. + exit newtonloop + else + ! Move ahead and calculate another solution + ! and continue the search. Residual isn't zero + ! but no reason not to continue searching + + ! Record that we performed a solve (this is total iterations) + cohort_hydr%iterh2 = cohort_hydr%iterh2 + 1 + + ! --------------------------------------------------------------------------- + ! From Lapack documentation + ! + ! subroutine dgesv(integer N (in), + ! integer NRHS (in), + ! real(r8), dimension( lda, * ) A (in/out), + ! integer LDA (in), + ! integer, dimension( * ) IPIV (out), + ! real(r8), dimension( ldb, * ) B (in/out), + ! integer LDB (in), + ! integer INFO (out) ) + ! + ! DGESV computes the solution to a real system of linear equations + ! A * X = B, where A is an N-by-N matrix and X and B are N-by-NRHS matrices. + ! The LU decomposition with partial pivoting and row interchanges is + ! used to factor A as A = P * L * U, + ! where P is a permutation matrix, L is unit lower triangular, and U is + ! upper triangular. The factored form of A is then used to solve the + ! system of equations A * X = B. + ! + ! N is the number of linear equations, i.e., the order of the + ! matrix A. N >= 0. + ! + ! NRHS is the number of right hand sides, i.e., the number of columns + ! of the matrix B. NRHS >= 0. + ! + ! A: + ! On entry, the N-by-N coefficient matrix A. + ! On exit, the factors L and U from the factorization + ! A = P*L*U; the unit diagonal elements of L are not stored. + ! + ! LDA is the leading dimension of the array A. LDA >= max(1,N). + ! + ! IPIV is the pivot indices that define the permutation matrix P; + ! row i of the matrix was interchanged with row IPIV(i). + ! + ! B + ! On entry, the N-by-NRHS matrix of right hand side matrix B. + ! On exit, if INFO = 0, the N-by-NRHS solution matrix X. + ! + ! LDB is the leading dimension of the array B. LDB >= max(1,N). + ! + ! INFO: + ! = 0: successful exit + ! < 0: if INFO = -i, the i-th argument had an illegal value + ! > 0: if INFO = i, U(i,i) is exactly zero. The factorization + ! has been completed, but the factor U is exactly + ! singular, so the solution could not be computed. + ! --------------------------------------------------------------------------- + !cohort_hydr%iterh2 = cohort_hydr%iterh2 + + call DGESV(csite_hydr%num_nodes,1,ajac,csite_hydr%num_nodes,ipiv,residual,csite_hydr%num_nodes,info) + + + if ( info < 0 ) then + write(fates_log(),*) 'illegal value generated in DGESV() linear' + write(fates_log(),*) 'system solver, see node: ',-info + call endrun(msg=errMsg(sourcefile, __LINE__)) + END IF + if ( info > 0 ) then + write(fates_log(),*) 'the factorization of linear system in DGESV() generated' + write(fates_log(),*) 'a singularity at node: ',info + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Update the previous water content state to be the current + ! th_node_prev(:) = th_node(:) + + ! If info == 0, then + ! lapack was able to generate a solution. + ! For A * X = B, + ! Where the residual() was B, DGESV() returns + ! the solution X into the residual array. + + ! Update the matric potential of each node. Since this is a search + ! we update matric potential as only a fraction of delta psi (residual) + + do k = 1, csite_hydr%num_nodes + + if(pm_node(k) == rhiz_p_media) then + j = node_layer(k) + if(abs(residual(k)) < dpsi_scap) then + psi_node(k) = psi_node(k) + residual(k) * rlfx_soil + else + psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_scap,residual(k)) - dpsi_scap*dpsi_scap/residual(k) + endif + th_node(k) = csite_hydr%wrf_soil(j)%p%th_from_psi(psi_node(k)) + else + if(abs(residual(k)) < dpsi_pcap) then + psi_node(k) = psi_node(k) + residual(k) * rlfx_plnt + else + psi_node(k) = psi_node(k) + 2._r8*sign(dpsi_pcap,residual(k)) - dpsi_pcap*dpsi_pcap/residual(k) + endif + th_node(k) = wrf_plant(pm_node(k),ft)%p%th_from_psi(psi_node(k)) + endif + + enddo + + ! Increase relaxation factors for next iteration + rlfx_plnt = min(1._r8,rlfx_plnt0 + & + (1.0-rlfx_plnt0)*real(nwtn_iter,r8)/real(max_newton_iter-3,r8)) + rlfx_soil = min(1._r8,rlfx_soil0 + & + (1.0-rlfx_soil0)*real(nwtn_iter,r8)/real(max_newton_iter-3,r8)) + + end if + end if + + end do newtonloop + + ! If we are here, that means we succesfully finished + ! a solve with minimal error. More substeps may be required though + ! ------------------------------------------------------------------------------ + + ! If there are any sub-steps left, we need to update + ! the initial water content + th_node_prev(:) = th_node(:) + + + ! Reset relaxation factors + rlfx_plnt = rlfx_plnt0 + rlfx_soil = rlfx_soil0 + + end do outerloop + + if(cohort_hydr%iterh1>1._r8) then + write(fates_log(),*) "hydro solve info: i1: ",cohort_hydr%iterh1,"i2: ",cohort_hydr%iterh2 + end if + + ! Save flux diagnostics + ! ------------------------------------------------------ + + sapflow = sapflow + q_flux(n_hypool_ag)*tmx + + do j = 1,csite_hydr%nlevrhiz + ! Connection betwen the 1st rhizosphere and absorbing roots + icnx_ar = n_hypool_ag + (j-1)*(nshell+1)+2 + rootuptake(j) = q_flux(icnx_ar)*tmx + enddo + + + ! Update the total change in water content + dth_node(:) = dth_node(:) + (th_node(:) - th_node_init(:)) + + ! Update state variables in plant compartments + cohort_hydr%th_ag(1:n_hypool_ag) = cohort_hydr%th_ag(1:n_hypool_ag) + dth_node(1:n_hypool_ag) + cohort_hydr%th_troot = cohort_hydr%th_troot + dth_node(n_hypool_ag+1) + + ! Change in water per plant [kg/plant] + dwat_plant = sum(dth_node(1:n_hypool_ag+n_hypool_troot)*v_node(1:n_hypool_ag+n_hypool_troot))*denh2o + + inode = n_hypool_ag+n_hypool_troot + do j = 1,csite_hydr%nlevrhiz + do k = 1, 1 + nshell + inode = inode + 1 + if(k==1) then + cohort_hydr%th_aroot(j) = cohort_hydr%th_aroot(j)+dth_node(inode) + dwat_plant = dwat_plant + (dth_node(inode) * v_node(inode))*denh2o + else + ishell = k-1 + dth_layershell_site(j,ishell) = dth_layershell_site(j,ishell) + & + dth_node(inode) * cohort_hydr%l_aroot_layer(j) * & + cohort%n / csite_hydr%l_aroot_layer(j) + + endif enddo - - ! Total water mass in the plant at the end of this solve [kg h2o] - w_tot_end = sum(th_node(:)*v_node(:))*denh2o - - ! Mass error (flux - change) [kg/m2] - wb_err_plant = (qtop*tmx)-(w_tot_beg-w_tot_end) + enddo + + ! Total water mass in the plant at the end of this solve [kg h2o] + w_tot_end = sum(th_node(:)*v_node(:))*denh2o + + ! Mass error (flux - change) [kg/m2] + wb_err_plant = (qtop*tmx)-(w_tot_beg-w_tot_end) + + + end associate + + return +end subroutine MatSolve2D + +! ===================================================================================== + +function SumBetweenDepths(csite_hydr,depth_t,depth_b,array_in) result(depth_sum) + + ! This function sums the quantity in array_in between depth_t (top) + ! and depth_b. It assumes many things. Firstly, that the depth coordinates + ! for array_in do match csite_hydr%zi_rhiz (on rhizosphere layers), and that + ! those coordinates are positive down. + + type(ed_site_hydr_type), intent(in) :: csite_hydr + real(r8),intent(in) :: depth_t ! Top Depth (positive coordinate) + real(r8),intent(in) :: depth_b ! Bottom depth (positive coordinate) + real(r8),intent(in) :: array_in(:) ! Quantity to be summed (flux?mass?) + real(r8) :: depth_sum ! The summed result we return in units (/depth) + integer :: i_rhiz_t ! Layer index of top full layer + integer :: i_rhiz_b ! layer index of bottom full layer + integer :: nlevrhiz ! Number of rhizosphere layers (not shells) + real(r8) :: frac ! Fraction of partial layer, by depth + + i_rhiz_t = count((csite_hydr%zi_rhiz(:)-csite_hydr%dz_rhiz(:))nlevrhiz) then + return + end if + + ! Sum all fully encased layers + if(i_rhiz_b>=i_rhiz_t)then + depth_sum = depth_sum + sum(array_in(i_rhiz_t:i_rhiz_b)) + end if + + ! Find fraction contribution from top partial layer (if any) + if(i_rhiz_t>1) then + frac = (csite_hydr%zi_rhiz(i_rhiz_t-1)-depth_t)/csite_hydr%dz_rhiz(i_rhiz_t-1) + depth_sum = depth_sum + frac*array_in(i_rhiz_t-1) + end if + + ! Find fraction contribution from bottom partial layer (if any) + if(i_rhiz_b rhizosphere shell + + integer :: nsd ! node index of highest residual + integer :: nwtn_iter ! number of (Newton) iterations on each substep + + ! to get a succesfull Newton solve. + integer :: kshell ! rhizosphere shell index, 1->nshell + + integer :: info + integer :: nstep !number of time steps + + + ! This is a convergence test. This is the maximum difference + ! allowed between the flux balance and the change in storage + ! on a node. [kg/s] *Note, 1.e-9 = 1 ug/s + real(r8), parameter :: max_allowed_residual = 1.e-8_r8 + + ! Maximum number of times we re-try a round of Picard + ! iterations, each time decreasing the time-step and + ! potentially reducing relaxation factors + integer, parameter :: max_picard_rounds = 100 + + ! dtime will shrink at the following rate (halving) [s]: + ! 1800,900,450,225,112.5,56.25,28.125,14.0625,7.03125,3.515625, + ! 1.7578125,0.87890625,0.439453125,0.2197265625,0.10986328125, + ! 0.054931640625,0.0274658203125,0.01373291015625,0.006866455078125, + ! 0.0034332275390625,0.00171661376953125, + + + ! Flag definitions for convergence flag (icnv) + ! icnv = 1 fail the round due to either wacky math, or + ! too many Newton iterations + ! icnv = 2 continue onto next iteration, + ! icnv = 3 acceptable solution + + + integer, parameter :: icnv_fail_round = 1 + integer, parameter :: icnv_pass_round = 2 + + ! Timestep reduction factor when a round of + ! newton iterations fail. + + real(r8), parameter :: dtime_rf = 0.5_r8 + + ! These are the initial relaxation factors at the beginning + ! of the large time-step. These may or may not shrink on + ! subsequent rounds, and may or may not grow over subsequent + ! iterations within rounds + real(r8), parameter :: rlfx_soil_init = 1.0 ! Initial Pressure update + ! reduction factor for soil compartments + real(r8), parameter :: rlfx_plnt_init = 1.0 ! Initial Pressure update + ! reduction factor for plant comparmtents + real(r8), parameter :: dpsi_scap = 0.1 ! Changes in psi (for soil) larger than this + ! will be subject to a capping routine + real(r8), parameter :: dpsi_pcap = 0.1 ! Change sin psi (for plants) larger than this + ! will be subject to a capping routine + real(r8), parameter :: rlfx_plnt_shrink = 1.0 ! Shrink the starting plant relaxtion factor + ! by this multipliler each round + real(r8), parameter :: rlfx_soil_shrink = 1.0 ! Shrink the starting soil relaxtion factor + ! by this multipliler each round + logical, parameter :: reset_on_fail = .false. ! If a round of Newton iterations is unable + ! to find a solution, you can either reset + ! to the beginning of the large timestep (true), or + ! to the beginning of the current substep (false) + + logical, parameter :: allow_lenient_lastiter = .true. ! If this is true, when the newton iteration + ! reaches its last allowed attempt, the + ! error tolerance will be increased (the bar lowered) by 10x + + real(r8), parameter :: cfl = 1.0_r8 !courant number (volume of water replaced in dt) + real(r8) :: cfl_max !maximum courant number + real(r8) :: wb_error ! sub sep error + real(r8) :: a_term ! flux contribution to dn_node + real(r8) :: b_term ! flux contribution to up_node + real(r8) :: dftc_dtheta_node(nnode) ! deriv FTC w.r.t. theta + real(r8) :: dpsi_dtheta_node(nnode) ! deriv psi w.r.t. theta + real(r8) :: volx !temporary volume + integer :: picd_iter !picard iteration counter + real(r8) :: th_prev(nnode) !temporary for th from previous iteration + + + associate(conn_up => csite_hydr%conn_up, & + conn_dn => csite_hydr%conn_dn, & + kmax_up => csite_hydr%kmax_up, & + kmax_dn => csite_hydr%kmax_dn, & + q_flux => csite_hydr%q_flux, & + residual => csite_hydr%residual, & + ajac => csite_hydr%ajac, & + ipiv => csite_hydr%ipiv, & + th_node => csite_hydr%th_node, & + th_node_prev => csite_hydr%th_node_prev, & + th_node_init => csite_hydr%th_node_init, & + psi_node => csite_hydr%psi_node, & + pm_node => csite_hydr%pm_node, & + ftc_node => csite_hydr%ftc_node, & + z_node => csite_hydr%z_node, & + v_node => csite_hydr%v_node, & + dth_node => csite_hydr%dth_node, & + node_layer => csite_hydr%node_layer, & + h_node => csite_hydr%h_node, & + dftc_dpsi_node => csite_hydr%dftc_dpsi_node, & + ft => cohort%pft) - end associate + !for debug only + nstep = get_nstep() - return - end subroutine MatSolve2D - ! ===================================================================================== - - function SumBetweenDepths(site_hydr,depth_t,depth_b,array_in) result(depth_sum) - - ! This function sums the quantity in array_in between depth_t (top) - ! and depth_b. It assumes many things. Firstly, that the depth coordinates - ! for array_in do match site_hydr%zi_rhiz (on rhizosphere layers), and that - ! those coordinates are positive down. - - type(ed_site_hydr_type), intent(in) :: site_hydr - real(r8),intent(in) :: depth_t ! Top Depth (positive coordinate) - real(r8),intent(in) :: depth_b ! Bottom depth (positive coordinate) - real(r8),intent(in) :: array_in(:) ! Quantity to be summed (flux?mass?) - real(r8) :: depth_sum ! The summed result we return in units (/depth) - integer :: i_rhiz_t ! Layer index of top full layer - integer :: i_rhiz_b ! layer index of bottom full layer - integer :: nlevrhiz ! Number of rhizosphere layers (not shells) - real(r8) :: frac ! Fraction of partial layer, by depth - - i_rhiz_t = count((site_hydr%zi_rhiz-site_hydr%dz_rhiz)nlevrhiz) then - return - end if - - ! Sum all fully encased layers - if(i_rhiz_b>=i_rhiz_t)then - depth_sum = depth_sum + sum(array_in(i_rhiz_t:i_rhiz_b)) - end if - - ! Find fraction contribution from top partial layer (if any) - if(i_rhiz_t>1) then - frac = (site_hydr%zi_rhiz(i_rhiz_t-1)-depth_t)/site_hydr%dz_rhiz(i_rhiz_t-1) - depth_sum = depth_sum + frac*array_in(i_rhiz_t-1) - end if - - ! Find fraction contribution from bottom partial layer (if any) - if(i_rhiz_bn_hypool_ag) then + z_node(i) = cohort_hydr%z_node_troot + v_node(i) = cohort_hydr%v_troot + th_node_init(i) = cohort_hydr%th_troot + end if + end do - ! Path is between the transporting root and the absorbing roots - inode = n_hypool_ag - do j = 1,site_hydr%nlevrhiz + ! Transfer node-heights, volumes and intiial water contents + ! for below-ground components, + ! from the cohort structures, into the complete node vector + i = n_hypool_ag + n_hypool_troot + + do j = 1,csite_hydr%nlevrhiz + + ! Calculate the fraction of the soil layer + ! folume that this plant's rhizosphere accounts forPath is across the upper an lower rhizosphere comparment + ! on each side of the nodes. Since there is no flow across the outer + ! node to the edge, we ignore that last half compartment + aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/csite_hydr%l_aroot_layer(j) - aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/site_hydr%l_aroot_layer(j) - do k = 1, n_hypool_aroot + nshell - icnx = icnx + 1 - inode = inode + 1 - if( k == 1 ) then !troot-aroot - kmax_dn(icnx) = cohort_hydr%kmax_troot_lower(j) - kmax_up(icnx) = cohort_hydr%kmax_aroot_upper(j) + i = i + 1 + if (k==1) then + z_node(i) = -csite_hydr%zi_rhiz(j)+0.5*csite_hydr%dz_rhiz(j) + v_node(i) = cohort_hydr%v_aroot_layer(j) + th_node_init(i) = cohort_hydr%th_aroot(j) + else + kshell = k-1 + z_node(i) = -csite_hydr%zi_rhiz(j)+0.5*csite_hydr%dz_rhiz(j) + ! The volume of the Rhizosphere for a single plant + v_node(i) = csite_hydr%v_shell(j,kshell)*aroot_frac_plant + th_node_init(i) = csite_hydr%h2osoi_liqvol_shell(j,kshell) + end if + enddo + + enddo + ! Initialize variables and flags that track + ! the progress of the solve + + tm = 0 + nsteps = 0 + th_node_prev(:) = th_node_init(:) + th_node(:) = th_node_init(:) + dtime = tmx + + ! Total water mass in the plant at the beginning of this solve [kg h2o] + w_tot_beg = sum(th_node_init(:)*v_node(:))*denh2o + + ! calculate cfl + cfl_max = 0._r8 + do k=1,csite_hydr%num_nodes + + if(pm_node(k) == rhiz_p_media) then + + j = node_layer(k) + psi_node(k) = max(-1e5_r8, csite_hydr%wrf_soil(j)%p%psi_from_th(th_node(k))) + + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_node(k)) + dftc_dpsi_node(k) = csite_hydr%wkf_soil(j)%p%dftcdpsi_from_psi(psi_node(k)) + + dpsi_dtheta_node(k) = csite_hydr%wrf_soil(j)%p%dpsidth_from_th(th_node(k)) + dftc_dtheta_node(k) = dftc_dpsi_node(k) * dpsi_dtheta_node(k) + + else + + psi_node(k) = max(-1e5_r8, wrf_plant(pm_node(k),ft)%p%psi_from_th(th_node(k))) + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = wkf_plant(pm_node(k),ft)%p%ftc_from_psi(psi_node(k)) + ! deriv ftc wrt psi + dftc_dpsi_node(k) = wkf_plant(pm_node(k),ft)%p%dftcdpsi_from_psi(psi_node(k)) + dpsi_dtheta_node(k) = wrf_plant(pm_node(k),ft)%p%dpsidth_from_th(th_node(k)) + + dftc_dtheta_node(k) = dftc_dpsi_node(k) * dpsi_dtheta_node(k) + + end if + + + enddo + + + ! Calculations of maximum conductance for upstream and downstream sides + ! of each connection. This IS dependant on total potential h_node + ! because of the root-soil radial conductance. + + call SetMaxCondConnections(csite_hydr, cohort_hydr, h_node, kmax_dn, kmax_up) + + ! calculate boundary fluxes + do icnx=1,csite_hydr%num_connections + + id_dn = conn_dn(icnx) + id_up = conn_up(icnx) + call GetImTaylorKAB(kmax_up(icnx),kmax_dn(icnx), & + ftc_node(id_up),ftc_node(id_dn), & + h_node(id_up),h_node(id_dn), & + dftc_dtheta_node(id_up), dftc_dtheta_node(id_dn), & + dpsi_dtheta_node(id_up), dpsi_dtheta_node(id_dn), & + k_eff, & + A_term, & + B_term) + + q_flux(icnx) = k_eff*(h_node(id_up)-h_node(id_dn)) + volx = (v_node(id_dn) + v_node(id_up))/2._r8 + cfl_max = max(cfl_max,abs(k_eff*(h_node(id_dn) -h_node(id_up)))*dtime/volx/denh2o) + enddo + !Top node + cfl_max = max(cfl_max, abs(qtop * dtime/v_node(1)/denh2o)) + ! To avoid extreme large clf_max due to large qtop from small gw weight + cfl_max = min(20._r8,cfl_max) + + !Calculate time step that meet cfl condition + if(cfl_max > cfl) then + nsteps = min(int(cfl_max/cfl) + 1, 20) + dtime = tmx/nsteps + end if + + icnv = 0 + outerloop: do while( tm < tmx ) + + ! The solve may reduce the time-step, the shorter + ! time-steps may not be perfectly divisible into + ! the remaining time. If so, then make sure we + ! don't overshoot + + dtime = min(dtime,tmx-tm) + if( ((tmx-tm) < (2*dtime)) .and. ((tmx-tm) > dtime) ) dtime = tmx-tm + + ! Advance time forward + tm = tm + dtime + + + ! This is the newton search loop + + continue_search = .true. + picd_iter = 0 + picardloop: do while(continue_search) + + picd_iter = picd_iter + 1 - elseif( k == 2) then ! aroot-soil + ! The Jacobian and the residual are incremented, + ! and the Jacobian is sparse, thus they both need + ! to be zerod. + ajac(:,:) = 0._r8 + residual(:) = 0._r8 + th_prev(:) = th_node(:) - ! Special case. Maximum conductance depends on the - ! potential gradient. + do k=1,csite_hydr%num_nodes + + ! This is the storage gained from previous newton iterations. + residual(k) = residual(k) + & + (th_node(k)-th_node_prev(k))*denh2o*v_node(k)/dtime + + if(pm_node(k) == rhiz_p_media) then + + j = node_layer(k) + psi_node(k) = max(-1e2_r8, csite_hydr%wrf_soil(j)%p%psi_from_th(th_node(k))) + + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_node(k)) + dftc_dpsi_node(k) = csite_hydr%wkf_soil(j)%p%dftcdpsi_from_psi(psi_node(k)) + + dpsi_dtheta_node(k) = csite_hydr%wrf_soil(j)%p%dpsidth_from_th(th_node(k)) + dftc_dtheta_node(k) = dftc_dpsi_node(k) * dpsi_dtheta_node(k) - if(h_node(inode) < h_node(inode+1) ) then - kmax_dn(icnx) = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(j) + & - 1._r8/cohort_hydr%kmax_aroot_radial_in(j)) else - kmax_dn(icnx) = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(j) + & - 1._r8/cohort_hydr%kmax_aroot_radial_out(j)) + + psi_node(k) = max(-1e2_r8, wrf_plant(pm_node(k),ft)%p%psi_from_th(th_node(k))) + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = wkf_plant(pm_node(k),ft)%p%ftc_from_psi(psi_node(k)) + ! deriv ftc wrt psi + dftc_dpsi_node(k) = wkf_plant(pm_node(k),ft)%p%dftcdpsi_from_psi(psi_node(k)) + dpsi_dtheta_node(k) = wrf_plant(pm_node(k),ft)%p%dpsidth_from_th(th_node(k)) + + dftc_dtheta_node(k) = dftc_dpsi_node(k) * dpsi_dtheta_node(k) + end if - kmax_up(icnx) = site_hydr%kmax_upper_shell(j,1)*aroot_frac_plant - else ! soil - soil - kmax_dn(icnx) = site_hydr%kmax_lower_shell(j,k-2)*aroot_frac_plant - kmax_up(icnx) = site_hydr%kmax_upper_shell(j,k-1)*aroot_frac_plant + ! Fill the self-term on the Jacobian's diagonal with the + ! the change in storage wrt change in psi. + + ajac(k,k) = - denh2o*v_node(k)/dtime + + enddo + + + ! Calculations of maximum conductance for upstream and downstream sides + ! of each connection. This IS dependant on total potential h_node + ! because of the root-soil radial conductance. + + call SetMaxCondConnections(csite_hydr, cohort_hydr, h_node, kmax_dn, kmax_up) + + ! calculate boundary fluxes + do icnx=1,csite_hydr%num_connections + + id_dn = conn_dn(icnx) + id_up = conn_up(icnx) + + ! The row (first index) of the Jacobian (ajac) represents the + ! the node for which we are calculating the water balance + ! The column (second index) of the Jacobian represents the nodes + ! on which the pressure differentials effect the water balance + ! of the node of the first index. + ! This will get the effective K, and may modify FTC depending + ! on the flow direction + + call GetImTaylorKAB(kmax_up(icnx),kmax_dn(icnx), & + ftc_node(id_up),ftc_node(id_dn), & + h_node(id_up),h_node(id_dn), & + dftc_dtheta_node(id_up), dftc_dtheta_node(id_dn), & + dpsi_dtheta_node(id_up), dpsi_dtheta_node(id_dn), & + k_eff, & + A_term, & + B_term) + + q_flux(icnx) = k_eff*(h_node(id_up)-h_node(id_dn)) + + ! See equation (22) in technical documentation + ! Add fluxes at current time to the residual + residual(id_dn) = residual(id_dn) - q_flux(icnx) + residual(id_up) = residual(id_up) + q_flux(icnx) + + ! Down-stream node's contribution to the down-stream node's mass balance + ajac(id_dn,id_dn) = ajac(id_dn,id_dn) + A_term + + ! Down-stream node's contribution to the up-stream node's mass balance + ajac(id_up,id_dn) = ajac(id_up,id_dn) - A_term + + ! Up-stream node's contribution to the down-stream node's mass balance + ajac(id_dn,id_up) = ajac(id_dn,id_up) + B_term + + ! Up-stream node's contribution to the up-stream node's mass balance + ajac(id_up,id_up) = ajac(id_up,id_up) - B_term + + + + enddo + + ! Add the transpiration flux (known, retrieved from photosynthesis scheme) + ! to the mass balance on the leaf (1st) node. This is constant over + ! the time-step, so no Jacobian term needed (yet) + + residual(1) = residual(1) + qtop + + !Solve linear equations + call DGESV(csite_hydr%num_nodes,1,ajac,csite_hydr%num_nodes,ipiv,residual,csite_hydr%num_nodes,info) + + + if ( info < 0 ) then + write(fates_log(),*) 'illegal value generated in DGESV() linear' + write(fates_log(),*) 'system solver, see node: ',-info + call endrun(msg=errMsg(sourcefile, __LINE__)) + END IF + if ( info > 0 ) then + write(fates_log(),*) 'the factorization of linear system in DGESV() generated' + write(fates_log(),*) 'a singularity at node: ',info + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Update the water content + th_node(:) = th_node(:) + residual(:) + ! constrain th + do k=1,csite_hydr%num_nodes + + if(pm_node(k) == rhiz_p_media) then + + j = node_layer(k) + th_node(k) = max(th_node(k), csite_hydr%wrf_soil(j)%p%get_thmin()) + + else + + th_node(k) = max(th_node(k), wrf_plant(pm_node(k),ft)%p%get_thmin()) + + end if + + + enddo + + wb_error = qtop*dtime - (sum( th_node_prev(:)*v_node(:) ) - sum( th_node(:)*v_node(:) ))*denh2o + + ! Mass is conserved or solver is converged + if(abs(wb_error) < max_allowed_residual .or. maxval(abs(residual(:))) < 1.e-3_r8 .or. maxval(abs(th_node(:) - th_prev(:))) < 1.e-3) exit picardloop + + if(icnv == 1 ) then + print *,'dtime-',dtime,tm + exit picardloop !explicit integration with small time step + end if + + if(picd_iter > max_picard_rounds) then + + icnv = 1 + + ! reset to initial condition + tm = 0._r8 + th_node(:) = th_node_init(:) + th_node_prev(:) = th_node_init(:) + + cycle outerloop !do explicit integration + endif - enddo - end do + end do picardloop - end subroutine SetMaxCondConnections - - ! ===================================================================================== + ! If we are here, that means we succesfully finished + ! a solve with minimal error. More substeps may be required though + ! ------------------------------------------------------------------------------ - subroutine InitHydroGlobals() - - ! This routine allocates the Water Transfer Functions (WTFs) - ! which include both water retention functions (WRFs) - ! as well as the water conductance (K) functions (WKFs) - ! But, this is only for plants! These functions have specific - ! parameters, potentially, for each plant functional type and - ! each organ (pft x organ), but this can be used globally (across - ! all sites on the node (machine) to save memory. These functions - ! are also applied to soils, but since soil properties vary with - ! soil layer and location, those functions are bound to the site - ! structure, and are therefore not "global". - - ! Define - class(wrf_type_vg), pointer :: wrf_vg - class(wkf_type_vg), pointer :: wkf_vg - class(wrf_type_cch), pointer :: wrf_cch - class(wkf_type_tfs), pointer :: wkf_tfs - class(wrf_type_tfs), pointer :: wrf_tfs - - integer :: ft ! PFT index - integer :: pm ! plant media index - integer :: inode ! compartment node index - real(r8) :: cap_corr ! correction for nonzero psi0x (TFS) - real(r8) :: cap_slp ! slope of capillary region of curve - real(r8) :: cap_int ! intercept of capillary region of curve - - if(hlm_use_planthydro.eq.ifalse) return - - ! we allocate from stomata_p_media, which should be zero + ! If there are any sub-steps left, we need to update + ! the initial water content + th_node_prev(:) = th_node(:) - allocate(wrf_plant(stomata_p_media:n_plant_media,numpft)) - allocate(wkf_plant(stomata_p_media:n_plant_media,numpft)) - - ! ----------------------------------------------------------------------------------- - ! Initialize the Water Retention Functions - ! ----------------------------------------------------------------------------------- - select case(plant_wrf_type) - case(van_genuchten_type) - do ft = 1,numpft - do pm = 1, n_plant_media - allocate(wrf_vg) - wrf_plant(pm,ft)%p => wrf_vg - call wrf_vg%set_wrf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg]) - end do - end do - case(campbell_type) - do ft = 1,numpft - do pm = 1,n_plant_media - allocate(wrf_cch) - wrf_plant(pm,ft)%p => wrf_cch - call wrf_cch%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & - EDPftvarcon_inst%hydr_pinot_node(ft,pm), & - 9._r8]) - end do - end do - case(tfs_type) - do ft = 1,numpft - do pm = 1,n_plant_media - allocate(wrf_tfs) - wrf_plant(pm,ft)%p => wrf_tfs - - if (pm.eq.leaf_p_media) then ! Leaf tissue - cap_slp = 0.0_r8 - cap_int = 0.0_r8 - cap_corr = 1.0_r8 - else ! Non leaf tissues - cap_slp = (hydr_psi0 - hydr_psicap )/(1.0_r8 - rwccap(pm)) - cap_int = -cap_slp + hydr_psi0 - cap_corr = -cap_int/cap_slp - end if - - call wrf_tfs%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & - EDPftvarcon_inst%hydr_resid_node(ft,pm), & - EDPftvarcon_inst%hydr_pinot_node(ft,pm), & - EDPftvarcon_inst%hydr_epsil_node(ft,pm), & - rwcft(pm), & - cap_corr, & - cap_int, & - cap_slp,real(pm,r8)]) - end do - end do - end select + end do outerloop - ! ----------------------------------------------------------------------------------- - ! Initialize the Water Conductance (K) Functions - ! ----------------------------------------------------------------------------------- + !update psi + do k=1,csite_hydr%num_nodes - select case(plant_wkf_type) - case(van_genuchten_type) - do ft = 1,numpft - do pm = 1, n_plant_media - allocate(wkf_vg) - wkf_plant(pm,ft)%p => wkf_vg - call wkf_vg%set_wkf_param([alpha_vg, psd_vg, th_sat_vg, th_res_vg, tort_vg]) - end do - - end do - case(campbell_type) - write(fates_log(),*) 'campbell/clapp-hornberger conductance not used in plants' - call endrun(msg=errMsg(sourcefile, __LINE__)) - case(tfs_type) - do ft = 1,numpft - do pm = 1, n_plant_media - allocate(wkf_tfs) - wkf_plant(pm,ft)%p => wkf_tfs - call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_node(ft,pm), & - EDPftvarcon_inst%hydr_avuln_node(ft,pm)]) - end do - end do - end select + if(pm_node(k) == rhiz_p_media) then - ! There is only 1 stomata conductance hypothesis which uses the p50 and - ! vulnerability parameters - ! ----------------------------------------------------------------------------------- + j = node_layer(k) + psi_node(k) = max(-1e2_r8, csite_hydr%wrf_soil(j)%p%psi_from_th(th_node(k))) + + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = csite_hydr%wkf_soil(j)%p%ftc_from_psi(psi_node(k)) + else - do ft = 1,numpft - allocate(wkf_tfs) - wkf_plant(stomata_p_media,ft)%p => wkf_tfs - call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_gs(ft), & - EDPftvarcon_inst%hydr_avuln_gs(ft)]) + psi_node(k) = max(-1e2_r8, wrf_plant(pm_node(k),ft)%p%psi_from_th(th_node(k))) + ! Get total potential [Mpa] + h_node(k) = mpa_per_pa*denh2o*grav_earth*z_node(k) + psi_node(k) + ! Get Fraction of Total Conductivity [-] + ftc_node(k) = wkf_plant(pm_node(k),ft)%p%ftc_from_psi(psi_node(k)) + + end if + + enddo + + ! update fluxes + do icnx=1,csite_hydr%num_connections + + id_dn = conn_dn(icnx) + id_up = conn_up(icnx) + + call GetImTaylorKAB(kmax_up(icnx),kmax_dn(icnx), & + ftc_node(id_up),ftc_node(id_dn), & + h_node(id_up),h_node(id_dn), & + dftc_dtheta_node(id_up), dftc_dtheta_node(id_dn), & + dpsi_dtheta_node(id_up), dpsi_dtheta_node(id_dn), & + k_eff, & + A_term, & + B_term) + + q_flux(icnx) = k_eff*(h_node(id_up)-h_node(id_dn)) end do + ! Save flux diagnostics + ! ------------------------------------------------------ - - return - end subroutine InitHydroGlobals - - !! subroutine UpdateLWPMemFLCMin(ccohort_hydr) - - ! This code may be re-introduced at a later date (rgk 08-2019) - - ! SET COHORT-LEVEL BTRAN FOR USE IN NEXT TIMESTEP - ! first update the leaf water potential memory - !! do t=2, numLWPmem - !!ccohort_hydr%lwp_mem(t-1) = ccohort_hydr%lwp_mem(t) - !!end do - !!ccohort_hydr%lwp_mem(numLWPmem) = ccohort_hydr%psi_ag(1) - !!call flc_gs_from_psi(cCohort, ccohort_hydr%psi_ag(1)) - - !!refill_rate = -log(0.5)/(ccohort_hydr%refill_days*24._r8*3600._r8) ! s-1 - !!do k=1,n_hypool_ag - !!ccohort_hydr%flc_min_ag(k) = min(ccohort_hydr%flc_min_ag(k), ccohort_hydr%flc_ag(k)) - !!if(ccohort_hydr%psi_ag(k) >= ccohort_hydr%refill_thresh .and. & - !! ccohort_hydr%flc_ag(k) > ccohort_hydr%flc_min_ag(k)) then ! then refilling - !! ccohort_hydr%flc_min_ag(k) = ccohort_hydr%flc_ag(k) - & - !! (ccohort_hydr%flc_ag(k) - ccohort_hydr%flc_min_ag(k))*exp(-refill_rate*dtime) - !!end if - !!end do - !!do k=1,n_hypool_troot - !!ccohort_hydr%flc_min_troot(k) = min(ccohort_hydr%flc_min_troot(k), ccohort_hydr%flc_troot(k)) - !!if(ccohort_hydr%psi_troot(k) >= ccohort_hydr%refill_thresh .and. & - !! ccohort_hydr%flc_troot(k) > ccohort_hydr%flc_min_troot(k)) then ! then refilling - !! ccohort_hydr%flc_min_troot(k) = ccohort_hydr%flc_troot(k) - & - !! (ccohort_hydr%flc_troot(k) - ccohort_hydr%flc_min_troot(k))*exp(-refill_rate*dtime) - !!end if - !!end do - !!do j=1,site_hydr%nlevrhiz - !!ccohort_hydr%flc_min_aroot(j) = min(ccohort_hydr%flc_min_aroot(j), ccohort_hydr%flc_aroot(j)) - !!if(ccohort_hydr%psi_aroot(j) >= ccohort_hydr%refill_thresh .and. & - !! ccohort_hydr%flc_aroot(j) > ccohort_hydr%flc_min_aroot(j)) then ! then refilling - !! ccohort_hydr%flc_min_aroot(j) = ccohort_hydr%flc_aroot(j) - & - !! (ccohort_hydr%flc_aroot(j) - ccohort_hydr%flc_min_aroot(j))*exp(-refill_rate*dtime) - !!end if - !!end do - !!end subroutine UpdateLWPMemFLCMin + sapflow = sapflow + q_flux(n_hypool_ag)*tmx + + do j = 1,csite_hydr%nlevrhiz + ! Connection betwen the 1st rhizosphere and absorbing roots + icnx_ar = n_hypool_ag + (j-1)*(nshell+1)+2 + rootuptake(j) = q_flux(icnx_ar)*tmx + enddo + + + ! Update the total change in water content + dth_node(:) = dth_node(:) + (th_node(:) - th_node_init(:)) + + ! Update state variables in plant compartments + cohort_hydr%th_ag(1:n_hypool_ag) = cohort_hydr%th_ag(1:n_hypool_ag) + dth_node(1:n_hypool_ag) + if(minval(cohort_hydr%th_ag(1:n_hypool_ag)) < 0._r8) then + write(fates_log(),*) 'negative water content', cohort_hydr%th_ag(1:n_hypool_ag),wrf_plant(pm_node(1),ft)%p%get_thmin() + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif + cohort_hydr%th_troot = cohort_hydr%th_troot + dth_node(n_hypool_ag+1) + + ! Change in water per plant [kg/plant] + dwat_plant = sum(dth_node(1:n_hypool_ag+n_hypool_troot)*v_node(1:n_hypool_ag+n_hypool_troot))*denh2o + + inode = n_hypool_ag+n_hypool_troot + do j = 1,csite_hydr%nlevrhiz + do k = 1, 1 + nshell + inode = inode + 1 + if(k==1) then + cohort_hydr%th_aroot(j) = cohort_hydr%th_aroot(j)+dth_node(inode) + dwat_plant = dwat_plant + (dth_node(inode) * v_node(inode))*denh2o + else + ishell = k-1 + dth_layershell_site(j,ishell) = dth_layershell_site(j,ishell) + & + dth_node(inode) * cohort_hydr%l_aroot_layer(j) * & + cohort%n / csite_hydr%l_aroot_layer(j) + + endif + enddo + enddo + + ! Total water mass in the plant at the end of this solve [kg h2o] + w_tot_end = sum(th_node(:)*v_node(:))*denh2o + + ! Mass error (flux - change) [kg/m2] + wb_err_plant = (qtop*tmx)-(w_tot_beg-w_tot_end) + + + end associate + + return +end subroutine PicardSolve2D + +! ===================================================================================== + +subroutine SetMaxCondConnections(csite_hydr, cohort_hydr, h_node, kmax_dn, kmax_up) + + ! ------------------------------------------------------------------------------- + ! This subroutine sets the maximum conductances + ! on the downstream (towards atm) and upstream (towards + ! soil) side of each connection. This scheme is somewhat complicated + ! by the fact that the direction of flow at the root surface impacts + ! which root surface radial conductance to use, which makes these calculation + ! dependent on the updating potential in the system, and not just a function + ! of plant geometry and material properties. + ! ------------------------------------------------------------------------------- + + type(ed_site_hydr_type), intent(in),target :: csite_hydr + type(ed_cohort_hydr_type), intent(in),target :: cohort_hydr + real(r8),intent(in) :: h_node(:) ! Total (matric+height) potential at each node (Mpa) + real(r8),intent(out) :: kmax_dn(:) ! Max conductance of downstream sides of connections (kg s-1 MPa-1) + real(r8),intent(out) :: kmax_up(:) ! Max conductance of upstream sides of connections (kg s-1 MPa-1) + + real(r8):: aroot_frac_plant ! Fraction of the cohort's fine-roots + ! out of the total in the current layer + integer :: icnx ! connection index + integer :: inode ! node index + integer :: istem ! stem index + integer :: k ! rhizosphere/root index (per level) + integer :: j ! soil layer index + + kmax_dn(:) = fates_unset_r8 + kmax_up(:) = fates_unset_r8 + + ! Set leaf to stem connections (only 1 leaf layer + ! this will break if we have multiple, as there would + ! need to be assumptions about which compartment + ! to connect the leaves to. + icnx = 1 + kmax_dn(icnx) = cohort_hydr%kmax_petiole_to_leaf + kmax_up(icnx) = cohort_hydr%kmax_stem_upper(1) + + ! Stem to stem connections + do istem = 1,n_hypool_stem-1 + icnx = icnx + 1 + kmax_dn(icnx) = cohort_hydr%kmax_stem_lower(istem) + kmax_up(icnx) = cohort_hydr%kmax_stem_upper(istem+1) + enddo + + ! Path is between lowest stem and transporting root + icnx = icnx + 1 + kmax_dn(icnx) = cohort_hydr%kmax_stem_lower(n_hypool_stem) + kmax_up(icnx) = cohort_hydr%kmax_troot_upper + + ! Path is between the transporting root and the absorbing roots + inode = n_hypool_ag + do j = 1,csite_hydr%nlevrhiz + + aroot_frac_plant = cohort_hydr%l_aroot_layer(j)/csite_hydr%l_aroot_layer(j) + + do k = 1, n_hypool_aroot + nshell + icnx = icnx + 1 + inode = inode + 1 + if( k == 1 ) then !troot-aroot + kmax_dn(icnx) = cohort_hydr%kmax_troot_lower(j) + kmax_up(icnx) = cohort_hydr%kmax_aroot_upper(j) + + elseif( k == 2) then ! aroot-soil + + ! Special case. Maximum conductance depends on the + ! potential gradient. + + if(h_node(inode) < h_node(inode+1) ) then + kmax_dn(icnx) = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(j) + & + 1._r8/cohort_hydr%kmax_aroot_radial_in(j)) + else + kmax_dn(icnx) = 1._r8/(1._r8/cohort_hydr%kmax_aroot_lower(j) + & + 1._r8/cohort_hydr%kmax_aroot_radial_out(j)) + end if + kmax_up(icnx) = csite_hydr%kmax_upper_shell(j,1)*aroot_frac_plant + + else ! soil - soil + kmax_dn(icnx) = csite_hydr%kmax_lower_shell(j,k-2)*aroot_frac_plant + kmax_up(icnx) = csite_hydr%kmax_upper_shell(j,k-1)*aroot_frac_plant + endif + enddo + + end do + + +end subroutine SetMaxCondConnections + +! ===================================================================================== + +subroutine InitHydroGlobals() + + ! This routine allocates the Water Transfer Functions (WTFs) + ! which include both water retention functions (WRFs) + ! as well as the water conductance (K) functions (WKFs) + ! But, this is only for plants! These functions have specific + ! parameters, potentially, for each plant functional type and + ! each organ (pft x organ), but this can be used globally (across + ! all sites on the node (machine) to save memory. These functions + ! are also applied to soils, but since soil properties vary with + ! soil layer and location, those functions are bound to the site + ! structure, and are therefore not "global". + + ! Define + class(wrf_type_vg), pointer :: wrf_vg + class(wkf_type_vg), pointer :: wkf_vg + class(wrf_type_cch), pointer :: wrf_cch + class(wkf_type_tfs), pointer :: wkf_tfs + class(wrf_type_tfs), pointer :: wrf_tfs + + integer :: ft ! PFT index + integer :: pm ! plant media index + integer :: inode ! compartment node index + real(r8) :: cap_corr ! correction for nonzero psi0x (TFS) + real(r8) :: cap_slp ! slope of capillary region of curve + real(r8) :: cap_int ! intercept of capillary region of curve + + if(hlm_use_planthydro.eq.ifalse) return + + ! we allocate from stomata_p_media, which should be zero + + allocate(wrf_plant(stomata_p_media:n_plant_media,numpft)) + allocate(wkf_plant(stomata_p_media:n_plant_media,numpft)) + + ! ----------------------------------------------------------------------------------- + ! Initialize the Water Retention Functions + ! ----------------------------------------------------------------------------------- + + do pm = 1, n_plant_media + select case(hydr_htftype_node(pm)) + case(van_genuchten_type) + do ft = 1,numpft + allocate(wrf_vg) + wrf_plant(pm,ft)%p => wrf_vg + call wrf_vg%set_wrf_param([EDPftvarcon_inst%hydr_vg_alpha_node(ft,pm), & + EDPftvarcon_inst%hydr_vg_n_node(ft,pm), & + EDPftvarcon_inst%hydr_vg_m_node(ft,pm), & + EDPftvarcon_inst%hydr_thetas_node(ft,pm), & + EDPftvarcon_inst%hydr_resid_node(ft,pm)]) + + end do + case(tfs_type) + do ft = 1,numpft + allocate(wrf_tfs) + wrf_plant(pm,ft)%p => wrf_tfs + if (pm.eq.leaf_p_media) then ! Leaf tissue + cap_slp = 0.0_r8 + cap_int = 0.0_r8 + cap_corr = 1.0_r8 + else ! Non leaf tissues + cap_slp = (hydr_psi0 - hydr_psicap )/(1.0_r8 - rwccap(pm)) + cap_int = -cap_slp + hydr_psi0 + cap_corr = -cap_int/cap_slp + end if + call wrf_tfs%set_wrf_param([EDPftvarcon_inst%hydr_thetas_node(ft,pm), & + EDPftvarcon_inst%hydr_resid_node(ft,pm), & + EDPftvarcon_inst%hydr_pinot_node(ft,pm), & + EDPftvarcon_inst%hydr_epsil_node(ft,pm), & + rwcft(pm), & + cap_corr, & + cap_int, & + cap_slp,real(pm,r8)]) + end do + case default + write(fates_log(),*) 'undefined water retention type for plants, pm:',pm,'type: ',hydr_htftype_node(pm) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + end do + + ! ----------------------------------------------------------------------------------- + ! Initialize the Water Conductance (K) Functions + ! ----------------------------------------------------------------------------------- + do pm = 1, n_plant_media + select case(hydr_htftype_node(pm)) + + case(van_genuchten_type) + do ft = 1,numpft + allocate(wkf_vg) + wkf_plant(pm,ft)%p => wkf_vg + call wkf_vg%set_wkf_param([EDPftvarcon_inst%hydr_vg_alpha_node(ft,pm), & + EDPftvarcon_inst%hydr_vg_n_node(ft,pm), & + EDPftvarcon_inst%hydr_vg_m_node(ft,pm), & + EDPftvarcon_inst%hydr_thetas_node(ft,pm), & + EDPftvarcon_inst%hydr_resid_node(ft,pm), & + plant_tort_vg]) + end do + case(tfs_type) + do ft = 1,numpft + allocate(wkf_tfs) + wkf_plant(pm,ft)%p => wkf_tfs + call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_node(ft,pm), & + EDPftvarcon_inst%hydr_avuln_node(ft,pm)]) + end do + case default + write(fates_log(),*) 'undefined water conductance type for plants, pm:',pm,'type: ',hydr_htftype_node(pm) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + end do + + ! There is only 1 stomata conductance hypothesis which uses the p50 and + ! vulnerability parameters + ! ----------------------------------------------------------------------------------- + + do ft = 1,numpft + allocate(wkf_tfs) + wkf_plant(stomata_p_media,ft)%p => wkf_tfs + call wkf_tfs%set_wkf_param([EDPftvarcon_inst%hydr_p50_gs(ft), & + EDPftvarcon_inst%hydr_avuln_gs(ft)]) + end do + + + return +end subroutine InitHydroGlobals + +!! subroutine UpdateLWPMemFLCMin(ccohort_hydr) + +! This code may be re-introduced at a later date (rgk 08-2019) + +! SET COHORT-LEVEL BTRAN FOR USE IN NEXT TIMESTEP +! first update the leaf water potential memory +!! do t=2, numLWPmem +!!ccohort_hydr%lwp_mem(t-1) = ccohort_hydr%lwp_mem(t) +!!end do +!!ccohort_hydr%lwp_mem(numLWPmem) = ccohort_hydr%psi_ag(1) +!!call flc_gs_from_psi(cCohort, ccohort_hydr%psi_ag(1)) + +!!refill_rate = -log(0.5)/(ccohort_hydr%refill_days*24._r8*3600._r8) ! s-1 +!!do k=1,n_hypool_ag +!!ccohort_hydr%flc_min_ag(k) = min(ccohort_hydr%flc_min_ag(k), ccohort_hydr%flc_ag(k)) +!!if(ccohort_hydr%psi_ag(k) >= ccohort_hydr%refill_thresh .and. & +!! ccohort_hydr%flc_ag(k) > ccohort_hydr%flc_min_ag(k)) then ! then refilling +!! ccohort_hydr%flc_min_ag(k) = ccohort_hydr%flc_ag(k) - & +!! (ccohort_hydr%flc_ag(k) - ccohort_hydr%flc_min_ag(k))*exp(-refill_rate*dtime) +!!end if +!!end do +!!do k=1,n_hypool_troot +!!ccohort_hydr%flc_min_troot(k) = min(ccohort_hydr%flc_min_troot(k), ccohort_hydr%flc_troot(k)) +!!if(ccohort_hydr%psi_troot(k) >= ccohort_hydr%refill_thresh .and. & +!! ccohort_hydr%flc_troot(k) > ccohort_hydr%flc_min_troot(k)) then ! then refilling +!! ccohort_hydr%flc_min_troot(k) = ccohort_hydr%flc_troot(k) - & +!! (ccohort_hydr%flc_troot(k) - ccohort_hydr%flc_min_troot(k))*exp(-refill_rate*dtime) +!!end if +!!end do +!!do j=1,site_hydr%nlevrhiz +!!ccohort_hydr%flc_min_aroot(j) = min(ccohort_hydr%flc_min_aroot(j), ccohort_hydr%flc_aroot(j)) +!!if(ccohort_hydr%psi_aroot(j) >= ccohort_hydr%refill_thresh .and. & +!! ccohort_hydr%flc_aroot(j) > ccohort_hydr%flc_min_aroot(j)) then ! then refilling +!! ccohort_hydr%flc_min_aroot(j) = ccohort_hydr%flc_aroot(j) - & +!! (ccohort_hydr%flc_aroot(j) - ccohort_hydr%flc_min_aroot(j))*exp(-refill_rate*dtime) +!!end if +!!end do +!!end subroutine UpdateLWPMemFLCMin diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index b3576cb989..adffe67d85 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -1,82 +1,105 @@ - module FATESPlantRespPhotosynthMod - - !------------------------------------------------------------------------------------- - ! !DESCRIPTION: - ! Calculates the plant respiration and photosynthetic fluxes for the FATES model - ! This code is similar to and was originally based off of the 'photosynthesis' - ! subroutine in the CLM model. - ! - ! Parameter for activation and deactivation energies were taken from: - ! Activation energy, from: - ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 - ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 - ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 - ! High temperature deactivation, from: - ! Leuning (2002) Plant, Cell and Environment 25:1205-1210 - ! The factor "c" scales the deactivation to a value of 1.0 at 25C - ! Photosynthesis and stomatal conductance parameters, from: - ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 - ! ------------------------------------------------------------------------------------ - - ! !USES: - - use FatesGlobals, only : endrun => fates_endrun - use FatesGlobals, only : fates_log - use FatesConstantsMod, only : r8 => fates_r8 - use FatesConstantsMod, only : itrue - use FatesConstantsMod, only : nearzero - use FatesInterfaceTypesMod, only : hlm_use_planthydro - use FatesInterfaceTypesMod, only : hlm_parteh_mode - use FatesInterfaceTypesMod, only : numpft - use FatesInterfaceTypesMod, only : nleafage - use EDTypesMod, only : maxpft - use EDTypesMod, only : nlevleaf - use EDTypesMod, only : nclmax - use PRTGenericMod, only : max_nleafage - use EDTypesMod, only : do_fates_salinity - use EDParamsMod, only : q10_mr - use PRTGenericMod, only : prt_carbon_allom_hyp - use PRTGenericMod, only : prt_cnp_flex_allom_hyp - use PRTGenericMod, only : all_carbon_elements - use PRTGenericMod, only : nitrogen_element - use PRTGenericMod, only : leaf_organ - use PRTGenericMod, only : fnrt_organ - use PRTGenericMod, only : sapw_organ - use PRTGenericMod, only : store_organ - use PRTGenericMod, only : repro_organ - use PRTGenericMod, only : struct_organ - use EDParamsMod, only : ED_val_base_mr_20, stomatal_model - use PRTParametersMod, only : prt_params - - ! CIME Globals - use shr_log_mod , only : errMsg => shr_log_errMsg - - implicit none - private - - public :: FatesPlantRespPhotosynthDrive ! Called by the HLM-Fates interface - - character(len=*), parameter, private :: sourcefile = & - __FILE__ - !------------------------------------------------------------------------------------- - - ! maximum stomatal resistance [s/m] (used across several procedures) - real(r8),parameter :: rsmax0 = 2.e8_r8 - - logical :: debug = .false. - !------------------------------------------------------------------------------------- - - ! Ratio of H2O/CO2 gas diffusion in stomatal airspace (approximate) - real(r8),parameter :: h2o_co2_stoma_diffuse_ratio = 1.6_r8 - - ! Ratio of H2O/CO2 gass diffusion in the leaf boundary layer (approximate) - real(r8),parameter :: h2o_co2_bl_diffuse_ratio = 1.4_r8 -contains + !------------------------------------------------------------------------------------- + ! !DESCRIPTION: + ! Calculates the plant respiration and photosynthetic fluxes for the FATES model + ! This code is similar to and was originally based off of the 'photosynthesis' + ! subroutine in the CLM model. + ! + ! Parameter for activation and deactivation energies were taken from: + ! Activation energy, from: + ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 + ! except TPU from: Harley et al (1992) Plant, Cell and Environment 15:271-282 + ! High temperature deactivation, from: + ! Leuning (2002) Plant, Cell and Environment 25:1205-1210 + ! The factor "c" scales the deactivation to a value of 1.0 at 25C + ! Photosynthesis and stomatal conductance parameters, from: + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 + ! ------------------------------------------------------------------------------------ + + ! !USES: + + use FatesGlobals, only : endrun => fates_endrun + use FatesGlobals, only : fates_log + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : itrue + use FatesConstantsMod, only : nearzero + use FatesConstantsMod, only : molar_mass_ratio_vapdry + use FatesConstantsMod, only : molar_mass_water + use FatesConstantsMod, only : rgas_J_K_mol + use FatesConstantsMod, only : fates_unset_r8 + use FatesInterfaceTypesMod, only : hlm_use_planthydro + use FatesInterfaceTypesMod, only : hlm_parteh_mode + use FatesInterfaceTypesMod, only : numpft + use FatesInterfaceTypesMod, only : nleafage + use EDTypesMod, only : maxpft + use EDTypesMod, only : nlevleaf + use EDTypesMod, only : nclmax + use PRTGenericMod, only : max_nleafage + use EDTypesMod, only : do_fates_salinity + use EDParamsMod, only : q10_mr + use PRTGenericMod, only : prt_carbon_allom_hyp + use PRTGenericMod, only : prt_cnp_flex_allom_hyp + use PRTGenericMod, only : all_carbon_elements + use PRTGenericMod, only : nitrogen_element + use PRTGenericMod, only : leaf_organ + use PRTGenericMod, only : fnrt_organ + use PRTGenericMod, only : sapw_organ + use PRTGenericMod, only : store_organ + use PRTGenericMod, only : repro_organ + use PRTGenericMod, only : struct_organ + use EDParamsMod, only : ED_val_base_mr_20, stomatal_model + use PRTParametersMod, only : prt_params + use EDPftvarcon , only : EDPftvarcon_inst - !-------------------------------------------------------------------------------------- + ! CIME Globals + use shr_log_mod , only : errMsg => shr_log_errMsg + + implicit none + private + + public :: FatesPlantRespPhotosynthDrive ! Called by the HLM-Fates interface + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + !------------------------------------------------------------------------------------- + + ! maximum stomatal resistance [s/m] (used across several procedures) + real(r8),parameter :: rsmax0 = 2.e8_r8 + + logical :: debug = .false. + !------------------------------------------------------------------------------------- + + ! Ratio of H2O/CO2 gas diffusion in stomatal airspace (approximate) + real(r8),parameter :: h2o_co2_stoma_diffuse_ratio = 1.6_r8 + + ! Ratio of H2O/CO2 gass diffusion in the leaf boundary layer (approximate) + real(r8),parameter :: h2o_co2_bl_diffuse_ratio = 1.4_r8 + + ! Constants used to define C3 versus C4 photosynth pathways + integer, parameter :: c3_path_index = 1 + integer, parameter :: c4_path_index = 0 + + + ! Constants used to define conductance models + integer, parameter :: medlyn_model = 2 + integer, parameter :: ballberry_model = 1 + + ! Alternatively, Gross Assimilation can be used to estimate + ! leaf co2 partial pressure and therefore conductance. The default + !is to use anet + logical, parameter :: use_agross = .false. + + + + + +contains + + !-------------------------------------------------------------------------------------- + subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! ----------------------------------------------------------------------------------- @@ -89,14 +112,13 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! !USES: - use EDPftvarcon , only : EDPftvarcon_inst - use FatesSynchronizedParamsMod , only : FatesSynchronizedParamsInst use EDTypesMod , only : ed_patch_type use EDTypesMod , only : ed_cohort_type use EDTypesMod , only : ed_site_type use EDTypesMod , only : maxpft - use EDTypesMod , only : dinc_ed + use EDTypesMod , only : dinc_vai + use EDTypesMod , only : dlower_vai use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : bc_out_type use EDCanopyStructureMod, only : calc_areaindex @@ -106,7 +128,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use FatesConstantsMod, only : rgas => rgas_J_K_kmol use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm use FatesParameterDerivedMod, only : param_derived - + use FatesAllometryMod, only : bleaf, bstore_allom use FatesAllometryMod, only : storage_fraction_of_target use FatesAllometryMod, only : set_root_fraction @@ -131,7 +153,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! 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 + ! 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. @@ -146,23 +168,23 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: lmr_z(nlevleaf,maxpft,nclmax) ! stomatal resistance [s/m] - real(r8) :: rs_z(nlevleaf,maxpft,nclmax) + 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) - + 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) :: kp_z ! leaf layer initial slope of CO2 response - ! curve (C4 plants) + 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) :: kp_z ! leaf layer initial slope of CO2 response + ! curve (C4 plants) real(r8) :: c13disc_z(nclmax,maxpft,nlevleaf) ! carbon 13 in newly assimilated carbon at leaf level - + 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) @@ -174,14 +196,14 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) 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) :: tcsoi ! Temperature response function for root respiration. + real(r8) :: tcsoi ! Temperature response function for root respiration. real(r8) :: tcwood ! Temperature response function for wood - + real(r8) :: elai ! exposed LAI (patch scale) - real(r8) :: live_stem_n ! Live stem (above-ground sapwood) - ! nitrogen content (kgN/plant) - real(r8) :: live_croot_n ! Live coarse root (below-ground sapwood) - ! nitrogen content (kgN/plant) + 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) :: sapw_c ! Sapwood carbon (kgC/plant) real(r8) :: store_c_target ! Target storage carbon (kgC/plant) real(r8) :: fnrt_c ! Fine root carbon (kgC/plant) @@ -189,32 +211,32 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: leaf_c ! Leaf carbon (kgC/plant) real(r8) :: leaf_n ! leaf nitrogen content (kgN/plant) real(r8) :: g_sb_leaves ! Mean combined (stomata+boundary layer) leaf conductance [m/s] - ! over all of the patch's leaves. The "sb" refers to the combined - ! "s"tomatal and "b"oundary layer. - ! This quantity is relevant on leaf surfaces. It does not - ! have units of /m2 leaf per say, but is implicitly on leaf surfaces + ! over all of the patch's leaves. The "sb" refers to the combined + ! "s"tomatal and "b"oundary layer. + ! This quantity is relevant on leaf surfaces. It does not + ! have units of /m2 leaf per say, but is implicitly on leaf surfaces real(r8) :: r_sb_leaves ! Mean leaf resistance over all the patch's leaves [s/m] - ! This is the direct reciprocal of g_sb_leaves + ! This is the direct reciprocal of g_sb_leaves real(r8) :: r_stomata ! Mean stomatal resistance across all leaves in the patch [s/m] - real(r8) :: maintresp_reduction_factor ! factor by which to reduce maintenance - ! respiration when storage pools are low + real(r8) :: maintresp_reduction_factor ! factor by which to reduce maintenance + ! respiration when storage pools are low real(r8) :: b_leaf ! leaf biomass kgC real(r8) :: frac ! storage pool as a fraction of target leaf biomass real(r8) :: check_elai ! This is a check on the effective LAI that is calculated - ! over each cohort x layer. + ! over each cohort x layer. real(r8) :: cohort_eleaf_area ! This is the effective leaf area [m2] reported by each cohort real(r8) :: lnc_top ! Leaf nitrogen content per unit area at canopy top [gN/m2] real(r8) :: lmr25top ! canopy top leaf maint resp rate at 25C ! for this plant or pft (umol CO2/m**2/s) - real(r8) :: leaf_inc ! LAI-only portion of the vegetation increment of dinc_ed + real(r8) :: leaf_inc ! LAI-only portion of the vegetation increment of dinc_vai real(r8) :: lai_canopy_above ! the LAI in the canopy layers above the layer of interest - real(r8) :: lai_layers_above ! the LAI in the leaf layers, within the current canopy, - ! above the leaf layer of interest + real(r8) :: lai_layers_above ! the LAI in the leaf layers, within the current canopy, + ! above the leaf layer of interest real(r8) :: lai_current ! the LAI in the current leaf layer real(r8) :: cumulative_lai ! the cumulative LAI, top down, to the leaf layer of interest - + real(r8) :: leaf_psi ! leaf xylem matric potential [MPa] (only meaningful/used w/ hydro) real(r8), allocatable :: rootfr_ft(:,:) ! Root fractions per depth and PFT ! ----------------------------------------------------------------------------------- @@ -222,7 +244,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! ! ----------------------------------------------------------------------------------- !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) + !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 @@ -248,1722 +270,1849 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) associate( & c3psn => EDPftvarcon_inst%c3psn , & - slatop => prt_params%slatop , & ! specific leaf area at top of canopy, - ! projected area basis [m^2/gC] - woody => prt_params%woody, & ! Is vegetation woody or not? + slatop => prt_params%slatop , & ! specific leaf area at top of canopy, + ! projected area basis [m^2/gC] + woody => prt_params%woody, & ! Is vegetation woody or not? stomatal_intercept => EDPftvarcon_inst%stomatal_intercept ) !Unstressed minimum stomatal conductance - do s = 1,nsites - - ! Multi-layer parameters scaled by leaf nitrogen profile. - ! Loop through each canopy layer to calculate nitrogen profile using - ! cumulative lai at the midpoint of the layer - - - - ! Pre-process some variables that are PFT dependent - ! but not environmentally dependent - ! ------------------------------------------------------------------------ - - allocate(rootfr_ft(numpft, bc_in(s)%nlevsoil)) - - do ft = 1,numpft - call set_root_fraction(rootfr_ft(ft,:), ft, & - bc_in(s)%zi_sisl) - end do - - - ifp = 0 - currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) - - ifp = ifp+1 - NCL_p = currentPatch%NCL_p - - ! Part I. Zero output boundary conditions - ! --------------------------------------------------------------------------- - bc_out(s)%rssun_pa(ifp) = 0._r8 - bc_out(s)%rssha_pa(ifp) = 0._r8 - - g_sb_leaves = 0._r8 - check_elai = 0._r8 - - ! Part II. Filter out patches - ! Patch level filter flag for photosynthesis calculations - ! has a short memory, flags: - ! 1 = patch has not been called - ! 2 = patch is currently marked for photosynthesis - ! 3 = patch has been called for photosynthesis already - ! --------------------------------------------------------------------------- - if(bc_in(s)%filter_photo_pa(ifp)==2)then - - - ! Part III. Calculate the number of sublayers for each pft and layer. - ! And then identify which layer/pft combinations have things in them. - ! Output: - ! currentPatch%ncan(:,:) - ! currentPatch%canopy_mask(:,:) - call UpdateCanopyNCanNRadPresent(currentPatch) - - - ! Part IV. Identify some environmentally derived parameters: - ! These quantities are biologically irrelevant - ! Michaelis-Menten constant for CO2 (Pa) - ! Michaelis-Menten constant for O2 (Pa) - ! CO2 compensation point (Pa) - ! leaf boundary layer conductance of h20 - ! constrained vapor pressure - call GetCanopyGasParameters(bc_in(s)%forc_pbot, & ! in - bc_in(s)%oair_pa(ifp), & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - bc_in(s)%tgcm_pa(ifp), & ! in - bc_in(s)%eair_pa(ifp), & ! in - bc_in(s)%esat_tv_pa(ifp), & ! in - bc_in(s)%rb_pa(ifp), & ! in - mm_kco2, & ! out - mm_ko2, & ! out - co2_cpoint, & ! out - cf, & ! out - gb_mol, & ! out - ceair) ! out - - - - - ! ------------------------------------------------------------------------ - ! Part VI: Loop over all leaf layers. - ! The concept of leaf layers is a result of the radiative transfer scheme. - ! A leaf layer has uniform radiation environment. Leaf layers are a group - ! of vegetation surfaces (stems and leaves) which inhabit the same - ! canopy-layer "CL", have the same functional type "ft" and within those - ! two partitions are further partitioned into vertical layers where - ! downwelling radiation attenuates in order. - ! In this phase we loop over the leaf layers and calculate the - ! photosynthesis and respiration of the layer (since all biophysical - ! properties are homogeneous). After this step, we can loop through - ! our cohort list, associate each cohort with its list of leaf-layers - ! and transfer these quantities to the cohort. - ! With plant hydraulics, we must realize that photosynthesis and - ! respiration will be different for leaves of each cohort in the leaf - ! layers, as they will have there own hydraulic limitations. - ! NOTE: Only need to flush mask on the number of used pfts, not the whole - ! scratch space. - ! ------------------------------------------------------------------------ - rate_mask_z(:,1:numpft,:) = .false. - - if(currentPatch%countcohorts > 0.0)then ! Ignore empty patches - - currentCohort => currentPatch%tallest - do while (associated(currentCohort)) ! Cohort loop - - ! Identify the canopy layer (cl), functional type (ft) - ! and the leaf layer (IV) for this cohort - ft = currentCohort%pft - cl = currentCohort%canopy_layer - - call bleaf(currentCohort%dbh,currentCohort%pft,currentCohort%canopy_trim,store_c_target) -! call bstore_allom(currentCohort%dbh,currentCohort%pft, & -! currentCohort%canopy_trim,store_c_target) - - call storage_fraction_of_target(store_c_target, & + do s = 1,nsites + + ! Multi-layer parameters scaled by leaf nitrogen profile. + ! Loop through each canopy layer to calculate nitrogen profile using + ! cumulative lai at the midpoint of the layer + + + + ! Pre-process some variables that are PFT dependent + ! but not environmentally dependent + ! ------------------------------------------------------------------------ + + allocate(rootfr_ft(numpft, bc_in(s)%nlevsoil)) + + do ft = 1,numpft + call set_root_fraction(rootfr_ft(ft,:), ft, & + bc_in(s)%zi_sisl, & + bc_in(s)%max_rooting_depth_index_col) + end do + + + ifp = 0 + currentpatch => sites(s)%oldest_patch + do while (associated(currentpatch)) + if(currentpatch%nocomp_pft_label.ne.0)then + ifp = ifp+1 + NCL_p = currentPatch%NCL_p + + ! Part I. Zero output boundary conditions + ! --------------------------------------------------------------------------- + bc_out(s)%rssun_pa(ifp) = 0._r8 + bc_out(s)%rssha_pa(ifp) = 0._r8 + + g_sb_leaves = 0._r8 + check_elai = 0._r8 + + ! Part II. Filter out patches + ! Patch level filter flag for photosynthesis calculations + ! has a short memory, flags: + ! 1 = patch has not been called + ! 2 = patch is currently marked for photosynthesis + ! 3 = patch has been called for photosynthesis already + ! --------------------------------------------------------------------------- + if(bc_in(s)%filter_photo_pa(ifp)==2)then + + + ! Part III. Calculate the number of sublayers for each pft and layer. + ! And then identify which layer/pft combinations have things in them. + ! Output: + ! currentPatch%ncan(:,:) + ! currentPatch%canopy_mask(:,:) + call UpdateCanopyNCanNRadPresent(currentPatch) + + + ! Part IV. Identify some environmentally derived parameters: + ! These quantities are biologically irrelevant + ! Michaelis-Menten constant for CO2 (Pa) + ! Michaelis-Menten constant for O2 (Pa) + ! CO2 compensation point (Pa) + ! leaf boundary layer conductance of h20 + ! constrained vapor pressure + call GetCanopyGasParameters(bc_in(s)%forc_pbot, & ! in + bc_in(s)%oair_pa(ifp), & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + bc_in(s)%tgcm_pa(ifp), & ! in + bc_in(s)%eair_pa(ifp), & ! in + bc_in(s)%esat_tv_pa(ifp), & ! in + bc_in(s)%rb_pa(ifp), & ! in + mm_kco2, & ! out + mm_ko2, & ! out + co2_cpoint, & ! out + cf, & ! out + gb_mol, & ! out + ceair) ! out + + + + + ! ------------------------------------------------------------------------ + ! Part VI: Loop over all leaf layers. + ! The concept of leaf layers is a result of the radiative transfer scheme. + ! A leaf layer has uniform radiation environment. Leaf layers are a group + ! of vegetation surfaces (stems and leaves) which inhabit the same + ! canopy-layer "CL", have the same functional type "ft" and within those + ! two partitions are further partitioned into vertical layers where + ! downwelling radiation attenuates in order. + ! In this phase we loop over the leaf layers and calculate the + ! photosynthesis and respiration of the layer (since all biophysical + ! properties are homogeneous). After this step, we can loop through + ! our cohort list, associate each cohort with its list of leaf-layers + ! and transfer these quantities to the cohort. + ! With plant hydraulics, we must realize that photosynthesis and + ! respiration will be different for leaves of each cohort in the leaf + ! layers, as they will have there own hydraulic limitations. + ! NOTE: Only need to flush mask on the number of used pfts, not the whole + ! scratch space. + ! ------------------------------------------------------------------------ + rate_mask_z(:,1:numpft,:) = .false. + + if(currentPatch%countcohorts > 0.0)then ! Ignore empty patches + + currentCohort => currentPatch%tallest + do while (associated(currentCohort)) ! Cohort loop + + ! Identify the canopy layer (cl), functional type (ft) + ! and the leaf layer (IV) for this cohort + ft = currentCohort%pft + cl = currentCohort%canopy_layer + + call bleaf(currentCohort%dbh,currentCohort%pft,currentCohort%canopy_trim,store_c_target) + ! call bstore_allom(currentCohort%dbh,currentCohort%pft, & + ! currentCohort%canopy_trim,store_c_target) + + call storage_fraction_of_target(store_c_target, & currentCohort%prt%GetState(store_organ, all_carbon_elements), & frac) - call lowstorage_maintresp_reduction(frac,currentCohort%pft, & - maintresp_reduction_factor) - - ! are there any leaves of this pft in this layer? - if(currentPatch%canopy_mask(cl,ft) == 1)then - - ! Loop over leaf-layers - do iv = 1,currentCohort%nv - - ! ------------------------------------------------------------ - ! If we are doing plant hydro-dynamics (or any run-type - ! where cohorts may generate different photosynthetic rates - ! of other cohorts in the same canopy-pft-layer combo), - ! we re-calculate the leaf biophysical rates for the - ! cohort-layer combo of interest. - ! but in the vanilla case, we only re-calculate if it has - ! not been done yet. - ! Other cases where we need to solve for every cohort - ! in every leaf layer: nutrient dynamic mode, multiple leaf - ! age classes - ! ------------------------------------------------------------ - - if ( .not.rate_mask_z(iv,ft,cl) .or. & + call lowstorage_maintresp_reduction(frac,currentCohort%pft, & + maintresp_reduction_factor) + + ! are there any leaves of this pft in this layer? + if(currentPatch%canopy_mask(cl,ft) == 1)then + + ! Loop over leaf-layers + do iv = 1,currentCohort%nv + + ! ------------------------------------------------------------ + ! If we are doing plant hydro-dynamics (or any run-type + ! where cohorts may generate different photosynthetic rates + ! of other cohorts in the same canopy-pft-layer combo), + ! we re-calculate the leaf biophysical rates for the + ! cohort-layer combo of interest. + ! but in the vanilla case, we only re-calculate if it has + ! not been done yet. + ! Other cases where we need to solve for every cohort + ! in every leaf layer: nutrient dynamic mode, multiple leaf + ! age classes + ! ------------------------------------------------------------ + + if ( .not.rate_mask_z(iv,ft,cl) .or. & (hlm_use_planthydro.eq.itrue) .or. & (nleafage > 1) .or. & (hlm_parteh_mode .ne. prt_carbon_allom_hyp ) ) then - + if (hlm_use_planthydro.eq.itrue ) then - - stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentCohort%co_hydr%btran ) - btran_eff = currentCohort%co_hydr%btran - - ! dinc_ed is the total vegetation area index of each "leaf" layer - ! we convert to the leaf only portion of the increment - ! ------------------------------------------------------ - leaf_inc = dinc_ed * & - currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) - - ! Now calculate the cumulative top-down lai of the current layer's midpoint - lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) - lai_layers_above = leaf_inc * (iv-1) - lai_current = min(leaf_inc, currentCohort%treelai - lai_layers_above) - cumulative_lai = lai_canopy_above + lai_layers_above + 0.5*lai_current - - else - - stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentPatch%btran_ft(ft) ) - - btran_eff = currentPatch%btran_ft(ft) - ! For consistency sake, we use total LAI here, and not exposed - ! if the plant is under-snow, it will be effectively dormant for - ! the purposes of nscaler - - cumulative_lai = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + & - sum(currentPatch%tlai_profile(cl,ft,1:iv-1)) + & - 0.5*currentPatch%tlai_profile(cl,ft,iv) - - - end if - - if(do_fates_salinity)then - btran_eff = btran_eff*currentPatch%bstress_sal_ft(ft) - endif - - - ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 used - ! kn = 0.11. Here, derive kn from vcmax25 as in Lloyd et al - ! (2010) Biogeosciences, 7, 1833-1859 - - kn = decay_coeff_kn(ft,currentCohort%vcmax25top) - - ! Scale for leaf nitrogen profile - nscaler = exp(-kn * cumulative_lai) - - ! Leaf maintenance respiration to match the base rate used in CN - ! but with the new temperature functions for C3 and C4 plants. - - ! CN respiration has units: g C / g N [leaf] / s. This needs to be - ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s - - ! Then scale this value at the top of the canopy for canopy depth - ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp) - - lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) - - case (prt_cnp_flex_allom_hyp) - - leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) - if( (leaf_c*slatop(ft)) > nearzero) then - leaf_n = currentCohort%prt%GetState(leaf_organ, nitrogen_element) - lnc_top = leaf_n / (slatop(ft) * leaf_c ) - else - lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) - end if - - ! If one wants to break coupling with dynamic N conentrations, - ! use the stoichiometry parameter - ! lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) - - end select - - lmr25top = 2.525e-6_r8 * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) - lmr25top = lmr25top * lnc_top / (umolC_to_kgC * g_per_kg) - - - ! Part VII: Calculate dark respiration (leaf maintenance) for this layer - call LeafLayerMaintenanceRespiration( lmr25top, & ! in - nscaler, & ! in - ft, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - lmr_z(iv,ft,cl)) ! out - - ! Part VII: Calculate (1) maximum rate of carboxylation (vcmax), - ! (2) maximum electron transport rate, (3) triose phosphate - ! utilization rate and (4) the initial slope of CO2 response curve - ! (C4 plants). Earlier we calculated their base rates as dictated - ! by their plant functional type and some simple scaling rules for - ! nitrogen limitation baesd on canopy position (not prognostic). - ! These rates are the specific rates used in the actual photosynthesis - ! calculations that take localized environmental effects (temperature) - ! into consideration. - - - - call LeafLayerBiophysicalRates(currentPatch%ed_parsun_z(cl,ft,iv), & ! in - ft, & ! in - currentCohort%vcmax25top, & ! in - currentCohort%jmax25top, & ! in - currentCohort%kp25top, & ! in - nscaler, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - btran_eff, & ! in - vcmax_z, & ! out - jmax_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 - kp_z, & ! in - bc_in(s)%t_veg_pa(ifp), & ! in - bc_in(s)%esat_tv_pa(ifp), & ! in - bc_in(s)%forc_pbot, & ! in - bc_in(s)%cair_pa(ifp), & ! in - bc_in(s)%oair_pa(ifp), & ! in - btran_eff, & ! in - stomatal_intercept_btran, & ! in - cf, & ! in - gb_mol, & ! in - ceair, & ! in - mm_kco2, & ! in - mm_ko2, & ! in - co2_cpoint, & ! in - lmr_z(iv,ft,cl), & ! in - currentPatch%psn_z(cl,ft,iv), & ! out - rs_z(iv,ft,cl), & ! out - anet_av_z(iv,ft,cl), & ! out - c13disc_z(cl,ft,iv)) ! out - - rate_mask_z(iv,ft,cl) = .true. - end if - end do - - ! Zero cohort flux accumulators. - currentCohort%npp_tstep = 0.0_r8 - currentCohort%resp_tstep = 0.0_r8 - currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rdark = 0.0_r8 - currentCohort%resp_m = 0.0_r8 - currentCohort%ts_net_uptake = 0.0_r8 - currentCohort%c13disc_clm = 0.0_r8 - - ! --------------------------------------------------------------- - ! Part VII: Transfer leaf flux rates (like maintenance respiration, - ! carbon assimilation and conductance) that are defined by the - ! leaf layer (which is area independent, ie /m2) onto each cohort - ! (where the rates become per cohort, ie /individual). Most likely - ! a sum over layers. - ! --------------------------------------------------------------- - nv = currentCohort%nv - call ScaleLeafLayerFluxToCohort(nv, & !in - currentPatch%psn_z(cl,ft,1:nv), & !in - lmr_z(1:nv,ft,cl), & !in - rs_z(1:nv,ft,cl), & !in - currentPatch%elai_profile(cl,ft,1:nv), & !in - c13disc_z(cl, ft, 1:nv), & !in - currentCohort%c_area, & !in - currentCohort%n, & !in - bc_in(s)%rb_pa(ifp), & !in - maintresp_reduction_factor, & !in - currentCohort%g_sb_laweight, & !out - currentCohort%gpp_tstep, & !out - currentCohort%rdark, & !out - currentCohort%c13disc_clm, & !out - cohort_eleaf_area) !out - - ! Net Uptake does not need to be scaled, just transfer directly - currentCohort%ts_net_uptake(1:nv) = anet_av_z(1:nv,ft,cl) * umolC_to_kgC - - else - - ! In this case, the cohort had no leaves, - ! so no productivity,conductance, transpiration uptake - ! or dark respiration - cohort_eleaf_area = 0.0_r8 - currentCohort%gpp_tstep = 0.0_r8 - currentCohort%rdark = 0.0_r8 - currentCohort%g_sb_laweight = 0.0_r8 - currentCohort%ts_net_uptake(:) = 0.0_r8 - - end if ! if(currentPatch%canopy_mask(cl,ft) == 1)then - - - ! ------------------------------------------------------------------ - ! Part VIII: Calculate maintenance respiration in the sapwood and - ! fine root pools. - ! ------------------------------------------------------------------ - - ! Calculate the amount of nitrogen in the above and below ground - ! stem and root pools, used for maint resp - ! We are using the fine-root C:N ratio as an approximation for - ! the sapwood pools. - ! Units are in (kgN/plant) - ! ------------------------------------------------------------------ - - sapw_c = currentCohort%prt%GetState(sapw_organ, all_carbon_elements) - fnrt_c = currentCohort%prt%GetState(fnrt_organ, all_carbon_elements) - - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp) - - live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & - sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) - - live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & - sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) - - fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,fnrt_organ) - - case(prt_cnp_flex_allom_hyp) - - live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & - currentCohort%prt%GetState(sapw_organ, nitrogen_element) - - live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & - currentCohort%prt%GetState(sapw_organ, nitrogen_element) - - fnrt_n = currentCohort%prt%GetState(fnrt_organ, nitrogen_element) - - ! If one wants to break coupling with dynamic N conentrations, - ! use the stoichiometry parameter - ! - ! live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & - ! sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) - ! live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & - ! sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) - ! fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,fnrt_organ) - - - case default - - - end select - - !------------------------------------------------------------------------------ - ! Calculate Whole Plant Respiration - ! (this doesn't really need to be in this iteration at all, surely?) - ! Response: (RGK 12-2016): I think the positioning of these calls is - ! appropriate as of now. Maintenance calculations in sapwood and roots - ! vary by cohort and with changing temperature at the minimum, and there are - ! no sub-pools chopping up those pools any finer that need to be dealt with. - !------------------------------------------------------------------------------ - - ! Live stem MR (kgC/plant/s) (above ground sapwood) - ! ------------------------------------------------------------------ - if ( int(woody(ft)) == itrue) then - tcwood = q10_mr**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) - ! kgC/s = kgN * kgC/kgN/s - currentCohort%livestem_mr = live_stem_n * ED_val_base_mr_20 * tcwood * maintresp_reduction_factor - else - currentCohort%livestem_mr = 0._r8 - end if - - - ! Fine Root MR (kgC/plant/s) - ! ------------------------------------------------------------------ - currentCohort%froot_mr = 0._r8 - do j = 1,bc_in(s)%nlevsoil - tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) - currentCohort%froot_mr = currentCohort%froot_mr + & + + stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentCohort%co_hydr%btran ) + btran_eff = currentCohort%co_hydr%btran + + ! dinc_vai(:) is the total vegetation area index of each "leaf" layer + ! we convert to the leaf only portion of the increment + ! ------------------------------------------------------ + leaf_inc = dinc_vai(iv) * & + currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) + + ! Now calculate the cumulative top-down lai of the current layer's midpoint + lai_canopy_above = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + + lai_layers_above = (dlower_vai(iv) - dinc_vai(iv)) * & + currentCohort%treelai/(currentCohort%treelai+currentCohort%treesai) + lai_current = min(leaf_inc, currentCohort%treelai - lai_layers_above) + cumulative_lai = lai_canopy_above + lai_layers_above + 0.5*lai_current + + leaf_psi = currentCohort%co_hydr%psi_ag(1) + + else + + stomatal_intercept_btran = max( cf/rsmax0,stomatal_intercept(ft)*currentPatch%btran_ft(ft) ) + + btran_eff = currentPatch%btran_ft(ft) + ! For consistency sake, we use total LAI here, and not exposed + ! if the plant is under-snow, it will be effectively dormant for + ! the purposes of nscaler + + cumulative_lai = sum(currentPatch%canopy_layer_tlai(1:cl-1)) + & + sum(currentPatch%tlai_profile(cl,ft,1:iv-1)) + & + 0.5*currentPatch%tlai_profile(cl,ft,iv) + + leaf_psi = fates_unset_r8 + + end if + + if(do_fates_salinity)then + btran_eff = btran_eff*currentPatch%bstress_sal_ft(ft) + endif + + + ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 used + ! kn = 0.11. Here, derive kn from vcmax25 as in Lloyd et al + ! (2010) Biogeosciences, 7, 1833-1859 + + kn = decay_coeff_kn(ft,currentCohort%vcmax25top) + + ! Scale for leaf nitrogen profile + nscaler = exp(-kn * cumulative_lai) + + ! Leaf maintenance respiration to match the base rate used in CN + ! but with the new temperature functions for C3 and C4 plants. + + ! CN respiration has units: g C / g N [leaf] / s. This needs to be + ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s + + ! Then scale this value at the top of the canopy for canopy depth + ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp) + + lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) + + case (prt_cnp_flex_allom_hyp) + + leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) + if( (leaf_c*slatop(ft)) > nearzero) then + leaf_n = currentCohort%prt%GetState(leaf_organ, nitrogen_element) + lnc_top = leaf_n / (slatop(ft) * leaf_c ) + else + lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) + end if + + ! If one wants to break coupling with dynamic N conentrations, + ! use the stoichiometry parameter + ! lnc_top = prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(leaf_organ))/slatop(ft) + + end select + + lmr25top = 2.525e-6_r8 * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) + lmr25top = lmr25top * lnc_top / (umolC_to_kgC * g_per_kg) + + + ! Part VII: Calculate dark respiration (leaf maintenance) for this layer + call LeafLayerMaintenanceRespiration( lmr25top, & ! in + nscaler, & ! in + ft, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + lmr_z(iv,ft,cl)) ! out + + ! Part VII: Calculate (1) maximum rate of carboxylation (vcmax), + ! (2) maximum electron transport rate, (3) triose phosphate + ! utilization rate and (4) the initial slope of CO2 response curve + ! (C4 plants). Earlier we calculated their base rates as dictated + ! by their plant functional type and some simple scaling rules for + ! nitrogen limitation baesd on canopy position (not prognostic). + ! These rates are the specific rates used in the actual photosynthesis + ! calculations that take localized environmental effects (temperature) + ! into consideration. + + + + call LeafLayerBiophysicalRates(currentPatch%ed_parsun_z(cl,ft,iv), & ! in + ft, & ! in + currentCohort%vcmax25top, & ! in + currentCohort%jmax25top, & ! in + currentCohort%kp25top, & ! in + nscaler, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + btran_eff, & ! in + vcmax_z, & ! out + jmax_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 + kp_z, & ! in + bc_in(s)%t_veg_pa(ifp), & ! in + bc_in(s)%esat_tv_pa(ifp), & ! in + bc_in(s)%forc_pbot, & ! in + bc_in(s)%cair_pa(ifp), & ! in + bc_in(s)%oair_pa(ifp), & ! in + btran_eff, & ! in + stomatal_intercept_btran, & ! in + cf, & ! in + gb_mol, & ! in + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr_z(iv,ft,cl), & ! in + leaf_psi, & ! in + bc_in(s)%rb_pa(ifp), & ! in + currentPatch%psn_z(cl,ft,iv), & ! out + rs_z(iv,ft,cl), & ! out + anet_av_z(iv,ft,cl), & ! out + c13disc_z(cl,ft,iv)) ! out + + rate_mask_z(iv,ft,cl) = .true. + end if + end do + + ! Zero cohort flux accumulators. + currentCohort%npp_tstep = 0.0_r8 + currentCohort%resp_tstep = 0.0_r8 + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rdark = 0.0_r8 + currentCohort%resp_m = 0.0_r8 + currentCohort%ts_net_uptake = 0.0_r8 + currentCohort%c13disc_clm = 0.0_r8 + + ! --------------------------------------------------------------- + ! Part VII: Transfer leaf flux rates (like maintenance respiration, + ! carbon assimilation and conductance) that are defined by the + ! leaf layer (which is area independent, ie /m2) onto each cohort + ! (where the rates become per cohort, ie /individual). Most likely + ! a sum over layers. + ! --------------------------------------------------------------- + nv = currentCohort%nv + call ScaleLeafLayerFluxToCohort(nv, & !in + currentPatch%psn_z(cl,ft,1:nv), & !in + lmr_z(1:nv,ft,cl), & !in + rs_z(1:nv,ft,cl), & !in + currentPatch%elai_profile(cl,ft,1:nv), & !in + c13disc_z(cl, ft, 1:nv), & !in + currentCohort%c_area, & !in + currentCohort%n, & !in + bc_in(s)%rb_pa(ifp), & !in + maintresp_reduction_factor, & !in + currentCohort%g_sb_laweight, & !out + currentCohort%gpp_tstep, & !out + currentCohort%rdark, & !out + currentCohort%c13disc_clm, & !out + cohort_eleaf_area) !out + + ! Net Uptake does not need to be scaled, just transfer directly + currentCohort%ts_net_uptake(1:nv) = anet_av_z(1:nv,ft,cl) * umolC_to_kgC + + else + + ! In this case, the cohort had no leaves, + ! so no productivity,conductance, transpiration uptake + ! or dark respiration + cohort_eleaf_area = 0.0_r8 + currentCohort%gpp_tstep = 0.0_r8 + currentCohort%rdark = 0.0_r8 + currentCohort%g_sb_laweight = 0.0_r8 + currentCohort%ts_net_uptake(:) = 0.0_r8 + + end if ! if(currentPatch%canopy_mask(cl,ft) == 1)then + + + ! ------------------------------------------------------------------ + ! Part VIII: Calculate maintenance respiration in the sapwood and + ! fine root pools. + ! ------------------------------------------------------------------ + + ! Calculate the amount of nitrogen in the above and below ground + ! stem and root pools, used for maint resp + ! We are using the fine-root C:N ratio as an approximation for + ! the sapwood pools. + ! Units are in (kgN/plant) + ! ------------------------------------------------------------------ + + sapw_c = currentCohort%prt%GetState(sapw_organ, all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ, all_carbon_elements) + + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp) + + live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & + sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) + + live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & + sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) + + fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(fnrt_organ)) + + case(prt_cnp_flex_allom_hyp) + + live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & + currentCohort%prt%GetState(sapw_organ, nitrogen_element) + + live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & + currentCohort%prt%GetState(sapw_organ, nitrogen_element) + + fnrt_n = currentCohort%prt%GetState(fnrt_organ, nitrogen_element) + + ! If one wants to break coupling with dynamic N conentrations, + ! use the stoichiometry parameter + ! + ! live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & + ! sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) + ! live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & + ! sapw_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(sapw_organ)) + ! fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,prt_params%organ_param_id(fnrt_organ)) + + + case default + + + end select + + !------------------------------------------------------------------------------ + ! Calculate Whole Plant Respiration + ! (this doesn't really need to be in this iteration at all, surely?) + ! Response: (RGK 12-2016): I think the positioning of these calls is + ! appropriate as of now. Maintenance calculations in sapwood and roots + ! vary by cohort and with changing temperature at the minimum, and there are + ! no sub-pools chopping up those pools any finer that need to be dealt with. + !------------------------------------------------------------------------------ + + ! Live stem MR (kgC/plant/s) (above ground sapwood) + ! ------------------------------------------------------------------ + if ( int(woody(ft)) == itrue) then + tcwood = q10_mr**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) + ! kgC/s = kgN * kgC/kgN/s + currentCohort%livestem_mr = live_stem_n * ED_val_base_mr_20 * tcwood * maintresp_reduction_factor + else + currentCohort%livestem_mr = 0._r8 + end if + + + ! Fine Root MR (kgC/plant/s) + ! ------------------------------------------------------------------ + currentCohort%froot_mr = 0._r8 + do j = 1,bc_in(s)%nlevsoil + tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) + currentCohort%froot_mr = currentCohort%froot_mr + & fnrt_n * ED_val_base_mr_20 * tcsoi * rootfr_ft(ft,j) * maintresp_reduction_factor - enddo - - ! Coarse Root MR (kgC/plant/s) (below ground sapwood) - ! ------------------------------------------------------------------ - if ( int(woody(ft)) == itrue) then - currentCohort%livecroot_mr = 0._r8 - do j = 1,bc_in(s)%nlevsoil - ! Soil temperature used to adjust base rate of MR - tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) - currentCohort%livecroot_mr = currentCohort%livecroot_mr + & + enddo + + ! Coarse Root MR (kgC/plant/s) (below ground sapwood) + ! ------------------------------------------------------------------ + if ( int(woody(ft)) == itrue) then + currentCohort%livecroot_mr = 0._r8 + do j = 1,bc_in(s)%nlevsoil + ! Soil temperature used to adjust base rate of MR + tcsoi = q10_mr**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) + currentCohort%livecroot_mr = currentCohort%livecroot_mr + & live_croot_n * ED_val_base_mr_20 * tcsoi * & rootfr_ft(ft,j) * maintresp_reduction_factor - enddo - else - currentCohort%livecroot_mr = 0._r8 - end if - - - ! ------------------------------------------------------------------ - ! Part IX: Perform some unit conversions (rate to integrated) and - ! calcualate some fluxes that are sums and nets of the base fluxes - ! ------------------------------------------------------------------ - - if ( debug ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m - if ( debug ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark - if ( debug ) write(fates_log(),*) 'EDPhoto 906 ', currentCohort%livestem_mr - if ( debug ) write(fates_log(),*) 'EDPhoto 907 ', currentCohort%livecroot_mr - if ( debug ) write(fates_log(),*) 'EDPhoto 908 ', currentCohort%froot_mr - - - - ! add on whole plant respiration values in kgC/indiv/s-1 - currentCohort%resp_m = currentCohort%livestem_mr + & - currentCohort%livecroot_mr + & - currentCohort%froot_mr - - ! no drought response right now.. something like: - ! resp_m = resp_m * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft) * & - ! EDPftvarcon_inst%resp_drought_response(ft)) - - currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark - - ! convert from kgC/indiv/s to kgC/indiv/timestep - currentCohort%resp_m = currentCohort%resp_m * dtime - currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime - currentCohort%ts_net_uptake = currentCohort%ts_net_uptake * dtime - - if ( debug ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep - if ( debug ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep - if ( debug ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m - - - currentCohort%resp_g_tstep = prt_params%grperc(ft) * & - (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) - - - currentCohort%resp_tstep = currentCohort%resp_m + & - currentCohort%resp_g_tstep ! kgC/indiv/ts - currentCohort%npp_tstep = currentCohort%gpp_tstep - & - currentCohort%resp_tstep ! kgC/indiv/ts - - ! Accumulate the combined conductance (stomatal+leaf boundary layer) - ! Note that currentCohort%g_sb_laweight is weighted by the leaf area - ! of each cohort and has units of [m/s] * [m2 leaf] - - g_sb_leaves = g_sb_leaves + currentCohort%g_sb_laweight - - ! Accumulate the total effective leaf area from all cohorts - ! in this patch. Normalize by canopy area outside the loop - check_elai = check_elai + cohort_eleaf_area - - currentCohort => currentCohort%shorter - - enddo ! end cohort loop. - end if !count_cohorts is more than zero. - - check_elai = check_elai / currentPatch%total_canopy_area - elai = calc_areaindex(currentPatch,'elai') - - ! Normalize canopy total conductance by the effective LAI - ! The value here was integrated over each cohort x leaf layer - ! and was weighted by m2 of effective leaf area for each layer - - if(check_elai>tiny(check_elai)) then - - ! Normalize the leaf-area weighted canopy conductance - ! The denominator is the total effective leaf area in the canopy, - ! units of [m/s]*[m2] / [m2] = [m/s] - g_sb_leaves = g_sb_leaves / (elai*currentPatch%total_canopy_area) - - if( g_sb_leaves > (1._r8/rsmax0) ) then - - ! Combined mean leaf resistance is the inverse of mean leaf conductance - r_sb_leaves = 1.0_r8/g_sb_leaves - - if (r_sb_leaves currentPatch%younger - - end do - - deallocate(rootfr_ft) - - end do !site loop - - end associate - end subroutine FatesPlantRespPhotosynthDrive + enddo + else + currentCohort%livecroot_mr = 0._r8 + end if + + + ! ------------------------------------------------------------------ + ! Part IX: Perform some unit conversions (rate to integrated) and + ! calcualate some fluxes that are sums and nets of the base fluxes + ! ------------------------------------------------------------------ + + if ( debug ) write(fates_log(),*) 'EDPhoto 904 ', currentCohort%resp_m + if ( debug ) write(fates_log(),*) 'EDPhoto 905 ', currentCohort%rdark + if ( debug ) write(fates_log(),*) 'EDPhoto 906 ', currentCohort%livestem_mr + if ( debug ) write(fates_log(),*) 'EDPhoto 907 ', currentCohort%livecroot_mr + if ( debug ) write(fates_log(),*) 'EDPhoto 908 ', currentCohort%froot_mr + + + + ! add on whole plant respiration values in kgC/indiv/s-1 + currentCohort%resp_m = currentCohort%livestem_mr + & + currentCohort%livecroot_mr + & + currentCohort%froot_mr + + ! no drought response right now.. something like: + ! resp_m = resp_m * (1.0_r8 - currentPatch%btran_ft(currentCohort%pft) * & + ! EDPftvarcon_inst%resp_drought_response(ft)) + + currentCohort%resp_m = currentCohort%resp_m + currentCohort%rdark + + ! convert from kgC/indiv/s to kgC/indiv/timestep + currentCohort%resp_m = currentCohort%resp_m * dtime + currentCohort%gpp_tstep = currentCohort%gpp_tstep * dtime + currentCohort%ts_net_uptake = currentCohort%ts_net_uptake * dtime + + if ( debug ) write(fates_log(),*) 'EDPhoto 911 ', currentCohort%gpp_tstep + if ( debug ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep + if ( debug ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m + + + currentCohort%resp_g_tstep = prt_params%grperc(ft) * & + (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) + + + currentCohort%resp_tstep = currentCohort%resp_m + & + currentCohort%resp_g_tstep ! kgC/indiv/ts + currentCohort%npp_tstep = currentCohort%gpp_tstep - & + currentCohort%resp_tstep ! kgC/indiv/ts + + ! Accumulate the combined conductance (stomatal+leaf boundary layer) + ! Note that currentCohort%g_sb_laweight is weighted by the leaf area + ! of each cohort and has units of [m/s] * [m2 leaf] + + g_sb_leaves = g_sb_leaves + currentCohort%g_sb_laweight + + ! Accumulate the total effective leaf area from all cohorts + ! in this patch. Normalize by canopy area outside the loop + check_elai = check_elai + cohort_eleaf_area + + currentCohort => currentCohort%shorter + + enddo ! end cohort loop. + end if !count_cohorts is more than zero. + + check_elai = check_elai / currentPatch%total_canopy_area + elai = calc_areaindex(currentPatch,'elai') + + ! Normalize canopy total conductance by the effective LAI + ! The value here was integrated over each cohort x leaf layer + ! and was weighted by m2 of effective leaf area for each layer + + if(check_elai>tiny(check_elai)) then + + ! Normalize the leaf-area weighted canopy conductance + ! The denominator is the total effective leaf area in the canopy, + ! units of [m/s]*[m2] / [m2] = [m/s] + g_sb_leaves = g_sb_leaves / (elai*currentPatch%total_canopy_area) + + if( g_sb_leaves > (1._r8/rsmax0) ) then + + ! Combined mean leaf resistance is the inverse of mean leaf conductance + r_sb_leaves = 1.0_r8/g_sb_leaves + + if (r_sb_leaves currentPatch%younger + end do + + deallocate(rootfr_ft) + + end do !site loop + + end associate +end subroutine FatesPlantRespPhotosynthDrive + +! ======================================================================================= + +subroutine LeafLayerPhotosynthesis(f_sun_lsl, & ! in + parsun_lsl, & ! in + parsha_lsl, & ! in + laisun_lsl, & ! in + laisha_lsl, & ! in + canopy_area_lsl, & ! in + ft, & ! in + vcmax, & ! in + jmax, & ! in + co2_rcurve_islope, & ! in + veg_tempk, & ! in + veg_esat, & ! in + can_press, & ! in + can_co2_ppress, & ! in + can_o2_ppress, & ! in + btran, & ! in + stomatal_intercept_btran, & ! in + cf, & ! in + gb_mol, & ! in + ceair, & ! in + mm_kco2, & ! in + mm_ko2, & ! in + co2_cpoint, & ! in + lmr, & ! in + leaf_psi, & ! in + rb, & ! in + psn_out, & ! out + rstoma_out, & ! out + anet_av_out, & ! out + c13disc_z) ! out + + + ! ------------------------------------------------------------------------------------ + ! This subroutine calculates photosynthesis and stomatal conductance within each leaf + ! sublayer. + ! 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 EDParamsMod , only : theta_cj_c3, theta_cj_c4 + + + ! 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) :: co2_rcurve_islope ! initial slope of CO2 response curve (C4 plants) + real(r8), intent(in) :: veg_tempk ! vegetation temperature + real(r8), intent(in) :: veg_esat ! saturation vapor pressure at veg_tempk (Pa) + + ! Important Note on the following gas pressures. This photosynthesis scheme will iteratively + ! solve for the co2 partial pressure at the leaf surface (ie in the stomata). The reference + ! point for these input values are NOT within that boundary layer that separates the stomata from + ! the canopy air space. The reference point for these is on the outside of that boundary + ! layer. This routine, which operates at the leaf scale, makes no assumptions about what the + ! scale of the refernce is, it could be lower atmosphere, it could be within the canopy + ! but most likely it is the closest value one can get to the edge of the leaf's boundary + ! layer. We use the convention "can_" because a reference point of within the canopy + ! ia a best reasonable scenario of where we can get that information from. + + real(r8), intent(in) :: can_press ! Air pressure NEAR the surface of the leaf (Pa) + real(r8), intent(in) :: can_co2_ppress ! Partial pressure of CO2 NEAR the leaf surface (Pa) + real(r8), intent(in) :: can_o2_ppress ! Partial pressure of O2 NEAR the leaf surface (Pa) + real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) + real(r8), intent(in) :: stomatal_intercept_btran !water-stressed minimum stomatal conductance (umol H2O/m**2/s) + real(r8), intent(in) :: cf ! s m**2/umol -> s/m (ideal gas conversion) [umol/m3] + real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol /m**2/s) + real(r8), intent(in) :: ceair ! vapor pressure of air, constrained (Pa) + real(r8), intent(in) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) + real(r8), intent(in) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) + real(r8), intent(in) :: co2_cpoint ! CO2 compensation point (Pa) + real(r8), intent(in) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) + real(r8), intent(in) :: leaf_psi ! Leaf water potential [MPa] + real(r8), intent(in) :: rb ! Boundary Layer resistance of leaf [s/m] - ! ======================================================================================= + real(r8), intent(out) :: psn_out ! carbon assimilated in this leaf layer umolC/m2/s + real(r8), intent(out) :: rstoma_out ! stomatal resistance (1/gs_lsl) (s/m) + real(r8), intent(out) :: anet_av_out ! net leaf photosynthesis (umol CO2/m**2/s) + ! averaged over sun and shade leaves. + real(r8), intent(out) :: c13disc_z ! carbon 13 in newly assimilated carbon + + + - 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 - co2_rcurve_islope, & ! in - veg_tempk, & ! in - veg_esat, & ! in - can_press, & ! in - can_co2_ppress, & ! in - can_o2_ppress, & ! in - btran, & ! in - stomatal_intercept_btran, & ! in - cf, & ! in - gb_mol, & ! in - ceair, & ! in - mm_kco2, & ! in - mm_ko2, & ! in - co2_cpoint, & ! in - lmr, & ! in - psn_out, & ! out - rstoma_out, & ! out - anet_av_out, & ! out - c13disc_z) ! out - - ! ------------------------------------------------------------------------------------ - ! This subroutine calculates photosynthesis and stomatal conductance within each leaf - ! sublayer. - ! A note on naming conventions: As this subroutine is called for every - ! leaf-sublayer, many of the arguments are specific to that "leaf sub layer" - ! (LSL), those variables are given a dimension tag "_lsl" - ! Other arguments or variables may be indicative of scales broader than the LSL. - ! ------------------------------------------------------------------------------------ - - use EDPftvarcon , only : EDPftvarcon_inst - - - ! Arguments - ! ------------------------------------------------------------------------------------ - real(r8), intent(in) :: f_sun_lsl ! - real(r8), intent(in) :: parsun_lsl ! Absorbed PAR in sunlist leaves - real(r8), intent(in) :: parsha_lsl ! Absorved PAR in shaded leaves - real(r8), intent(in) :: laisun_lsl ! LAI in sunlit leaves - real(r8), intent(in) :: laisha_lsl ! LAI in shaded leaves - real(r8), intent(in) :: canopy_area_lsl ! - integer, intent(in) :: ft ! (plant) Functional Type Index - real(r8), intent(in) :: vcmax ! maximum rate of carboxylation (umol co2/m**2/s) - real(r8), intent(in) :: jmax ! maximum electron transport rate (umol electrons/m**2/s) - real(r8), intent(in) :: 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. + ! Locals + ! ------------------------------------------------------------------------ + integer :: c3c4_path_index ! Index for which photosynthetic pathway + ! is active. C4 = 0, C3 = 1 + integer :: sunsha ! Index for differentiating sun and shade + real(r8) :: gstoma ! Stomatal Conductance of this leaf layer (m/s) + real(r8) :: agross ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: anet ! net leaf photosynthesis (umol CO2/m**2/s) + real(r8) :: a_gs ! The assimilation (a) for calculating conductance (gs) + ! is either = to anet or agross + real(r8) :: je ! electron transport rate (umol electrons/m**2/s) + real(r8) :: qabs ! PAR absorbed by PS II (umol photons/m**2/s) + real(r8) :: aquad,bquad,cquad ! terms for quadratic equations + real(r8) :: r1,r2 ! roots of quadratic equation + real(r8) :: co2_inter_c ! intercellular leaf CO2 (Pa) + real(r8) :: co2_inter_c_old ! intercellular leaf CO2 (Pa) (previous iteration) + logical :: loop_continue ! Loop control variable + integer :: niter ! iteration loop index + real(r8) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) + real(r8) :: gs ! leaf stomatal conductance (m/s) + real(r8) :: hs ! fractional humidity at leaf surface (dimensionless) + real(r8) :: gs_mol_err ! gs_mol for error check + real(r8) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) + real(r8) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) + real(r8) :: ap ! product-limited (C3) or CO2-limited + ! (C4) gross photosynthesis (umol CO2/m**2/s) + real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) + real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) + real(r8) :: init_co2_inter_c ! First guess intercellular co2 specific to C path + real(r8) :: term ! intermediate variable in Medlyn stomatal conductance model + real(r8) :: vpd ! water vapor deficit in Medlyn stomatal model (KPa) + + + ! Parameters + ! ------------------------------------------------------------------------ + ! Fraction of light absorbed by non-photosynthetic pigments + real(r8),parameter :: fnps = 0.15_r8 + + ! For plants with no leaves, a miniscule amount of conductance + ! can happen through the stems, at a partial rate of cuticular conductance + real(r8),parameter :: stem_cuticle_loss_frac = 0.1_r8 + + ! empirical curvature parameter for electron transport rate + real(r8),parameter :: theta_psii = 0.7_r8 + + ! First guess on ratio between intercellular co2 and the atmosphere + ! an iterator converges on actual + real(r8),parameter :: init_a2l_co2_c3 = 0.7_r8 + real(r8),parameter :: init_a2l_co2_c4 = 0.4_r8 + + ! quantum efficiency, used only for C4 (mol CO2 / mol photons) (index 0) + real(r8),parameter,dimension(0:1) :: quant_eff = [0.05_r8,0.0_r8] + + ! empirical curvature parameter for ap photosynthesis co-limitation + real(r8),parameter :: theta_ip = 0.999_r8 + + associate( bb_slope => EDPftvarcon_inst%bb_slope ,& ! slope of BB relationship, unitless + medlyn_slope=> EDPftvarcon_inst%medlyn_slope , & ! Slope for Medlyn stomatal conductance model method, the unit is KPa^0.5 + stomatal_intercept=> EDPftvarcon_inst%stomatal_intercept ) !Unstressed minimum stomatal conductance, the unit is umol/m**2/s + + ! photosynthetic pathway: 0. = c4, 1. = c3 + c3c4_path_index = nint(EDPftvarcon_inst%c3psn(ft)) + + if (c3c4_path_index == c3_path_index) then + init_co2_inter_c = init_a2l_co2_c3 * can_co2_ppress + else + init_co2_inter_c = init_a2l_co2_c4 * can_co2_ppress + end if + + ! Part III: Photosynthesis and Conductance + ! ---------------------------------------------------------------------------------- + + if_daytime: if ( parsun_lsl <= 0._r8 ) then ! night time - real(r8), intent(in) :: can_press ! Air pressure NEAR the surface of the leaf (Pa) - real(r8), intent(in) :: can_co2_ppress ! Partial pressure of CO2 NEAR the leaf surface (Pa) - real(r8), intent(in) :: can_o2_ppress ! Partial pressure of O2 NEAR the leaf surface (Pa) - real(r8), intent(in) :: btran ! transpiration wetness factor (0 to 1) - real(r8), intent(in) :: stomatal_intercept_btran !water-stressed minimum stomatal conductance (umol H2O/m**2/s) - real(r8), intent(in) :: cf ! s m**2/umol -> s/m (ideal gas conversion) [umol/m3] - real(r8), intent(in) :: gb_mol ! leaf boundary layer conductance (umol /m**2/s) - real(r8), intent(in) :: ceair ! vapor pressure of air, constrained (Pa) - real(r8), intent(in) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) - real(r8), intent(in) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) - real(r8), intent(in) :: co2_cpoint ! CO2 compensation point (Pa) - real(r8), intent(in) :: lmr ! Leaf Maintenance Respiration (umol CO2/m**2/s) - - real(r8), intent(out) :: psn_out ! carbon assimilated in this leaf layer umolC/m2/s - real(r8), intent(out) :: rstoma_out ! stomatal resistance (1/gs_lsl) (s/m) - real(r8), intent(out) :: anet_av_out ! net leaf photosynthesis (umol CO2/m**2/s) - ! averaged over sun and shade leaves. - real(r8), intent(out) :: c13disc_z ! carbon 13 in newly assimilated carbon + anet_av_out = -lmr + psn_out = 0._r8 - ! Locals - ! ------------------------------------------------------------------------ - integer :: c3c4_path_index ! Index for which photosynthetic pathway - ! is active. C4 = 0, C3 = 1 - integer :: sunsha ! Index for differentiating sun and shade - real(r8) :: gstoma ! Stomatal Conductance of this leaf layer (m/s) - real(r8) :: agross ! co-limited gross leaf photosynthesis (umol CO2/m**2/s) - real(r8) :: anet ! net leaf photosynthesis (umol CO2/m**2/s) - real(r8) :: je ! electron transport rate (umol electrons/m**2/s) - real(r8) :: qabs ! PAR absorbed by PS II (umol photons/m**2/s) - real(r8) :: aquad,bquad,cquad ! terms for quadratic equations - real(r8) :: r1,r2 ! roots of quadratic equation - real(r8) :: co2_inter_c ! intercellular leaf CO2 (Pa) - real(r8) :: co2_inter_c_old ! intercellular leaf CO2 (Pa) (previous iteration) - logical :: loop_continue ! Loop control variable - integer :: niter ! iteration loop index - real(r8) :: gs_mol ! leaf stomatal conductance (umol H2O/m**2/s) - real(r8) :: gs ! leaf stomatal conductance (m/s) - real(r8) :: hs ! fractional humidity at leaf surface (dimensionless) - real(r8) :: gs_mol_err ! gs_mol for error check - real(r8) :: ac ! Rubisco-limited gross photosynthesis (umol CO2/m**2/s) - real(r8) :: aj ! RuBP-limited gross photosynthesis (umol CO2/m**2/s) - real(r8) :: ap ! product-limited (C3) or CO2-limited - ! (C4) gross photosynthesis (umol CO2/m**2/s) - real(r8) :: ai ! intermediate co-limited photosynthesis (umol CO2/m**2/s) - real(r8) :: leaf_co2_ppress ! CO2 partial pressure at leaf surface (Pa) - real(r8) :: init_co2_inter_c ! First guess intercellular co2 specific to C path - real(r8) :: term ! intermediate variable in Medlyn stomatal conductance model - real(r8) :: vpd ! water vapor deficit in Medlyn stomatal model (KPa) + ! The cuticular conductance already factored in maximum resistance as a bound + ! no need to re-bound it + rstoma_out = cf/stomatal_intercept_btran - ! Parameters - ! ------------------------------------------------------------------------ - ! Fraction of light absorbed by non-photosynthetic pigments - real(r8),parameter :: fnps = 0.15_r8 + c13disc_z = 0.0_r8 !carbon 13 discrimination in night time carbon flux, note value of 1.0 is used in CLM - ! For plants with no leaves, a miniscule amount of conductance - ! can happen through the stems, at a partial rate of cuticular conductance - real(r8),parameter :: stem_cuticle_loss_frac = 0.1_r8 + else ! day time (a little bit more complicated ...) - ! empirical curvature parameter for electron transport rate - real(r8),parameter :: theta_psii = 0.7_r8 - - ! First guess on ratio between intercellular co2 and the atmosphere - ! an iterator converges on actual - real(r8),parameter :: init_a2l_co2_c3 = 0.7_r8 - real(r8),parameter :: init_a2l_co2_c4 = 0.4_r8 + ! Is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) + + if_leafarea: if ( laisun_lsl + laisha_lsl > 0._r8 ) then - ! quantum efficiency, used only for C4 (mol CO2 / mol photons) (index 0) - real(r8),parameter,dimension(0:1) :: quant_eff = [0.05_r8,0.0_r8] + !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 - ! empirical curvature parameter for ac, aj photosynthesis co-limitation. - ! Changed theta_cj and theta_ip to 0.999 to effectively remove smoothing logic - ! following Anthony Walker's findings from MAAT. - real(r8),parameter,dimension(0:1) :: theta_cj = [0.999_r8,0.999_r8] + 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. - ! empirical curvature parameter for ap photosynthesis co-limitation - real(r8),parameter :: theta_ip = 0.999_r8 + if(sunsha == 1)then !sunlit + if(( laisun_lsl * canopy_area_lsl) > 0.0000000001_r8)then - associate( bb_slope => EDPftvarcon_inst%bb_slope ,& ! slope of BB relationship, unitless - medlyn_slope=> EDPftvarcon_inst%medlyn_slope , & ! Slope for Medlyn stomatal conductance model method, the unit is KPa^0.5 - stomatal_intercept=> EDPftvarcon_inst%stomatal_intercept ) !Unstressed minimum stomatal conductance, the unit is umol/m**2/s + qabs = parsun_lsl / (laisun_lsl * canopy_area_lsl ) + qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 - ! photosynthetic pathway: 0. = c4, 1. = c3 - c3c4_path_index = nint(EDPftvarcon_inst%c3psn(ft)) - - if (c3c4_path_index == 1) then - init_co2_inter_c = init_a2l_co2_c3 * can_co2_ppress - else - init_co2_inter_c = init_a2l_co2_c4 * can_co2_ppress - end if + else + qabs = 0.0_r8 + end if + else - ! Part III: Photosynthesis and Conductance - ! ---------------------------------------------------------------------------------- - - if ( parsun_lsl <= 0._r8 ) then ! night time - - anet_av_out = -lmr - psn_out = 0._r8 + qabs = parsha_lsl / (laisha_lsl * canopy_area_lsl) + qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 - ! The cuticular conductance already factored in maximum resistance as a bound - ! no need to re-bound it + end if - rstoma_out = cf/stomatal_intercept_btran - - c13disc_z = 0.0_r8 !carbon 13 discrimination in night time carbon flux, note value of 1.0 is used in CLM - - else ! day time (a little bit more complicated ...) - - !is there leaf area? - (NV can be larger than 0 with only stem area if deciduous) - if ( laisun_lsl + laisha_lsl > 0._r8 ) then - - !Loop aroun shaded and unshaded leaves - psn_out = 0._r8 ! psn is accumulated across sun and shaded leaves. - rstoma_out = 0._r8 ! 1/rs is accumulated across sun and shaded leaves. - anet_av_out = 0._r8 - gstoma = 0._r8 - - do sunsha = 1,2 - ! Electron transport rate for C3 plants. - ! Convert par from W/m2 to umol photons/m**2/s using the factor 4.6 - ! Convert from units of par absorbed per unit ground area to par - ! absorbed per unit leaf area. - - if(sunsha == 1)then !sunlit - if(( laisun_lsl * canopy_area_lsl) > 0.0000000001_r8)then + !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) - 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 + ! Initialize intercellular co2 + co2_inter_c = init_co2_inter_c - qabs = parsha_lsl / (laisha_lsl * canopy_area_lsl) - qabs = qabs * 0.5_r8 * (1._r8 - fnps) * 4.6_r8 + niter = 0 + loop_continue = .true. + iter_loop: do while(loop_continue) + ! Increment iteration counter. Stop if too many iterations + niter = niter + 1 - end if + ! Save old co2_inter_c + co2_inter_c_old = co2_inter_c + + ! Photosynthesis limitation rate calculations + if (c3c4_path_index == c3_path_index)then - !convert the absorbed par into absorbed par per m2 of leaf, - ! so it is consistant with the vcmax and lmr numbers. - aquad = theta_psii - bquad = -(qabs + jmax) - cquad = qabs * jmax - call quadratic_f (aquad, bquad, cquad, r1, r2) - je = min(r1,r2) - - ! Initialize intercellular co2 - co2_inter_c = init_co2_inter_c - - niter = 0 - loop_continue = .true. - do while(loop_continue) - ! Increment iteration counter. Stop if too many iterations - niter = niter + 1 - - ! Save old co2_inter_c - co2_inter_c_old = co2_inter_c - - ! Photosynthesis limitation rate calculations - if (c3c4_path_index == 1)then - - ! C3: Rubisco-limited photosynthesis - ac = vcmax * max(co2_inter_c-co2_cpoint, 0._r8) / & - (co2_inter_c+mm_kco2 * (1._r8+can_o2_ppress / mm_ko2 )) - - ! C3: RuBP-limited photosynthesis - aj = je * max(co2_inter_c-co2_cpoint, 0._r8) / & - (4._r8*co2_inter_c+8._r8*co2_cpoint) - - ! Gross photosynthesis smoothing calculations. Co-limit ac and aj. - aquad = theta_cj(c3c4_path_index) + ! C3: Rubisco-limited photosynthesis + ac = vcmax * max(co2_inter_c-co2_cpoint, 0._r8) / & + (co2_inter_c+mm_kco2 * (1._r8+can_o2_ppress / mm_ko2 )) + + ! C3: RuBP-limited photosynthesis + aj = je * max(co2_inter_c-co2_cpoint, 0._r8) / & + (4._r8*co2_inter_c+8._r8*co2_cpoint) + + ! Gross photosynthesis smoothing calculations. Co-limit ac and aj. + aquad = theta_cj_c3 bquad = -(ac + aj) cquad = ac * aj call quadratic_f (aquad, bquad, cquad, r1, r2) agross = min(r1,r2) - else - - ! C4: Rubisco-limited photosynthesis - ac = vcmax - - ! C4: RuBP-limited photosynthesis - if(sunsha == 1)then !sunlit - !guard against /0's in the night. - if((laisun_lsl * canopy_area_lsl) > 0.0000000001_r8) then - aj = quant_eff(c3c4_path_index) * parsun_lsl * 4.6_r8 - !convert from per cohort to per m2 of leaf) - aj = aj / (laisun_lsl * canopy_area_lsl) - else - aj = 0._r8 - end if + else + + ! C4: Rubisco-limited photosynthesis + ac = vcmax + + ! C4: RuBP-limited photosynthesis + if(sunsha == 1)then !sunlit + !guard against /0's in the night. + if((laisun_lsl * canopy_area_lsl) > 0.0000000001_r8) then + aj = quant_eff(c3c4_path_index) * parsun_lsl * 4.6_r8 + !convert from per cohort to per m2 of leaf) + aj = aj / (laisun_lsl * canopy_area_lsl) else - aj = quant_eff(c3c4_path_index) * parsha_lsl * 4.6_r8 - aj = aj / (laisha_lsl * canopy_area_lsl) + aj = 0._r8 end if + else + aj = quant_eff(c3c4_path_index) * parsha_lsl * 4.6_r8 + aj = aj / (laisha_lsl * canopy_area_lsl) + end if - ! C4: PEP carboxylase-limited (CO2-limited) - ap = co2_rcurve_islope * max(co2_inter_c, 0._r8) / can_press + ! C4: PEP carboxylase-limited (CO2-limited) + ap = co2_rcurve_islope * max(co2_inter_c, 0._r8) / can_press - ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap + ! Gross photosynthesis smoothing calculations. First co-limit ac and aj. Then co-limit ap - aquad = theta_cj(c3c4_path_index) - bquad = -(ac + aj) - cquad = ac * aj - call quadratic_f (aquad, bquad, cquad, r1, r2) - ai = min(r1,r2) + aquad = theta_cj_c4 + bquad = -(ac + aj) + cquad = ac * aj + call quadratic_f (aquad, bquad, cquad, r1, r2) + ai = min(r1,r2) - aquad = theta_ip - bquad = -(ai + ap) - cquad = ai * ap - call quadratic_f (aquad, bquad, cquad, r1, r2) - agross = min(r1,r2) + aquad = theta_ip + bquad = -(ai + ap) + cquad = ai * ap + call quadratic_f (aquad, bquad, cquad, r1, r2) + agross = min(r1,r2) + end if + + ! Calculate anet, only exit iteration with negative anet when + ! using anet in calculating gs this is version B + anet = agross - lmr + + if (use_agross) then + if ( stomatal_model == medlyn_model ) then + write (fates_log(),*) 'Gross Assimilation conductance is incompatible with the Medlyn model' + call endrun(msg=errMsg(sourcefile, __LINE__)) end if - - ! Net carbon assimilation. Exit iteration if an < 0 - anet = agross - lmr + a_gs = agross + else if (anet < 0._r8) then loop_continue = .false. end if + a_gs = anet + end if - ! Quadratic gs_mol calculation with an known. Valid for an >= 0. - ! With an <= 0, then gs_mol = stomatal_intercept_btran - leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press - leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) - if ( stomatal_model == 2 ) then - !stomatal conductance calculated from Medlyn et al. (2011), the numerical & - !implementation was adapted from the equations in CLM5.0 - vpd = max((veg_esat - ceair), 50._r8) * 0.001_r8 !addapted from CLM5. Put some constraint on VPD - !when Medlyn stomatal conductance is being used, the unit is KPa. Ignoring the constraint will cause errors when model runs. - term = h2o_co2_stoma_diffuse_ratio * anet / (leaf_co2_ppress / can_press) - aquad = 1.0_r8 - bquad = -(2.0 * (stomatal_intercept_btran+ term) + (medlyn_slope(ft) * term)**2 / & - (gb_mol * vpd )) - cquad = stomatal_intercept_btran*stomatal_intercept_btran + & - (2.0*stomatal_intercept_btran + term * & - (1.0 - medlyn_slope(ft)* medlyn_slope(ft) / vpd)) * term - - call quadratic_f (aquad, bquad, cquad, r1, r2) - gs_mol = max(r1,r2) + ! With an <= 0, then gs_mol = stomatal_intercept_btran + leaf_co2_ppress = can_co2_ppress- h2o_co2_bl_diffuse_ratio/gb_mol * a_gs * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + + if ( stomatal_model == medlyn_model ) then + !stomatal conductance calculated from Medlyn et al. (2011), the numerical & + !implementation was adapted from the equations in CLM5.0 + vpd = max((veg_esat - ceair), 50._r8) * 0.001_r8 !addapted from CLM5. Put some constraint on VPD + !when Medlyn stomatal conductance is being used, the unit is KPa. Ignoring the constraint will cause errors when model runs. + term = h2o_co2_stoma_diffuse_ratio * anet / (leaf_co2_ppress / can_press) + aquad = 1.0_r8 + bquad = -(2.0 * (stomatal_intercept_btran+ term) + (medlyn_slope(ft) * term)**2 / & + (gb_mol * vpd )) + cquad = stomatal_intercept_btran*stomatal_intercept_btran + & + (2.0*stomatal_intercept_btran + term * & + (1.0 - medlyn_slope(ft)* medlyn_slope(ft) / vpd)) * term - else if ( stomatal_model == 1 ) then !stomatal conductance calculated from Ball et al. (1987) - aquad = leaf_co2_ppress - bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * anet * can_press - cquad = -gb_mol*(leaf_co2_ppress*stomatal_intercept_btran + & - bb_slope(ft)*anet*can_press * ceair/ veg_esat ) + call quadratic_f (aquad, bquad, cquad, r1, r2) + gs_mol = max(r1,r2) + + else if ( stomatal_model == ballberry_model ) then !stomatal conductance calculated from Ball et al. (1987) + aquad = leaf_co2_ppress + bquad = leaf_co2_ppress*(gb_mol - stomatal_intercept_btran) - bb_slope(ft) * a_gs * can_press + cquad = -gb_mol*(leaf_co2_ppress*stomatal_intercept_btran + & + bb_slope(ft)*anet*can_press * ceair/ veg_esat ) call quadratic_f (aquad, bquad, cquad, r1, r2) gs_mol = max(r1,r2) - end if - ! Derive new estimate for co2_inter_c - co2_inter_c = can_co2_ppress - anet * can_press * & - (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - - ! Check for co2_inter_c convergence. Delta co2_inter_c/pair = mol/mol. - ! Multiply by 10**6 to convert to umol/mol (ppm). Exit iteration if - ! convergence criteria of +/- 1 x 10**-6 ppm is met OR if at least ten - ! iterations (niter=10) are completed - - if ((abs(co2_inter_c-co2_inter_c_old)/can_press*1.e06_r8 <= 2.e-06_r8) & - .or. niter == 5) then - loop_continue = .false. - end if - end do !iteration loop - - ! End of co2_inter_c iteration. Check for an < 0, in which case - ! gs_mol =stomatal_intercept_btran - if (anet < 0._r8) then - gs_mol = stomatal_intercept_btran end if - ! Final estimates for leaf_co2_ppress and co2_inter_c - ! (needed for early exit of co2_inter_c iteration when an < 0) - leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press - leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + ! Derive new estimate for co2_inter_c co2_inter_c = can_co2_ppress - anet * can_press * & - (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - - ! Convert gs_mol (umol /m**2/s) to gs (m/s) and then to rs (s/m) - gs = gs_mol / cf - - ! estimate carbon 13 discrimination in leaf level carbon - ! flux Liang WEI and Hang ZHOU 2018, based on - ! Ubierna and Farquhar, 2014 doi:10.1111/pce.12346, using the simplified model: - ! $\Delta ^{13} C = \alpha_s + (b - \alpha_s) \cdot \frac{C_i}{C_a}$ - ! just hard code b and \alpha_s for now, might move to parameter set in future - ! b = 27.0 alpha_s = 4.4 - ! TODO, not considering C4 or CAM right now, may need to address this - ! note co2_inter_c is intracelluar CO2, not intercelluar - c13disc_z = 4.4_r8 + (27.0_r8 - 4.4_r8) * & - min (can_co2_ppress, max (co2_inter_c, 0._r8)) / can_co2_ppress - - ! Accumulate total photosynthesis umol/m2 ground/s-1. - ! weight per unit sun and sha leaves. - if(sunsha == 1)then !sunlit - psn_out = psn_out + agross * f_sun_lsl - anet_av_out = anet_av_out + anet * f_sun_lsl - gstoma = gstoma + 1._r8/(min(1._r8/gs, rsmax0)) * f_sun_lsl - else - psn_out = psn_out + agross * (1.0_r8-f_sun_lsl) - anet_av_out = anet_av_out + anet * (1.0_r8-f_sun_lsl) - gstoma = gstoma + & - 1._r8/(min(1._r8/gs, rsmax0)) * (1.0_r8-f_sun_lsl) - end if - - ! Make sure iterative solution is correct - if (gs_mol < 0._r8) then - write (fates_log(),*)'Negative stomatal conductance:' - write (fates_log(),*)'gs_mol= ',gs_mol - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Compare with Medlyn model: gs_mol = 1.6*(1+m/sqrt(vpd)) * an/leaf_co2_ppress*p + b - if ( stomatal_model == 2 ) then - gs_mol_err = h2o_co2_stoma_diffuse_ratio*(1 + medlyn_slope(ft)/sqrt(vpd))*max(anet,0._r8)/leaf_co2_ppress*can_press + stomatal_intercept_btran - ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress*p + b - else if ( stomatal_model == 1 ) then - hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) - gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/leaf_co2_ppress*can_press + stomatal_intercept_btran - end if + (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) - if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then - write (fates_log(),*) 'Stomatal model error check - stomatal conductance error:' - write (fates_log(),*) gs_mol, gs_mol_err - end if - - enddo !sunsha loop + ! Check for co2_inter_c convergence. Delta co2_inter_c/pair = mol/mol. + ! Multiply by 10**6 to convert to umol/mol (ppm). Exit iteration if + ! convergence criteria of +/- 1 x 10**-6 ppm is met OR if at least ten + ! iterations (niter=10) are completed - ! This is the stomatal resistance of the leaf layer - rstoma_out = 1._r8/gstoma - + if ((abs(co2_inter_c-co2_inter_c_old)/can_press*1.e06_r8 <= 2.e-06_r8) & + .or. niter == 5) then + loop_continue = .false. + end if + end do iter_loop + + ! End of co2_inter_c iteration. Check for an < 0, in which case gs_mol = bbb + ! And Final estimates for leaf_co2_ppress and co2_inter_c + ! (needed for early exit of co2_inter_c iteration when an < 0) + if (anet < 0._r8) then + gs_mol = stomatal_intercept_btran + end if + + ! Final estimates for leaf_co2_ppress and co2_inter_c + leaf_co2_ppress = can_co2_ppress - h2o_co2_bl_diffuse_ratio/gb_mol * anet * can_press + leaf_co2_ppress = max(leaf_co2_ppress,1.e-06_r8) + co2_inter_c = can_co2_ppress - anet * can_press * & + (h2o_co2_bl_diffuse_ratio*gs_mol+h2o_co2_stoma_diffuse_ratio*gb_mol) / (gb_mol*gs_mol) + + ! Convert gs_mol (umol /m**2/s) to gs (m/s) and then to rs (s/m) + gs = gs_mol / cf + + ! estimate carbon 13 discrimination in leaf level carbon + ! flux Liang WEI and Hang ZHOU 2018, based on + ! Ubierna and Farquhar, 2014 doi:10.1111/pce.12346, using the simplified model: + ! $\Delta ^{13} C = \alpha_s + (b - \alpha_s) \cdot \frac{C_i}{C_a}$ + ! just hard code b and \alpha_s for now, might move to parameter set in future + ! b = 27.0 alpha_s = 4.4 + ! TODO, not considering C4 or CAM right now, may need to address this + ! note co2_inter_c is intracelluar CO2, not intercelluar + c13disc_z = 4.4_r8 + (27.0_r8 - 4.4_r8) * & + min (can_co2_ppress, max (co2_inter_c, 0._r8)) / can_co2_ppress + + ! Accumulate total photosynthesis umol/m2 ground/s-1. + ! weight per unit sun and sha leaves. + if(sunsha == 1)then !sunlit + psn_out = psn_out + agross * f_sun_lsl + anet_av_out = anet_av_out + anet * f_sun_lsl + gstoma = gstoma + 1._r8/(min(1._r8/gs, rsmax0)) * f_sun_lsl + else + psn_out = psn_out + agross * (1.0_r8-f_sun_lsl) + anet_av_out = anet_av_out + anet * (1.0_r8-f_sun_lsl) + gstoma = gstoma + & + 1._r8/(min(1._r8/gs, rsmax0)) * (1.0_r8-f_sun_lsl) + end if + + ! Make sure iterative solution is correct + if (gs_mol < 0._r8) then + write (fates_log(),*)'Negative stomatal conductance:' + write (fates_log(),*)'gs_mol= ',gs_mol + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Compare with Medlyn model: gs_mol = 1.6*(1+m/sqrt(vpd)) * an/leaf_co2_ppress*p + b + if ( stomatal_model == 2 ) then + gs_mol_err = h2o_co2_stoma_diffuse_ratio*(1 + medlyn_slope(ft)/sqrt(vpd))*max(anet,0._r8)/leaf_co2_ppress*can_press + stomatal_intercept_btran + ! Compare with Ball-Berry model: gs_mol = m * an * hs/leaf_co2_ppress*p + b + else if ( stomatal_model == 1 ) then + hs = (gb_mol*ceair + gs_mol* veg_esat ) / ((gb_mol+gs_mol)*veg_esat ) + gs_mol_err = bb_slope(ft)*max(anet, 0._r8)*hs/leaf_co2_ppress*can_press + stomatal_intercept_btran + end if + + if (abs(gs_mol-gs_mol_err) > 1.e-01_r8) then + write (fates_log(),*) 'Stomatal model error check - stomatal conductance error:' + write (fates_log(),*) gs_mol, gs_mol_err + end if + + enddo !sunsha loop + + ! Stomatal resistance of the leaf-layer + if ( (hlm_use_planthydro.eq.itrue .and. EDPftvarcon_inst%hydr_k_lwp(ft)>nearzero) ) then + rstoma_out = LeafHumidityStomaResis(leaf_psi, veg_tempk, ceair, can_press, veg_esat, & + rb, gstoma, ft) else + rstoma_out = 1._r8/gstoma + end if + + + else - ! No leaf area. This layer is present only because of stems. - ! Net assimilation is zero, not negative because there are - ! no leaves to even respire - ! (leaves are off, or have reduced to 0) + ! No leaf area. This layer is present only because of stems. + ! Net assimilation is zero, not negative because there are + ! no leaves to even respire + ! (leaves are off, or have reduced to 0) - psn_out = 0._r8 - anet_av_out = 0._r8 + psn_out = 0._r8 + anet_av_out = 0._r8 + + rstoma_out = min(rsmax0,cf/(stem_cuticle_loss_frac*stomatal_intercept(ft))) + c13disc_z = 0.0_r8 + + end if if_leafarea !is there leaf area? + + + end if if_daytime ! night or day - rstoma_out = min(rsmax0,cf/(stem_cuticle_loss_frac*stomatal_intercept(ft))) - c13disc_z = 0.0_r8 - - end if !is there leaf area? - - - end if ! night or day - end associate return - end subroutine LeafLayerPhotosynthesis - - ! ===================================================================================== - - subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv - psn_llz, & ! in %psn_z(1:currentCohort%nv,ft,cl) - lmr_llz, & ! in lmr_z(1:currentCohort%nv,ft,cl) - rs_llz, & ! in rs_z(1:currentCohort%nv,ft,cl) - elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) - c13disc_llz, & ! in c13disc_z(cl, ft, 1:currentCohort%nv) - c_area, & ! in currentCohort%c_area - nplant, & ! in currentCohort%n - rb, & ! in bc_in(s)%rb_pa(ifp) - maintresp_reduction_factor, & ! in - g_sb_laweight, & ! out currentCohort%g_sb_laweight [m/s] [m2-leaf] - gpp, & ! out currentCohort%gpp_tstep - rdark, & ! out currentCohort%rdark - c13disc_clm, & ! out currentCohort%c13disc_clm - cohort_eleaf_area ) ! out [m2] - - ! ------------------------------------------------------------------------------------ - ! This subroutine effectively integrates leaf carbon fluxes over the - ! leaf layers to give cohort totals. - ! Some arguments have the suffix "_llz". This indicates that the vector - ! is stratefied in the leaf-layer (ll) dimension, and is a portion of the calling - ! array which has the "_z" tag, thus "llz". - ! ------------------------------------------------------------------------------------ - - use FatesConstantsMod, only : umolC_to_kgC - - ! Arguments - integer, intent(in) :: nv ! number of active leaf layers - real(r8), intent(in) :: psn_llz(nv) ! layer photosynthesis rate (GPP) [umolC/m2leaf/s] - real(r8), intent(in) :: lmr_llz(nv) ! layer dark respiration rate [umolC/m2leaf/s] - real(r8), intent(in) :: rs_llz(nv) ! leaf layer stomatal resistance [s/m] - real(r8), intent(in) :: elai_llz(nv) ! exposed LAI per layer [m2 leaf/ m2 pft footprint] - real(r8), intent(in) :: c13disc_llz(nv) ! leaf layer c13 discrimination, weighted mean - real(r8), intent(in) :: c_area ! crown area m2/m2 - real(r8), intent(in) :: nplant ! indiv/m2 - real(r8), intent(in) :: rb ! leaf boundary layer resistance (s/m) - real(r8), intent(in) :: maintresp_reduction_factor ! factor by which to reduce maintenance respiration - real(r8), intent(out) :: g_sb_laweight ! Combined conductance (stomatal + boundary layer) for the cohort - ! weighted by leaf area [m/s]*[m2] - real(r8), intent(out) :: gpp ! GPP (kgC/indiv/s) - real(r8), intent(out) :: rdark ! Dark Leaf Respiration (kgC/indiv/s) - real(r8), intent(out) :: cohort_eleaf_area ! Effective leaf area of the cohort [m2] - real(r8), intent(out) :: c13disc_clm ! unpacked Cohort level c13 discrimination - real(r8) :: sum_weight ! sum of weight for unpacking d13c flux (c13disc_z) from - ! (canopy_layer, pft, leaf_layer) matrix to cohort (c13disc_clm) - - ! GPP IN THIS SUBROUTINE IS A RATE. THE CALLING ARGUMENT IS GPP_TSTEP. AFTER THIS - ! CALL THE RATE WILL BE MULTIPLIED BY THE INTERVAL TO GIVE THE INTEGRATED QUANT. - - ! Locals - integer :: il ! leaf layer index - real(r8) :: cohort_layer_eleaf_area ! the effective leaf area of the cohort's current layer [m2] - - cohort_eleaf_area = 0.0_r8 - g_sb_laweight = 0.0_r8 - gpp = 0.0_r8 - rdark = 0.0_r8 - - do il = 1, nv ! Loop over the leaf layers this cohort participates in - - - ! Cohort's total effective leaf area in this layer [m2] - ! leaf area index of the layer [m2/m2 ground] * [m2 ground] - ! elai_llz is the LAI for the whole PFT. Multiplying this by the ground - ! area this cohort contributes, give the cohort's portion of the leaf - ! area in this layer - cohort_layer_eleaf_area = elai_llz(il) * c_area - - ! Increment the cohort's total effective leaf area [m2] - cohort_eleaf_area = cohort_eleaf_area + cohort_layer_eleaf_area - - ! Leaf conductance (stomatal and boundary layer) - ! This should be the weighted average over the leaf surfaces. - ! Since this is relevant to the stomata, its weighting should be based - ! on total leaf area, and not really footprint area - ! [m/s] * [m2 cohort's leaf layer] - g_sb_laweight = g_sb_laweight + 1.0_r8/(rs_llz(il)+rb) * cohort_layer_eleaf_area - - ! GPP [umolC/m2leaf/s] * [m2 leaf ] -> [umolC/s] (This is cohort group sum) - gpp = gpp + psn_llz(il) * cohort_layer_eleaf_area - - ! Dark respiration - ! [umolC/m2leaf/s] * [m2 leaf] (This is the cohort group sum) - rdark = rdark + lmr_llz(il) * cohort_layer_eleaf_area - - end do - - - - if (nv > 1) then +end subroutine LeafLayerPhotosynthesis + +! ======================================================================================= + +function LeafHumidityStomaResis(leaf_psi, veg_tempk, ceair, can_press, veg_esat, & + rb, gstoma, ft) result(rstoma_out) + + ! ------------------------------------------------------------------------------------- + ! This calculates inner leaf humidity as a function of mesophyll water potential + ! Adopted from Vesala et al., 2017 https://www.frontiersin.org/articles/10.3389/fpls.2017.00054/full + ! + ! Equation 1 in Vesala et al: + ! lwp_star = wi/w0 = exp( k_lwp*leaf_psi*molar_mass_water/(rgas_J_k_mol * veg_tempk) ) + ! + ! Terms: + ! leaf_psi: leaf water potential [MPa] + ! k_lwp: inner leaf humidity scaling coefficient [-] + ! rgas_J_K_mol: universal gas constant, [J/K/mol], 8.3144598 + ! molar_mass_water, molar mass of water, [g/mol]: 18.0 + ! + ! Unit conversions: + ! 1 Pa = 1 N/m2 = 1 J/m3 + ! density of liquid water [kg/m3] = 1000 + ! + ! units of equation 1: exp( [MPa]*[g/mol]/( [J/K/mol] * [K] ) ) + ! [MJ/m3]*[g/mol]*[m3/kg]*[kg/g]*[J/MJ] / ([J/mol]) + ! dimensionless: [J/g]*[g/mol]/([J/mol]) + ! + ! Note: unit conversions drop out b/c [m3/kg]*[kg/g]*[J/MJ] = 1e-3*1.e-3*1e6 = 1.0 + ! + ! Junyan Ding 2021 + ! ------------------------------------------------------------------------------------- + + ! Arguments + real(r8) :: leaf_psi ! Leaf water potential [MPa] + real(r8) :: veg_tempk ! Leaf temperature [K] + real(r8) :: ceair ! vapor pressure of air, constrained [Pa] + real(r8) :: can_press ! Atmospheric pressure of canopy [Pa] + real(r8) :: veg_esat ! Saturated vapor pressure at veg surf [Pa] + real(r8) :: rb ! Leaf Boundary layer resistance [s/m] + real(r8) :: gstoma ! Stomatal Conductance of this leaf layer [m/s] + integer :: ft ! Plant Functional Type + real(r8) :: rstoma_out ! Total Stomatal resistance (stoma and BL) [s/m] + + ! Locals + real(r8) :: k_lwp ! Scaling coefficient for the ratio of leaf xylem + ! water potential to mesophyll water potential + real(r8) :: qs ! Specific humidity [g/kg] + real(r8) :: qsat ! Saturation specific humidity [g/kg] + real(r8) :: qsat_adj ! Adjusted saturation specific humidity [g/kg] + real(r8) :: lwp_star ! leaf water potential scaling coefficient + ! for inner leaf humidity, 0 means total dehydroted + ! leaf, 1 means total saturated leaf + + ! Note: to disable this control, set k_lwp to zero, LWP_star will be 1 + k_lwp = EDPftvarcon_inst%hydr_k_lwp(ft) + if (leaf_psi<0._r8) then + lwp_star = exp(k_lwp*leaf_psi*molar_mass_water/(rgas_J_K_mol *veg_tempk)) + else + lwp_star = 1._r8 + end if + + ! compute specific humidity from vapor pressure + ! q = molar_mass_ratio_vapdry*e/(can_press - (1-molar_mass_ratio_vapdry)*e) + ! source https://cran.r-project.org/web/packages/humidity/vignettes/humidity-measures.html + ! now adjust inner leaf humidity by LWP_star + + qs = molar_mass_ratio_vapdry * ceair / (can_press - (1._r8-molar_mass_ratio_vapdry) * ceair) + qsat = molar_mass_ratio_vapdry * veg_esat / (can_press - (1._r8-molar_mass_ratio_vapdry) * veg_esat) + qsat_adj = qsat*lwp_star + + ! Adjusting gs (compute a virtual gs) that will be passed to host model + + if ( qsat_adj < qs ) then + + ! if inner leaf vapor pressure is less then or equal to that at leaf surface + ! then set stomata resistance to be very large to stop the transpiration or back flow of vapor + rstoma_out = rsmax0 + + else + + rstoma_out = (qsat-qs)*( 1/gstoma + rb)/(qsat_adj - qs)-rb + + end if + + if (rstoma_out < nearzero ) then + write (fates_log(),*) 'qsat:', qsat, 'qs:', qs + write (fates_log(),*) 'LWP :', leaf_psi + write (fates_log(),*) 'ceair:', ceair, 'veg_esat:', veg_esat + write (fates_log(),*) 'rstoma_out:', rstoma_out, 'rb:', rb + write (fates_log(),*) 'LWP_star', lwp_star + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + +end function LeafHumidityStomaResis + + +! ===================================================================================== + +subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv + psn_llz, & ! in %psn_z(1:currentCohort%nv,ft,cl) + lmr_llz, & ! in lmr_z(1:currentCohort%nv,ft,cl) + rs_llz, & ! in rs_z(1:currentCohort%nv,ft,cl) + elai_llz, & ! in %elai_profile(cl,ft,1:currentCohort%nv) + c13disc_llz, & ! in c13disc_z(cl, ft, 1:currentCohort%nv) + c_area, & ! in currentCohort%c_area + nplant, & ! in currentCohort%n + rb, & ! in bc_in(s)%rb_pa(ifp) + maintresp_reduction_factor, & ! in + g_sb_laweight, & ! out currentCohort%g_sb_laweight [m/s] [m2-leaf] + gpp, & ! out currentCohort%gpp_tstep + rdark, & ! out currentCohort%rdark + c13disc_clm, & ! out currentCohort%c13disc_clm + cohort_eleaf_area ) ! out [m2] + + ! ------------------------------------------------------------------------------------ + ! This subroutine effectively integrates leaf carbon fluxes over the + ! leaf layers to give cohort totals. + ! Some arguments have the suffix "_llz". This indicates that the vector + ! is stratefied in the leaf-layer (ll) dimension, and is a portion of the calling + ! array which has the "_z" tag, thus "llz". + ! ------------------------------------------------------------------------------------ + + use FatesConstantsMod, only : umolC_to_kgC + + ! Arguments + integer, intent(in) :: nv ! number of active leaf layers + real(r8), intent(in) :: psn_llz(nv) ! layer photosynthesis rate (GPP) [umolC/m2leaf/s] + real(r8), intent(in) :: lmr_llz(nv) ! layer dark respiration rate [umolC/m2leaf/s] + real(r8), intent(in) :: rs_llz(nv) ! leaf layer stomatal resistance [s/m] + real(r8), intent(in) :: elai_llz(nv) ! exposed LAI per layer [m2 leaf/ m2 pft footprint] + real(r8), intent(in) :: c13disc_llz(nv) ! leaf layer c13 discrimination, weighted mean + real(r8), intent(in) :: c_area ! crown area m2/m2 + real(r8), intent(in) :: nplant ! indiv/m2 + real(r8), intent(in) :: rb ! leaf boundary layer resistance (s/m) + real(r8), intent(in) :: maintresp_reduction_factor ! factor by which to reduce maintenance respiration + real(r8), intent(out) :: g_sb_laweight ! Combined conductance (stomatal + boundary layer) for the cohort + ! weighted by leaf area [m/s]*[m2] + real(r8), intent(out) :: gpp ! GPP (kgC/indiv/s) + real(r8), intent(out) :: rdark ! Dark Leaf Respiration (kgC/indiv/s) + real(r8), intent(out) :: cohort_eleaf_area ! Effective leaf area of the cohort [m2] + real(r8), intent(out) :: c13disc_clm ! unpacked Cohort level c13 discrimination + real(r8) :: sum_weight ! sum of weight for unpacking d13c flux (c13disc_z) from + ! (canopy_layer, pft, leaf_layer) matrix to cohort (c13disc_clm) + + ! GPP IN THIS SUBROUTINE IS A RATE. THE CALLING ARGUMENT IS GPP_TSTEP. AFTER THIS + ! CALL THE RATE WILL BE MULTIPLIED BY THE INTERVAL TO GIVE THE INTEGRATED QUANT. + + ! Locals + integer :: il ! leaf layer index + real(r8) :: cohort_layer_eleaf_area ! the effective leaf area of the cohort's current layer [m2] + + cohort_eleaf_area = 0.0_r8 + g_sb_laweight = 0.0_r8 + gpp = 0.0_r8 + rdark = 0.0_r8 + + do il = 1, nv ! Loop over the leaf layers this cohort participates in + + + ! Cohort's total effective leaf area in this layer [m2] + ! leaf area index of the layer [m2/m2 ground] * [m2 ground] + ! elai_llz is the LAI for the whole PFT. Multiplying this by the ground + ! area this cohort contributes, give the cohort's portion of the leaf + ! area in this layer + cohort_layer_eleaf_area = elai_llz(il) * c_area + + ! Increment the cohort's total effective leaf area [m2] + cohort_eleaf_area = cohort_eleaf_area + cohort_layer_eleaf_area + + ! Leaf conductance (stomatal and boundary layer) + ! This should be the weighted average over the leaf surfaces. + ! Since this is relevant to the stomata, its weighting should be based + ! on total leaf area, and not really footprint area + ! [m/s] * [m2 cohort's leaf layer] + g_sb_laweight = g_sb_laweight + 1.0_r8/(rs_llz(il)+rb) * cohort_layer_eleaf_area + + ! GPP [umolC/m2leaf/s] * [m2 leaf ] -> [umolC/s] (This is cohort group sum) + gpp = gpp + psn_llz(il) * cohort_layer_eleaf_area + + ! Dark respiration + ! [umolC/m2leaf/s] * [m2 leaf] (This is the cohort group sum) + rdark = rdark + lmr_llz(il) * cohort_layer_eleaf_area + + end do + + + + if (nv > 1) then ! cohort%c13disc_clm as weighted mean of d13c flux at all related leave layers sum_weight = sum(psn_llz(1:nv-1) * elai_llz(1:nv-1)) - if (sum_weight .eq. 0.0_r8) then - c13disc_clm = 0.0 - else - c13disc_clm = sum(c13disc_llz(1:nv-1) * psn_llz(1:nv-1) * elai_llz(1:nv-1)) / sum_weight - end if + if (sum_weight .eq. 0.0_r8) then + c13disc_clm = 0.0 + else + c13disc_clm = sum(c13disc_llz(1:nv-1) * psn_llz(1:nv-1) * elai_llz(1:nv-1)) / sum_weight + end if - end if + end if - ! ----------------------------------------------------------------------------------- - ! We DO NOT normalize g_sb_laweight. - ! The units that we are passing back are [m/s] * [m2 effective leaf] - ! We will add these up over the whole patch, and then normalized - ! by the patch's total leaf area in the calling routine - ! ----------------------------------------------------------------------------------- + ! ----------------------------------------------------------------------------------- + ! We DO NOT normalize g_sb_laweight. + ! The units that we are passing back are [m/s] * [m2 effective leaf] + ! We will add these up over the whole patch, and then normalized + ! by the patch's total leaf area in the calling routine + ! ----------------------------------------------------------------------------------- - ! ----------------------------------------------------------------------------------- - ! Convert dark respiration and GPP from [umol/s] to [kgC/plant/s] - ! Also, apply the maintenance respiration reduction factor - ! ----------------------------------------------------------------------------------- - - rdark = rdark * umolC_to_kgC * maintresp_reduction_factor / nplant - gpp = gpp * umolC_to_kgC / nplant - - if ( debug ) then - write(fates_log(),*) 'EDPhoto 816 ', gpp - write(fates_log(),*) 'EDPhoto 817 ', psn_llz(1:nv) - write(fates_log(),*) 'EDPhoto 820 ', nv - write(fates_log(),*) 'EDPhoto 821 ', elai_llz(1:nv) - write(fates_log(),*) 'EDPhoto 843 ', rdark - write(fates_log(),*) 'EDPhoto 873 ', nv - write(fates_log(),*) 'EDPhoto 874 ', cohort_eleaf_area - endif - - return - end subroutine ScaleLeafLayerFluxToCohort - - ! ===================================================================================== - - function ft1_f(tl, ha) result(ans) - ! - !!DESCRIPTION: - ! photosynthesis temperature response - ! - ! !REVISION HISTORY - ! Jinyun Tang separated it out from Photosynthesis, Feb. 07/2013 - ! 7/23/16: Copied over from CLM by Ryan Knox - ! - !!USES - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - ! - ! !ARGUMENTS: - real(r8), intent(in) :: tl ! leaf temperature in photosynthesis temperature function (K) - real(r8), intent(in) :: ha ! activation energy in photosynthesis temperature function (J/mol) - ! - ! !LOCAL VARIABLES: - real(r8) :: ans - !------------------------------------------------------------------------------- + ! ----------------------------------------------------------------------------------- + ! Convert dark respiration and GPP from [umol/s] to [kgC/plant/s] + ! Also, apply the maintenance respiration reduction factor + ! ----------------------------------------------------------------------------------- - ans = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) + rdark = rdark * umolC_to_kgC * maintresp_reduction_factor / nplant + gpp = gpp * umolC_to_kgC / nplant - return - end function ft1_f + if ( debug ) then + write(fates_log(),*) 'EDPhoto 816 ', gpp + write(fates_log(),*) 'EDPhoto 817 ', psn_llz(1:nv) + write(fates_log(),*) 'EDPhoto 820 ', nv + write(fates_log(),*) 'EDPhoto 821 ', elai_llz(1:nv) + write(fates_log(),*) 'EDPhoto 843 ', rdark + write(fates_log(),*) 'EDPhoto 873 ', nv + write(fates_log(),*) 'EDPhoto 874 ', cohort_eleaf_area + endif - ! ===================================================================================== - - 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 + 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 + !------------------------------------------------------------------------------- - ! - ! !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 = exp( ha / (rgas*1.e-3_r8*(tfrz+25._r8)) * (1._r8 - (tfrz+25._r8)/tl) ) - ans = scaleFactor / ( 1._r8 + exp( (-hd+se*tl) / (rgas*1.e-3_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 - return - end function fth_f + ! + ! !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) ) ) - 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 + return +end function fth_f - 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)) ) +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 + !------------------------------------------------------------------------------ - 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 (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 + r2 = c / q ! else ! r2 = 1.e36_r8 ! end if - - end subroutine quadratic_fast - - - ! ==================================================================================== - - subroutine UpdateCanopyNCanNRadPresent(currentPatch) - - ! --------------------------------------------------------------------------------- - ! This subroutine calculates two patch level quanities: - ! currentPatch%ncan and - ! currentPatch%canopy_mask - ! - ! currentPatch%ncan(:,:) is a two dimensional array that indicates - ! the total number of leaf layers (including those that are not exposed to light) - ! in each canopy layer and for each functional type. - ! - ! currentPatch%nrad(:,:) is a two dimensional array that indicates - ! the total number of EXPOSED leaf layers, but for all intents and purposes - ! in the photosynthesis routine, this appears to be the same as %ncan... - ! - ! currentPatch%canopy_mask(:,:) has the same dimensions, is binary, and - ! indicates whether or not leaf layers are present (by evaluating the canopy area - ! profile). - ! --------------------------------------------------------------------------------- - - - use EDTypesMod , only : ed_patch_type - use EDTypesMod , only : ed_cohort_type - - ! Arguments - type(ed_patch_type), target :: currentPatch - type(ed_cohort_type), pointer :: currentCohort - - ! Locals - integer :: cl ! Canopy Layer Index - integer :: ft ! Function Type Index - integer :: iv ! index of the exposed leaf layer for each canopy layer and pft - - ! Loop through the cohorts in this patch, associate each cohort with a layer and PFT - ! and use the cohort's memory of how many layer's it takes up to assign the maximum - ! of the layer/pft index it is in - ! --------------------------------------------------------------------------------- - - currentPatch%ncan(:,:) = 0 - ! redo the canopy structure algorithm to get round a - ! bug that is happening for site 125, FT13. - currentCohort => currentPatch%tallest - do while(associated(currentCohort)) - - currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft) = & - max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft), & - currentCohort%NV) - - currentCohort => currentCohort%shorter - - enddo !cohort - - ! NRAD = NCAN ... - currentPatch%nrad = currentPatch%ncan - - ! Now loop through and identify which layer and pft combo has scattering elements - do cl = 1,nclmax - do ft = 1,numpft - currentPatch%canopy_mask(cl,ft) = 0 - do iv = 1, currentPatch%nrad(cl,ft); - if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then - currentPatch%canopy_mask(cl,ft) = 1 - end if - end do !iv - enddo !ft - enddo !cl - - return - end subroutine UpdateCanopyNCanNRadPresent - - ! ==================================================================================== - - subroutine GetCanopyGasParameters(can_press, & - can_o2_partialpress, & - veg_tempk, & - air_tempk, & - air_vpress, & - veg_esat, & - rb, & - mm_kco2, & - mm_ko2, & - co2_cpoint, & - cf, & - gb_mol, & - ceair) - - ! --------------------------------------------------------------------------------- - ! This subroutine calculates the specific Michaelis Menten Parameters (pa) for CO2 - ! and O2, as well as the CO2 compentation point. - ! --------------------------------------------------------------------------------- - - use FatesConstantsMod, only: umol_per_mol - use FatesConstantsMod, only: mmol_per_mol - use FatesConstantsMod, only: umol_per_kmol - use FatesConstantsMod, only : rgas => rgas_J_K_kmol - - ! Arguments - real(r8), intent(in) :: can_press ! Air pressure within the canopy (Pa) - real(r8), intent(in) :: can_o2_partialpress ! Partial press of o2 in the canopy (Pa) - real(r8), intent(in) :: veg_tempk ! The temperature of the vegetation (K) - real(r8), intent(in) :: air_tempk ! Temperature of canopy air (K) - real(r8), intent(in) :: air_vpress ! Vapor pressure of canopy air (Pa) - real(r8), intent(in) :: veg_esat ! Saturated vapor pressure at veg surf (Pa) - real(r8), intent(in) :: rb ! Leaf Boundary layer resistance (s/m) - - real(r8), intent(out) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) - real(r8), intent(out) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) - real(r8), intent(out) :: co2_cpoint ! CO2 compensation point (Pa) - real(r8), intent(out) :: cf ! conversion factor between molar form and velocity form - ! of conductance and resistance: [umol/m3] - real(r8), intent(out) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) - real(r8), intent(out) :: ceair ! vapor pressure of air, constrained (Pa) - - ! Locals - real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) - real(r8) :: ko25 ! Michaelis-Menten constant for O2 at 25C (Pa) - real(r8) :: sco ! relative specificity of rubisco - real(r8) :: cp25 ! CO2 compensation point at 25C (Pa) - - ! --------------------------------------------------------------------------------- - ! Intensive values (per mol of air) - ! kc, ko, currentPatch, from: Bernacchi et al (2001) - ! Plant, Cell and Environment 24:253-259 - ! --------------------------------------------------------------------------------- - - real(r8), parameter :: mm_kc25_umol_per_mol = 404.9_r8 - real(r8), parameter :: mm_ko25_mmol_per_mol = 278.4_r8 - real(r8), parameter :: co2_cpoint_umol_per_mol = 42.75_r8 - - ! Activation energy, from: - ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 - ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 - - real(r8), parameter :: kcha = 79430._r8 ! activation energy for kc (J/mol) - real(r8), parameter :: koha = 36380._r8 ! activation energy for ko (J/mol) - real(r8), parameter :: cpha = 37830._r8 ! activation energy for cp (J/mol) - - - ! Derive sco from currentPatch and O2 using present-day O2 (0.209 mol/mol) and re-calculate - ! currentPatch to account for variation in O2 using currentPatch = 0.5 O2 / sco - - ! FIXME (RGK 11-30-2016 THere are more constants here, but I don't have enough information - ! about what they are or do, so I can't give them more descriptive names. Someone please - ! fill this in when possible) - - kc25 = ( mm_kc25_umol_per_mol / umol_per_mol ) * can_press - ko25 = ( mm_ko25_mmol_per_mol / mmol_per_mol ) * can_press - sco = 0.5_r8 * 0.209_r8 / (co2_cpoint_umol_per_mol / umol_per_mol ) - cp25 = 0.5_r8 * can_o2_partialpress / sco - - if( veg_tempk.gt.150_r8 .and. veg_tempk.lt.350_r8 )then - mm_kco2 = kc25 * ft1_f(veg_tempk, kcha) - mm_ko2 = ko25 * ft1_f(veg_tempk, koha) - co2_cpoint = cp25 * ft1_f(veg_tempk, cpha) - else - mm_kco2 = 1.0_r8 - mm_ko2 = 1.0_r8 - co2_cpoint = 1.0_r8 - end if - - ! --------------------------------------------------------------------------------- - ! - ! cf is the conversion factor between molar form and velocity form - ! of conductance and resistance: [umol/m3] - ! - ! i.e. - ! [m/s] * [umol/m3] -> [umol/m2/s] - ! - ! Breakdown of the conversion factor: [ umol / m3 ] - ! - ! Rgas [J /K /kmol] - ! Air Potential Temperature [ K ] - ! Canopy Pressure [ Pa ] - ! conversion: umol/kmol = 1e9 - ! - ! [ Pa * K * kmol umol/kmol / J K ] = [ Pa * umol / J ] - ! since: 1 Pa = 1 N / m2 - ! [ Pa * umol / J ] = [ N * umol / J m2 ] - ! since: 1 J = 1 N * m - ! [ N * umol / J m2 ] = [ N * umol / N m3 ] - ! [ umol / m3 ] - ! - ! -------------------------------------------------------------------------------- - - cf = can_press/(rgas * air_tempk )*umol_per_kmol - gb_mol = (1._r8/ rb) * cf - - ! Constrain eair >= 0.05*esat_tv so that solution does not blow up. This ensures - ! that hs does not go to zero. Also eair <= veg_esat so that hs <= 1 - ceair = min( max(air_vpress, 0.05_r8*veg_esat ),veg_esat ) - - - - return - end subroutine GetCanopyGasParameters - - ! ==================================================================================== + +end subroutine quadratic_fast + + +! ==================================================================================== + +subroutine UpdateCanopyNCanNRadPresent(currentPatch) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates two patch level quanities: + ! currentPatch%ncan and + ! currentPatch%canopy_mask + ! + ! currentPatch%ncan(:,:) is a two dimensional array that indicates + ! the total number of leaf layers (including those that are not exposed to light) + ! in each canopy layer and for each functional type. + ! + ! currentPatch%nrad(:,:) is a two dimensional array that indicates + ! the total number of EXPOSED leaf layers, but for all intents and purposes + ! in the photosynthesis routine, this appears to be the same as %ncan... + ! + ! currentPatch%canopy_mask(:,:) has the same dimensions, is binary, and + ! indicates whether or not leaf layers are present (by evaluating the canopy area + ! profile). + ! --------------------------------------------------------------------------------- + + + use EDTypesMod , only : ed_patch_type + use EDTypesMod , only : ed_cohort_type + + ! Arguments + type(ed_patch_type), target :: currentPatch + type(ed_cohort_type), pointer :: currentCohort + + ! Locals + integer :: cl ! Canopy Layer Index + integer :: ft ! Function Type Index + integer :: iv ! index of the exposed leaf layer for each canopy layer and pft + + ! Loop through the cohorts in this patch, associate each cohort with a layer and PFT + ! and use the cohort's memory of how many layer's it takes up to assign the maximum + ! of the layer/pft index it is in + ! --------------------------------------------------------------------------------- + + currentPatch%ncan(:,:) = 0 + ! redo the canopy structure algorithm to get round a + ! bug that is happening for site 125, FT13. + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + + currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft) = & + max(currentPatch%ncan(currentCohort%canopy_layer,currentCohort%pft), & + currentCohort%NV) + + currentCohort => currentCohort%shorter + + enddo !cohort + + ! NRAD = NCAN ... + currentPatch%nrad = currentPatch%ncan + + ! Now loop through and identify which layer and pft combo has scattering elements + do cl = 1,nclmax + do ft = 1,numpft + currentPatch%canopy_mask(cl,ft) = 0 + do iv = 1, currentPatch%nrad(cl,ft); + if(currentPatch%canopy_area_profile(cl,ft,iv) > 0._r8)then + currentPatch%canopy_mask(cl,ft) = 1 + end if + end do !iv + enddo !ft + enddo !cl + + return +end subroutine UpdateCanopyNCanNRadPresent + +! ==================================================================================== + +subroutine GetCanopyGasParameters(can_press, & + can_o2_partialpress, & + veg_tempk, & + air_tempk, & + air_vpress, & + veg_esat, & + rb, & + mm_kco2, & + mm_ko2, & + co2_cpoint, & + cf, & + gb_mol, & + ceair) + + ! --------------------------------------------------------------------------------- + ! This subroutine calculates the specific Michaelis Menten Parameters (pa) for CO2 + ! and O2, as well as the CO2 compentation point. + ! --------------------------------------------------------------------------------- + + use FatesConstantsMod, only: umol_per_mol + use FatesConstantsMod, only: mmol_per_mol + use FatesConstantsMod, only: umol_per_kmol + use FatesConstantsMod, only : rgas => rgas_J_K_kmol + + ! Arguments + real(r8), intent(in) :: can_press ! Air pressure within the canopy (Pa) + real(r8), intent(in) :: can_o2_partialpress ! Partial press of o2 in the canopy (Pa) + real(r8), intent(in) :: veg_tempk ! The temperature of the vegetation (K) + real(r8), intent(in) :: air_tempk ! Temperature of canopy air (K) + real(r8), intent(in) :: air_vpress ! Vapor pressure of canopy air (Pa) + real(r8), intent(in) :: veg_esat ! Saturated vapor pressure at veg surf (Pa) + real(r8), intent(in) :: rb ! Leaf Boundary layer resistance (s/m) + + real(r8), intent(out) :: mm_kco2 ! Michaelis-Menten constant for CO2 (Pa) + real(r8), intent(out) :: mm_ko2 ! Michaelis-Menten constant for O2 (Pa) + real(r8), intent(out) :: co2_cpoint ! CO2 compensation point (Pa) + real(r8), intent(out) :: cf ! conversion factor between molar form and velocity form + ! of conductance and resistance: [umol/m3] + real(r8), intent(out) :: gb_mol ! leaf boundary layer conductance (umol H2O/m**2/s) + real(r8), intent(out) :: ceair ! vapor pressure of air, constrained (Pa) + + ! Locals + real(r8) :: kc25 ! Michaelis-Menten constant for CO2 at 25C (Pa) + real(r8) :: ko25 ! Michaelis-Menten constant for O2 at 25C (Pa) + real(r8) :: sco ! relative specificity of rubisco + real(r8) :: cp25 ! CO2 compensation point at 25C (Pa) + + ! --------------------------------------------------------------------------------- + ! Intensive values (per mol of air) + ! kc, ko, currentPatch, from: Bernacchi et al (2001) + ! Plant, Cell and Environment 24:253-259 + ! --------------------------------------------------------------------------------- + + real(r8), parameter :: mm_kc25_umol_per_mol = 404.9_r8 + real(r8), parameter :: mm_ko25_mmol_per_mol = 278.4_r8 + real(r8), parameter :: co2_cpoint_umol_per_mol = 42.75_r8 + + ! Activation energy, from: + ! Bernacchi et al (2001) Plant, Cell and Environment 24:253-259 + ! Bernacchi et al (2003) Plant, Cell and Environment 26:1419-1430 + + real(r8), parameter :: kcha = 79430._r8 ! activation energy for kc (J/mol) + real(r8), parameter :: koha = 36380._r8 ! activation energy for ko (J/mol) + real(r8), parameter :: cpha = 37830._r8 ! activation energy for cp (J/mol) + + + ! Derive sco from currentPatch and O2 using present-day O2 (0.209 mol/mol) and re-calculate + ! currentPatch to account for variation in O2 using currentPatch = 0.5 O2 / sco + + ! FIXME (RGK 11-30-2016 THere are more constants here, but I don't have enough information + ! about what they are or do, so I can't give them more descriptive names. Someone please + ! fill this in when possible) + + kc25 = ( mm_kc25_umol_per_mol / umol_per_mol ) * can_press + ko25 = ( mm_ko25_mmol_per_mol / mmol_per_mol ) * can_press + sco = 0.5_r8 * 0.209_r8 / (co2_cpoint_umol_per_mol / umol_per_mol ) + cp25 = 0.5_r8 * can_o2_partialpress / sco + + if( veg_tempk.gt.150_r8 .and. veg_tempk.lt.350_r8 )then + mm_kco2 = kc25 * ft1_f(veg_tempk, kcha) + mm_ko2 = ko25 * ft1_f(veg_tempk, koha) + co2_cpoint = cp25 * ft1_f(veg_tempk, cpha) + else + mm_kco2 = 1.0_r8 + mm_ko2 = 1.0_r8 + co2_cpoint = 1.0_r8 + end if + + ! --------------------------------------------------------------------------------- + ! + ! cf is the conversion factor between molar form and velocity form + ! of conductance and resistance: [umol/m3] + ! + ! i.e. + ! [m/s] * [umol/m3] -> [umol/m2/s] + ! + ! Breakdown of the conversion factor: [ umol / m3 ] + ! + ! Rgas [J /K /kmol] + ! Air Potential Temperature [ K ] + ! Canopy Pressure [ Pa ] + ! conversion: umol/kmol = 1e9 + ! + ! [ Pa * K * kmol umol/kmol / J K ] = [ Pa * umol / J ] + ! since: 1 Pa = 1 N / m2 + ! [ Pa * umol / J ] = [ N * umol / J m2 ] + ! since: 1 J = 1 N * m + ! [ N * umol / J m2 ] = [ N * umol / N m3 ] + ! [ umol / m3 ] + ! + ! -------------------------------------------------------------------------------- + + cf = can_press/(rgas * air_tempk )*umol_per_kmol + gb_mol = (1._r8/ rb) * cf + + ! Constrain eair >= 0.05*esat_tv so that solution does not blow up. This ensures + ! that hs does not go to zero. Also eair <= veg_esat so that hs <= 1 + ceair = min( max(air_vpress, 0.05_r8*veg_esat ),veg_esat ) + + + + return +end subroutine GetCanopyGasParameters + +! ==================================================================================== + +subroutine LeafLayerMaintenanceRespiration(lmr25top_ft, & + nscaler, & + ft, & + veg_tempk, & + lmr) + + use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm - 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) + ! 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, & + co2_rcurve_islope25top_ft, & + nscaler, & + veg_tempk, & + btran, & + vcmax, & + jmax, & + 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, + ! 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) :: 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) :: 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) :: co2_rcurve_islope25 ! leaf layer: Initial slope of CO2 response curve + ! (C4 plants) at 25C - ! 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, & - co2_rcurve_islope25top_ft, & - nscaler, & - veg_tempk, & - btran, & - vcmax, & - jmax, & - 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, - ! 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) :: 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) :: 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) :: 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) :: vcmaxhd ! deactivation energy for vcmax (J/mol) - real(r8) :: jmaxhd ! deactivation energy for jmax (J/mol) - real(r8) :: vcmaxse ! entropy term for vcmax (J/mol/K) - real(r8) :: jmaxse ! entropy term for jmax (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) - - vcmaxha = EDPftvarcon_inst%vcmaxha(FT) - jmaxha = EDPftvarcon_inst%jmaxha(FT) - - vcmaxhd = EDPftvarcon_inst%vcmaxhd(FT) - jmaxhd = EDPftvarcon_inst%jmaxhd(FT) - - vcmaxse = EDPftvarcon_inst%vcmaxse(FT) - jmaxse = EDPftvarcon_inst%jmaxse(FT) - - vcmaxc = fth25_f(vcmaxhd, vcmaxse) - jmaxc = fth25_f(jmaxhd, jmaxse) - - if ( parsun_lsl <= 0._r8) then ! night time - vcmax = 0._r8 - jmax = 0._r8 - co2_rcurve_islope = 0._r8 - else ! day time - - ! Vcmax25top was already calculated to derive the nscaler function - vcmax25 = vcmax25top_ft * nscaler - jmax25 = jmax25top_ft * nscaler - 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) - - 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) + + ! Parameters + ! --------------------------------------------------------------------------------- + real(r8) :: vcmaxha ! activation energy for vcmax (J/mol) + real(r8) :: jmaxha ! activation energy for jmax (J/mol) + real(r8) :: vcmaxhd ! deactivation energy for vcmax (J/mol) + real(r8) :: jmaxhd ! deactivation energy for jmax (J/mol) + real(r8) :: vcmaxse ! entropy term for vcmax (J/mol/K) + real(r8) :: jmaxse ! entropy term for jmax (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) + + vcmaxha = EDPftvarcon_inst%vcmaxha(FT) + jmaxha = EDPftvarcon_inst%jmaxha(FT) + + vcmaxhd = EDPftvarcon_inst%vcmaxhd(FT) + jmaxhd = EDPftvarcon_inst%jmaxhd(FT) + + vcmaxse = EDPftvarcon_inst%vcmaxse(FT) + jmaxse = EDPftvarcon_inst%jmaxse(FT) + + vcmaxc = fth25_f(vcmaxhd, vcmaxse) + jmaxc = fth25_f(jmaxhd, jmaxse) + + if ( parsun_lsl <= 0._r8) then ! night time + vcmax = 0._r8 + jmax = 0._r8 + co2_rcurve_islope = 0._r8 + else ! day time + + ! Vcmax25top was already calculated to derive the nscaler function + vcmax25 = vcmax25top_ft * nscaler + jmax25 = jmax25top_ft * nscaler + 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) + + 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 - - ! Adjust for water limitations - vcmax = vcmax * btran - - return - end subroutine LeafLayerBiophysicalRates - - subroutine lowstorage_maintresp_reduction(frac, pft, maintresp_reduction_factor) - - ! This subroutine reduces maintenance respiration rates when storage pool is low. The premise - ! of this is that mortality of plants increases when storage is low because they are not able - ! to repair tissues, generate defense compounds, etc. This reduction is reflected in a reduced - ! maintenance demand. The output of this function takes the form of a curve between 0 and 1, - ! and the curvature of the function is determined by a parameter. - - ! Uses - use EDPftvarcon , only : EDPftvarcon_inst - - ! Arguments - ! ------------------------------------------------------------------------------ - real(r8), intent(in) :: frac ! ratio of storage to target leaf biomass - integer, intent(in) :: pft ! what pft is this cohort? - real(r8), intent(out) :: maintresp_reduction_factor ! the factor by which to reduce maintenance respiration - - ! -------------------------------------------------------------------------------- - ! Parameters are at the PFT level: - ! fates_maintresp_reduction_curvature controls the curvature of this. - ! If this parameter is zero, then there is no reduction until the plant dies at storage = 0. - ! If this parameter is one, then there is a linear reduction in respiration below the storage point. - ! Intermediate values will give some (concave-downwards) curvature. - ! - ! maintresp_reduction_intercept controls the maximum amount of throttling. - ! zero means no throttling at any point, so it turns this mechanism off completely and so - ! allows an entire cohort to die via negative carbon-induced termination mortality. - ! one means complete throttling, so no maintenance respiration at all, when out of carbon. - ! --------------------------------------------------------------------------------- - - if( frac .lt. 1._r8 )then - if ( EDPftvarcon_inst%maintresp_reduction_curvature(pft) .ne. 1._r8 ) then - maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & - EDPftvarcon_inst%maintresp_reduction_intercept(pft) * & - (1._r8 - EDPftvarcon_inst%maintresp_reduction_curvature(pft)**frac) & - / (1._r8-EDPftvarcon_inst%maintresp_reduction_curvature(pft)) - else ! avoid nan answer for linear case - maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & - EDPftvarcon_inst%maintresp_reduction_intercept(pft) * frac - endif - - else - maintresp_reduction_factor = 1._r8 - endif - - - end subroutine lowstorage_maintresp_reduction - - end module FATESPlantRespPhotosynthMod + !q10 response of product limited psn. + co2_rcurve_islope = co2_rcurve_islope25 * 2._r8**((veg_tempk-(tfrz+25._r8))/10._r8) + end if + + ! Adjust for water limitations + vcmax = vcmax * btran + + return +end subroutine LeafLayerBiophysicalRates + +subroutine lowstorage_maintresp_reduction(frac, pft, maintresp_reduction_factor) + + ! This subroutine reduces maintenance respiration rates when storage pool is low. The premise + ! of this is that mortality of plants increases when storage is low because they are not able + ! to repair tissues, generate defense compounds, etc. This reduction is reflected in a reduced + ! maintenance demand. The output of this function takes the form of a curve between 0 and 1, + ! and the curvature of the function is determined by a parameter. + + ! Uses + use EDPftvarcon , only : EDPftvarcon_inst + + ! Arguments + ! ------------------------------------------------------------------------------ + real(r8), intent(in) :: frac ! ratio of storage to target leaf biomass + integer, intent(in) :: pft ! what pft is this cohort? + real(r8), intent(out) :: maintresp_reduction_factor ! the factor by which to reduce maintenance respiration + + ! -------------------------------------------------------------------------------- + ! Parameters are at the PFT level: + ! fates_maintresp_reduction_curvature controls the curvature of this. + ! If this parameter is zero, then there is no reduction until the plant dies at storage = 0. + ! If this parameter is one, then there is a linear reduction in respiration below the storage point. + ! Intermediate values will give some (concave-downwards) curvature. + ! + ! maintresp_reduction_intercept controls the maximum amount of throttling. + ! zero means no throttling at any point, so it turns this mechanism off completely and so + ! allows an entire cohort to die via negative carbon-induced termination mortality. + ! one means complete throttling, so no maintenance respiration at all, when out of carbon. + ! --------------------------------------------------------------------------------- + + if( frac .lt. 1._r8 )then + if ( EDPftvarcon_inst%maintresp_reduction_curvature(pft) .ne. 1._r8 ) then + maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & + EDPftvarcon_inst%maintresp_reduction_intercept(pft) * & + (1._r8 - EDPftvarcon_inst%maintresp_reduction_curvature(pft)**frac) & + / (1._r8-EDPftvarcon_inst%maintresp_reduction_curvature(pft)) + else ! avoid nan answer for linear case + maintresp_reduction_factor = (1._r8 - EDPftvarcon_inst%maintresp_reduction_intercept(pft)) + & + EDPftvarcon_inst%maintresp_reduction_intercept(pft) * frac + endif + + else + maintresp_reduction_factor = 1._r8 + endif + + +end subroutine lowstorage_maintresp_reduction + +end module FATESPlantRespPhotosynthMod diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 127dfa43f9..aedcb4aa7c 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -46,6 +46,7 @@ module SFMainMod use PRTGenericMod, only : struct_organ use PRTGenericMod, only : SetState use FatesInterfaceTypesMod , only : numpft + use FatesAllometryMod, only : CrownDepth implicit none private @@ -142,7 +143,7 @@ subroutine fire_danger_index ( currentSite, bc_in) iofp = currentSite%oldest_patch%patchno - temp_in_C = bc_in%t_veg24_pa(iofp) - tfrz + temp_in_C = currentSite%oldest_patch%tveg24%GetMean() - tfrz rainfall = bc_in%precip24_pa(iofp)*sec_per_day rh = bc_in%relhumid24_pa(iofp) @@ -908,7 +909,8 @@ subroutine crown_damage ( currentSite ) type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort - + real(r8) :: crown_depth ! Depth of crown in meters + currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) @@ -921,20 +923,21 @@ subroutine crown_damage ( currentSite ) if ( int(prt_params%woody(currentCohort%pft)) == itrue) then !trees only ! Flames lower than bottom of canopy. ! c%hite is height of cohort + + call CrownDepth(currentCohort%hite,currentCohort%pft,crown_depth) + if (currentPatch%Scorch_ht(currentCohort%pft) < & - (currentCohort%hite-currentCohort%hite*EDPftvarcon_inst%crown(currentCohort%pft))) then + (currentCohort%hite-crown_depth)) then currentCohort%fraction_crown_burned = 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%Scorch_ht(currentCohort%pft) >= & - (currentCohort%hite-currentCohort%hite*EDPftvarcon_inst%crown(currentCohort%pft)))) then + (currentCohort%hite-crown_depth))) then currentCohort%fraction_crown_burned = (currentPatch%Scorch_ht(currentCohort%pft) - & - currentCohort%hite*(1.0_r8 - & - EDPftvarcon_inst%crown(currentCohort%pft)))/(currentCohort%hite* & - EDPftvarcon_inst%crown(currentCohort%pft)) + (currentCohort%hite - crown_depth))/crown_depth else ! Flames over top of canopy. diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index bb380b0a00..7463a2a8a4 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -1,7 +1,7 @@ module EDInitMod ! ============================================================================ - ! Contains all modules to set up the ED structure. + ! Contains all modules to set up the ED structure. ! ============================================================================ use FatesConstantsMod , only : r8 => fates_r8 @@ -9,6 +9,7 @@ module EDInitMod use FatesConstantsMod , only : itrue use FatesConstantsMod , only : fates_unset_int use FatesConstantsMod , only : primaryforest + use FatesConstantsMod , only : nearzero use FatesGlobals , only : endrun => fates_endrun use EDTypesMod , only : nclmax use FatesGlobals , only : fates_log @@ -18,6 +19,8 @@ module EDInitMod use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts use EDCohortDynamicsMod , only : InitPRTObject use EDPatchDynamicsMod , only : create_patch + use EDPatchDynamicsMod , only : set_patchno + use EDPhysiologyMod , only : assign_cohort_sp_properties use ChecksBalancesMod , only : SiteMassStock use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDTypesMod , only : numWaterMem @@ -36,15 +39,18 @@ module EDInitMod use EDTypesMod , only : phen_dstat_moistoff use EDTypesMod , only : phen_cstat_notcold use EDTypesMod , only : phen_dstat_moiston - use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : bc_in_type,bc_out_type use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_use_inventory_init use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog + use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : numpft use FatesInterfaceTypesMod , only : nleafage use FatesInterfaceTypesMod , only : nlevsclass use FatesInterfaceTypesMod , only : nlevcoage + use FatesInterfaceTypesMod , only : hlm_use_nocomp use FatesInterfaceTypesMod , only : nlevage + use FatesAllometryMod , only : h2d_allom use FatesAllometryMod , only : bagw_allom use FatesAllometryMod , only : bbgw_allom @@ -53,7 +59,7 @@ module EDInitMod use FatesAllometryMod , only : bsap_allom use FatesAllometryMod , only : bdead_allom use FatesAllometryMod , only : bstore_allom - + use PRTGenericMod , only : StorageNutrientTarget use FatesInterfaceTypesMod, only : hlm_parteh_mode use PRTGenericMod, only : prt_carbon_allom_hyp use PRTGenericMod, only : prt_cnp_flex_allom_hyp @@ -68,7 +74,8 @@ module EDInitMod use PRTGenericMod, only : nitrogen_element use PRTGenericMod, only : phosphorus_element use PRTGenericMod, only : SetState - + use FatesSizeAgeTypeIndicesMod,only : get_age_class_index + ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg @@ -78,7 +85,7 @@ module EDInitMod logical :: debug = .false. character(len=*), parameter, private :: sourcefile = & - __FILE__ + __FILE__ public :: zero_site public :: init_site_vars @@ -93,14 +100,15 @@ module EDInitMod ! ============================================================================ - subroutine init_site_vars( site_in, bc_in ) + subroutine init_site_vars( site_in, bc_in, bc_out ) ! ! !DESCRIPTION: ! ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout) :: site_in - type(bc_in_type),intent(in) :: bc_in + type(bc_in_type),intent(in),target :: bc_in + type(bc_out_type),intent(in),target :: bc_out ! ! !LOCAL VARIABLES: !---------------------------------------------------------------------- @@ -119,36 +127,45 @@ subroutine init_site_vars( site_in, bc_in ) allocate(site_in%growthflux_fusion(1:nlevsclass,1:numpft)) allocate(site_in%mass_balance(1:num_elements)) allocate(site_in%flux_diags(1:num_elements)) - + site_in%nlevsoil = bc_in%nlevsoil allocate(site_in%rootfrac_scr(site_in%nlevsoil)) allocate(site_in%zi_soil(0:site_in%nlevsoil)) allocate(site_in%dz_soil(site_in%nlevsoil)) allocate(site_in%z_soil(site_in%nlevsoil)) - allocate(site_in%area_pft(1:numpft)) + if (hlm_use_nocomp .eq. itrue) then + allocate(site_in%area_pft(0:numpft)) + else ! SP and nocomp require a bare-ground patch. + allocate(site_in%area_pft(1:numpft)) + endif + allocate(site_in%use_this_pft(1:numpft)) + allocate(site_in%area_by_age(1:nlevage)) + + + ! SP mode + allocate(site_in%sp_tlai(1:numpft)) + allocate(site_in%sp_tsai(1:numpft)) + allocate(site_in%sp_htop(1:numpft)) do el=1,num_elements - allocate(site_in%flux_diags(el)%leaf_litter_input(1:numpft)) - allocate(site_in%flux_diags(el)%root_litter_input(1:numpft)) - allocate(site_in%flux_diags(el)%nutrient_efflux_scpf(nlevsclass*numpft)) - allocate(site_in%flux_diags(el)%nutrient_uptake_scpf(nlevsclass*numpft)) - allocate(site_in%flux_diags(el)%nutrient_needgrow_scpf(nlevsclass*numpft)) - allocate(site_in%flux_diags(el)%nutrient_needmax_scpf(nlevsclass*numpft)) + allocate(site_in%flux_diags(el)%leaf_litter_input(1:numpft)) + allocate(site_in%flux_diags(el)%root_litter_input(1:numpft)) + allocate(site_in%flux_diags(el)%nutrient_efflux_scpf(nlevsclass*numpft)) + allocate(site_in%flux_diags(el)%nutrient_uptake_scpf(nlevsclass*numpft)) + allocate(site_in%flux_diags(el)%nutrient_need_scpf(nlevsclass*numpft)) end do - ! Initialize the static soil + ! Initialize the static soil ! arrays from the boundary (initial) condition - site_in%zi_soil(:) = bc_in%zi_sisl(:) site_in%dz_soil(:) = bc_in%dz_sisl(:) site_in%z_soil(:) = bc_in%z_sisl(:) - ! - end subroutine init_site_vars + end subroutine init_site_vars ! ============================================================================ subroutine zero_site( site_in ) @@ -158,7 +175,7 @@ subroutine zero_site( site_in ) ! !USES: use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout) :: site_in ! ! !LOCAL VARIABLES: @@ -167,9 +184,9 @@ subroutine zero_site( site_in ) site_in%oldest_patch => null() ! pointer to oldest patch at the site site_in%youngest_patch => null() ! pointer to yngest patch at the site - - ! PHENOLOGY + + ! PHENOLOGY site_in%cstatus = fates_unset_int ! are leaves in this pixel on or off? site_in%dstatus = fates_unset_int @@ -184,10 +201,17 @@ subroutine zero_site( site_in ) site_in%water_memory(:) = nan site_in%vegtemp_memory(:) = nan ! record of last 10 days temperature for senescence model. + ! Disturbance rates tracking + site_in%primary_land_patchfusion_error = 0.0_r8 + site_in%potential_disturbance_rates(:) = 0.0_r8 + site_in%disturbance_rates_secondary_to_secondary(:) = 0.0_r8 + site_in%disturbance_rates_primary_to_secondary(:) = 0.0_r8 + site_in%disturbance_rates_primary_to_primary(:) = 0.0_r8 - ! FIRE + ! FIRE site_in%acc_ni = 0.0_r8 ! daily nesterov index accumulating over time. time unlimited theoretically. - site_in%NF = 0.0_r8 ! daily lightning strikes per km2 + site_in%FDI = 0.0_r8 ! daily fire danger index (0-1) + site_in%NF = 0.0_r8 ! daily lightning strikes per km2 site_in%NF_successful = 0.0_r8 ! daily successful iginitions per km2 do el=1,num_elements @@ -196,7 +220,7 @@ subroutine zero_site( site_in ) call site_in%mass_balance(el)%ZeroMassBalFlux() call site_in%flux_diags(el)%ZeroFluxDiags() end do - + ! termination and recruitment info site_in%term_nindivs_canopy(:,:) = 0._r8 @@ -221,7 +245,7 @@ subroutine zero_site( site_in ) site_in%demotion_carbonflux = 0._r8 site_in%promotion_rate(:) = 0._r8 site_in%promotion_carbonflux = 0._r8 - + ! Resources management (logging/harvesting, etc) site_in%resources_management%trunk_product_site = 0.0_r8 @@ -230,6 +254,8 @@ subroutine zero_site( site_in ) site_in%area_pft(:) = 0._r8 site_in%use_this_pft(:) = fates_unset_int + site_in%area_by_age(:) = 0._r8 + end subroutine zero_site ! ============================================================================ @@ -239,7 +265,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) ! ! !USES: ! - ! !ARGUMENTS + ! !ARGUMENTS integer, intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) @@ -251,12 +277,15 @@ subroutine set_site_properties( nsites, sites,bc_in ) real(r8) :: GDD integer :: dstat ! drought status phenology flag real(r8) :: acc_NI - real(r8) :: watermem + real(r8) :: watermem integer :: cleafon ! DOY for cold-decid leaf-on, initial guess integer :: cleafoff ! DOY for cold-decid leaf-off, initial guess integer :: dleafoff ! DOY for drought-decid leaf-off, initial guess integer :: dleafon ! DOY for drought-decid leaf-on, initial guess integer :: ft ! PFT loop + real(r8) :: sumarea ! area of PFTs in nocomp mode. + integer :: hlm_pft ! used in fixed biogeog mode + integer :: fates_pft ! used in fixed biogeog mode !---------------------------------------------------------------------- @@ -269,7 +298,7 @@ subroutine set_site_properties( nsites, sites,bc_in ) GDD = 30.0_r8 cleafon = 100 - cleafoff = 300 + cleafoff = 300 cstat = phen_cstat_notcold ! Leaves are on acc_NI = 0.0_r8 dstat = phen_dstat_moiston ! Leaves are on @@ -280,47 +309,104 @@ subroutine set_site_properties( nsites, sites,bc_in ) do s = 1,nsites sites(s)%nchilldays = 0 sites(s)%ncolddays = 0 ! recalculated in phenology - ! immediately, so yes this - ! is memory-less, but needed - ! for first value in history file + ! immediately, so yes this + ! is memory-less, but needed + ! for first value in history file sites(s)%cleafondate = cleafon sites(s)%cleafoffdate = cleafoff sites(s)%dleafoffdate = dleafoff sites(s)%dleafondate = dleafon sites(s)%grow_deg_days = GDD - + sites(s)%water_memory(1:numWaterMem) = watermem sites(s)%vegtemp_memory(1:num_vegtemp_mem) = 0._r8 - + sites(s)%cstatus = cstat sites(s)%dstatus = dstat - + sites(s)%acc_NI = acc_NI - sites(s)%NF = 0.0_r8 + sites(s)%NF = 0.0_r8 sites(s)%NF_successful = 0.0_r8 - - ! PLACEHOLDER FOR PFT AREA DATA MOVED ACROSS INTERFACE + if(hlm_use_fixed_biogeog.eq.itrue)then - do ft = 1,numpft - sites(s)%area_pft(ft) = bc_in(s)%pft_areafrac(ft) - end do - end if + ! MAPPING OF FATES PFTs on to HLM_PFTs + ! add up the area associated with each FATES PFT + ! where pft_areafrac is the area of land in each HLM PFT and (from surface dataset) + ! hlm_pft_map is the area of that land in each FATES PFT (from param file) + + sites(s)%area_pft(1:numpft) = 0._r8 + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + do fates_pft = 1,numpft ! loop round all fates pfts for all hlm pfts + sites(s)%area_pft(fates_pft) = sites(s)%area_pft(fates_pft) + & + EDPftvarcon_inst%hlm_pft_map(fates_pft,hlm_pft) * bc_in(s)%pft_areafrac(hlm_pft) + end do + end do !hlm_pft + + do ft = 1,numpft + if(sites(s)%area_pft(ft).lt.0.01_r8.and.sites(s)%area_pft(ft).gt.0.0_r8)then + write(fates_log(),*) 'removing small pft patches',s,ft,sites(s)%area_pft(ft) + sites(s)%area_pft(ft)=0.0_r8 + ! remove tiny patches to prevent numerical errors in terminate patches + endif + if(sites(s)%area_pft(ft).lt.0._r8)then + write(fates_log(),*) 'negative area',s,ft,sites(s)%area_pft(ft) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + sites(s)%area_pft(ft)= sites(s)%area_pft(ft) * AREA ! rescale units to m2. + end do + + ! re-normalize PFT area to ensure it sums to one. + ! note that in areas of 'bare ground' (PFT 0 in CLM/ELM) + ! the bare ground will no longer be proscribed and should emerge from FATES + ! this may or may not be the right way to deal with this? + + if(hlm_use_nocomp.eq.ifalse)then ! when not in nocomp (i.e. or SP) mode, + ! subsume bare ground evenly into the existing patches. + + sumarea = sum(sites(s)%area_pft(1:numpft)) + do ft = 1,numpft + if(sumarea.gt.0._r8)then + sites(s)%area_pft(ft) = area * sites(s)%area_pft(ft)/sumarea + else + sites(s)%area_pft(ft) = area/numpft + ! in nocomp mode where there is only bare ground, we assign equal area to + ! all pfts and let the model figure out whether land should be bare or not. + end if + end do !ft + else ! for sp and nocomp mode, assert a bare ground patch if needed + sumarea = sum(sites(s)%area_pft(1:numpft)) + + ! In all the other FATES modes, bareground is the area in which plants + ! do not grow of their own accord. In SP mode we assert that the canopy is full for + ! each PFT patch. Thus, we also need to assert a bare ground area in + ! order to not have all of the ground filled by leaves. + + ! Further to that, one could calculate bare ground as the remaining area when + ! all fhe canopies are accounted for, but this means we don't pass balance checks + ! on canopy are inside FATES, and so in SP mode, we define the bare groud + ! patch as having a PFT identifier as zero. + + if(sumarea.lt.area)then !make some bare ground + sites(s)%area_pft(0) = area - sumarea + else + sites(s)%area_pft(0) = 0.0_r8 + end if + end if !sp mode + end if !fixed biogeog do ft = 1,numpft - sites(s)%use_this_pft(ft) = itrue - if(hlm_use_fixed_biogeog.eq.itrue)then - if(sites(s)%area_pft(ft).gt.0.0_r8)then - sites(s)%use_this_pft(ft) = itrue - else - sites(s)%use_this_pft(ft) = ifalse - end if !area - end if !SBG + sites(s)%use_this_pft(ft) = itrue + if(hlm_use_fixed_biogeog.eq.itrue)then + if(sites(s)%area_pft(ft).gt.0.0_r8)then + sites(s)%use_this_pft(ft) = itrue + else + sites(s)%use_this_pft(ft) = ifalse + end if !area + end if !SBG end do !ft - - end do - - end if + end do !site loop + end if !restart return end subroutine set_site_properties @@ -328,157 +414,249 @@ end subroutine set_site_properties ! ============================================================================ subroutine init_patches( nsites, sites, bc_in) - ! - ! !DESCRIPTION: - ! initialize patches - ! This may be call a near bare ground initialization, or it may - ! load patches from an inventory. - - ! - - - use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydProps - use FatesInventoryInitMod, only : initialize_sites_by_inventory - - ! - ! !ARGUMENTS - integer, intent(in) :: nsites - type(ed_site_type) , intent(inout), target :: sites(nsites) - type(bc_in_type), intent(in) :: bc_in(nsites) - ! - ! !LOCAL VARIABLES: - integer :: s - integer :: el - real(r8) :: age !notional age of this patch - - ! dummy locals - real(r8) :: biomass_stock - real(r8) :: litter_stock - real(r8) :: seed_stock - - type(ed_site_type), pointer :: sitep - type(ed_patch_type), pointer :: newp - type(ed_patch_type), pointer :: currentPatch - - ! List out some nominal patch values that are used for Near Bear Ground initializations - ! as well as initializing inventory - age = 0.0_r8 - ! --------------------------------------------------------------------------------------------- - - ! --------------------------------------------------------------------------------------------- - ! Two primary options, either a Near Bear Ground (NBG) or Inventory based cold-start - ! --------------------------------------------------------------------------------------------- - - if ( hlm_use_inventory_init.eq.itrue ) then - - ! Initialize the site-level crown area spread factor (0-1) - ! It is likely that closed canopy forest inventories - ! have smaller spread factors than bare ground (they are crowded) - do s = 1, nsites - sites(s)%spread = init_spread_inventory - enddo - - call initialize_sites_by_inventory(nsites,sites,bc_in) - - - ! For carbon balance checks, we need to initialize the - ! total carbon stock - do s = 1, nsites - do el=1,num_elements - call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & - biomass_stock,litter_stock,seed_stock) - end do - enddo - - else - - !FIX(SPM,032414) clean this up...inits out of this loop - do s = 1, nsites - - ! Initialize the site-level crown area spread factor (0-1) - ! It is likely that closed canopy forest inventories - ! have smaller spread factors than bare ground (they are crowded) - sites(s)%spread = init_spread_near_bare_ground - - 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, primaryforest) - - ! Initialize the litter pools to zero, these - ! pools will be populated by looping over the existing patches - ! and transfering in mass - do el=1,num_elements - call newp%litter(el)%InitConditions(init_leaf_fines=0._r8, & - init_root_fines=0._r8, & - init_ag_cwd=0._r8, & - init_bg_cwd=0._r8, & - init_seed=0._r8, & - init_seed_germ=0._r8) - end do - - sitep => sites(s) - call init_cohorts(sitep, newp, bc_in(s)) - - ! For carbon balance checks, we need to initialize the - ! total carbon stock - do el=1,num_elements - call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & - biomass_stock,litter_stock,seed_stock) - end do - enddo - - end if + ! + ! !DESCRIPTION: + ! initialize patches + ! This may be call a near bare ground initialization, or it may + ! load patches from an inventory. + + ! + + + use FatesPlantHydraulicsMod, only : updateSizeDepRhizHydProps + use FatesInventoryInitMod, only : initialize_sites_by_inventory + + ! + ! !ARGUMENTS + integer, intent(in) :: nsites + type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type), intent(in) :: bc_in(nsites) + ! + ! !LOCAL VARIABLES: + integer :: s + integer :: el + real(r8) :: age !notional age of this patch + integer :: ageclass + + ! dummy locals + real(r8) :: biomass_stock + real(r8) :: litter_stock + real(r8) :: seed_stock + integer :: n + integer :: start_patch + integer :: num_new_patches + integer :: nocomp_pft + real(r8) :: newparea + real(r8) :: tota !check on area + integer :: is_first_patch + + type(ed_site_type), pointer :: sitep + type(ed_patch_type), pointer :: newppft(:) + type(ed_patch_type), pointer :: newp + type(ed_patch_type), pointer :: currentPatch + + ! List out some nominal patch values that are used for Near Bear Ground initializations + ! as well as initializing inventory + age = 0.0_r8 + ! --------------------------------------------------------------------------------------------- + + ! --------------------------------------------------------------------------------------------- + ! Two primary options, either a Near Bear Ground (NBG) or Inventory based cold-start + ! --------------------------------------------------------------------------------------------- + + if ( hlm_use_inventory_init.eq.itrue ) then + + ! Initialize the site-level crown area spread factor (0-1) + ! It is likely that closed canopy forest inventories + ! have smaller spread factors than bare ground (they are crowded) + do s = 1, nsites + sites(s)%spread = init_spread_inventory + enddo + + call initialize_sites_by_inventory(nsites,sites,bc_in) + + + ! For carbon balance checks, we need to initialize the + ! total carbon stock + do s = 1, nsites + do el=1,num_elements + call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & + biomass_stock,litter_stock,seed_stock) + end do + enddo + + else + + do s = 1, nsites + sites(s)%sp_tlai(:) = 0._r8 + sites(s)%sp_tsai(:) = 0._r8 + sites(s)%sp_htop(:) = 0._r8 + + ! Initialize the site-level crown area spread factor (0-1) + ! It is likely that closed canopy forest inventories + ! have smaller spread factors than bare ground (they are crowded) + sites(s)%spread = init_spread_near_bare_ground + + start_patch = 1 ! start at the first vegetated patch + if(hlm_use_nocomp.eq.itrue)then + num_new_patches = numpft + if( hlm_use_fixed_biogeog .eq.itrue )then + start_patch = 0 ! start at the bare ground patch + endif + ! allocate(newppft(numpft)) + else !default + num_new_patches = 1 + end if !nocomp + + is_first_patch = itrue + do n = start_patch, num_new_patches + + ! set the PFT index for patches if in nocomp mode. + if(hlm_use_nocomp.eq.itrue)then + nocomp_pft = n + else + nocomp_pft = fates_unset_int + end if + + if(hlm_use_nocomp.eq.itrue)then + ! In no competition mode, if we are using the fixed_biogeog filter + ! then each PFT has the area dictated by the surface dataset. + + ! If we are not using fixed biogeog model, each PFT gets the same area. + ! i.e. each grid cell is divided exactly into the number of FATES PFTs. + + if(hlm_use_fixed_biogeog.eq.itrue)then + newparea = sites(s)%area_pft(nocomp_pft) + else + newparea = area / numpft + end if + else ! The default case is initialized w/ one patch with the area of the whole site. + newparea = area + end if !nocomp mode + + if(newparea.gt.0._r8)then ! Stop patches being initilialized when PFT not present in nocomop mode + allocate(newp) + + call create_patch(sites(s), newp, age, newparea, primaryforest, nocomp_pft) + + if(is_first_patch.eq.itrue)then !is this the first patch? + ! set poointers for first patch (or only patch, if nocomp is false) + newp%patchno = 1 + newp%younger => null() + newp%older => null() + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp + is_first_patch = ifalse + else + ! Set pointers for N>1 patches. Note this only happens when nocomp mode s on. + ! The new patch is the 'youngest' one, arbitrarily. + newp%patchno = nocomp_pft + newp%older => sites(s)%youngest_patch + newp%younger => null() + sites(s)%youngest_patch%younger => newp + sites(s)%youngest_patch => newp + end if + + ! Initialize the litter pools to zero, these + ! pools will be populated by looping over the existing patches + ! and transfering in mass + do el=1,num_elements + call newp%litter(el)%InitConditions(init_leaf_fines=0._r8, & + init_root_fines=0._r8, & + init_ag_cwd=0._r8, & + init_bg_cwd=0._r8, & + init_seed=0._r8, & + init_seed_germ=0._r8) + end do + + sitep => sites(s) + if(hlm_use_sp.eq.itrue)then + if(nocomp_pft.ne.0)then !don't initialize cohorts for SP bare ground patch + call init_cohorts(sitep, newp, bc_in(s)) + end if + else ! normal non SP case always call init cohorts + call init_cohorts(sitep, newp, bc_in(s)) + end if + end if + end do !no new patches + + !check if the total area adds to the same as site area + tota = 0.0_r8 + newp => sites(s)%oldest_patch + do while (associated(newp)) + tota=tota+newp%area + newp=>newp%younger + end do + + if(abs(tota-area).gt.nearzero*area)then + if(abs(tota-area).lt.1.0e-10_r8)then ! this is a precision error + if(sites(s)%oldest_patch%area.gt.(tota-area+nearzero))then + ! remove or add extra area + ! if the oldest patch has enough area, use that + sites(s)%oldest_patch%area = sites(s)%oldest_patch%area - (tota-area) + write(*,*) 'fixing patch precision - oldest',s, tota-area + else ! or otherwise take the area from the youngest patch. + sites(s)%youngest_patch%area = sites(s)%oldest_patch%area - (tota-area) + write(*,*) 'fixing patch precision -youngest ',s, tota-area + endif + else !this is a big error not just a precision error. + write(*,*) 'issue with patch area in EDinit',tota-area,tota + call endrun(msg=errMsg(sourcefile, __LINE__)) + endif ! big error + end if ! too much patch area + + ! For carbon balance checks, we need to initialize the + ! total carbon stock + do el=1,num_elements + call SiteMassStock(sites(s),el,sites(s)%mass_balance(el)%old_stock, & + biomass_stock,litter_stock,seed_stock) + end do + + call set_patchno(sites(s)) + + enddo !s + end if ! zero all the patch fire variables for the first timestep - do s = 1, nsites - currentPatch => sites(s)%youngest_patch - do while(associated(currentPatch)) - - currentPatch%litter_moisture(:) = 0._r8 - currentPatch%fuel_eff_moist = 0._r8 - currentPatch%livegrass = 0._r8 - currentPatch%sum_fuel = 0._r8 - currentPatch%fuel_bulkd = 0._r8 - currentPatch%fuel_sav = 0._r8 - currentPatch%fuel_mef = 0._r8 - currentPatch%ros_front = 0._r8 - currentPatch%effect_wspeed = 0._r8 - currentPatch%tau_l = 0._r8 - currentPatch%fuel_frac(:) = 0._r8 - currentPatch%tfc_ros = 0._r8 - currentPatch%fi = 0._r8 - currentPatch%fire = 0 - currentPatch%fd = 0._r8 - currentPatch%ros_back = 0._r8 - currentPatch%scorch_ht(:) = 0._r8 - currentPatch%frac_burnt = 0._r8 - currentPatch%burnt_frac_litter(:) = 0._r8 - - currentPatch => currentPatch%older - enddo - enddo - - ! This sets the rhizosphere shells based on the plant initialization - ! The initialization of the plant-relevant hydraulics variables - ! were set from a call inside of the init_cohorts()->create_cohort() subroutine - if (hlm_use_planthydro.eq.itrue) then - do s = 1, nsites - sitep => sites(s) - call updateSizeDepRhizHydProps(sitep, bc_in(s)) - end do - end if - - return + do s = 1, nsites + currentPatch => sites(s)%youngest_patch + do while(associated(currentPatch)) + + currentPatch%litter_moisture(:) = 0._r8 + currentPatch%fuel_eff_moist = 0._r8 + currentPatch%livegrass = 0._r8 + currentPatch%sum_fuel = 0._r8 + currentPatch%fuel_bulkd = 0._r8 + currentPatch%fuel_sav = 0._r8 + currentPatch%fuel_mef = 0._r8 + currentPatch%ros_front = 0._r8 + currentPatch%effect_wspeed = 0._r8 + currentPatch%tau_l = 0._r8 + currentPatch%fuel_frac(:) = 0._r8 + currentPatch%tfc_ros = 0._r8 + currentPatch%fi = 0._r8 + currentPatch%fire = 0 + currentPatch%fd = 0._r8 + currentPatch%ros_back = 0._r8 + currentPatch%scorch_ht(:) = 0._r8 + currentPatch%frac_burnt = 0._r8 + currentPatch%burnt_frac_litter(:) = 0._r8 + + currentPatch => currentPatch%older + enddo + enddo + + ! This sets the rhizosphere shells based on the plant initialization + ! The initialization of the plant-relevant hydraulics variables + ! were set from a call inside of the init_cohorts()->create_cohort() subroutine + if (hlm_use_planthydro.eq.itrue) then + do s = 1, nsites + sitep => sites(s) + call updateSizeDepRhizHydProps(sitep, bc_in(s)) + end do + end if + + return end subroutine init_patches ! ============================================================================ @@ -489,7 +667,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) ! ! !USES: ! - ! !ARGUMENTS + ! !ARGUMENTS type(ed_site_type), intent(inout), pointer :: site_in type(ed_patch_type), intent(inout), pointer :: patch_in type(bc_in_type), intent(in) :: bc_in @@ -502,6 +680,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) integer :: iage ! index for leaf age loop integer :: el ! index for element loop integer :: element_id ! element index consistent with defs in PRTGeneric + integer :: use_pft_local(numpft) ! determine whether this PFT is used for this patch and site. real(r8) :: c_agw ! biomass above ground (non-leaf) [kgC] real(r8) :: c_bgw ! biomass below ground (non-fineroot) [kgC] real(r8) :: c_leaf ! biomass in leaves [kgC] @@ -519,171 +698,223 @@ subroutine init_cohorts( site_in, patch_in, bc_in) real(r8) :: stem_drop_fraction integer, parameter :: rstatus = 0 - + integer init !---------------------------------------------------------------------- patch_in%tallest => null() patch_in%shortest => null() - + + ! Manage interactions of fixed biogeog (site level filter) and + ! nocomp (patch level filter) + ! Need to cover all potential biogeog x nocomp combinations + ! 1. biogeog = false. nocomp = false: all PFTs on (DEFAULT) + ! 2. biogeog = true. nocomp = false: site level filter + ! 3. biogeog = false. nocomp = true : patch level filter + ! 4. biogeog = true. nocomp = true : patch and site level filter + ! in principle this could be a patch level variable. do pft = 1,numpft - if(site_in%use_this_pft(pft).eq.itrue)then - if(EDPftvarcon_inst%initd(pft)>1.0E-7) then - - allocate(temp_cohort) ! temporary cohort - - temp_cohort%pft = pft - temp_cohort%n = EDPftvarcon_inst%initd(pft) * patch_in%area - temp_cohort%hite = EDPftvarcon_inst%hgt_min(pft) - - - ! Calculate the plant diameter from height - call h2d_allom(temp_cohort%hite,pft,temp_cohort%dbh) - - temp_cohort%canopy_trim = 1.0_r8 - - ! Calculate total above-ground biomass from allometry - call bagw_allom(temp_cohort%dbh,pft,c_agw) - - ! Calculate coarse root biomass from allometry - call bbgw_allom(temp_cohort%dbh,pft,c_bgw) - - ! Calculate the leaf biomass from allometry - ! (calculates a maximum first, then applies canopy trim) - call bleaf(temp_cohort%dbh,pft,temp_cohort%canopy_trim,c_leaf) - - ! Calculate fine root biomass from allometry - ! (calculates a maximum and then trimming value) - call bfineroot(temp_cohort%dbh,pft,temp_cohort%canopy_trim,c_fnrt) - - ! Calculate sapwood biomass - call bsap_allom(temp_cohort%dbh,pft,temp_cohort%canopy_trim,a_sapw,c_sapw) - - call bdead_allom( c_agw, c_bgw, c_sapw, pft, c_struct ) - - call bstore_allom(temp_cohort%dbh, pft, temp_cohort%canopy_trim, c_store) - - temp_cohort%laimemory = 0._r8 - temp_cohort%sapwmemory = 0._r8 - temp_cohort%structmemory = 0._r8 - cstatus = leaves_on - - stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) - - if( prt_params%season_decid(pft) == itrue .and. & - any(site_in%cstatus == [phen_cstat_nevercold,phen_cstat_iscold])) then - - temp_cohort%laimemory = c_leaf - temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction - c_leaf = 0._r8 - c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw - c_struct = (1.0_r8-stem_drop_fraction) * c_struct - cstatus = leaves_off + ! Turn every PFT ON, unless we are in a special case. + use_pft_local(pft) = itrue ! Case 1 + if(hlm_use_fixed_biogeog.eq.itrue)then !filter geographically + use_pft_local(pft) = site_in%use_this_pft(pft) ! Case 2 + if(hlm_use_nocomp.eq.itrue.and.pft.ne.patch_in%nocomp_pft_label)then + ! Having set the biogeog filter as on or off, turn off all PFTs + ! whose identiy does not correspond to this patch label. + use_pft_local(pft) = ifalse ! Case 3 + endif + else + if(hlm_use_nocomp.eq.itrue.and.pft.ne.patch_in%nocomp_pft_label)then + ! This case has all PFTs on their own patch everywhere. + use_pft_local(pft) = ifalse ! Case 4 + endif endif - if ( prt_params%stress_decid(pft) == itrue .and. & - any(site_in%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then - temp_cohort%laimemory = c_leaf - temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction - c_leaf = 0._r8 - c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw - c_struct = (1.0_r8-stem_drop_fraction) * c_struct - cstatus = leaves_off - endif + end do + do pft = 1,numpft + if(use_pft_local(pft).eq.itrue)then + if(EDPftvarcon_inst%initd(pft)>nearzero) then + + allocate(temp_cohort) ! temporary cohort + + temp_cohort%pft = pft + temp_cohort%n = EDPftvarcon_inst%initd(pft) * patch_in%area + if(hlm_use_nocomp.eq.itrue)then !in nocomp mode we only have one PFT per patch + ! as opposed to numpft's. So we should up the initial density + ! to compensate (otherwise runs are very hard to compare) + ! this multiplies it by the number of PFTs there would have been in + ! the single shared patch in competition mode. + ! n.b. that this is the same as currentcohort%n = %initd(pft) &AREA + temp_cohort%n = temp_cohort%n * sum(site_in%use_this_pft) + endif + + temp_cohort%canopy_trim = 1.0_r8 + + ! h,dbh,leafc,n from SP values or from small initial size. + + if(hlm_use_sp.eq.itrue)then + init = itrue + ! At this point, we do not know the bc_in values of tlai tsai and htop, + ! so this is initializing to an arbitrary value for the very first timestep. + ! Not sure if there's a way around this or not. + call assign_cohort_SP_properties(temp_cohort, 0.5_r8,0.2_r8, 0.1_r8,patch_in%area,init,c_leaf) + + else + temp_cohort%hite = EDPftvarcon_inst%hgt_min(pft) + + ! Calculate the plant diameter from height + call h2d_allom(temp_cohort%hite,pft,temp_cohort%dbh) + + ! Calculate the leaf biomass from allometry + ! (calculates a maximum first, then applies canopy trim) + call bleaf(temp_cohort%dbh,pft,temp_cohort%canopy_trim,c_leaf) + end if ! sp mode + + ! Calculate total above-ground biomass from allometry + call bagw_allom(temp_cohort%dbh,pft,c_agw) + + ! Calculate coarse root biomass from allometry + call bbgw_allom(temp_cohort%dbh,pft,c_bgw) + + ! Calculate fine root biomass from allometry + ! (calculates a maximum and then trimming value) + call bfineroot(temp_cohort%dbh,pft,temp_cohort%canopy_trim,c_fnrt) + + ! Calculate sapwood biomass + call bsap_allom(temp_cohort%dbh,pft,temp_cohort%canopy_trim,a_sapw,c_sapw) + + call bdead_allom( c_agw, c_bgw, c_sapw, pft, c_struct ) + + call bstore_allom(temp_cohort%dbh, pft, temp_cohort%canopy_trim, c_store) + + temp_cohort%laimemory = 0._r8 + temp_cohort%sapwmemory = 0._r8 + temp_cohort%structmemory = 0._r8 + cstatus = leaves_on + + stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) + + if(hlm_use_sp.eq.ifalse)then ! do not override SP vales with phenology + + if( prt_params%season_decid(pft) == itrue .and. & + any(site_in%cstatus == [phen_cstat_nevercold,phen_cstat_iscold])) then + temp_cohort%laimemory = c_leaf + temp_cohort%sapwmemory = c_sapw * stem_drop_fraction + temp_cohort%structmemory = c_struct * stem_drop_fraction + c_leaf = 0._r8 + c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw + c_struct = (1.0_r8-stem_drop_fraction) * c_struct + cstatus = leaves_off + endif + + if ( prt_params%stress_decid(pft) == itrue .and. & + any(site_in%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then + temp_cohort%laimemory = c_leaf + temp_cohort%sapwmemory = c_sapw * stem_drop_fraction + temp_cohort%structmemory = c_struct * stem_drop_fraction + c_leaf = 0._r8 + c_sapw = (1.0_r8-stem_drop_fraction) * c_sapw + c_struct = (1.0_r8-stem_drop_fraction) * c_struct + cstatus = leaves_off + endif + + end if ! SP mode + + if ( debug ) write(fates_log(),*) 'EDInitMod.F90 call create_cohort ' + + temp_cohort%coage = 0.0_r8 + + + ! -------------------------------------------------------------------------------- + ! Initialize the mass of every element in every organ of the organ + ! -------------------------------------------------------------------------------- + + prt_obj => null() + call InitPRTObject(prt_obj) + + do el = 1,num_elements + + element_id = element_list(el) + + ! If this is carbon12, then the initialization is straight forward + ! otherwise, we use stoichiometric ratios + select case(element_id) + case(carbon12_element) + + m_struct = c_struct + m_leaf = c_leaf + m_fnrt = c_fnrt + m_sapw = c_sapw + m_store = c_store + m_repro = 0._r8 + + case(nitrogen_element) + + m_struct = c_struct*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(struct_organ)) + m_leaf = c_leaf*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(leaf_organ)) + m_fnrt = c_fnrt*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(fnrt_organ)) + m_sapw = c_sapw*prt_params%nitr_stoich_p2(pft,prt_params%organ_param_id(sapw_organ)) + m_repro = 0._r8 + m_store = StorageNutrientTarget(pft,element_id,m_leaf,m_fnrt,m_sapw,m_struct) + + case(phosphorus_element) + + m_struct = c_struct*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(struct_organ)) + m_leaf = c_leaf*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(leaf_organ)) + m_fnrt = c_fnrt*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(fnrt_organ)) + m_sapw = c_sapw*prt_params%phos_stoich_p2(pft,prt_params%organ_param_id(sapw_organ)) + m_repro = 0._r8 + m_store = StorageNutrientTarget(pft,element_id,m_leaf,m_fnrt,m_sapw,m_struct) + + end select + + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp,prt_cnp_flex_allom_hyp ) + + ! Put all of the leaf mass into the first bin + call SetState(prt_obj,leaf_organ, element_id,m_leaf,1) + do iage = 2,nleafage + call SetState(prt_obj,leaf_organ, element_id,0._r8,iage) + end do + + call SetState(prt_obj,fnrt_organ, element_id, m_fnrt) + call SetState(prt_obj,sapw_organ, element_id, m_sapw) + call SetState(prt_obj,store_organ, element_id, m_store) + call SetState(prt_obj,struct_organ, element_id, m_struct) + call SetState(prt_obj,repro_organ, element_id, m_repro) + + case default + write(fates_log(),*) 'Unspecified PARTEH module during create_cohort' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select - if ( debug ) write(fates_log(),*) 'EDInitMod.F90 call create_cohort ' - - temp_cohort%coage = 0.0_r8 - - - ! -------------------------------------------------------------------------------- - ! Initialize the mass of every element in every organ of the organ - ! -------------------------------------------------------------------------------- - - prt_obj => null() - call InitPRTObject(prt_obj) - - do el = 1,num_elements - - element_id = element_list(el) - - ! If this is carbon12, then the initialization is straight forward - ! otherwise, we use stoichiometric ratios - select case(element_id) - case(carbon12_element) - - m_struct = c_struct - m_leaf = c_leaf - m_fnrt = c_fnrt - m_sapw = c_sapw - m_store = c_store - m_repro = 0._r8 - - case(nitrogen_element) - - m_struct = c_struct*prt_params%nitr_stoich_p2(pft,struct_organ) - m_leaf = c_leaf*prt_params%nitr_stoich_p2(pft,leaf_organ) - m_fnrt = c_fnrt*prt_params%nitr_stoich_p2(pft,fnrt_organ) - m_sapw = c_sapw*prt_params%nitr_stoich_p2(pft,sapw_organ) - m_store = c_store*prt_params%nitr_stoich_p2(pft,store_organ) - m_repro = 0._r8 - - case(phosphorus_element) - - m_struct = c_struct*prt_params%phos_stoich_p2(pft,struct_organ) - m_leaf = c_leaf*prt_params%phos_stoich_p2(pft,leaf_organ) - m_fnrt = c_fnrt*prt_params%phos_stoich_p2(pft,fnrt_organ) - m_sapw = c_sapw*prt_params%phos_stoich_p2(pft,sapw_organ) - m_store = c_store*prt_params%phos_stoich_p2(pft,store_organ) - m_repro = 0._r8 - end select - - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp,prt_cnp_flex_allom_hyp ) - - ! Put all of the leaf mass into the first bin - call SetState(prt_obj,leaf_organ, element_id,m_leaf,1) - do iage = 2,nleafage - call SetState(prt_obj,leaf_organ, element_id,0._r8,iage) end do - - call SetState(prt_obj,fnrt_organ, element_id, m_fnrt) - call SetState(prt_obj,sapw_organ, element_id, m_sapw) - call SetState(prt_obj,store_organ, element_id, m_store) - call SetState(prt_obj,struct_organ, element_id, m_struct) - call SetState(prt_obj,repro_organ, element_id, m_repro) - - case default - write(fates_log(),*) 'Unspecified PARTEH module during create_cohort' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - end do - call prt_obj%CheckInitialConditions() + call prt_obj%CheckInitialConditions() - call create_cohort(site_in, patch_in, pft, temp_cohort%n, temp_cohort%hite, & - temp_cohort%coage, temp_cohort%dbh, prt_obj, temp_cohort%laimemory, & - temp_cohort%sapwmemory, temp_cohort%structmemory, cstatus, rstatus, & - temp_cohort%canopy_trim, 1, site_in%spread, bc_in) + call create_cohort(site_in, patch_in, pft, temp_cohort%n, temp_cohort%hite, & + temp_cohort%coage, temp_cohort%dbh, prt_obj, temp_cohort%laimemory, & + temp_cohort%sapwmemory, temp_cohort%structmemory, cstatus, rstatus, & + temp_cohort%canopy_trim, temp_cohort%c_area,1, site_in%spread, bc_in) - deallocate(temp_cohort) ! get rid of temporary cohort - endif - endif !use_this_pft + deallocate(temp_cohort) ! get rid of temporary cohort + + endif + endif !use_this_pft enddo !numpft - ! Zero the mass flux pools of the new cohorts -! temp_cohort => patch_in%tallest -! do while(associated(temp_cohort)) -! call temp_cohort%prt%ZeroRates() -! temp_cohort => temp_cohort%shorter -! end do + ! (Keeping as an example) + ! Pass patch level temperature to the new cohorts (this is a nominal 15C right now) + !temp_cohort => patch_in%tallest + !do while(associated(temp_cohort)) + !call temp_cohort%tveg_lpa%UpdateRmean(patch_in%tveg_lpa%GetMean()) + !temp_cohort => temp_cohort%shorter + !end do call fuse_cohorts(site_in, patch_in,bc_in) call sort_cohorts(patch_in) + end subroutine init_cohorts ! =============================================================================================== diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 3d70760090..152911b59c 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -1,29 +1,31 @@ - module EDMainMod ! =========================================================================== - ! Main ED module. + ! Main ED module. ! ============================================================================ use shr_kind_mod , only : r8 => shr_kind_r8 - + use FatesGlobals , only : fates_log + use FatesInterfaceTypesMod , only : hlm_freq_day use FatesInterfaceTypesMod , only : hlm_day_of_year use FatesInterfaceTypesMod , only : hlm_days_per_year use FatesInterfaceTypesMod , only : hlm_current_year use FatesInterfaceTypesMod , only : hlm_current_month - use FatesInterfaceTypesMod , only : hlm_current_day + use FatesInterfaceTypesMod , only : hlm_current_day use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_parteh_mode use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking use FatesInterfaceTypesMod , only : hlm_reference_date use FatesInterfaceTypesMod , only : hlm_use_ed_prescribed_phys - use FatesInterfaceTypesMod , only : hlm_use_ed_st3 + use FatesInterfaceTypesMod , only : hlm_use_ed_st3 + use FatesInterfaceTypesMod , only : hlm_use_sp use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : bc_out_type use FatesInterfaceTypesMod , only : hlm_masterproc use FatesInterfaceTypesMod , only : numpft + use FatesInterfaceTypesMod , only : hlm_use_nocomp use PRTGenericMod , only : prt_carbon_allom_hyp use PRTGenericMod , only : prt_cnp_flex_allom_hyp use PRTGenericMod , only : nitrogen_element @@ -38,6 +40,7 @@ module EDMainMod use EDPatchDynamicsMod , only : spawn_patches use EDPatchDynamicsMod , only : terminate_patches use EDPhysiologyMod , only : phenology + use EDPhysiologyMod , only : satellite_phenology use EDPhysiologyMod , only : recruitment use EDPhysiologyMod , only : trim_canopy use EDPhysiologyMod , only : SeedIn @@ -48,7 +51,8 @@ module EDMainMod use FatesSoilBGCFluxMod , only : FluxIntoLitterPools use EDCohortDynamicsMod , only : UpdateCohortBioPhysRates use FatesSoilBGCFluxMod , only : PrepNutrientAquisitionBCs - use SFMainMod , only : fire_model + use FatesSoilBGCFluxMod , only : PrepCH4BCs + use SFMainMod , only : fire_model use FatesSizeAgeTypeIndicesMod, only : get_age_class_index use FatesSizeAgeTypeIndicesMod, only : coagetype_class_index use FatesLitterMod , only : litter_type @@ -66,14 +70,15 @@ module EDMainMod use FatesConstantsMod , only : itrue,ifalse use FatesConstantsMod , only : primaryforest, secondaryforest use FatesConstantsMod , only : nearzero + use FatesConstantsMod , only : m2_per_ha + use FatesConstantsMod , only : sec_per_day use FatesPlantHydraulicsMod , only : do_growthrecruiteffects use FatesPlantHydraulicsMod , only : UpdateSizeDepPlantHydProps use FatesPlantHydraulicsMod , only : UpdateSizeDepPlantHydStates use FatesPlantHydraulicsMod , only : InitPlantHydStates - use FatesPlantHydraulicsMod , only : UpdateSizeDepRhizHydProps + use FatesPlantHydraulicsMod , only : UpdateSizeDepRhizHydProps use FatesPlantHydraulicsMod , only : AccumulateMortalityWaterStorage use FatesAllometryMod , only : h_allom,tree_sai,tree_lai - use FatesPlantHydraulicsMod , only : UpdateSizeDepRhizHydStates use EDLoggingMortalityMod , only : IsItLoggingTime use EDPatchDynamicsMod , only : get_frac_site_primary use FatesGlobals , only : endrun => fates_endrun @@ -88,11 +93,12 @@ module EDMainMod use PRTGenericMod, only : store_organ use PRTGenericMod, only : repro_organ use PRTGenericMod, only : struct_organ - use PRTLossFluxesMod, only : PRTMaintTurnover use PRTLossFluxesMod, only : PRTReproRelease - use EDPftvarcon, only : EDPftvarcon_inst + use FatesHistoryInterfaceMod, only : ih_nh4uptake_si, ih_no3uptake_si, ih_puptake_si + use FatesHistoryInterfaceMod, only : ih_nh4uptake_scpf, ih_no3uptake_scpf, ih_puptake_scpf + use FatesHistoryInterfaceMod, only : fates_hist ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -107,18 +113,18 @@ module EDMainMod public :: ed_update_site ! ! !PRIVATE MEMBER FUNCTIONS: - + private :: ed_integrate_state_variables private :: TotalBalanceCheck private :: bypass_dynamics - + logical :: debug = .false. integer, parameter :: final_check_id = -1 - + character(len=*), parameter, private :: sourcefile = & __FILE__ - + ! ! 10/30/09: Created by Rosie Fisher !----------------------------------------------------------------------- @@ -129,7 +135,7 @@ module EDMainMod subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) ! ! !DESCRIPTION: - ! Core of ed model, calling all subsequent vegetation dynamics routines + ! Core of ed model, calling all subsequent vegetation dynamics routines ! ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite @@ -138,29 +144,34 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) ! ! !LOCAL VARIABLES: type(ed_patch_type), pointer :: currentPatch - integer :: el ! Loop counter for elements + integer :: el ! Loop counter for elements + integer :: do_patch_dynamics ! for some modes, we turn off patch dynamics !----------------------------------------------------------------------- if ( hlm_masterproc==itrue ) write(fates_log(),'(A,I4,A,I2.2,A,I2.2)') 'FATES Dynamics: ',& hlm_current_year,'-',hlm_current_month,'-',hlm_current_day - ! Consider moving this towards the end, because some of these + ! Consider moving this towards the end, because some of these ! are being integrated over the short time-step - + do el = 1,num_elements call currentSite%mass_balance(el)%ZeroMassBalFlux() call currentSite%flux_diags(el)%ZeroFluxDiags() end do + ! zero dynamics (upfreq_in = 1) output history variables + call fates_hist%zero_site_hvars(currentSite,upfreq_in=1) + + ! Call a routine that simply identifies if logging should occur ! This is limited to a global event until more structured event handling is enabled call IsItLoggingTime(hlm_masterproc,currentSite) !************************************************************************** - ! Fire, growth, biogeochemistry. + ! Fire, growth, biogeochemistry. !************************************************************************** - + !FIX(SPM,032414) take this out. On startup these values are all zero and on restart it !zeros out values read in the restart file @@ -170,28 +181,31 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) ! Zero fluxes in and out of litter pools call ZeroLitterFluxes(currentSite) - ! Zero mass balance + ! Zero mass balance call TotalBalanceCheck(currentSite, 0) ! We do not allow phenology while in ST3 mode either, it is hypothetically ! possible to allow this, but we have not plugged in the litter fluxes ! of flushing or turning over leaves for non-dynamics runs - if (hlm_use_ed_st3.eq.ifalse) then - call phenology(currentSite, bc_in ) + if (hlm_use_ed_st3.eq.ifalse)then + if(hlm_use_sp.eq.ifalse) then + call phenology(currentSite, bc_in ) + else + call satellite_phenology(currentSite, bc_in ) + end if ! SP phenology end if - if (hlm_use_ed_st3.eq.ifalse) then ! Bypass if ST3 - call fire_model(currentSite, bc_in) + if (hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.ifalse) then ! Bypass if ST3 + call fire_model(currentSite, bc_in) ! Calculate disturbance and mortality based on previous timestep vegetation. ! disturbance_rates calls logging mortality and other mortalities, Yi Xu call disturbance_rates(currentSite, bc_in) - end if - if (hlm_use_ed_st3.eq.ifalse) then ! Integrate state variables from annual rates to daily timestep - call ed_integrate_state_variables(currentSite, bc_in, bc_out ) + call ed_integrate_state_variables(currentSite, bc_in, bc_out ) + else ! ed_intergrate_state_variables is where the new cohort flag ! is set. This flag designates wether a cohort has @@ -200,82 +214,83 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) ! Make sure cohorts are marked as non-recruits call bypass_dynamics(currentSite) - + end if !****************************************************************************** - ! Reproduction, Recruitment and Cohort Dynamics : controls cohort organization + ! Reproduction, Recruitment and Cohort Dynamics : controls cohort organization !****************************************************************************** - if(hlm_use_ed_st3.eq.ifalse) then + if(hlm_use_ed_st3.eq.ifalse.and.hlm_use_sp.eq.ifalse) then currentPatch => currentSite%oldest_patch - do while (associated(currentPatch)) - + do while (associated(currentPatch)) + ! adds small cohort of each PFT call recruitment(currentSite, currentPatch, bc_in) - + currentPatch => currentPatch%younger enddo - end if - - - call TotalBalanceCheck(currentSite,1) - if( hlm_use_ed_st3.eq.ifalse ) then + call TotalBalanceCheck(currentSite,1) + currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) - + ! puts cohorts in right order - call sort_cohorts(currentPatch) + call sort_cohorts(currentPatch) ! kills cohorts that are too few - call terminate_cohorts(currentSite, currentPatch, 1, 10 ) + call terminate_cohorts(currentSite, currentPatch, 1, 10, bc_in ) ! fuses similar cohorts call fuse_cohorts(currentSite,currentPatch, bc_in ) - + ! kills cohorts for various other reasons - call terminate_cohorts(currentSite, currentPatch, 2, 10 ) - - + call terminate_cohorts(currentSite, currentPatch, 2, 10, bc_in ) + + currentPatch => currentPatch%younger enddo end if - + call TotalBalanceCheck(currentSite,2) !********************************************************************************* ! Patch dynamics sub-routines: fusion, new patch creation (spwaning), termination. !********************************************************************************* + ! turn off patch dynamics if SP or ST3 modes in use + do_patch_dynamics = itrue + if(hlm_use_ed_st3.eq.itrue .or. & + hlm_use_sp.eq.itrue)then + do_patch_dynamics = ifalse + end if + ! make new patches from disturbed land - if ( hlm_use_ed_st3.eq.ifalse ) then + if (do_patch_dynamics.eq.itrue ) then call spawn_patches(currentSite, bc_in) - end if - - call TotalBalanceCheck(currentSite,3) - ! fuse on the spawned patches. - if ( hlm_use_ed_st3.eq.ifalse ) then - call fuse_patches(currentSite, bc_in ) - + call TotalBalanceCheck(currentSite,3) + + ! fuse on the spawned patches. + call fuse_patches(currentSite, bc_in ) + ! If using BC FATES hydraulics, update the rhizosphere geometry ! based on the new cohort-patch structure - ! 'rhizosphere geometry' (column-level root biomass + rootfr --> root length + ! 'rhizosphere geometry' (column-level root biomass + rootfr --> root length ! density --> node radii and volumes) if( (hlm_use_planthydro.eq.itrue) .and. do_growthrecruiteffects) then call UpdateSizeDepRhizHydProps(currentSite, bc_in) - call UpdateSizeDepRhizHydStates(currentSite, bc_in) + !! call UpdateSizeDepRhizHydStates(currentSite, bc_in) ! keeping if re-implemented (RGK 12-2021) end if - end if - call TotalBalanceCheck(currentSite,4) + ! SP has changes in leaf carbon but we don't expect them to be in balance. + call TotalBalanceCheck(currentSite,4) - ! kill patches that are too small - if ( hlm_use_ed_st3.eq.ifalse ) then - call terminate_patches(currentSite) + ! kill patches that are too small + call terminate_patches(currentSite) end if - + call TotalBalanceCheck(currentSite,5) end subroutine ed_ecosystem_dynamics @@ -283,7 +298,7 @@ end subroutine ed_ecosystem_dynamics !-------------------------------------------------------------------------------! subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! - + ! !DESCRIPTION: ! FIX(SPM,032414) refactor so everything goes through interface ! @@ -291,7 +306,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) use FatesInterfaceTypesMod, only : hlm_use_cohort_age_tracking use FatesConstantsMod, only : itrue ! !ARGUMENTS: - + type(ed_site_type) , intent(inout) :: currentSite type(bc_in_type) , intent(in) :: bc_in type(bc_out_type) , intent(inout) :: bc_out @@ -302,8 +317,9 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type) , pointer :: currentCohort - integer :: c ! Counter for litter size class + integer :: c ! Counter for litter size class integer :: ft ! Counter for PFT + integer :: io_si ! global site index for history writing integer :: iscpf ! index for the size-class x pft multiplexed bins integer :: el ! Counter for element type (c,n,p,etc) real(r8) :: cohort_biomass_store ! remembers the biomass in the cohort for balance checking @@ -346,7 +362,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! Update Canopy Biomass Pools currentCohort => currentPatch%shortest - do while(associated(currentCohort)) + do while(associated(currentCohort)) ft = currentCohort%pft @@ -359,20 +375,20 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! ----------------------------------------------------------------------------- ! ----------------------------------------------------------------------------- ! Identify the net carbon gain for this dynamics interval - ! Set the available carbon pool, identify allocation portions, and + ! Set the available carbon pool, identify allocation portions, and ! decrement the available carbon pool to zero. ! ----------------------------------------------------------------------------- - - + + if (hlm_use_ed_prescribed_phys .eq. itrue) then if (currentCohort%canopy_layer .eq. 1) then currentCohort%npp_acc = EDPftvarcon_inst%prescribed_npp_canopy(ft) & - * currentCohort%c_area / currentCohort%n / hlm_days_per_year + * currentCohort%c_area / currentCohort%n / hlm_days_per_year else currentCohort%npp_acc = EDPftvarcon_inst%prescribed_npp_understory(ft) & * currentCohort%c_area / currentCohort%n / hlm_days_per_year endif - + ! We don't explicitly define a respiration rate for prescribe phys ! but we do need to pass mass balance. So we say it is zero respiration currentCohort%gpp_acc = currentCohort%npp_acc @@ -388,15 +404,15 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! ! convert from kgC/indiv/day into kgC/indiv/year ! _acc_hold is remembered until the next dynamics step (used for I/O) - ! _acc will be reset soon and will be accumulated on the next leaf + ! _acc will be reset soon and will be accumulated on the next leaf ! photosynthesis step ! ----------------------------------------------------------------------------- - + currentCohort%npp_acc_hold = currentCohort%npp_acc * real(hlm_days_per_year,r8) currentCohort%gpp_acc_hold = currentCohort%gpp_acc * real(hlm_days_per_year,r8) currentCohort%resp_acc_hold = currentCohort%resp_acc * real(hlm_days_per_year,r8) - + ! Conduct Maintenance Turnover (parteh) if(debug) call currentCohort%prt%CheckMassConservation(ft,3) if(any(currentSite%dstatus == [phen_dstat_moiston,phen_dstat_timeon])) then @@ -418,10 +434,10 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! ----------------------------------------------------------------------------- ! Growth and Allocation (PARTEH) ! ----------------------------------------------------------------------------- - + call currentCohort%prt%DailyPRT() - + ! Update the mass balance tracking for the daily nutrient uptake flux ! Then zero out the daily uptakes, they have been used ! ----------------------------------------------------------------------------- @@ -429,61 +445,80 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) if(hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp ) then ! Mass balance for N uptake - currentSite%mass_balance(element_pos(nitrogen_element))%net_root_uptake = & + currentSite%mass_balance(element_pos(nitrogen_element))%net_root_uptake = & currentSite%mass_balance(element_pos(nitrogen_element))%net_root_uptake + & - (currentCohort%daily_n_uptake-currentCohort%daily_n_efflux)*currentCohort%n - + (currentCohort%daily_nh4_uptake+currentCohort%daily_no3_uptake- & + currentCohort%daily_n_efflux)*currentCohort%n + ! Mass balance for P uptake - currentSite%mass_balance(element_pos(phosphorus_element))%net_root_uptake = & - currentSite%mass_balance(element_pos(phosphorus_element))%net_root_uptake + & + currentSite%mass_balance(element_pos(phosphorus_element))%net_root_uptake = & + currentSite%mass_balance(element_pos(phosphorus_element))%net_root_uptake + & (currentCohort%daily_p_uptake-currentCohort%daily_p_efflux)*currentCohort%n - + ! mass balance for C efflux (if any) - currentSite%mass_balance(element_pos(carbon12_element))%net_root_uptake = & - currentSite%mass_balance(element_pos(carbon12_element))%net_root_uptake - & + currentSite%mass_balance(element_pos(carbon12_element))%net_root_uptake = & + currentSite%mass_balance(element_pos(carbon12_element))%net_root_uptake - & currentCohort%daily_c_efflux*currentCohort%n - + ! size class index iscpf = currentCohort%size_by_pft_class - + ! Diagnostics for uptake, by size and pft, [kgX/ha/day] - currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_uptake_scpf(iscpf) = & - currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_uptake_scpf(iscpf) + & - currentCohort%daily_n_uptake*currentCohort%n - - currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_uptake_scpf(iscpf) = & - currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_uptake_scpf(iscpf) + & - currentCohort%daily_p_uptake*currentCohort%n - + + io_si = currentSite%h_gid + + fates_hist%hvars(ih_nh4uptake_scpf)%r82d(io_si,iscpf) = & + fates_hist%hvars(ih_nh4uptake_scpf)%r82d(io_si,iscpf) + & + currentCohort%daily_nh4_uptake*currentCohort%n / & + m2_per_ha / sec_per_day + + fates_hist%hvars(ih_no3uptake_scpf)%r82d(io_si,iscpf) = & + fates_hist%hvars(ih_no3uptake_scpf)%r82d(io_si,iscpf) + & + currentCohort%daily_no3_uptake*currentCohort%n / & + m2_per_ha / sec_per_day + + fates_hist%hvars(ih_puptake_scpf)%r82d(io_si,iscpf) = & + fates_hist%hvars(ih_puptake_scpf)%r82d(io_si,iscpf) + & + currentCohort%daily_p_uptake*currentCohort%n / & + m2_per_ha / sec_per_day + + fates_hist%hvars(ih_nh4uptake_si)%r81d(io_si) = & + fates_hist%hvars(ih_nh4uptake_si)%r81d(io_si) + & + currentCohort%daily_nh4_uptake*currentCohort%n / & + m2_per_ha / sec_per_day + + fates_hist%hvars(ih_no3uptake_si)%r81d(io_si) = & + fates_hist%hvars(ih_no3uptake_si)%r81d(io_si) + & + currentCohort%daily_no3_uptake*currentCohort%n / & + m2_per_ha / sec_per_day + + fates_hist%hvars(ih_puptake_si)%r81d(io_si) = & + fates_hist%hvars(ih_puptake_si)%r81d(io_si) + & + currentCohort%daily_p_uptake*currentCohort%n / & + m2_per_ha / sec_per_day + + ! Diagnostics on efflux, size and pft [kgX/ha/day] - currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_efflux_scpf(iscpf) = & - currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_efflux_scpf(iscpf) + & + currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_efflux_scpf(iscpf) = & + currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_efflux_scpf(iscpf) + & currentCohort%daily_n_efflux*currentCohort%n - - currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_efflux_scpf(iscpf) = & - currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_efflux_scpf(iscpf) + & + + currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_efflux_scpf(iscpf) = & + currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_efflux_scpf(iscpf) + & currentCohort%daily_p_efflux*currentCohort%n - - currentSite%flux_diags(element_pos(carbon12_element))%nutrient_efflux_scpf(iscpf) = & - currentSite%flux_diags(element_pos(carbon12_element))%nutrient_efflux_scpf(iscpf) + & + + currentSite%flux_diags(element_pos(carbon12_element))%nutrient_efflux_scpf(iscpf) = & + currentSite%flux_diags(element_pos(carbon12_element))%nutrient_efflux_scpf(iscpf) + & currentCohort%daily_c_efflux*currentCohort%n ! Diagnostics on plant nutrient need - currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_needgrow_scpf(iscpf) = & - currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_needgrow_scpf(iscpf) + & - currentCohort%daily_n_need1*currentCohort%n + currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_need_scpf(iscpf) = & + currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_need_scpf(iscpf) + & + currentCohort%daily_n_need*currentCohort%n - currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_needmax_scpf(iscpf) = & - currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_needmax_scpf(iscpf) + & - currentCohort%daily_n_need2*currentCohort%n - - currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_needgrow_scpf(iscpf) = & - currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_needgrow_scpf(iscpf) + & - currentCohort%daily_p_need1*currentCohort%n - - currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_needmax_scpf(iscpf) = & - currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_needmax_scpf(iscpf) + & - currentCohort%daily_p_need2*currentCohort%n + currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_need_scpf(iscpf) = & + currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_need_scpf(iscpf) + & + currentCohort%daily_p_need*currentCohort%n end if @@ -492,7 +527,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) currentCohort%gpp_acc * currentCohort%n site_cmass%aresp_acc = site_cmass%aresp_acc + & currentCohort%resp_acc * currentCohort%n - + call currentCohort%prt%CheckMassConservation(ft,5) ! Update the leaf biophysical rates based on proportion of leaf @@ -503,10 +538,10 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! This cohort has grown, it is no longer "new" currentCohort%isnew = .false. - + ! Update the plant height (if it has grown) call h_allom(currentCohort%dbh,ft,currentCohort%hite) - + currentCohort%dhdt = (currentCohort%hite-hite_old)/hlm_freq_day currentCohort%ddbhdt = (currentCohort%dbh-dbh_old)/hlm_freq_day @@ -516,9 +551,9 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) currentCohort%npp_acc = 0.0_r8 currentCohort%gpp_acc = 0.0_r8 currentCohort%resp_acc = 0.0_r8 - - ! BOC...update tree 'hydraulic geometry' - ! (size --> heights of elements --> hydraulic path lengths --> + + ! BOC...update tree 'hydraulic geometry' + ! (size --> heights of elements --> hydraulic path lengths --> ! maximum node-to-node conductances) if( (hlm_use_planthydro.eq.itrue) .and. do_growthrecruiteffects) then call UpdateSizeDepPlantHydProps(currentSite,currentCohort, bc_in) @@ -544,10 +579,10 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) currentPatch => currentPatch%older end do - - + + ! When plants die, the water goes with them. This effects - ! the water balance. + ! the water balance. if( hlm_use_planthydro == itrue ) then currentPatch => currentSite%youngest_patch @@ -561,22 +596,22 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) currentPatch => currentPatch%older end do end if - + ! With growth and mortality rates now calculated we can determine the seed rain ! fluxes. However, because this is potentially a cross-patch mixing model ! we will calculate this as a group call SeedIn(currentSite,bc_in) - + ! Calculate all other litter fluxes ! ----------------------------------------------------------------------------------- currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) - + call PreDisturbanceLitterFluxes( currentSite, currentPatch, bc_in) - + call PreDisturbanceIntegrateLitter(currentPatch ) @@ -591,15 +626,15 @@ subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) call FluxIntoLitterPools(currentsite, bc_in, bc_out) - ! Update cohort number. - ! This needs to happen after the CWD_input and seed_input calculations as they - ! assume the pre-mortality currentCohort%n. - + ! Update cohort number. + ! This needs to happen after the CWD_input and seed_input calculations as they + ! assume the pre-mortality currentCohort%n. + currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) currentCohort => currentPatch%shortest - do while(associated(currentCohort)) - currentCohort%n = max(0._r8,currentCohort%n + currentCohort%dndt * hlm_freq_day ) + do while(associated(currentCohort)) + currentCohort%n = max(0._r8,currentCohort%n + currentCohort%dndt * hlm_freq_day ) currentCohort => currentCohort%taller enddo currentPatch => currentPatch%older @@ -616,8 +651,8 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) ! Calls routines to consolidate the ED growth process. ! Canopy Structure to assign canopy layers to cohorts ! Canopy Spread to figure out the size of tree crowns - ! Trim_canopy to figure out the target leaf biomass. - ! Extra recruitment to fill empty patches. + ! Trim_canopy to figure out the target leaf biomass. + ! Extra recruitment to fill empty patches. ! ! !USES: use EDCanopyStructureMod , only : canopy_spread, canopy_structure @@ -628,62 +663,70 @@ subroutine ed_update_site( currentSite, bc_in, bc_out ) type(bc_out_type) , intent(inout) :: bc_out ! ! !LOCAL VARIABLES: - type (ed_patch_type) , pointer :: currentPatch + type (ed_patch_type) , pointer :: currentPatch !----------------------------------------------------------------------- - - call canopy_spread(currentSite) + if(hlm_use_sp.eq.ifalse)then + call canopy_spread(currentSite) + end if call TotalBalanceCheck(currentSite,6) - call canopy_structure(currentSite, bc_in) + if(hlm_use_sp.eq.ifalse)then + call canopy_structure(currentSite, bc_in) + endif call TotalBalanceCheck(currentSite,final_check_id) + currentSite%area_by_age(:) = 0._r8 + currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) - - ! Is termination really needed here? + + ! Is termination really needed here? ! Canopy_structure just called it several times! (rgk) - call terminate_cohorts(currentSite, currentPatch, 1, 11) - call terminate_cohorts(currentSite, currentPatch, 2, 11) + call terminate_cohorts(currentSite, currentPatch, 1, 11, bc_in) + call terminate_cohorts(currentSite, currentPatch, 2, 11, bc_in) ! This cohort count is used in the photosynthesis loop call count_cohorts(currentPatch) + ! Update the total area of by patch age class array + currentSite%area_by_age(currentPatch%age_class) = & + currentSite%area_by_age(currentPatch%age_class) + currentPatch%area + + currentPatch => currentPatch%younger - currentPatch => currentPatch%younger enddo - ! Aggregate FATES litter output fluxes and - ! package them into boundary conditions - ! Note: The FATES state variables that generate these - ! boundary conditions are read in on the restart, - ! and, they are zero'd only at the start of ecosystem - ! dynamics - - ! Based on current status of the + ! The HLMs need to know about nutrient demand, and/or + ! root mass and affinities call PrepNutrientAquisitionBCs(currentSite,bc_in,bc_out) + ! The HLM methane module needs information about + ! rooting mass, distributions, respiration rates and NPP + call PrepCH4BCs(currentSite,bc_in,bc_out) + ! FIX(RF,032414). This needs to be monthly, not annual ! If this is the second to last day of the year, then perform trimming if( hlm_day_of_year == hlm_days_per_year-1) then - write(fates_log(),*) 'calling trim canopy' - call trim_canopy(currentSite) + if(hlm_use_sp.eq.ifalse)then + call trim_canopy(currentSite) + endif endif end subroutine ed_update_site !-------------------------------------------------------------------------------! - + subroutine TotalBalanceCheck (currentSite, call_index ) ! ! !DESCRIPTION: - ! This routine looks at the mass flux in and out of the FATES and compares it to + ! This routine looks at the mass flux in and out of the FATES and compares it to ! the change in total stocks (states). - ! Fluxes in are NPP. Fluxes out are decay of CWD and litter into SOM pools. + ! Fluxes in are NPP. Fluxes out are decay of CWD and litter into SOM pools. ! ! !ARGUMENTS: type(ed_site_type) , intent(inout) :: currentSite @@ -696,7 +739,7 @@ subroutine TotalBalanceCheck (currentSite, call_index ) real(r8) :: seed_stock ! total seed mass in Kg/site real(r8) :: total_stock ! total ED carbon in Kg/site real(r8) :: change_in_stock ! Change since last time we set ed_allsites_inst%old_stock in this routine. KgC/site - real(r8) :: error ! How much carbon did we gain or lose (should be zero!) + real(r8) :: error ! How much carbon did we gain or lose (should be zero!) real(r8) :: error_frac ! Error as a fraction of total biomass real(r8) :: net_flux ! Difference between recorded fluxes in and out. KgC/site real(r8) :: flux_in ! mass flux into fates control volume @@ -710,11 +753,11 @@ subroutine TotalBalanceCheck (currentSite, call_index ) integer :: el ! loop counter for element types - ! nb. There is no time associated with these variables - ! because this routine can be called between any two - ! arbitrary points in code, even if no time has passed. - ! Also, the carbon pools are per site/gridcell, so that - ! we can account for the changing areas of patches. + ! nb. There is no time associated with these variables + ! because this routine can be called between any two + ! arbitrary points in code, even if no time has passed. + ! Also, the carbon pools are per site/gridcell, so that + ! we can account for the changing areas of patches. type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type) , pointer :: currentCohort @@ -724,34 +767,36 @@ subroutine TotalBalanceCheck (currentSite, call_index ) ! upon fail (lots of text) !----------------------------------------------------------------------- + if(hlm_use_sp.eq.ifalse)then + change_in_stock = 0.0_r8 - + ! Loop through the number of elements in the system do el = 1, num_elements - + site_mass => currentSite%mass_balance(el) call SiteMassStock(currentSite,el,total_stock,biomass_stock,litter_stock,seed_stock) change_in_stock = total_stock - site_mass%old_stock - flux_in = site_mass%seed_in + & + flux_in = site_mass%seed_in + & site_mass%net_root_uptake + & site_mass%gpp_acc + & site_mass%flux_generic_in + & site_mass%patch_resize_err flux_out = site_mass%wood_product + & - site_mass%burn_flux_to_atm + & - site_mass%seed_out + & + site_mass%burn_flux_to_atm + & + site_mass%seed_out + & site_mass%flux_generic_out + & - site_mass%frag_out + & - site_mass%aresp_acc + site_mass%frag_out + & + site_mass%aresp_acc net_flux = flux_in - flux_out - error = abs(net_flux - change_in_stock) + error = abs(net_flux - change_in_stock) if(change_in_stock>0.0)then @@ -778,19 +823,19 @@ subroutine TotalBalanceCheck (currentSite, call_index ) write(fates_log(),*) 'burn_flux_to_atm: ',site_mass%burn_flux_to_atm write(fates_log(),*) 'seed_out: ',site_mass%seed_out write(fates_log(),*) 'flux_generic_out: ',site_mass%flux_generic_out - write(fates_log(),*) 'frag_out: ',site_mass%frag_out + write(fates_log(),*) 'frag_out: ',site_mass%frag_out write(fates_log(),*) 'aresp_acc: ',site_mass%aresp_acc write(fates_log(),*) 'error=net_flux-dstock:', error write(fates_log(),*) 'biomass', biomass_stock write(fates_log(),*) 'litter',litter_stock write(fates_log(),*) 'seeds',seed_stock write(fates_log(),*) 'total stock', total_stock - write(fates_log(),*) 'previous total',site_mass%old_stock + write(fates_log(),*) 'previous total',site_mass%old_stock write(fates_log(),*) 'lat lon',currentSite%lat,currentSite%lon - + ! If this is the first day of simulation, carbon balance reports but does not end the run ! if(( hlm_current_year*10000 + hlm_current_month*100 + hlm_current_day).ne.hlm_reference_date) then - + currentPatch => currentSite%oldest_patch do while(associated(currentPatch)) litt => currentPatch%litter(el) @@ -821,7 +866,8 @@ subroutine TotalBalanceCheck (currentSite, call_index ) write(fates_log(),*) 'resp m def: ',currentCohort%resp_m_def*currentCohort%n if(element_list(el).eq.nitrogen_element) then - write(fates_log(),*) 'N uptake: ',currentCohort%daily_n_uptake*currentCohort%n + write(fates_log(),*) 'NH4 uptake: ',currentCohort%daily_nh4_uptake*currentCohort%n + write(fates_log(),*) 'NO3 uptake: ',currentCohort%daily_no3_uptake*currentCohort%n write(fates_log(),*) 'N efflux: ',currentCohort%daily_n_efflux*currentCohort%n elseif(element_list(el).eq.phosphorus_element) then write(fates_log(),*) 'P uptake: ',currentCohort%daily_p_uptake*currentCohort%n @@ -830,7 +876,7 @@ subroutine TotalBalanceCheck (currentSite, call_index ) write(fates_log(),*) 'C efflux: ',currentCohort%daily_c_efflux*currentCohort%n end if - + currentCohort => currentCohort%shorter enddo !end cohort loop end if @@ -839,7 +885,7 @@ subroutine TotalBalanceCheck (currentSite, call_index ) write(fates_log(),*) 'aborting on date:',hlm_current_year,hlm_current_month,hlm_current_day call endrun(msg=errMsg(sourcefile, __LINE__)) !end if - + endif ! This is the last check of the sequence, where we update our total @@ -850,11 +896,11 @@ subroutine TotalBalanceCheck (currentSite, call_index ) end if end do - + end if ! not SP mode end subroutine TotalBalanceCheck - + ! ===================================================================================== - + subroutine bypass_dynamics(currentSite) ! ---------------------------------------------------------------------------------- @@ -866,15 +912,15 @@ subroutine bypass_dynamics(currentSite) ! Arguments type(ed_site_type) , intent(inout), target :: currentSite - + ! Locals type(ed_patch_type), pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort - + currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) currentCohort => currentPatch%shortest - do while(associated(currentCohort)) + do while(associated(currentCohort)) currentCohort%isnew=.false. @@ -910,11 +956,7 @@ subroutine bypass_dynamics(currentSite) enddo currentPatch => currentPatch%older enddo - + end subroutine bypass_dynamics end module EDMainMod - - - - diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index bda572db88..8c5e2500e0 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -20,9 +20,27 @@ module EDParamsMod ! ! this is what the user can use for the actual values ! + + real(r8),protected, public :: vai_top_bin_width ! width in VAI units of uppermost leaf+stem + ! layer scattering element in each canopy layer [m2/m2] + ! (NOT YET IMPLEMENTED) + real(r8),protected, public :: vai_width_increase_factor ! factor by which each leaf+stem scattering element + ! increases in VAI width (1 = uniform spacing) + ! (NOT YET IMPLEMENTED) + real(r8),protected, public :: photo_temp_acclim_timescale ! Length of the window for the exponential moving average (ema) + ! of vegetation temperature used in photosynthesis + ! temperature acclimation (NOT YET IMPLEMENTED) + + integer,protected, public :: maintresp_model ! switch for choosing between leaf maintenance + ! respiration model. 1=Ryan (1991) (NOT YET IMPLEMENTED) + integer,protected, public :: photo_tempsens_model ! switch for choosing the model that defines the temperature + ! sensitivity of photosynthetic parameters (vcmax, jmax). + ! 1=non-acclimating (NOT YET IMPLEMENTED) real(r8),protected, public :: fates_mortality_disturbance_fraction ! the fraction of canopy mortality that results in disturbance real(r8),protected, public :: ED_val_comp_excln + real(r8),protected, public :: ED_val_vai_top_bin_width + real(r8),protected, public :: ED_val_vai_width_increase_factor real(r8),protected, public :: ED_val_init_litter real(r8),protected, public :: ED_val_nignitions real(r8),protected, public :: ED_val_understorey_death @@ -50,18 +68,49 @@ module EDParamsMod real(r8), protected, public :: cg_strikes ! fraction of cloud to ground lightning strikes (0-1) character(len=param_string_length),parameter :: fates_name_cg_strikes="fates_fire_cg_strikes" + + ! empirical curvature parameters for ac, aj photosynthesis co-limitation, c3 and c4 plants respectively + real(r8),protected,public :: theta_cj_c3 + real(r8),protected,public :: theta_cj_c4 real(r8),protected,public :: q10_mr ! Q10 for respiration rate (for soil fragmenation and plant respiration) (unitless) real(r8),protected,public :: q10_froz ! Q10 for frozen-soil respiration rates (for soil fragmentation) (unitless) - ! two special parameters whose size is defined in the parameter file + ! Unassociated pft dimensioned free parameter that developers can use for testing arbitrary new hypotheses + ! (THIS PARAMETER IS UNUSED, FEEL FREE TO USE IT FOR WHATEVER PURPOSE YOU LIKE. WE CAN + ! HELP MIGRATE YOUR USAGE OF THE PARMETER TO A PERMANENT HOME LATER) + real(r8),protected,public :: dev_arbitrary + character(len=param_string_length),parameter,public :: name_dev_arbitrary = "fates_dev_arbitrary" + + ! parameters whose size is defined in the parameter file real(r8),protected,allocatable,public :: ED_val_history_sizeclass_bin_edges(:) real(r8),protected,allocatable,public :: ED_val_history_ageclass_bin_edges(:) real(r8),protected,allocatable,public :: ED_val_history_height_bin_edges(:) real(r8),protected,allocatable,public :: ED_val_history_coageclass_bin_edges(:) + + ! Switch that defines the current pressure-volume and pressure-conductivity model + ! to be used at each node (compartment/organ) + ! 1 = Christofferson et al. 2016 (TFS), 2 = Van Genuchten 1980 + integer, protected,allocatable,public :: hydr_htftype_node(:) + + ! Switch that defines which hydraulic solver to use + ! 1 = Taylor solution that solves plant fluxes with 1 layer + ! sequentially placing solution on top of previous layer solves + ! 2 = Newton-Raphson solution that solves all fluxes in a plant and + ! the soil simultaneously, 2D: soil x (root + shell) + ! 3 = Picard solution that solves all fluxes in a plant and + ! the soil simultaneously, 2D: soil x (root + shell) + + integer, parameter, public :: hydr_solver_type = 1 ! 1 = hydr_solver_1DTaylor + character(len=param_string_length),parameter,public :: ED_name_photo_temp_acclim_timescale = "fates_photo_temp_acclim_timescale" + character(len=param_string_length),parameter,public :: name_photo_tempsens_model = "fates_photo_tempsens_model" + character(len=param_string_length),parameter,public :: name_maintresp_model = "fates_maintresp_model" + character(len=param_string_length),parameter,public :: ED_name_hydr_htftype_node = "fates_hydr_htftype_node" character(len=param_string_length),parameter,public :: ED_name_mort_disturb_frac = "fates_mort_disturb_frac" character(len=param_string_length),parameter,public :: ED_name_comp_excln = "fates_comp_excln" + character(len=param_string_length),parameter,public :: ED_name_vai_top_bin_width = "fates_vai_top_bin_width" + character(len=param_string_length),parameter,public :: ED_name_vai_width_increase_factor = "fates_vai_width_increase_factor" character(len=param_string_length),parameter,public :: ED_name_init_litter = "fates_init_litter" character(len=param_string_length),parameter,public :: ED_name_nignitions = "fates_fire_nignitions" character(len=param_string_length),parameter,public :: ED_name_understorey_death = "fates_mort_understorey_death" @@ -83,13 +132,12 @@ module EDParamsMod character(len=param_string_length),parameter,public :: ED_name_canopy_closure_thresh= "fates_canopy_closure_thresh" character(len=param_string_length),parameter,public :: ED_name_stomatal_model= "fates_leaf_stomatal_model" - ! Resistance to active crown fire - - + character(len=param_string_length),parameter,public :: name_theta_cj_c3 = "fates_theta_cj_c3" + character(len=param_string_length),parameter,public :: name_theta_cj_c4 = "fates_theta_cj_c4" + character(len=param_string_length),parameter :: fates_name_q10_mr="fates_q10_mr" character(len=param_string_length),parameter :: fates_name_q10_froz="fates_q10_froz" - ! non-scalar parameter names character(len=param_string_length),parameter,public :: ED_name_history_sizeclass_bin_edges= "fates_history_sizeclass_bin_edges" character(len=param_string_length),parameter,public :: ED_name_history_ageclass_bin_edges= "fates_history_ageclass_bin_edges" @@ -177,8 +225,15 @@ subroutine FatesParamsInit() implicit none + vai_top_bin_width = nan + vai_width_increase_factor = nan + photo_temp_acclim_timescale = nan + photo_tempsens_model = -9 + maintresp_model = -9 fates_mortality_disturbance_fraction = nan ED_val_comp_excln = nan + ED_val_vai_top_bin_width = nan + ED_val_vai_width_increase_factor = nan ED_val_init_litter = nan ED_val_nignitions = nan ED_val_understorey_death = nan @@ -216,7 +271,9 @@ subroutine FatesParamsInit() eca_plant_escalar = nan q10_mr = nan q10_froz = nan - + theta_cj_c3 = nan + theta_cj_c4 = nan + dev_arbitrary = nan end subroutine FatesParamsInit !----------------------------------------------------------------------- @@ -227,7 +284,7 @@ subroutine FatesRegisterParams(fates_params) use FatesParametersInterface, only : fates_parameters_type, dimension_name_scalar, dimension_shape_1d use FatesParametersInterface, only : dimension_name_history_size_bins, dimension_name_history_age_bins - use FatesParametersInterface, only : dimension_name_history_height_bins + use FatesParametersInterface, only : dimension_name_history_height_bins, dimension_name_hydr_organs use FatesParametersInterface, only : dimension_name_history_coage_bins use FatesParametersInterface, only : dimension_shape_scalar @@ -241,16 +298,37 @@ subroutine FatesRegisterParams(fates_params) character(len=param_string_length), parameter :: dim_names_ageclass(1) = (/dimension_name_history_age_bins/) character(len=param_string_length), parameter :: dim_names_height(1) = (/dimension_name_history_height_bins/) character(len=param_string_length), parameter :: dim_names_coageclass(1) = (/dimension_name_history_coage_bins/) - + character(len=param_string_length), parameter :: dim_names_hydro_organs(1) = (/dimension_name_hydr_organs/) call FatesParamsInit() + call fates_params%RegisterParameter(name=ED_name_photo_temp_acclim_timescale, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=name_photo_tempsens_model,dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=name_maintresp_model,dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=name_theta_cj_c3, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=name_theta_cj_c4, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_mort_disturb_frac, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) call fates_params%RegisterParameter(name=ED_name_comp_excln, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_vai_top_bin_width, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + + call fates_params%RegisterParameter(name=ED_name_vai_width_increase_factor, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=ED_name_init_litter, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) @@ -365,7 +443,14 @@ subroutine FatesRegisterParams(fates_params) call fates_params%RegisterParameter(name=fates_name_q10_froz, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=name_dev_arbitrary, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + ! non-scalar parameters + + call fates_params%RegisterParameter(name=ED_name_hydr_htftype_node, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names_hydro_organs) + call fates_params%RegisterParameter(name=ED_name_history_sizeclass_bin_edges, dimension_shape=dimension_shape_1d, & dimension_names=dim_names_sizeclass) @@ -398,6 +483,18 @@ subroutine FatesReceiveParams(fates_params) class(fates_parameters_type), intent(inout) :: fates_params real(r8) :: tmpreal ! local real variable for changing type on read + real(r8), allocatable :: hydr_htftype_real(:) + + call fates_params%RetreiveParameter(name=ED_name_photo_temp_acclim_timescale, & + data=photo_temp_acclim_timescale) + + call fates_params%RetreiveParameter(name=name_photo_tempsens_model, & + data=tmpreal) + photo_tempsens_model = nint(tmpreal) + + call fates_params%RetreiveParameter(name=name_maintresp_model, & + data=tmpreal) + maintresp_model = nint(tmpreal) call fates_params%RetreiveParameter(name=ED_name_mort_disturb_frac, & data=fates_mortality_disturbance_fraction) @@ -405,6 +502,12 @@ subroutine FatesReceiveParams(fates_params) call fates_params%RetreiveParameter(name=ED_name_comp_excln, & data=ED_val_comp_excln) + call fates_params%RetreiveParameter(name=ED_name_vai_top_bin_width, & + data=ED_val_vai_top_bin_width) + + call fates_params%RetreiveParameter(name=ED_name_vai_width_increase_factor, & + data=ED_val_vai_width_increase_factor) + call fates_params%RetreiveParameter(name=ED_name_init_litter, & data=ED_val_init_litter) @@ -514,11 +617,20 @@ subroutine FatesReceiveParams(fates_params) call fates_params%RetreiveParameter(name=eca_name_plant_escalar, & data=eca_plant_escalar) + call fates_params%RetreiveParameter(name=name_theta_cj_c3, & + data=theta_cj_c3) + + call fates_params%RetreiveParameter(name=name_theta_cj_c4, & + data=theta_cj_c4) + call fates_params%RetreiveParameter(name=fates_name_q10_mr, & data=q10_mr) call fates_params%RetreiveParameter(name=fates_name_q10_froz, & - data=q10_froz) + data=q10_froz) + + call fates_params%RetreiveParameter(name=name_dev_arbitrary, & + data=dev_arbitrary) call fates_params%RetreiveParameter(name=fates_name_active_crown_fire, & data=tmpreal) @@ -540,6 +652,11 @@ subroutine FatesReceiveParams(fates_params) call fates_params%RetreiveParameterAllocate(name=ED_name_history_coageclass_bin_edges, & data=ED_val_history_coageclass_bin_edges) + call fates_params%RetreiveParameterAllocate(name=ED_name_hydr_htftype_node, & + data=hydr_htftype_real) + allocate(hydr_htftype_node(size(hydr_htftype_real))) + hydr_htftype_node(:) = nint(hydr_htftype_real(:)) + deallocate(hydr_htftype_real) end subroutine FatesReceiveParams @@ -550,13 +667,20 @@ subroutine FatesReportParams(is_master) logical,intent(in) :: is_master character(len=32),parameter :: fmt0 = '(a,(F12.4))' + character(len=32),parameter :: fmti = '(a,(I4))' logical, parameter :: debug_report = .false. if(debug_report .and. is_master) then write(fates_log(),*) '----------- FATES Scalar Parameters -----------------' + write(fates_log(),fmt0) 'vai_top_bin_width = ',vai_top_bin_width + write(fates_log(),fmt0) 'vai_width_increase_factor = ',vai_width_increase_factor + write(fates_log(),fmt0) 'photo_temp_acclim_timescale = ',photo_temp_acclim_timescale + write(fates_log(),fmti) 'hydr_htftype_node = ',hydr_htftype_node write(fates_log(),fmt0) 'fates_mortality_disturbance_fraction = ',fates_mortality_disturbance_fraction write(fates_log(),fmt0) 'ED_val_comp_excln = ',ED_val_comp_excln + write(fates_log(),fmt0) 'ED_val_vai_top_bin_width = ',ED_val_vai_top_bin_width + write(fates_log(),fmt0) 'ED_val_vai_width_increase_factor = ',ED_val_vai_width_increase_factor write(fates_log(),fmt0) 'ED_val_init_litter = ',ED_val_init_litter write(fates_log(),fmt0) 'ED_val_nignitions = ',ED_val_nignitions write(fates_log(),fmt0) 'ED_val_understorey_death = ',ED_val_understorey_death diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 61f095a758..a149132a8d 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -15,7 +15,6 @@ module EDPftvarcon use FatesGlobals, only : fates_log use FatesGlobals, only : endrun => fates_endrun use FatesLitterMod, only : ilabile,icellulose,ilignin - use PRTGenericMod, only : num_organ_types use PRTGenericMod, only : leaf_organ, fnrt_organ, store_organ use PRTGenericMod, only : sapw_organ, struct_organ, repro_organ use PRTGenericMod, only : prt_cnp_flex_allom_hyp,prt_carbon_allom_hyp @@ -26,11 +25,11 @@ module EDPftvarcon use FatesConstantsMod , only : prescribed_n_uptake use FatesConstantsMod , only : coupled_p_uptake use FatesConstantsMod , only : coupled_n_uptake - + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg - + ! ! !PUBLIC TYPES: implicit none @@ -40,25 +39,23 @@ module EDPftvarcon integer, parameter, public :: lower_bound_pft = 1 integer, parameter, public :: lower_bound_general = 1 - !ED specific variables. + !ED specific variables. type, public :: EDPftvarcon_type real(r8), allocatable :: freezetol(:) ! minimum temperature tolerance real(r8), allocatable :: hgt_min(:) ! sapling height m real(r8), allocatable :: dleaf(:) ! leaf characteristic dimension length (m) - real(r8), allocatable :: z0mr(:) ! ratio of roughness length of vegetation to height (-) - real(r8), allocatable :: displar(:) ! ratio of displacement height to canopy top height (-) - real(r8), allocatable :: crown(:) ! fraction of the height of the plant - ! that is occupied by crown. For fire model. + real(r8), allocatable :: z0mr(:) ! ratio of roughness length of vegetation to height (-) + real(r8), allocatable :: displar(:) ! ratio of displacement height to canopy top height real(r8), allocatable :: bark_scaler(:) ! scaler from dbh to bark thickness. For fire model. - real(r8), allocatable :: crown_kill(:) ! scaler on fire death. For fire model. - real(r8), allocatable :: initd(:) ! initial seedling density + real(r8), allocatable :: crown_kill(:) ! scaler on fire death. For fire model. + real(r8), allocatable :: initd(:) ! initial seedling density real(r8), allocatable :: seed_suppl(:) ! seeds that come from outside the gridbox. real(r8), allocatable :: bb_slope(:) ! ball berry slope parameter real(r8), allocatable :: medlyn_slope(:) ! Medlyn slope parameter KPa^0.5 real(r8), allocatable :: stomatal_intercept(:) ! intercept of stomatal conductance model - + real(r8), allocatable :: lf_flab(:) ! Leaf litter labile fraction [-] real(r8), allocatable :: lf_fcel(:) ! Leaf litter cellulose fraction [-] @@ -67,27 +64,27 @@ module EDPftvarcon real(r8), allocatable :: fr_fcel(:) ! Fine-root litter cellulose fraction [-] real(r8), allocatable :: fr_flig(:) ! Fine-root litter lignatn fraction [-] real(r8), allocatable :: xl(:) ! Leaf-stem orientation index - real(r8), allocatable :: clumping_index(:) ! factor describing how much self-occlusion - ! of leaf scattering elements + real(r8), allocatable :: clumping_index(:) ! factor describing how much self-occlusion + ! of leaf scattering elements ! decreases light interception - real(r8), allocatable :: c3psn(:) ! index defining the photosynthetic + real(r8), allocatable :: c3psn(:) ! index defining the photosynthetic ! pathway C4 = 0, C3 = 1 - - real(r8), allocatable :: smpso(:) ! Soil water potential at full stomatal opening + + real(r8), allocatable :: smpso(:) ! Soil water potential at full stomatal opening ! (non-HYDRO mode only) [mm] - real(r8), allocatable :: smpsc(:) ! Soil water potential at full stomatal closure + real(r8), allocatable :: smpsc(:) ! Soil water potential at full stomatal closure ! (non-HYDRO mode only) [mm] - real(r8), allocatable :: maintresp_reduction_curvature(:) ! curvature of MR reduction as f(carbon storage), + real(r8), allocatable :: maintresp_reduction_curvature(:) ! curvature of MR reduction as f(carbon storage), ! 1=linear, 0=very curved - real(r8), allocatable :: maintresp_reduction_intercept(:) ! intercept of MR reduction as f(carbon storage), + real(r8), allocatable :: maintresp_reduction_intercept(:) ! intercept of MR reduction as f(carbon storage), ! 0=no throttling, 1=max throttling real(r8), allocatable :: bmort(:) real(r8), allocatable :: mort_ip_size_senescence(:) ! inflection point of dbh dependent senescence real(r8), allocatable :: mort_r_size_senescence(:) ! rate of change in mortality with dbh - real(r8), allocatable :: mort_ip_age_senescence(:) ! inflection point of age dependent senescence - real(r8), allocatable :: mort_r_age_senescence(:) ! rate of change in mortality with age + real(r8), allocatable :: mort_ip_age_senescence(:) ! inflection point of age dependent senescence + real(r8), allocatable :: mort_r_age_senescence(:) ! rate of change in mortality with age real(r8), allocatable :: mort_scalar_coldstress(:) real(r8), allocatable :: mort_scalar_cstarvation(:) real(r8), allocatable :: mort_scalar_hydrfailure(:) @@ -100,9 +97,9 @@ module EDPftvarcon real(r8), allocatable :: vcmaxse(:) real(r8), allocatable :: jmaxse(:) real(r8), allocatable :: germination_rate(:) ! Fraction of seed mass germinating per year (yr-1) - real(r8), allocatable :: seed_decay_rate(:) ! Fraction of seed mass (both germinated and + real(r8), allocatable :: seed_decay_rate(:) ! Fraction of seed mass (both germinated and ! ungerminated), decaying per year (yr-1) - + real(r8), allocatable :: trim_limit(:) ! Limit to reductions in leaf area w stress (m2/m2) real(r8), allocatable :: trim_inc(:) ! Incremental change in trimming function (m2/m2) real(r8), allocatable :: rhol(:, :) @@ -117,21 +114,21 @@ module EDPftvarcon ! Equation 16 Thonicke et al 2010 ! Non-PARTEH Allometry Parameters - ! -------------------------------------------------------------------------------------------- + ! -------------------------------------------------------------------------------------------- real(r8), allocatable :: allom_frbstor_repro(:) ! fraction of bstrore for reproduction after mortality ! Prescribed Physiology Mode Parameters - real(r8), allocatable :: prescribed_npp_canopy(:) ! this is only for the + real(r8), allocatable :: prescribed_npp_canopy(:) ! this is only for the ! prescribed_physiology_mode - real(r8), allocatable :: prescribed_npp_understory(:) ! this is only for the + real(r8), allocatable :: prescribed_npp_understory(:) ! this is only for the ! prescribed physiology mode - real(r8), allocatable :: prescribed_mortality_canopy(:) ! this is only for the + real(r8), allocatable :: prescribed_mortality_canopy(:) ! this is only for the ! prescribed_physiology_mode - real(r8), allocatable :: prescribed_mortality_understory(:) ! this is only for the + real(r8), allocatable :: prescribed_mortality_understory(:) ! this is only for the ! prescribed_physiology_mode - real(r8), allocatable :: prescribed_recruitment(:) ! this is only for the + real(r8), allocatable :: prescribed_recruitment(:) ! this is only for the ! prescribed_physiology_mode ! Nutrient Aquisition (ECA & RD) @@ -147,7 +144,7 @@ module EDPftvarcon ! Note*: units of [gC] is grams carbon of fine-root real(r8), allocatable :: eca_km_nh4(:) ! half-saturation constant for plant nh4 uptake [gN/m3] - real(r8), allocatable :: eca_vmax_nh4(:) ! maximum production rate for plant nh4 uptake [gN/gC/s] + real(r8), allocatable :: eca_vmax_nh4(:) ! maximum production rate for plant nh4 uptake [gN/gC/s] real(r8), allocatable :: eca_km_no3(:) ! half-saturation constant for plant no3 uptake [gN/m3] real(r8), allocatable :: eca_vmax_no3(:) ! maximum production rate for plant no3 uptake [gN/gC/s] real(r8), allocatable :: eca_km_p(:) ! half-saturation constant for plant p uptake [gP/m3] @@ -156,34 +153,39 @@ module EDPftvarcon real(r8), allocatable :: eca_vmax_ptase(:) ! maximum production rate for biochemical P prod [gP/gC/s] real(r8), allocatable :: eca_alpha_ptase(:) ! Fraction of min P generated from ptase activity ! that is immediately sent to the plant [/] - real(r8), allocatable :: eca_lambda_ptase(:) ! critical value for Ptase that incurs + real(r8), allocatable :: eca_lambda_ptase(:) ! critical value for Ptase that incurs ! biochemical production, fraction based how much ! more in need a plant is for P versus N [/] !real(r8), allocatable :: nfix1(:) ! nitrogen fixation parameter 1 !real(r8), allocatable :: nfix2(:) ! nitrogen fixation parameter 2 - + ! Turnover related things real(r8), allocatable :: phenflush_fraction(:) ! Maximum fraction of storage carbon used to flush leaves ! on bud-burst [kgC/kgC] - real(r8), allocatable :: phen_cold_size_threshold(:) ! stem/leaf drop occurs on DBH size of decidious non-woody - ! (coastal grass) plants larger than the threshold value - real(r8), allocatable :: phen_stem_drop_fraction(:) ! Fraction of stem dropped/senescened for decidious - ! non-woody (grass) plants + real(r8), allocatable :: phen_cold_size_threshold(:) ! stem/leaf drop occurs on DBH size of decidious non-woody + ! (coastal grass) plants larger than the threshold value + real(r8), allocatable :: phen_stem_drop_fraction(:) ! Fraction of stem dropped/senescened for decidious + ! non-woody (grass) plants ! Nutrient Aquisition parameters real(r8), allocatable :: prescribed_nuptake(:) ! If there is no soil BGC model active, - ! prescribe an uptake rate for nitrogen, this is the fraction of plant demand + ! prescribe an uptake rate for nitrogen, this is the fraction of plant demand real(r8), allocatable :: prescribed_puptake(:) ! If there is no soil BGC model active, ! prescribe an uptake rate for phosphorus ! This is the fraction of plant demand - + + + ! Unassociated pft dimensioned free parameter that + ! developers can use for testing arbitrary new hypothese + real(r8), allocatable :: dev_arbitrary_pft(:) + ! Parameters dimensioned by PFT and leaf age - real(r8), allocatable :: vcmax25top(:,:) ! maximum carboxylation rate of Rub. at 25C, - ! canopy top [umol CO2/m^2/s]. Dimensioned by + real(r8), allocatable :: vcmax25top(:,:) ! maximum carboxylation rate of Rub. at 25C, + ! canopy top [umol CO2/m^2/s]. Dimensioned by ! leaf age-class ! Plant Hydraulic Parameters ! --------------------------------------------------------------------------------------------- @@ -193,20 +195,36 @@ module EDPftvarcon real(r8), allocatable :: hydr_rs2(:) ! absorbing root radius (m) real(r8), allocatable :: hydr_srl(:) ! specific root length (m g-1) real(r8), allocatable :: hydr_rfrac_stem(:) ! fraction of total tree resistance from troot to canopy - real(r8), allocatable :: hydr_avuln_gs(:) ! shape parameter for stomatal control of water vapor exiting leaf + real(r8), allocatable :: hydr_avuln_gs(:) ! shape parameter for stomatal control of water vapor exiting leaf real(r8), allocatable :: hydr_p50_gs(:) ! water potential at 50% loss of stomatal conductance + real(r8), allocatable :: hydr_k_lwp(:) ! inner leaf humidity scaling coefficient ! PFT x Organ Dimension (organs are: 1=leaf, 2=stem, 3=transporting root, 4=absorbing root) - real(r8), allocatable :: hydr_avuln_node(:,:) ! xylem vulernability curve shape parameter + ! ---------------------------------------------------------------------------------- + + ! Van Genuchten PV PK curves + real(r8), allocatable :: hydr_vg_alpha_node(:,:) ! capilary length parameter in van Genuchten model + real(r8), allocatable :: hydr_vg_m_node(:,:) ! pore size distribution, m in van Genuchten 1980 model, range (0,1) + real(r8), allocatable :: hydr_vg_n_node(:,:) ! pore size distribution, n in van Genuchten 1980 model, range >2 + + ! TFS PV-PK curves + real(r8), allocatable :: hydr_avuln_node(:,:) ! xylem vulernability curve shape parameter real(r8), allocatable :: hydr_p50_node(:,:) ! xylem water potential at 50% conductivity loss (MPa) - real(r8), allocatable :: hydr_thetas_node(:,:) ! saturated water content (cm3/cm3) real(r8), allocatable :: hydr_epsil_node(:,:) ! bulk elastic modulus (MPa) real(r8), allocatable :: hydr_pitlp_node(:,:) ! turgor loss point (MPa) - real(r8), allocatable :: hydr_resid_node(:,:) ! residual fraction (fraction) real(r8), allocatable :: hydr_fcap_node(:,:) ! fraction of (1-resid_node) that is capillary in source real(r8), allocatable :: hydr_pinot_node(:,:) ! osmotic potential at full turgor real(r8), allocatable :: hydr_kmax_node(:,:) ! maximum xylem conductivity per unit conducting xylem area - + + ! Parameters for both VG and TFS PV-PK curves + real(r8), allocatable :: hydr_resid_node(:,:) ! residual fraction (fraction) + real(r8), allocatable :: hydr_thetas_node(:,:) ! saturated water content (cm3/cm3) + + ! Table that maps HLM pfts to FATES pfts for fixed biogeography mode + ! The values are area fractions (NOT IMPLEMENTED) + real(r8), allocatable :: hlm_pft_map(:,:) + + contains procedure, public :: Init => EDpftconInit procedure, public :: Register @@ -214,7 +232,7 @@ module EDPftvarcon procedure, private :: Register_PFT procedure, private :: Receive_PFT procedure, private :: Register_PFT_hydr_organs - procedure, private :: Receive_PFT_hydr_organs + procedure, private :: Receive_PFT_hydr_organs procedure, private :: Register_PFT_leafage procedure, private :: Receive_PFT_leafage procedure, private :: Register_PFT_numrad @@ -259,7 +277,7 @@ subroutine Register(this, fates_params) call this%Register_PFT_numrad(fates_params) call this%Register_PFT_hydr_organs(fates_params) call this%Register_PFT_leafage(fates_params) - + end subroutine Register !----------------------------------------------------------------------- @@ -284,6 +302,7 @@ subroutine Register_PFT(this, fates_params) use FatesParametersInterface, only : fates_parameters_type, param_string_length use FatesParametersInterface, only : dimension_name_pft, dimension_shape_1d + use FatesParametersInterface, only : dimension_name_hlm_pftno, dimension_shape_2d implicit none @@ -291,9 +310,11 @@ subroutine Register_PFT(this, fates_params) class(fates_parameters_type), intent(inout) :: fates_params character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_pft/) + character(len=param_string_length) :: pftmap_dim_names(2) integer, parameter :: dim_lower_bound(1) = (/ lower_bound_pft /) + character(len=param_string_length) :: name !X! name = '' @@ -308,10 +329,6 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_fire_crown_depth_frac' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_fire_bark_scaler' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -335,7 +352,7 @@ subroutine Register_PFT(this, fates_params) name = 'fates_leaf_stomatal_slope_medlyn' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_leaf_stomatal_intercept' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -388,7 +405,7 @@ subroutine Register_PFT(this, fates_params) name = 'fates_maintresp_reduction_curvature' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_maintresp_reduction_intercept' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -412,7 +429,7 @@ subroutine Register_PFT(this, fates_params) name = 'fates_prescribed_recruitment' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_fire_alpha_SH' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -436,15 +453,19 @@ subroutine Register_PFT(this, fates_params) name = 'fates_hydr_rfrac_stem' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_hydr_avuln_gs' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_hydr_p50_gs' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + + name = 'fates_hydr_k_lwp' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_mort_bmort' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -480,11 +501,11 @@ subroutine Register_PFT(this, fates_params) name = 'fates_mort_hf_sm_threshold' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_mort_hf_flc_threshold' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_leaf_vcmaxha' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -520,11 +541,11 @@ subroutine Register_PFT(this, fates_params) name = 'fates_trim_limit' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_trim_inc' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_leaf_diameter' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -540,11 +561,11 @@ subroutine Register_PFT(this, fates_params) name = 'fates_phenflush_fraction' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_phen_cold_size_threshold' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_phen_stem_drop_fraction' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -555,35 +576,35 @@ subroutine Register_PFT(this, fates_params) name = 'fates_eca_decompmicc' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_eca_km_nh4' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_eca_vmax_nh4' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_eca_km_no3' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_eca_vmax_no3' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_eca_km_p' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_eca_vmax_p' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_eca_km_ptase' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_eca_vmax_ptase' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -595,15 +616,27 @@ subroutine Register_PFT(this, fates_params) name = 'fates_eca_lambda_ptase' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_prescribed_nuptake' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'fates_prescribed_puptake' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_dev_arbitrary_pft' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + ! adding the hlm_pft_map variable with two dimensions - FATES PFTno and HLM PFTno + pftmap_dim_names(1) = dimension_name_pft + pftmap_dim_names(2) = dimension_name_hlm_pftno + + name = 'fates_hlm_pft_map' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=pftmap_dim_names, lower_bounds=dim_lower_bound) + end subroutine Register_PFT !----------------------------------------------------------------------- @@ -630,10 +663,6 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%hgt_min) - name = 'fates_fire_crown_depth_frac' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%crown) - name = 'fates_fire_bark_scaler' call fates_params%RetreiveParameterAllocate(name=name, & data=this%bark_scaler) @@ -654,14 +683,14 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%bb_slope) - name = 'fates_leaf_stomatal_slope_medlyn' + name = 'fates_leaf_stomatal_slope_medlyn' call fates_params%RetreiveParameterAllocate(name=name, & data=this%medlyn_slope) name = 'fates_leaf_stomatal_intercept' call fates_params%RetreiveParameterAllocate(name=name, & data=this%stomatal_intercept) - + name = 'fates_lf_flab' call fates_params%RetreiveParameterAllocate(name=name, & data=this%lf_flab) @@ -740,7 +769,7 @@ subroutine Receive_PFT(this, fates_params) name = 'fates_allom_frbstor_repro' call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_frbstor_repro) + data=this%allom_frbstor_repro) name = 'fates_hydr_p_taper' call fates_params%RetreiveParameterAllocate(name=name, & @@ -749,23 +778,31 @@ subroutine Receive_PFT(this, fates_params) name = 'fates_hydr_rs2' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_rs2) - + name = 'fates_hydr_srl' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_srl) - + name = 'fates_hydr_rfrac_stem' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_rfrac_stem) + name = 'fates_hydr_k_lwp' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_k_lwp) + name = 'fates_hydr_avuln_gs' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_avuln_gs) - + name = 'fates_hydr_p50_gs' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_p50_gs) + name = 'fates_hydr_k_lwp' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_k_lwp) + name = 'fates_mort_bmort' call fates_params%RetreiveParameterAllocate(name=name, & data=this%bmort) @@ -798,7 +835,7 @@ subroutine Receive_PFT(this, fates_params) name = 'fates_mort_r_age_senescence' call fates_params%RetreiveParameterAllocate(name=name, & data=this%mort_r_age_senescence) - + name = 'fates_mort_scalar_coldstress' call fates_params%RetreiveParameterAllocate(name=name, & data=this%mort_scalar_coldstress) @@ -807,15 +844,15 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%mort_scalar_cstarvation) - + name = 'fates_mort_hf_sm_threshold' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hf_sm_threshold) - + name = 'fates_mort_hf_flc_threshold' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hf_flc_threshold) - + name = 'fates_leaf_vcmaxha' call fates_params%RetreiveParameterAllocate(name=name, & data=this%vcmaxha) @@ -871,11 +908,11 @@ subroutine Receive_PFT(this, fates_params) name = 'fates_phenflush_fraction' call fates_params%RetreiveParameterAllocate(name=name, & data=this%phenflush_fraction) - + name = 'fates_phen_cold_size_threshold' call fates_params%RetreiveParameterAllocate(name=name, & data=this%phen_cold_size_threshold) - + name = 'fates_phen_stem_drop_fraction' call fates_params%RetreiveParameterAllocate(name=name, & data=this%phen_stem_drop_fraction) @@ -887,7 +924,11 @@ subroutine Receive_PFT(this, fates_params) name = 'fates_prescribed_puptake' call fates_params%RetreiveParameterAllocate(name=name, & data=this%prescribed_puptake) - + + name = 'fates_dev_arbitrary_pft' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%dev_arbitrary_pft) + name = 'fates_eca_decompmicc' call fates_params%RetreiveParameterAllocate(name=name, & data=this%decompmicc) @@ -895,11 +936,11 @@ subroutine Receive_PFT(this, fates_params) name = 'fates_eca_km_nh4' call fates_params%RetreiveParameterAllocate(name=name, & data=this%eca_km_nh4) - + name = 'fates_eca_vmax_nh4' call fates_params%RetreiveParameterAllocate(name=name, & data=this%eca_vmax_nh4) - + name = 'fates_eca_km_no3' call fates_params%RetreiveParameterAllocate(name=name, & data=this%eca_km_no3) @@ -932,6 +973,10 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%eca_lambda_ptase) + name = 'fates_hlm_pft_map' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hlm_pft_map) + end subroutine Receive_PFT !----------------------------------------------------------------------- @@ -988,7 +1033,7 @@ subroutine Register_PFT_numrad(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names) - + end subroutine Register_PFT_numrad @@ -1042,7 +1087,7 @@ subroutine Receive_PFT_numrad(this, fates_params) ! received rhol data ! allocate(this%rhol(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) - + name = 'fates_rholvis' call fates_params%RetreiveParameter(name=name, & data=dummy_data) @@ -1057,7 +1102,7 @@ subroutine Receive_PFT_numrad(this, fates_params) ! received rhos data ! allocate(this%rhos(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) - + name = 'fates_rhosvis' call fates_params%RetreiveParameter(name=name, & data=dummy_data) @@ -1072,7 +1117,7 @@ subroutine Receive_PFT_numrad(this, fates_params) ! received taul data ! allocate(this%taul(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) - + name = 'fates_taulvis' call fates_params%RetreiveParameter(name=name, & data=dummy_data) @@ -1087,7 +1132,7 @@ subroutine Receive_PFT_numrad(this, fates_params) ! received taus data ! allocate(this%taus(lower_bound_1:upper_bound_1, lower_bound_2:upper_bound_2)) - + name = 'fates_tausvis' call fates_params%RetreiveParameter(name=name, & data=dummy_data) @@ -1108,7 +1153,7 @@ subroutine Register_PFT_leafage(this, fates_params) use FatesParametersInterface, only : fates_parameters_type, param_string_length use FatesParametersInterface, only : max_dimensions, dimension_name_leaf_age use FatesParametersInterface, only : dimension_name_pft, dimension_shape_2d - + implicit none class(EDPftvarcon_type), intent(inout) :: this @@ -1124,25 +1169,28 @@ subroutine Register_PFT_leafage(this, fates_params) name = 'fates_leaf_vcmax25top' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + return end subroutine Register_PFT_leafage + + + ! ===================================================================================== subroutine Receive_PFT_leafage(this, fates_params) - + use FatesParametersInterface, only : fates_parameters_type use FatesParametersInterface, only : param_string_length - + implicit none - + class(EDPftvarcon_type), intent(inout) :: this class(fates_parameters_type), intent(inout) :: fates_params - + character(len=param_string_length) :: name - + name = 'fates_leaf_vcmax25top' call fates_params%RetreiveParameterAllocate(name=name, & data=this%vcmax25top) @@ -1172,10 +1220,22 @@ subroutine Register_PFT_hydr_organs(this, fates_params) dim_names(1) = dimension_name_pft dim_names(2) = dimension_name_hydr_organs + name = 'fates_hydr_vg_alpha_node' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hydr_vg_m_node' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hydr_vg_n_node' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_hydr_avuln_node' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_hydr_p50_node' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -1203,28 +1263,52 @@ subroutine Register_PFT_hydr_organs(this, fates_params) name = 'fates_hydr_pinot_node' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + name = 'fates_hydr_kmax_node' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - + + name = 'fates_hydr_vg_alpha_node' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hydr_vg_m_node' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_hydr_vg_n_node' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) end subroutine Register_PFT_hydr_organs !----------------------------------------------------------------------- subroutine Receive_PFT_hydr_organs(this, fates_params) - + use FatesParametersInterface, only : fates_parameters_type use FatesParametersInterface, only : param_string_length - + implicit none - + class(EDPftvarcon_type), intent(inout) :: this class(fates_parameters_type), intent(inout) :: fates_params - + character(len=param_string_length) :: name - + + + name = 'fates_hydr_vg_alpha_node' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_vg_alpha_node) + + name = 'fates_hydr_vg_m_node' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_vg_m_node) + + name = 'fates_hydr_vg_n_node' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_vg_n_node) + name = 'fates_hydr_avuln_node' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_avuln_node) @@ -1236,19 +1320,19 @@ subroutine Receive_PFT_hydr_organs(this, fates_params) name = 'fates_hydr_thetas_node' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_thetas_node) - + name = 'fates_hydr_epsil_node' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_epsil_node) - + name = 'fates_hydr_pitlp_node' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_pitlp_node) - + name = 'fates_hydr_resid_node' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_resid_node) - + name = 'fates_hydr_fcap_node' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_fcap_node) @@ -1261,12 +1345,24 @@ subroutine Receive_PFT_hydr_organs(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%hydr_kmax_node) + name = 'fates_hydr_vg_alpha_node' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_vg_alpha_node) + + name = 'fates_hydr_vg_m_node' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_vg_m_node) + + name = 'fates_hydr_vg_n_node' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%hydr_vg_n_node) + end subroutine Receive_PFT_hydr_organs ! =============================================================================================== - + subroutine FatesReportPFTParams(is_master) - + ! Argument logical, intent(in) :: is_master ! Only log if this is the master proc @@ -1274,11 +1370,11 @@ subroutine FatesReportPFTParams(is_master) character(len=32),parameter :: fmt0 = '(a,100(F12.4,1X))' integer :: npft,ipft - + npft = size(EDPftvarcon_inst%initd,1) - + if(debug_report .and. is_master) then - + if(npft>100)then write(fates_log(),*) 'you are trying to report pft parameters during initialization' write(fates_log(),*) 'but you have so many that it is over-running the format spec' @@ -1292,13 +1388,12 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'dleaf = ',EDPftvarcon_inst%dleaf write(fates_log(),fmt0) 'z0mr = ',EDPftvarcon_inst%z0mr write(fates_log(),fmt0) 'displar = ',EDPftvarcon_inst%displar - write(fates_log(),fmt0) 'crown = ',EDPftvarcon_inst%crown write(fates_log(),fmt0) 'bark_scaler = ',EDPftvarcon_inst%bark_scaler write(fates_log(),fmt0) 'crown_kill = ',EDPftvarcon_inst%crown_kill write(fates_log(),fmt0) 'initd = ',EDPftvarcon_inst%initd write(fates_log(),fmt0) 'seed_suppl = ',EDPftvarcon_inst%seed_suppl write(fates_log(),fmt0) 'bb_slope = ',EDPftvarcon_inst%bb_slope - write(fates_log(),fmt0) 'medlyn_slope = ',EDPftvarcon_inst%medlyn_slope + write(fates_log(),fmt0) 'medlyn_slope = ',EDPftvarcon_inst%medlyn_slope write(fates_log(),fmt0) 'stomatal_intercept = ',EDPftvarcon_inst%stomatal_intercept write(fates_log(),fmt0) 'lf_flab = ',EDPftvarcon_inst%lf_flab write(fates_log(),fmt0) 'lf_fcel = ',EDPftvarcon_inst%lf_fcel @@ -1316,7 +1411,7 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'mort_ip_size_senescence = ', EDPftvarcon_inst%mort_ip_size_senescence write(fates_log(),fmt0) 'mort_r_size_senescence = ', EDPftvarcon_inst%mort_r_size_senescence write(fates_log(),fmt0) 'mort_ip_age_senescence = ', EDPftvarcon_inst%mort_ip_age_senescence - write(fates_log(),fmt0) 'mort_r_age_senescence = ', EDPftvarcon_inst%mort_r_age_senescence + write(fates_log(),fmt0) 'mort_r_age_senescence = ', EDPftvarcon_inst%mort_r_age_senescence write(fates_log(),fmt0) 'mort_scalar_coldstress = ',EDPftvarcon_inst%mort_scalar_coldstress write(fates_log(),fmt0) 'mort_scalar_cstarvation = ',EDPftvarcon_inst%mort_scalar_cstarvation write(fates_log(),fmt0) 'mort_scalar_hydrfailure = ',EDPftvarcon_inst%mort_scalar_hydrfailure @@ -1334,7 +1429,7 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'trim_inc = ',EDPftvarcon_inst%trim_inc write(fates_log(),fmt0) 'rhol = ',EDPftvarcon_inst%rhol write(fates_log(),fmt0) 'rhos = ',EDPftvarcon_inst%rhos - write(fates_log(),fmt0) 'taul = ',EDPftvarcon_inst%taul + write(fates_log(),fmt0) 'taul = ',EDPftvarcon_inst%taul write(fates_log(),fmt0) 'taus = ',EDPftvarcon_inst%taus write(fates_log(),fmt0) 'phenflush_fraction',EDpftvarcon_inst%phenflush_fraction write(fates_log(),fmt0) 'phen_cold_size_threshold = ',EDPftvarcon_inst%phen_cold_size_threshold @@ -1346,16 +1441,22 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'hydr_srl = ',EDPftvarcon_inst%hydr_srl write(fates_log(),fmt0) 'hydr_rfrac_stem = ',EDPftvarcon_inst%hydr_rfrac_stem write(fates_log(),fmt0) 'hydr_avuln_gs = ',EDPftvarcon_inst%hydr_avuln_gs + write(fates_log(),fmt0) 'hydr_k_lwp = ',EDPftvarcon_inst%hydr_k_lwp write(fates_log(),fmt0) 'hydr_p50_gs = ',EDPftvarcon_inst%hydr_p50_gs + write(fates_log(),fmt0) 'hydr_k_lwp = ',EDPftvarcon_inst%hydr_k_lwp write(fates_log(),fmt0) 'hydr_avuln_node = ',EDPftvarcon_inst%hydr_avuln_node write(fates_log(),fmt0) 'hydr_p50_node = ',EDPftvarcon_inst%hydr_p50_node - write(fates_log(),fmt0) 'hydr_thetas_node = ',EDPftvarcon_inst%hydr_thetas_node + write(fates_log(),fmt0) 'hydr_thetas_node = ',EDPftvarcon_inst%hydr_thetas_node write(fates_log(),fmt0) 'hydr_epsil_node = ',EDPftvarcon_inst%hydr_epsil_node write(fates_log(),fmt0) 'hydr_pitlp_node = ',EDPftvarcon_inst%hydr_pitlp_node write(fates_log(),fmt0) 'hydr_resid_node = ',EDPftvarcon_inst%hydr_resid_node write(fates_log(),fmt0) 'hydr_fcap_node = ',EDPftvarcon_inst%hydr_fcap_node write(fates_log(),fmt0) 'hydr_pinot_node = ',EDPftvarcon_inst%hydr_pinot_node write(fates_log(),fmt0) 'hydr_kmax_node = ',EDPftvarcon_inst%hydr_kmax_node + write(fates_log(),fmt0) 'hlm_pft_map = ', EDPftvarcon_inst%hlm_pft_map + write(fates_log(),fmt0) 'hydr_vg_alpha_node = ',EDPftvarcon_inst%hydr_vg_alpha_node + write(fates_log(),fmt0) 'hydr_vg_m_node = ',EDPftvarcon_inst%hydr_vg_m_node + write(fates_log(),fmt0) 'hydr_vg_n_node = ',EDPftvarcon_inst%hydr_vg_n_node write(fates_log(),*) '-------------------------------------------------' end if @@ -1370,7 +1471,7 @@ subroutine FatesCheckParams(is_master) ! ---------------------------------------------------------------------------------- ! ! This subroutine performs logical checks on user supplied parameters. It cross - ! compares various parameters and will fail if they don't make sense. + ! compares various parameters and will fail if they don't make sense. ! Examples: ! A tree can not be defined as both evergreen and deciduous. A woody plant ! cannot have a structural biomass allometry intercept of 0, and a non-woody @@ -1379,7 +1480,8 @@ subroutine FatesCheckParams(is_master) use FatesConstantsMod , only : fates_check_param_set use FatesConstantsMod , only : itrue, ifalse use EDParamsMod , only : logging_mechanical_frac, logging_collateral_frac, logging_direct_frac - + use FatesInterfaceTypesMod , only : hlm_use_fixed_biogeog,hlm_use_sp + ! Argument logical, intent(in) :: is_master ! Only log if this is the master proc @@ -1390,6 +1492,10 @@ subroutine FatesCheckParams(is_master) integer :: nleafage ! size of the leaf age class array integer :: iage ! leaf age class index integer :: norgans ! size of the plant organ dimension + integer :: hlm_pft ! used in fixed biogeog mode + integer :: fates_pft ! used in fixed biogeog mode + + real(r8) :: sumarea ! area of PFTs in nocomp mode. npft = size(EDPftvarcon_inst%freezetol,1) @@ -1397,9 +1503,9 @@ subroutine FatesCheckParams(is_master) if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then - + ! Check to see if either RD/ECA/MIC is turned on - + if (.not.( (trim(hlm_nu_com).eq.'RD') .or. (trim(hlm_nu_com).eq.'ECA'))) then write(fates_log(),*) 'FATES PARTEH with allometric flexible CNP must have' write(fates_log(),*) 'a valid BGC model enabled: RD,ECA,MIC or SYN' @@ -1407,19 +1513,19 @@ subroutine FatesCheckParams(is_master) write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + ! If nitrogen is turned on, check to make sure there are valid ammonium ! parameters if(hlm_nitrogen_spec>0)then if (trim(hlm_nu_com).eq.'ECA') then - + if(any(EDpftvarcon_inst%eca_km_nh4(:)<0._r8) ) then write(fates_log(),*) 'ECA with nitrogen is turned on' write(fates_log(),*) 'bad ECA km value(s) for nh4: ',EDpftvarcon_inst%eca_km_nh4(:) write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + if(hlm_nitrogen_spec==2)then if(any(EDpftvarcon_inst%eca_km_no3(:)<0._r8)) then write(fates_log(),*) 'ECA with nit/denitr is turned on' @@ -1431,9 +1537,9 @@ subroutine FatesCheckParams(is_master) end if end if - + elseif (hlm_parteh_mode .ne. prt_carbon_allom_hyp) then - + write(fates_log(),*) 'FATES Plant Allocation and Reactive Transport has' write(fates_log(),*) 'only 2 modules supported, allometric carbon and CNP.' write(fates_log(),*) 'fates_parteh_mode must be set to 1 or 2 in the namelist' @@ -1443,7 +1549,7 @@ subroutine FatesCheckParams(is_master) ! If any PFTs are specified as either prescribed N or P uptake ! then they all must be ! - + if (any(EDPftvarcon_inst%prescribed_nuptake(:) < -nearzero ) .or. & any(EDPftvarcon_inst%prescribed_nuptake(:) > 10._r8 ) ) then write(fates_log(),*) 'Negative values for EDPftvarcon_inst%prescribed_nuptake(:)' @@ -1474,7 +1580,7 @@ subroutine FatesCheckParams(is_master) write(fates_log(),*) 'Exiting' call endrun(msg=errMsg(sourcefile, __LINE__)) endif - + ! Same for phosphorus if (any(EDPftvarcon_inst%prescribed_puptake(:) < -nearzero ) .or. & any(EDPftvarcon_inst%prescribed_puptake(:) > 10._r8 )) then @@ -1498,14 +1604,14 @@ subroutine FatesCheckParams(is_master) else p_uptake_mode = coupled_p_uptake end if - - + + do ipft = 1,npft - - ! Check that parameter ranges for age-dependent mortality make sense - !----------------------------------------------------------------------------------- + + ! Check that parameter ranges for age-dependent mortality make sense + !----------------------------------------------------------------------------------- if ( ( EDPftvarcon_inst%mort_ip_age_senescence(ipft) < fates_check_param_set ) .and. & ( EDPftvarcon_inst%mort_r_age_senescence(ipft) > fates_check_param_set ) ) then @@ -1516,8 +1622,8 @@ subroutine FatesCheckParams(is_master) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - ! Check that parameter ranges for size-dependent mortality make sense - !----------------------------------------------------------------------------------- + ! Check that parameter ranges for size-dependent mortality make sense + !----------------------------------------------------------------------------------- if ( ( EDPftvarcon_inst%mort_ip_size_senescence(ipft) < fates_check_param_set ) .and. & ( EDPftvarcon_inst%mort_r_size_senescence(ipft) > fates_check_param_set ) ) then @@ -1528,8 +1634,8 @@ subroutine FatesCheckParams(is_master) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - ! Check that parameter ranges for size-dependent mortality make sense - !----------------------------------------------------------------------------------- + ! Check that parameter ranges for size-dependent mortality make sense + !----------------------------------------------------------------------------------- if ( ( EDPftvarcon_inst%mort_ip_size_senescence(ipft) < 0.0_r8 ) .or. & ( EDPftvarcon_inst%mort_r_size_senescence(ipft) < 0.0_r8 ) ) then @@ -1542,8 +1648,8 @@ subroutine FatesCheckParams(is_master) end if - ! Check that parameter ranges for size-dependent mortality make sense - !----------------------------------------------------------------------------------- + ! Check that parameter ranges for size-dependent mortality make sense + !----------------------------------------------------------------------------------- if ( ( EDPftvarcon_inst%mort_ip_size_senescence(ipft) < 0.0_r8 ) .or. & ( EDPftvarcon_inst%mort_r_size_senescence(ipft) < 0.0_r8 ) ) then @@ -1558,10 +1664,10 @@ subroutine FatesCheckParams(is_master) ! Check if the fraction of storage used for flushing deciduous trees ! is greater than zero, and less than or equal to 1. - if ( int(prt_params%evergreen(ipft)) .ne. 1 ) then + if ( int(prt_params%evergreen(ipft)) .ne. 1 ) then if ( ( EDPftvarcon_inst%phenflush_fraction(ipft) < nearzero ) .or. & ( EDPFtvarcon_inst%phenflush_fraction(ipft) > 1 ) ) then - + write(fates_log(),*) ' Deciduous plants must flush some storage carbon' write(fates_log(),*) ' on bud-burst. If phenflush_fraction is not greater than 0' write(fates_log(),*) ' it will not be able to put out any leaves. Plants need leaves.' @@ -1580,13 +1686,13 @@ subroutine FatesCheckParams(is_master) write(fates_log(),*) ' phen_stem_drop_fraction: ', EDPFtvarcon_inst%phen_stem_drop_fraction(ipft) write(fates_log(),*) ' Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + end if end if - + ! Check if freezing tolerance is within reasonable bounds ! ---------------------------------------------------------------------------------- - + if ( ( EDPftvarcon_inst%freezetol(ipft) > 60.0_r8 ) .or. & ( EDPFtvarcon_inst%freezetol(ipft) < -273.1_r8 ) ) then @@ -1602,11 +1708,11 @@ subroutine FatesCheckParams(is_master) end if - + ! Check if fraction of storage to reproduction is between 0-1 ! ---------------------------------------------------------------------------------- - + if ( ( EDPftvarcon_inst%allom_frbstor_repro(ipft) < 0.0_r8 ) .or. & ( EDPftvarcon_inst%allom_frbstor_repro(ipft) > 1.0_r8 ) ) then @@ -1619,11 +1725,11 @@ subroutine FatesCheckParams(is_master) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + ! Check if photosynthetic pathway is neither C3/C4 ! ---------------------------------------------------------------------------------- - + if ( ( EDPftvarcon_inst%c3psn(ipft) < 0.0_r8 ) .or. & ( EDPftvarcon_inst%c3psn(ipft) > 1.0_r8 ) ) then @@ -1637,13 +1743,30 @@ subroutine FatesCheckParams(is_master) end if - end do + if( hlm_use_fixed_biogeog .eq. itrue ) then + ! check that the host-fates PFT map adds to one along HLM dimension so that all the HLM area + ! goes to a FATES PFT. Each FATES PFT can get < or > 1 of an HLM PFT. + do hlm_pft = 1,size( EDPftvarcon_inst%hlm_pft_map,2) + sumarea = sum(EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft)) + if(abs(sumarea-1.0_r8).gt.nearzero)then + write(fates_log(),*) 'The distribution of this host land model PFT :',hlm_pft + write(fates_log(),*) 'into FATES PFTs, does not add up to 1.0.' + write(fates_log(),*) 'Error is:',sumarea-1.0_r8 + write(fates_log(),*) 'and the hlm_pft_map is:', EDPftvarcon_inst%hlm_pft_map(1:npft,hlm_pft) + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do !hlm_pft + end if + + end do !ipft + !! ! Checks for HYDRO !! if( hlm_use_planthydro == itrue ) then -!! +!! !! do ipft=1,numpft -!! +!! !! ! Calculate fine-root density and see if the result !! ! is reasonable. !! ! kg/m3 @@ -1668,7 +1791,7 @@ end subroutine FatesCheckParams ! ===================================================================================== function GetDecompyFrac(pft,organ_id,dcmpy) result(decompy_frac) - + ! This simple routine matches the correct decomposibility pool's ! material fraction with the pft parameter data. @@ -1676,8 +1799,8 @@ function GetDecompyFrac(pft,organ_id,dcmpy) result(decompy_frac) integer, intent(in) :: pft integer, intent(in) :: organ_id integer, intent(in) :: dcmpy - real(r8) :: decompy_frac - + real(r8) :: decompy_frac + ! Decomposability for leaves if(organ_id == leaf_organ)then select case(dcmpy) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index a52f73f8ec..3586417970 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -18,6 +18,11 @@ module EDTypesMod use FatesLitterMod, only : ncwd use FatesConstantsMod, only : n_anthro_disturbance_categories use FatesConstantsMod, only : days_per_year + use FatesConstantsMod, only : fates_unset_r8 + use FatesRunningMeanMod, only : rmean_type + use FatesInterfaceTypesMod,only : bc_in_type + use FatesInterfaceTypesMod,only : bc_out_type + implicit none private ! By default everything is private @@ -34,14 +39,14 @@ module EDTypesMod ! to understory layers (all layers that ! are not the top canopy layer) - integer, parameter, public :: nlevleaf = 30 ! number of leaf layers in canopy layer integer, parameter, public :: maxpft = 16 ! maximum number of PFTs allowed ! the parameter file may determine that fewer ! are used, but this helps allocate scratch ! space and output arrays. - + real(r8), parameter, public :: init_recruit_trim = 0.8_r8 ! This is the initial trimming value that + ! new recruits start with ! ------------------------------------------------------------------------------------- ! Radiation parameters @@ -55,6 +60,10 @@ module EDTypesMod integer, parameter, public :: idirect = 1 ! This is the array index for direct radiation integer, parameter, public :: idiffuse = 2 ! This is the array index for diffuse radiation + ! parameters that govern the VAI (LAI+SAI) bins used in radiative transfer code + integer, parameter, public :: nlevleaf = 30 ! number of leaf+stem layers in canopy layer + real(r8), public :: dinc_vai(nlevleaf) = fates_unset_r8 ! VAI bin widths array + real(r8), public :: dlower_vai(nlevleaf) = fates_unset_r8 ! lower edges of VAI bins ! TODO: we use this cp_maxSWb only because we have a static array q(size=2) of ! land-ice abledo for vis and nir. This should be a parameter, which would @@ -120,8 +129,6 @@ module EDTypesMod ! BIOLOGY/BIOGEOCHEMISTRY integer , parameter, public :: num_vegtemp_mem = 10 ! Window of time over which we track temp for cold sensecence (days) - real(r8), parameter, public :: dinc_ed = 1.0_r8 ! size of VAI bins (LAI+SAI) [CHANGE THIS NAME WITH NEXT INTERFACE - ! UPDATE] integer , parameter, public :: N_DIST_TYPES = 3 ! Disturbance Modes 1) tree-fall, 2) fire, 3) logging integer , parameter, public :: dtype_ifall = 1 ! index for naturally occuring tree-fall generated event integer , parameter, public :: dtype_ifire = 2 ! index for fire generated disturbance event @@ -187,8 +194,7 @@ module EDTypesMod integer, public :: n_uptake_mode integer, public :: p_uptake_mode - - + !************************************ !** COHORT type structure ** !************************************ @@ -282,21 +288,19 @@ module EDTypesMod ! Nutrient Fluxes (if N, P, etc. are turned on) - real(r8) :: daily_n_uptake ! integrated daily uptake of mineralized N through competitive acquisition in soil [kg N / plant/ day] + real(r8) :: daily_nh4_uptake ! integrated daily uptake of mineralized ammonium through competitive acquisition in soil [kg N / plant/ day] + real(r8) :: daily_no3_uptake ! integrated daily uptake of mineralized nitrate through competitive acquisition in soil [kg N / plant/ day] real(r8) :: daily_p_uptake ! integrated daily uptake of mineralized P through competitive acquisition in soil [kg P / plant/ day] real(r8) :: daily_c_efflux ! daily mean efflux of excess carbon from roots into labile pool [kg C/plant/day] real(r8) :: daily_n_efflux ! daily mean efflux of excess nitrogen from roots into labile pool [kg N/plant/day] real(r8) :: daily_p_efflux ! daily mean efflux of excess phophorus from roots into labile pool [kg P/plant/day] - real(r8) :: daily_n_need1 ! Nitrogen needed to enable non-limited C growth (AllometricCNP hypothesis) - real(r8) :: daily_n_need2 ! Nitrogen needed to bring N concentrations up to optimal - real(r8) :: daily_p_need1 ! Phosphorus needed to enable non-limited C growth (AllometricCNP hypothesis) - real(r8) :: daily_p_need2 ! Phosphorus needed to bring P concentrations up to optimal + real(r8) :: daily_n_need ! Generic Nitrogen need of the plant, (hypothesis dependent) [kgN/plant/day] + real(r8) :: daily_p_need ! Generic Phosphorus need of the plant, (hypothesis dependent) [kgN/plant/day] + ! These two variables may use the previous "need" variables, by applying a smoothing function. - ! Or, its possible that the plant will use another method to calculate this, perhaps based - ! on storage. ! These variables are used in two scenarios. 1) They work with the prescribed uptake fraction ! in un-coupled mode, and 2) They are the plant's demand subbmitted to the Relative-Demand ! type soil BGC scheme. @@ -385,6 +389,14 @@ module EDTypesMod ! Hydraulics type(ed_cohort_hydr_type), pointer :: co_hydr ! All cohort hydraulics data, see FatesHydraulicsMemMod.F90 + + ! Running means + + ! (keeping this in-code as an example) + !class(rmean_type), pointer :: tveg_lpa ! exponential moving average of leaf temperature at the + ! leaf photosynthetic acclimation time-scale [K] + + end type ed_cohort_type !************************************ @@ -411,6 +423,14 @@ module EDTypesMod integer :: anthro_disturbance_label ! patch label for anthropogenic disturbance classification real(r8) :: age_since_anthro_disturbance ! average age for secondary forest since last anthropogenic disturbance + + ! Running means + !class(rmean_type), pointer :: t2m ! Place-holder for 2m air temperature (variable window-size) + class(rmean_type), pointer :: tveg24 ! 24-hour mean vegetation temperature (K) + class(rmean_type), pointer :: tveg_lpa ! Running mean of vegetation temperature at the + ! leaf photosynthesis acclimation timescale [K] + integer :: nocomp_pft_label ! where nocomp is active, use this label for patch ID. + ! LEAF ORGANIZATION real(r8) :: pft_agb_profile(maxpft,n_dbh_bins) ! binned above ground biomass, for patch fusion: KgC/m2 real(r8) :: canopy_layer_tlai(nclmax) ! total leaf area index of each canopy layer @@ -429,7 +449,7 @@ module EDTypesMod real(r8) :: elai_profile(nclmax,maxpft,nlevleaf) ! exposed leaf area in each canopy layer, pft, and leaf layer real(r8) :: tsai_profile(nclmax,maxpft,nlevleaf) ! total stem area in each canopy layer, pft, and leaf layer real(r8) :: esai_profile(nclmax,maxpft,nlevleaf) ! exposed stem area in each canopy layer, pft, and leaf layer - + real(r8) :: radiation_error ! radiation error (w/m2) real(r8) :: layer_height_profile(nclmax,maxpft,nlevleaf) real(r8) :: canopy_area_profile(nclmax,maxpft,nlevleaf) ! fraction of crown area per canopy area in each layer ! they will sum to 1.0 in the fully closed canopy layers @@ -443,6 +463,7 @@ module EDTypesMod integer :: ncan(nclmax,maxpft) ! number of total leaf layers for each canopy layer and pft !RADIATION FLUXES + real(r8) :: fcansno ! Fraction of canopy covered in snow logical :: solar_zenith_flag ! integer flag specifying daylight (based on zenith angle) real(r8) :: solar_zenith_angle ! solar zenith angle (radians) @@ -528,8 +549,6 @@ module EDTypesMod real(r8),allocatable :: fragmentation_scaler(:) ! Scale rate of litter fragmentation based on soil layer. 0 to 1. - real(r8) :: repro(maxpft) ! allocation to reproduction per PFT : KgC/m2 - !FUEL CHARECTERISTICS real(r8) :: sum_fuel ! total ground fuel related to ros (omits 1000hr fuels): KgC/m2 real(r8) :: fuel_frac(nfsc) ! fraction of each litter class in the ros_fuel:-. @@ -602,8 +621,7 @@ module EDTypesMod real(r8),allocatable :: nutrient_uptake_scpf(:) real(r8),allocatable :: nutrient_efflux_scpf(:) - real(r8),allocatable :: nutrient_needgrow_scpf(:) - real(r8),allocatable :: nutrient_needmax_scpf(:) + real(r8),allocatable :: nutrient_need_scpf(:) contains @@ -663,11 +681,6 @@ module EDTypesMod procedure :: ZeroMassBalFlux end type site_massbal_type - - - - - !************************************ @@ -683,8 +696,14 @@ module EDTypesMod ! Resource management type (ed_resources_management_type) :: resources_management ! resources_management at the site + ! If this simulation uses shared memory then the sites need to know what machine + ! index they are on. This index is (currently) only used to identify the sites + ! position in history output fields + !integer :: clump_id - + ! Global index of this site in the history output file + integer :: h_gid + ! INDICES real(r8) :: lat ! latitude: degrees real(r8) :: lon ! longitude: degrees @@ -692,7 +711,15 @@ module EDTypesMod ! Fixed Biogeography mode inputs real(r8), allocatable :: area_PFT(:) ! Area allocated to individual PFTs integer, allocatable :: use_this_pft(:) ! Is area_PFT > 0 ? (1=yes, 0=no) - + + ! Total area of patches in each age bin [m2] + real(r8), allocatable :: area_by_age(:) + + ! SP mode target PFT level variables + real(r8), allocatable :: sp_tlai(:) ! target TLAI per FATES pft + real(r8), allocatable :: sp_tsai(:) ! target TSAI per FATES pft + real(r8), allocatable :: sp_htop(:) ! target HTOP per FATES pft + ! Mass Balance (allocation for each element) type(site_massbal_type), pointer :: mass_balance(:) @@ -744,7 +771,7 @@ module EDTypesMod real(r8), allocatable :: dz_soil(:) ! layer thickness (m) real(r8), allocatable :: z_soil(:) ! layer depth (m) real(r8), allocatable :: rootfrac_scr(:) ! This is just allocated scratch space to hold - ! root fractions. Since root fractions may be dependant + ! root fractions. Since root fractions may be dependent ! on cohort properties, and we do not want to store this infromation ! on each cohort, we do not keep root fractions in ! memory, and instead calculate them on demand. @@ -835,8 +862,7 @@ subroutine ZeroFluxDiags(this) this%root_litter_input(:) = 0._r8 this%nutrient_uptake_scpf(:) = 0._r8 this%nutrient_efflux_scpf(:) = 0._r8 - this%nutrient_needgrow_scpf(:) = 0._r8 - this%nutrient_needmax_scpf(:) = 0._r8 + this%nutrient_need_scpf(:) = 0._r8 return end subroutine ZeroFluxDiags diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index 66d089a895..726100a37b 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -23,7 +23,7 @@ module FatesConstantsMod ! Used to check if a parameter was specified in the parameter file (or left as _) real(fates_r8), parameter, public :: fates_check_param_set = 9.9e32_fates_r8 - + ! Integer equivalent of true (in case some compilers dont auto convert) integer, parameter, public :: itrue = 1 @@ -46,18 +46,24 @@ module FatesConstantsMod integer, public, parameter :: prescribed_n_uptake = 1 integer, public, parameter :: coupled_n_uptake = 2 - + integer, public, parameter :: cohort_np_comp_scaling = 1 ! This flag definition indicates that EVERY cohort on - ! the column should compete independently in the soil - ! BGC nitrogen and phosphorus acquisition scheme. + ! the column should compete independently in the soil + ! BGC nitrogen and phosphorus acquisition scheme. integer, public, parameter :: pft_np_comp_scaling = 2 ! This flag definition indicates that cohorts should - ! be grouped into PFTs, and each PFT will be represented - ! as the competitor, in the BGC N and P acquisition scheme + ! be grouped into PFTs, and each PFT will be represented + ! as the competitor, in the BGC N and P acquisition scheme + + integer, public, parameter :: trivial_np_comp_scaling = 3 ! This flag definition indicates that either + ! nutrients are turned off in FATES, or, that the + ! plants are not coupled with below ground chemistry. In + ! this situation, we send token boundary condition information. + ! This flag specifies the scaling of how we present ! nutrient competitors to the HLM's soil BGC model - + integer, public, parameter :: fates_np_comp_scaling = cohort_np_comp_scaling real(fates_r8), parameter, public :: secondary_age_threshold = 94._fates_r8 ! less than this value is young secondary land @@ -66,9 +72,9 @@ module FatesConstantsMod ! integer labels for specifying harvest units integer, parameter, public :: hlm_harvest_area_fraction = 1 ! Code for harvesting by area - integer, parameter, public :: hlm_harvest_carbon = 2 ! Code for harvesting based on carbon extracted. + integer, parameter, public :: hlm_harvest_carbon = 2 ! Code for harvesting based on carbon extracted. + - ! Error Tolerances ! Allowable error in carbon allocations, should be applied to estimates @@ -82,7 +88,7 @@ module FatesConstantsMod ! multiplying each by their original sum, and then seeing if their addition ! matches the original sum. Other simple examples of rounding errors ! are simply changing the orders: a*b*c .ne. a*c*b - ! This value here is used as an error expectation comparison + ! This value here is used as an error expectation comparison ! for multiplication/division procedures, also allowing for 3 orders ! of magnitude of buffer error (ie instead of 1e-15) real(fates_r8), parameter, public :: rsnbl_math_prec = 1.0e-12_fates_r8 @@ -91,7 +97,7 @@ module FatesConstantsMod real(fates_r8), parameter, public :: tinyr8 = tiny(1.0_fates_r8) ! We mostly use this in place of logical comparisons - ! between reals with zero, as the chances are their + ! between reals with zero, as the chances are their ! precisions are preventing perfect zero in comparison real(fates_r8), parameter, public :: nearzero = 1.0e-30_fates_r8 @@ -104,10 +110,10 @@ module FatesConstantsMod ! Conversion factor: miligrams per kilogram real(fates_r8), parameter, public :: mg_per_kg = 1.0e6_fates_r8 - + ! Conversion factor: grams per kilograms real(fates_r8), parameter, public :: g_per_kg = 1000.0_fates_r8 - + ! Conversion factor: kilograms per gram real(fates_r8), parameter, public :: kg_per_g = 0.001_fates_r8 @@ -122,7 +128,7 @@ module FatesConstantsMod ! Conversion factor: milimoles per mole real(fates_r8), parameter, public :: mmol_per_mol = 1000.0_fates_r8 - + ! Conversion factor: micromoles per mole real(fates_r8), parameter, public :: umol_per_mol = 1.0E6_fates_r8 @@ -135,9 +141,15 @@ module FatesConstantsMod ! Conversion factor: milimeters per meter real(fates_r8), parameter, public :: mm_per_m = 1.0E3_fates_r8 + ! Conversion factor: meters per centimeter + real(fates_r8), parameter, public :: m_per_cm = 1.0E-2_fates_r8 + ! Conversion factor: m2 per ha real(fates_r8), parameter, public :: m2_per_ha = 1.0e4_fates_r8 + ! Conversion factor: m2 per km2 + real(fates_r8), parameter, public :: m2_per_km2 = 1.0e6_fates_r8 + ! Conversion factor: cm2 per m2 real(fates_r8), parameter, public :: cm2_per_m2 = 10000.0_fates_r8 @@ -161,31 +173,43 @@ module FatesConstantsMod ! Conversion: days per second real(fates_r8), parameter, public :: days_per_sec = 1.0_fates_r8/86400.0_fates_r8 - ! Conversion: days per year. assume HLM uses 365 day calendar. + ! Conversion: days per year. assume HLM uses 365 day calendar. ! If we need to link to 365.25-day-calendared HLM, rewire to pass through interface real(fates_r8), parameter, public :: days_per_year = 365.00_fates_r8 - - ! Conversion: years per day. assume HLM uses 365 day calendar. + + ! Conversion: years per day. assume HLM uses 365 day calendar. ! If we need to link to 365.25-day-calendared HLM, rewire to pass through interface real(fates_r8), parameter, public :: years_per_day = 1.0_fates_r8/365.00_fates_r8 ! Conversion: months per year real(fates_r8), parameter, public :: months_per_year = 12.0_fates_r8 + ! Conversion: Joules per kiloJoules + real(fates_r8), parameter, public :: J_per_kJ = 1000.0_fates_r8 + ! Physical constants ! universal gas constant [J/K/kmol] real(fates_r8), parameter, public :: rgas_J_K_kmol = 8314.4598_fates_r8 + ! universal gas constant [J/k/mol] + real(fates_r8), parameter, public :: rgas_J_K_mol = 8.3144598_fates_r8 + ! freezing point of water at 1 atm (K) - real(fates_r8), parameter, public :: t_water_freeze_k_1atm = 273.15_fates_r8 + real(fates_r8), parameter, public :: t_water_freeze_k_1atm = 273.15_fates_r8 ! freezing point of water at triple point (K) - real(fates_r8), parameter, public :: t_water_freeze_k_triple = 273.16_fates_r8 + real(fates_r8), parameter, public :: t_water_freeze_k_triple = 273.16_fates_r8 ! Density of fresh liquid water (kg/m3) real(fates_r8), parameter, public :: dens_fresh_liquid_water = 1.0E3_fates_r8 + ! Molar mass of water (g/mol) + real(fates_r8), parameter, public :: molar_mass_water = 18.0_fates_r8 + + ! Approximate molar mass of water vapor to dry air (-) + real(fates_r8), parameter, public :: molar_mass_ratio_vapdry= 0.622_fates_r8 + ! Gravity constant on earth [m/s] real(fates_r8), parameter, public :: grav_earth = 9.8_fates_r8 @@ -201,7 +225,7 @@ module FatesConstantsMod real(fates_r8), parameter, public :: fates_tiny = tiny(g_per_kg) ! Geometric Constants - + ! PI real(fates_r8), parameter, public :: pi_const = 3.14159265359_fates_r8 diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index d8368966b7..4094b2055d 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -8,6 +8,8 @@ module FatesHistoryInterfaceMod use FatesConstantsMod , only : calloc_abs_error use FatesConstantsMod , only : mg_per_kg use FatesConstantsMod , only : pi_const + use FatesConstantsMod , only : nearzero + use FatesConstantsMod , only : t_water_freeze_k_1atm use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun use EDTypesMod , only : nclmax @@ -17,7 +19,7 @@ module FatesHistoryInterfaceMod use EDTypesMod , only : site_fluxdiags_type use EDtypesMod , only : ed_site_type use EDtypesMod , only : ed_cohort_type - use EDtypesMod , only : ed_patch_type + use EDtypesMod , only : ed_patch_type use EDtypesMod , only : AREA use EDtypesMod , only : AREA_INV use EDTypesMod , only : numWaterMem @@ -30,6 +32,7 @@ module FatesHistoryInterfaceMod use EDTypesMod , only : dtype_ilog use FatesIODimensionsMod , only : fates_io_dimension_type use FatesIOVariableKindMod , only : fates_io_variable_kind_type + use FatesIOVariableKindMod , only : site_int use FatesHistoryVariableType , only : fates_history_variable_type use FatesInterfaceTypesMod , only : hlm_hio_ignore_val use FatesInterfaceTypesMod , only : hlm_use_planthydro @@ -45,11 +48,12 @@ module FatesHistoryInterfaceMod use FatesInterfaceTypesMod , only : bc_in_type use FatesInterfaceTypesMod , only : hlm_model_day use FatesInterfaceTypesMod , only : nlevcoage + use FatesInterfaceTypesMod , only : hlm_use_nocomp + use FatesAllometryMod , only : CrownDepth - ! FIXME(bja, 2016-10) need to remove CLM dependancy use EDPftvarcon , only : EDPftvarcon_inst use PRTParametersMod , only : prt_params - + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg use shr_infnan_mod , only : isnan => shr_infnan_isnan @@ -59,6 +63,13 @@ module FatesHistoryInterfaceMod use FatesConstantsMod , only : sec_per_day use FatesConstantsMod , only : days_per_year use FatesConstantsMod , only : years_per_day + use FatesConstantsMod , only : m2_per_km2 + use FatesConstantsMod , only : J_per_kJ + use FatesConstantsMod , only : m2_per_ha + use FatesConstantsMod , only : m_per_cm + use FatesConstantsMod , only : sec_per_min + use FatesConstantsMod , only : umol_per_mol + use FatesConstantsMod , only : pa_per_mpa use FatesLitterMod , only : litter_type use FatesConstantsMod , only : secondaryforest @@ -83,26 +94,26 @@ module FatesHistoryInterfaceMod ! as distinct classes such as PFTs or fuel size bins, there are multiple different dimensions in ! which it is possible to output history variables to better understand what's going on. ! - ! a key point is that, while the number of patches or cohorts can in principle be large, and - ! the age and size indices of a given patch or cohort can be finely resolved, we collapse these - ! continuously varying indices into bins of time-invariant width for the purposes of history + ! a key point is that, while the number of patches or cohorts can in principle be large, and + ! the age and size indices of a given patch or cohort can be finely resolved, we collapse these + ! continuously varying indices into bins of time-invariant width for the purposes of history ! outputting. This is because a given patch or cohort may not persist across a given interval - ! of history averaging, so it is better to output all patches of cohorts whose index is within + ! of history averaging, so it is better to output all patches of cohorts whose index is within ! a given interval along the size or age bin. ! - ! Another particularity of the issue of FATES shifting its subgrid structure frequently + ! Another particularity of the issue of FATES shifting its subgrid structure frequently ! and possibly having multiple (or zero) patches or cohorts within a given bin is that, if you - ! want to output an average quantities across some dimension, such as a mean carbon flux across + ! want to output an average quantities across some dimension, such as a mean carbon flux across ! patch area of a given age, in general it is better to output both the numerator and denominator - ! of the averaging calculation separately, rather than the average itself, and then calculate - ! the average in post-processing. So, e.g. this means outputting both the patch area and the - ! product of the flux within each patch and the patch area as separate variables. Doing this + ! of the averaging calculation separately, rather than the average itself, and then calculate + ! the average in post-processing. So, e.g. this means outputting both the patch area and the + ! product of the flux within each patch and the patch area as separate variables. Doing this ! allows conservation even when the weights are changing rapidly and simplifies the logic when ! the number of patches or cohorts may be anywhere from zero to a large number. ! - ! So what this means is that anything that is disaggregated at the patch area requires + ! So what this means is that anything that is disaggregated at the patch area requires ! outputting the patch age distribution (in units of patch area / site area) as the denominator - ! of the average and then calculating the numerator of the average as XXX times the patch + ! of the average and then calculating the numerator of the average as XXX times the patch ! area so (so in units of XXX * patch area / site area). For cohort-level quantities, ! this requires outputting the number density (in units of individuals per site area), etc. ! @@ -113,7 +124,7 @@ module FatesHistoryInterfaceMod ! age = the age bin dimension ! height = the height bin dimension ! cwdsc = the coarse woody debris size class dimension - ! + ! ! Since the netcdf interface can only handle variables with a certain number of dimensions, ! we have create some "multiplexed" dimensions that combine two or more dimensions into a ! single dimension. Examples of these are the following: @@ -125,25 +136,25 @@ module FatesHistoryInterfaceMod ! scagpft = size class bin x age bin x PFT ! agepft = age bin x PFT ! agefuel = age bin x fuel size class - + ! A recipe for adding a new history variable to this module: ! (1) decide what time frequency it makes sense to update the variable at, and what dimension(s) ! you want to output the variable on - ! (2) add the ih_ integer variable in the immediately following section of the module. + ! (2) add the ih_ integer variable in the immediately following section of the module. ! use the suffix as outlined above for the dimension you are using. - ! (3) define a corresponding hio_ variable by associating it to the ih_ variable - ! in the associate section of the subroutine that corresponds to the time-updating + ! (3) define a corresponding hio_ variable by associating it to the ih_ variable + ! in the associate section of the subroutine that corresponds to the time-updating ! frequency that you've chosen - ! (i.e. if half-hourly, then work in subroutine update_history_prod; if daily, + ! (i.e. if half-hourly, then work in subroutine update_history_prod; if daily, ! then work in subroutine update_history_dyn) - ! (4) within that subroutine, add the logic that passes the information from the - ! fates-native variable (possibly on a patch or cohort structure) to the history + ! (4) within that subroutine, add the logic that passes the information from the + ! fates-native variable (possibly on a patch or cohort structure) to the history ! hio_ variable that you've associated to. - ! (5) add the variable name, metadata, units, dimension, updating frequency, the ih_ variable + ! (5) add the variable name, metadata, units, dimension, updating frequency, the ih_ variable ! index, etc via a call to the set_history_var method in the subroutine define_history_vars. ! - + ! Indices to 1D Patch variables integer :: ih_storec_si @@ -154,6 +165,7 @@ module FatesHistoryInterfaceMod integer :: ih_totvegc_si integer :: ih_storen_si + integer :: ih_storentfrac_si integer :: ih_leafn_si integer :: ih_sapwn_si integer :: ih_fnrtn_si @@ -161,22 +173,22 @@ module FatesHistoryInterfaceMod integer :: ih_totvegn_si integer :: ih_storep_si + integer :: ih_storeptfrac_si integer :: ih_leafp_si integer :: ih_sapwp_si integer :: ih_fnrtp_si integer :: ih_reprop_si integer :: ih_totvegp_si - integer :: ih_nuptake_si - integer :: ih_puptake_si + integer,public :: ih_nh4uptake_si + integer,public :: ih_no3uptake_si + integer,public :: ih_puptake_si integer :: ih_cefflux_si integer :: ih_nefflux_si integer :: ih_pefflux_si - integer :: ih_nneedgrow_si - integer :: ih_nneedmax_si - integer :: ih_pneedgrow_si - integer :: ih_pneedmax_si - + integer :: ih_nneed_si + integer :: ih_pneed_si + integer :: ih_trimming_si integer :: ih_area_plant_si integer :: ih_area_trees_si @@ -203,7 +215,7 @@ module FatesHistoryInterfaceMod integer :: ih_burn_flux_elem ! Size-class x PFT mass states - + integer :: ih_bstor_canopy_si_scpf integer :: ih_bstor_understory_si_scpf integer :: ih_bleaf_canopy_si_scpf @@ -215,12 +227,14 @@ module FatesHistoryInterfaceMod integer :: ih_leafn_scpf integer :: ih_fnrtn_scpf integer :: ih_storen_scpf + integer :: ih_storentfrac_canopy_scpf + integer :: ih_storentfrac_understory_scpf integer :: ih_sapwn_scpf integer :: ih_repron_scpf - integer :: ih_nuptake_scpf + integer,public :: ih_nh4uptake_scpf + integer,public :: ih_no3uptake_scpf integer :: ih_nefflux_scpf - integer :: ih_nneedgrow_scpf - integer :: ih_nneedmax_scpf + integer :: ih_nneed_scpf integer :: ih_totvegc_scpf integer :: ih_leafc_scpf @@ -235,23 +249,15 @@ module FatesHistoryInterfaceMod integer :: ih_fnrtp_scpf integer :: ih_reprop_scpf integer :: ih_storep_scpf + integer :: ih_storeptfrac_canopy_scpf + integer :: ih_storeptfrac_understory_scpf integer :: ih_sapwp_scpf - integer :: ih_puptake_scpf + integer,public :: ih_puptake_scpf integer :: ih_pefflux_scpf - integer :: ih_pneedgrow_scpf - integer :: ih_pneedmax_scpf - - integer :: ih_daily_temp - integer :: ih_daily_rh - integer :: ih_daily_prec - - integer :: ih_bstore_si + integer :: ih_pneed_scpf + integer :: ih_bdead_si integer :: ih_balive_si - integer :: ih_bleaf_si - integer :: ih_bsapwood_si - integer :: ih_bfineroot_si - integer :: ih_btotal_si integer :: ih_agb_si integer :: ih_npp_si integer :: ih_gpp_si @@ -293,11 +299,14 @@ module FatesHistoryInterfaceMod integer :: ih_scorch_height_si_agepft ! Indices to (site) variables - + integer :: ih_tveg24_si + integer :: ih_tveg_si integer :: ih_nep_si + integer :: ih_hr_si integer :: ih_c_stomata_si integer :: ih_c_lblayer_si + integer :: ih_rad_error_si integer :: ih_fire_c_to_atm_si @@ -330,7 +339,7 @@ module FatesHistoryInterfaceMod integer :: ih_h2oveg_recruit_si integer :: ih_h2oveg_growturn_err_si integer :: ih_h2oveg_hydro_err_si - + integer :: ih_site_cstatus_si integer :: ih_site_dstatus_si integer :: ih_gdd_si @@ -347,10 +356,8 @@ module FatesHistoryInterfaceMod integer :: ih_fire_fdi_si integer :: ih_fire_intensity_area_product_si integer :: ih_spitfire_ros_si - integer :: ih_fire_ros_area_product_si integer :: ih_effect_wspeed_si integer :: ih_tfc_ros_si - integer :: ih_tfc_ros_area_product_si integer :: ih_fire_intensity_si integer :: ih_fire_area_si integer :: ih_fire_fuel_bulkd_si @@ -371,8 +378,8 @@ module FatesHistoryInterfaceMod integer :: ih_npp_agsw_si_scpf integer :: ih_npp_agdw_si_scpf integer :: ih_npp_stor_si_scpf - - + + integer :: ih_mortality_canopy_si_scpf integer :: ih_mortality_understory_si_scpf integer :: ih_nplant_canopy_si_scpf @@ -395,7 +402,7 @@ module FatesHistoryInterfaceMod integer :: ih_m4_si_scpf integer :: ih_m5_si_scpf integer :: ih_m6_si_scpf - integer :: ih_m7_si_scpf + integer :: ih_m7_si_scpf integer :: ih_m8_si_scpf integer :: ih_m9_si_scpf integer :: ih_m10_si_scpf @@ -412,7 +419,7 @@ module FatesHistoryInterfaceMod integer :: ih_ar_agsapm_si_scpf integer :: ih_ar_crootm_si_scpf integer :: ih_ar_frootm_si_scpf - + integer :: ih_c13disc_si_scpf ! indices to (site x scls [size class bins]) variables @@ -444,7 +451,7 @@ module FatesHistoryInterfaceMod integer :: ih_m4_si_scls integer :: ih_m5_si_scls integer :: ih_m6_si_scls - integer :: ih_m7_si_scls + integer :: ih_m7_si_scls integer :: ih_m8_si_scls integer :: ih_m9_si_scls integer :: ih_m10_si_scls @@ -507,6 +514,9 @@ module FatesHistoryInterfaceMod integer :: ih_canopycrownarea_si_pft integer :: ih_gpp_si_pft integer :: ih_npp_si_pft + integer :: ih_nocomp_pftpatchfraction_si_pft + integer :: ih_nocomp_pftnpatches_si_pft + integer :: ih_nocomp_pftburnedarea_si_pft ! indices to (site x patch-age) variables integer :: ih_area_si_age @@ -532,30 +542,30 @@ module FatesHistoryInterfaceMod integer :: ih_leaf_height_dist_si_height ! Indices to hydraulics variables - + integer :: ih_errh2o_scpf integer :: ih_tran_scpf ! integer :: ih_h2osoi_si_scagpft ! hijacking the scagpft dimension instead of creating a new shsl dimension integer :: ih_sapflow_scpf integer :: ih_sapflow_si - integer :: ih_iterh1_scpf - integer :: ih_iterh2_scpf - integer :: ih_supsub_scpf - integer :: ih_ath_scpf - integer :: ih_tth_scpf - integer :: ih_sth_scpf - integer :: ih_lth_scpf - integer :: ih_awp_scpf - integer :: ih_twp_scpf - integer :: ih_swp_scpf - integer :: ih_lwp_scpf - integer :: ih_aflc_scpf - integer :: ih_tflc_scpf - integer :: ih_sflc_scpf - integer :: ih_lflc_scpf + integer :: ih_iterh1_scpf + integer :: ih_iterh2_scpf + integer :: ih_supsub_scpf + integer :: ih_ath_scpf + integer :: ih_tth_scpf + integer :: ih_sth_scpf + integer :: ih_lth_scpf + integer :: ih_awp_scpf + integer :: ih_twp_scpf + integer :: ih_swp_scpf + integer :: ih_lwp_scpf + integer :: ih_aflc_scpf + integer :: ih_tflc_scpf + integer :: ih_sflc_scpf + integer :: ih_lflc_scpf integer :: ih_btran_scpf - + ! Hydro: Soil water states integer :: ih_rootwgt_soilvwc_si integer :: ih_rootwgt_soilvwcsat_si @@ -565,7 +575,7 @@ module FatesHistoryInterfaceMod integer :: ih_soilmatpot_sl integer :: ih_soilvwc_sl integer :: ih_soilvwcsat_sl - + ! Hydro: Root water Uptake rates integer :: ih_rootuptake_si integer :: ih_rootuptake_sl @@ -574,7 +584,7 @@ module FatesHistoryInterfaceMod integer :: ih_rootuptake50_scpf integer :: ih_rootuptake100_scpf - + ! indices to (site x fuel class) variables integer :: ih_litter_moisture_si_fuel integer :: ih_burnt_frac_litter_si_fuel @@ -633,38 +643,24 @@ module FatesHistoryInterfaceMod integer, parameter, public :: fates_history_num_dimensions = 50 integer, parameter, public :: fates_history_num_dim_kinds = 50 - ! This structure is allocated by thread, and must be calculated after the FATES - ! sites are allocated, and their mapping to the HLM is identified. This structure - ! is not combined with iovar_bounds, because that one is multi-instanced. This - ! structure is used more during the update phase, wherease _bounds is used - ! more for things like flushing - type, public :: iovar_map_type - integer, allocatable :: site_index(:) ! maps site indexes to the HIO site position - integer, allocatable :: patch1_index(:) ! maps site index to the HIO patch 1st position - end type iovar_map_type - - type, public :: fates_history_interface_type - + ! Instance of the list of history output varialbes 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(:) - !! THESE WERE EXPLICITLY PRIVATE WHEN TYPE WAS PUBLIC - integer, private :: patch_index_, column_index_, levgrnd_index_, levscpf_index_ + integer, private :: column_index_, levsoil_index_, levscpf_index_ integer, private :: levscls_index_, levpft_index_, levage_index_ integer, private :: levfuel_index_, levcwdsc_index_, levscag_index_ integer, private :: levcan_index_, levcnlf_index_, levcnlfpft_index_ @@ -674,14 +670,14 @@ module FatesHistoryInterfaceMod integer, private :: levelcwd_index_, levelage_index_ integer, private :: levcacls_index_, levcapf_index_ - + contains - + procedure :: Init procedure :: SetThreadBoundsEach procedure :: initialize_history_vars procedure :: assemble_history_output_types - + procedure :: update_history_dyn procedure :: update_history_hifrq procedure :: update_history_hydraulics @@ -689,9 +685,8 @@ module FatesHistoryInterfaceMod ! 'get' methods used by external callers to access private read only data procedure :: num_history_vars - procedure :: patch_index procedure :: column_index - procedure :: levgrnd_index + procedure :: levsoil_index procedure :: levscpf_index procedure :: levscls_index procedure :: levcapf_index @@ -718,11 +713,8 @@ module FatesHistoryInterfaceMod procedure, private :: set_history_var procedure, private :: init_dim_kinds_maps procedure, private :: set_dim_indices - procedure, private :: flush_hvars - - procedure, private :: set_patch_index procedure, private :: set_column_index - procedure, private :: set_levgrnd_index + procedure, private :: set_levsoil_index procedure, private :: set_levscpf_index procedure, private :: set_levcacls_index procedure, private :: set_levcapf_index @@ -739,25 +731,33 @@ module FatesHistoryInterfaceMod procedure, private :: set_levagepft_index procedure, private :: set_levheight_index procedure, private :: set_levagefuel_index - + procedure, private :: set_levelem_index procedure, private :: set_levelpft_index procedure, private :: set_levelcwd_index procedure, private :: set_levelage_index + procedure, public :: flush_hvars + procedure, public :: zero_site_hvars end type fates_history_interface_type - + character(len=*), parameter :: sourcefile = & __FILE__ + + ! The instance of the type + + type(fates_history_interface_type), public :: fates_hist + + contains ! ====================================================================== - + subroutine Init(this, num_threads, fates_bounds) - use FatesIODimensionsMod, only : patch, column, levgrnd, levscpf + use FatesIODimensionsMod, only : column, levsoil, levscpf use FatesIODimensionsMod, only : levscls, levpft, levage use FatesIODimensionsMod, only : levcacls, levcapf use FatesIODimensionsMod, only : levfuel, levcwdsc, levscag @@ -776,20 +776,15 @@ subroutine Init(this, num_threads, fates_bounds) integer :: dim_count = 0 - dim_count = dim_count + 1 - call this%set_patch_index(dim_count) - call this%dim_bounds(dim_count)%Init(patch, num_threads, & - fates_bounds%patch_begin, fates_bounds%patch_end) - dim_count = dim_count + 1 call this%set_column_index(dim_count) call this%dim_bounds(dim_count)%Init(column, num_threads, & fates_bounds%column_begin, fates_bounds%column_end) dim_count = dim_count + 1 - call this%set_levgrnd_index(dim_count) - call this%dim_bounds(dim_count)%Init(levgrnd, num_threads, & - fates_bounds%ground_begin, fates_bounds%ground_end) + call this%set_levsoil_index(dim_count) + call this%dim_bounds(dim_count)%Init(levsoil, num_threads, & + fates_bounds%soil_begin, fates_bounds%soil_end) dim_count = dim_count + 1 call this%set_levscpf_index(dim_count) @@ -850,17 +845,17 @@ subroutine Init(this, num_threads, fates_bounds) call this%set_levscag_index(dim_count) call this%dim_bounds(dim_count)%Init(levscag, num_threads, & fates_bounds%sizeage_class_begin, fates_bounds%sizeage_class_end) - + dim_count = dim_count + 1 call this%set_levscagpft_index(dim_count) call this%dim_bounds(dim_count)%Init(levscagpft, num_threads, & fates_bounds%sizeagepft_class_begin, fates_bounds%sizeagepft_class_end) - + dim_count = dim_count + 1 call this%set_levagepft_index(dim_count) call this%dim_bounds(dim_count)%Init(levagepft, num_threads, & fates_bounds%agepft_class_begin, fates_bounds%agepft_class_end) - + dim_count = dim_count + 1 call this%set_levheight_index(dim_count) call this%dim_bounds(dim_count)%Init(levheight, num_threads, & @@ -875,7 +870,7 @@ subroutine Init(this, num_threads, fates_bounds) call this%set_levelpft_index(dim_count) call this%dim_bounds(dim_count)%Init(levelpft, num_threads, & fates_bounds%elpft_begin, fates_bounds%elpft_end) - + dim_count = dim_count + 1 call this%set_levelcwd_index(dim_count) call this%dim_bounds(dim_count)%Init(levelcwd, num_threads, & @@ -885,18 +880,12 @@ subroutine Init(this, num_threads, fates_bounds) call this%set_levelage_index(dim_count) call this%dim_bounds(dim_count)%Init(levelage, num_threads, & fates_bounds%elage_begin, fates_bounds%elage_end) - + dim_count = dim_count + 1 call this%set_levagefuel_index(dim_count) call this%dim_bounds(dim_count)%Init(levagefuel, num_threads, & fates_bounds%agefuel_begin, fates_bounds%agefuel_end) - - - ! 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 ! ====================================================================== @@ -912,18 +901,14 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) type(fates_bounds_type), intent(in) :: thread_bounds integer :: index - - index = this%patch_index() - call this%dim_bounds(index)%SetThreadBounds(thread_index, & - thread_bounds%patch_begin, thread_bounds%patch_end) index = this%column_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%column_begin, thread_bounds%column_end) - index = this%levgrnd_index() + index = this%levsoil_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & - thread_bounds%ground_begin, thread_bounds%ground_end) + thread_bounds%soil_begin, thread_bounds%soil_end) index = this%levscpf_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & @@ -944,43 +929,43 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) index = this%levpft_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%pft_class_begin, thread_bounds%pft_class_end) - + index = this%levage_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%age_class_begin, thread_bounds%age_class_end) - + index = this%levfuel_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%fuel_begin, thread_bounds%fuel_end) - + index = this%levcwdsc_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%cwdsc_begin, thread_bounds%cwdsc_end) - + index = this%levcan_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%can_begin, thread_bounds%can_end) - + index = this%levcnlf_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%cnlf_begin, thread_bounds%cnlf_end) - + index = this%levcnlfpft_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%cnlfpft_begin, thread_bounds%cnlfpft_end) - + index = this%levscag_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%sizeage_class_begin, thread_bounds%sizeage_class_end) - + index = this%levscagpft_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%sizeagepft_class_begin, thread_bounds%sizeagepft_class_end) - + index = this%levagepft_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%agepft_class_begin, thread_bounds%agepft_class_end) - + index = this%levheight_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%height_begin, thread_bounds%height_end) @@ -992,7 +977,7 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) index = this%levelpft_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%elpft_begin, thread_bounds%elpft_end) - + index = this%levelcwd_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%elcwd_begin, thread_bounds%elcwd_end) @@ -1000,22 +985,21 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) index = this%levelage_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%elage_begin, thread_bounds%elage_end) - + index = this%levagefuel_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%agefuel_begin, thread_bounds%agefuel_end) - - - + + + end subroutine SetThreadBoundsEach - + ! =================================================================================== subroutine assemble_history_output_types(this) - use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 - use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_soil_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 use FatesIOVariableKindMod, only : site_coage_r8, site_coage_pft_r8 use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 @@ -1031,18 +1015,10 @@ subroutine assemble_history_output_types(this) call this%init_dim_kinds_maps() - call this%set_dim_indices(patch_r8, 1, this%patch_index()) - call this%set_dim_indices(site_r8, 1, this%column_index()) - call this%set_dim_indices(patch_ground_r8, 1, this%patch_index()) - call this%set_dim_indices(patch_ground_r8, 2, this%levgrnd_index()) - - call this%set_dim_indices(site_ground_r8, 1, this%column_index()) - call this%set_dim_indices(site_ground_r8, 2, this%levgrnd_index()) - - call this%set_dim_indices(patch_size_pft_r8, 1, this%patch_index()) - call this%set_dim_indices(patch_size_pft_r8, 2, this%levscpf_index()) + call this%set_dim_indices(site_soil_r8, 1, this%column_index()) + call this%set_dim_indices(site_soil_r8, 2, this%levsoil_index()) call this%set_dim_indices(site_size_pft_r8, 1, this%column_index()) call this%set_dim_indices(site_size_pft_r8, 2, this%levscpf_index()) @@ -1091,24 +1067,24 @@ subroutine assemble_history_output_types(this) call this%set_dim_indices(site_elem_r8, 1, this%column_index()) call this%set_dim_indices(site_elem_r8, 2, this%levelem_index()) - + call this%set_dim_indices(site_elpft_r8, 1, this%column_index()) call this%set_dim_indices(site_elpft_r8, 2, this%levelpft_index()) call this%set_dim_indices(site_elcwd_r8, 1, this%column_index()) call this%set_dim_indices(site_elcwd_r8, 2, this%levelcwd_index()) - + call this%set_dim_indices(site_elage_r8, 1, this%column_index()) call this%set_dim_indices(site_elage_r8, 2, this%levelage_index()) call this%set_dim_indices(site_agefuel_r8, 1, this%column_index()) call this%set_dim_indices(site_agefuel_r8, 2, this%levagefuel_index()) - + end subroutine assemble_history_output_types - + ! =================================================================================== - + subroutine set_dim_indices(this, dk_name, idim, dim_index) use FatesIOVariableKindMod , only : iotype_index @@ -1147,20 +1123,6 @@ subroutine set_dim_indices(this, dk_name, idim, dim_index) this%dim_bounds(dim_index)%lower_bound + 1 end subroutine set_dim_indices - - ! ======================================================================= - subroutine set_patch_index(this, index) - implicit none - 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) @@ -1177,18 +1139,18 @@ integer function column_index(this) end function column_index ! ======================================================================= - subroutine set_levgrnd_index(this, index) + subroutine set_levsoil_index(this, index) implicit none class(fates_history_interface_type), intent(inout) :: this integer, intent(in) :: index - this%levgrnd_index_ = index - end subroutine set_levgrnd_index + this%levsoil_index_ = index + end subroutine set_levsoil_index - integer function levgrnd_index(this) + integer function levsoil_index(this) implicit none class(fates_history_interface_type), intent(in) :: this - levgrnd_index = this%levgrnd_index_ - end function levgrnd_index + levsoil_index = this%levsoil_index_ + end function levsoil_index ! ======================================================================= subroutine set_levscpf_index(this, index) @@ -1416,7 +1378,7 @@ integer function levelem_index(this) end function levelem_index ! ====================================================================================== - + subroutine set_levelpft_index(this, index) implicit none class(fates_history_interface_type), intent(inout) :: this @@ -1468,17 +1430,56 @@ subroutine set_levagefuel_index(this, index) integer, intent(in) :: index this%levagefuel_index_ = index end subroutine set_levagefuel_index - + integer function levagefuel_index(this) implicit none class(fates_history_interface_type), intent(in) :: this levagefuel_index = this%levagefuel_index_ end function levagefuel_index - + + ! ====================================================================================== + + subroutine zero_site_hvars(this, currentSite, upfreq_in) + + ! This routine zero's a history diagnostic variable + ! but only zero's on fates sites + ! This should be called prior to filling the variable + ! and after they have been flushed to the ignore value + + class(fates_history_interface_type) :: this ! hvars_interface instance + integer, intent(in) :: upfreq_in ! + type(ed_site_type), intent(in), target :: currentSite ! site instance + + integer :: ivar ! history variable index + integer :: ndims ! number of dimensions + + do ivar=1,ubound(this%hvars,1) + if (this%hvars(ivar)%upfreq == upfreq_in) then ! Only flush variables with update on dynamics step + + ndims = this%dim_kinds(this%hvars(ivar)%dim_kinds_index)%ndims + + if(trim(this%dim_kinds(this%hvars(ivar)%dim_kinds_index)%name) == site_int)then + write(fates_log(),*)'add in zeroing provision for SI_INT' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(ndims==1) then + this%hvars(ivar)%r81d(currentSite%h_gid) = 0._r8 + elseif(ndims==2) then + this%hvars(ivar)%r82d(currentSite%h_gid,:) = 0._r8 + elseif(ndims==3) then + this%hvars(ivar)%r83d(currentSite%h_gid,:,:) = 0._r8 + end if + end if + end do + + return + end subroutine zero_site_hvars + ! ====================================================================================== subroutine flush_hvars(this,nc,upfreq_in) - + class(fates_history_interface_type) :: this integer,intent(in) :: nc integer,intent(in) :: upfreq_in @@ -1488,23 +1489,22 @@ subroutine flush_hvars(this,nc,upfreq_in) do ivar=1,ubound(this%hvars,1) if (this%hvars(ivar)%upfreq == upfreq_in) then ! Only flush variables with update on dynamics step call this%hvars(ivar)%flush(nc, this%dim_bounds, this%dim_kinds) - end if end do - + end subroutine flush_hvars - + ! ===================================================================================== - + subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype, & - hlms, flushval, upfreq, ivar, initialize, index) + hlms, upfreq, ivar, initialize, index) use FatesUtilsMod, only : check_hlm_list use FatesInterfaceTypesMod, only : hlm_name implicit none - + ! arguments class(fates_history_interface_type), intent(inout) :: this character(len=*), intent(in) :: vname @@ -1514,57 +1514,60 @@ subroutine set_history_var(this, vname, units, long, use_default, avgflag, vtype character(len=*), intent(in) :: avgflag character(len=*), intent(in) :: vtype character(len=*), intent(in) :: hlms - real(r8), intent(in) :: flushval ! IF THE TYPE IS AN INT WE WILL round with NINT integer, intent(in) :: upfreq - logical, intent(in) :: initialize - integer, intent(inout) :: ivar - integer, intent(inout) :: index ! This is the index for the variable of + logical, intent(in) :: initialize + integer, intent(inout) :: ivar + integer, intent(inout) :: index ! This is the index for the variable of ! interest that is associated with an ! explict name (for fast reference during update) ! A zero is passed back when the variable is ! not used - ! locals - integer :: ub1, lb1, ub2, lb2 ! Bounds for allocating the var - integer :: ityp + integer :: ub1, lb1, ub2, lb2 ! Bounds for allocating the var + integer :: ityp + real(r8) :: flushval + logical :: write_var - logical :: write_var + + ! Flushing to the ignore val coerces all FATES diagnostics to be + ! relevant only on FATES sites. This way we do not average zero's + ! at locations not on FATES columns + + flushval = hlm_hio_ignore_val write_var = check_hlm_list(trim(hlms), trim(hlm_name)) if( write_var ) then ivar = ivar+1 - index = ivar - + index = ivar + if (initialize) then - call this%hvars(ivar)%Init(vname, units, long, use_default, & - vtype, avgflag, flushval, upfreq, & - fates_history_num_dim_kinds, this%dim_kinds, this%dim_bounds) + call this%hvars(ivar)%Init(vname, units, long, use_default, & + vtype, avgflag, flushval, upfreq, fates_history_num_dim_kinds, & + this%dim_kinds, this%dim_bounds) end if else index = 0 end if - + return end subroutine set_history_var - + ! ==================================================================================== - + subroutine init_dim_kinds_maps(this) - + ! ---------------------------------------------------------------------------------- ! This subroutine simply initializes the structures that define the different ! array and type formats for different IO variables ! - ! PA_R8 : 1D patch scale 8-byte reals ! SI_R8 : 1D site scale 8-byte reals ! ! The allocation on the structures is not dynamic and should only add up to the ! number of entries listed here. ! ! ---------------------------------------------------------------------------------- - use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 - use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_soil_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 use FatesIOVariableKindMod, only : site_coage_r8, site_coage_pft_r8 use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 @@ -1575,32 +1578,20 @@ subroutine init_dim_kinds_maps(this) use FatesIOVariableKindMod, only : site_elcwd_r8, site_elage_r8 implicit none - + ! Arguments class(fates_history_interface_type), intent(inout) :: this - + integer :: index - ! 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 + ! site x soil 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) + call this%dim_kinds(index)%Init(site_soil_r8, 2) ! site x size-class/pft index = index + 1 @@ -1669,7 +1660,7 @@ subroutine init_dim_kinds_maps(this) ! site x element x pft index = index + 1 call this%dim_kinds(index)%Init(site_elpft_r8, 2) - + ! site x element x cwd index = index + 1 call this%dim_kinds(index)%Init(site_elcwd_r8, 2) @@ -1691,14 +1682,14 @@ end subroutine init_dim_kinds_maps ! ==================================================================================== - + subroutine update_history_dyn(this,nc,nsites,sites) - + ! --------------------------------------------------------------------------------- ! This is the call to update the history IO arrays that are expected to only change ! after Ecosystem Dynamics have been processed. ! --------------------------------------------------------------------------------- - + use EDtypesMod , only : nfsc use FatesLitterMod , only : ncwd @@ -1720,7 +1711,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) integer , intent(in) :: nc ! clump index integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) - + ! Locals type(litter_type), pointer :: litt_c ! Pointer to the carbon12 litter pool type(litter_type), pointer :: litt ! Generic pointer to any litter pool @@ -1731,10 +1722,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) integer :: s ! The local site index integer :: io_si ! The site index of the IO array integer :: ilyr ! Soil index for nlevsoil - integer :: ipa, ipa2 ! The local "I"ndex of "PA"tches - integer :: 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 :: ipa, ipa2 ! The local "I"ndex of "PA"tches integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread integer :: ivar ! index of IO variable object vector integer :: ft ! functional type index @@ -1751,18 +1739,18 @@ subroutine update_history_dyn(this,nc,nsites,sites) integer :: height_bin_max, height_bin_min ! which height bin a given cohort's canopy is in integer :: i_heightbin ! iterator for height bins integer :: el ! Loop index for elements - integer :: model_day_int ! integer model day from reference + integer :: model_day_int ! integer model day from reference integer :: ageclass_since_anthrodist ! what is the equivalent age class for ! time-since-anthropogenic-disturbance of secondary forest - + real(r8) :: store_max ! The target nutrient mass for storage element of interest [kg] real(r8) :: n_perm2 ! individuals per m2 for the whole column real(r8) :: dbh ! diameter ("at breast height") - real(r8) :: coage ! cohort age + real(r8) :: coage ! cohort age real(r8) :: npp_partition_error ! a check that the NPP partitions sum to carbon allocation real(r8) :: frac_canopy_in_bin ! fraction of a leaf's canopy that is within a given height bin real(r8) :: binbottom,bintop ! edges of height bins - + real(r8) :: gpp_cached ! variable used to cache gpp value in previous time step; for C13 discrimination ! The following are all carbon states, turnover and net allocation flux variables @@ -1787,20 +1775,21 @@ subroutine update_history_dyn(this,nc,nsites,sites) real(r8) :: struct_m_net_alloc real(r8) :: repro_m_net_alloc real(r8) :: area_frac + real(r8) :: crown_depth type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort real(r8), parameter :: tiny = 1.e-5_r8 ! some small number real(r8), parameter :: reallytalltrees = 1000. ! some large number (m) - + integer :: tmp associate( hio_npatches_si => this%hvars(ih_npatches_si)%r81d, & hio_ncohorts_si => this%hvars(ih_ncohorts_si)%r81d, & hio_trimming_si => this%hvars(ih_trimming_si)%r81d, & hio_area_plant_si => this%hvars(ih_area_plant_si)%r81d, & - hio_area_trees_si => this%hvars(ih_area_trees_si)%r81d, & + hio_area_trees_si => this%hvars(ih_area_trees_si)%r81d, & hio_canopy_spread_si => this%hvars(ih_canopy_spread_si)%r81d, & hio_biomass_si_pft => this%hvars(ih_biomass_si_pft)%r82d, & hio_leafbiomass_si_pft => this%hvars(ih_leafbiomass_si_pft)%r82d, & @@ -1816,9 +1805,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_fire_nignitions_si => this%hvars(ih_fire_nignitions_si)%r81d, & hio_fire_fdi_si => this%hvars(ih_fire_fdi_si)%r81d, & hio_spitfire_ros_si => this%hvars(ih_spitfire_ros_si)%r81d, & - hio_fire_ros_area_product_si=> this%hvars(ih_fire_ros_area_product_si)%r81d, & hio_tfc_ros_si => this%hvars(ih_tfc_ros_si)%r81d, & - hio_tfc_ros_area_product_si => this%hvars(ih_tfc_ros_area_product_si)%r81d, & hio_effect_wspeed_si => this%hvars(ih_effect_wspeed_si)%r81d, & hio_fire_intensity_si => this%hvars(ih_fire_intensity_si)%r81d, & hio_fire_intensity_area_product_si => this%hvars(ih_fire_intensity_area_product_si)%r81d, & @@ -1828,7 +1815,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_fire_fuel_sav_si => this%hvars(ih_fire_fuel_sav_si)%r81d, & hio_fire_fuel_mef_si => this%hvars(ih_fire_fuel_mef_si)%r81d, & hio_sum_fuel_si => this%hvars(ih_sum_fuel_si)%r81d, & - hio_fragmentation_scaler_sl => this%hvars(ih_fragmentation_scaler_sl)%r82d, & + hio_fragmentation_scaler_sl => this%hvars(ih_fragmentation_scaler_sl)%r82d, & hio_litter_in_si => this%hvars(ih_litter_in_si)%r81d, & hio_litter_out_si => this%hvars(ih_litter_out_si)%r81d, & hio_seed_bank_si => this%hvars(ih_seed_bank_si)%r81d, & @@ -1837,16 +1824,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_litter_out_elem => this%hvars(ih_litter_out_elem)%r82d, & hio_seed_bank_elem => this%hvars(ih_seed_bank_elem)%r82d, & hio_seeds_in_local_elem => this%hvars(ih_seeds_in_local_elem)%r82d, & - hio_seed_in_extern_elem => this%hvars(ih_seeds_in_extern_elem)%r82d, & + hio_seed_in_extern_elem => this%hvars(ih_seeds_in_extern_elem)%r82d, & hio_seed_decay_elem => this%hvars(ih_seed_decay_elem)%r82d, & hio_seed_germ_elem => this%hvars(ih_seed_germ_elem)%r82d, & - hio_bstore_si => this%hvars(ih_bstore_si)%r81d, & hio_bdead_si => this%hvars(ih_bdead_si)%r81d, & hio_balive_si => this%hvars(ih_balive_si)%r81d, & - hio_bleaf_si => this%hvars(ih_bleaf_si)%r81d, & - hio_bsapwood_si => this%hvars(ih_bsapwood_si)%r81d, & - hio_bfineroot_si => this%hvars(ih_bfineroot_si)%r81d, & - hio_btotal_si => this%hvars(ih_btotal_si)%r81d, & hio_agb_si => this%hvars(ih_agb_si)%r81d, & hio_canopy_biomass_si => this%hvars(ih_canopy_biomass_si)%r81d, & hio_understory_biomass_si => this%hvars(ih_understory_biomass_si)%r81d, & @@ -1898,19 +1880,19 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_agb_si_scpf => this%hvars(ih_agb_si_scpf)%r82d, & hio_nplant_si_scpf => this%hvars(ih_nplant_si_scpf)%r82d, & hio_nplant_si_capf => this%hvars(ih_nplant_si_capf)%r82d, & - + hio_m1_si_scpf => this%hvars(ih_m1_si_scpf)%r82d, & hio_m2_si_scpf => this%hvars(ih_m2_si_scpf)%r82d, & hio_m3_si_scpf => this%hvars(ih_m3_si_scpf)%r82d, & hio_m4_si_scpf => this%hvars(ih_m4_si_scpf)%r82d, & hio_m5_si_scpf => this%hvars(ih_m5_si_scpf)%r82d, & hio_m6_si_scpf => this%hvars(ih_m6_si_scpf)%r82d, & - hio_m7_si_scpf => this%hvars(ih_m7_si_scpf)%r82d, & + hio_m7_si_scpf => this%hvars(ih_m7_si_scpf)%r82d, & hio_m8_si_scpf => this%hvars(ih_m8_si_scpf)%r82d, & hio_m9_si_scpf => this%hvars(ih_m9_si_scpf)%r82d, & hio_m10_si_scpf => this%hvars(ih_m10_si_scpf)%r82d, & hio_m10_si_capf => this%hvars(ih_m10_si_capf)%r82d, & - + hio_crownfiremort_si_scpf => this%hvars(ih_crownfiremort_si_scpf)%r82d, & hio_cambialfiremort_si_scpf => this%hvars(ih_cambialfiremort_si_scpf)%r82d, & @@ -1928,14 +1910,14 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_m9_si_scls => this%hvars(ih_m9_si_scls)%r82d, & hio_m10_si_scls => this%hvars(ih_m10_si_scls)%r82d, & hio_m10_si_cacls => this%hvars(ih_m10_si_cacls)%r82d, & - - hio_c13disc_si_scpf => this%hvars(ih_c13disc_si_scpf)%r82d, & + + hio_c13disc_si_scpf => this%hvars(ih_c13disc_si_scpf)%r82d, & hio_cwd_elcwd => this%hvars(ih_cwd_elcwd)%r82d, & hio_cwd_ag_elem => this%hvars(ih_cwd_ag_elem)%r82d, & hio_cwd_bg_elem => this%hvars(ih_cwd_bg_elem)%r82d, & - hio_fines_ag_elem => this%hvars(ih_fines_bg_elem)%r82d, & - hio_fines_bg_elem => this%hvars(ih_fines_ag_elem)%r82d, & + hio_fines_ag_elem => this%hvars(ih_fines_ag_elem)%r82d, & + hio_fines_bg_elem => this%hvars(ih_fines_bg_elem)%r82d, & hio_ba_si_scls => this%hvars(ih_ba_si_scls)%r82d, & hio_agb_si_scls => this%hvars(ih_agb_si_scls)%r82d, & hio_biomass_si_scls => this%hvars(ih_biomass_si_scls)%r82d, & @@ -2037,1316 +2019,1452 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_cleafon_si => this%hvars(ih_cleafon_si)%r81d, & hio_dleafoff_si => this%hvars(ih_dleafoff_si)%r81d, & hio_dleafon_si => this%hvars(ih_dleafoff_si)%r81d, & + hio_tveg24 => this%hvars(ih_tveg24_si)%r81d, & hio_meanliqvol_si => this%hvars(ih_meanliqvol_si)%r81d, & hio_cbal_err_fates_si => this%hvars(ih_cbal_err_fates_si)%r81d, & hio_err_fates_si => this%hvars(ih_err_fates_si)%r82d ) - - ! --------------------------------------------------------------------------------- - ! 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 (hlm_use_ed_st3.eq.itrue) return - ! If we don't have dynamics turned on, we just abort these diagnostics - if (hlm_use_ed_st3.eq.itrue) return + model_day_int = nint(hlm_model_day) - model_day_int = nint(hlm_model_day) + ! --------------------------------------------------------------------------------- + ! Loop through the FATES scale hierarchy and fill the history IO arrays + ! --------------------------------------------------------------------------------- - ! --------------------------------------------------------------------------------- - ! Loop through the FATES scale hierarchy and fill the history IO arrays - ! --------------------------------------------------------------------------------- - - do s = 1,nsites - - io_si = this%iovar_map(nc)%site_index(s) - io_pa1 = this%iovar_map(nc)%patch1_index(s) - io_soipa = io_pa1-1 + siteloop: do s = 1,nsites - ! Total carbon model error [kgC/day -> mgC/day] - hio_cbal_err_fates_si(io_si) = & - sites(s)%mass_balance(element_pos(carbon12_element))%err_fates * mg_per_kg + io_si = sites(s)%h_gid - ! Total carbon lost to atmosphere from burning (kgC/site/day -> gC/m2/s) - hio_fire_c_to_atm_si(io_si) = & - sites(s)%mass_balance(element_pos(carbon12_element))%burn_flux_to_atm * & - g_per_kg * ha_per_m2 * days_per_sec + ! Total carbon model error [kgC/day -> kgC/s] + hio_cbal_err_fates_si(io_si) = & + sites(s)%mass_balance(element_pos(carbon12_element))%err_fates / sec_per_day - ! Total model error [kg/day -> mg/day] (all elements) - do el = 1, num_elements + ! Total carbon lost to atmosphere from burning (kgC/site/day -> kgC/m2/s) + hio_fire_c_to_atm_si(io_si) = & + sites(s)%mass_balance(element_pos(carbon12_element))%burn_flux_to_atm * & + ha_per_m2 * days_per_sec - hio_err_fates_si(io_si,el) = sites(s)%mass_balance(el)%err_fates * mg_per_kg + do el = 1, num_elements - ! Total element lost to atmosphere from burning (kg/site/day -> g/m2/s) - hio_burn_flux_elem(io_si,el) = & - sites(s)%mass_balance(el)%burn_flux_to_atm * & - g_per_kg * ha_per_m2 * days_per_sec + ! Total model error [kg/day -> kg/s] (all elements) + hio_err_fates_si(io_si,el) = sites(s)%mass_balance(el)%err_fates / sec_per_day - end do + ! Total element lost to atmosphere from burning (kg/site/day -> kg/m2/s) + hio_burn_flux_elem(io_si,el) = & + sites(s)%mass_balance(el)%burn_flux_to_atm * ha_per_m2 * & + days_per_sec - hio_canopy_spread_si(io_si) = sites(s)%spread + end do - ! Update the site statuses (stati?) - hio_site_cstatus_si(io_si) = real(sites(s)%cstatus,r8) - hio_site_dstatus_si(io_si) = real(sites(s)%dstatus,r8) + ! Canopy spread index (0-1) + hio_canopy_spread_si(io_si) = sites(s)%spread - !count number of days for leaves off - hio_site_nchilldays_si(io_si) = real(sites(s)%nchilldays,r8) - hio_site_ncolddays_si(io_si) = real(sites(s)%ncolddays,r8) + ! Site statuses (stati?) for cold deciduous and drought + ! deciduous + hio_site_cstatus_si(io_si) = real(sites(s)%cstatus,r8) + hio_site_dstatus_si(io_si) = real(sites(s)%dstatus,r8) - - hio_gdd_si(io_si) = sites(s)%grow_deg_days - hio_cleafoff_si(io_si) = real(model_day_int - sites(s)%cleafoffdate,r8) - hio_cleafon_si(io_si) = real(model_day_int - sites(s)%cleafondate,r8) - hio_dleafoff_si(io_si) = real(model_day_int - sites(s)%dleafoffdate,r8) - hio_dleafon_si(io_si) = real(model_day_int - sites(s)%dleafondate,r8) - - if(model_day_int>numWaterMem)then - hio_meanliqvol_si(io_si) = & - sum(sites(s)%water_memory(1:numWaterMem))/real(numWaterMem,r8) - end if + ! Number of chill days and cold days + hio_site_nchilldays_si(io_si) = real(sites(s)%nchilldays,r8) + hio_site_ncolddays_si(io_si) = real(sites(s)%ncolddays,r8) - ! track total wood product accumulation at the site level - hio_woodproduct_si(io_si) = sites(s)%resources_management%trunk_product_site & - * AREA_INV * g_per_kg - - ! site-level fire variables - hio_nesterov_fire_danger_si(io_si) = sites(s)%acc_NI - hio_fire_nignitions_si(io_si) = sites(s)%NF_successful - hio_fire_fdi_si(io_si) = sites(s)%FDI - - ! If hydraulics are turned on, track the error terms - ! associated with dynamics - - if(hlm_use_planthydro.eq.itrue)then - this%hvars(ih_h2oveg_dead_si)%r81d(io_si) = sites(s)%si_hydr%h2oveg_dead - this%hvars(ih_h2oveg_recruit_si)%r81d(io_si) = sites(s)%si_hydr%h2oveg_recruit - this%hvars(ih_h2oveg_growturn_err_si)%r81d(io_si) = sites(s)%si_hydr%h2oveg_growturn_err - end if + ! Growing degree-days + hio_gdd_si(io_si) = sites(s)%grow_deg_days - ! error in primary lands from patch fusion - hio_primaryland_fusion_error_si(io_si) = sites(s)%primary_land_patchfusion_error + ! Model days elapsed since leaf on/off for cold- and drought-deciduous + hio_cleafoff_si(io_si) = real(model_day_int - sites(s)%cleafoffdate,r8) + hio_cleafon_si(io_si) = real(model_day_int - sites(s)%cleafondate,r8) + hio_dleafoff_si(io_si) = real(model_day_int - sites(s)%dleafoffdate,r8) + hio_dleafon_si(io_si) = real(model_day_int - sites(s)%dleafondate,r8) - ! output site-level disturbance rates - hio_disturbance_rate_p2p_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_primary(1:N_DIST_TYPES)) - hio_disturbance_rate_p2s_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_secondary(1:N_DIST_TYPES)) - hio_disturbance_rate_s2s_si(io_si) = sum(sites(s)%disturbance_rates_secondary_to_secondary(1:N_DIST_TYPES)) + ! Mean liquid water content (m3/m3) used for drought phenology + if(model_day_int>numWaterMem)then + hio_meanliqvol_si(io_si) = & + sum(sites(s)%water_memory(1:numWaterMem))/real(numWaterMem,r8) + end if - hio_fire_disturbance_rate_si(io_si) = sites(s)%disturbance_rates_primary_to_primary(dtype_ifire) + & - sites(s)%disturbance_rates_primary_to_secondary(dtype_ifire) + & - sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifire) + ! track total wood product accumulation at the site level + hio_woodproduct_si(io_si) = sites(s)%resources_management%trunk_product_site & + * AREA_INV - hio_logging_disturbance_rate_si(io_si) = sites(s)%disturbance_rates_primary_to_primary(dtype_ilog) + & - sites(s)%disturbance_rates_primary_to_secondary(dtype_ilog) + & - sites(s)%disturbance_rates_secondary_to_secondary(dtype_ilog) + ! site-level fire variables: - hio_fall_disturbance_rate_si(io_si) = sites(s)%disturbance_rates_primary_to_primary(dtype_ifall) + & - sites(s)%disturbance_rates_primary_to_secondary(dtype_ifall) + & - sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifall) + ! Nesterov index (unitless) + hio_nesterov_fire_danger_si(io_si) = sites(s)%acc_NI - hio_potential_disturbance_rate_si(io_si) = sum(sites(s)%potential_disturbance_rates(1:N_DIST_TYPES)) + ! number of ignitions [#/km2/day -> #/m2/s] + hio_fire_nignitions_si(io_si) = sites(s)%NF_successful / m2_per_km2 / & + sec_per_day - hio_harvest_carbonflux_si(io_si) = sites(s)%mass_balance(element_pos(carbon12_element))%wood_product * AREA_INV + ! Fire danger index (FDI) (0-1) + hio_fire_fdi_si(io_si) = sites(s)%FDI - ipa = 0 - cpatch => sites(s)%oldest_patch - do while(associated(cpatch)) - - io_pa = io_pa1 + ipa + ! If hydraulics are turned on, track the error terms associated with + ! dynamics [kg/m2] + if(hlm_use_planthydro.eq.itrue)then + this%hvars(ih_h2oveg_dead_si)%r81d(io_si) = sites(s)%si_hydr%h2oveg_dead + this%hvars(ih_h2oveg_recruit_si)%r81d(io_si) = sites(s)%si_hydr%h2oveg_recruit + this%hvars(ih_h2oveg_growturn_err_si)%r81d(io_si) = sites(s)%si_hydr%h2oveg_growturn_err + end if - ! Increment the number of patches per site - hio_npatches_si(io_si) = hio_npatches_si(io_si) + 1._r8 + ! error in primary lands from patch fusion [m2 m-2 day-1] -> [m2 m-2 yr-1] + hio_primaryland_fusion_error_si(io_si) = sites(s)%primary_land_patchfusion_error * days_per_year - cpatch%age_class = get_age_class_index(cpatch%age) + ! output site-level disturbance rates [m2 m-2 day-1] -> [m2 m-2 yr-1] + hio_disturbance_rate_p2p_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_primary(1:N_DIST_TYPES)) * days_per_year + hio_disturbance_rate_p2s_si(io_si) = sum(sites(s)%disturbance_rates_primary_to_secondary(1:N_DIST_TYPES)) * days_per_year + hio_disturbance_rate_s2s_si(io_si) = sum(sites(s)%disturbance_rates_secondary_to_secondary(1:N_DIST_TYPES)) * days_per_year - ! 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 + hio_fire_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ifire) + & + sites(s)%disturbance_rates_primary_to_secondary(dtype_ifire) + & + sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifire)) * & + days_per_year - ! Increment some patch-age-resolved diagnostics - hio_lai_si_age(io_si,cpatch%age_class) = hio_lai_si_age(io_si,cpatch%age_class) & - + sum(cpatch%tlai_profile(:,:,:)) * cpatch%area + hio_logging_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ilog) + & + sites(s)%disturbance_rates_primary_to_secondary(dtype_ilog) + & + sites(s)%disturbance_rates_secondary_to_secondary(dtype_ilog)) * & + days_per_year - hio_ncl_si_age(io_si,cpatch%age_class) = hio_ncl_si_age(io_si,cpatch%age_class) & - + cpatch%ncl_p * cpatch%area - hio_npatches_si_age(io_si,cpatch%age_class) = hio_npatches_si_age(io_si,cpatch%age_class) + 1._r8 - if ( ED_val_comp_excln .lt. 0._r8 ) then ! only valid when "strict ppa" enabled - hio_zstar_si_age(io_si,cpatch%age_class) = hio_zstar_si_age(io_si,cpatch%age_class) & - + cpatch%zstar * cpatch%area * AREA_INV - endif + hio_fall_disturbance_rate_si(io_si) = (sites(s)%disturbance_rates_primary_to_primary(dtype_ifall) + & + sites(s)%disturbance_rates_primary_to_secondary(dtype_ifall) + & + sites(s)%disturbance_rates_secondary_to_secondary(dtype_ifall)) * & + days_per_year - ! some diagnostics on secondary forest area and its age distribution - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then - hio_fraction_secondary_forest_si(io_si) = hio_fraction_secondary_forest_si(io_si) + & - cpatch%area * AREA_INV - - ageclass_since_anthrodist = get_age_class_index(cpatch%age_since_anthro_disturbance) - - hio_agesince_anthrodist_si_age(io_si,ageclass_since_anthrodist) = & - hio_agesince_anthrodist_si_age(io_si,ageclass_since_anthrodist) & - + cpatch%area * AREA_INV + hio_potential_disturbance_rate_si(io_si) = sum(sites(s)%potential_disturbance_rates(1:N_DIST_TYPES)) * days_per_year - hio_secondaryforest_area_si_age(io_si,cpatch%age_class) = & - hio_secondaryforest_area_si_age(io_si,cpatch%age_class) & - + cpatch%area * AREA_INV - endif - - !!! patch-age-resolved fire variables - do i_pft = 1,numpft - ! for scorch height, weight the value by patch area within any given age calss (in the event that there is - ! more than one patch per age class. - iagepft = cpatch%age_class + (i_pft-1) * nlevage - hio_scorch_height_si_agepft(io_si,iagepft) = hio_scorch_height_si_agepft(io_si,iagepft) + & - cpatch%Scorch_ht(i_pft) * cpatch%area - end do + hio_harvest_carbonflux_si(io_si) = sites(s)%mass_balance(element_pos(carbon12_element))%wood_product * AREA_INV + + ! Loop through patches to sum up diagonistics + ipa = 0 + cpatch => sites(s)%oldest_patch + patchloop: do while(associated(cpatch)) - hio_area_burnt_si_age(io_si,cpatch%age_class) = hio_area_burnt_si_age(io_si,cpatch%age_class) + & - cpatch%frac_burnt * cpatch%area * AREA_INV + ! Increment the number of patches per site + hio_npatches_si(io_si) = hio_npatches_si(io_si) + 1._r8 - ! hio_fire_rate_of_spread_front_si_age(io_si, cpatch%age_class) = hio_fire_rate_of_spread_si_age(io_si, cpatch%age_class) + & - ! cpatch%ros_front * cpatch*frac_burnt * cpatch%area * AREA_INV + cpatch%age_class = get_age_class_index(cpatch%age) - hio_fire_intensity_si_age(io_si, cpatch%age_class) = hio_fire_intensity_si_age(io_si, cpatch%age_class) + & - cpatch%FI * cpatch%frac_burnt * cpatch%area * AREA_INV + ! 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 - hio_fire_sum_fuel_si_age(io_si, cpatch%age_class) = hio_fire_sum_fuel_si_age(io_si, cpatch%age_class) + & - cpatch%sum_fuel * g_per_kg * cpatch%area * AREA_INV - - if(associated(cpatch%tallest))then - hio_trimming_si(io_si) = hio_trimming_si(io_si) + cpatch%tallest%canopy_trim * cpatch%area * AREA_INV + ! 24hr veg temperature + hio_tveg24(io_si) = hio_tveg24(io_si) + & + (cpatch%tveg24%GetMean()- t_water_freeze_k_1atm)*cpatch%area*AREA_INV + + ! Increment some patch-age-resolved diagnostics + + hio_lai_si_age(io_si,cpatch%age_class) = hio_lai_si_age(io_si,cpatch%age_class) & + + sum(cpatch%tlai_profile(:,:,:)) * cpatch%area + hio_ncl_si_age(io_si,cpatch%age_class) = hio_ncl_si_age(io_si,cpatch%age_class) & + + cpatch%ncl_p * cpatch%area + hio_npatches_si_age(io_si,cpatch%age_class) = hio_npatches_si_age(io_si,cpatch%age_class) + 1._r8 + + if ( ED_val_comp_excln .lt. 0._r8 ) then ! only valid when "strict ppa" enabled + hio_zstar_si_age(io_si,cpatch%age_class) = hio_zstar_si_age(io_si,cpatch%age_class) & + + cpatch%zstar * cpatch%area * AREA_INV + endif + + ! some diagnostics on secondary forest area and its age distribution + if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + hio_fraction_secondary_forest_si(io_si) = hio_fraction_secondary_forest_si(io_si) + & + cpatch%area * AREA_INV + + ageclass_since_anthrodist = get_age_class_index(cpatch%age_since_anthro_disturbance) + + hio_agesince_anthrodist_si_age(io_si,ageclass_since_anthrodist) = & + hio_agesince_anthrodist_si_age(io_si,ageclass_since_anthrodist) & + + cpatch%area * AREA_INV + + hio_secondaryforest_area_si_age(io_si,cpatch%age_class) = & + hio_secondaryforest_area_si_age(io_si,cpatch%age_class) & + + cpatch%area * AREA_INV + endif + + ! patch-age-resolved fire variables + do i_pft = 1,numpft + ! for scorch height, weight the value by patch area within any + ! given age class - in the event that there is more than one + ! patch per age class. + iagepft = cpatch%age_class + (i_pft-1) * nlevage + hio_scorch_height_si_agepft(io_si,iagepft) = hio_scorch_height_si_agepft(io_si,iagepft) + & + cpatch%Scorch_ht(i_pft) * cpatch%area + + ! and also pft-labeled patch areas in the event that we are in nocomp mode + if ( hlm_use_nocomp .eq. itrue .and. cpatch%nocomp_pft_label .eq. i_pft) then + this%hvars(ih_nocomp_pftpatchfraction_si_pft)%r82d(io_si,i_pft) = & + this%hvars(ih_nocomp_pftpatchfraction_si_pft)%r82d(io_si,i_pft) + cpatch%area * AREA_INV + + this%hvars(ih_nocomp_pftnpatches_si_pft)%r82d(io_si,i_pft) = & + this%hvars(ih_nocomp_pftnpatches_si_pft)%r82d(io_si,i_pft) + 1._r8 + + this%hvars(ih_nocomp_pftburnedarea_si_pft)%r82d(io_si,i_pft) = & + this%hvars(ih_nocomp_pftburnedarea_si_pft)%r82d(io_si,i_pft) + & + cpatch%frac_burnt * cpatch%area * AREA_INV / sec_per_day endif - hio_area_plant_si(io_si) = hio_area_plant_si(io_si) + min(cpatch%total_canopy_area,cpatch%area) * AREA_INV + end do - hio_area_trees_si(io_si) = hio_area_trees_si(io_si) + min(cpatch%total_tree_area,cpatch%area) * AREA_INV - - ccohort => cpatch%shortest - do while(associated(ccohort)) - - ft = ccohort%pft - - call sizetype_class_index(ccohort%dbh, ccohort%pft, ccohort%size_class, ccohort%size_by_pft_class) - call coagetype_class_index(ccohort%coage, ccohort%pft, & - ccohort%coage_class, ccohort%coage_by_pft_class) - - ! Increment the number of cohorts per site - hio_ncohorts_si(io_si) = hio_ncohorts_si(io_si) + 1._r8 - - n_perm2 = ccohort%n * AREA_INV - - hio_canopy_area_si_age(io_si,cpatch%age_class) = hio_canopy_area_si_age(io_si,cpatch%age_class) & - + ccohort%c_area * AREA_INV - - ! calculate leaf height distribution, assuming leaf area is evenly distributed thru crown depth - height_bin_max = get_height_index(ccohort%hite) - height_bin_min = get_height_index(ccohort%hite * (1._r8 - EDPftvarcon_inst%crown(ft))) - do i_heightbin = height_bin_min, height_bin_max - binbottom = ED_val_history_height_bin_edges(i_heightbin) - if (i_heightbin .eq. nlevheight) then - bintop = reallytalltrees - else - bintop = ED_val_history_height_bin_edges(i_heightbin+1) - endif - ! what fraction of a cohort's crown is in this height bin? - frac_canopy_in_bin = (min(bintop,ccohort%hite) - & - max(binbottom,ccohort%hite * (1._r8 - EDPftvarcon_inst%crown(ft)))) / & - (ccohort%hite * EDPftvarcon_inst%crown(ft)) - ! - hio_leaf_height_dist_si_height(io_si,i_heightbin) = & - hio_leaf_height_dist_si_height(io_si,i_heightbin) + & - ccohort%c_area * AREA_INV * ccohort%treelai * frac_canopy_in_bin - - ! if ( ( ccohort%c_area * AREA_INV * ccohort%treelai * frac_canopy_in_bin) .lt. 0._r8) then - ! write(fates_log(),*) ' negative hio_leaf_height_dist_si_height:' - ! write(fates_log(),*) ' c_area, treelai, frac_canopy_in_bin:', ccohort%c_area, ccohort%treelai, frac_canopy_in_bin - ! endif - end do - - if (ccohort%canopy_layer .eq. 1) then - ! calculate the area of canopy that is within each height bin - hio_canopy_height_dist_si_height(io_si,height_bin_max) = & - hio_canopy_height_dist_si_height(io_si,height_bin_max) + ccohort%c_area * AREA_INV + ! fractional area burnt [frac/day] -> [frac/sec] + hio_area_burnt_si_age(io_si,cpatch%age_class) = hio_area_burnt_si_age(io_si,cpatch%age_class) + & + cpatch%frac_burnt * cpatch%area * AREA_INV / sec_per_day + + ! hio_fire_rate_of_spread_front_si_age(io_si, cpatch%age_class) = hio_fire_rate_of_spread_si_age(io_si, cpatch%age_class) + & + ! cpatch%ros_front * cpatch*frac_burnt * cpatch%area * AREA_INV + + ! Fire intensity weighted by burned fraction [kJ/m/s] -> [J/m/s] + hio_fire_intensity_si_age(io_si, cpatch%age_class) = hio_fire_intensity_si_age(io_si, cpatch%age_class) + & + cpatch%FI * cpatch%frac_burnt * cpatch%area * AREA_INV * J_per_kJ + + ! Fuel sum [kg/m2] + hio_fire_sum_fuel_si_age(io_si, cpatch%age_class) = hio_fire_sum_fuel_si_age(io_si, cpatch%age_class) + & + cpatch%sum_fuel * cpatch%area * AREA_INV + + ! Canopy trimming - degree to which canopy expansion is limited by leaf economics (0-1) + if(associated(cpatch%tallest))then + hio_trimming_si(io_si) = hio_trimming_si(io_si) + cpatch%tallest%canopy_trim * cpatch%area * AREA_INV + endif + + ! area occupied by plants and trees [m2/m2] + hio_area_plant_si(io_si) = hio_area_plant_si(io_si) + min(cpatch%total_canopy_area,cpatch%area) * AREA_INV + hio_area_trees_si(io_si) = hio_area_trees_si(io_si) + min(cpatch%total_tree_area,cpatch%area) * AREA_INV + + ! loop through cohorts on patch + ccohort => cpatch%shortest + cohortloop: do while(associated(ccohort)) + + ft = ccohort%pft + + ! get indices for size class x pft and cohort age x pft + ! size class is the fastest changing dimension + call sizetype_class_index(ccohort%dbh, ccohort%pft, & + ccohort%size_class, ccohort%size_by_pft_class) + ! cohort age is the fastest changing dimension + call coagetype_class_index(ccohort%coage, ccohort%pft, & + ccohort%coage_class, ccohort%coage_by_pft_class) + + ! Increment the number of cohorts per site + hio_ncohorts_si(io_si) = hio_ncohorts_si(io_si) + 1._r8 + + n_perm2 = ccohort%n * AREA_INV + + hio_canopy_area_si_age(io_si,cpatch%age_class) = hio_canopy_area_si_age(io_si,cpatch%age_class) & + + ccohort%c_area * AREA_INV + + ! calculate leaf height distribution, assuming leaf area is evenly distributed thru crown depth + call CrownDepth(ccohort%hite,ft,crown_depth) + height_bin_max = get_height_index(ccohort%hite) + height_bin_min = get_height_index(ccohort%hite - crown_depth) + do i_heightbin = height_bin_min, height_bin_max + binbottom = ED_val_history_height_bin_edges(i_heightbin) + if (i_heightbin .eq. nlevheight) then + bintop = reallytalltrees + else + bintop = ED_val_history_height_bin_edges(i_heightbin+1) endif + ! what fraction of a cohort's crown is in this height bin? + frac_canopy_in_bin = (min(bintop,ccohort%hite) - & + max(binbottom,ccohort%hite-crown_depth)) / & + (crown_depth) + + hio_leaf_height_dist_si_height(io_si,i_heightbin) = & + hio_leaf_height_dist_si_height(io_si,i_heightbin) + & + ccohort%c_area * AREA_INV * ccohort%treelai * frac_canopy_in_bin + + ! if ( ( ccohort%c_area * AREA_INV * ccohort%treelai * frac_canopy_in_bin) .lt. 0._r8) then + ! write(fates_log(),*) ' negative hio_leaf_height_dist_si_height:' + ! write(fates_log(),*) ' c_area, treelai, frac_canopy_in_bin:', ccohort%c_area, ccohort%treelai, frac_canopy_in_bin + ! endif + end do - ! Update biomass components - ! Mass pools [kgC] - do el = 1, num_elements - - sapw_m = ccohort%prt%GetState(sapw_organ, element_list(el)) - struct_m = ccohort%prt%GetState(struct_organ, element_list(el)) - leaf_m = ccohort%prt%GetState(leaf_organ, element_list(el)) - fnrt_m = ccohort%prt%GetState(fnrt_organ, element_list(el)) - store_m = ccohort%prt%GetState(store_organ, element_list(el)) - repro_m = ccohort%prt%GetState(repro_organ, element_list(el)) - - alive_m = leaf_m + fnrt_m + sapw_m - total_m = alive_m + store_m + struct_m - - ! Plant multi-element states and fluxes - ! Zero states, and set the fluxes - if( element_list(el).eq.carbon12_element )then - - this%hvars(ih_storec_si)%r81d(io_si) = & - this%hvars(ih_storec_si)%r81d(io_si) + ccohort%n * store_m - this%hvars(ih_leafc_si)%r81d(io_si) = & - this%hvars(ih_leafc_si)%r81d(io_si) + ccohort%n * leaf_m - this%hvars(ih_fnrtc_si)%r81d(io_si) = & - this%hvars(ih_fnrtc_si)%r81d(io_si) + ccohort%n * fnrt_m - this%hvars(ih_reproc_si)%r81d(io_si) = & - this%hvars(ih_reproc_si)%r81d(io_si)+ ccohort%n * repro_m - this%hvars(ih_sapwc_si)%r81d(io_si) = & - this%hvars(ih_sapwc_si)%r81d(io_si)+ ccohort%n * sapw_m - this%hvars(ih_totvegc_si)%r81d(io_si) = & - this%hvars(ih_totvegc_si)%r81d(io_si)+ ccohort%n * total_m - - hio_bleaf_si(io_si) = hio_bleaf_si(io_si) + n_perm2 * leaf_m * g_per_kg - hio_bstore_si(io_si) = hio_bstore_si(io_si) + n_perm2 * store_m * g_per_kg - hio_bdead_si(io_si) = hio_bdead_si(io_si) + n_perm2 * struct_m * g_per_kg - hio_balive_si(io_si) = hio_balive_si(io_si) + n_perm2 * alive_m * g_per_kg - - hio_bsapwood_si(io_si) = hio_bsapwood_si(io_si) + n_perm2 * sapw_m * g_per_kg - hio_bfineroot_si(io_si) = hio_bfineroot_si(io_si) + n_perm2 * fnrt_m * g_per_kg - hio_btotal_si(io_si) = hio_btotal_si(io_si) + n_perm2 * total_m * g_per_kg - - hio_agb_si(io_si) = hio_agb_si(io_si) + n_perm2 * g_per_kg * & - ( leaf_m + (sapw_m + struct_m + store_m) * prt_params%allom_agb_frac(ccohort%pft) ) - - - ! Update PFT partitioned biomass components - hio_leafbiomass_si_pft(io_si,ft) = hio_leafbiomass_si_pft(io_si,ft) + & - (ccohort%n * AREA_INV) * leaf_m * g_per_kg - - hio_storebiomass_si_pft(io_si,ft) = hio_storebiomass_si_pft(io_si,ft) + & - (ccohort%n * AREA_INV) * store_m * g_per_kg - - hio_nindivs_si_pft(io_si,ft) = hio_nindivs_si_pft(io_si,ft) + & - ccohort%n * AREA_INV - - hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & - (ccohort%n * AREA_INV) * total_m * g_per_kg - - ! update total biomass per age bin - hio_biomass_si_age(io_si,cpatch%age_class) = hio_biomass_si_age(io_si,cpatch%age_class) & - + total_m * ccohort%n * AREA_INV - - ! track the total biomass on all secondary lands - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then - hio_biomass_secondary_forest_si(io_si) = hio_biomass_secondary_forest_si(io_si) + & - total_m * ccohort%n * AREA_INV - endif - - elseif(element_list(el).eq.nitrogen_element)then - - this%hvars(ih_storen_si)%r81d(io_si) = & - this%hvars(ih_storen_si)%r81d(io_si) + ccohort%n * store_m - this%hvars(ih_leafn_si)%r81d(io_si) = & - this%hvars(ih_leafn_si)%r81d(io_si) + ccohort%n * leaf_m - this%hvars(ih_fnrtn_si)%r81d(io_si) = & - this%hvars(ih_fnrtn_si)%r81d(io_si) + ccohort%n * fnrt_m - this%hvars(ih_repron_si)%r81d(io_si) = & - this%hvars(ih_repron_si)%r81d(io_si) + ccohort%n * repro_m - this%hvars(ih_sapwn_si)%r81d(io_si) = & - this%hvars(ih_sapwn_si)%r81d(io_si) + ccohort%n * sapw_m - this%hvars(ih_totvegn_si)%r81d(io_si) = & - this%hvars(ih_totvegn_si)%r81d(io_si) + ccohort%n * total_m - - - elseif(element_list(el).eq.phosphorus_element) then - - this%hvars(ih_storep_si)%r81d(io_si) = & - this%hvars(ih_storep_si)%r81d(io_si) + ccohort%n * store_m - this%hvars(ih_leafp_si)%r81d(io_si) = & - this%hvars(ih_leafp_si)%r81d(io_si) + ccohort%n * leaf_m - this%hvars(ih_fnrtp_si)%r81d(io_si) = & - this%hvars(ih_fnrtp_si)%r81d(io_si) + ccohort%n * fnrt_m - this%hvars(ih_reprop_si)%r81d(io_si) = & - this%hvars(ih_reprop_si)%r81d(io_si) + ccohort%n * repro_m - this%hvars(ih_sapwp_si)%r81d(io_si) = & - this%hvars(ih_sapwp_si)%r81d(io_si) + ccohort%n * sapw_m - this%hvars(ih_totvegp_si)%r81d(io_si) = & - this%hvars(ih_totvegp_si)%r81d(io_si)+ ccohort%n * total_m + if (ccohort%canopy_layer .eq. 1) then + ! calculate the area of canopy that is within each height bin + hio_canopy_height_dist_si_height(io_si,height_bin_max) = & + hio_canopy_height_dist_si_height(io_si,height_bin_max) + ccohort%c_area * AREA_INV + endif - end if - - end do + ! Update biomass components + ! Mass pools [kg] + elloop: do el = 1, num_elements + + sapw_m = ccohort%prt%GetState(sapw_organ, element_list(el)) + struct_m = ccohort%prt%GetState(struct_organ, element_list(el)) + leaf_m = ccohort%prt%GetState(leaf_organ, element_list(el)) + fnrt_m = ccohort%prt%GetState(fnrt_organ, element_list(el)) + store_m = ccohort%prt%GetState(store_organ, element_list(el)) + repro_m = ccohort%prt%GetState(repro_organ, element_list(el)) + + alive_m = leaf_m + fnrt_m + sapw_m + total_m = alive_m + store_m + struct_m + + ! Plant multi-element states and fluxes + ! Zero states, and set the fluxes + if( element_list(el).eq.carbon12_element )then + + ! mass in different tissues [kg/ha] -> [kg/m2] + this%hvars(ih_storec_si)%r81d(io_si) = & + this%hvars(ih_storec_si)%r81d(io_si) + ccohort%n * & + store_m / m2_per_ha + this%hvars(ih_leafc_si)%r81d(io_si) = & + this%hvars(ih_leafc_si)%r81d(io_si) + ccohort%n * & + leaf_m / m2_per_ha + this%hvars(ih_fnrtc_si)%r81d(io_si) = & + this%hvars(ih_fnrtc_si)%r81d(io_si) + ccohort%n * & + fnrt_m / m2_per_ha + this%hvars(ih_reproc_si)%r81d(io_si) = & + this%hvars(ih_reproc_si)%r81d(io_si)+ ccohort%n * & + repro_m / m2_per_ha + this%hvars(ih_sapwc_si)%r81d(io_si) = & + this%hvars(ih_sapwc_si)%r81d(io_si) + ccohort%n * & + sapw_m / m2_per_ha + this%hvars(ih_totvegc_si)%r81d(io_si) = & + this%hvars(ih_totvegc_si)%r81d(io_si)+ ccohort%n * & + total_m / m2_per_ha + + hio_bdead_si(io_si) = hio_bdead_si(io_si) + n_perm2 * struct_m + hio_balive_si(io_si) = hio_balive_si(io_si) + n_perm2 * alive_m + + hio_agb_si(io_si) = hio_agb_si(io_si) + n_perm2 * & + ( leaf_m + (sapw_m + struct_m + store_m) * prt_params%allom_agb_frac(ccohort%pft) ) + + + ! Update PFT partitioned biomass components + hio_leafbiomass_si_pft(io_si,ft) = hio_leafbiomass_si_pft(io_si,ft) + & + (ccohort%n * AREA_INV) * leaf_m + + hio_storebiomass_si_pft(io_si,ft) = hio_storebiomass_si_pft(io_si,ft) + & + (ccohort%n * AREA_INV) * store_m + + hio_nindivs_si_pft(io_si,ft) = hio_nindivs_si_pft(io_si,ft) + & + ccohort%n * AREA_INV + + hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & + (ccohort%n * AREA_INV) * total_m + + ! update total biomass per age bin + hio_biomass_si_age(io_si,cpatch%age_class) = hio_biomass_si_age(io_si,cpatch%age_class) & + + total_m * ccohort%n * AREA_INV + + ! track the total biomass on all secondary lands + if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + hio_biomass_secondary_forest_si(io_si) = hio_biomass_secondary_forest_si(io_si) + & + total_m * ccohort%n * AREA_INV + endif + + elseif(element_list(el).eq.nitrogen_element)then + + store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) + + this%hvars(ih_storen_si)%r81d(io_si) = & + this%hvars(ih_storen_si)%r81d(io_si) + ccohort%n * & + store_m / m2_per_ha + this%hvars(ih_storentfrac_si)%r81d(io_si) = & + this%hvars(ih_storentfrac_si)%r81d(io_si) + ccohort%n * & + store_max / m2_per_ha + this%hvars(ih_leafn_si)%r81d(io_si) = & + this%hvars(ih_leafn_si)%r81d(io_si) + ccohort%n * & + leaf_m / m2_per_ha + this%hvars(ih_fnrtn_si)%r81d(io_si) = & + this%hvars(ih_fnrtn_si)%r81d(io_si) + ccohort%n * & + fnrt_m / m2_per_ha + this%hvars(ih_repron_si)%r81d(io_si) = & + this%hvars(ih_repron_si)%r81d(io_si) + ccohort%n * & + repro_m / m2_per_ha + this%hvars(ih_sapwn_si)%r81d(io_si) = & + this%hvars(ih_sapwn_si)%r81d(io_si) + ccohort%n * & + sapw_m / m2_per_ha + this%hvars(ih_totvegn_si)%r81d(io_si) = & + this%hvars(ih_totvegn_si)%r81d(io_si) + ccohort%n * & + total_m / m2_per_ha + + elseif(element_list(el).eq.phosphorus_element) then + + store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) + + this%hvars(ih_storep_si)%r81d(io_si) = & + this%hvars(ih_storep_si)%r81d(io_si) + ccohort%n * & + store_m / m2_per_ha + this%hvars(ih_storeptfrac_si)%r81d(io_si) = & + this%hvars(ih_storeptfrac_si)%r81d(io_si) + ccohort%n * & + store_max / m2_per_ha + this%hvars(ih_leafp_si)%r81d(io_si) = & + this%hvars(ih_leafp_si)%r81d(io_si) + ccohort%n * & + leaf_m / m2_per_ha + this%hvars(ih_fnrtp_si)%r81d(io_si) = & + this%hvars(ih_fnrtp_si)%r81d(io_si) + ccohort%n * & + fnrt_m / m2_per_ha + this%hvars(ih_reprop_si)%r81d(io_si) = & + this%hvars(ih_reprop_si)%r81d(io_si) + ccohort%n * & + repro_m / m2_per_ha + this%hvars(ih_sapwp_si)%r81d(io_si) = & + this%hvars(ih_sapwp_si)%r81d(io_si) + ccohort%n * & + sapw_m / m2_per_ha + this%hvars(ih_totvegp_si)%r81d(io_si) = & + this%hvars(ih_totvegp_si)%r81d(io_si)+ ccohort%n * & + total_m / m2_per_ha + end if + end do elloop + + ! Update PFT crown area + hio_crownarea_si_pft(io_si, ft) = hio_crownarea_si_pft(io_si, ft) + & + ccohort%c_area * AREA_INV + if (ccohort%canopy_layer .eq. 1) then + ! Update PFT canopy crown area + hio_canopycrownarea_si_pft(io_si, ft) = hio_canopycrownarea_si_pft(io_si, ft) + & + ccohort%c_area * AREA_INV + end if - ! Update PFT crown area - hio_crownarea_si_pft(io_si, ft) = hio_crownarea_si_pft(io_si, ft) + & - ccohort%c_area * AREA_INV + ! update pft-resolved NPP and GPP fluxes + hio_gpp_si_pft(io_si, ft) = hio_gpp_si_pft(io_si, ft) + & + ccohort%gpp_acc_hold * n_perm2 / days_per_year / sec_per_day + + hio_npp_si_pft(io_si, ft) = hio_npp_si_pft(io_si, ft) + & + ccohort%npp_acc_hold * n_perm2 / days_per_year / sec_per_day + + ! Site by Size-Class x PFT (SCPF) + ! ------------------------------------------------------------------------ + + dbh = ccohort%dbh !-0.5*(1./365.25)*ccohort%ddbhdt + + ! Flux Variables (cohorts must had experienced a day before any of these values + ! have any meaning, otherwise they are just inialization values + notnew: if( .not.(ccohort%isnew) ) then + + ! Turnover pools [kgC/day] * [day/yr] = [kgC/yr] + sapw_m_turnover = ccohort%prt%GetTurnover(sapw_organ, carbon12_element) * days_per_year + store_m_turnover = ccohort%prt%GetTurnover(store_organ, carbon12_element) * days_per_year + leaf_m_turnover = ccohort%prt%GetTurnover(leaf_organ, carbon12_element) * days_per_year + fnrt_m_turnover = ccohort%prt%GetTurnover(fnrt_organ, carbon12_element) * days_per_year + struct_m_turnover = ccohort%prt%GetTurnover(struct_organ, carbon12_element) * days_per_year + + ! Net change from allocation and transport [kgC/day] * [day/yr] = [kgC/yr] + sapw_m_net_alloc = ccohort%prt%GetNetAlloc(sapw_organ, carbon12_element) * days_per_year + store_m_net_alloc = ccohort%prt%GetNetAlloc(store_organ, carbon12_element) * days_per_year + leaf_m_net_alloc = ccohort%prt%GetNetAlloc(leaf_organ, carbon12_element) * days_per_year + fnrt_m_net_alloc = ccohort%prt%GetNetAlloc(fnrt_organ, carbon12_element) * days_per_year + struct_m_net_alloc = ccohort%prt%GetNetAlloc(struct_organ, carbon12_element) * days_per_year + repro_m_net_alloc = ccohort%prt%GetNetAlloc(repro_organ, carbon12_element) * days_per_year + + ! ecosystem-level, organ-partitioned NPP/allocation fluxes + ! [kgC/yr] -> [kgC/sec] + hio_npp_leaf_si(io_si) = hio_npp_leaf_si(io_si) + & + leaf_m_net_alloc * n_perm2 / days_per_year / sec_per_day + hio_npp_seed_si(io_si) = hio_npp_seed_si(io_si) + & + repro_m_net_alloc * n_perm2 / days_per_year / sec_per_day + hio_npp_stem_si(io_si) = hio_npp_stem_si(io_si) + & + (sapw_m_net_alloc + struct_m_net_alloc) * n_perm2 * & + (prt_params%allom_agb_frac(ccohort%pft)) / & + days_per_year / sec_per_day + hio_npp_froot_si(io_si) = hio_npp_froot_si(io_si) + & + fnrt_m_net_alloc * n_perm2 / days_per_year / sec_per_day + hio_npp_croot_si(io_si) = hio_npp_croot_si(io_si) + & + (sapw_m_net_alloc + struct_m_net_alloc) * n_perm2 * & + (1._r8-prt_params%allom_agb_frac(ccohort%pft)) / & + days_per_year / sec_per_day + hio_npp_stor_si(io_si) = hio_npp_stor_si(io_si) + & + store_m_net_alloc * n_perm2 / days_per_year / sec_per_day + + associate( scpf => ccohort%size_by_pft_class, & + scls => ccohort%size_class, & + cacls => ccohort%coage_class, & + capf => ccohort%coage_by_pft_class) + + gpp_cached = (hio_gpp_si_scpf(io_si,scpf)) * & + days_per_year * sec_per_day + + ! [kgC/m2/s] + hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + & + n_perm2*ccohort%gpp_acc_hold / days_per_year / sec_per_day + hio_npp_totl_si_scpf(io_si,scpf) = hio_npp_totl_si_scpf(io_si,scpf) + & + ccohort%npp_acc_hold * n_perm2 / days_per_year / sec_per_day + + hio_npp_leaf_si_scpf(io_si,scpf) = hio_npp_leaf_si_scpf(io_si,scpf) + & + leaf_m_net_alloc*n_perm2 / days_per_year / sec_per_day + hio_npp_fnrt_si_scpf(io_si,scpf) = hio_npp_fnrt_si_scpf(io_si,scpf) + & + fnrt_m_net_alloc*n_perm2 / days_per_year / sec_per_day + hio_npp_bgsw_si_scpf(io_si,scpf) = hio_npp_bgsw_si_scpf(io_si,scpf) + & + sapw_m_net_alloc*n_perm2*(1._r8-prt_params%allom_agb_frac(ccohort%pft)) / & + days_per_year / sec_per_day + hio_npp_agsw_si_scpf(io_si,scpf) = hio_npp_agsw_si_scpf(io_si,scpf) + & + sapw_m_net_alloc*n_perm2*prt_params%allom_agb_frac(ccohort%pft) / & + days_per_year / sec_per_day + hio_npp_bgdw_si_scpf(io_si,scpf) = hio_npp_bgdw_si_scpf(io_si,scpf) + & + struct_m_net_alloc*n_perm2*(1._r8-prt_params%allom_agb_frac(ccohort%pft)) / & + days_per_year / sec_per_day + hio_npp_agdw_si_scpf(io_si,scpf) = hio_npp_agdw_si_scpf(io_si,scpf) + & + struct_m_net_alloc*n_perm2*prt_params%allom_agb_frac(ccohort%pft) / & + days_per_year / sec_per_day + hio_npp_seed_si_scpf(io_si,scpf) = hio_npp_seed_si_scpf(io_si,scpf) + & + repro_m_net_alloc*n_perm2 / days_per_year / sec_per_day + hio_npp_stor_si_scpf(io_si,scpf) = hio_npp_stor_si_scpf(io_si,scpf) + & + store_m_net_alloc*n_perm2 / days_per_year / sec_per_day + + ! Woody State Variables (basal area growth increment) + if ( int(prt_params%woody(ft)) == itrue) then + + ! basal area [m2/m2] + hio_ba_si_scpf(io_si,scpf) = hio_ba_si_scpf(io_si,scpf) + & + 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)*ccohort%n / m2_per_ha + + ! also by size class only + hio_ba_si_scls(io_si,scls) = hio_ba_si_scls(io_si,scls) + & + 0.25_r8*3.14159_r8*((dbh/100.0_r8)**2.0_r8)* & + ccohort%n / m2_per_ha + + ! growth increment + hio_ddbh_si_scpf(io_si,scpf) = hio_ddbh_si_scpf(io_si,scpf) + & + ccohort%ddbhdt*ccohort%n / m2_per_ha * m_per_cm - if (ccohort%canopy_layer .eq. 1) then - ! Update PFT canopy crown area - hio_canopycrownarea_si_pft(io_si, ft) = hio_canopycrownarea_si_pft(io_si, ft) + & - ccohort%c_area * AREA_INV end if - ! update pft-resolved NPP and GPP fluxes - hio_gpp_si_pft(io_si, ft) = hio_gpp_si_pft(io_si, ft) + & - ccohort%gpp_acc_hold * n_perm2 + ! mortality sums [#/m2] + hio_m1_si_scpf(io_si,scpf) = hio_m1_si_scpf(io_si,scpf) + & + ccohort%bmort*ccohort%n / m2_per_ha + hio_m2_si_scpf(io_si,scpf) = hio_m2_si_scpf(io_si,scpf) + & + ccohort%hmort*ccohort%n / m2_per_ha + hio_m3_si_scpf(io_si,scpf) = hio_m3_si_scpf(io_si,scpf) + & + ccohort%cmort*ccohort%n / m2_per_ha + + hio_m7_si_scpf(io_si,scpf) = hio_m7_si_scpf(io_si,scpf) + & + (ccohort%lmort_direct + ccohort%lmort_collateral + & + ccohort%lmort_infra) * ccohort%n / m2_per_ha + + hio_m8_si_scpf(io_si,scpf) = hio_m8_si_scpf(io_si,scpf) + & + ccohort%frmort*ccohort%n / m2_per_ha + hio_m9_si_scpf(io_si,scpf) = hio_m9_si_scpf(io_si,scpf) + & + ccohort%smort*ccohort%n / m2_per_ha + + if (hlm_use_cohort_age_tracking .eq.itrue) then + hio_m10_si_scpf(io_si,scpf) = hio_m10_si_scpf(io_si,scpf) + & + ccohort%asmort*ccohort%n / m2_per_ha + hio_m10_si_capf(io_si,capf) = hio_m10_si_capf(io_si,capf) + & + ccohort%asmort*ccohort%n / m2_per_ha + hio_m10_si_scls(io_si,scls) = hio_m10_si_scls(io_si,scls) + & + ccohort%asmort*ccohort%n / m2_per_ha + hio_m10_si_cacls(io_si,cacls) = hio_m10_si_cacls(io_si,cacls)+ & + ccohort%asmort*ccohort%n / m2_per_ha + end if - hio_npp_si_pft(io_si, ft) = hio_npp_si_pft(io_si, ft) + & - ccohort%npp_acc_hold * n_perm2 - + hio_m1_si_scls(io_si,scls) = hio_m1_si_scls(io_si,scls) + ccohort%bmort*ccohort%n / m2_per_ha + hio_m2_si_scls(io_si,scls) = hio_m2_si_scls(io_si,scls) + ccohort%hmort*ccohort%n / m2_per_ha + hio_m3_si_scls(io_si,scls) = hio_m3_si_scls(io_si,scls) + ccohort%cmort*ccohort%n / m2_per_ha + hio_m7_si_scls(io_si,scls) = hio_m7_si_scls(io_si,scls) + & + (ccohort%lmort_direct+ccohort%lmort_collateral+ccohort%lmort_infra) * ccohort%n / m2_per_ha + hio_m8_si_scls(io_si,scls) = hio_m8_si_scls(io_si,scls) + & + ccohort%frmort*ccohort%n / m2_per_ha + hio_m9_si_scls(io_si,scls) = hio_m9_si_scls(io_si,scls) + ccohort%smort*ccohort%n / m2_per_ha + + !C13 discrimination + if(gpp_cached + ccohort%gpp_acc_hold > 0.0_r8)then + hio_c13disc_si_scpf(io_si,scpf) = ((hio_c13disc_si_scpf(io_si,scpf) * gpp_cached) + & + (ccohort%c13disc_acc * ccohort%gpp_acc_hold)) / (gpp_cached + ccohort%gpp_acc_hold) + else + hio_c13disc_si_scpf(io_si,scpf) = 0.0_r8 + endif - ! Site by Size-Class x PFT (SCPF) - ! ------------------------------------------------------------------------ - - dbh = ccohort%dbh !-0.5*(1./365.25)*ccohort%ddbhdt - - ! Flux Variables (cohorts must had experienced a day before any of these values - ! have any meaning, otherwise they are just inialization values - if( .not.(ccohort%isnew) ) then - - ! Turnover pools [kgC/day] * [day/yr] = [kgC/yr] - sapw_m_turnover = ccohort%prt%GetTurnover(sapw_organ, carbon12_element) * days_per_year - store_m_turnover = ccohort%prt%GetTurnover(store_organ, carbon12_element) * days_per_year - leaf_m_turnover = ccohort%prt%GetTurnover(leaf_organ, carbon12_element) * days_per_year - fnrt_m_turnover = ccohort%prt%GetTurnover(fnrt_organ, carbon12_element) * days_per_year - struct_m_turnover = ccohort%prt%GetTurnover(struct_organ, carbon12_element) * days_per_year - - ! Net change from allocation and transport [kgC/day] * [day/yr] = [kgC/yr] - sapw_m_net_alloc = ccohort%prt%GetNetAlloc(sapw_organ, carbon12_element) * days_per_year - store_m_net_alloc = ccohort%prt%GetNetAlloc(store_organ, carbon12_element) * days_per_year - leaf_m_net_alloc = ccohort%prt%GetNetAlloc(leaf_organ, carbon12_element) * days_per_year - fnrt_m_net_alloc = ccohort%prt%GetNetAlloc(fnrt_organ, carbon12_element) * days_per_year - struct_m_net_alloc = ccohort%prt%GetNetAlloc(struct_organ, carbon12_element) * days_per_year - repro_m_net_alloc = ccohort%prt%GetNetAlloc(repro_organ, carbon12_element) * days_per_year - - ! ecosystem-level, organ-partitioned NPP/allocation fluxes - hio_npp_leaf_si(io_si) = hio_npp_leaf_si(io_si) + leaf_m_net_alloc * n_perm2 - hio_npp_seed_si(io_si) = hio_npp_seed_si(io_si) + repro_m_net_alloc * n_perm2 - hio_npp_stem_si(io_si) = hio_npp_stem_si(io_si) + (sapw_m_net_alloc + struct_m_net_alloc) * n_perm2 * & - (prt_params%allom_agb_frac(ccohort%pft)) - hio_npp_froot_si(io_si) = hio_npp_froot_si(io_si) + fnrt_m_net_alloc * n_perm2 - hio_npp_croot_si(io_si) = hio_npp_croot_si(io_si) + (sapw_m_net_alloc + struct_m_net_alloc) * n_perm2 * & - (1._r8-prt_params%allom_agb_frac(ccohort%pft)) - hio_npp_stor_si(io_si) = hio_npp_stor_si(io_si) + store_m_net_alloc * n_perm2 - - associate( scpf => ccohort%size_by_pft_class, & + ! number density [/m2] + hio_nplant_si_scpf(io_si,scpf) = hio_nplant_si_scpf(io_si,scpf) + ccohort%n / m2_per_ha - scls => ccohort%size_class, & - cacls => ccohort%coage_class, & - capf => ccohort%coage_by_pft_class) - - - gpp_cached = hio_gpp_si_scpf(io_si,scpf) - - hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + & - n_perm2*ccohort%gpp_acc_hold ! [kgC/m2/yr] - hio_npp_totl_si_scpf(io_si,scpf) = hio_npp_totl_si_scpf(io_si,scpf) + & - ccohort%npp_acc_hold *n_perm2 - - - hio_npp_leaf_si_scpf(io_si,scpf) = hio_npp_leaf_si_scpf(io_si,scpf) + & - leaf_m_net_alloc*n_perm2 - hio_npp_fnrt_si_scpf(io_si,scpf) = hio_npp_fnrt_si_scpf(io_si,scpf) + & - fnrt_m_net_alloc*n_perm2 - hio_npp_bgsw_si_scpf(io_si,scpf) = hio_npp_bgsw_si_scpf(io_si,scpf) + & - sapw_m_net_alloc*n_perm2* & - (1._r8-prt_params%allom_agb_frac(ccohort%pft)) - hio_npp_agsw_si_scpf(io_si,scpf) = hio_npp_agsw_si_scpf(io_si,scpf) + & - sapw_m_net_alloc*n_perm2* & - prt_params%allom_agb_frac(ccohort%pft) - hio_npp_bgdw_si_scpf(io_si,scpf) = hio_npp_bgdw_si_scpf(io_si,scpf) + & - struct_m_net_alloc*n_perm2* & - (1._r8-prt_params%allom_agb_frac(ccohort%pft)) - hio_npp_agdw_si_scpf(io_si,scpf) = hio_npp_agdw_si_scpf(io_si,scpf) + & - struct_m_net_alloc*n_perm2* & - prt_params%allom_agb_frac(ccohort%pft) - hio_npp_seed_si_scpf(io_si,scpf) = hio_npp_seed_si_scpf(io_si,scpf) + & - repro_m_net_alloc*n_perm2 - hio_npp_stor_si_scpf(io_si,scpf) = hio_npp_stor_si_scpf(io_si,scpf) + & - store_m_net_alloc*n_perm2 - - ! Woody State Variables (basal area growth increment) - if ( int(prt_params%woody(ft)) == itrue) then - - ! 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 - - ! growth increment - hio_ddbh_si_scpf(io_si,scpf) = hio_ddbh_si_scpf(io_si,scpf) + & - ccohort%ddbhdt*ccohort%n - - end if - - hio_m1_si_scpf(io_si,scpf) = hio_m1_si_scpf(io_si,scpf) + ccohort%bmort*ccohort%n - hio_m2_si_scpf(io_si,scpf) = hio_m2_si_scpf(io_si,scpf) + ccohort%hmort*ccohort%n - hio_m3_si_scpf(io_si,scpf) = hio_m3_si_scpf(io_si,scpf) + ccohort%cmort*ccohort%n - hio_m7_si_scpf(io_si,scpf) = hio_m7_si_scpf(io_si,scpf) + & - (ccohort%lmort_direct+ccohort%lmort_collateral+ccohort%lmort_infra) * ccohort%n - hio_m8_si_scpf(io_si,scpf) = hio_m8_si_scpf(io_si,scpf) + ccohort%frmort*ccohort%n - hio_m9_si_scpf(io_si,scpf) = hio_m9_si_scpf(io_si,scpf) + ccohort%smort*ccohort%n - - if (hlm_use_cohort_age_tracking .eq.itrue) then - hio_m10_si_scpf(io_si,scpf) = hio_m10_si_scpf(io_si,scpf) + ccohort%asmort*ccohort%n - hio_m10_si_capf(io_si,capf) = hio_m10_si_capf(io_si,capf) + ccohort%asmort*ccohort%n - hio_m10_si_scls(io_si,scls) = hio_m10_si_scls(io_si,scls) + ccohort%asmort*ccohort%n - hio_m10_si_cacls(io_si,cacls) = hio_m10_si_cacls(io_si,cacls)+ & - ccohort%asmort*ccohort%n - end if - - hio_m1_si_scls(io_si,scls) = hio_m1_si_scls(io_si,scls) + ccohort%bmort*ccohort%n - hio_m2_si_scls(io_si,scls) = hio_m2_si_scls(io_si,scls) + ccohort%hmort*ccohort%n - hio_m3_si_scls(io_si,scls) = hio_m3_si_scls(io_si,scls) + ccohort%cmort*ccohort%n - hio_m7_si_scls(io_si,scls) = hio_m7_si_scls(io_si,scls) + & - (ccohort%lmort_direct+ccohort%lmort_collateral+ccohort%lmort_infra) * ccohort%n - hio_m8_si_scls(io_si,scls) = hio_m8_si_scls(io_si,scls) + & - ccohort%frmort*ccohort%n - hio_m9_si_scls(io_si,scls) = hio_m9_si_scls(io_si,scls) + ccohort%smort*ccohort%n - - - - !C13 discrimination - if(gpp_cached + ccohort%gpp_acc_hold > 0.0_r8)then - hio_c13disc_si_scpf(io_si,scpf) = ((hio_c13disc_si_scpf(io_si,scpf) * gpp_cached) + & - (ccohort%c13disc_acc * ccohort%gpp_acc_hold)) / (gpp_cached + ccohort%gpp_acc_hold) - else - hio_c13disc_si_scpf(io_si,scpf) = 0.0_r8 - endif - - ! number density [/ha] - hio_nplant_si_scpf(io_si,scpf) = hio_nplant_si_scpf(io_si,scpf) + ccohort%n - - ! number density along the cohort age dimension - if (hlm_use_cohort_age_tracking .eq.itrue) then - hio_nplant_si_capf(io_si,capf) = hio_nplant_si_capf(io_si,capf) + ccohort%n - hio_nplant_si_cacls(io_si,cacls) = hio_nplant_si_cacls(io_si,cacls)+ccohort%n - end if - - - ! Carbon only metrics - sapw_m = ccohort%prt%GetState(sapw_organ, carbon12_element) - struct_m = ccohort%prt%GetState(struct_organ, carbon12_element) - leaf_m = ccohort%prt%GetState(leaf_organ, carbon12_element) - fnrt_m = ccohort%prt%GetState(fnrt_organ, carbon12_element) - store_m = ccohort%prt%GetState(store_organ, carbon12_element) - repro_m = ccohort%prt%GetState(repro_organ, carbon12_element) - alive_m = leaf_m + fnrt_m + sapw_m - total_m = alive_m + store_m + struct_m - - - ! number density by size and biomass - hio_agb_si_scls(io_si,scls) = hio_agb_si_scls(io_si,scls) + & - total_m * ccohort%n * prt_params%allom_agb_frac(ccohort%pft) * AREA_INV - - hio_agb_si_scpf(io_si,scpf) = hio_agb_si_scpf(io_si,scpf) + & - total_m * ccohort%n * prt_params%allom_agb_frac(ccohort%pft) * AREA_INV - - - hio_biomass_si_scls(io_si,scls) = hio_biomass_si_scls(io_si,scls) + & - total_m * ccohort%n * AREA_INV - - ! update size-class x patch-age related quantities - - iscag = get_sizeage_class_index(ccohort%dbh,cpatch%age) - - hio_nplant_si_scag(io_si,iscag) = hio_nplant_si_scag(io_si,iscag) + ccohort%n - - hio_nplant_si_scls(io_si,scls) = hio_nplant_si_scls(io_si,scls) + ccohort%n - - - ! update size, age, and PFT - indexed quantities - - iscagpft = get_sizeagepft_class_index(ccohort%dbh,cpatch%age,ccohort%pft) - - hio_nplant_si_scagpft(io_si,iscagpft) = hio_nplant_si_scagpft(io_si,iscagpft) + ccohort%n - - ! update age and PFT - indexed quantities - - iagepft = get_agepft_class_index(cpatch%age,ccohort%pft) - - hio_npp_si_agepft(io_si,iagepft) = hio_npp_si_agepft(io_si,iagepft) + & - ccohort%n * ccohort%npp_acc_hold * AREA_INV - - hio_biomass_si_agepft(io_si,iagepft) = hio_biomass_si_agepft(io_si,iagepft) + & - total_m * ccohort%n * AREA_INV - - ! update SCPF/SCLS- and canopy/subcanopy- partitioned quantities - if (ccohort%canopy_layer .eq. 1) then - hio_nplant_canopy_si_scag(io_si,iscag) = hio_nplant_canopy_si_scag(io_si,iscag) + ccohort%n - hio_mortality_canopy_si_scag(io_si,iscag) = hio_mortality_canopy_si_scag(io_si,iscag) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n - hio_ddbh_canopy_si_scag(io_si,iscag) = hio_ddbh_canopy_si_scag(io_si,iscag) + & - ccohort%ddbhdt*ccohort%n - hio_bstor_canopy_si_scpf(io_si,scpf) = hio_bstor_canopy_si_scpf(io_si,scpf) + & - store_m * ccohort%n - hio_bleaf_canopy_si_scpf(io_si,scpf) = hio_bleaf_canopy_si_scpf(io_si,scpf) + & - leaf_m * ccohort%n - - hio_canopy_biomass_si(io_si) = hio_canopy_biomass_si(io_si) + n_perm2 * total_m * 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%frmort + ccohort%smort + ccohort%asmort) * ccohort%n - - hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & - - (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%frmort + & - ccohort%smort + ccohort%asmort) * ccohort%n + & - (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * sec_per_day * days_per_year - - hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + ccohort%n - hio_nplant_canopy_si_scls(io_si,scls) = hio_nplant_canopy_si_scls(io_si,scls) + ccohort%n - hio_lai_canopy_si_scls(io_si,scls) = hio_lai_canopy_si_scls(io_si,scls) + & - ccohort%treelai*ccohort%c_area * AREA_INV - hio_sai_canopy_si_scls(io_si,scls) = hio_sai_canopy_si_scls(io_si,scls) + & - ccohort%treesai*ccohort%c_area * AREA_INV - hio_trimming_canopy_si_scls(io_si,scls) = hio_trimming_canopy_si_scls(io_si,scls) + & - ccohort%n * ccohort%canopy_trim - hio_crown_area_canopy_si_scls(io_si,scls) = hio_crown_area_canopy_si_scls(io_si,scls) + & - ccohort%c_area - hio_gpp_canopy_si_scpf(io_si,scpf) = hio_gpp_canopy_si_scpf(io_si,scpf) + & - n_perm2*ccohort%gpp_acc_hold - hio_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 - hio_ddbh_canopy_si_scls(io_si,scls) = hio_ddbh_canopy_si_scls(io_si,scls) + & - 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%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + & - (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * sec_per_day * days_per_year - - hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * & - total_m * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + & - (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_m * & - ccohort%n * g_per_kg * ha_per_m2 - - - hio_carbon_balance_canopy_si_scls(io_si,scls) = hio_carbon_balance_canopy_si_scls(io_si,scls) + & - ccohort%n * ccohort%npp_acc_hold - - - hio_leaf_md_canopy_si_scls(io_si,scls) = hio_leaf_md_canopy_si_scls(io_si,scls) + & - leaf_m_turnover * ccohort%n - hio_root_md_canopy_si_scls(io_si,scls) = hio_root_md_canopy_si_scls(io_si,scls) + & - fnrt_m_turnover * ccohort%n - hio_bsw_md_canopy_si_scls(io_si,scls) = hio_bsw_md_canopy_si_scls(io_si,scls) + & - sapw_m_turnover * ccohort%n - hio_bstore_md_canopy_si_scls(io_si,scls) = hio_bstore_md_canopy_si_scls(io_si,scls) + & - store_m_turnover * ccohort%n - hio_bdead_md_canopy_si_scls(io_si,scls) = hio_bdead_md_canopy_si_scls(io_si,scls) + & - struct_m_turnover * 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_npp_leaf_canopy_si_scls(io_si,scls) = hio_npp_leaf_canopy_si_scls(io_si,scls) + & - leaf_m_net_alloc * ccohort%n - hio_npp_fnrt_canopy_si_scls(io_si,scls) = hio_npp_fnrt_canopy_si_scls(io_si,scls) + & - fnrt_m_net_alloc * ccohort%n - hio_npp_sapw_canopy_si_scls(io_si,scls) = hio_npp_sapw_canopy_si_scls(io_si,scls) + & - sapw_m_net_alloc * ccohort%n - hio_npp_dead_canopy_si_scls(io_si,scls) = hio_npp_dead_canopy_si_scls(io_si,scls) + & - struct_m_net_alloc * ccohort%n - hio_npp_seed_canopy_si_scls(io_si,scls) = hio_npp_seed_canopy_si_scls(io_si,scls) + & - repro_m_net_alloc * ccohort%n - hio_npp_stor_canopy_si_scls(io_si,scls) = hio_npp_stor_canopy_si_scls(io_si,scls) + & - store_m_net_alloc * ccohort%n - - hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) = & - hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) + & - ccohort%canopy_layer_yesterday * ccohort%n - else - hio_nplant_understory_si_scag(io_si,iscag) = hio_nplant_understory_si_scag(io_si,iscag) + ccohort%n - hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n - hio_ddbh_understory_si_scag(io_si,iscag) = hio_ddbh_understory_si_scag(io_si,iscag) + & - ccohort%ddbhdt*ccohort%n - hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & - store_m * ccohort%n - hio_bleaf_understory_si_scpf(io_si,scpf) = hio_bleaf_understory_si_scpf(io_si,scpf) + & - leaf_m * ccohort%n - hio_understory_biomass_si(io_si) = hio_understory_biomass_si(io_si) + & - n_perm2 * total_m * g_per_kg - - !hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & - ! (ccohort%bmort + ccohort%hmort + ccohort%cmort + - ! ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n - - hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + & - (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * sec_per_day * days_per_year - - 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_lai_understory_si_scls(io_si,scls) = hio_lai_understory_si_scls(io_si,scls) + & - ccohort%treelai*ccohort%c_area * AREA_INV - hio_sai_understory_si_scls(io_si,scls) = hio_sai_understory_si_scls(io_si,scls) + & - ccohort%treelai*ccohort%c_area * AREA_INV - hio_trimming_understory_si_scls(io_si,scls) = hio_trimming_understory_si_scls(io_si,scls) + & - ccohort%n * ccohort%canopy_trim - hio_crown_area_understory_si_scls(io_si,scls) = hio_crown_area_understory_si_scls(io_si,scls) + & - ccohort%c_area - hio_gpp_understory_si_scpf(io_si,scpf) = hio_gpp_understory_si_scpf(io_si,scpf) + & - n_perm2*ccohort%gpp_acc_hold - 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 - hio_ddbh_understory_si_scls(io_si,scls) = hio_ddbh_understory_si_scls(io_si,scls) + & - 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%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + & - (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & - ccohort%n * sec_per_day * days_per_year - - hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & - (ccohort%bmort + ccohort%hmort + ccohort%cmort + & - ccohort%frmort + ccohort%smort + ccohort%asmort) * & - total_m * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + & - (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_m * & - ccohort%n * g_per_kg * ha_per_m2 - - hio_carbon_balance_understory_si_scls(io_si,scls) = hio_carbon_balance_understory_si_scls(io_si,scls) + & - ccohort%npp_acc_hold * ccohort%n - - hio_leaf_md_understory_si_scls(io_si,scls) = hio_leaf_md_understory_si_scls(io_si,scls) + & - leaf_m_turnover * ccohort%n - hio_root_md_understory_si_scls(io_si,scls) = hio_root_md_understory_si_scls(io_si,scls) + & - fnrt_m_turnover * ccohort%n - hio_bsw_md_understory_si_scls(io_si,scls) = hio_bsw_md_understory_si_scls(io_si,scls) + & - sapw_m_turnover * ccohort%n - hio_bstore_md_understory_si_scls(io_si,scls) = hio_bstore_md_understory_si_scls(io_si,scls) + & - store_m_turnover * ccohort%n - hio_bdead_md_understory_si_scls(io_si,scls) = hio_bdead_md_understory_si_scls(io_si,scls) + & - struct_m_turnover * 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_npp_leaf_understory_si_scls(io_si,scls) = hio_npp_leaf_understory_si_scls(io_si,scls) + & - leaf_m_net_alloc * ccohort%n - hio_npp_fnrt_understory_si_scls(io_si,scls) = hio_npp_fnrt_understory_si_scls(io_si,scls) + & - fnrt_m_net_alloc * ccohort%n - hio_npp_sapw_understory_si_scls(io_si,scls) = hio_npp_sapw_understory_si_scls(io_si,scls) + & - sapw_m_net_alloc * ccohort%n - hio_npp_dead_understory_si_scls(io_si,scls) = hio_npp_dead_understory_si_scls(io_si,scls) + & - struct_m_net_alloc * ccohort%n - hio_npp_seed_understory_si_scls(io_si,scls) = hio_npp_seed_understory_si_scls(io_si,scls) + & - repro_m_net_alloc * ccohort%n - hio_npp_stor_understory_si_scls(io_si,scls) = hio_npp_stor_understory_si_scls(io_si,scls) + & - store_m_net_alloc * ccohort%n - - hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) = & - hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) + & - ccohort%canopy_layer_yesterday * ccohort%n - endif - ! - ! - ccohort%canopy_layer_yesterday = real(ccohort%canopy_layer, r8) - ! - ! growth flux of individuals into a given bin - ! track the actual growth here, the virtual growth from fusion lower down - if ( (scls - ccohort%size_class_lasttimestep ) .gt. 0) then - do i_scls = ccohort%size_class_lasttimestep + 1, scls - i_scpf = (ccohort%pft-1)*nlevsclass+i_scls - hio_growthflux_si_scpf(io_si,i_scpf) = hio_growthflux_si_scpf(io_si,i_scpf) + & - ccohort%n * days_per_year - end do - end if - ccohort%size_class_lasttimestep = scls - - - ! - end associate - else ! i.e. cohort%isnew - ! - ! if cohort is new, track its growth flux into the first size bin - i_scpf = (ccohort%pft-1)*nlevsclass+1 - hio_growthflux_si_scpf(io_si,i_scpf) = hio_growthflux_si_scpf(io_si,i_scpf) + ccohort%n * days_per_year - ccohort%size_class_lasttimestep = 1 - + ! number density along the cohort age dimension + if (hlm_use_cohort_age_tracking .eq.itrue) then + hio_nplant_si_capf(io_si,capf) = hio_nplant_si_capf(io_si,capf) + ccohort%n / m2_per_ha + hio_nplant_si_cacls(io_si,cacls) = hio_nplant_si_cacls(io_si,cacls)+ccohort%n / m2_per_ha end if - ! resolve some canopy area profiles, both total and of occupied leaves - ican = ccohort%canopy_layer + ! Carbon only metrics + sapw_m = ccohort%prt%GetState(sapw_organ, carbon12_element) + struct_m = ccohort%prt%GetState(struct_organ, carbon12_element) + leaf_m = ccohort%prt%GetState(leaf_organ, carbon12_element) + fnrt_m = ccohort%prt%GetState(fnrt_organ, carbon12_element) + store_m = ccohort%prt%GetState(store_organ, carbon12_element) + repro_m = ccohort%prt%GetState(repro_organ, carbon12_element) + alive_m = leaf_m + fnrt_m + sapw_m + total_m = alive_m + store_m + struct_m + + + ! number density by size and biomass + hio_agb_si_scls(io_si,scls) = hio_agb_si_scls(io_si,scls) + & + total_m * ccohort%n * prt_params%allom_agb_frac(ccohort%pft) * AREA_INV + + hio_agb_si_scpf(io_si,scpf) = hio_agb_si_scpf(io_si,scpf) + & + total_m * ccohort%n * prt_params%allom_agb_frac(ccohort%pft) * AREA_INV + + hio_biomass_si_scls(io_si,scls) = hio_biomass_si_scls(io_si,scls) + & + total_m * ccohort%n * AREA_INV + + ! update size-class x patch-age related quantities + + iscag = get_sizeage_class_index(ccohort%dbh,cpatch%age) + + hio_nplant_si_scag(io_si,iscag) = hio_nplant_si_scag(io_si,iscag) + ccohort%n / m2_per_ha + + hio_nplant_si_scls(io_si,scls) = hio_nplant_si_scls(io_si,scls) + ccohort%n / m2_per_ha + + + ! update size, age, and PFT - indexed quantities + iscagpft = get_sizeagepft_class_index(ccohort%dbh,cpatch%age,ccohort%pft) + + hio_nplant_si_scagpft(io_si,iscagpft) = hio_nplant_si_scagpft(io_si,iscagpft) + ccohort%n / m2_per_ha + + ! update age and PFT - indexed quantities + iagepft = get_agepft_class_index(cpatch%age,ccohort%pft) + + hio_npp_si_agepft(io_si,iagepft) = hio_npp_si_agepft(io_si,iagepft) + & + ccohort%n * ccohort%npp_acc_hold * AREA_INV / days_per_year / sec_per_day + + hio_biomass_si_agepft(io_si,iagepft) = hio_biomass_si_agepft(io_si,iagepft) + & + total_m * ccohort%n * AREA_INV + + ! update SCPF/SCLS- and canopy/subcanopy- partitioned quantities + canlayer: if (ccohort%canopy_layer .eq. 1) then + hio_nplant_canopy_si_scag(io_si,iscag) = hio_nplant_canopy_si_scag(io_si,iscag) + ccohort%n / m2_per_ha + hio_mortality_canopy_si_scag(io_si,iscag) = hio_mortality_canopy_si_scag(io_si,iscag) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + hio_ddbh_canopy_si_scag(io_si,iscag) = hio_ddbh_canopy_si_scag(io_si,iscag) + & + ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha + hio_bstor_canopy_si_scpf(io_si,scpf) = hio_bstor_canopy_si_scpf(io_si,scpf) + & + store_m * ccohort%n / m2_per_ha + hio_bleaf_canopy_si_scpf(io_si,scpf) = hio_bleaf_canopy_si_scpf(io_si,scpf) + & + leaf_m * ccohort%n / m2_per_ha + + hio_canopy_biomass_si(io_si) = hio_canopy_biomass_si(io_si) + n_perm2 * total_m + + !hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & + ! (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + ! ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + + hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%frmort + & + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & + ccohort%n * sec_per_day * days_per_year / m2_per_ha + + hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + ccohort%n / m2_per_ha + hio_nplant_canopy_si_scls(io_si,scls) = hio_nplant_canopy_si_scls(io_si,scls) + ccohort%n / m2_per_ha + hio_lai_canopy_si_scls(io_si,scls) = hio_lai_canopy_si_scls(io_si,scls) + & + ccohort%treelai*ccohort%c_area * AREA_INV + hio_sai_canopy_si_scls(io_si,scls) = hio_sai_canopy_si_scls(io_si,scls) + & + ccohort%treesai*ccohort%c_area * AREA_INV + hio_trimming_canopy_si_scls(io_si,scls) = hio_trimming_canopy_si_scls(io_si,scls) + & + ccohort%n * ccohort%canopy_trim / m2_per_ha + hio_crown_area_canopy_si_scls(io_si,scls) = hio_crown_area_canopy_si_scls(io_si,scls) + & + ccohort%c_area / m2_per_ha + hio_gpp_canopy_si_scpf(io_si,scpf) = hio_gpp_canopy_si_scpf(io_si,scpf) + & + n_perm2*ccohort%gpp_acc_hold / days_per_year / sec_per_day + hio_ar_canopy_si_scpf(io_si,scpf) = hio_ar_canopy_si_scpf(io_si,scpf) + & + n_perm2*ccohort%resp_acc_hold / days_per_year / sec_per_day + ! growth increment + hio_ddbh_canopy_si_scpf(io_si,scpf) = hio_ddbh_canopy_si_scpf(io_si,scpf) + & + ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha + hio_ddbh_canopy_si_scls(io_si,scls) = hio_ddbh_canopy_si_scls(io_si,scls) + & + ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha + + ! sum of all mortality + hio_mortality_canopy_si_scls(io_si,scls) = hio_mortality_canopy_si_scls(io_si,scls) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & + ccohort%n * sec_per_day * days_per_year / m2_per_ha + + hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + ccohort%frmort + ccohort%smort + ccohort%asmort) * & + total_m * ccohort%n * days_per_sec * years_per_day * ha_per_m2 + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_m * & + ccohort%n * ha_per_m2 + + + hio_carbon_balance_canopy_si_scls(io_si,scls) = hio_carbon_balance_canopy_si_scls(io_si,scls) + & + ccohort%n * ccohort%npp_acc_hold / m2_per_ha / days_per_year / sec_per_day + + hio_leaf_md_canopy_si_scls(io_si,scls) = hio_leaf_md_canopy_si_scls(io_si,scls) + & + leaf_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_root_md_canopy_si_scls(io_si,scls) = hio_root_md_canopy_si_scls(io_si,scls) + & + fnrt_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_bsw_md_canopy_si_scls(io_si,scls) = hio_bsw_md_canopy_si_scls(io_si,scls) + & + sapw_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_bstore_md_canopy_si_scls(io_si,scls) = hio_bstore_md_canopy_si_scls(io_si,scls) + & + store_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_bdead_md_canopy_si_scls(io_si,scls) = hio_bdead_md_canopy_si_scls(io_si,scls) + & + struct_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_seed_prod_canopy_si_scls(io_si,scls) = hio_seed_prod_canopy_si_scls(io_si,scls) + & + ccohort%seed_prod * ccohort%n / m2_per_ha / days_per_year / sec_per_day + + hio_npp_leaf_canopy_si_scls(io_si,scls) = hio_npp_leaf_canopy_si_scls(io_si,scls) + & + leaf_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_fnrt_canopy_si_scls(io_si,scls) = hio_npp_fnrt_canopy_si_scls(io_si,scls) + & + fnrt_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_sapw_canopy_si_scls(io_si,scls) = hio_npp_sapw_canopy_si_scls(io_si,scls) + & + sapw_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_dead_canopy_si_scls(io_si,scls) = hio_npp_dead_canopy_si_scls(io_si,scls) + & + struct_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_seed_canopy_si_scls(io_si,scls) = hio_npp_seed_canopy_si_scls(io_si,scls) + & + repro_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_stor_canopy_si_scls(io_si,scls) = hio_npp_stor_canopy_si_scls(io_si,scls) + & + store_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + + hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) = & + hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) + & + ccohort%canopy_layer_yesterday * ccohort%n / m2_per_ha + else canlayer + hio_nplant_understory_si_scag(io_si,iscag) = hio_nplant_understory_si_scag(io_si,iscag) + ccohort%n / m2_per_ha + hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + hio_ddbh_understory_si_scag(io_si,iscag) = hio_ddbh_understory_si_scag(io_si,iscag) + & + ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha + hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & + store_m * ccohort%n / m2_per_ha + hio_bleaf_understory_si_scpf(io_si,scpf) = hio_bleaf_understory_si_scpf(io_si,scpf) + & + leaf_m * ccohort%n / m2_per_ha + hio_understory_biomass_si(io_si) = hio_understory_biomass_si(io_si) + & + n_perm2 * total_m + + !hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & + ! (ccohort%bmort + ccohort%hmort + ccohort%cmort + + ! ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + + hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & + ccohort%n * sec_per_day * days_per_year / m2_per_ha + + hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + ccohort%n / m2_per_ha + hio_nplant_understory_si_scls(io_si,scls) = hio_nplant_understory_si_scls(io_si,scls) + ccohort%n / m2_per_ha + hio_lai_understory_si_scls(io_si,scls) = hio_lai_understory_si_scls(io_si,scls) + & + ccohort%treelai*ccohort%c_area * AREA_INV + hio_sai_understory_si_scls(io_si,scls) = hio_sai_understory_si_scls(io_si,scls) + & + ccohort%treelai*ccohort%c_area * AREA_INV + hio_trimming_understory_si_scls(io_si,scls) = hio_trimming_understory_si_scls(io_si,scls) + & + ccohort%n * ccohort%canopy_trim / m2_per_ha + hio_crown_area_understory_si_scls(io_si,scls) = hio_crown_area_understory_si_scls(io_si,scls) + & + ccohort%c_area / m2_per_ha + hio_gpp_understory_si_scpf(io_si,scpf) = hio_gpp_understory_si_scpf(io_si,scpf) + & + n_perm2*ccohort%gpp_acc_hold / days_per_year / sec_per_day + hio_ar_understory_si_scpf(io_si,scpf) = hio_ar_understory_si_scpf(io_si,scpf) + & + n_perm2*ccohort%resp_acc_hold / days_per_year / sec_per_day + + ! growth increment + hio_ddbh_understory_si_scpf(io_si,scpf) = hio_ddbh_understory_si_scpf(io_si,scpf) + & + ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha + hio_ddbh_understory_si_scls(io_si,scls) = hio_ddbh_understory_si_scls(io_si,scls) + & + ccohort%ddbhdt*ccohort%n * m_per_cm / m2_per_ha + + ! sum of all mortality + hio_mortality_understory_si_scls(io_si,scls) = hio_mortality_understory_si_scls(io_si,scls) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n / m2_per_ha + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & + ccohort%n * sec_per_day * days_per_year / m2_per_ha + + hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & + (ccohort%bmort + ccohort%hmort + ccohort%cmort + & + ccohort%frmort + ccohort%smort + ccohort%asmort) * & + total_m * ccohort%n * days_per_sec * years_per_day * ha_per_m2 + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_m * & + ccohort%n * ha_per_m2 + + hio_carbon_balance_understory_si_scls(io_si,scls) = hio_carbon_balance_understory_si_scls(io_si,scls) + & + ccohort%npp_acc_hold * ccohort%n / m2_per_ha / days_per_year / sec_per_day + + hio_leaf_md_understory_si_scls(io_si,scls) = hio_leaf_md_understory_si_scls(io_si,scls) + & + leaf_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_root_md_understory_si_scls(io_si,scls) = hio_root_md_understory_si_scls(io_si,scls) + & + fnrt_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_bsw_md_understory_si_scls(io_si,scls) = hio_bsw_md_understory_si_scls(io_si,scls) + & + sapw_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_bstore_md_understory_si_scls(io_si,scls) = hio_bstore_md_understory_si_scls(io_si,scls) + & + store_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_bdead_md_understory_si_scls(io_si,scls) = hio_bdead_md_understory_si_scls(io_si,scls) + & + struct_m_turnover * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_seed_prod_understory_si_scls(io_si,scls) = hio_seed_prod_understory_si_scls(io_si,scls) + & + ccohort%seed_prod * ccohort%n / m2_per_ha / days_per_year / sec_per_day + + hio_npp_leaf_understory_si_scls(io_si,scls) = hio_npp_leaf_understory_si_scls(io_si,scls) + & + leaf_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_fnrt_understory_si_scls(io_si,scls) = hio_npp_fnrt_understory_si_scls(io_si,scls) + & + fnrt_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_sapw_understory_si_scls(io_si,scls) = hio_npp_sapw_understory_si_scls(io_si,scls) + & + sapw_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_dead_understory_si_scls(io_si,scls) = hio_npp_dead_understory_si_scls(io_si,scls) + & + struct_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_seed_understory_si_scls(io_si,scls) = hio_npp_seed_understory_si_scls(io_si,scls) + & + repro_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + hio_npp_stor_understory_si_scls(io_si,scls) = hio_npp_stor_understory_si_scls(io_si,scls) + & + store_m_net_alloc * ccohort%n / m2_per_ha / days_per_year / sec_per_day + + hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) = & + hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) + & + ccohort%canopy_layer_yesterday * ccohort%n / m2_per_ha + endif canlayer ! - hio_crownarea_si_can(io_si, ican) = hio_crownarea_si_can(io_si, ican) + ccohort%c_area / AREA ! - do ileaf=1,ccohort%nv - cnlf_indx = ileaf + (ican-1) * nlevleaf - hio_crownarea_si_cnlf(io_si, cnlf_indx) = hio_crownarea_si_cnlf(io_si, cnlf_indx) + & - ccohort%c_area / AREA - end do - - ccohort => ccohort%taller - enddo ! cohort loop - - ! Patch specific variables that are already calculated - ! These things are all duplicated. Should they all be converted to LL or array structures RF? - ! define scalar to counteract the patch albedo scaling logic for conserved quantities - - ! Update Fire Variables - hio_spitfire_ros_si(io_si) = hio_spitfire_ros_si(io_si) + cpatch%ROS_front * cpatch%area * AREA_INV - hio_fire_ros_area_product_si(io_si)= hio_fire_ros_area_product_si(io_si) + & - cpatch%frac_burnt * cpatch%ROS_front * cpatch%area * AREA_INV - hio_effect_wspeed_si(io_si) = hio_effect_wspeed_si(io_si) + cpatch%effect_wspeed * cpatch%area * AREA_INV - hio_tfc_ros_si(io_si) = hio_tfc_ros_si(io_si) + cpatch%TFC_ROS * cpatch%area * AREA_INV - hio_tfc_ros_area_product_si(io_si) = hio_tfc_ros_area_product_si(io_si) + & - cpatch%frac_burnt * cpatch%TFC_ROS * cpatch%area * AREA_INV - hio_fire_intensity_si(io_si) = hio_fire_intensity_si(io_si) + cpatch%FI * cpatch%area * AREA_INV - hio_fire_area_si(io_si) = hio_fire_area_si(io_si) + cpatch%frac_burnt * cpatch%area * AREA_INV - hio_fire_fuel_bulkd_si(io_si) = hio_fire_fuel_bulkd_si(io_si) + cpatch%fuel_bulkd * cpatch%area * AREA_INV - hio_fire_fuel_eff_moist_si(io_si) = hio_fire_fuel_eff_moist_si(io_si) + cpatch%fuel_eff_moist * cpatch%area * AREA_INV - hio_fire_fuel_sav_si(io_si) = hio_fire_fuel_sav_si(io_si) + cpatch%fuel_sav * cpatch%area * AREA_INV - hio_fire_fuel_mef_si(io_si) = hio_fire_fuel_mef_si(io_si) + cpatch%fuel_mef * cpatch%area * AREA_INV - hio_sum_fuel_si(io_si) = hio_sum_fuel_si(io_si) + cpatch%sum_fuel * g_per_kg * cpatch%area * AREA_INV - - do ilyr = 1,sites(s)%nlevsoil - hio_fragmentation_scaler_sl(io_si,ilyr) = hio_fragmentation_scaler_sl(io_si,ilyr) + cpatch%fragmentation_scaler(ilyr) * cpatch%area * AREA_INV + ccohort%canopy_layer_yesterday = real(ccohort%canopy_layer, r8) + ! + ! growth flux of individuals into a given bin + ! track the actual growth here, the virtual growth from fusion lower down + if ( (scls - ccohort%size_class_lasttimestep ) .gt. 0) then + do i_scls = ccohort%size_class_lasttimestep + 1, scls + i_scpf = (ccohort%pft-1)*nlevsclass+i_scls + hio_growthflux_si_scpf(io_si,i_scpf) = hio_growthflux_si_scpf(io_si,i_scpf) + & + ccohort%n * days_per_year / m2_per_ha + end do + end if + ccohort%size_class_lasttimestep = scls + + end associate + else notnew ! i.e. cohort%isnew + ! + ! if cohort is new, track its growth flux into the first size bin + i_scpf = (ccohort%pft-1)*nlevsclass+1 + hio_growthflux_si_scpf(io_si,i_scpf) = & + hio_growthflux_si_scpf(io_si,i_scpf) + ccohort%n * & + days_per_year / m2_per_ha + ccohort%size_class_lasttimestep = 1 + + end if notnew + + ! resolve some canopy area profiles, both total and of occupied leaves + ican = ccohort%canopy_layer + ! + hio_crownarea_si_can(io_si, ican) = hio_crownarea_si_can(io_si, ican) + ccohort%c_area / AREA + ! + do ileaf=1,ccohort%nv + cnlf_indx = ileaf + (ican-1) * nlevleaf + hio_crownarea_si_cnlf(io_si, cnlf_indx) = hio_crownarea_si_cnlf(io_si, cnlf_indx) + & + ccohort%c_area / AREA end do - - do i_fuel = 1,nfsc - i_agefuel = get_agefuel_class_index(cpatch%age,i_fuel) - hio_fuel_amount_age_fuel(io_si,i_agefuel) = hio_fuel_amount_age_fuel(io_si,i_agefuel) + & - cpatch%fuel_frac(i_fuel) * cpatch%sum_fuel * cpatch%area * AREA_INV + ccohort => ccohort%taller + enddo cohortloop ! cohort loop + + ! Patch specific variables that are already calculated + ! These things are all duplicated. Should they all be converted to LL or array structures RF? + ! define scalar to counteract the patch albedo scaling logic for conserved quantities + + ! Update Fire Variables + hio_spitfire_ros_si(io_si) = hio_spitfire_ros_si(io_si) + cpatch%ROS_front * cpatch%area * AREA_INV / sec_per_min + hio_effect_wspeed_si(io_si) = hio_effect_wspeed_si(io_si) + cpatch%effect_wspeed * cpatch%area * AREA_INV / sec_per_min + hio_tfc_ros_si(io_si) = hio_tfc_ros_si(io_si) + cpatch%TFC_ROS * cpatch%area * AREA_INV + hio_fire_intensity_si(io_si) = hio_fire_intensity_si(io_si) + cpatch%FI * cpatch%area * AREA_INV * J_per_kJ + hio_fire_area_si(io_si) = hio_fire_area_si(io_si) + cpatch%frac_burnt * cpatch%area * AREA_INV / sec_per_day + hio_fire_fuel_bulkd_si(io_si) = hio_fire_fuel_bulkd_si(io_si) + cpatch%fuel_bulkd * cpatch%area * AREA_INV + hio_fire_fuel_eff_moist_si(io_si) = hio_fire_fuel_eff_moist_si(io_si) + cpatch%fuel_eff_moist * cpatch%area * AREA_INV + hio_fire_fuel_sav_si(io_si) = hio_fire_fuel_sav_si(io_si) + cpatch%fuel_sav * cpatch%area * AREA_INV / m_per_cm + hio_fire_fuel_mef_si(io_si) = hio_fire_fuel_mef_si(io_si) + cpatch%fuel_mef * cpatch%area * AREA_INV + hio_sum_fuel_si(io_si) = hio_sum_fuel_si(io_si) + cpatch%sum_fuel * cpatch%area * AREA_INV + + do ilyr = 1,sites(s)%nlevsoil + hio_fragmentation_scaler_sl(io_si,ilyr) = hio_fragmentation_scaler_sl(io_si,ilyr) + cpatch%fragmentation_scaler(ilyr) * cpatch%area * AREA_INV + end do + + 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 + i_agefuel = get_agefuel_class_index(cpatch%age,i_fuel) + hio_fuel_amount_age_fuel(io_si,i_agefuel) = hio_fuel_amount_age_fuel(io_si,i_agefuel) + & + cpatch%fuel_frac(i_fuel) * cpatch%sum_fuel * cpatch%area * AREA_INV - hio_fuel_amount_si_fuel(io_si, i_fuel) = hio_fuel_amount_si_fuel(io_si, i_fuel) + & - cpatch%fuel_frac(i_fuel) * cpatch%sum_fuel * cpatch%area * AREA_INV + hio_litter_moisture_si_fuel(io_si, i_fuel) = hio_litter_moisture_si_fuel(io_si, i_fuel) + & + cpatch%litter_moisture(i_fuel) * cpatch%area * AREA_INV - hio_burnt_frac_litter_si_fuel(io_si, i_fuel) = hio_burnt_frac_litter_si_fuel(io_si, i_fuel) + & - cpatch%burnt_frac_litter(i_fuel) * cpatch%frac_burnt * cpatch%area * AREA_INV - end do + hio_fuel_amount_si_fuel(io_si, i_fuel) = hio_fuel_amount_si_fuel(io_si, i_fuel) + & + cpatch%fuel_frac(i_fuel) * cpatch%sum_fuel * cpatch%area * AREA_INV + hio_burnt_frac_litter_si_fuel(io_si, i_fuel) = hio_burnt_frac_litter_si_fuel(io_si, i_fuel) + & + cpatch%burnt_frac_litter(i_fuel) * cpatch%frac_burnt * cpatch%area * AREA_INV + end do - hio_fire_intensity_area_product_si(io_si) = hio_fire_intensity_area_product_si(io_si) + & - cpatch%FI * cpatch%frac_burnt * cpatch%area * AREA_INV - ! Update Litter Flux Variables + hio_fire_intensity_area_product_si(io_si) = hio_fire_intensity_area_product_si(io_si) + & + cpatch%FI * cpatch%frac_burnt * cpatch%area * AREA_INV * J_per_kJ - litt_c => cpatch%litter(element_pos(carbon12_element)) - flux_diags_c => sites(s)%flux_diags(element_pos(carbon12_element)) - - do i_cwd = 1, ncwd + ! Update Litter Flux Variables - hio_cwd_ag_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_si_cwdsc(io_si, i_cwd) + & - litt_c%ag_cwd(i_cwd)*cpatch%area * AREA_INV * g_per_kg - hio_cwd_bg_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_si_cwdsc(io_si, i_cwd) + & - sum(litt_c%bg_cwd(i_cwd,:)) * cpatch%area * AREA_INV * g_per_kg - - hio_cwd_ag_out_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_out_si_cwdsc(io_si, i_cwd) + & - litt_c%ag_cwd_frag(i_cwd)*cpatch%area * AREA_INV * g_per_kg - - hio_cwd_bg_out_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_out_si_cwdsc(io_si, i_cwd) + & - sum(litt_c%bg_cwd_frag(i_cwd,:)) * cpatch%area * AREA_INV * g_per_kg + litt_c => cpatch%litter(element_pos(carbon12_element)) + flux_diags_c => sites(s)%flux_diags(element_pos(carbon12_element)) - end do + do i_cwd = 1, ncwd - ipa = ipa + 1 - cpatch => cpatch%younger - end do !patch loop + hio_cwd_ag_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_si_cwdsc(io_si, i_cwd) + & + litt_c%ag_cwd(i_cwd)*cpatch%area * AREA_INV + hio_cwd_bg_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_si_cwdsc(io_si, i_cwd) + & + sum(litt_c%bg_cwd(i_cwd,:)) * cpatch%area * AREA_INV - ! divide so-far-just-summed but to-be-averaged patch-age-class variables by patch-age-class area to get mean values - do ipa2 = 1, nlevage - if (hio_area_si_age(io_si, ipa2) .gt. tiny) then + hio_cwd_ag_out_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_out_si_cwdsc(io_si, i_cwd) + & + litt_c%ag_cwd_frag(i_cwd)*cpatch%area * AREA_INV / & + days_per_year / sec_per_day + + hio_cwd_bg_out_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_out_si_cwdsc(io_si, i_cwd) + & + sum(litt_c%bg_cwd_frag(i_cwd,:)) * cpatch%area * AREA_INV / & + days_per_year / sec_per_day + + end do + + ipa = ipa + 1 + cpatch => cpatch%younger + end do patchloop !patch loop + + ! divide so-far-just-summed but to-be-averaged patch-age-class variables by patch-age-class area to get mean values + do ipa2 = 1, nlevage + if (hio_area_si_age(io_si, ipa2) .gt. tiny) then hio_lai_si_age(io_si, ipa2) = hio_lai_si_age(io_si, ipa2) / (hio_area_si_age(io_si, ipa2)*AREA) hio_ncl_si_age(io_si, ipa2) = hio_ncl_si_age(io_si, ipa2) / (hio_area_si_age(io_si, ipa2)*AREA) - do i_pft = 1, numpft - iagepft = ipa2 + (i_pft-1) * nlevage - hio_scorch_height_si_agepft(io_si, iagepft) = & - hio_scorch_height_si_agepft(io_si, iagepft) / (hio_area_si_age(io_si, ipa2)*AREA) - enddo - else - hio_lai_si_age(io_si, ipa2) = 0._r8 - hio_ncl_si_age(io_si, ipa2) = 0._r8 - endif + do i_pft = 1, numpft + iagepft = ipa2 + (i_pft-1) * nlevage + hio_scorch_height_si_agepft(io_si, iagepft) = & + hio_scorch_height_si_agepft(io_si, iagepft) / (hio_area_si_age(io_si, ipa2)*AREA) + enddo + else + hio_lai_si_age(io_si, ipa2) = 0._r8 + hio_ncl_si_age(io_si, ipa2) = 0._r8 + endif + end do + + ! pass the cohort termination mortality as a flux to the history, and then reset the termination mortality buffer + ! note there are various ways of reporting the total mortality, so pass to these as well + do i_pft = 1, numpft + do i_scls = 1,nlevsclass + i_scpf = (i_pft-1)*nlevsclass + i_scls + ! + ! termination mortality. sum of canopy and understory indices + hio_m6_si_scpf(io_si,i_scpf) = (sites(s)%term_nindivs_canopy(i_scls,i_pft) + & + sites(s)%term_nindivs_ustory(i_scls,i_pft)) * & + days_per_year / m2_per_ha + + hio_m6_si_scls(io_si,i_scls) = hio_m6_si_scls(io_si,i_scls) + & + (sites(s)%term_nindivs_canopy(i_scls,i_pft) + & + sites(s)%term_nindivs_ustory(i_scls,i_pft)) * & + days_per_year / m2_per_ha + ! + ! add termination mortality to canopy and understory mortality + hio_mortality_canopy_si_scls(io_si,i_scls) = hio_mortality_canopy_si_scls(io_si,i_scls) + & + sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year / m2_per_ha + + hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & + sites(s)%term_nindivs_ustory(i_scls,i_pft) * days_per_year / m2_per_ha + + hio_mortality_canopy_si_scpf(io_si,i_scpf) = hio_mortality_canopy_si_scpf(io_si,i_scpf) + & + sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year / m2_per_ha + + hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & + sites(s)%term_nindivs_ustory(i_scls,i_pft) * days_per_year / m2_per_ha + + ! + ! imort on its own + hio_m4_si_scpf(io_si,i_scpf) = sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha + hio_m4_si_scls(io_si,i_scls) = hio_m4_si_scls(io_si,i_scls) + sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha + ! + ! add imort to other mortality terms. consider imort as understory mortality even if it happens in + ! cohorts that may have been promoted as part of the patch creation, and use the pre-calculated site-level + ! values to avoid biasing the results by the dramatically-reduced number densities in cohorts that are subject to imort + hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & + sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha + hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & + sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha + ! + iscag = i_scls ! since imort is by definition something that only happens in newly disturbed patches, treat as such + hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & + sites(s)%imort_rate(i_scls, i_pft) / m2_per_ha + + ! fire mortality from the site-level diagnostic rates + hio_m5_si_scpf(io_si,i_scpf) = (sites(s)%fmort_rate_canopy(i_scls, i_pft) + & + sites(s)%fmort_rate_ustory(i_scls, i_pft)) / m2_per_ha + hio_m5_si_scls(io_si,i_scls) = hio_m5_si_scls(io_si,i_scls) + & + (sites(s)%fmort_rate_canopy(i_scls, i_pft) + & + sites(s)%fmort_rate_ustory(i_scls, i_pft)) / m2_per_ha + ! + hio_crownfiremort_si_scpf(io_si,i_scpf) = sites(s)%fmort_rate_crown(i_scls, i_pft) / m2_per_ha + hio_cambialfiremort_si_scpf(io_si,i_scpf) = sites(s)%fmort_rate_cambial(i_scls, i_pft) / m2_per_ha + ! + ! fire components of overall canopy and understory mortality + hio_mortality_canopy_si_scpf(io_si,i_scpf) = hio_mortality_canopy_si_scpf(io_si,i_scpf) + & + sites(s)%fmort_rate_canopy(i_scls, i_pft) / m2_per_ha + hio_mortality_canopy_si_scls(io_si,i_scls) = hio_mortality_canopy_si_scls(io_si,i_scls) + & + sites(s)%fmort_rate_canopy(i_scls, i_pft) / m2_per_ha + + ! the fire mortality rates for each layer are total dead, since the usable + ! output will then normalize by the counts, we are allowed to sum over layers + hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & + sites(s)%fmort_rate_ustory(i_scls, i_pft) / m2_per_ha + + hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & + sites(s)%fmort_rate_ustory(i_scls, i_pft) / m2_per_ha + + ! + ! carbon flux associated with mortality of trees dying by fire + hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & + sites(s)%fmort_carbonflux_canopy / g_per_kg + + hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & + sites(s)%fmort_carbonflux_ustory / g_per_kg + + ! + ! for scag variables, also treat as happening in the newly-disurbed patch + + hio_mortality_canopy_si_scag(io_si,iscag) = hio_mortality_canopy_si_scag(io_si,iscag) + & + sites(s)%fmort_rate_canopy(i_scls, i_pft) / m2_per_ha + hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & + sites(s)%fmort_rate_ustory(i_scls, i_pft) / m2_per_ha + + ! while in this loop, pass the fusion-induced growth rate flux to history + hio_growthflux_fusion_si_scpf(io_si,i_scpf) = hio_growthflux_fusion_si_scpf(io_si,i_scpf) + & + sites(s)%growthflux_fusion(i_scls, i_pft) * days_per_year / m2_per_ha end do + end do + + ! treat carbon flux from imort the same way + hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & + sites(s)%imort_carbonflux / g_per_kg + ! + sites(s)%term_nindivs_canopy(:,:) = 0._r8 + sites(s)%term_nindivs_ustory(:,:) = 0._r8 + sites(s)%imort_carbonflux = 0._r8 + sites(s)%imort_rate(:,:) = 0._r8 + sites(s)%fmort_rate_canopy(:,:) = 0._r8 + sites(s)%fmort_rate_ustory(:,:) = 0._r8 + sites(s)%fmort_carbonflux_canopy = 0._r8 + sites(s)%fmort_carbonflux_ustory = 0._r8 + sites(s)%fmort_rate_cambial(:,:) = 0._r8 + sites(s)%fmort_rate_crown(:,:) = 0._r8 + sites(s)%growthflux_fusion(:,:) = 0._r8 + + ! pass the recruitment rate as a flux to the history, and then reset the recruitment buffer + do i_pft = 1, numpft + hio_recruitment_si_pft(io_si,i_pft) = sites(s)%recruitment_rate(i_pft) * days_per_year / m2_per_ha + end do + sites(s)%recruitment_rate(:) = 0._r8 + + ! summarize all of the mortality fluxes by PFT + do i_pft = 1, numpft + do i_scls = 1,nlevsclass + i_scpf = (i_pft-1)*nlevsclass + i_scls + + hio_mortality_si_pft(io_si,i_pft) = hio_mortality_si_pft(io_si,i_pft) + & + hio_m1_si_scpf(io_si,i_scpf) + & + hio_m2_si_scpf(io_si,i_scpf) + & + hio_m3_si_scpf(io_si,i_scpf) + & + hio_m4_si_scpf(io_si,i_scpf) + & + hio_m5_si_scpf(io_si,i_scpf) + & + hio_m6_si_scpf(io_si,i_scpf) + & + hio_m7_si_scpf(io_si,i_scpf) + & + hio_m8_si_scpf(io_si,i_scpf) + & + hio_m9_si_scpf(io_si,i_scpf) + & + hio_m10_si_scpf(io_si,i_scpf) - ! pass the cohort termination mortality as a flux to the history, and then reset the termination mortality buffer - ! note there are various ways of reporting the total mortality, so pass to these as well - do i_pft = 1, numpft - do i_scls = 1,nlevsclass - i_scpf = (i_pft-1)*nlevsclass + i_scls - ! - ! termination mortality. sum of canopy and understory indices - hio_m6_si_scpf(io_si,i_scpf) = (sites(s)%term_nindivs_canopy(i_scls,i_pft) + & - sites(s)%term_nindivs_ustory(i_scls,i_pft)) * days_per_year + end do + end do + + ! ------------------------------------------------------------------------------ + ! Some carbon only litter diagnostics (legacy) + ! ------------------------------------------------------------------------------ + + flux_diags => sites(s)%flux_diags(element_pos(carbon12_element)) + + hio_litter_in_si(io_si) = (sum(flux_diags%cwd_ag_input(:)) + & + sum(flux_diags%cwd_bg_input(:)) + & + sum(flux_diags%leaf_litter_input(:)) + & + sum(flux_diags%root_litter_input(:))) * & + AREA_INV * days_per_sec + + hio_litter_out_si(io_si) = 0._r8 + hio_seed_bank_si(io_si) = 0._r8 + hio_seeds_in_si(io_si) = 0._r8 + + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + + litt => cpatch%litter(element_pos(carbon12_element)) + + area_frac = cpatch%area * AREA_INV + + ! Sum up all output fluxes (fragmentation) kgC/m2/day -> gC/m2/s + hio_litter_out_si(io_si) = hio_litter_out_si(io_si) + & + (sum(litt%leaf_fines_frag(:)) + & + sum(litt%root_fines_frag(:,:)) + & + sum(litt%ag_cwd_frag(:)) + & + sum(litt%bg_cwd_frag(:,:))) * & + area_frac * days_per_sec + + ! Sum up total seed bank (germinated and ungerminated) + hio_seed_bank_si(io_si) = hio_seed_bank_si(io_si) + & + (sum(litt%seed(:))+sum(litt%seed_germ(:))) * & + area_frac * days_per_sec + + ! Sum up the input flux into the seed bank (local and external) + hio_seeds_in_si(io_si) = hio_seeds_in_si(io_si) + & + (sum(litt%seed_in_local(:)) + sum(litt%seed_in_extern(:))) * & + area_frac * days_per_sec + + cpatch => cpatch%younger + end do + + ! ------------------------------------------------------------------------------ + ! Diagnostics discretized by element type + ! ------------------------------------------------------------------------------ + + hio_cwd_elcwd(io_si,:) = 0._r8 + + do el = 1, num_elements + + flux_diags => sites(s)%flux_diags(el) + + ! Sum up all input litter fluxes (above below, fines, cwd) [kg/ha/day] + hio_litter_in_elem(io_si, el) = (sum(flux_diags%cwd_ag_input(:)) + & + sum(flux_diags%cwd_bg_input(:)) + sum(flux_diags%leaf_litter_input(:)) + & + sum(flux_diags%root_litter_input(:))) / m2_per_ha / sec_per_day + + hio_cwd_ag_elem(io_si,el) = 0._r8 + hio_cwd_bg_elem(io_si,el) = 0._r8 + hio_fines_ag_elem(io_si,el) = 0._r8 + hio_fines_bg_elem(io_si,el) = 0._r8 + + hio_seed_bank_elem(io_si,el) = 0._r8 + hio_seed_germ_elem(io_si,el) = 0._r8 + hio_seed_decay_elem(io_si,el) = 0._r8 + hio_seeds_in_local_elem(io_si,el) = 0._r8 + hio_seed_in_extern_elem(io_si,el) = 0._r8 + hio_litter_out_elem(io_si,el) = 0._r8 + + ! Plant multi-element states and fluxes + ! Zero states, and set the fluxes + if(element_list(el).eq.carbon12_element)then + this%hvars(ih_totvegc_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_leafc_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_fnrtc_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_sapwc_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storec_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_reproc_scpf)%r82d(io_si,:) = 0._r8 + + this%hvars(ih_cefflux_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) / & + m2_per_ha / sec_per_day + + this%hvars(ih_cefflux_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) / & + m2_per_ha / sec_per_day + + elseif(element_list(el).eq.nitrogen_element)then + + this%hvars(ih_totvegn_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_leafn_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_fnrtn_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_sapwn_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storen_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_repron_scpf)%r82d(io_si,:) = 0._r8 + + this%hvars(ih_nefflux_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) / & + m2_per_ha / sec_per_day + + this%hvars(ih_nneed_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_need_scpf(:) / & + m2_per_ha / sec_per_day + + this%hvars(ih_nneed_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_need_scpf(:),dim=1) / & + m2_per_ha / sec_per_day + + this%hvars(ih_nefflux_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) / & + m2_per_ha / sec_per_day + + + elseif(element_list(el).eq.phosphorus_element)then + this%hvars(ih_totvegp_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_leafp_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_fnrtp_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_sapwp_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storep_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_reprop_scpf)%r82d(io_si,:) = 0._r8 + + this%hvars(ih_pefflux_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) / & + m2_per_ha / sec_per_day + + this%hvars(ih_pneed_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_need_scpf(:) / & + m2_per_ha / sec_per_day + + this%hvars(ih_pneed_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_need_scpf(:),dim=1) / & + m2_per_ha / sec_per_day + + this%hvars(ih_pefflux_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) / & + m2_per_ha / sec_per_day - hio_m6_si_scls(io_si,i_scls) = hio_m6_si_scls(io_si,i_scls) + & - (sites(s)%term_nindivs_canopy(i_scls,i_pft) + & - sites(s)%term_nindivs_ustory(i_scls,i_pft)) * days_per_year - + end if - ! - ! add termination mortality to canopy and understory mortality - hio_mortality_canopy_si_scls(io_si,i_scls) = hio_mortality_canopy_si_scls(io_si,i_scls) + & - sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) - hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & - sites(s)%term_nindivs_ustory(i_scls,i_pft) * days_per_year + litt => cpatch%litter(el) - hio_mortality_canopy_si_scpf(io_si,i_scpf) = hio_mortality_canopy_si_scpf(io_si,i_scpf) + & - sites(s)%term_nindivs_canopy(i_scls,i_pft) * days_per_year + area_frac = cpatch%area * AREA_INV - hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & - sites(s)%term_nindivs_ustory(i_scls,i_pft) * days_per_year + ! Sum up all output fluxes (fragmentation) + hio_litter_out_elem(io_si,el) = hio_litter_out_elem(io_si,el) + & + (sum(litt%leaf_fines_frag(:)) + & + sum(litt%root_fines_frag(:,:)) + & + sum(litt%ag_cwd_frag(:)) + & + sum(litt%bg_cwd_frag(:,:)) + & + sum(litt%seed_decay(:)) + & + sum(litt%seed_germ_decay(:))) * cpatch%area / m2_per_ha / sec_per_day - ! - ! imort on its own - hio_m4_si_scpf(io_si,i_scpf) = sites(s)%imort_rate(i_scls, i_pft) - hio_m4_si_scls(io_si,i_scls) = hio_m4_si_scls(io_si,i_scls) + sites(s)%imort_rate(i_scls, i_pft) - ! - ! add imort to other mortality terms. consider imort as understory mortality even if it happens in - ! cohorts that may have been promoted as part of the patch creation, and use the pre-calculated site-level - ! values to avoid biasing the results by the dramatically-reduced number densities in cohorts that are subject to imort - hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & - sites(s)%imort_rate(i_scls, i_pft) - hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & - sites(s)%imort_rate(i_scls, i_pft) - ! - iscag = i_scls ! since imort is by definition something that only happens in newly disturbed patches, treat as such - hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & - sites(s)%imort_rate(i_scls, i_pft) - - ! fire mortality from the site-level diagnostic rates - hio_m5_si_scpf(io_si,i_scpf) = sites(s)%fmort_rate_canopy(i_scls, i_pft) + & - sites(s)%fmort_rate_ustory(i_scls, i_pft) - hio_m5_si_scls(io_si,i_scls) = hio_m5_si_scls(io_si,i_scls) + & - sites(s)%fmort_rate_canopy(i_scls, i_pft) + sites(s)%fmort_rate_ustory(i_scls, i_pft) - ! - hio_crownfiremort_si_scpf(io_si,i_scpf) = sites(s)%fmort_rate_crown(i_scls, i_pft) - hio_cambialfiremort_si_scpf(io_si,i_scpf) = sites(s)%fmort_rate_cambial(i_scls, i_pft) - ! - ! fire components of overall canopy and understory mortality - hio_mortality_canopy_si_scpf(io_si,i_scpf) = hio_mortality_canopy_si_scpf(io_si,i_scpf) + & - sites(s)%fmort_rate_canopy(i_scls, i_pft) - hio_mortality_canopy_si_scls(io_si,i_scls) = hio_mortality_canopy_si_scls(io_si,i_scls) + & - sites(s)%fmort_rate_canopy(i_scls, i_pft) + hio_seed_bank_elem(io_si,el) = hio_seed_bank_elem(io_si,el) + & + sum(litt%seed(:)) * cpatch%area / m2_per_ha - ! the fire mortality rates for each layer are total dead, since the usable - ! output will then normalize by the counts, we are allowed to sum over layers - hio_mortality_understory_si_scpf(io_si,i_scpf) = hio_mortality_understory_si_scpf(io_si,i_scpf) + & - sites(s)%fmort_rate_ustory(i_scls, i_pft) + hio_seed_germ_elem(io_si,el) = hio_seed_germ_elem(io_si,el) + & + sum(litt%seed_germ(:)) * cpatch%area / m2_per_ha / sec_per_day - hio_mortality_understory_si_scls(io_si,i_scls) = hio_mortality_understory_si_scls(io_si,i_scls) + & - sites(s)%fmort_rate_ustory(i_scls, i_pft) + hio_seed_decay_elem(io_si,el) = hio_seed_decay_elem(io_si,el) + & + sum(litt%seed_decay(:) + litt%seed_germ_decay(:) ) * & + cpatch%area / m2_per_ha / sec_per_day - ! - ! carbon flux associated with mortality of trees dying by fire - hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & - sites(s)%fmort_carbonflux_canopy - - hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & - sites(s)%fmort_carbonflux_ustory - - ! - ! for scag variables, also treat as happening in the newly-disurbed patch + hio_seeds_in_local_elem(io_si,el) = hio_seeds_in_local_elem(io_si,el) + & + sum(litt%seed_in_local(:)) * cpatch%area / m2_per_ha / sec_per_day - hio_mortality_canopy_si_scag(io_si,iscag) = hio_mortality_canopy_si_scag(io_si,iscag) + & - sites(s)%fmort_rate_canopy(i_scls, i_pft) - hio_mortality_understory_si_scag(io_si,iscag) = hio_mortality_understory_si_scag(io_si,iscag) + & - sites(s)%fmort_rate_ustory(i_scls, i_pft) + hio_seed_in_extern_elem(io_si,el) = hio_seed_in_extern_elem(io_si,el) + & + sum(litt%seed_in_extern(:)) * cpatch%area / m2_per_ha / sec_per_day - ! while in this loop, pass the fusion-induced growth rate flux to history - hio_growthflux_fusion_si_scpf(io_si,i_scpf) = hio_growthflux_fusion_si_scpf(io_si,i_scpf) + & - sites(s)%growthflux_fusion(i_scls, i_pft) * days_per_year - end do - end do - ! - - ! treat carbon flux from imort the same way - hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & - sites(s)%imort_carbonflux - ! - sites(s)%term_nindivs_canopy(:,:) = 0._r8 - sites(s)%term_nindivs_ustory(:,:) = 0._r8 - sites(s)%imort_carbonflux = 0._r8 - sites(s)%imort_rate(:,:) = 0._r8 - sites(s)%fmort_rate_canopy(:,:) = 0._r8 - sites(s)%fmort_rate_ustory(:,:) = 0._r8 - sites(s)%fmort_carbonflux_canopy = 0._r8 - sites(s)%fmort_carbonflux_ustory = 0._r8 - sites(s)%fmort_rate_cambial(:,:) = 0._r8 - sites(s)%fmort_rate_crown(:,:) = 0._r8 - sites(s)%growthflux_fusion(:,:) = 0._r8 - - ! pass the recruitment rate as a flux to the history, and then reset the recruitment buffer - do i_pft = 1, numpft - hio_recruitment_si_pft(io_si,i_pft) = sites(s)%recruitment_rate(i_pft) * days_per_year - end do - sites(s)%recruitment_rate(:) = 0._r8 - - ! summarize all of the mortality fluxes by PFT - do i_pft = 1, numpft - do i_scls = 1,nlevsclass - i_scpf = (i_pft-1)*nlevsclass + i_scls - - hio_mortality_si_pft(io_si,i_pft) = hio_mortality_si_pft(io_si,i_pft) + & - hio_m1_si_scpf(io_si,i_scpf) + & - hio_m2_si_scpf(io_si,i_scpf) + & - hio_m3_si_scpf(io_si,i_scpf) + & - hio_m4_si_scpf(io_si,i_scpf) + & - hio_m5_si_scpf(io_si,i_scpf) + & - hio_m6_si_scpf(io_si,i_scpf) + & - hio_m7_si_scpf(io_si,i_scpf) + & - hio_m8_si_scpf(io_si,i_scpf) + & - hio_m9_si_scpf(io_si,i_scpf) + & - hio_m10_si_scpf(io_si,i_scpf) - - end do - end do - - ! ------------------------------------------------------------------------------ - ! Some carbon only litter diagnostics (legacy) - ! ------------------------------------------------------------------------------ + ! Litter State Variables + hio_cwd_ag_elem(io_si,el) = hio_cwd_ag_elem(io_si,el) + & + sum(litt%ag_cwd(:)) * cpatch%area / m2_per_ha - flux_diags => sites(s)%flux_diags(element_pos(carbon12_element)) + hio_cwd_bg_elem(io_si,el) = hio_cwd_bg_elem(io_si,el) + & + sum(litt%bg_cwd(:,:)) * cpatch%area / m2_per_ha - hio_litter_in_si(io_si) = (sum(flux_diags%cwd_ag_input(:)) + & - sum(flux_diags%cwd_bg_input(:)) + & - sum(flux_diags%leaf_litter_input(:)) + & - sum(flux_diags%root_litter_input(:))) * & - g_per_kg * AREA_INV * days_per_sec - - hio_litter_out_si(io_si) = 0._r8 - hio_seed_bank_si(io_si) = 0._r8 - hio_seeds_in_si(io_si) = 0._r8 - - cpatch => sites(s)%oldest_patch - do while(associated(cpatch)) - - litt => cpatch%litter(element_pos(carbon12_element)) - - area_frac = cpatch%area * AREA_INV - - ! Sum up all output fluxes (fragmentation) kgC/m2/day -> gC/m2/s - hio_litter_out_si(io_si) = hio_litter_out_si(io_si) + & - (sum(litt%leaf_fines_frag(:)) + & - sum(litt%root_fines_frag(:,:)) + & - sum(litt%ag_cwd_frag(:)) + & - sum(litt%bg_cwd_frag(:,:))) * & - area_frac * g_per_kg * days_per_sec - - ! Sum up total seed bank (germinated and ungerminated) - hio_seed_bank_si(io_si) = hio_seed_bank_si(io_si) + & - (sum(litt%seed(:))+sum(litt%seed_germ(:))) * & - area_frac * g_per_kg * days_per_sec - - ! Sum up the input flux into the seed bank (local and external) - hio_seeds_in_si(io_si) = hio_seeds_in_si(io_si) + & - (sum(litt%seed_in_local(:)) + sum(litt%seed_in_extern(:))) * & - area_frac * g_per_kg * days_per_sec - - cpatch => cpatch%younger - end do - + hio_fines_ag_elem(io_si,el) = hio_fines_ag_elem(io_si,el) + & + sum(litt%leaf_fines(:)) * cpatch%area / m2_per_ha - ! ------------------------------------------------------------------------------ - ! Diagnostics discretized by element type - ! ------------------------------------------------------------------------------ + hio_fines_bg_elem(io_si,el) = hio_fines_bg_elem(io_si,el) + & + sum(litt%root_fines(:,:)) * cpatch%area / m2_per_ha - hio_cwd_elcwd(io_si,:) = 0._r8 + do cwd=1,ncwd + elcwd = (el-1)*ncwd+cwd + hio_cwd_elcwd(io_si,elcwd) = hio_cwd_elcwd(io_si,elcwd) + & + (litt%ag_cwd(cwd) + sum(litt%bg_cwd(cwd,:))) * & + cpatch%area / m2_per_ha - do el = 1, num_elements - - flux_diags => sites(s)%flux_diags(el) - - ! Sum up all input litter fluxes (above below, fines, cwd) [kg/ha/day] - hio_litter_in_elem(io_si, el) = & - sum(flux_diags%cwd_ag_input(:)) + & - sum(flux_diags%cwd_bg_input(:)) + & - sum(flux_diags%leaf_litter_input(:)) + & - sum(flux_diags%root_litter_input(:)) - - hio_cwd_ag_elem(io_si,el) = 0._r8 - hio_cwd_bg_elem(io_si,el) = 0._r8 - hio_fines_ag_elem(io_si,el) = 0._r8 - hio_fines_bg_elem(io_si,el) = 0._r8 - - hio_seed_bank_elem(io_si,el) = 0._r8 - hio_seed_germ_elem(io_si,el) = 0._r8 - hio_seed_decay_elem(io_si,el) = 0._r8 - hio_seeds_in_local_elem(io_si,el) = 0._r8 - hio_seed_in_extern_elem(io_si,el) = 0._r8 - hio_litter_out_elem(io_si,el) = 0._r8 - - ! Plant multi-element states and fluxes - ! Zero states, and set the fluxes - if(element_list(el).eq.carbon12_element)then - this%hvars(ih_totvegc_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_leafc_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_fnrtc_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_sapwc_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_storec_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_reproc_scpf)%r82d(io_si,:) = 0._r8 - - this%hvars(ih_cefflux_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) - - this%hvars(ih_cefflux_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) - - elseif(element_list(el).eq.nitrogen_element)then - - this%hvars(ih_totvegn_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_leafn_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_fnrtn_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_sapwn_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_storen_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_repron_scpf)%r82d(io_si,:) = 0._r8 + end do - this%hvars(ih_nuptake_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_uptake_scpf(:) + ! Load Mass States + ccohort => cpatch%tallest + do while(associated(ccohort)) - this%hvars(ih_nefflux_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) + sapw_m = ccohort%prt%GetState(sapw_organ, element_list(el)) + struct_m = ccohort%prt%GetState(struct_organ, element_list(el)) + leaf_m = ccohort%prt%GetState(leaf_organ, element_list(el)) + fnrt_m = ccohort%prt%GetState(fnrt_organ, element_list(el)) + store_m = ccohort%prt%GetState(store_organ, element_list(el)) + repro_m = ccohort%prt%GetState(repro_organ, element_list(el)) + total_m = sapw_m+struct_m+leaf_m+fnrt_m+store_m+repro_m + + + i_scpf = ccohort%size_by_pft_class + + if(element_list(el).eq.carbon12_element)then + this%hvars(ih_totvegc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_totvegc_scpf)%r82d(io_si,i_scpf) + & + total_m * ccohort%n / m2_per_ha + this%hvars(ih_leafc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_leafc_scpf)%r82d(io_si,i_scpf) + & + leaf_m * ccohort%n / m2_per_ha + this%hvars(ih_fnrtc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_fnrtc_scpf)%r82d(io_si,i_scpf) + & + fnrt_m * ccohort%n / m2_per_ha + this%hvars(ih_sapwc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_sapwc_scpf)%r82d(io_si,i_scpf) + & + sapw_m * ccohort%n / m2_per_ha + this%hvars(ih_storec_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storec_scpf)%r82d(io_si,i_scpf) + & + store_m * ccohort%n / m2_per_ha + this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) + & + repro_m * ccohort%n / m2_per_ha + elseif(element_list(el).eq.nitrogen_element)then + + store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) + + this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) + & + total_m * ccohort%n / m2_per_ha + this%hvars(ih_leafn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_leafn_scpf)%r82d(io_si,i_scpf) + & + leaf_m * ccohort%n / m2_per_ha + this%hvars(ih_fnrtn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_fnrtn_scpf)%r82d(io_si,i_scpf) + & + fnrt_m * ccohort%n / m2_per_ha + this%hvars(ih_sapwn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_sapwn_scpf)%r82d(io_si,i_scpf) + & + sapw_m * ccohort%n / m2_per_ha + this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) + & + store_m * ccohort%n / m2_per_ha + this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) + & + repro_m * ccohort%n / m2_per_ha - this%hvars(ih_nneedgrow_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_needgrow_scpf(:) + if (ccohort%canopy_layer .eq. 1) then + this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n + else + this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n + end if - this%hvars(ih_nneedmax_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_needmax_scpf(:) - - this%hvars(ih_nneedgrow_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_needgrow_scpf(:),dim=1) + elseif(element_list(el).eq.phosphorus_element)then + + store_max = ccohort%prt%GetNutrientTarget(element_list(el),store_organ) + + this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) + & + total_m * ccohort%n / m2_per_ha + this%hvars(ih_leafp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_leafp_scpf)%r82d(io_si,i_scpf) + & + leaf_m * ccohort%n / m2_per_ha + this%hvars(ih_fnrtp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_fnrtp_scpf)%r82d(io_si,i_scpf) + & + fnrt_m * ccohort%n / m2_per_ha + this%hvars(ih_sapwp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_sapwp_scpf)%r82d(io_si,i_scpf) + & + sapw_m * ccohort%n / m2_per_ha + this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) + & + store_m * ccohort%n / m2_per_ha + this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) + & + repro_m * ccohort%n / m2_per_ha - this%hvars(ih_nneedmax_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_needmax_scpf(:),dim=1) + if (ccohort%canopy_layer .eq. 1) then + this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n + else + this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) + store_m/store_max * ccohort%n + end if - this%hvars(ih_nuptake_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_uptake_scpf(:),dim=1) + end if - this%hvars(ih_nefflux_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) - - - elseif(element_list(el).eq.phosphorus_element)then - this%hvars(ih_totvegp_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_leafp_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_fnrtp_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_sapwp_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_storep_scpf)%r82d(io_si,:) = 0._r8 - this%hvars(ih_reprop_scpf)%r82d(io_si,:) = 0._r8 - - this%hvars(ih_puptake_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_uptake_scpf(:) - - this%hvars(ih_pefflux_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) - - this%hvars(ih_pneedgrow_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_needgrow_scpf(:) + ccohort => ccohort%shorter + end do ! end cohort loop - this%hvars(ih_pneedmax_scpf)%r82d(io_si,:) = & - sites(s)%flux_diags(el)%nutrient_needmax_scpf(:) + cpatch => cpatch%younger + end do ! end patch loop - this%hvars(ih_pneedgrow_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_needgrow_scpf(:),dim=1) + end do ! end element loop - this%hvars(ih_pneedmax_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_needmax_scpf(:),dim=1) + ! Normalize nutrient storage fractions - this%hvars(ih_puptake_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_uptake_scpf(:),dim=1) - - this%hvars(ih_pefflux_si)%r81d(io_si) = & - sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) - + do el = 1, num_elements + if(element_list(el).eq.nitrogen_element)then + if( this%hvars(ih_storentfrac_si)%r81d(io_si)>nearzero ) then + this%hvars(ih_storentfrac_si)%r81d(io_si) = this%hvars(ih_storen_si)%r81d(io_si) / & + this%hvars(ih_storentfrac_si)%r81d(io_si) end if + do i_pft = 1, numpft + do i_scls = 1,nlevsclass + i_scpf = (i_pft-1)*nlevsclass + i_scls + + if( hio_nplant_canopy_si_scpf(io_si,i_scpf)>nearzero ) then + this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storentfrac_canopy_scpf)%r82d(io_si,i_scpf) / & + (hio_nplant_canopy_si_scpf(io_si,i_scpf)*m2_per_ha) + end if - - cpatch => sites(s)%oldest_patch - do while(associated(cpatch)) - - litt => cpatch%litter(el) - - area_frac = cpatch%area * AREA_INV - - ! Sum up all output fluxes (fragmentation) - hio_litter_out_elem(io_si,el) = hio_litter_out_elem(io_si,el) + & - (sum(litt%leaf_fines_frag(:)) + & - sum(litt%root_fines_frag(:,:)) + & - sum(litt%ag_cwd_frag(:)) + & - sum(litt%bg_cwd_frag(:,:))) * cpatch%area - - hio_seed_bank_elem(io_si,el) = hio_seed_bank_elem(io_si,el) + & - sum(litt%seed(:)) * cpatch%area - - hio_seed_germ_elem(io_si,el) = hio_seed_germ_elem(io_si,el) + & - sum(litt%seed_germ(:)) * cpatch%area - - hio_seed_decay_elem(io_si,el) = hio_seed_decay_elem(io_si,el) + & - sum(litt%seed_decay(:)) * cpatch%area - - hio_seeds_in_local_elem(io_si,el) = hio_seeds_in_local_elem(io_si,el) + & - sum(litt%seed_in_local(:)) * cpatch%area - - hio_seed_in_extern_elem(io_si,el) = hio_seed_in_extern_elem(io_si,el) + & - sum(litt%seed_in_extern(:)) * cpatch%area - - ! Litter State Variables - hio_cwd_ag_elem(io_si,el) = hio_cwd_ag_elem(io_si,el) + & - sum(litt%ag_cwd(:)) * cpatch%area - - hio_cwd_bg_elem(io_si,el) = hio_cwd_bg_elem(io_si,el) + & - sum(litt%bg_cwd(:,:)) * cpatch%area - - hio_fines_ag_elem(io_si,el) = hio_fines_ag_elem(io_si,el) + & - sum(litt%leaf_fines(:)) * cpatch%area - - hio_fines_bg_elem(io_si,el) = hio_fines_bg_elem(io_si,el) + & - sum(litt%root_fines(:,:)) * cpatch%area - - do cwd=1,ncwd - elcwd = (el-1)*ncwd+cwd - hio_cwd_elcwd(io_si,elcwd) = hio_cwd_elcwd(io_si,elcwd) + & - (litt%ag_cwd(cwd) + sum(litt%bg_cwd(cwd,:))) * cpatch%area + if( hio_nplant_understory_si_scpf(io_si,i_scpf)>nearzero ) then + this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storentfrac_understory_scpf)%r82d(io_si,i_scpf) / & + (hio_nplant_understory_si_scpf(io_si,i_scpf)*m2_per_ha) + end if end do + end do + elseif(element_list(el).eq.phosphorus_element)then + if( this%hvars(ih_storeptfrac_si)%r81d(io_si)>nearzero ) then + this%hvars(ih_storeptfrac_si)%r81d(io_si) = this%hvars(ih_storep_si)%r81d(io_si) / & + this%hvars(ih_storeptfrac_si)%r81d(io_si) + end if + do i_pft = 1, numpft + do i_scls = 1,nlevsclass + i_scpf = (i_pft-1)*nlevsclass + i_scls + + if( hio_nplant_canopy_si_scpf(io_si,i_scpf)>nearzero ) then + this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storeptfrac_canopy_scpf)%r82d(io_si,i_scpf) /& + (hio_nplant_canopy_si_scpf(io_si,i_scpf)*m2_per_ha) - ! Load Mass States - ccohort => cpatch%tallest - do while(associated(ccohort)) - - sapw_m = ccohort%prt%GetState(sapw_organ, element_list(el)) - struct_m = ccohort%prt%GetState(struct_organ, element_list(el)) - leaf_m = ccohort%prt%GetState(leaf_organ, element_list(el)) - fnrt_m = ccohort%prt%GetState(fnrt_organ, element_list(el)) - store_m = ccohort%prt%GetState(store_organ, element_list(el)) - repro_m = ccohort%prt%GetState(repro_organ, element_list(el)) - total_m = sapw_m+struct_m+leaf_m+fnrt_m+store_m+repro_m - - i_scpf = ccohort%size_by_pft_class - - if(element_list(el).eq.carbon12_element)then - this%hvars(ih_totvegc_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_totvegc_scpf)%r82d(io_si,i_scpf) + total_m * ccohort%n - this%hvars(ih_leafc_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_leafc_scpf)%r82d(io_si,i_scpf) + leaf_m * ccohort%n - this%hvars(ih_fnrtc_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_fnrtc_scpf)%r82d(io_si,i_scpf) + fnrt_m * ccohort%n - this%hvars(ih_sapwc_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_sapwc_scpf)%r82d(io_si,i_scpf) + sapw_m * ccohort%n - this%hvars(ih_storec_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storec_scpf)%r82d(io_si,i_scpf) + store_m * ccohort%n - this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) + repro_m * ccohort%n - elseif(element_list(el).eq.nitrogen_element)then - this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) + total_m * ccohort%n - this%hvars(ih_leafn_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_leafn_scpf)%r82d(io_si,i_scpf) + leaf_m * ccohort%n - this%hvars(ih_fnrtn_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_fnrtn_scpf)%r82d(io_si,i_scpf) + fnrt_m * ccohort%n - this%hvars(ih_sapwn_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_sapwn_scpf)%r82d(io_si,i_scpf) + sapw_m * ccohort%n - this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) + store_m * ccohort%n - this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) + repro_m * ccohort%n - elseif(element_list(el).eq.phosphorus_element)then - this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) + total_m * ccohort%n - this%hvars(ih_leafp_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_leafp_scpf)%r82d(io_si,i_scpf) + leaf_m * ccohort%n - this%hvars(ih_fnrtp_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_fnrtp_scpf)%r82d(io_si,i_scpf) + fnrt_m * ccohort%n - this%hvars(ih_sapwp_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_sapwp_scpf)%r82d(io_si,i_scpf) + sapw_m * ccohort%n - this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) + store_m * ccohort%n - this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) = & - this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) + repro_m * ccohort%n end if - - ccohort => ccohort%shorter + if( hio_nplant_understory_si_scpf(io_si,i_scpf)>nearzero ) then + this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storeptfrac_understory_scpf)%r82d(io_si,i_scpf) /& + (hio_nplant_understory_si_scpf(io_si,i_scpf)*m2_per_ha) + end if + end do - - cpatch => cpatch%younger end do + end if + end do - end do - - + ! pass demotion rates and associated carbon fluxes to history + do i_scls = 1,nlevsclass + hio_demotion_rate_si_scls(io_si,i_scls) = sites(s)%demotion_rate(i_scls) * days_per_year / m2_per_ha + hio_promotion_rate_si_scls(io_si,i_scls) = sites(s)%promotion_rate(i_scls) * days_per_year / m2_per_ha + end do + ! + ! convert kg C / ha / day to kgc / m2 / sec + hio_demotion_carbonflux_si(io_si) = sites(s)%demotion_carbonflux * ha_per_m2 * days_per_sec + hio_promotion_carbonflux_si(io_si) = sites(s)%promotion_carbonflux * ha_per_m2 * days_per_sec + ! + ! mortality-associated carbon fluxes + hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & + sites(s)%term_carbonflux_canopy * days_per_sec * ha_per_m2 - - ! pass demotion rates and associated carbon fluxes to history - do i_scls = 1,nlevsclass - hio_demotion_rate_si_scls(io_si,i_scls) = sites(s)%demotion_rate(i_scls) * days_per_year - hio_promotion_rate_si_scls(io_si,i_scls) = sites(s)%promotion_rate(i_scls) * days_per_year - 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)%term_carbonflux_canopy * g_per_kg * days_per_sec * ha_per_m2 - - hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & - sites(s)%term_carbonflux_ustory * g_per_kg * days_per_sec * ha_per_m2 + hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & + sites(s)%term_carbonflux_ustory * days_per_sec * ha_per_m2 - ! and zero the site-level termination carbon flux variable - sites(s)%term_carbonflux_canopy = 0._r8 - sites(s)%term_carbonflux_ustory = 0._r8 - ! + ! and zero the site-level termination carbon flux variable + sites(s)%term_carbonflux_canopy = 0._r8 + sites(s)%term_carbonflux_ustory = 0._r8 + ! - ! add the site-level disturbance-associated cwd and litter input fluxes to thir respective flux fields + ! add the site-level disturbance-associated cwd and litter input fluxes to thir respective flux fields - do i_cwd = 1, ncwd - hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) + & - flux_diags_c%cwd_ag_input(i_cwd) * g_per_kg - - hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) + & - flux_diags_c%cwd_bg_input(i_cwd) * g_per_kg + do i_cwd = 1, ncwd + hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) = hio_cwd_ag_in_si_cwdsc(io_si, i_cwd) + & + flux_diags_c%cwd_ag_input(i_cwd) / days_per_year / sec_per_day - end do + hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) = hio_cwd_bg_in_si_cwdsc(io_si, i_cwd) + & + flux_diags_c%cwd_bg_input(i_cwd) / days_per_year / sec_per_day - ! and reset the disturbance-related field buffers + end do - do el = 1, num_elements - call sites(s)%flux_diags(el)%ZeroFluxDiags() - end do + enddo siteloop ! site loop - enddo ! site loop - - end associate + end associate - return + return end subroutine update_history_dyn - + subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! --------------------------------------------------------------------------------- ! This is the call to update the history IO arrays that are expected to only change ! after rapid timescale productivity calculations (gpp and respiration). ! --------------------------------------------------------------------------------- - + use EDTypesMod , only : nclmax, nlevleaf ! ! Arguments @@ -3356,14 +3474,11 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) type(ed_site_type) , intent(inout), target :: sites(nsites) type(bc_in_type) , intent(in) :: bc_in(nsites) real(r8) , intent(in) :: dt_tstep - + ! Locals integer :: s ! The local site index integer :: io_si ! The site index of the IO array - integer :: ipa ! The local "I"ndex of "PA"tches - integer :: 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 :: ipa ! The local "I"ndex of "PA"tches integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread integer :: ivar ! index of IO variable object vector integer :: ft ! functional type index @@ -3388,7 +3503,9 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_growth_resp_si => this%hvars(ih_growth_resp_si)%r81d, & hio_c_stomata_si => this%hvars(ih_c_stomata_si)%r81d, & hio_c_lblayer_si => this%hvars(ih_c_lblayer_si)%r81d, & - hio_nep_si => this%hvars(ih_nep_si)%r81d, & + hio_rad_error_si => this%hvars(ih_rad_error_si)%r81d, & + hio_nep_si => this%hvars(ih_nep_si)%r81d, & + hio_hr_si => this%hvars(ih_hr_si)%r81d, & hio_ar_si_scpf => this%hvars(ih_ar_si_scpf)%r82d, & 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, & @@ -3448,23 +3565,23 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_fabi_sun_top_si_can => this%hvars(ih_fabi_sun_top_si_can)%r82d, & hio_fabi_sha_top_si_can => this%hvars(ih_fabi_sha_top_si_can)%r82d, & hio_parsun_top_si_can => this%hvars(ih_parsun_top_si_can)%r82d, & - hio_parsha_top_si_can => this%hvars(ih_parsha_top_si_can)%r82d & - ) - - - ! Flush the relevant history variables + hio_parsha_top_si_can => this%hvars(ih_parsha_top_si_can)%r82d, & + hio_tveg => this%hvars(ih_tveg_si)%r81d) + + ! 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 - - hio_nep_si(io_si) = -bc_in(s)%tot_het_resp ! (gC/m2/s) - + + call this%zero_site_hvars(sites(s), upfreq_in=2) + + io_si = sites(s)%h_gid + + hio_nep_si(io_si) = -bc_in(s)%tot_het_resp / g_per_kg ! (kgC/m2/s) + hio_hr_si(io_si) = bc_in(s)%tot_het_resp / g_per_kg + ipa = 0 cpatch => sites(s)%oldest_patch @@ -3472,8 +3589,6 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) canopy_area_by_age(1:nlevage) = 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 @@ -3484,142 +3599,149 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! Canopy resitance terms hio_c_stomata_si_age(io_si,cpatch%age_class) = & hio_c_stomata_si_age(io_si,cpatch%age_class) + & - cpatch%c_stomata * cpatch%total_canopy_area - + cpatch%c_stomata * cpatch%total_canopy_area / umol_per_mol + hio_c_lblayer_si_age(io_si,cpatch%age_class) = & hio_c_lblayer_si_age(io_si,cpatch%age_class) + & - cpatch%c_lblayer * cpatch%total_canopy_area - + cpatch%c_lblayer * cpatch%total_canopy_area / umol_per_mol + hio_c_stomata_si(io_si) = hio_c_stomata_si(io_si) + & - cpatch%c_stomata * cpatch%total_canopy_area - + cpatch%c_stomata * cpatch%total_canopy_area / umol_per_mol + hio_c_lblayer_si(io_si) = hio_c_lblayer_si(io_si) + & - cpatch%c_lblayer * cpatch%total_canopy_area + cpatch%c_lblayer * cpatch%total_canopy_area / umol_per_mol + hio_rad_error_si(io_si) = hio_rad_error_si(io_si) + & + cpatch%radiation_error * cpatch%area * AREA_INV + + hio_tveg(io_si) = hio_tveg(io_si) + & + (bc_in(s)%t_veg_pa(cpatch%patchno) - t_water_freeze_k_1atm)*cpatch%area*area_inv + ccohort => cpatch%shortest do while(associated(ccohort)) - + n_perm2 = ccohort%n * AREA_INV - + if ( .not. ccohort%isnew ) then npp = ccohort%npp_tstep resp_g = ccohort%resp_g_tstep aresp = ccohort%resp_tstep - + ! Calculate index for the scpf class associate( scpf => ccohort%size_by_pft_class, & scls => ccohort%size_class ) - + ! scale up cohort fluxes to the site level hio_npp_si(io_si) = hio_npp_si(io_si) + & - npp * g_per_kg * n_perm2 * per_dt_tstep - + npp * n_perm2 * per_dt_tstep + hio_gpp_si(io_si) = hio_gpp_si(io_si) + & - ccohort%gpp_tstep * g_per_kg * n_perm2 * per_dt_tstep + ccohort%gpp_tstep * n_perm2 * per_dt_tstep hio_aresp_si(io_si) = hio_aresp_si(io_si) + & - aresp * g_per_kg * n_perm2 * per_dt_tstep + aresp * n_perm2 * per_dt_tstep hio_growth_resp_si(io_si) = hio_growth_resp_si(io_si) + & - resp_g * g_per_kg * n_perm2 * per_dt_tstep + resp_g * n_perm2 * per_dt_tstep hio_maint_resp_si(io_si) = hio_maint_resp_si(io_si) + & - ccohort%resp_m * g_per_kg * n_perm2 * per_dt_tstep + ccohort%resp_m * n_perm2 * per_dt_tstep ! Add up the total Net Ecosystem Production - ! for this timestep. [gC/m2/s] + ! for this timestep. [kgC/m2/s] hio_nep_si(io_si) = hio_nep_si(io_si) + & - npp * g_per_kg * n_perm2 * per_dt_tstep + npp * n_perm2 * per_dt_tstep ! aggregate MR fluxes to the site level hio_leaf_mr_si(io_si) = hio_leaf_mr_si(io_si) + ccohort%rdark & - * n_perm2 * sec_per_day * days_per_year + * n_perm2 hio_froot_mr_si(io_si) = hio_froot_mr_si(io_si) + ccohort%froot_mr & - * n_perm2 * sec_per_day * days_per_year + * n_perm2 hio_livecroot_mr_si(io_si) = hio_livecroot_mr_si(io_si) + ccohort%livecroot_mr & - * n_perm2 * sec_per_day * days_per_year + * n_perm2 hio_livestem_mr_si(io_si) = hio_livestem_mr_si(io_si) + ccohort%livestem_mr & - * n_perm2 * sec_per_day * days_per_year + * n_perm2 - ! Total AR (kgC/m2/yr) = (kgC/plant/step) / (s/step) * (plant/m2) * (s/yr) + ! Total AR (kgC/m2/s) = (kgC/plant/step) / (s/step) * (plant/m2) hio_ar_si_scpf(io_si,scpf) = hio_ar_si_scpf(io_si,scpf) + & - (ccohort%resp_tstep/dt_tstep) * n_perm2 * sec_per_day * days_per_year + (ccohort%resp_tstep/dt_tstep) * n_perm2 - ! Growth AR (kgC/m2/yr) + ! Growth AR (kgC/m2/s) hio_ar_grow_si_scpf(io_si,scpf) = hio_ar_grow_si_scpf(io_si,scpf) + & - (resp_g/dt_tstep) * n_perm2 * sec_per_day * days_per_year + (resp_g/dt_tstep) * n_perm2 - ! Maint AR (kgC/m2/yr) + ! Maint AR (kgC/m2/s) hio_ar_maint_si_scpf(io_si,scpf) = hio_ar_maint_si_scpf(io_si,scpf) + & - (ccohort%resp_m/dt_tstep) * n_perm2 * sec_per_day * days_per_year - + (ccohort%resp_m/dt_tstep) * n_perm2 + ! Maintenance AR partition variables are stored as rates (kgC/plant/s) - ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + ! (kgC/m2/s) = (kgC/plant/s) * (plant/m2) hio_ar_agsapm_si_scpf(io_si,scpf) = hio_ar_agsapm_si_scpf(io_si,scpf) + & - ccohort%livestem_mr * n_perm2 * sec_per_day * days_per_year + ccohort%livestem_mr * n_perm2 - ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + ! (kgC/m2/s) = (kgC/plant/s) * (plant/m2) hio_ar_darkm_si_scpf(io_si,scpf) = hio_ar_darkm_si_scpf(io_si,scpf) + & - ccohort%rdark * n_perm2 * sec_per_day * days_per_year + ccohort%rdark * n_perm2 - ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + ! (kgC/m2/s) = (kgC/plant/s) * (plant/m2) hio_ar_crootm_si_scpf(io_si,scpf) = hio_ar_crootm_si_scpf(io_si,scpf) + & - ccohort%livecroot_mr * n_perm2 * sec_per_day * days_per_year + ccohort%livecroot_mr * n_perm2 - ! (kgC/m2/yr) = (kgC/plant/s) * (plant/m2) * (s/yr) + ! (kgC/m2/s) = (kgC/plant/s) * (plant/m2) hio_ar_frootm_si_scpf(io_si,scpf) = hio_ar_frootm_si_scpf(io_si,scpf) + & - ccohort%froot_mr * n_perm2 * sec_per_day * days_per_year + ccohort%froot_mr * n_perm2 ! accumulate fluxes per patch age bin hio_gpp_si_age(io_si,cpatch%age_class) = hio_gpp_si_age(io_si,cpatch%age_class) & - + ccohort%gpp_tstep * ccohort%n * g_per_kg * per_dt_tstep + + ccohort%gpp_tstep * ccohort%n * per_dt_tstep hio_npp_si_age(io_si,cpatch%age_class) = hio_npp_si_age(io_si,cpatch%age_class) & - + npp * ccohort%n * g_per_kg * per_dt_tstep + + npp * ccohort%n * per_dt_tstep ! accumulate fluxes on canopy- and understory- separated fluxes if (ccohort%canopy_layer .eq. 1) then ! ! bulk fluxes are in gC / m2 / s hio_gpp_canopy_si(io_si) = hio_gpp_canopy_si(io_si) + & - ccohort%gpp_tstep * g_per_kg * n_perm2 * per_dt_tstep + ccohort%gpp_tstep * n_perm2 * per_dt_tstep hio_ar_canopy_si(io_si) = hio_ar_canopy_si(io_si) + & - aresp * g_per_kg * n_perm2 * per_dt_tstep + aresp * n_perm2 * per_dt_tstep ! - ! size-resolved respiration fluxes are in kg C / ha / yr + ! size-resolved respiration fluxes are in kg C / m2 / s hio_rdark_canopy_si_scls(io_si,scls) = hio_rdark_canopy_si_scls(io_si,scls) + & - ccohort%rdark * ccohort%n * sec_per_day * days_per_year + ccohort%rdark * ccohort%n / m2_per_ha hio_livestem_mr_canopy_si_scls(io_si,scls) = hio_livestem_mr_canopy_si_scls(io_si,scls) + & - ccohort%livestem_mr * ccohort%n * sec_per_day * days_per_year + ccohort%livestem_mr * ccohort%n / m2_per_ha hio_livecroot_mr_canopy_si_scls(io_si,scls) = hio_livecroot_mr_canopy_si_scls(io_si,scls) + & - ccohort%livecroot_mr * ccohort%n * sec_per_day * days_per_year + ccohort%livecroot_mr * ccohort%n / m2_per_ha hio_froot_mr_canopy_si_scls(io_si,scls) = hio_froot_mr_canopy_si_scls(io_si,scls) + & - ccohort%froot_mr * ccohort%n * sec_per_day * days_per_year + ccohort%froot_mr * ccohort%n / m2_per_ha + hio_resp_g_canopy_si_scls(io_si,scls) = hio_resp_g_canopy_si_scls(io_si,scls) + & - resp_g * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + resp_g * ccohort%n * per_dt_tstep / m2_per_ha hio_resp_m_canopy_si_scls(io_si,scls) = hio_resp_m_canopy_si_scls(io_si,scls) + & - ccohort%resp_m * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + ccohort%resp_m * ccohort%n * per_dt_tstep / m2_per_ha else ! ! bulk fluxes are in gC / m2 / s hio_gpp_understory_si(io_si) = hio_gpp_understory_si(io_si) + & - ccohort%gpp_tstep * g_per_kg * n_perm2 * per_dt_tstep + ccohort%gpp_tstep * n_perm2 * per_dt_tstep hio_ar_understory_si(io_si) = hio_ar_understory_si(io_si) + & - aresp * g_per_kg * n_perm2 * per_dt_tstep + aresp * n_perm2 * per_dt_tstep ! - ! size-resolved respiration fluxes are in kg C / ha / yr + ! size-resolved respiration fluxes are in kg C / m2 / s hio_rdark_understory_si_scls(io_si,scls) = hio_rdark_understory_si_scls(io_si,scls) + & - ccohort%rdark * ccohort%n * sec_per_day * days_per_year + ccohort%rdark * ccohort%n / m2_per_ha hio_livestem_mr_understory_si_scls(io_si,scls) = hio_livestem_mr_understory_si_scls(io_si,scls) + & - ccohort%livestem_mr * ccohort%n * sec_per_day * days_per_year + ccohort%livestem_mr * ccohort%n / m2_per_ha hio_livecroot_mr_understory_si_scls(io_si,scls) = hio_livecroot_mr_understory_si_scls(io_si,scls) + & - ccohort%livecroot_mr * ccohort%n * sec_per_day * days_per_year + ccohort%livecroot_mr * ccohort%n / m2_per_ha hio_froot_mr_understory_si_scls(io_si,scls) = hio_froot_mr_understory_si_scls(io_si,scls) + & - ccohort%froot_mr * ccohort%n * sec_per_day * days_per_year + ccohort%froot_mr * ccohort%n / m2_per_ha hio_resp_g_understory_si_scls(io_si,scls) = hio_resp_g_understory_si_scls(io_si,scls) + & - resp_g * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + resp_g * ccohort%n * per_dt_tstep / m2_per_ha hio_resp_m_understory_si_scls(io_si,scls) = hio_resp_m_understory_si_scls(io_si,scls) + & - ccohort%resp_m * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + ccohort%resp_m * ccohort%n * per_dt_tstep / m2_per_ha endif end associate endif @@ -3629,7 +3751,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) do ileaf=1,ccohort%nv cnlf_indx = ileaf + (ican-1) * nlevleaf hio_ts_net_uptake_si_cnlf(io_si, cnlf_indx) = hio_ts_net_uptake_si_cnlf(io_si, cnlf_indx) + & - ccohort%ts_net_uptake(ileaf) * g_per_kg * per_dt_tstep * ccohort%c_area / AREA + ccohort%ts_net_uptake(ileaf) * per_dt_tstep * ccohort%c_area / AREA end do ccohort => ccohort%taller @@ -3637,10 +3759,10 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! summarize radiation profiles through the canopy do ipft=1,numpft - do ican=1,nclmax ! cpatch%ncl_p ? - do ileaf=1,nlevleaf ! cpatch%ncan(ican,ipft) ? + do ican=1,cpatch%ncl_p + do ileaf=1,cpatch%ncan(ican,ipft) ! calculate where we are on multiplexed dimensions - cnlfpft_indx = ileaf + (ican-1) * nlevleaf + (ipft-1) * nlevleaf * nclmax + 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 @@ -3711,11 +3833,12 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) cpatch%fabi_sha_z(ican,ipft,1) * cpatch%area * AREA_INV ! end do - end do + end do ! PFT-mean radiation profiles - do ican=1,nclmax - do ileaf=1,nlevleaf + do ican = 1, cpatch%ncl_p + do ileaf = 1, maxval(cpatch%nrad(ican,:)) + ! calculate where we are on multiplexed dimensions cnlf_indx = ileaf + (ican-1) * nlevleaf ! @@ -3750,9 +3873,9 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) hio_c_stomata_si_age(io_si,ipa2) = 0._r8 hio_c_lblayer_si_age(io_si,ipa2) = 0._r8 end if - + end do - + ! Normalize resistance diagnostics if ( sum(canopy_area_by_age(1:nlevage)) .gt. tiny) then hio_c_stomata_si(io_si) = hio_c_stomata_si(io_si) / sum(canopy_area_by_age(1:nlevage)) @@ -3765,7 +3888,7 @@ subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) enddo ! site loop end associate - + end subroutine update_history_hifrq ! ===================================================================================== @@ -3776,12 +3899,12 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) ! This is the call to update the history IO arrays that are expected to only change ! after rapid timescale productivity calculations (gpp and respiration). ! --------------------------------------------------------------------------------- - + use FatesHydraulicsMemMod, only : ed_cohort_hydr_type, nshell use FatesHydraulicsMemMod, only : ed_site_hydr_type use EDTypesMod , only : maxpft - + ! Arguments class(fates_history_interface_type) :: this integer , intent(in) :: nc ! clump index @@ -3789,11 +3912,11 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) type(ed_site_type) , intent(inout), target :: sites(nsites) type(bc_in_type) , intent(in) :: bc_in(nsites) real(r8) , intent(in) :: dt_tstep - + ! Locals integer :: s ! The local site index integer :: io_si ! The site index of the IO array - integer :: ipa ! The local "I"ndex of "PA"tches + integer :: ipa ! The local "I"ndex of "PA"tches integer :: ft ! functional type index ! integer :: io_shsl ! The combined "SH"ell "S"oil "L"ayer index in the IO array real(r8), parameter :: tiny = 1.e-5_r8 ! some small number @@ -3810,10 +3933,11 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) integer :: ipft ! index of the pft loop integer :: iscls ! index of the size-class loop integer :: k ! rhizosphere shell index - integer :: jsoil ! soil layer index - integer :: jrhiz ! rhizosphere layer index - integer :: jr1, jr2 ! Rhizosphere top and bottom layers + integer :: j ! rhizosphere (ie root) layer index + integer :: j_bc ! Soil layer index (ie boundary condition grid index) + integer :: j_t,j_b ! top and bottom soil layer matching current rhiz layer integer :: nlevrhiz ! number of rhizosphere layers + integer :: nlevsoil ! number of soil layers real(r8) :: mean_soil_vwc ! mean soil volumetric water content [m3/m3] real(r8) :: mean_soil_vwcsat ! mean soil saturated volumetric water content [m3/m3] real(r8) :: mean_soil_matpot ! mean soil water potential [MPa] @@ -3822,6 +3946,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) real(r8) :: vwc ! volumetric water content of layer [m3/m3] = theta real(r8) :: vwc_sat ! saturated water content of layer [m3/m3] real(r8) :: psi ! matric potential of soil layer + real(r8) :: depth_frac ! fraction of rhizosphere layer depth occupied by current soil layer character(2) :: fmt_char type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort @@ -3835,37 +3960,37 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) real(r8), parameter :: iterh2_dx = 1._r8 real(r8) :: iterh2_histx(iterh2_nhist) real(r8) :: iterh2_histy(iterh2_nhist) - + logical, parameter :: print_iterations = .false. - + if(hlm_use_planthydro.eq.ifalse) return - + associate( hio_errh2o_scpf => this%hvars(ih_errh2o_scpf)%r82d, & hio_tran_scpf => this%hvars(ih_tran_scpf)%r82d, & hio_sapflow_scpf => this%hvars(ih_sapflow_scpf)%r82d, & - hio_sapflow_si => this%hvars(ih_sapflow_si)%r81d, & - hio_iterh1_scpf => this%hvars(ih_iterh1_scpf)%r82d, & - hio_iterh2_scpf => this%hvars(ih_iterh2_scpf)%r82d, & - hio_ath_scpf => this%hvars(ih_ath_scpf)%r82d, & - hio_tth_scpf => this%hvars(ih_tth_scpf)%r82d, & - hio_sth_scpf => this%hvars(ih_sth_scpf)%r82d, & - hio_lth_scpf => this%hvars(ih_lth_scpf)%r82d, & - hio_awp_scpf => this%hvars(ih_awp_scpf)%r82d, & - hio_twp_scpf => this%hvars(ih_twp_scpf)%r82d, & - hio_swp_scpf => this%hvars(ih_swp_scpf)%r82d, & - hio_lwp_scpf => this%hvars(ih_lwp_scpf)%r82d, & - hio_aflc_scpf => this%hvars(ih_aflc_scpf)%r82d, & - hio_tflc_scpf => this%hvars(ih_tflc_scpf)%r82d, & - hio_sflc_scpf => this%hvars(ih_sflc_scpf)%r82d, & - hio_lflc_scpf => this%hvars(ih_lflc_scpf)%r82d, & + hio_sapflow_si => this%hvars(ih_sapflow_si)%r81d, & + hio_iterh1_scpf => this%hvars(ih_iterh1_scpf)%r82d, & + hio_iterh2_scpf => this%hvars(ih_iterh2_scpf)%r82d, & + hio_ath_scpf => this%hvars(ih_ath_scpf)%r82d, & + hio_tth_scpf => this%hvars(ih_tth_scpf)%r82d, & + hio_sth_scpf => this%hvars(ih_sth_scpf)%r82d, & + hio_lth_scpf => this%hvars(ih_lth_scpf)%r82d, & + hio_awp_scpf => this%hvars(ih_awp_scpf)%r82d, & + hio_twp_scpf => this%hvars(ih_twp_scpf)%r82d, & + hio_swp_scpf => this%hvars(ih_swp_scpf)%r82d, & + hio_lwp_scpf => this%hvars(ih_lwp_scpf)%r82d, & + hio_aflc_scpf => this%hvars(ih_aflc_scpf)%r82d, & + hio_tflc_scpf => this%hvars(ih_tflc_scpf)%r82d, & + hio_sflc_scpf => this%hvars(ih_sflc_scpf)%r82d, & + hio_lflc_scpf => this%hvars(ih_lflc_scpf)%r82d, & hio_btran_scpf => this%hvars(ih_btran_scpf)%r82d, & hio_h2oveg_si => this%hvars(ih_h2oveg_si)%r81d, & hio_nplant_si_scpf => this%hvars(ih_nplant_si_scpf)%r82d, & hio_nplant_si_capf => this%hvars(ih_nplant_si_capf)%r82d, & hio_h2oveg_hydro_err_si => this%hvars(ih_h2oveg_hydro_err_si)%r81d, & hio_rootwgt_soilvwc_si => this%hvars(ih_rootwgt_soilvwc_si)%r81d, & - hio_rootwgt_soilvwcsat_si => this%hvars(ih_rootwgt_soilvwcsat_si)%r81d, & + hio_rootwgt_soilvwcsat_si => this%hvars(ih_rootwgt_soilvwcsat_si)%r81d, & hio_rootwgt_soilmatpot_si => this%hvars(ih_rootwgt_soilmatpot_si)%r81d, & hio_soilmatpot_sl => this%hvars(ih_soilmatpot_sl)%r82d, & hio_soilvwc_sl => this%hvars(ih_soilvwc_sl)%r82d, & @@ -3877,7 +4002,7 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) hio_rootuptake50_scpf => this%hvars(ih_rootuptake50_scpf)%r82d, & hio_rootuptake100_scpf => this%hvars(ih_rootuptake100_scpf)%r82d ) - ! Flush the relevant history variables + ! Flush the relevant history variables call this%flush_hvars(nc,upfreq_in=4) if(print_iterations) then @@ -3887,53 +4012,70 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) end if do s = 1,nsites + call this%zero_site_hvars(sites(s),upfreq_in=4) + site_hydr => sites(s)%si_hydr nlevrhiz = site_hydr%nlevrhiz - jr1 = site_hydr%i_rhiz_t - jr2 = site_hydr%i_rhiz_b + nlevsoil = bc_in(s)%nlevsoil + io_si = sites(s)%h_gid - io_si = this%iovar_map(nc)%site_index(s) - hio_h2oveg_si(io_si) = site_hydr%h2oveg hio_h2oveg_hydro_err_si(io_si) = site_hydr%h2oveg_hydro_err - + hio_rootuptake_sl(io_si,1:nlevsoil) = site_hydr%rootuptake_sl(1:nlevsoil) + hio_rootuptake_si(io_si) = sum(site_hydr%rootuptake_sl,dim=1) ! Get column means of some soil diagnostics, these are weighted ! by the amount of fine-root surface area in each layer ! -------------------------------------------------------------------- - + mean_soil_vwc = 0._r8 mean_soil_matpot = 0._r8 mean_soil_vwcsat = 0._r8 areaweight = 0._r8 - - do jrhiz=1,nlevrhiz - - jsoil = jrhiz + jr1-1 - vwc = bc_in(s)%h2o_liqvol_sl(jsoil) - psi = site_hydr%wrf_soil(jrhiz)%p%psi_from_th(vwc) - vwc_sat = bc_in(s)%watsat_sl(jsoil) - layer_areaweight = site_hydr%l_aroot_layer(jrhiz)*pi_const*site_hydr%rs1(jrhiz)**2.0 - mean_soil_vwc = mean_soil_vwc + vwc*layer_areaweight - mean_soil_vwcsat = mean_soil_vwcsat + vwc_sat*layer_areaweight - mean_soil_matpot = mean_soil_matpot + psi*layer_areaweight - areaweight = areaweight + layer_areaweight - - hio_soilmatpot_sl(io_si,jsoil) = psi - hio_soilvwc_sl(io_si,jsoil) = vwc - hio_soilvwcsat_sl(io_si,jsoil) = vwc_sat + + do j=1,nlevrhiz + + j_t = site_hydr%map_r2s(j,1) ! top soil layer matching rhiz layer + j_b = site_hydr%map_r2s(j,2) ! bottom soil layer matching rhiz layer + + do j_bc = j_t,j_b + vwc = bc_in(s)%h2o_liqvol_sl(j_bc) + psi = site_hydr%wrf_soil(j)%p%psi_from_th(vwc) + ! cap capillary pressure + ! psi = max(-1e5_r8,psi) Removing cap as that is inconstistent + ! with model internals and physics. Should + ! implement caps inside the functions + ! if desired. (RGK 12-2021) + vwc_sat = bc_in(s)%watsat_sl(j_bc) + depth_frac = bc_in(s)%dz_sisl(j_bc)/site_hydr%dz_rhiz(j) + + ! If there are any roots, we use root weighting + if(sum(site_hydr%l_aroot_layer(:),dim=1) > nearzero) then + layer_areaweight = site_hydr%l_aroot_layer(j)*depth_frac*pi_const*site_hydr%rs1(j)**2.0 + + ! If there are no roots, we use depth weighting + else + layer_areaweight = bc_in(s)%dz_sisl(j_bc) + endif + + areaweight = areaweight + layer_areaweight + mean_soil_vwc = mean_soil_vwc + vwc*layer_areaweight + mean_soil_vwcsat = mean_soil_vwcsat + vwc_sat*layer_areaweight + mean_soil_matpot = mean_soil_matpot + psi*layer_areaweight + + hio_soilmatpot_sl(io_si,j_bc) = psi * pa_per_mpa + hio_soilvwc_sl(io_si,j_bc) = vwc + hio_soilvwcsat_sl(io_si,j_bc) = vwc_sat + + end do end do hio_rootwgt_soilvwc_si(io_si) = mean_soil_vwc/areaweight hio_rootwgt_soilvwcsat_si(io_si) = mean_soil_vwcsat/areaweight - hio_rootwgt_soilmatpot_si(io_si) = mean_soil_matpot/areaweight + hio_rootwgt_soilmatpot_si(io_si) = mean_soil_matpot/areaweight * pa_per_mpa - hio_rootuptake_si(io_si) = sum(site_hydr%rootuptake_sl,dim=1) - hio_rootuptake_sl(io_si,:) = 0._r8 - hio_rootuptake_sl(io_si,jr1:jr2) = site_hydr%rootuptake_sl(1:nlevrhiz) - hio_rootuptake_si(io_si) = sum(site_hydr%sapflow_scpf) ! Normalization counters nplant_scpf(:) = 0._r8 @@ -3967,18 +4109,18 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) ccohort => ccohort%taller enddo ! cohort loop cpatch => cpatch%younger - end do !patch loop + end do !patch loop end if - + do ipft = 1, numpft do iscls = 1,nlevsclass iscpf = (ipft-1)*nlevsclass + iscls - hio_sapflow_scpf(io_si,iscpf) = site_hydr%sapflow_scpf(iscls, ipft) - hio_rootuptake0_scpf(io_si,iscpf) = site_hydr%rootuptake0_scpf(iscls,ipft) - hio_rootuptake10_scpf(io_si,iscpf) = site_hydr%rootuptake10_scpf(iscls,ipft) - hio_rootuptake50_scpf(io_si,iscpf) = site_hydr%rootuptake50_scpf(iscls,ipft) - hio_rootuptake100_scpf(io_si,iscpf) = site_hydr%rootuptake100_scpf(iscls,ipft) + hio_sapflow_scpf(io_si,iscpf) = site_hydr%sapflow_scpf(iscls, ipft) / m2_per_ha + hio_rootuptake0_scpf(io_si,iscpf) = site_hydr%rootuptake0_scpf(iscls,ipft) / m2_per_ha + hio_rootuptake10_scpf(io_si,iscpf) = site_hydr%rootuptake10_scpf(iscls,ipft) / m2_per_ha + hio_rootuptake50_scpf(io_si,iscpf) = site_hydr%rootuptake50_scpf(iscls,ipft) / m2_per_ha + hio_rootuptake100_scpf(io_si,iscpf) = site_hydr%rootuptake100_scpf(iscls,ipft) / m2_per_ha hio_iterh1_scpf(io_si,iscpf) = 0._r8 hio_iterh2_scpf(io_si,iscpf) = 0._r8 end do @@ -3987,82 +4129,82 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) ipa = 0 cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - + ccohort => cpatch%shortest do while(associated(ccohort)) ccohort_hydr => ccohort%co_hydr - + if ( .not. ccohort%isnew ) then ! Calculate index for the scpf class iscpf = ccohort%size_by_pft_class - + ! scale up cohort fluxes to their sites number_fraction_rate = (ccohort%n / nplant_scpf(iscpf))/dt_tstep - + ! scale cohorts to mean quantity number_fraction = (ccohort%n / nplant_scpf(iscpf)) - + hio_errh2o_scpf(io_si,iscpf) = hio_errh2o_scpf(io_si,iscpf) + & ccohort_hydr%errh2o * number_fraction_rate ! [kg/indiv/s] - + hio_tran_scpf(io_si,iscpf) = hio_tran_scpf(io_si,iscpf) + & (ccohort_hydr%qtop) * number_fraction_rate ! [kg/indiv/s] - + hio_iterh1_scpf(io_si,iscpf) = hio_iterh1_scpf(io_si,iscpf) + & ccohort_hydr%iterh1/ncohort_scpf(iscpf) - + hio_iterh2_scpf(io_si,iscpf) = hio_iterh2_scpf(io_si,iscpf) + & ccohort_hydr%iterh2/ncohort_scpf(iscpf) - + mean_aroot = sum(ccohort_hydr%th_aroot(:)*ccohort_hydr%v_aroot_layer(:)) / & sum(ccohort_hydr%v_aroot_layer(:)) - + hio_ath_scpf(io_si,iscpf) = hio_ath_scpf(io_si,iscpf) + & mean_aroot * number_fraction ! [m3 m-3] - + hio_tth_scpf(io_si,iscpf) = hio_tth_scpf(io_si,iscpf) + & ccohort_hydr%th_troot * number_fraction ! [m3 m-3] - + hio_sth_scpf(io_si,iscpf) = hio_sth_scpf(io_si,iscpf) + & ccohort_hydr%th_ag(2) * number_fraction ! [m3 m-3] - + hio_lth_scpf(io_si,iscpf) = hio_lth_scpf(io_si,iscpf) + & ccohort_hydr%th_ag(1) * number_fraction ! [m3 m-3] mean_aroot = sum(ccohort_hydr%psi_aroot(:)*ccohort_hydr%v_aroot_layer(:)) / & sum(ccohort_hydr%v_aroot_layer(:)) - + hio_awp_scpf(io_si,iscpf) = hio_awp_scpf(io_si,iscpf) + & - mean_aroot * number_fraction ! [MPa] - + mean_aroot * number_fraction * pa_per_mpa ! [Pa] + hio_twp_scpf(io_si,iscpf) = hio_twp_scpf(io_si,iscpf) + & - ccohort_hydr%psi_troot * number_fraction ! [MPa] - + ccohort_hydr%psi_troot * number_fraction * pa_per_mpa ! [Pa] + hio_swp_scpf(io_si,iscpf) = hio_swp_scpf(io_si,iscpf) + & - ccohort_hydr%psi_ag(2) * number_fraction ! [MPa] - + ccohort_hydr%psi_ag(2) * number_fraction * pa_per_mpa ! [Pa] + hio_lwp_scpf(io_si,iscpf) = hio_lwp_scpf(io_si,iscpf) + & - ccohort_hydr%psi_ag(1) * number_fraction ! [MPa] + ccohort_hydr%psi_ag(1) * number_fraction * pa_per_mpa ! [Pa] mean_aroot = sum(ccohort_hydr%ftc_aroot(:)*ccohort_hydr%v_aroot_layer(:)) / & sum(ccohort_hydr%v_aroot_layer(:)) hio_aflc_scpf(io_si,iscpf) = hio_aflc_scpf(io_si,iscpf) + & - mean_aroot * number_fraction - + mean_aroot * number_fraction + hio_tflc_scpf(io_si,iscpf) = hio_tflc_scpf(io_si,iscpf) + & - ccohort_hydr%ftc_troot * number_fraction - + ccohort_hydr%ftc_troot * number_fraction + hio_sflc_scpf(io_si,iscpf) = hio_sflc_scpf(io_si,iscpf) + & - ccohort_hydr%ftc_ag(2) * number_fraction - + ccohort_hydr%ftc_ag(2) * number_fraction + hio_lflc_scpf(io_si,iscpf) = hio_lflc_scpf(io_si,iscpf) + & - ccohort_hydr%ftc_ag(1) * number_fraction - + ccohort_hydr%ftc_ag(1) * number_fraction + hio_btran_scpf(io_si,iscpf) = hio_btran_scpf(io_si,iscpf) + & ccohort_hydr%btran * number_fraction ! [-] - + endif ccohort => ccohort%taller @@ -4073,7 +4215,8 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) if(hlm_use_ed_st3.eq.ifalse) then do iscpf=1,nlevsclass*numpft - if( abs(hio_nplant_si_scpf(io_si, iscpf)-nplant_scpf(iscpf)) > 1.0E-8_r8 ) then + if ((abs(hio_nplant_si_scpf(io_si, iscpf)-(nplant_scpf(iscpf)/m2_per_ha)) > 1.0E-8_r8) .and. & + (hio_nplant_si_scpf(io_si, iscpf) .ne. hlm_hio_ignore_val)) then write(fates_log(),*) 'numpft:',numpft write(fates_log(),*) 'nlevsclass:',nlevsclass write(fates_log(),*) 'scpf:',iscpf @@ -4095,11 +4238,11 @@ subroutine update_history_hydraulics(this,nc,nsites,sites,bc_in,dt_tstep) end if - + enddo ! site loop end associate - + end subroutine update_history_hydraulics ! ==================================================================================== @@ -4110,11 +4253,11 @@ integer function num_history_vars(this) class(fates_history_interface_type), intent(in) :: this num_history_vars = this%num_history_vars_ - + end function num_history_vars - + ! ==================================================================================== - + subroutine initialize_history_vars(this) implicit none @@ -4127,21 +4270,21 @@ subroutine initialize_history_vars(this) ! Allocate the list of history output variable objects allocate(this%hvars(this%num_history_vars())) - + ! construct the object that defines all of the IO variables call this%define_history_vars(initialize_variables=.true.) - + end subroutine initialize_history_vars - + ! ==================================================================================== - + subroutine define_history_vars(this, initialize_variables) - + ! --------------------------------------------------------------------------------- - ! + ! ! REGISTRY OF HISTORY OUTPUT VARIABLES ! - ! This subroutine is called in two contexts, either in count mode or inialize mode + ! This subroutine is called in two contexts, either in count mode or initialize mode ! In count mode, we just walk through the list of registerred variables, compare ! if the variable of interest list the current host model and add it to the count ! if true. This count is used just to allocate the variable space. After this @@ -4154,23 +4297,22 @@ subroutine define_history_vars(this, initialize_variables) ! indices which may not be relevant to FATES, are flushed to this value. So ! in that case, lakes and crops that are not controlled by FATES will zero'd ! and when values are scaled up to the land-grid, the zero's for non FATES will - ! be included. This is good and correct if nothing is there. + ! be included. This is good and correct if nothing is there. ! ! But, what if crops exist in the host model and occupy a fraction of the land-surface ! shared with natural vegetation? In that case, you want to flush your arrays ! with a value that the HLM treats as "do not average" - ! + ! ! If your HLM makes use of, and you want, INTEGER OUTPUT, pass the flushval as ! a real. The applied flush value will use the NINT() intrinsic function ! --------------------------------------------------------------------------------- - use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 - use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_soil_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 use FatesIOVariableKindMod, only : site_coage_pft_r8, site_coage_r8 use FatesIOVariableKindMod, only : site_height_r8, site_agefuel_r8 use FatesInterfaceTypesMod , only : hlm_use_planthydro - + use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 use FatesIOVariableKindMod, only : site_scagpft_r8, site_agepft_r8 @@ -4179,2133 +4321,2682 @@ subroutine define_history_vars(this, initialize_variables) implicit none - + class(fates_history_interface_type), intent(inout) :: this logical, intent(in) :: initialize_variables ! are we 'count'ing or 'initializ'ing? integer :: ivar - character(len=10) :: tempstring - + character(len=10) :: tempstring + ivar=0 - - ! Site level counting variables - call this%set_history_var(vname='ED_NPATCHES', units='none', & - long='Total number of ED patches per site', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_npatches_si) - - call this%set_history_var(vname='ED_NCOHORTS', units='none', & - long='Total number of ED cohorts per site', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_ncohorts_si) - - ! Patch variables - call this%set_history_var(vname='TRIMMING', units='none', & - long='Degree to which canopy expansion is limited by leaf economics', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_trimming_si) - - call this%set_history_var(vname='AREA_PLANT', units='m2/m2', & - long='area occupied by all plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_area_plant_si) - - call this%set_history_var(vname='AREA_TREES', units='m2/m2', & - long='area occupied by woody plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_area_trees_si) - - call this%set_history_var(vname='SITE_COLD_STATUS', units='0,1,2', & - long='Site level cold status, 0=not cold-dec, 1=too cold for leaves, 2=not-too cold', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_site_cstatus_si ) - - call this%set_history_var(vname='SITE_DROUGHT_STATUS', units='0,1,2,3', & - long='Site level drought status, <2 too dry for leaves, >=2 not-too dry', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_site_dstatus_si) - - call this%set_history_var(vname='SITE_GDD', units='degC', & - long='site level growing degree days', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_gdd_si) - - call this%set_history_var(vname='SITE_NCHILLDAYS', units = 'days', & - long='site level number of chill days', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_site_nchilldays_si) - - call this%set_history_var(vname='SITE_NCOLDDAYS', units = 'days', & - long='site level number of cold days', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_site_ncolddays_si) - - call this%set_history_var(vname='SITE_DAYSINCE_COLDLEAFOFF', units='days', & - long='site level days elapsed since cold leaf drop', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_cleafoff_si) - - call this%set_history_var(vname='SITE_DAYSINCE_COLDLEAFON', units='days', & - long='site level days elapsed since cold leaf flush', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_cleafon_si) - - call this%set_history_var(vname='SITE_DAYSINCE_DROUGHTLEAFOFF', units='days', & - long='site level days elapsed since drought leaf drop', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_dleafoff_si) - - call this%set_history_var(vname='SITE_DAYSINCE_DROUGHTLEAFON', units='days', & - long='site level days elapsed since drought leaf flush', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_dleafon_si) - - call this%set_history_var(vname='SITE_MEANLIQVOL_DROUGHTPHEN', units='m3/m3', & - long='site level mean liquid water volume for drought phen', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_meanliqvol_si) - - call this%set_history_var(vname='CANOPY_SPREAD', units='0-1', & - long='Scaling factor between tree basal area and canopy area', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_canopy_spread_si) - - call this%set_history_var(vname='PFTbiomass', units='gC/m2', & - long='total PFT level biomass', use_default='active', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_pft ) - - call this%set_history_var(vname='PFTleafbiomass', units='gC/m2', & - long='total PFT level leaf biomass', use_default='active', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_leafbiomass_si_pft ) - - call this%set_history_var(vname='PFTstorebiomass', units='gC/m2', & - long='total PFT level stored biomass', use_default='active', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_storebiomass_si_pft ) - - call this%set_history_var(vname='PFTcrownarea', units='m2/m2', & - long='total PFT level crown area', use_default='inactive', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_crownarea_si_pft ) - - call this%set_history_var(vname='PFTcanopycrownarea', units='m2/m2', & - long='total PFT-level canopy-layer crown area', use_default='inactive', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_canopycrownarea_si_pft ) - - call this%set_history_var(vname='PFTgpp', units='kg C m-2 y-1', & - long='total PFT-level GPP', use_default='active', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_gpp_si_pft ) - - call this%set_history_var(vname='PFTnpp', units='kg C m-2 y-1', & - long='total PFT-level NPP', use_default='active', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_npp_si_pft ) - - call this%set_history_var(vname='PFTnindivs', units='indiv / m2', & - long='total PFT level number of individuals', use_default='active', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_nindivs_si_pft ) - call this%set_history_var(vname='RECRUITMENT', units='indiv/ha/yr', & - long='Rate of recruitment by PFT', use_default='active', & - avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_recruitment_si_pft ) + ! Variable names should start with the 'FATES_' prefix and end with a suffix + ! depending on how it is indexed (i.e. the dimension): + ! site (site_r8) : no suffix + ! cohort age (site_coage_r8) : AC + ! patch age (site_age_r8) : AP + ! canopy layer (site_can_r8) : CL + ! coarse woody debris size (site_cwdsc_r8) : DC + ! element (site_elem_r8) : EL + ! leaf layer : LL + ! fuel class (site_fuel_r8) : FC + ! height (site_height_r8) : HT + ! plant functional type (site_pft_r8) : PF + ! soil layer (site_soil_r8) : SL + ! cohort size (site_size_r8) : SZ + + ! Multiple dimensions should have multiple two-code suffixes: + ! cohort age x pft (site_cooage_r8) : ACPF + ! patch age x fuel class (site_agefuel_r8) : APFC + ! patch age x pft (site_agepft_r8) : APPF + ! canopy layer x leaf layer (site_cnlf_r8) : CLLL + ! canopy layer x leaf layer x pft (site_cnlfpft_r8) : CLLLPF + ! element x cwd size (site_elcwd_r8) : ELDC + ! cohort size x patch age (site_scag_r8) : SZAP + ! cohort size x patch age x pft (site_scagpft_r8) : SZAPPF + ! cohort size x pft (site_size_pft_r8) : SZPF - 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='inactive', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_npatches_si_age ) + ! Site level counting variables + call this%set_history_var(vname='FATES_NPATCHES', units='', & + long='total number of patches per site', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_npatches_si) + + call this%set_history_var(vname='FATES_NCOHORTS', units='', & + long='total number of cohorts per site', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_ncohorts_si) + + ! Patch variables + call this%set_history_var(vname='FATES_TRIMMING', units='1', & + long='degree to which canopy expansion is limited by leaf economics (0-1)', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_trimming_si) + + call this%set_history_var(vname='FATES_AREA_PLANTS', units='m2 m-2', & + long='area occupied by all plants per m2 land area', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index=ih_area_plant_si) + + call this%set_history_var(vname='FATES_AREA_TREES', units='m2 m-2', & + long='area occupied by woody plants per m2 land area', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_area_trees_si) + + call this%set_history_var(vname='FATES_COLD_STATUS', units='', & + long='site-level cold status, 0=not cold-dec, 1=too cold for leaves, 2=not too cold', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_site_cstatus_si) + + call this%set_history_var(vname='FATES_DROUGHT_STATUS', & + units='', & + long='site-level drought status, <2 too dry for leaves, >=2 not too dry', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_site_dstatus_si) + + call this%set_history_var(vname='FATES_GDD', units='degree_Celsius', & + long='site-level growing degree days', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, index=ih_gdd_si) + + call this%set_history_var(vname='FATES_NCHILLDAYS', units = 'days', & + long='site-level number of chill days', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_site_nchilldays_si) + + call this%set_history_var(vname='FATES_NCOLDDAYS', units = 'days', & + long='site-level number of cold days', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_site_ncolddays_si) + + call this%set_history_var(vname='FATES_DAYSINCE_COLDLEAFOFF', & + units='days', long='site-level days elapsed since cold leaf drop', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_cleafoff_si) + + call this%set_history_var(vname='FATES_DAYSINCE_COLDLEAFON', & + units='days', long='site-level days elapsed since cold leaf flush', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_cleafon_si) + + call this%set_history_var(vname='FATES_DAYSINCE_DROUGHTLEAFOFF', & + units='days', long='site level days elapsed since drought leaf drop', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_dleafoff_si) + + call this%set_history_var(vname='FATES_DAYSINCE_DROUGHTLEAFON', & + units='days', & + long='site-level days elapsed since drought leaf flush', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_dleafon_si) + + call this%set_history_var(vname='FATES_MEANLIQVOL_DROUGHTPHEN', & + units='m3 m-3', & + long='site-level mean liquid water volume for drought phenolgy', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_meanliqvol_si) + + call this%set_history_var(vname='FATES_CANOPY_SPREAD', units='', & + long='scaling factor (0-1) between tree basal area and canopy area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_canopy_spread_si) + + call this%set_history_var(vname='FATES_VEGC_PF', units='kg m-2', & + long='total PFT-level biomass in kg of carbon per land area', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_biomass_si_pft) + + call this%set_history_var(vname='FATES_LEAFC_PF', units='kg m-2', & + long='total PFT-level leaf biomass in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_leafbiomass_si_pft) + + call this%set_history_var(vname='FATES_STOREC_PF', units='kg m-2', & + long='total PFT-level stored biomass in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_storebiomass_si_pft) + + call this%set_history_var(vname='FATES_CROWNAREA_PF', units='m2 m-2', & + long='total PFT-level crown area per m2 land area', & + use_default='active', avgflag='A', vtype=site_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_crownarea_si_pft) + + call this%set_history_var(vname='FATES_CANOPYCROWNAREA_PF', & + units='m2 m-2', long='total PFT-level canopy-layer crown area per m2 land area', & + use_default='active', avgflag='A', vtype=site_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_canopycrownarea_si_pft) + + call this%set_history_var(vname='FATES_GPP_PF', units='kg m-2 s-1', & + long='total PFT-level GPP in kg carbon per m2 land area per second', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_gpp_si_pft) + + call this%set_history_var(vname='FATES_NPP_PF', units='kg m-2 yr-1', & + long='total PFT-level NPP in kg carbon per m2 land area per second', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_npp_si_pft) + + call this%set_history_var(vname='FATES_NPLANT_PF', units='m-2', & + long='total PFT-level number of individuals per m2 land area', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_nindivs_si_pft) + + call this%set_history_var(vname='FATES_RECRUITMENT_PF', & + units='m-2 yr-1', & + long='PFT-level recruitment rate in number of individuals per m2 land area per year', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_recruitment_si_pft) + + call this%set_history_var(vname='FATES_MORTALITY_PF', units='m-2 yr-1', & + long='PFT-level mortality rate in number of individuals per m2 land area per year', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_mortality_si_pft) + + nocomp_if: if (hlm_use_nocomp .eq. itrue) then + call this%set_history_var(vname='FATES_NOCOMP_NPATCHES_PF', units='', & + long='number of patches per PFT (nocomp-mode-only)', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_nocomp_pftnpatches_si_pft) + + call this%set_history_var(vname='FATES_NOCOMP_PATCHAREA_PF', units='m2 m-2',& + long='total patch area allowed per PFT (nocomp-mode-only)', & + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_nocomp_pftpatchfraction_si_pft) + + call this%set_history_var(vname='FATES_NOCOMP_BURNEDAREA_PF', units='s-1', & + long='total burned area of PFT-labeled patch area (nocomp-mode-only)',& + use_default='active', avgflag='A', vtype=site_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_nocomp_pftburnedarea_si_pft) + endif nocomp_if + + ! patch age class variables + call this%set_history_var(vname='FATES_PATCHAREA_AP', units='m2 m-2', & + long='patch area by age bin per m2 land area', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index=ih_area_si_age) + + call this%set_history_var(vname='FATES_LAI_AP', units='m2 m-2', & + long='leaf area index by age bin per m2 land area', & + use_default='active', avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_lai_si_age) + + call this%set_history_var(vname='FATES_CANOPYAREA_AP', units='m2 m-2', & + long='canopy area by age bin per m2 land area', use_default='active', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index=ih_canopy_area_si_age) + + call this%set_history_var(vname='FATES_NCL_AP', units='', & + long='number of canopy levels by age bin', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_ncl_si_age) + + call this%set_history_var(vname='FATES_NPATCH_AP', units='', & + long='number of patches by age bin', use_default='inactive', & + avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_npatches_si_age) if ( ED_val_comp_excln .lt. 0._r8 ) then ! only valid when "strict ppa" enabled tempstring = 'active' else tempstring = 'inactive' endif - - call this%set_history_var(vname='ZSTAR_BY_AGE', units='m', & - long='product of zstar and patch area by age bin (divide by PATCH_AREA_BY_AGE to get mean zstar)', & - use_default=trim(tempstring), & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_zstar_si_age ) - - call this%set_history_var(vname='CANOPY_HEIGHT_DIST', units='m2/m2', & - long='canopy height distribution', use_default='active', & - avgflag='A', vtype=site_height_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_canopy_height_dist_si_height ) - - call this%set_history_var(vname='LEAF_HEIGHT_DIST', units='m2/m2', & - long='leaf height distribution', use_default='active', & - avgflag='A', vtype=site_height_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_leaf_height_dist_si_height ) - - call this%set_history_var(vname='BIOMASS_BY_AGE', units='kgC/m2', & - long='Total Biomass within a given patch age bin', & - use_default='inactive', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_age ) - ! Secondary forest area and age diagnostics - - call this%set_history_var(vname='SECONDARY_FOREST_FRACTION', units='m2/m2', & - long='Secondary forest fraction', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fraction_secondary_forest_si ) - - call this%set_history_var(vname='WOOD_PRODUCT', units='gC/m2', & - long='Total wood product from logging', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_woodproduct_si ) - - call this%set_history_var(vname='SECONDARY_FOREST_BIOMASS', units='kgC/m2', & - long='Biomass on secondary lands (per total site area, mult by SECONDARY_FOREST_FRACTION to get per secondary forest area)',& - use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_biomass_secondary_forest_si ) - - call this%set_history_var(vname='SECONDARY_AREA_AGE_ANTHRO_DIST', units='m2/m2', & - long='Secondary forest patch area age distribution since anthropgenic disturbance', & - use_default='inactive', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_agesince_anthrodist_si_age ) + call this%set_history_var(vname='FATES_ZSTAR_AP', units='m', & + long='product of zstar and patch area by age bin (divide by FATES_PATCHAREA_AP to get mean zstar)', & + use_default=trim(tempstring), avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_zstar_si_age) + + call this%set_history_var(vname='FATES_CANOPYAREA_HT', units='m2 m-2', & + long='canopy area height distribution', & + use_default='active', avgflag='A', vtype=site_height_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_canopy_height_dist_si_height) + + call this%set_history_var(vname='FATES_LEAFAREA_HT', units='m2 m-2', & + long='leaf area height distribution', use_default='active', & + avgflag='A', vtype=site_height_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_leaf_height_dist_si_height) + + call this%set_history_var(vname='FATES_VEGC_AP', units='kg m-2', & + long='total biomass within a given patch age bin in kg carbon per m2 land area', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_biomass_si_age) - call this%set_history_var(vname='SECONDARY_AREA_PATCH_AGE_DIST', units='m2/m2', & - long='Secondary forest patch area age distribution since any kind of disturbance', & - use_default='inactive', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_secondaryforest_area_si_age ) + ! Secondary forest area and age diagnostics + call this%set_history_var(vname='FATES_SECONDARY_FOREST_FRACTION', & + units='m2 m-2', long='secondary forest fraction', & + use_default='inactive', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_fraction_secondary_forest_si) + + call this%set_history_var(vname='FATES_WOOD_PRODUCT', units='kg m-2', & + long='total wood product from logging in kg carbon per m2 land area', & + use_default='inactive', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_woodproduct_si) + + call this%set_history_var(vname='FATES_SECONDARY_FOREST_VEGC', & + units='kg m-2', & + long='biomass on secondary lands in kg carbon per m2 land area (mult by FATES_SECONDARY_FOREST_FRACTION to get per secondary forest area)', & + use_default='inactive', avgflag='A', vtype=site_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_biomass_secondary_forest_si) + + call this%set_history_var(vname='FATES_SECONDAREA_ANTHRODIST_AP', & + units='m2 m-2', & + long='secondary forest patch area age distribution since anthropgenic disturbance', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_agesince_anthrodist_si_age) + + call this%set_history_var(vname='FATES_SECONDAREA_DIST_AP', & + units='m2 m-2', & + long='secondary forest patch area age distribution since any kind of disturbance', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_secondaryforest_area_si_age) ! Fire Variables - call this%set_history_var(vname='FIRE_NESTEROV_INDEX', units='none', & - long='nesterov_fire_danger index', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_nesterov_fire_danger_si) - - call this%set_history_var(vname='FIRE_IGNITIONS', units='number/km2/day', & - long='number of successful ignitions', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_nignitions_si) - - call this%set_history_var(vname='FIRE_FDI', units='none', & - long='probability that an ignition will lead to a fire', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_fdi_si) - - call this%set_history_var(vname='FIRE_ROS', units='m/min', & - long='fire rate of spread m/min', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_spitfire_ros_si) - - call this%set_history_var(vname='FIRE_ROS_AREA_PRODUCT', units='m/min', & - long='product of fire rate of spread (m/min) and burned area (fraction)--divide by FIRE_AREA to get burned-area-weighted-mean ROS', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_ros_area_product_si) - - call this%set_history_var(vname='EFFECT_WSPEED', units='none', & - long ='effective windspeed for fire spread', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_effect_wspeed_si ) - - call this%set_history_var(vname='FIRE_TFC_ROS', units='kgC/m2', & - long ='total fuel consumed', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_tfc_ros_si ) - - call this%set_history_var(vname='FIRE_TFC_ROS_AREA_PRODUCT', units='kgC/m2', & - long ='product of total fuel consumed and burned area--divide by FIRE_AREA to get burned-area-weighted-mean TFC', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_tfc_ros_area_product_si ) - - call this%set_history_var(vname='FIRE_INTENSITY', units='kJ/m/s', & - long='spitfire fire intensity: kJ/m/s', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_intensity_si ) - - call this%set_history_var(vname='FIRE_INTENSITY_AREA_PRODUCT', units='kJ/m/s', & - long='spitfire product of fire intensity and burned area (divide by FIRE_AREA to get area-weighted mean intensity)', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_intensity_area_product_si ) - - call this%set_history_var(vname='FIRE_AREA', units='fraction/day', & - long='spitfire fire area burn fraction', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_area_si ) - - call this%set_history_var(vname='FIRE_FUEL_MEF', units='m', & - long='spitfire fuel moisture', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_mef_si ) - - call this%set_history_var(vname='FIRE_FUEL_BULKD', units='kg biomass/m3', & - long='spitfire fuel bulk density', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_bulkd_si ) - - call this%set_history_var(vname='FIRE_FUEL_EFF_MOIST', units='m', & - long='spitfire fuel moisture', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_eff_moist_si ) - - call this%set_history_var(vname='FIRE_FUEL_SAV', units='per m', & - long='spitfire fuel surface/volume ', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_fuel_sav_si ) - - call this%set_history_var(vname='SUM_FUEL', units='gC m-2', & - long='total ground fuel related to ros (omits 1000hr fuels)', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_sum_fuel_si ) - - call this%set_history_var(vname='FRAGMENTATION_SCALER_SL', units='unitless (0-1)', & - long='factor by which litter/cwd fragmentation proceeds relative to max rate by soil layer', & - use_default='active', & - avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fragmentation_scaler_sl ) - - call this%set_history_var(vname='FUEL_MOISTURE_NFSC', units='-', & - long='spitfire size-resolved fuel moisture', use_default='active', & - avgflag='A', vtype=site_fuel_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_litter_moisture_si_fuel ) - - call this%set_history_var(vname='FUEL_AMOUNT_BY_NFSC', units='kg C / m2', & - long='spitfire size-resolved fuel quantity', use_default='active', & - avgflag='A', vtype=site_fuel_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fuel_amount_si_fuel ) - - call this%set_history_var(vname='FUEL_AMOUNT_AGEFUEL', units='kg C / m2', & - long='spitfire fuel quantity in each age x fuel class ', use_default='active', & - avgflag='A', vtype=site_agefuel_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fuel_amount_age_fuel ) - - call this%set_history_var(vname='AREA_BURNT_BY_PATCH_AGE', units='m2/m2/day', & - long='spitfire area burnt by patch age (divide by patch_area_by_age to get burnt fraction by age)', & - use_default='active', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_area_burnt_si_age ) - - call this%set_history_var(vname='FIRE_INTENSITY_BY_PATCH_AGE', units='kJ/m/2', & - long='product of fire intensity and burned area, resolved by patch age (so divide by AREA_BURNT_BY_PATCH_AGE to get burned-area-weighted-average intensity', & - use_default='active', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_intensity_si_age ) - - call this%set_history_var(vname='SUM_FUEL_BY_PATCH_AGE', units='gC / m2 of site area', & - long='spitfire ground fuel related to ros (omits 1000hr fuels) within each patch age bin (divide by patch_area_by_age to get fuel per unit area of that-age patch)', & - use_default='active', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_sum_fuel_si_age ) - - call this%set_history_var(vname='BURNT_LITTER_FRAC_AREA_PRODUCT', units='fraction', & - long='product of fraction of fuel burnt and burned area (divide by FIRE_AREA to get burned-area-weighted mean fraction fuel burnt)', & - use_default='active', & - avgflag='A', vtype=site_fuel_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_burnt_frac_litter_si_fuel ) - + call this%set_history_var(vname='FATES_NESTEROV_INDEX', units='', & + long='nesterov fire danger index', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_nesterov_fire_danger_si) + + call this%set_history_var(vname='FATES_IGNITIONS', & + units='m-2 s-1', & + long='number of successful fire ignitions per m2 land area per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_fire_nignitions_si) + + call this%set_history_var(vname='FATES_FDI', units='1', & + long='Fire Danger Index (probability that an ignition will lead to a fire)', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_fire_fdi_si) + + call this%set_history_var(vname='FATES_ROS', units='m s-1', & + long='fire rate of spread in meters per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_spitfire_ros_si) + + call this%set_history_var(vname='FATES_EFFECT_WSPEED', units='m s-1', & + long ='effective wind speed for fire spread in meters per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_effect_wspeed_si) + + call this%set_history_var(vname='FATES_FUELCONSUMED', units='kg m-2', & + long ='total fuel consumed in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_tfc_ros_si) + + call this%set_history_var(vname='FATES_FIRE_INTENSITY', & + units='J m-1 s-1', & + long='spitfire surface fireline intensity in J per m per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_fire_intensity_si) + + call this%set_history_var(vname='FATES_FIRE_INTENSITY_BURNFRAC', & + units='J m-1 s-1', & + long='product of surface fire intensity and burned area fraction -- divide by FATES_BURNFRAC to get area-weighted mean intensity', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_fire_intensity_area_product_si) + + call this%set_history_var(vname='FATES_BURNFRAC', units='s-1', & + long='burned area fraction per second', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_fire_area_si) + + call this%set_history_var(vname='FATES_FUEL_MEF', units='m3 m-3', & + long='fuel moisture of extinction (volumetric)', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index=ih_fire_fuel_mef_si) + + call this%set_history_var(vname='FATES_FUEL_BULKD', & + units='kg m-3', long='fuel bulk density in kg per m3', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fire_fuel_bulkd_si ) + + call this%set_history_var(vname='FATES_FUEL_EFF_MOIST', units='m3 m-3', & + long='spitfire fuel moisture (volumetric)', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_fire_fuel_eff_moist_si) + + call this%set_history_var(vname='FATES_FUEL_SAV', units='per m', & + long='spitfire fuel surface area to volume ratio', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fire_fuel_sav_si) + + call this%set_history_var(vname='FATES_FUEL_AMOUNT', units='kg m-2', & + long='total ground fuel related to FATES_ROS (omits 1000hr fuels) in kg C per m2 land area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_sum_fuel_si) + + call this%set_history_var(vname='FATES_FRAGMENTATION_SCALER_SL', units='', & + long='factor (0-1) by which litter/cwd fragmentation proceeds relative to max rate by soil layer', & + use_default='active', avgflag='A', vtype=site_soil_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fragmentation_scaler_sl) + + call this%set_history_var(vname='FATES_FUEL_MOISTURE_FC', units='m3 m-3', & + long='spitfire fuel class-level fuel moisture (volumetric)', & + use_default='active', avgflag='A', vtype=site_fuel_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_litter_moisture_si_fuel) + + call this%set_history_var(vname='FATES_FUEL_AMOUNT_FC', units='kg m-2', & + long='spitfire fuel-class level fuel amount in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_fuel_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fuel_amount_si_fuel) + + call this%set_history_var(vname='FATES_FUEL_AMOUNT_APFC', units='kg m-2', & + long='spitfire fuel quantity in each age x fuel class in kg carbon per m2 land area', & + use_default='inactive', avgflag='A', vtype=site_agefuel_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fuel_amount_age_fuel) + + call this%set_history_var(vname='FATES_BURNFRAC_AP', units='s-1', & + long='spitfire fraction area burnt (per second) by patch age', & + use_default='active', avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_area_burnt_si_age) + + call this%set_history_var(vname='FATES_FIRE_INTENSITY_BURNFRAC_AP', & + units='J m-1 s-1', & + long='product of fire intensity and burned fraction, resolved by patch age (so divide by FATES_BURNFRAC_AP to get burned-area-weighted-average intensity)', & + use_default='active', avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fire_intensity_si_age) + + call this%set_history_var(vname='FATES_FUEL_AMOUNT_AP', units='kg m-2', & + long='spitfire ground fuel (kg carbon per m2) related to FATES_ROS (omits 1000hr fuels) within each patch age bin (divide by FATES_PATCHAREA_AP to get fuel per unit area of that-age patch)', & + use_default='active', avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fire_sum_fuel_si_age) + + call this%set_history_var(vname='FATES_FUEL_BURNT_BURNFRAC_FC', units='1', & + long='product of fraction (0-1) of fuel burnt and burnt fraction (divide by FATES_BURNFRAC to get burned-area-weighted mean fraction fuel burnt)', & + use_default='active', avgflag='A', vtype=site_fuel_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_burnt_frac_litter_si_fuel) ! Litter Variables - call this%set_history_var(vname='LITTER_IN', units='gC m-2 s-1', & - long='FATES litter flux in', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_litter_in_si ) - - call this%set_history_var(vname='LITTER_OUT', units='gC m-2 s-1', & - long='FATES litter flux out', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_litter_out_si ) - - call this%set_history_var(vname='SEED_BANK', units='gC m-2', & - long='Total Seed Mass of all PFTs', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_seed_bank_si ) - - call this%set_history_var(vname='SEEDS_IN', units='gC m-2 s-1', & - long='Seed Production Rate', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_seeds_in_si ) - - call this%set_history_var(vname='LITTER_IN_ELEM', units='kg ha-1 d-1', & - long='FATES litter flux in', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_litter_in_elem ) - - call this%set_history_var(vname='LITTER_OUT_ELEM', units='kg ha-1 d-1', & - long='FATES litter flux out (fragmentation only)', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_litter_out_elem ) - - call this%set_history_var(vname='SEED_BANK_ELEM', units='kg ha-1', & - long='Total Seed Mass of all PFTs', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_seed_bank_elem ) - - call this%set_history_var(vname='SEEDS_IN_LOCAL_ELEM', units='kg ha-1 d-1', & - long='Within Site Seed Production Rate', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_seeds_in_local_elem ) - - call this%set_history_var(vname='SEEDS_IN_EXTERN_ELEM', units='kg ha-1 d-1', & - long='External Seed Influx Rate', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_seeds_in_extern_elem ) - - call this%set_history_var(vname='SEED_GERM_ELEM', units='kg ha-1 d-1', & - long='Seed mass converted into new cohorts', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_seed_germ_elem ) - - call this%set_history_var(vname='SEED_DECAY_ELEM', units='kg ha-1 d-1', & - long='Seed mass decay', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_seed_decay_elem ) + call this%set_history_var(vname='FATES_LITTER_IN', units='kg m-2 s-1', & + long='litter flux in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_litter_in_si) + + call this%set_history_var(vname='FATES_LITTER_OUT', units='kg m-2 s-1', & + long='litter flux out in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_litter_out_si) + + call this%set_history_var(vname='FATES_SEED_BANK', units='kg m-2', & + long='total seed mass of all PFTs in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_seed_bank_si) + + call this%set_history_var(vname='FATES_SEEDS_IN', units='kg m-2 s-1', & + long='seed production rate in kg carbon per m2 second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_seeds_in_si) + + call this%set_history_var(vname='FATES_LITTER_IN_EL', units='kg m-2 s-1', & + long='litter flux in in kg element per m2 per second', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_litter_in_elem) + + call this%set_history_var(vname='FATES_LITTER_OUT_EL', units='kg m-2 s-1', & + long='litter flux out (fragmentation only) in kg element per m2 per second', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_litter_out_elem) + + call this%set_history_var(vname='FATES_SEED_BANK_EL', units='kg m-2', & + long='element-level total seed mass of all PFTs in kg element per m2', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_seed_bank_elem) + + call this%set_history_var(vname='FATES_SEEDS_IN_LOCAL_EL', & + units='kg m-2 s-1', & + long='within-site, element-level seed production rate in kg element per m2 per second', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_seeds_in_local_elem) + + call this%set_history_var(vname='FATES_SEEDS_IN_EXTERN_EL', & + units='kg m-2 s-1', long='external seed influx rate in kg element per m2 per second', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_seeds_in_extern_elem) + + call this%set_history_var(vname='FATES_SEED_GERM_EL', units='kg m-2 s-1', & + long='seed mass converted into new cohorts in kg element per m2 per s', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_seed_germ_elem) + + call this%set_history_var(vname='FATES_SEED_DECAY_EL', units='kg m-2 s-1', & + long='seed mass decay (germinated and un-germinated) in kg element per m2 per second', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_seed_decay_elem) - ! SITE LEVEL CARBON STATE VARIABLES - call this%set_history_var(vname='STOREC', units='kgC ha-1', & - long='Total carbon in live plant storage', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_storec_si ) - - call this%set_history_var(vname='TOTVEGC', units='kgC ha-1', & - long='Total carbon in live plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_totvegc_si ) - - call this%set_history_var(vname='SAPWC', units='kgC ha-1', & - long='Total carbon in live plant sapwood', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_sapwc_si ) - - call this%set_history_var(vname='LEAFC', units='kgC ha-1', & - long='Total carbon in live plant leaves', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_leafc_si ) - - call this%set_history_var(vname='FNRTC', units='kgC ha-1', & - long='Total carbon in live plant fine-roots', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fnrtc_si ) - - call this%set_history_var(vname='REPROC', units='kgC ha-1', & - long='Total carbon in live plant reproductive tissues', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_reproc_si ) - - call this%set_history_var(vname='CEFFLUX', units='kgC/ha/day', & - long='carbon efflux, root to soil', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cefflux_si ) - + + call this%set_history_var(vname='FATES_STOREC', units='kg m-2', & + long='total biomass in live plant storage in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_storec_si) + + call this%set_history_var(vname='FATES_VEGC', units='kg m-2', & + long='total biomass in live plants in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_totvegc_si) + + call this%set_history_var(vname='FATES_SAPWOODC', units='kg m-2', & + long='total biomass in live plant sapwood in kg carbon per m2', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_sapwc_si) + + call this%set_history_var(vname='FATES_LEAFC', units='kg m-2', & + long='total biomass in live plant leaves in kg carbon per m2', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_leafc_si) + + call this%set_history_var(vname='FATES_FROOTC', units='kg m-2', & + long='total biomass in live plant fine roots in kg carbon per m2', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fnrtc_si) + + call this%set_history_var(vname='FATES_REPROC', units='kg m-2', & + long='total biomass in live plant reproductive tissues in kg carbon per m2', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_reproc_si) + + call this%set_history_var(vname='FATES_CEFFLUX', units='kg m-2 s-1', & + long='carbon efflux, root to soil, in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_cefflux_si) + nitrogen_active_if: if(any(element_list(:)==nitrogen_element)) then - call this%set_history_var(vname='STOREN', units='kgN ha-1', & - long='Total nitrogen in live plant storage', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_storen_si ) - - call this%set_history_var(vname='TOTVEGN', units='kgN ha-1', & - long='Total nitrogen in live plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_totvegn_si ) - - call this%set_history_var(vname='SAPWN', units='kgN ha-1', & - long='Total nitrogen in live plant sapwood', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_sapwn_si ) - - call this%set_history_var(vname='LEAFN', units='kgN ha-1', & - long='Total nitrogen in live plant leaves', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_leafn_si ) - - call this%set_history_var(vname='FNRTN', units='kgN ha-1', & - long='Total nitrogen in live plant fine-roots', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fnrtn_si ) - - call this%set_history_var(vname='REPRON', units='kgN ha-1', & - long='Total nitrogen in live plant reproductive tissues', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_repron_si ) - - call this%set_history_var(vname='NUPTAKE', units='kgN d-1 ha-1', & - long='Total nitrogen uptake by plants per sq meter per day', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_nuptake_si ) - - call this%set_history_var(vname='NEFFLUX', units='kgN d-1 ha-1', & - long='Nitrogen effluxed from plant (unused)', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_nefflux_si ) - - call this%set_history_var(vname='NNEED_GROW', units='kgN d-1 ha-1', & - long='(Approx) plant nitrogen needed to satisfy growth', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_nneedgrow_si ) - - call this%set_history_var(vname='NNEED_MAX', units='kgN d-1 ha-1', & - long='(Approx) plant nitrogen needed to reach maximum capacity', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_nneedmax_si ) - + call this%set_history_var(vname='FATES_STOREN', units='kg m-2', & + long='total nitrogen in live plant storage', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_storen_si) + + call this%set_history_var(vname='FATES_STOREN_TF', units='1', & + long='storage N fraction of target', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_storentfrac_si) + + call this%set_history_var(vname='FATES_VEGN', units='kg m-2', & + long='total nitrogen in live plants', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_totvegn_si) + + call this%set_history_var(vname='FATES_SAPWOODN', units='kg m-2', & + long='total nitrogen in live plant sapwood', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_sapwn_si) + + call this%set_history_var(vname='FATES_LEAFN', units='kg m-2', & + long='total nitrogen in live plant leaves', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_leafn_si) + + call this%set_history_var(vname='FATES_FROOTN', units='kg m-2', & + long='total nitrogen in live plant fine-roots', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fnrtn_si) + + call this%set_history_var(vname='FATES_REPRON', units='kg m-2', & + long='total nitrogen in live plant reproductive tissues', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_repron_si) + + call this%set_history_var(vname='FATES_NH4UPTAKE', units='kg m-2 s-1', & + long='ammonium uptake rate by plants in kg NH4 per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_nh4uptake_si) + + call this%set_history_var(vname='FATES_NO3UPTAKE', units='kg m-2 s-1', & + long='nitrate uptake rate by plants in kg NO3 per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_no3uptake_si) + + call this%set_history_var(vname='FATES_NEFFLUX', units='kg m-2 s-1', & + long='nitrogen effluxed from plant in kg N per m2 per second (unused)', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_nefflux_si) + + call this%set_history_var(vname='FATES_NNEED', units='kg m-2 s-1', & + long='plant nitrogen need (algorithm dependent) in kg N per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_nneed_si) + end if nitrogen_active_if - + phosphorus_active_if: if(any(element_list(:)==phosphorus_element)) then - call this%set_history_var(vname='STOREP', units='kgP ha-1', & - long='Total phosphorus in live plant storage', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_storep_si ) - - call this%set_history_var(vname='TOTVEGP', units='kgP ha-1', & - long='Total phosphorus in live plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_totvegp_si ) - - call this%set_history_var(vname='SAPWP', units='kgP ha-1', & - long='Total phosphorus in live plant sapwood', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_sapwp_si ) - - call this%set_history_var(vname='LEAFP', units='kgP ha-1', & - long='Total phosphorus in live plant leaves', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_leafp_si ) - - call this%set_history_var(vname='FNRTP', units='kgP ha-1', & - long='Total phosphorus in live plant fine-roots', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fnrtp_si ) - - call this%set_history_var(vname='REPROP', units='kgP ha-1', & - long='Total phosphorus in live plant reproductive tissues', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_reprop_si ) - - call this%set_history_var(vname='PUPTAKE', units='kgP ha-1 d-1', & - long='Total phosphorus uptake by plants per sq meter per day', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_puptake_si ) - - call this%set_history_var(vname='PEFFLUX', units='kgP ha-1 d-1', & - long='Phosphorus effluxed from plant (unused)', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_pefflux_si ) - - call this%set_history_var(vname='PNEED_GROW', units='kgP ha-1 d-1', & - long='Plant phosphorus needed to satisfy growth', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_pneedgrow_si ) - - call this%set_history_var(vname='PNEED_MAX', units='kgP ha-1 d-1', & - long='Plant phosphorus needed to reach maximum capacity', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_pneedmax_si ) - - + call this%set_history_var(vname='FATES_STOREP', units='kg m-2', & + long='total phosphorus in live plant storage', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_storep_si) + + call this%set_history_var(vname='FATES_STOREP_TF', units='1', & + long='storage P fraction of target', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, & + index = ih_storeptfrac_si) + + call this%set_history_var(vname='FATES_VEGP', units='kg m-2', & + long='total phosphorus in live plants', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_totvegp_si) + + call this%set_history_var(vname='FATES_SAPWOODP', units='kg m-2', & + long='Total phosphorus in live plant sapwood', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_sapwp_si) + + call this%set_history_var(vname='FATES_LEAFP', units='kg m-2', & + long='total phosphorus in live plant leaves', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_leafp_si) + + call this%set_history_var(vname='FATES_FROOTP', units='kg m-2', & + long='total phosphorus in live plant fine roots', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fnrtp_si) + + call this%set_history_var(vname='FATES_REPROP', units='kg m-2', & + long='total phosphorus in live plant reproductive tissues', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_reprop_si) + + call this%set_history_var(vname='FATES_PUPTAKE', units='kg m-2 s-1', & + long='mineralized phosphorus uptake rate of plants in kg P per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_puptake_si) + + call this%set_history_var(vname='FATES_PEFFLUX', units='kg m-2 s-1', & + long='phosphorus effluxed from plant in kg P per m2 per second (unused)', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_pefflux_si) + + call this%set_history_var(vname='FATES_PNEED', units='kg m-2 s-1', & + long='plant phosphorus need (algorithm dependent) in kg P per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_pneed_si) + end if phosphorus_active_if + call this%set_history_var(vname='FATES_STRUCTC', units='kg m-2', & + long='structural biomass in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_bdead_si) + + call this%set_history_var(vname='FATES_NONSTRUCTC', units='kg m-2', & + long='non-structural biomass (sapwood + leaf + fineroot) in kg carbon per m2', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_balive_si) + + call this%set_history_var(vname='FATES_VEGC_ABOVEGROUND', units='kg m-2', & + long='aboveground biomass in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_agb_si) + + call this%set_history_var(vname='FATES_CANOPY_VEGC', units='kg m-2', & + long='biomass of canopy plants in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_canopy_biomass_si) + + call this%set_history_var(vname='FATES_USTORY_VEGC', units='kg m-2', & + long='biomass of understory plants in kg carbon per m2 land area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_understory_biomass_si) - ! Consider deprecating the "ED_" variables (RGK 08-2020) - ! They have been replaced, eg. STOREC = ED_bstore - - call this%set_history_var(vname='ED_bstore', units='gC m-2', & - long='Storage biomass', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_bstore_si ) - - call this%set_history_var(vname='ED_bdead', units='gC m-2', & - long='Dead (structural) biomass (live trees, not CWD)', & - use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_bdead_si ) - - call this%set_history_var(vname='ED_balive', units='gC m-2', & - long='Live biomass', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_balive_si ) - - call this%set_history_var(vname='ED_bleaf', units='gC m-2', & - long='Leaf biomass', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_bleaf_si ) - - call this%set_history_var(vname='ED_bsapwood', units='gC m-2', & - long='Sapwood biomass', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_bsapwood_si ) - - call this%set_history_var(vname='ED_bfineroot', units='gC m-2', & - long='Fine root biomass', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_bfineroot_si ) - - call this%set_history_var(vname='ED_biomass', units='gC m-2', & - long='Total biomass', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_btotal_si ) + ! disturbance rates + call this%set_history_var(vname='FATES_PRIMARY_PATCHFUSION_ERR', & + units='m2 m-2 yr-1', & + long='error in total primary lands associated with patch fusion', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_primaryland_fusion_error_si) + + call this%set_history_var(vname='FATES_DISTURBANCE_RATE_P2P', & + units='m2 m-2 yr-1', & + long='disturbance rate from primary to primary lands', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_disturbance_rate_p2p_si) + + call this%set_history_var(vname='FATES_DISTURBANCE_RATE_P2S', & + units='m2 m-2 yr-1', & + long='disturbance rate from primary to secondary lands', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_disturbance_rate_p2s_si ) + + call this%set_history_var(vname='FATES_DISTURBANCE_RATE_S2S', & + units='m2 m-2 yr-1', & + long='disturbance rate from secondary to secondary lands', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_disturbance_rate_s2s_si) + + call this%set_history_var(vname='FATES_DISTURBANCE_RATE_FIRE', & + units='m2 m-2 yr-1', long='disturbance rate from fire', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fire_disturbance_rate_si) + + call this%set_history_var(vname='FATES_DISTURBANCE_RATE_LOGGING', & + units='m2 m-2 yr-1', long='disturbance rate from logging', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_logging_disturbance_rate_si) + + call this%set_history_var(vname='FATES_DISTURBANCE_RATE_TREEFALL', & + units='m2 m-2 yr-1', long='disturbance rate from treefall', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fall_disturbance_rate_si) + + call this%set_history_var(vname='FATES_DISTURBANCE_RATE_POTENTIAL', & + units='m2 m-2 yr-1', & + long='potential (i.e., including unresolved) disturbance rate', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_potential_disturbance_rate_si) + + call this%set_history_var(vname='FATES_HARVEST_CARBON_FLUX', & + units='kg m-2 yr-1', & + long='harvest carbon flux in kg carbon per m2 per year', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_harvest_carbonflux_si) + + ! Canopy Resistance + + call this%set_history_var(vname='FATES_STOMATAL_COND', & + units='mol m-2 s-1', long='mean stomatal conductance', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_c_stomata_si) + + call this%set_history_var(vname='FATES_LBLAYER_COND', units='mol m-2 s-1', & + long='mean leaf boundary layer conductance', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_c_lblayer_si) + + ! Temperature - call this%set_history_var(vname='AGB', units='gC m-2', & - long='Aboveground biomass', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_agb_si ) - - call this%set_history_var(vname='BIOMASS_CANOPY', units='gC m-2', & - long='Biomass of canopy plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_canopy_biomass_si ) - - call this%set_history_var(vname='BIOMASS_UNDERSTORY', units='gC m-2', & - long='Biomass of understory plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_understory_biomass_si ) + call this%set_history_var(vname='FATES_TVEG24', units='degree_Celsius', & + long='fates 24-hr running mean vegetation temperature by site', & + use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_tveg24_si ) + + call this%set_history_var(vname='FATES_TVEG', units='degree_Celsius', & + long='fates instantaneous mean vegetation temperature by site', & + use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_tveg_si ) + + ! radiation error - ! disturbance rates - call this%set_history_var(vname='PRIMARYLAND_PATCHFUSION_ERROR', units='m2 m-2 d-1', & - long='Error in total primary lands associated with patch fusion', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_primaryland_fusion_error_si ) - - call this%set_history_var(vname='DISTURBANCE_RATE_P2P', units='m2 m-2 d-1', & - long='Disturbance rate from primary to primary lands', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_disturbance_rate_p2p_si ) - - call this%set_history_var(vname='DISTURBANCE_RATE_P2S', units='m2 m-2 d-1', & - long='Disturbance rate from primary to secondary lands', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_disturbance_rate_p2s_si ) - - call this%set_history_var(vname='DISTURBANCE_RATE_S2S', units='m2 m-2 d-1', & - long='Disturbance rate from secondary to secondary lands', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_disturbance_rate_s2s_si ) - - call this%set_history_var(vname='DISTURBANCE_RATE_FIRE', units='m2 m-2 d-1', & - long='Disturbance rate from fire', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fire_disturbance_rate_si ) - - call this%set_history_var(vname='DISTURBANCE_RATE_LOGGING', units='m2 m-2 d-1', & - long='Disturbance rate from logging', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_logging_disturbance_rate_si ) - - call this%set_history_var(vname='DISTURBANCE_RATE_TREEFALL', units='m2 m-2 d-1', & - long='Disturbance rate from treefall', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_fall_disturbance_rate_si ) - - call this%set_history_var(vname='DISTURBANCE_RATE_POTENTIAL', units='m2 m-2 d-1', & - long='Potential (i.e., including unresolved) disturbance rate', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_potential_disturbance_rate_si ) - - call this%set_history_var(vname='HARVEST_CARBON_FLUX', units='kg C m-2 d-1', & - long='Harvest carbon flux', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_harvest_carbonflux_si ) - - ! Canopy Resistance - - call this%set_history_var(vname='C_STOMATA', units='umol m-2 s-1', & - long='mean stomatal conductance', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_c_stomata_si ) - - call this%set_history_var(vname='C_LBLAYER', units='umol m-2 s-1', & - long='mean leaf boundary layer conductance', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_c_lblayer_si ) + call this%set_history_var(vname='FATES_RAD_ERROR', units='W m-2 ', & + long='radiation error in FATES RTM', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', upfreq=2, & + ivar=ivar, initialize=initialize_variables, index = ih_rad_error_si) ! Ecosystem Carbon Fluxes (updated rapidly, upfreq=2) - call this%set_history_var(vname='NPP', units='gC/m^2/s', & - long='net primary production', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_npp_si ) - - call this%set_history_var(vname='GPP', units='gC/m^2/s', & - long='gross primary production', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_gpp_si ) - - call this%set_history_var(vname='AR', units='gC/m^2/s', & - long='autotrophic respiration', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_aresp_si ) - - call this%set_history_var(vname='GROWTH_RESP', units='gC/m^2/s', & - long='growth respiration', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_growth_resp_si ) - - call this%set_history_var(vname='MAINT_RESP', units='gC/m^2/s', & - long='maintenance respiration', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_maint_resp_si ) - - ! Canopy resistance - - call this%set_history_var(vname='C_STOMATA_BY_AGE', units='umol m-2 s-1', & - long='mean stomatal conductance - by patch age', use_default='inactive', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_c_stomata_si_age ) - - call this%set_history_var(vname='C_LBLAYER_BY_AGE', units='umol m-2 s-1', & - long='mean leaf boundary layer conductance - by patch age', use_default='inactive', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_c_lblayer_si_age ) + call this%set_history_var(vname='FATES_NPP', units='kg m-2 s-1', & + long='net primary production in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_npp_si) + + call this%set_history_var(vname='FATES_GPP', units='kg m-2 s-1', & + long='gross primary production in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_gpp_si) + + call this%set_history_var(vname='FATES_AUTORESP', units='kg m-2 s-1', & + long='autotrophic respiration in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_aresp_si) + + call this%set_history_var(vname='FATES_GROWTH_RESP', units='kg m-2 s-1', & + long='growth respiration in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_growth_resp_si) + + call this%set_history_var(vname='FATES_MAINT_RESP', units='kg m-2 s-1', & + long='maintenance respiration in kg carbon per m2 land area per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_maint_resp_si) + + ! Canopy resistance + + call this%set_history_var(vname='FATES_STOMATAL_COND_AP', & + units='mol m-2 s-1', long='mean stomatal conductance - by patch age', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_c_stomata_si_age) + + call this%set_history_var(vname='FATES_LBLAYER_COND_AP', & + units='mol m-2 s-1', & + long='mean leaf boundary layer conductance - by patch age', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_c_lblayer_si_age) ! fast fluxes by age bin - call this%set_history_var(vname='NPP_BY_AGE', units='gC/m^2/s', & - long='net primary productivity by age bin', use_default='inactive', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_npp_si_age ) - - call this%set_history_var(vname='GPP_BY_AGE', units='gC/m^2/s', & - long='gross primary productivity by age bin', use_default='inactive', & - avgflag='A', vtype=site_age_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_gpp_si_age ) + call this%set_history_var(vname='FATES_NPP_AP', units='kg m-2 s-1', & + long='net primary productivity by age bin in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_si_age) + + call this%set_history_var(vname='FATES_GPP_AP', units='kg m-2 s-1', & + long='gross primary productivity by age bin in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_age_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_gpp_si_age) ! fast fluxes separated canopy/understory - call this%set_history_var(vname='GPP_CANOPY', units='gC/m^2/s', & - long='gross primary production of canopy plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_gpp_canopy_si ) - - call this%set_history_var(vname='AR_CANOPY', units='gC/m^2/s', & - long='autotrophic respiration of canopy plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_ar_canopy_si ) - - call this%set_history_var(vname='GPP_UNDERSTORY', units='gC/m^2/s', & - long='gross primary production of understory plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_gpp_understory_si ) - - call this%set_history_var(vname='AR_UNDERSTORY', units='gC/m^2/s', & - long='autotrophic respiration of understory plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_ar_understory_si ) - + call this%set_history_var(vname='FATES_GPP_CANOPY', units='kg m-2 s-1', & + long='gross primary production of canopy plants in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_gpp_canopy_si) + + call this%set_history_var(vname='FATES_AUTORESP_CANOPY', & + units='kg m-2 s-1', & + long='autotrophic respiration of canopy plants in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_ar_canopy_si) + + call this%set_history_var(vname='FATES_GPP_UNDERSTORY', & + units='kg m-2 s-1', & + long='gross primary production of understory plants in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_gpp_understory_si) + + call this%set_history_var(vname='FATES_AUTORESP_UNDERSTORY', & + units='kg m-2 s-1', & + long='autotrophic respiration of understory plants in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_ar_understory_si) ! fast radiative fluxes resolved through the canopy - call this%set_history_var(vname='PARSUN_Z_CNLF', units='W/m2', & - long='PAR absorbed in the sun by each canopy and leaf layer', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parsun_z_si_cnlf ) - - call this%set_history_var(vname='PARSHA_Z_CNLF', units='W/m2', & - long='PAR absorbed in the shade by each canopy and leaf layer', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parsha_z_si_cnlf ) - - call this%set_history_var(vname='PARSUN_Z_CNLFPFT', units='W/m2', & - long='PAR absorbed in the sun by each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parsun_z_si_cnlfpft ) - - call this%set_history_var(vname='PARSHA_Z_CNLFPFT', units='W/m2', & - long='PAR absorbed in the shade by each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parsha_z_si_cnlfpft ) - - call this%set_history_var(vname='PARSUN_Z_CAN', units='W/m2', & + + call this%set_history_var(vname='FATES_PARSUN_Z_CLLL', units='W m-2', & + long='PAR absorbed in the sun by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_parsun_z_si_cnlf) + + call this%set_history_var(vname='FATES_PARSHA_Z_CLLL', units='W m-2', & + long='PAR absorbed in the shade by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_parsha_z_si_cnlf) + + call this%set_history_var(vname='FATES_PARSUN_Z_CLLLPF', units='W m-2', & + long='PAR absorbed in the sun by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parsun_z_si_cnlfpft) + + call this%set_history_var(vname='FATES_PARSHA_Z_CLLLPF', units='W m-2', & + long='PAR absorbed in the shade by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parsha_z_si_cnlfpft) + + call this%set_history_var(vname='FATES_PARSUN_Z_CL', units='W m-2', & long='PAR absorbed in the sun by top leaf layer in each canopy layer', & - use_default='inactive', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parsun_top_si_can ) + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parsun_top_si_can ) - call this%set_history_var(vname='PARSHA_Z_CAN', units='W/m2', & + call this%set_history_var(vname='FATES_PARSHA_Z_CL', units='W m-2', & long='PAR absorbed in the shade by top leaf layer in each canopy layer', & - use_default='inactive', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parsha_top_si_can ) - - call this%set_history_var(vname='LAISUN_Z_CNLF', units='m2/m2', & - long='LAI in the sun by each canopy and leaf layer', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_laisun_z_si_cnlf ) - - call this%set_history_var(vname='LAISHA_Z_CNLF', units='m2/m2', & - long='LAI in the shade by each canopy and leaf layer', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_laisha_z_si_cnlf ) - - call this%set_history_var(vname='LAISUN_Z_CNLFPFT', units='m2/m2', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parsha_top_si_can) + + call this%set_history_var(vname='FATES_LAISUN_Z_CLLL', units='m2 m-2', & + long='LAI in the sun by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisun_z_si_cnlf) + + call this%set_history_var(vname='FATES_LAISHA_Z_CLLL', units='m2 m-2', & + long='LAI in the shade by each canopy and leaf layer', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisha_z_si_cnlf) + + call this%set_history_var(vname='FATES_LAISUN_Z_CLLLPF', units='m2 m-2', & long='LAI in the sun by each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_laisun_z_si_cnlfpft ) - - call this%set_history_var(vname='LAISHA_Z_CNLFPFT', units='m2/m2', & - long='LAI in the shade by each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_laisha_z_si_cnlfpft ) - - call this%set_history_var(vname='LAISUN_TOP_CAN', units='m2/m2', & - long='LAI in the sun by the top leaf layer of each canopy layer', & - use_default='inactive', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_laisun_top_si_can ) - - call this%set_history_var(vname='LAISHA_TOP_CAN', units='m2/m2', & - long='LAI in the shade by the top leaf layer of each canopy layer', & - use_default='inactive', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_laisha_top_si_can ) - - call this%set_history_var(vname='FABD_SUN_CNLFPFT', units='fraction', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisun_z_si_cnlfpft) + + call this%set_history_var(vname='FATES_LAISHA_Z_CLLLPF', units='m2 m-2', & + long='LAI in the shade by each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisha_z_si_cnlfpft) + + call this%set_history_var(vname='FATES_LAISUN_TOP_CL', units='m2 m-2', & + long='LAI in the sun by the top leaf layer of each canopy layer', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisun_top_si_can) + + call this%set_history_var(vname='FATES_LAISHA_TOP_CL', units='m2 m-2', & + long='LAI in the shade by the top leaf layer of each canopy layer', & + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_laisha_top_si_can) + + call this%set_history_var(vname='FATES_FABD_SUN_CLLLPF', units='1', & long='sun fraction of direct light absorbed by each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabd_sun_si_cnlfpft ) + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sun_si_cnlfpft) - call this%set_history_var(vname='FABD_SHA_CNLFPFT', units='fraction', & + call this%set_history_var(vname='FATES_FABD_SHA_CLLLPF', units='1', & long='shade fraction of direct light absorbed by each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabd_sha_si_cnlfpft ) + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sha_si_cnlfpft) - call this%set_history_var(vname='FABI_SUN_CNLFPFT', units='fraction', & + call this%set_history_var(vname='FATES_FABI_SUN_CLLLPF', units='1', & long='sun fraction of indirect light absorbed by each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabi_sun_si_cnlfpft ) + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sun_si_cnlfpft) - call this%set_history_var(vname='FABI_SHA_CNLFPFT', units='fraction', & + call this%set_history_var(vname='FATES_FABI_SHA_CLLLPF', units='1', & long='shade fraction of indirect light absorbed by each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabi_sha_si_cnlfpft ) + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sha_si_cnlfpft) - call this%set_history_var(vname='FABD_SUN_CNLF', units='fraction', & + call this%set_history_var(vname='FATES_FABD_SUN_CLLL', units='1', & long='sun fraction of direct light absorbed by each canopy and leaf layer', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabd_sun_si_cnlf ) + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sun_si_cnlf) - call this%set_history_var(vname='FABD_SHA_CNLF', units='fraction', & + call this%set_history_var(vname='FATES_FABD_SHA_CLLL', units='1', & long='shade fraction of direct light absorbed by each canopy and leaf layer', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabd_sha_si_cnlf ) + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sha_si_cnlf) - call this%set_history_var(vname='FABI_SUN_CNLF', units='fraction', & + call this%set_history_var(vname='FATES_FABI_SUN_CLLL', units='1', & long='sun fraction of indirect light absorbed by each canopy and leaf layer', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabi_sun_si_cnlf ) + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sun_si_cnlf) - call this%set_history_var(vname='FABI_SHA_CNLF', units='fraction', & + call this%set_history_var(vname='FATES_FABI_SHA_CLLL', units='1', & long='shade fraction of indirect light absorbed by each canopy and leaf layer', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabi_sha_si_cnlf ) - - call this%set_history_var(vname='PARPROF_DIR_CNLFPFT', units='W/m2', & - long='Radiative profile of direct PAR through each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parprof_dir_si_cnlfpft ) - - call this%set_history_var(vname='PARPROF_DIF_CNLFPFT', units='W/m2', & - long='Radiative profile of diffuse PAR through each canopy, leaf, and PFT', & - use_default='inactive', & - avgflag='A', vtype=site_cnlfpft_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parprof_dif_si_cnlfpft ) - - call this%set_history_var(vname='PARPROF_DIR_CNLF', units='W/m2', & - long='Radiative profile of direct PAR through each canopy and leaf layer (averaged across PFTs)', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parprof_dir_si_cnlf ) - - call this%set_history_var(vname='PARPROF_DIF_CNLF', units='W/m2', & - long='Radiative profile of diffuse PAR through each canopy and leaf layer (averaged across PFTs)', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_parprof_dif_si_cnlf ) - - call this%set_history_var(vname='FABD_SUN_TOPLF_BYCANLAYER', units='fraction', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sha_si_cnlf) + + call this%set_history_var(vname='FATES_PARPROF_DIR_CLLLPF', units='W m-2', & + long='radiative profile of direct PAR through each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parprof_dir_si_cnlfpft) + + call this%set_history_var(vname='FATES_PARPROF_DIF_CLLLPF', units='W m-2', & + long='radiative profile of diffuse PAR through each canopy, leaf, and PFT', & + use_default='inactive', avgflag='A', vtype=site_cnlfpft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parprof_dif_si_cnlfpft) + + call this%set_history_var(vname='FATES_PARPROF_DIR_CLLL', units='W m-2', & + long='radiative profile of direct PAR through each canopy and leaf layer (averaged across PFTs)', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parprof_dir_si_cnlf) + + call this%set_history_var(vname='FATES_PARPROF_DIF_CLLL', units='W m-2', & + long='radiative profile of diffuse PAR through each canopy and leaf layer (averaged across PFTs)', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_parprof_dif_si_cnlf) + + call this%set_history_var(vname='FATES_FABD_SUN_TOPLF_CL', units='1', & long='sun fraction of direct light absorbed by the top leaf layer of each canopy layer', & - use_default='inactive', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabd_sun_top_si_can ) + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sun_top_si_can) - call this%set_history_var(vname='FABD_SHA_TOPLF_BYCANLAYER', units='fraction', & + call this%set_history_var(vname='FATES_FABD_SHA_TOPLF_CL', units='1', & long='shade fraction of direct light absorbed by the top leaf layer of each canopy layer', & - use_default='inactive', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabd_sha_top_si_can ) + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabd_sha_top_si_can) - call this%set_history_var(vname='FABI_SUN_TOPLF_BYCANLAYER', units='fraction', & + call this%set_history_var(vname='FATES_FABI_SUN_TOPLF_CL', units='1', & long='sun fraction of indirect light absorbed by the top leaf layer of each canopy layer', & - use_default='inactive', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabi_sun_top_si_can ) + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sun_top_si_can) - call this%set_history_var(vname='FABI_SHA_TOPLF_BYCANLAYER', units='fraction', & + call this%set_history_var(vname='FATES_FABI_SHA_TOPLF_CL', units='1', & long='shade fraction of indirect light absorbed by the top leaf layer of each canopy layer', & - use_default='inactive', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_fabi_sha_top_si_can ) + use_default='inactive', avgflag='A', vtype=site_can_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_fabi_sha_top_si_can) !!! canopy-resolved fluxes and structure - call this%set_history_var(vname='NET_C_UPTAKE_CNLF', units='gC/m2/s', & - long='net carbon uptake by each canopy and leaf layer per unit ground area (i.e. divide by CROWNAREA_CNLF to make per leaf area)', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=2, & - ivar=ivar, initialize=initialize_variables, index = ih_ts_net_uptake_si_cnlf ) - call this%set_history_var(vname='CROWNAREA_CNLF', units='m2/m2', & + call this%set_history_var(vname='FATES_NET_C_UPTAKE_CLLL', & + units='kg m-2 s-1', & + long='net carbon uptake in kg carbon per m2 per second by each canopy and leaf layer per unit ground area (i.e. divide by CROWNAREA_CLLL to make per leaf area)', & + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_ts_net_uptake_si_cnlf) + + call this%set_history_var(vname='FATES_CROWNAREA_CLLL', units='m2 m-2', & long='total crown area that is occupied by leaves in each canopy and leaf layer', & - use_default='inactive', & - avgflag='A', vtype=site_cnlf_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_crownarea_si_cnlf ) + use_default='inactive', avgflag='A', vtype=site_cnlf_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_crownarea_si_cnlf) - call this%set_history_var(vname='CROWNAREA_CAN', units='m2/m2', & - long='total crown area in each canopy layer', & - use_default='active', & - avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & - ivar=ivar, initialize=initialize_variables, index = ih_crownarea_si_can ) + call this%set_history_var(vname='FATES_CROWNAREA_CL', units='m2 m-2', & + long='total crown area in each canopy layer', use_default='active', & + avgflag='A', vtype=site_can_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_crownarea_si_can) ! slow carbon fluxes associated with mortality from or transfer betweeen canopy and understory - call this%set_history_var(vname='DEMOTION_CARBONFLUX', units = 'gC/m2/s', & - long='demotion-associated biomass carbon flux from canopy to understory', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_demotion_carbonflux_si ) - - call this%set_history_var(vname='PROMOTION_CARBONFLUX', units = 'gC/m2/s', & - long='promotion-associated biomass carbon flux from understory to canopy', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_promotion_carbonflux_si ) - - call this%set_history_var(vname='MORTALITY_CARBONFLUX_CANOPY', units = 'gC/m2/s', & - long='flux of biomass carbon from live to dead pools from mortality of canopy plants', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_canopy_mortality_carbonflux_si ) - - call this%set_history_var(vname='MORTALITY_CARBONFLUX_UNDERSTORY', units = 'gC/m2/s', & - long='flux of biomass carbon from live to dead pools from mortality of understory plants',use_default='active',& - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_understory_mortality_carbonflux_si ) + + call this%set_history_var(vname='FATES_DEMOTION_CARBONFLUX', & + units = 'kg m-2 s-1', & + long='demotion-associated biomass carbon flux from canopy to understory in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_demotion_carbonflux_si) + + call this%set_history_var(vname='FATES_PROMOTION_CARBONFLUX', & + units = 'kg m-2 s-1', & + long='promotion-associated biomass carbon flux from understory to canopy in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_promotion_carbonflux_si) + + call this%set_history_var(vname='FATES_MORTALITY_CFLUX_CANOPY', & + units = 'kg m-2 s-1', & + long='flux of biomass carbon from live to dead pools from mortality of canopy plants in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_canopy_mortality_carbonflux_si) + + call this%set_history_var(vname='FATES_MORTALITY_CFLUX_UNDERSTORY', & + units = 'kg m-2 s-1', & + long='flux of biomass carbon from live to dead pools from mortality of understory plants in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_understory_mortality_carbonflux_si) ! size class by age dimensioned variables - call this%set_history_var(vname='NPLANT_SCAG',units = 'plants/ha', & - long='number of plants per hectare in each size x age class', use_default='active', & - avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scag ) - - call this%set_history_var(vname='NPLANT_CANOPY_SCAG',units = 'plants/ha', & - long='number of plants per hectare in canopy in each size x age class', use_default='inactive', & - avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_canopy_si_scag ) - - call this%set_history_var(vname='NPLANT_UNDERSTORY_SCAG',units = 'plants/ha', & - long='number of plants per hectare in understory in each size x age class', use_default='inactive', & - avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_understory_si_scag ) - - call this%set_history_var(vname='DDBH_CANOPY_SCAG',units = 'cm/yr/ha', & - long='growth rate of canopy plantsnumber of plants per hectare in canopy in each size x age class', & - use_default='inactive', avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_canopy_si_scag ) - - call this%set_history_var(vname='DDBH_UNDERSTORY_SCAG',units = 'cm/yr/ha', & - long='growth rate of understory plants in each size x age class', use_default='inactive', & - avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_understory_si_scag ) - - call this%set_history_var(vname='MORTALITY_CANOPY_SCAG',units = 'plants/ha/yr', & - long='mortality rate of canopy plants in each size x age class', use_default='inactive', & - avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_canopy_si_scag ) - - call this%set_history_var(vname='MORTALITY_UNDERSTORY_SCAG',units = 'plants/ha/yr', & - long='mortality rate of understory plantsin each size x age class', use_default='inactive', & - avgflag='A', vtype=site_scag_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_understory_si_scag ) + + call this%set_history_var(vname='FATES_NPLANT_SZAP', units = 'm-2', & + long='number of plants per m2 in each size x age class', & + use_default='inactive', avgflag='A', vtype=site_scag_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nplant_si_scag) + + call this%set_history_var(vname='FATES_NPLANT_CANOPY_SZAP', units = 'm-2', & + long='number of plants per m2 in canopy in each size x age class', & + use_default='inactive', avgflag='A', vtype=site_scag_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nplant_canopy_si_scag) + + call this%set_history_var(vname='FATES_NPLANT_USTORY_SZAP', & + units = 'm-2', & + long='number of plants per m2 in understory in each size x age class', & + use_default='inactive', avgflag='A', vtype=site_scag_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nplant_understory_si_scag) + + call this%set_history_var(vname='FATES_DDBH_CANOPY_SZAP', & + units = 'm m-2 yr-1', & + long='growth rate of canopy plants in meters DBH per m2 per year in canopy in each size x age class', & + use_default='inactive', avgflag='A', vtype=site_scag_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_ddbh_canopy_si_scag) + + call this%set_history_var(vname='FATES_DDBH_USTORY_SZAP', & + units = 'm m-2 yr-1', & + long='growth rate of understory plants in meters DBH per m2 per year in each size x age class', & + use_default='inactive', avgflag='A', vtype=site_scag_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_ddbh_understory_si_scag) + + call this%set_history_var(vname='FATES_MORTALITY_CANOPY_SZAP', & + units = 'm-2 yr-1', & + long='mortality rate of canopy plants in number of plants per m2 per year in each size x age class', & + use_default='inactive', avgflag='A', vtype=site_scag_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_mortality_canopy_si_scag) + + call this%set_history_var(vname='FATES_MORTALITY_USTORY_SZAP', & + units = 'm-2 yr-1', & + long='mortality rate of understory plants in number of plants per m2 per year in each size x age class', & + use_default='inactive', avgflag='A', vtype=site_scag_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_mortality_understory_si_scag) ! size x age x pft dimensioned - call this%set_history_var(vname='NPLANT_SCAGPFT',units = 'plants/ha', & - long='number of plants per hectare in each size x age x pft class', use_default='inactive', & - avgflag='A', vtype=site_scagpft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scagpft ) + + call this%set_history_var(vname='FATES_NPLANT_SZAPPF',units = 'm-2', & + long='number of plants per m2 in each size x age x pft class', & + use_default='inactive', avgflag='A', vtype=site_scagpft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nplant_si_scagpft) ! age x pft dimensioned - call this%set_history_var(vname='NPP_AGEPFT',units = 'kgC/m2/yr', & - long='NPP per PFT in each age bin', use_default='inactive', & - avgflag='A', vtype=site_agepft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_si_agepft ) + call this%set_history_var(vname='FATES_NPP_APPF',units = 'kg m-2 s-1', & + long='NPP per PFT in each age bin in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_agepft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_npp_si_agepft) - call this%set_history_var(vname='BIOMASS_AGEPFT',units = 'kg C / m2', & - long='biomass per PFT in each age bin', use_default='inactive', & - avgflag='A', vtype=site_agepft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_agepft ) + call this%set_history_var(vname='FATES_VEGC_APPF',units = 'kg m-2', & + long='biomass per PFT in each age bin in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_agepft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_biomass_si_agepft) - call this%set_history_var(vname='SCORCH_HEIGHT',units = 'm', & - long='SPITFIRE Flame Scorch Height (calculated per PFT in each patch age bin)', & - use_default='active', & - avgflag='A', vtype=site_agepft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_scorch_height_si_agepft ) + call this%set_history_var(vname='FATES_SCORCH_HEIGHT_APPF',units = 'm', & + long='SPITFIRE flame Scorch Height (calculated per PFT in each patch age bin)', & + use_default='inactive', avgflag='A', vtype=site_agepft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_scorch_height_si_agepft) ! Carbon Flux (grid dimension x scpf) (THESE ARE DEFAULT INACTIVE!!! ! (BECAUSE THEY TAKE UP SPACE!!! ! =================================================================================== - call this%set_history_var(vname='GPP_SCPF', units='kgC/m2/yr', & - long='gross primary production by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_gpp_si_scpf ) - - call this%set_history_var(vname='GPP_CANOPY_SCPF', units='kgC/m2/yr', & - long='gross primary production of canopy plants by pft/size ', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_gpp_canopy_si_scpf ) - - call this%set_history_var(vname='AR_CANOPY_SCPF', units='kgC/m2/yr', & - long='autotrophic respiration of canopy plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ar_canopy_si_scpf ) - - call this%set_history_var(vname='GPP_UNDERSTORY_SCPF', units='kgC/m2/yr', & - long='gross primary production of understory plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_gpp_understory_si_scpf ) - - call this%set_history_var(vname='AR_UNDERSTORY_SCPF', units='kgC/m2/yr', & - long='autotrophic respiration of understory plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ar_understory_si_scpf ) - - call this%set_history_var(vname='NPP_SCPF', units='kgC/m2/yr', & - long='total net primary production by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_totl_si_scpf ) - - call this%set_history_var(vname='NPP_LEAF_SCPF', units='kgC/m2/yr', & - long='NPP flux into leaves by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_si_scpf ) - - call this%set_history_var(vname='NPP_SEED_SCPF', units='kgC/m2/yr', & - long='NPP flux into seeds by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_seed_si_scpf ) - - call this%set_history_var(vname='NPP_FNRT_SCPF', units='kgC/m2/yr', & - long='NPP flux into fine roots by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_fnrt_si_scpf ) - - call this%set_history_var(vname='NPP_BGSW_SCPF', units='kgC/m2/yr', & - long='NPP flux into below-ground sapwood by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bgsw_si_scpf ) - - call this%set_history_var(vname='NPP_BGDW_SCPF', units='kgC/m2/yr', & - long='NPP flux into below-ground deadwood by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_bgdw_si_scpf ) - - call this%set_history_var(vname='NPP_AGSW_SCPF', units='kgC/m2/yr', & - long='NPP flux into above-ground sapwood by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_agsw_si_scpf ) - - call this%set_history_var(vname = 'NPP_AGDW_SCPF', units='kgC/m2/yr', & - long='NPP flux into above-ground deadwood by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_agdw_si_scpf ) - - call this%set_history_var(vname = 'NPP_STOR_SCPF', units='kgC/m2/yr', & - long='NPP flux into storage by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stor_si_scpf ) - - call this%set_history_var(vname='DDBH_SCPF', units = 'cm/yr/ha', & - long='diameter growth increment by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_si_scpf ) - - call this%set_history_var(vname='GROWTHFLUX_SCPF', units = 'n/yr/ha', & - long='flux of individuals into a given size class bin via growth and recruitment',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_growthflux_si_scpf ) - - call this%set_history_var(vname='GROWTHFLUX_FUSION_SCPF', units = 'n/yr/ha', & - long='flux of individuals into a given size class bin via fusion',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_growthflux_fusion_si_scpf ) - - call this%set_history_var(vname='DDBH_CANOPY_SCPF', units = 'cm/yr/ha', & - long='diameter growth increment by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_canopy_si_scpf ) - - call this%set_history_var(vname='DDBH_UNDERSTORY_SCPF', units = 'cm/yr/ha', & - long='diameter growth increment by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_understory_si_scpf ) - - call this%set_history_var(vname='BA_SCPF', units = 'm2/ha', & - long='basal area by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scpf ) - - call this%set_history_var(vname='AGB_SCPF', units = 'kgC/m2', & - long='Aboveground biomass by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_agb_si_scpf ) - - call this%set_history_var(vname='NPLANT_SCPF', units = 'N/ha', & - long='stem number density by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scpf ) - - call this%set_history_var(vname='NPLANT_CAPF', units = 'N/ha', & - long='stem number density by pft/coage', use_default='inactive', & - avgflag='A', vtype=site_coage_pft_r8, hlms='CLM:ALM',flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_capf ) - - call this%set_history_var(vname='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='CROWNFIREMORT_SCPF', units = 'N/ha/yr', & - long='crown fire mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_crownfiremort_si_scpf ) - - call this%set_history_var(vname='CAMBIALFIREMORT_SCPF', units = 'N/ha/yr', & - long='cambial fire mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cambialfiremort_si_scpf ) - - call this%set_history_var(vname='M6_SCPF', units = 'N/ha/yr', & - long='termination mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m6_si_scpf ) - - call this%set_history_var(vname='M7_SCPF', units = 'N/ha/event', & - long='logging mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m7_si_scpf ) - - call this%set_history_var(vname='M8_SCPF', units = 'N/ha/yr', & - long='freezing mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m8_si_scpf ) - - call this%set_history_var(vname='M9_SCPF', units = 'N/ha/yr', & - long='senescence mortality by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m9_si_scpf ) - - call this%set_history_var(vname='M10_SCPF', units = 'N/ha/yr', & - long='age senescence mortality by pft/size',use_default='inactive', & - avgflag='A', vtype =site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m10_si_scpf ) - - call this%set_history_var(vname='M10_CAPF',units='N/ha/yr', & - long='age senescence mortality by pft/cohort age',use_default='inactive', & - avgflag='A', vtype =site_coage_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index =ih_m10_si_capf ) - - call this%set_history_var(vname='MORTALITY_CANOPY_SCPF', units = 'N/ha/yr', & - long='total mortality of canopy plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_canopy_si_scpf ) - - call this%set_history_var(vname='C13disc_SCPF', units = 'per mil', & - long='C13 discrimination by pft/size',use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_c13disc_si_scpf ) - - call this%set_history_var(vname='BSTOR_CANOPY_SCPF', units = 'kgC/ha', & - long='biomass carbon in storage pools of canopy plants by pft/size', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - 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 ) + call this%set_history_var(vname='FATES_GPP_SZPF', units='kg m-2 s-1', & + long='gross primary production by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_gpp_si_scpf) + + call this%set_history_var(vname='FATES_GPP_CANOPY_SZPF', & + units='kg m-2 s-1', & + long='gross primary production of canopy plants by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_gpp_canopy_si_scpf) + + call this%set_history_var(vname='FATES_AUTORESP_CANOPY_SZPF', & + units='kg m-2 s-1', & + long='autotrophic respiration of canopy plants by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_canopy_si_scpf) + + call this%set_history_var(vname='FATES_GPP_USTORY_SZPF', & + units='kg m-2 s-1', & + long='gross primary production of understory plants by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_gpp_understory_si_scpf) + + call this%set_history_var(vname='FATES_AUTORESP_USTORY_SZPF', & + units='kg m-2 s-1', & + long='autotrophic respiration of understory plants by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_understory_si_scpf) + + call this%set_history_var(vname='FATES_NPP_SZPF', units='kg m-2 s-1', & + long='total net primary production by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_npp_totl_si_scpf) + + call this%set_history_var(vname='FATES_LEAF_ALLOC_SZPF', units='kg m-2 s-1', & + long='allocation to leaves by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_npp_leaf_si_scpf) + + call this%set_history_var(vname='FATES_SEED_ALLOC_SZPF', units='kg m-2 s-1', & + long='allocation to seeds by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_npp_seed_si_scpf) + + call this%set_history_var(vname='FATES_FROOT_ALLOC_SZPF', & + units='kg m-2 s-1', & + long='allocation to fine roots by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_npp_fnrt_si_scpf) + + call this%set_history_var(vname='FATES_BGSAPWOOD_ALLOC_SZPF', & + units='kg m-2 s-1', & + long='allocation to below-ground sapwood by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_bgsw_si_scpf) + + call this%set_history_var(vname='FATES_BGSTRUCT_ALLOC_SZPF', units='kg m-2 s-1', & + long='allocation to below-ground structural (deadwood) by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_bgdw_si_scpf) + + call this%set_history_var(vname='FATES_AGSAPWOOD_ALLOC_SZPF', & + units='kg m-2 s-1', & + long='allocation to above-ground sapwood by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_agsw_si_scpf) + + call this%set_history_var(vname = 'FATES_AGSTRUCT_ALLOC_SZPF', & + units='kg m-2 s-1', & + long='allocation to above-ground structural (deadwood) by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_agdw_si_scpf) + + call this%set_history_var(vname = 'FATES_STORE_ALLOC_SZPF', & + units='kg m-2 s-1', & + long='allocation to storage C by pft/size in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_stor_si_scpf) + + call this%set_history_var(vname='FATES_DDBH_SZPF', units = 'm m-2 yr-1', & + long='diameter growth increment by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_ddbh_si_scpf) + + call this%set_history_var(vname='FATES_GROWTHFLUX_SZPF', & + units = 'm-2 yr-1', & + long='flux of individuals into a given size class bin via growth and recruitment', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_growthflux_si_scpf) + + call this%set_history_var(vname='FATES_GROWTHFLUX_FUSION_SZPF', & + units = 'm-2 yr-1', & + long='flux of individuals into a given size class bin via fusion', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_growthflux_fusion_si_scpf) + + call this%set_history_var(vname='FATES_DDBH_CANOPY_SZPF', & + units = 'm m-2 yr-1', & + long='diameter growth increment by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_ddbh_canopy_si_scpf) + + call this%set_history_var(vname='FATES_DDBH_USTORY_SZPF', & + units = 'm m-2 yr-1', & + long='diameter growth increment by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_ddbh_understory_si_scpf) + + call this%set_history_var(vname='FATES_BASALAREA_SZPF', units = 'm2 m-2', & + long='basal area by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scpf) + + call this%set_history_var(vname='FATES_VEGC_ABOVEGROUND_SZPF', & + units = 'kg m-2', & + long='aboveground biomass by pft/size in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_agb_si_scpf) + + call this%set_history_var(vname='FATES_NPLANT_SZPF', units = 'm-2', & + long='stem number density by pft/size', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_nplant_si_scpf) + + call this%set_history_var(vname='FATES_NPLANT_ACPF', units = 'm-2', & + long='stem number density by pft and age class', & + use_default='inactive', avgflag='A', vtype=site_coage_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_nplant_si_capf) + + call this%set_history_var(vname='FATES_MORTALITY_BACKGROUND_SZPF', & + units = 'm-2 yr-1', & + long='background mortality by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m1_si_scpf) + + call this%set_history_var(vname='FATES_MORTALITY_HYDRAULIC_SZPF', & + units = 'm-2 yr-1', & + long='hydraulic mortality by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m2_si_scpf) + + call this%set_history_var(vname='FATES_MORTALITY_CSTARV_SZPF', & + units = 'm-2 yr-1', & + long='carbon starvation mortality by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m3_si_scpf) + + call this%set_history_var(vname='FATES_MORTALITY_IMPACT_SZPF', & + units = 'm-2 yr-1', & + long='impact mortality by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m4_si_scpf) + + call this%set_history_var(vname='FATES_MORTALITY_FIRE_SZPF', & + units = 'm-2 yr-1', & + long='fire mortality by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m5_si_scpf) + + call this%set_history_var(vname='FATES_MORTALITY_CROWNSCORCH_SZPF', & + units = 'm-2 yr-1', & + long='fire mortality from crown scorch by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_crownfiremort_si_scpf) + + call this%set_history_var(vname='FATES_MORTALITY_CAMBIALBURN_SZPF', & + units = 'm-2 yr-1', & + long='fire mortality from cambial burn by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cambialfiremort_si_scpf) + + call this%set_history_var(vname='FATES_MORTALITY_TERMINATION_SZPF', & + units = 'm-2 yr-1', & + long='termination mortality by pft/size in number pf plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m6_si_scpf) + + call this%set_history_var(vname='FATES_MORTALITY_LOGGING_SZPF', & + units = 'm-2 yr-1', & + long='logging mortality by pft/size in number of plants per m2 per ', & + use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_m7_si_scpf) + + call this%set_history_var(vname='FATES_MORTALITY_FREEZING_SZPF', & + units = 'm-2 yr-1', & + long='freezing mortality by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m8_si_scpf) + + call this%set_history_var(vname='FATES_MORTALITY_SENESCENCE_SZPF', & + units = 'm-2 yr-1', & + long='senescence mortality by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m9_si_scpf) + + call this%set_history_var(vname='FATES_MORTALITY_AGESCEN_SZPF', & + units = 'm-2 yr-1', & + long='age senescence mortality by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype =site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_m10_si_scpf) + + call this%set_history_var(vname='FATES_MORTALITY_AGESCEN_ACPF', & + units='m-2 yr-1', & + long='age senescence mortality by pft/cohort age in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype =site_coage_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index =ih_m10_si_capf) + + call this%set_history_var(vname='FATES_MORTALITY_CANOPY_SZPF', & + units = 'm-2 yr-1', & + long='total mortality of canopy plants by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_mortality_canopy_si_scpf) + + call this%set_history_var(vname='FATES_C13DISC_SZPF', units = 'per mil', & + long='C13 discrimination by pft/size',use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_c13disc_si_scpf) + + call this%set_history_var(vname='FATES_STOREC_CANOPY_SZPF', units = 'kg m-2', & + long='biomass in storage pools of canopy plants by pft/size in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_bstor_canopy_si_scpf) + + call this%set_history_var(vname='FATES_LEAFC_CANOPY_SZPF', & + units = 'kg m-2', & + long='biomass in leaves of canopy plants by pft/size in kg carbon per m2', & + use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, & + index = ih_bleaf_canopy_si_scpf) + + call this%set_history_var(vname='FATES_NPLANT_CANOPY_SZPF', units = 'm-2', & + long='number of canopy plants by size/pft per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nplant_canopy_si_scpf) + + call this%set_history_var(vname='FATES_MORTALITY_USTORY_SZPF', & + units = 'm-2 yr-1', & + long='total mortality of understory plants by pft/size in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_mortality_understory_si_scpf) + + call this%set_history_var(vname='FATES_STOREC_USTORY_SZPF', & + units = 'kg m-2', & + long='biomass in storage pools of understory plants by pft/size in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_bstor_understory_si_scpf) + + call this%set_history_var(vname='FATES_LEAFC_USTORY_SZPF', & + units = 'kg m-2', & + long='biomass in leaves of understory plants by pft/size in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_bleaf_understory_si_scpf) + + call this%set_history_var(vname='FATES_NPLANT_USTORY_SZPF', & + units = 'm-2', & + long='density of understory plants by pft/size in number of plants per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nplant_understory_si_scpf) + + call this%set_history_var(vname='FATES_CWD_ABOVEGROUND_DC', units='kg m-2', & + long='debris class-level aboveground coarse woody debris stocks in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_cwdsc_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cwd_ag_si_cwdsc) + + call this%set_history_var(vname='FATES_CWD_BELOWGROUND_DC', units='kg m-2', & + long='debris class-level belowground coarse woody debris stocks in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_cwdsc_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cwd_bg_si_cwdsc) + + call this%set_history_var(vname='FATES_CWD_ABOVEGROUND_IN_DC', & + units='kg m-2 s-1', & + long='debris class-level aboveground coarse woody debris input in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_cwdsc_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cwd_ag_in_si_cwdsc) + + call this%set_history_var(vname='FATES_CWD_BELOWGROUND_IN_DC', & + units='kg m-2 s-1', & + long='debris class-level belowground coarse woody debris input in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_cwdsc_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cwd_bg_in_si_cwdsc) + + call this%set_history_var(vname='FATES_CWD_ABOVEGROUND_OUT_DC', & + units='kg m-2 s-1', & + long='debris class-level aboveground coarse woody debris output in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_cwdsc_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cwd_ag_out_si_cwdsc) + + call this%set_history_var(vname='FATES_CWD_BELOWGROUND_OUT_DC', & + units='kg m-2 s-1', & + long='debris class-level belowground coarse woody debris output in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_cwdsc_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cwd_bg_out_si_cwdsc) ! Size structured diagnostics that require rapid updates (upfreq=2) - call this%set_history_var(vname='AR_SCPF',units = 'kgC/m2/yr', & - long='total autotrophic respiration per m2 per year by pft/size',use_default='inactive',& - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', 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 ) + call this%set_history_var(vname='FATES_AUTORESP_SZPF', & + units = 'kg m-2 s-1', & + long='total autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_si_scpf) + + call this%set_history_var(vname='FATES_GROWAR_SZPF', & + units = 'kg m-2 s-1', & + long='growth autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_grow_si_scpf) + + call this%set_history_var(vname='FATES_MAINTAR_SZPF', & + units = 'kg m-2 s-1', & + long='maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_maint_si_scpf) + + call this%set_history_var(vname='FATES_RDARK_SZPF', & + units = 'kg m-2 s-1', & + long='dark portion of maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_darkm_si_scpf) + + call this%set_history_var(vname='FATES_AGSAPMAINTAR_SZPF', & + units = 'kg m-2 s-1', & + long='above-ground sapwood maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_agsapm_si_scpf) + + call this%set_history_var(vname='FATES_BGSAPMAINTAR_SZPF', & + units = 'kg m-2 s-1', & + long='below-ground sapwood maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_crootm_si_scpf) + + call this%set_history_var(vname='FATES_FROOTMAINTAR_SZPF', & + units = 'kg m-2 s-1', & + long='fine root maintenance autotrophic respiration in kg carbon per m2 per second by pft/size', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_ar_frootm_si_scpf) ! size-class only variables - call this%set_history_var(vname='DDBH_CANOPY_SCLS', units = 'cm/yr/ha', & - long='diameter growth increment by pft/size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_canopy_si_scls ) - - call this%set_history_var(vname='DDBH_UNDERSTORY_SCLS', units = 'cm/yr/ha', & - long='diameter growth increment by pft/size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_ddbh_understory_si_scls ) - - call this%set_history_var(vname='YESTERDAYCANLEV_CANOPY_SCLS', units = 'indiv/ha', & - long='Yesterdays canopy level for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - 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='active', & - 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='AGB_SCLS', units = 'kgC/m2', & - long='Aboveground biomass by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_agb_si_scls ) - - call this%set_history_var(vname='BIOMASS_SCLS', units = 'kgC/m2', & - long='Total biomass by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_biomass_si_scls ) - - call this%set_history_var(vname='DEMOTION_RATE_SCLS', units = 'indiv/ha/yr', & - long='demotion rate from canopy to understory by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - 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='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_canopy_si_scls ) - - call this%set_history_var(vname='LAI_CANOPY_SCLS', units = 'm2/m2', & - long='Leaf are index (LAI) by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_lai_canopy_si_scls ) - - call this%set_history_var(vname='SAI_CANOPY_SCLS', units = 'm2/m2', & - long='stem area index(SAI) by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sai_canopy_si_scls ) - - call this%set_history_var(vname='MORTALITY_CANOPY_SCLS', units = 'indiv/ha/yr', & - long='total mortality of canopy trees by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_canopy_si_scls ) - - call this%set_history_var(vname='NPLANT_UNDERSTORY_SCLS', units = 'indiv/ha', & - long='number of understory plants by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_understory_si_scls ) - - call this%set_history_var(vname='LAI_UNDERSTORY_SCLS', units = 'indiv/ha', & - long='number of understory plants by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_lai_understory_si_scls ) - - call this%set_history_var(vname='SAI_UNDERSTORY_SCLS', units = 'indiv/ha', & - long='number of understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sai_understory_si_scls ) - - call this%set_history_var(vname='NPLANT_SCLS', units = 'indiv/ha', & - long='number of plants by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scls ) - - call this%set_history_var(vname='NPLANT_CACLS', units = 'indiv/ha', & - long='number of plants by coage class', use_default='active', & - avgflag='A', vtype=site_coage_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_cacls ) - - call this%set_history_var(vname='M1_SCLS', units = 'N/ha/yr', & - long='background mortality by size', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m1_si_scls ) - - call this%set_history_var(vname='M2_SCLS', units = 'N/ha/yr', & - long='hydraulic mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m2_si_scls ) - - call this%set_history_var(vname='M3_SCLS', units = 'N/ha/yr', & - long='carbon starvation mortality by size', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m3_si_scls ) - - call this%set_history_var(vname='M4_SCLS', units = 'N/ha/yr', & - long='impact mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m4_si_scls ) - - call this%set_history_var(vname='M5_SCLS', units = 'N/ha/yr', & - long='fire mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m5_si_scls ) - - call this%set_history_var(vname='M6_SCLS', units = 'N/ha/yr', & - long='termination mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m6_si_scls ) - - call this%set_history_var(vname='M7_SCLS', units = 'N/ha/event', & - long='logging mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m7_si_scls ) - - call this%set_history_var(vname='M8_SCLS', units = 'N/ha/event', & - long='freezing mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m8_si_scls ) - - call this%set_history_var(vname='M9_SCLS', units = 'N/ha/yr', & - long='senescence mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m9_si_scls ) - - call this%set_history_var(vname='M10_SCLS', units = 'N/ha/yr', & - long='age senescence mortality by size',use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m10_si_scls ) - - call this%set_history_var(vname='M10_CACLS', units = 'N/ha/yr', & - long='age senescence mortality by cohort age',use_default='active', & - avgflag='A', vtype=site_coage_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_m10_si_cacls ) - - call this%set_history_var(vname='CARBON_BALANCE_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='CARBON_BALANCE for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_carbon_balance_canopy_si_scls ) - - call this%set_history_var(vname='CARBON_BALANCE_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='CARBON_BALANCE for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_carbon_balance_understory_si_scls ) - - call this%set_history_var(vname='MORTALITY_UNDERSTORY_SCLS', units = 'indiv/ha/yr', & - long='total mortality of understory trees by size class', use_default='active', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_mortality_understory_si_scls ) - - call this%set_history_var(vname='TRIMMING_CANOPY_SCLS', units = 'indiv/ha', & - long='trimming term of canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_trimming_canopy_si_scls ) - - call this%set_history_var(vname='TRIMMING_UNDERSTORY_SCLS', units = 'indiv/ha', & - long='trimming term of understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_trimming_understory_si_scls ) - - call this%set_history_var(vname='CROWN_AREA_CANOPY_SCLS', units = 'm2/ha', & - long='total crown area of canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_crown_area_canopy_si_scls ) - - call this%set_history_var(vname='CROWN_AREA_UNDERSTORY_SCLS', units = 'm2/ha', & - long='total crown area of understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_crown_area_understory_si_scls ) - - call this%set_history_var(vname='LEAF_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='LEAF_MD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - 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='BSTORE_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='BSTORE_MD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstore_md_canopy_si_scls ) - - call this%set_history_var(vname='BDEAD_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='BDEAD_MD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bdead_md_canopy_si_scls ) - - call this%set_history_var(vname='BSW_MD_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='BSW_MD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bsw_md_canopy_si_scls ) - - call this%set_history_var(vname='SEED_PROD_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='SEED_PROD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_seed_prod_canopy_si_scls ) - - call this%set_history_var(vname='NPP_LEAF_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='NPP_LEAF for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=-999.9_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_canopy_si_scls ) - - call this%set_history_var(vname='NPP_FROOT_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='NPP_FROOT for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_fnrt_canopy_si_scls ) - - call this%set_history_var(vname='NPP_BSW_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='NPP_BSW for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_sapw_canopy_si_scls ) - - call this%set_history_var(vname='NPP_BDEAD_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='NPP_BDEAD for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_dead_canopy_si_scls ) - - call this%set_history_var(vname='NPP_BSEED_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='NPP_BSEED for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_seed_canopy_si_scls ) - - call this%set_history_var(vname='NPP_STORE_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='NPP_STORE for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stor_canopy_si_scls ) - - call this%set_history_var(vname='LEAF_MR', units = 'kg C / m2 / yr', & - long='RDARK (leaf maintenance respiration)', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_leaf_mr_si ) - - call this%set_history_var(vname='FROOT_MR', units = 'kg C / m2 / yr', & - long='fine root maintenance respiration)', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_froot_mr_si ) - - call this%set_history_var(vname='LIVECROOT_MR', units = 'kg C / m2 / yr', & - long='live coarse root maintenance respiration)', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livecroot_mr_si ) - - call this%set_history_var(vname='LIVESTEM_MR', units = 'kg C / m2 / yr', & - long='live stem maintenance respiration)', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livestem_mr_si ) - - call this%set_history_var(vname='RDARK_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='RDARK for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_rdark_canopy_si_scls ) - - call this%set_history_var(vname='LIVESTEM_MR_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='LIVESTEM_MR for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livestem_mr_canopy_si_scls ) - - call this%set_history_var(vname='LIVECROOT_MR_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='LIVECROOT_MR for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livecroot_mr_canopy_si_scls ) - - call this%set_history_var(vname='FROOT_MR_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='FROOT_MR for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_froot_mr_canopy_si_scls ) - - call this%set_history_var(vname='RESP_G_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='RESP_G for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_g_canopy_si_scls ) - - call this%set_history_var(vname='RESP_M_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='RESP_M for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - 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='BSTORE_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='BSTORE_MD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bstore_md_understory_si_scls ) - - call this%set_history_var(vname='BDEAD_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='BDEAD_MD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bdead_md_understory_si_scls ) - - call this%set_history_var(vname='BSW_MD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='BSW_MD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_bsw_md_understory_si_scls ) - - call this%set_history_var(vname='SEED_PROD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='SEED_PROD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_seed_prod_understory_si_scls ) - - call this%set_history_var(vname='NPP_LEAF_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='NPP_LEAF for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_understory_si_scls ) - - call this%set_history_var(vname='NPP_FROOT_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='NPP_FROOT for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_fnrt_understory_si_scls ) - - call this%set_history_var(vname='NPP_BSW_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='NPP_BSW for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_sapw_understory_si_scls ) - - call this%set_history_var(vname='NPP_BDEAD_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='NPP_BDEAD for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_dead_understory_si_scls ) - - call this%set_history_var(vname='NPP_BSEED_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='NPP_BSEED for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_seed_understory_si_scls ) - - call this%set_history_var(vname='NPP_STORE_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='NPP_STORE for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stor_understory_si_scls ) - - call this%set_history_var(vname='RDARK_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='RDARK for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_rdark_understory_si_scls ) - - call this%set_history_var(vname='LIVESTEM_MR_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='LIVESTEM_MR for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livestem_mr_understory_si_scls ) - - call this%set_history_var(vname='LIVECROOT_MR_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='LIVECROOT_MR for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_livecroot_mr_understory_si_scls ) - - call this%set_history_var(vname='FROOT_MR_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='FROOT_MR for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_froot_mr_understory_si_scls ) - - call this%set_history_var(vname='RESP_G_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='RESP_G for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_g_understory_si_scls ) - - call this%set_history_var(vname='RESP_M_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='RESP_M for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_resp_m_understory_si_scls ) + call this%set_history_var(vname='FATES_DDBH_CANOPY_SZ', & + units = 'm m-2 yr-1', long='diameter growth increment by size of canopy plants', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_ddbh_canopy_si_scls) + + call this%set_history_var(vname='FATES_DDBH_USTORY_SZ', & + units = 'm m-2 yr-1', long='diameter growth increment by size of understory plants', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_ddbh_understory_si_scls) + + call this%set_history_var(vname='FATES_YESTCANLEV_CANOPY_SZ', & + units = 'm-2', & + long='yesterdays canopy level for canopy plants by size class in number of plants per m2', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_yesterdaycanopylevel_canopy_si_scls) + + call this%set_history_var(vname='FATES_YESTCANLEV_USTORY_SZ', & + units = 'm-2', & + long='yesterdays canopy level for understory plants by size class in number of plants per m2', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_yesterdaycanopylevel_understory_si_scls) + + call this%set_history_var(vname='FATES_BASALAREA_SZ', units = 'm2 m-2', & + long='basal area by size class', use_default='active', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_ba_si_scls) + + call this%set_history_var(vname='FATES_VEGC_ABOVEGROUND_SZ', & + units = 'kg m-2', & + long='aboveground biomass by size class in kg carbon per m2', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_agb_si_scls) + + call this%set_history_var(vname='FATES_VEGC_SZ', units = 'kg m-2', & + long='total biomass by size class in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_biomass_si_scls) + + call this%set_history_var(vname='FATES_DEMOTION_RATE_SZ', & + units = 'm-2 yr-1', & + long='demotion rate from canopy to understory by size class in number of plants per m2 per year', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_demotion_rate_si_scls) + + call this%set_history_var(vname='FATES_PROMOTION_RATE_SZ', & + units = 'm-2 yr-1', & + long='promotion rate from understory to canopy by size class', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_promotion_rate_si_scls) + + call this%set_history_var(vname='FATES_NPLANT_CANOPY_SZ', & + units = 'm-2', & + long='number of canopy plants per m2 by size class', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nplant_canopy_si_scls) + + call this%set_history_var(vname='FATES_LAI_CANOPY_SZ', units = 'm2 m-2', & + long='leaf area index (LAI) of canopy plants by size class', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_lai_canopy_si_scls) + + call this%set_history_var(vname='FATES_SAI_CANOPY_SZ', units = 'm2 m-2', & + long='stem area index (SAI) of canopy plants by size class', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_sai_canopy_si_scls) + + call this%set_history_var(vname='FATES_MORTALITY_CANOPY_SZ', & + units = 'm-2 yr-1', & + long='total mortality of canopy trees by size class in number of plants per m2', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_mortality_canopy_si_scls) + + call this%set_history_var(vname='FATES_NPLANT_USTORY_SZ', & + units = 'm-2', & + long='number of understory plants per m2 by size class', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nplant_understory_si_scls) + + call this%set_history_var(vname='FATES_LAI_USTORY_SZ', & + units = 'm2 m-2', & + long='leaf area index (LAI) of understory plants by size class', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_lai_understory_si_scls) + + call this%set_history_var(vname='FATES_SAI_USTORY_SZ', & + units = 'm2 m-2', & + long='stem area index (SAI) of understory plants by size class', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_sai_understory_si_scls) + + call this%set_history_var(vname='FATES_NPLANT_SZ', units = 'm-2', & + long='number of plants per m2 by size class', use_default='active', & + avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_nplant_si_scls) + + call this%set_history_var(vname='FATES_NPLANT_AC', units = 'm-2', & + long='number of plants per m2 by cohort age class', & + use_default='active', avgflag='A', vtype=site_coage_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nplant_si_cacls) + + call this%set_history_var(vname='FATES_MORTALITY_BACKGROUND_SZ', & + units = 'm-2 yr-1', & + long='background mortality by size in number of plants per m2 per year', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m1_si_scls) + + call this%set_history_var(vname='FATES_MORTALITY_HYDRAULIC_SZ', & + units = 'm-2 yr-1', & + long='hydraulic mortality by size in number of plants per m2 per year', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m2_si_scls) + + call this%set_history_var(vname='FATES_MORTALITY_CSTARV_SZ', & + units = 'm-2 yr-1', & + long='carbon starvation mortality by size in number of plants per m2 per year', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m3_si_scls) + + call this%set_history_var(vname='FATES_MORTALITY_IMPACT_SZ', & + units = 'm-2 yr-1', & + long='impact mortality by size in number of plants per m2 per year', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m4_si_scls) + + call this%set_history_var(vname='FATES_MORTALITY_FIRE_SZ', & + units = 'm-2 yr-1', & + long='fire mortality by size in number of plants per m2 per year', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m5_si_scls) + + call this%set_history_var(vname='FATES_MORTALITY_TERMINATION_SZ', & + units = 'm-2 yr-1', & + long='termination mortality by size in number of plants per m2 per year', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m6_si_scls) + + call this%set_history_var(vname='FATES_MORTALITY_LOGGING_SZ', & + units = 'm-2 yr-1', & + long='logging mortality by size in number of plants per m2 per event', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m7_si_scls) + + call this%set_history_var(vname='FATES_MORTALITY_FREEZING_SZ', & + units = 'm-2 event-1', & + long='freezing mortality by size in number of plants per m2 per event', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m8_si_scls) + + call this%set_history_var(vname='FATES_MORTALITY_SENESCENCE_SZ', & + units = 'm-2 yr-1', & + long='senescence mortality by size in number of plants per m2 per event', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m9_si_scls) + + call this%set_history_var(vname='FATES_MORTALITY_AGESCEN_SZ', & + units = 'm-2 yr-1', & + long='age senescence mortality by size in number of plants per m2 per year', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m10_si_scls) + + call this%set_history_var(vname='FATES_MORTALITY_AGESCEN_AC', & + units = 'm-2 yr-1', & + long='age senescence mortality by cohort age in number of plants per m2 per year', & + use_default='active', avgflag='A', vtype=site_coage_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_m10_si_cacls) + + call this%set_history_var(vname='FATES_NPP_CANOPY_SZ', units = 'kg m-2 s-1', & + long='NPP of canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_carbon_balance_canopy_si_scls) + + call this%set_history_var(vname='FATES_NPP_USTORY_SZ', units = 'kg m-2 s-1', & + long='NPP of understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_carbon_balance_understory_si_scls) + + call this%set_history_var(vname='FATES_MORTALITY_USTORY_SZ', & + units = 'm-2 yr-1', & + long='total mortality of understory trees by size class in individuals per m2 per year', & + use_default='active', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_mortality_understory_si_scls) + + call this%set_history_var(vname='FATES_TRIMMING_CANOPY_SZ', units = 'm-2', & + long='trimming term of canopy plants weighted by plant density, by size class', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_trimming_canopy_si_scls) + + call this%set_history_var(vname='FATES_TRIMMING_USTORY_SZ', & + units = 'm-2', & + long='trimming term of understory plants weighted by plant density, by size class', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_trimming_understory_si_scls) + + call this%set_history_var(vname='FATES_CROWNAREA_CANOPY_SZ', units = 'm2 m-2', & + long='total crown area of canopy plants by size class', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_crown_area_canopy_si_scls) + + call this%set_history_var(vname='FATES_CROWNAREA_USTORY_SZ', units = 'm2 m-2', & + long='total crown area of understory plants by size class', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_crown_area_understory_si_scls) + + call this%set_history_var(vname='FATES_LEAFCTURN_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='leaf turnover (non-mortal) for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_leaf_md_canopy_si_scls) + + call this%set_history_var(vname='FATES_FROOTCTURN_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='fine root turnover (non-mortal) for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_root_md_canopy_si_scls) + + call this%set_history_var(vname='FATES_STORECTURN_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='storage turnover (non-mortal) for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_bstore_md_canopy_si_scls) + + call this%set_history_var(vname='FATES_STRUCTCTURN_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='structural C turnover (non-mortal) for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_bdead_md_canopy_si_scls) + + call this%set_history_var(vname='FATES_SAPWOODCTURN_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='sapwood turnover (non-mortal) for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_bsw_md_canopy_si_scls) + + call this%set_history_var(vname='FATES_SEED_PROD_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='seed production of canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_seed_prod_canopy_si_scls) + + call this%set_history_var(vname='FATES_LEAF_ALLOC_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='allocation to leaves for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_leaf_canopy_si_scls) + + call this%set_history_var(vname='FATES_FROOT_ALLOC_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='allocation to fine root C for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_fnrt_canopy_si_scls) + + call this%set_history_var(vname='FATES_SAPWOOD_ALLOC_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='allocation to sapwood C for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_sapw_canopy_si_scls) + + call this%set_history_var(vname='FATES_STRUCT_ALLOC_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='allocation to structural C for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_dead_canopy_si_scls) + + call this%set_history_var(vname='FATES_SEED_ALLOC_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='allocation to reproductive C for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_seed_canopy_si_scls) + + call this%set_history_var(vname='FATES_STORE_ALLOC_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='allocation to storage C for canopy plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_stor_canopy_si_scls) + + call this%set_history_var(vname='FATES_LEAFMAINTAR', & + units = 'kg m-2 s-1', & + long='leaf maintenance autotrophic respiration in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_leaf_mr_si) + + call this%set_history_var(vname='FATES_FROOTMAINTAR', & + units = 'kg m-2 s-1', & + long='fine root maintenance autotrophic respiration in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_froot_mr_si) + + call this%set_history_var(vname='FATES_CROOTMAINTAR', & + units = 'kg m-2 s-1', & + long='live coarse root maintenance autotrophic respiration in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_livecroot_mr_si) + + call this%set_history_var(vname='FATES_LSTEMMAINTAR', & + units = 'kg m-2 s-1', & + long='live stem maintenance autotrophic respiration in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_livestem_mr_si) + + call this%set_history_var(vname='FATES_RDARK_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='dark respiration for canopy plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_rdark_canopy_si_scls) + + call this%set_history_var(vname='FATES_LSTEMMAINTAR_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='live stem maintenance autotrophic respiration for canopy plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, & + index = ih_livestem_mr_canopy_si_scls) + + call this%set_history_var(vname='FATES_CROOTMAINTAR_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='live coarse root maintenance autotrophic respiration for canopy plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, & + index = ih_livecroot_mr_canopy_si_scls) + + call this%set_history_var(vname='FATES_FROOTMAINTAR_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='live coarse root maintenance autotrophic respiration for canopy plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_froot_mr_canopy_si_scls) + + call this%set_history_var(vname='FATES_GROWAR_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='growth autotrophic respiration of canopy plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_resp_g_canopy_si_scls) + + call this%set_history_var(vname='FATES_MAINTAR_CANOPY_SZ', & + units = 'kg m-2 s-1', & + long='maintenance autotrophic respiration of canopy plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_resp_m_canopy_si_scls) + + call this%set_history_var(vname='FATES_LEAFCTURN_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='leaf turnover (non-mortal) for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_leaf_md_understory_si_scls) + + call this%set_history_var(vname='FATES_FROOTCTURN_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='fine root turnover (non-mortal) for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_root_md_understory_si_scls) + + call this%set_history_var(vname='FATES_STORECTURN_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='storage C turnover (non-mortal) for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_bstore_md_understory_si_scls) + + call this%set_history_var(vname='FATES_STRUCTCTURN_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='structural C turnover (non-mortal) for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_bdead_md_understory_si_scls) + + call this%set_history_var(vname='FATES_SAPWOODCTURN_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='sapwood C turnover (non-mortal) for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_bsw_md_understory_si_scls) + + call this%set_history_var(vname='FATES_SEED_PROD_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='seed production of understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_seed_prod_understory_si_scls) + + call this%set_history_var(vname='FATES_LEAF_ALLOC_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='allocation to leaves for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_leaf_understory_si_scls) + + call this%set_history_var(vname='FATES_FROOT_ALLOC_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='allocation to fine roots for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_fnrt_understory_si_scls) + + call this%set_history_var(vname='FATES_SAPWOOD_ALLOC_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='allocation to sapwood C for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_sapw_understory_si_scls) + + call this%set_history_var(vname='FATES_STRUCT_ALLOC_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='allocation to structural C for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_dead_understory_si_scls) + + call this%set_history_var(vname='FATES_SEED_ALLOC_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='allocation to reproductive C for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_seed_understory_si_scls) + + call this%set_history_var(vname='FATES_STORE_ALLOC_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='allocation to storage C for understory plants by size class in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_stor_understory_si_scls) + + call this%set_history_var(vname='FATES_RDARK_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='dark respiration for understory plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_rdark_understory_si_scls) + + call this%set_history_var(vname='FATES_LSTEMMAINTAR_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='live stem maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, & + index = ih_livestem_mr_understory_si_scls) + + call this%set_history_var(vname='FATES_CROOTMAINTAR_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='live coarse root maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, & + index = ih_livecroot_mr_understory_si_scls) + + call this%set_history_var(vname='FATES_FROOTMAINTAR_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='fine root maintenance autotrophic respiration for understory plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, & + index = ih_froot_mr_understory_si_scls) + + call this%set_history_var(vname='FATES_GROWAR_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='growth autotrophic respiration of understory plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', upfreq=2, ivar=ivar, & + initialize=initialize_variables, index = ih_resp_g_understory_si_scls) + + call this%set_history_var(vname='FATES_MAINTAR_USTORY_SZ', & + units = 'kg m-2 s-1', & + long='maintenance autotrophic respiration of understory plants in kg carbon per m2 per second by size', & + use_default='inactive', avgflag='A', vtype=site_size_r8, & + hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_resp_m_understory_si_scls) ! 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=2, 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=1, ivar=ivar, initialize=initialize_variables, index = ih_fire_c_to_atm_si ) - - call this%set_history_var(vname='FIRE_FLUX', units='g/m^2/s', & - long='ED-spitfire loss to atmosphere of elements', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_burn_flux_elem ) - - call this%set_history_var(vname='CBALANCE_ERROR_FATES', units='mgC/day', & - long='total carbon error, FATES', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cbal_err_fates_si ) - - call this%set_history_var(vname='ERROR_FATES', units='mg/day', & - long='total error, FATES mass-balance', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_err_fates_si ) - - call this%set_history_var(vname='LITTER_FINES_AG_ELEM', units='kg ha-1', & - long='mass of above ground litter in fines (leaves,nonviable seed)', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fines_ag_elem ) - - call this%set_history_var(vname='LITTER_FINES_BG_ELEM', units='kg ha-1', & - long='mass of below ground litter in fines (fineroots)', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fines_bg_elem ) - - call this%set_history_var(vname='LITTER_CWD_BG_ELEM', units='kg ha-1', & - long='mass of below ground litter in CWD (coarse roots)', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_elem ) - - call this%set_history_var(vname='LITTER_CWD_AG_ELEM', units='kg ha-1', & - long='mass of above ground litter in CWD (trunks/branches/twigs)', use_default='active', & - avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_elem ) - - call this%set_history_var(vname='LITTER_CWD', units='kg ha-1', & - long='total mass of litter in CWD', use_default='active', & - avgflag='A', vtype=site_elcwd_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_elcwd ) + call this%set_history_var(vname='FATES_NEP', units='kg m-2 s-1', & + long='net ecosystem production in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, & + index = ih_nep_si) + + call this%set_history_var(vname='FATES_HET_RESP', units='kg m-2 s-1', & + long='heterotrophic respiration in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_hr_si) + + call this%set_history_var(vname='FATES_FIRE_CLOSS', units='kg m-2 s-1', & + long='carbon loss to atmosphere from fire in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fire_c_to_atm_si) + + call this%set_history_var(vname='FATES_FIRE_FLUX_EL', units='kg m-2 s-1', & + long='loss to atmosphere from fire by element in kg element per m2 per s', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_burn_flux_elem) + + call this%set_history_var(vname='FATES_CBALANCE_ERROR', & + units='kg s-1', & + long='total carbon error in kg carbon per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_cbal_err_fates_si) + + call this%set_history_var(vname='FATES_ERROR_EL', units='kg s-1', & + long='total mass-balance error in kg per second by element', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_err_fates_si) + + call this%set_history_var(vname='FATES_LITTER_AG_FINE_EL', units='kg m-2', & + long='mass of aboveground litter in fines (leaves, nonviable seed) by element', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_fines_ag_elem) + + call this%set_history_var(vname='FATES_LITTER_BG_FINE_EL', units='kg m-2', & + long='mass of belowground litter in fines (fineroots) by element', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_fines_bg_elem) + + call this%set_history_var(vname='FATES_LITTER_BG_CWD_EL', units='kg m-2', & + long='mass of belowground litter in coarse woody debris (coarse roots) by element', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cwd_bg_elem) + + call this%set_history_var(vname='FATES_LITTER_AG_CWD_EL', units='kg m-2', & + long='mass of aboveground litter in coarse woody debris (trunks/branches/twigs) by element', & + use_default='active', avgflag='A', vtype=site_elem_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cwd_ag_elem) + + call this%set_history_var(vname='FATES_LITTER_CWD_ELDC', units='kg m-2', & + long='total mass of litter in coarse woody debris by element and coarse woody debris size', & + use_default='active', avgflag='A', vtype=site_elcwd_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_cwd_elcwd) ! Mass states C/N/P SCPF dimensions ! CARBON - call this%set_history_var(vname='TOTVEGC_SCPF', units='kgC/ha', & - long='total vegetation carbon mass in live plants by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_totvegc_scpf ) - - call this%set_history_var(vname='LEAFC_SCPF', units='kgC/ha', & - long='leaf carbon mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leafc_scpf ) - - call this%set_history_var(vname='FNRTC_SCPF', units='kgC/ha', & - long='fine-root carbon mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fnrtc_scpf ) - - call this%set_history_var(vname='SAPWC_SCPF', units='kgC/ha', & - long='sapwood carbon mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sapwc_scpf ) - - call this%set_history_var(vname='STOREC_SCPF', units='kgC/ha', & - long='storage carbon mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storec_scpf ) - - call this%set_history_var(vname='REPROC_SCPF', units='kgC/ha', & - long='reproductive carbon mass (on plant) by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_reproc_scpf ) - - call this%set_history_var(vname='CEFFLUX_SCPF', units='kg/ha/day', & - long='carbon efflux, root to soil, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cefflux_scpf ) + call this%set_history_var(vname='FATES_VEGC_SZPF', units='kg m-2', & + long='total vegetation biomass in live plants by size-class x pft in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_totvegc_scpf) + + call this%set_history_var(vname='FATES_LEAFC_SZPF', units='kg m-2', & + long='leaf carbon mass by size-class x pft in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_leafc_scpf) + + call this%set_history_var(vname='FATES_FROOTC_SZPF', units='kg m-2', & + long='fine-root carbon mass by size-class x pft in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_fnrtc_scpf) + + call this%set_history_var(vname='FATES_SAPWOODC_SZPF', units='kg m-2', & + long='sapwood carbon mass by size-class x pft in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_sapwc_scpf) + + call this%set_history_var(vname='FATES_STOREC_SZPF', units='kg m-2', & + long='storage carbon mass by size-class x pft in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_storec_scpf) + + call this%set_history_var(vname='FATES_REPROC_SZPF', units='kg m-2', & + long='reproductive carbon mass (on plant) by size-class x pft in kg carbon per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_reproc_scpf) + + call this%set_history_var(vname='FATES_CEFFLUX_SZPF', units='kg m-2 s-1', & + long='carbon efflux, root to soil, by size-class x pft in kg carbon per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_cefflux_scpf) ! NITROGEN + nitrogen_active_if2: if(any(element_list(:)==nitrogen_element)) then - call this%set_history_var(vname='TOTVEGN_SCPF', units='kgN/ha', & - long='total (live) vegetation nitrogen mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_totvegn_scpf ) - - call this%set_history_var(vname='LEAFN_SCPF', units='kgN/ha', & - long='leaf nitrogen mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leafn_scpf ) - - call this%set_history_var(vname='FNRTN_SCPF', units='kgN/ha', & - long='fine-root nitrogen mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fnrtn_scpf ) - - call this%set_history_var(vname='SAPWN_SCPF', units='kgN/ha', & - long='sapwood nitrogen mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sapwn_scpf ) - - call this%set_history_var(vname='STOREN_SCPF', units='kgN/ha', & - long='storage nitrogen mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storen_scpf ) - - call this%set_history_var(vname='REPRON_SCPF', units='kgN/ha', & - long='reproductive nitrogen mass (on plant) by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_repron_scpf ) - - call this%set_history_var(vname='NUPTAKE_SCPF', units='kgN d-1 ha-1', & - long='nitrogen uptake, soil to root, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nuptake_scpf ) - - call this%set_history_var(vname='NEFFLUX_SCPF', units='kgN d-1 ha-1', & - long='nitrogen efflux, root to soil, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nefflux_scpf ) - - call this%set_history_var(vname='NNEEDGROW_SCPF', units='kgN d-1 ha-1', & - long='nitrogen needed to match growth, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nneedgrow_scpf ) - - call this%set_history_var(vname='NNEEDMAX_SCPF', units='kgN d-1 ha-1', & - long='nitrogen needed to reach max concentrations, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nneedmax_scpf ) - - + + call this%set_history_var(vname='FATES_VEGN_SZPF', units='kg m-2', & + long='total (live) vegetation nitrogen mass by size-class x pft in kg N per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_totvegn_scpf) + + call this%set_history_var(vname='FATES_LEAFN_SZPF', units='kg m-2', & + long='leaf nitrogen mass by size-class x pft in kg N per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_leafn_scpf) + + call this%set_history_var(vname='FATES_FROOTN_SZPF', units='kg m-2', & + long='fine-root nitrogen mass by size-class x pft in kg N per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_fnrtn_scpf) + + call this%set_history_var(vname='FATES_SAPWOODN_SZPF', units='kg m-2', & + long='sapwood nitrogen mass by size-class x pft in kg N per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_sapwn_scpf) + + call this%set_history_var(vname='FATES_STOREN_SZPF', units='kg m-2', & + long='storage nitrogen mass by size-class x pft in kg N per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_storen_scpf) + + call this%set_history_var(vname='FATES_STOREN_TF_CANOPY_SZPF', & + units='1', & + long='storage nitrogen fraction (0-1) of target, in canopy, by size-class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_storentfrac_canopy_scpf) + + call this%set_history_var(vname='FATES_STOREN_TF_USTORY_SZPF', & + units='1', & + long='storage nitrogen fraction (0-1) of target, in understory, by size-class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_storentfrac_understory_scpf) + + call this%set_history_var(vname='FATES_REPRON_SZPF', units='kg m-2', & + long='reproductive nitrogen mass (on plant) by size-class x pft in kg N per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_repron_scpf) + + call this%set_history_var(vname='FATES_NH4UPTAKE_SZPF', & + units='kg m-2 s-1', & + long='ammonium uptake rate by plants by size-class x pft in kg NH4 per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nh4uptake_scpf) + + call this%set_history_var(vname='FATES_NO3UPTAKE_SZPF', & + units='kg m-2 s-1', & + long='nitrate uptake rate by plants by size-class x pft in kg NO3 per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_no3uptake_scpf) + + call this%set_history_var(vname='FATES_NEFFLUX_SZPF', units='kg m-2 s-1', & + long='nitrogen efflux, root to soil, by size-class x pft in kg N per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nefflux_scpf) + + call this%set_history_var(vname='FATES_NNEED_SZPF', units='kg m-2 s-1', & + long='plant N need (algorithm dependent), by size-class x pft in kg N per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_nneed_scpf) + end if nitrogen_active_if2 ! PHOSPHORUS + phosphorus_active_if2: if(any(element_list(:)==phosphorus_element))then - call this%set_history_var(vname='TOTVEGP_SCPF', units='kgP/ha', & - long='total (live) vegetation phosphorus mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_totvegp_scpf ) - call this%set_history_var(vname='LEAFP_SCPF', units='kgP/ha', & + call this%set_history_var(vname='FATES_VEGP_SZPF', units='kg m-2', & + long='total (live) vegetation phosphorus mass by size-class x pft in kg P per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_totvegp_scpf) + + call this%set_history_var(vname='FATES_LEAFP_SZPF', units='kg m-2', & long='leaf phosphorus mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leafp_scpf ) - call this%set_history_var(vname='FNRTP_SCPF', units='kgP/ha', & - long='fine-root phosphorus mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fnrtp_scpf ) - - call this%set_history_var(vname='SAPWP_SCPF', units='kgP/ha', & - long='sapwood phosphorus mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sapwp_scpf ) - - call this%set_history_var(vname='STOREP_SCPF', units='kgP/ha', & - long='storage phosphorus mass by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storep_scpf ) - - call this%set_history_var(vname='REPROP_SCPF', units='kgP/ha', & - long='reproductive phosphorus mass (on plant) by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_reprop_scpf ) - - call this%set_history_var(vname='PUPTAKE_SCPF', units='kg/ha/day', & - long='phosphorus uptake, soil to root, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_puptake_scpf ) - - call this%set_history_var(vname='PEFFLUX_SCPF', units='kg/ha/day', & - long='phosphorus efflux, root to soil, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_pefflux_scpf ) - - call this%set_history_var(vname='PNEEDGROW_SCPF', units='kg/ha/day', & - long='phosphorus needed to match growth, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_pneedgrow_scpf ) - - call this%set_history_var(vname='PNEEDMAX_SCPF', units='kg/ha/day', & - long='phosphorus needed to reach max concentrations, by size-class x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_pneedmax_scpf ) - + call this%set_history_var(vname='FATES_FROOTP_SZPF', units='kg m-2', & + long='fine-root phosphorus mass by size-class x pft in kg P per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_fnrtp_scpf) + + call this%set_history_var(vname='FATES_SAPWOODP_SZPF', units='kg m-2', & + long='sapwood phosphorus mass by size-class x pft in kg P per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_sapwp_scpf) + + call this%set_history_var(vname='FATES_STOREP_SZPF', units='kg m-2', & + long='storage phosphorus mass by size-class x pft in kg P per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_storep_scpf) + + call this%set_history_var(vname='FATES_STOREP_TF_CANOPY_SZPF', & + units='1', & + long='storage phosphorus fraction (0-1) of target, in canopy, by size-class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_storeptfrac_canopy_scpf) + + call this%set_history_var(vname='FATES_STOREP_TF_USTORY_SZPF', & + units='1', & + long='storage phosphorus fraction (0-1) of target, in understory, by size-class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, & + index = ih_storeptfrac_understory_scpf) + + call this%set_history_var(vname='FATES_REPROP_SZPF', units='kg m-2', & + long='reproductive phosphorus mass (on plant) by size-class x pft in kg P per m2', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_reprop_scpf) + + call this%set_history_var(vname='FATES_PUPTAKE_SZPF', & + units='kg m-2 s-1', & + long='phosphorus uptake rate by plants, by size-class x pft in kg P per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_puptake_scpf) + + call this%set_history_var(vname='FATES_PEFFLUX_SZPF', & + units='kg m-2 s-1', & + long='phosphorus efflux, root to soil, by size-class x pft in kg P per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_pefflux_scpf) + + call this%set_history_var(vname='FATES_PNEED_SZPF', units='kg m-2 s-1', & + long='plant P need (algorithm dependent), by size-class x pft in kg P per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_pneed_scpf) + end if phosphorus_active_if2 ! organ-partitioned NPP / allocation fluxes - call this%set_history_var(vname='NPP_LEAF', units='kgC/m2/yr', & - long='NPP flux into leaves', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_leaf_si ) - call this%set_history_var(vname='NPP_SEED', units='kgC/m2/yr', & - long='NPP flux into seeds', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_seed_si ) - - call this%set_history_var(vname='NPP_STEM', units='kgC/m2/yr', & - long='NPP flux into stem', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stem_si ) - - call this%set_history_var(vname='NPP_FROOT', units='kgC/m2/yr', & - long='NPP flux into fine roots', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_froot_si ) - - call this%set_history_var(vname='NPP_CROOT', units='kgC/m2/yr', & - long='NPP flux into coarse roots', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_croot_si ) - - call this%set_history_var(vname='NPP_STOR', units='kgC/m2/yr', & - long='NPP flux into storage tissues', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_npp_stor_si ) + call this%set_history_var(vname='FATES_LEAF_ALLOC', units='kg m-2 s-1', & + long='allocation to leaves in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_leaf_si) + + call this%set_history_var(vname='FATES_SEED_ALLOC', units='kg m-2 s-1', & + long='allocation to seeds in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_seed_si) + + call this%set_history_var(vname='FATES_STEM_ALLOC', units='kg m-2 s-1', & + long='allocation to stem in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_stem_si) + + call this%set_history_var(vname='FATES_FROOT_ALLOC', units='kg m-2 s-1', & + long='allocation to fine roots in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_froot_si) + + call this%set_history_var(vname='FATES_CROOT_ALLOC', units='kg m-2 s-1', & + long='allocation to coarse roots in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_croot_si) + + call this%set_history_var(vname='FATES_STORE_ALLOC', units='kg m-2 s-1', & + long='allocation to storage tissues in kg carbon per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=1, ivar=ivar, initialize=initialize_variables, & + index = ih_npp_stor_si) ! PLANT HYDRAULICS hydro_active_if: if(hlm_use_planthydro.eq.itrue) then - - call this%set_history_var(vname='FATES_ERRH2O_SCPF', units='kg/indiv/s', & - long='mean individual water balance error', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_errh2o_scpf ) - - call this%set_history_var(vname='FATES_TRAN_SCPF', units='kg/indiv/s', & - long='mean individual transpiration rate', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_tran_scpf ) - - call this%set_history_var(vname='FATES_SAPFLOW_SCPF', units='kg/ha/s', & - long='areal sap flow rate dimensioned by size x pft', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sapflow_scpf ) - - call this%set_history_var(vname='FATES_SAPFLOW_SI', units='kg/ha/s', & - long='areal sap flow rate', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sapflow_si ) - - - call this%set_history_var(vname='FATES_ITERH1_SCPF', units='count/indiv/step', & + + call this%set_history_var(vname='FATES_ERRH2O_SZPF', units='kg s-1', & + long='mean individual water balance error in kg per individual per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_errh2o_scpf) + + call this%set_history_var(vname='FATES_TRAN_SZPF', units='kg s-1', & + long='mean individual transpiration rate in kg per individual per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_tran_scpf) + + call this%set_history_var(vname='FATES_SAPFLOW_SZPF', units='kg m-2 s-1', & + long='areal sap flow rate dimensioned by size x pft in kg per m2 per second', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_sapflow_scpf) + + call this%set_history_var(vname='FATES_SAPFLOW', units='kg m-2 s-1', & + long='areal sap flow rate in kg per m2 per second', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=4, ivar=ivar, initialize=initialize_variables, & + index = ih_sapflow_si) + + call this%set_history_var(vname='FATES_ITERH1_SZPF', units='count indiv-1 step-1', & long='water balance error iteration diagnostic 1', & use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_iterh1_scpf ) - - call this%set_history_var(vname='FATES_ITERH2_SCPF', units='count/indiv/step', & + + call this%set_history_var(vname='FATES_ITERH2_SZPF', units='count indiv-1 step-1', & long='water balance error iteration diagnostic 2', & use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_iterh2_scpf ) - - call this%set_history_var(vname='FATES_ATH_SCPF', units='m3 m-3', & - long='absorbing root water content', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_ath_scpf ) - - call this%set_history_var(vname='FATES_TTH_SCPF', units='m3 m-3', & - long='transporting root water content', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_tth_scpf ) - - call this%set_history_var(vname='FATES_STH_SCPF', units='m3 m-3', & - long='stem water contenet', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sth_scpf ) - - call this%set_history_var(vname='FATES_LTH_SCPF', units='m3 m-3', & - long='leaf water content', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_lth_scpf ) - - call this%set_history_var(vname='FATES_AWP_SCPF', units='MPa', & - long='absorbing root water potential', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_awp_scpf ) - - call this%set_history_var(vname='FATES_TWP_SCPF', units='MPa', & - long='transporting root water potential', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_twp_scpf ) - - call this%set_history_var(vname='FATES_SWP_SCPF', units='MPa', & - long='stem water potential', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_swp_scpf ) - - call this%set_history_var(vname='FATES_LWP_SCPF', units='MPa', & - long='leaf water potential', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_lwp_scpf ) - - call this%set_history_var(vname='FATES_AFLC_SCPF', units='fraction', & - long='absorbing root fraction of condutivity', use_default='active', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_aflc_scpf ) - - call this%set_history_var(vname='FATES_TFLC_SCPF', units='fraction', & - long='transporting root fraction of condutivity', use_default='active', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_tflc_scpf ) - - call this%set_history_var(vname='FATES_SFLC_SCPF', units='fraction', & - long='stem water fraction of condutivity', use_default='active', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_sflc_scpf ) - - call this%set_history_var(vname='FATES_LFLC_SCPF', units='fraction', & - long='leaf fraction of condutivity', use_default='active', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_lflc_scpf ) - - call this%set_history_var(vname='FATES_BTRAN_SCPF', units='unitless', & - long='mean individual level btran', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_btran_scpf ) - - call this%set_history_var(vname='FATES_ROOTWGT_SOILVWC_SI', units='m3 m-3', & - long='soil volumetric water content, weighted by root area', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootwgt_soilvwc_si ) - - call this%set_history_var(vname='FATES_ROOTWGT_SOILVWCSAT_SI', units='m3 m-3', & - long='soil saturated volumetric water content, weighted by root area', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootwgt_soilvwcsat_si ) - - call this%set_history_var(vname='FATES_ROOTWGT_SOILMATPOT_SI', units='MPa', & - long='soil matric potential, weighted by root area', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootwgt_soilmatpot_si ) - - call this%set_history_var(vname='FATES_SOILMATPOT_SL', units='MPa', & - long='soil water matric potenial by soil layer', use_default='inactive', & - avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_soilmatpot_sl ) - - call this%set_history_var(vname='FATES_SOILVWC_SL', units='m3 m-3', & - long='soil volumetric water content by soil layer', use_default='inactive', & - avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_soilvwc_sl ) - - call this%set_history_var(vname='FATES_SOILVWCSAT_SL', units='m3 m-3', & - long='soil saturated volumetric water content by soil layer', use_default='inactive', & - avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_soilvwcsat_sl ) - - call this%set_history_var(vname='FATES_ROOTUPTAKE_SI', units='kg ha-1 s-1', & - long='root water uptake rate', use_default='active', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake_si ) - - call this%set_history_var(vname='FATES_ROOTUPTAKE_SL', units='kg ha-1 s-1', & - long='root water uptake rate by soil layer', use_default='inactive', & - avgflag='A', vtype=site_ground_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake_sl ) - - call this%set_history_var(vname='FATES_ROOTUPTAKE0_SCPF', units='kg ha-1 m-1 s-1', & - long='root water uptake from 0 to to 10 cm depth, by plant size x pft ', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake0_scpf ) - - call this%set_history_var(vname='FATES_ROOTUPTAKE10_SCPF', units='kg ha-1 m-1 s-1', & - long='root water uptake from 10 to to 50 cm depth, by plant size x pft ', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake10_scpf ) - - call this%set_history_var(vname='FATES_ROOTUPTAKE50_SCPF', units='kg ha-1 m-1 s-1', & - long='root water uptake from 50 to to 100 cm depth, by plant size x pft ', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake50_scpf ) - - call this%set_history_var(vname='FATES_ROOTUPTAKE100_SCPF', units='kg ha-1 m-1 s-1', & - long='root water uptake below 100 cm depth, by plant size x pft ', use_default='inactive', & - avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_rootuptake100_scpf ) - - call this%set_history_var(vname='H2OVEG', units = 'kg/m2', & - long='water stored inside vegetation tissues (leaf, stem, roots)', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_si ) - - call this%set_history_var(vname='H2OVEG_DEAD', units = 'kg/m2', & - long='cumulative plant_stored_h2o in dead biomass due to mortality', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_dead_si ) - - call this%set_history_var(vname='H2OVEG_RECRUIT', units = 'kg/m2', & - long='amount of water in new recruits', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_recruit_si ) - - call this%set_history_var(vname='H2OVEG_GROWTURN_ERR', units = 'kg/m2', & - long='cumulative net borrowed (+) or lost (-) from plant_stored_h2o due to combined growth & turnover', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_growturn_err_si ) - - call this%set_history_var(vname='H2OVEG_HYDRO_ERR', units = 'kg/m2', & - long='cumulative net borrowed (+) from plant_stored_h2o due to plant hydrodynamics', use_default='inactive', & - avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_hydro_err_si ) - end if hydro_active_if + + call this%set_history_var(vname='FATES_ABSROOT_H2O_SZPF', & + units='m3 m-3', & + long='absorbing volumetric root water content by size class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_ath_scpf) + + call this%set_history_var(vname='FATES_TRANSROOT_H2O_SZPF', & + units='m3 m-3', & + long='transporting volumetric root water content by size class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_tth_scpf) + + call this%set_history_var(vname='FATES_STEM_H2O_SZPF', units='m3 m-3', & + long='stem volumetric water content by size class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_sth_scpf) + + call this%set_history_var(vname='FATES_LEAF_H2O_SZPF', units='m3 m-3', & + long='leaf volumetric water content by size class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_lth_scpf) + + call this%set_history_var(vname='FATES_ABSROOT_H2OPOT_SZPF', units='Pa', & + long='absorbing root water potential by size class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_awp_scpf) + + call this%set_history_var(vname='FATES_TRANSROOT_H2OPOT_SZPF', & + units='Pa', long='transporting root water potential by size class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_twp_scpf) + + call this%set_history_var(vname='FATES_STEM_H2OPOT_SZPF', units='Pa', & + long='stem water potential by size class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_swp_scpf) + + call this%set_history_var(vname='FATES_LEAF_H2OPOT_SZPF', units='Pa', & + long='leaf water potential by size class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_lwp_scpf) + + call this%set_history_var(vname='FATES_ABSROOT_CONDFRAC_SZPF', units='1', & + long='absorbing root fraction (0-1) of condutivity by size class x pft', & + use_default='active', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_aflc_scpf) + + call this%set_history_var(vname='FATES_TRANSROOT_CONDFRAC_SZPF', units='1', & + long='transporting root fraction (0-1) of condutivity by size class x pft', & + use_default='active', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_tflc_scpf) + + call this%set_history_var(vname='FATES_STEM_CONDFRAC_SZPF', units='1', & + long='stem water fraction (0-1) of condutivity by size class x pft', & + use_default='active', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_sflc_scpf) + + call this%set_history_var(vname='FATES_LEAF_CONDFRAC_SZPF', units='1', & + long='leaf water fraction (0-1) of condutivity by size class x pft', & + use_default='active', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_lflc_scpf) + + call this%set_history_var(vname='FATES_BTRAN_SZPF', units='1', & + long='mean individual level BTRAN by size class x pft', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_btran_scpf) + + call this%set_history_var(vname='FATES_ROOTWGT_SOILVWC', units='m3 m-3', & + long='soil volumetric water content, weighted by root area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=4, ivar=ivar, initialize=initialize_variables, & + index = ih_rootwgt_soilvwc_si) + + call this%set_history_var(vname='FATES_ROOTWGT_SOILVWCSAT', & + units='m3 m-3', & + long='soil saturated volumetric water content, weighted by root area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=4, ivar=ivar, initialize=initialize_variables, & + index = ih_rootwgt_soilvwcsat_si) + + call this%set_history_var(vname='FATES_ROOTWGT_SOILMATPOT', units='Pa', & + long='soil matric potential, weighted by root area', & + use_default='active', avgflag='A', vtype=site_r8, hlms='CLM:ALM', & + upfreq=4, ivar=ivar, initialize=initialize_variables, & + index = ih_rootwgt_soilmatpot_si) + + call this%set_history_var(vname='FATES_SOILMATPOT_SL', units='Pa', & + long='soil water matric potenial by soil layer', & + use_default='inactive', avgflag='A', vtype=site_soil_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_soilmatpot_sl) + + call this%set_history_var(vname='FATES_SOILVWC_SL', units='m3 m-3', & + long='soil volumetric water content by soil layer', & + use_default='inactive', avgflag='A', vtype=site_soil_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_soilvwc_sl) + + call this%set_history_var(vname='FATES_SOILVWCSAT_SL', units='m3 m-3', & + long='soil saturated volumetric water content by soil layer', & + use_default='inactive', avgflag='A', vtype=site_soil_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_soilvwcsat_sl) + + call this%set_history_var(vname='FATES_ROOTUPTAKE', units='kg m-2 s-1', & + long='root water uptake rate', use_default='active', avgflag='A', & + vtype=site_r8, hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_rootuptake_si) + + call this%set_history_var(vname='FATES_ROOTUPTAKE_SL', & + units='kg m-2 s-1', & + long='root water uptake rate by soil layer', & + use_default='inactive', avgflag='A', vtype=site_soil_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_rootuptake_sl) + + call this%set_history_var(vname='FATES_ROOTUPTAKE0_SZPF', & + units='kg m-2 m-1 s-1', & + long='root water uptake from 0 to to 10 cm depth, by plant size x pft ', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_rootuptake0_scpf) + + call this%set_history_var(vname='FATES_ROOTUPTAKE10_SZPF', & + units='kg m-2 m-1 s-1', & + long='root water uptake from 10 to to 50 cm depth, by plant size x pft ', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_rootuptake10_scpf) + + call this%set_history_var(vname='FATES_ROOTUPTAKE50_SZPF', & + units='kg m-2 m-1 s-1', & + long='root water uptake from 50 to to 100 cm depth, by plant size x pft ', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_rootuptake50_scpf) + + call this%set_history_var(vname='FATES_ROOTUPTAKE100_SZPF', & + units='kg m-2 m-1 s-1', & + long='root water uptake below 100 cm depth, by plant size x pft ', & + use_default='inactive', avgflag='A', vtype=site_size_pft_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_rootuptake100_scpf) + + call this%set_history_var(vname='FATES_VEGH2O', units = 'kg m-2', & + long='water stored inside vegetation tissues (leaf, stem, roots)', & + use_default='inactive', avgflag='A', vtype=site_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_h2oveg_si) + + call this%set_history_var(vname='FATES_VEGH2O_DEAD', units = 'kg m-2', & + long='cumulative water stored in dead biomass due to mortality', & + use_default='inactive', avgflag='A', vtype=site_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_h2oveg_dead_si) + + call this%set_history_var(vname='FATES_VEGH2O_RECRUIT', & + units = 'kg m-2', long='amount of water in new recruits', & + use_default='inactive', avgflag='A', vtype=site_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_h2oveg_recruit_si) + + call this%set_history_var(vname='FATES_VEGH2O_GROWTURN_ERR', & + units = 'kg m-2', & + long='cumulative net borrowed (+) or lost (-) from water storage due to combined growth & turnover', & + use_default='inactive', avgflag='A', vtype=site_r8, & + hlms='CLM:ALM', upfreq=1, ivar=ivar, & + initialize=initialize_variables, index = ih_h2oveg_growturn_err_si) + + call this%set_history_var(vname='FATES_VEGH2O_HYDRO_ERR', & + units = 'kg m-2', & + long='cumulative net borrowed (+) from plant_stored_h2o due to plant hydrodynamics', & + use_default='inactive', avgflag='A', vtype=site_r8, & + hlms='CLM:ALM', upfreq=4, ivar=ivar, & + initialize=initialize_variables, index = ih_h2oveg_hydro_err_si) + end if hydro_active_if ! Must be last thing before return this%num_history_vars_ = ivar - + end subroutine define_history_vars diff --git a/main/FatesHistoryVariableType.F90 b/main/FatesHistoryVariableType.F90 index 6457e644f1..c56d1db984 100644 --- a/main/FatesHistoryVariableType.F90 +++ b/main/FatesHistoryVariableType.F90 @@ -4,11 +4,10 @@ module FatesHistoryVariableType use FatesGlobals, only : fates_log use FatesIODimensionsMod, only : fates_io_dimension_type use FatesIOVariableKindMod, only : fates_io_variable_kind_type - use FatesIOVariableKindMod, only : patch_r8, patch_ground_r8, patch_size_pft_r8 - use FatesIOVariableKindMod, only : site_r8, site_ground_r8, site_size_pft_r8 + use FatesIOVariableKindMod, only : site_r8, site_soil_r8, site_size_pft_r8 use FatesIOVariableKindMod, only : site_size_r8, site_pft_r8, site_age_r8 use FatesIOVariableKindMod, only : site_coage_r8, site_coage_pft_r8 - use FatesIOVariableKindMod, only : site_height_r8, patch_int + use FatesIOVariableKindMod, only : site_height_r8 use FatesIOVariableKindMod, only : site_fuel_r8, site_cwdsc_r8, site_scag_r8 use FatesIOVariableKindMod, only : site_scagpft_r8, site_agepft_r8 use FatesIOVariableKindMod, only : site_can_r8, site_cnlf_r8, site_cnlfpft_r8 @@ -105,23 +104,12 @@ subroutine Init(this, vname, units, long, use_default, & ! array spaces. select case(trim(vtype)) - case(patch_r8) - allocate(this%r81d(lb1:ub1)) - this%r81d(:) = flushval case(site_r8) allocate(this%r81d(lb1:ub1)) this%r81d(:) = flushval - case(patch_ground_r8) - allocate(this%r82d(lb1:ub1, lb2:ub2)) - this%r82d(:,:) = flushval - - case(patch_size_pft_r8) - allocate(this%r82d(lb1:ub1, lb2:ub2)) - this%r82d(:,:) = flushval - - case(site_ground_r8) + case(site_soil_r8) allocate(this%r82d(lb1:ub1, lb2:ub2)) this%r82d(:,:) = flushval @@ -282,15 +270,9 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) call this%GetBounds(thread, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) select case(trim(dim_kinds(this%dim_kinds_index)%name)) - case(patch_r8) - this%r81d(lb1:ub1) = this%flushval case(site_r8) this%r81d(lb1:ub1) = this%flushval - case(patch_ground_r8) - this%r82d(lb1:ub1, lb2:ub2) = this%flushval - case(patch_size_pft_r8) - this%r82d(lb1:ub1, lb2:ub2) = this%flushval - case(site_ground_r8) + case(site_soil_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_size_pft_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval @@ -322,8 +304,6 @@ subroutine Flush(this, thread, dim_bounds, dim_kinds) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_agepft_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval - case(patch_int) - this%int1d(lb1:ub1) = nint(this%flushval) case(site_elem_r8) this%r82d(lb1:ub1, lb2:ub2) = this%flushval case(site_elpft_r8) diff --git a/main/FatesHydraulicsMemMod.F90 b/main/FatesHydraulicsMemMod.F90 index 5de1165a16..65163e1c8c 100644 --- a/main/FatesHydraulicsMemMod.F90 +++ b/main/FatesHydraulicsMemMod.F90 @@ -10,8 +10,12 @@ module FatesHydraulicsMemMod implicit none private - logical, parameter, public :: use_2d_hydrosolve = .false. + + ! Define the various different solver options for hydraulics + integer, parameter, public :: hydr_solver_1DTaylor = 1 + integer, parameter, public :: hydr_solver_2DNewton = 2 + integer, parameter, public :: hydr_solver_2DPicard = 3 ! Number of soil layers for indexing cohort fine root quanitities ! NOTE: The hydraulics code does have some capacity to run a single soil @@ -31,6 +35,7 @@ module FatesHydraulicsMemMod integer, parameter, public :: n_hypool_aroot = 1 ! THIS IS "PER-SOIL-LAYER" integer, parameter, public :: nshell = 5 + ! number of aboveground plant water storage nodes integer, parameter, public :: n_hypool_ag = n_hypool_leaf+n_hypool_stem @@ -53,33 +58,18 @@ module FatesHydraulicsMemMod ! P-V curve: total RWC @ which capillary reserves exhausted (tfs) real(r8), parameter, public, dimension(n_plant_media) :: rwccap = (/1.0_r8,0.947_r8,0.947_r8,0.947_r8/) - - ! mirror of nlevcan, hard-set for simplicity, remove nlevcan_hyd on a rainy day - ! Note (RGK): uscing nclmax causes annoying circular dependency (this needs EDTypes, EDTypes needs this) - ! way around that: dynamic allocation, or just keep this, but set the value high - integer, parameter, public :: nlevcan_hyd = 2 - ! Mean fine root radius expected in the bulk soil real(r8), parameter, public :: fine_root_radius_const = 0.0001_r8 - ! Should we ignore the first soil layer and have root layers start on the second? - logical, parameter, public :: ignore_layer1=.true. - - - ! Derived parameters - ! ---------------------------------------------------------------------------------------------- - - !temporatory variables - real(r8), public :: cohort_recruit_water_layer(nlevsoi_hyd_max) ! the recruit water requirement for a - ! single individual at different layer (kg H2o/m2) - real(r8), public :: recruit_water_avail_layer(nlevsoi_hyd_max) ! the recruit water avaibility from soil (kg H2o/m2) + + type, public :: ed_site_hydr_type ! Plant Hydraulics - integer :: i_rhiz_t ! Soil layer index of top rhizosphere - integer :: i_rhiz_b ! Soil layer index of bottom rhizospher layer integer :: nlevrhiz ! Number of rhizosphere levels (vertical layers) + integer, allocatable :: map_s2r(:) ! soil to rhizoshpere level mapping + integer, allocatable :: map_r2s(:,:) ! rhizoshpere to soil level mapping, 1 -top soil layer, 2- bottom soil layer real(r8), allocatable :: zi_rhiz(:) ! Depth of the bottom edge of each rhizosphere level [m] real(r8), allocatable :: dz_rhiz(:) ! Width of each rhizosphere level [m] @@ -107,12 +97,6 @@ module FatesHydraulicsMemMod ! encountering super- or sub-saturation real(r8),allocatable :: h2osoi_liqvol_shell(:,:) ! volumetric water in rhizosphere compartment (m3/m3) - real(r8),allocatable :: h2osoi_liq_prev(:) ! liquid water mass for the bulk soil layer - ! defined at the end of the hydraulics sequence - ! after root water has been extracted. This should - ! be equal to the sum of the water over the rhizosphere shells - ! [kg/m2] - real(r8),allocatable :: recruit_w_uptake(:) ! recruitment water uptake (kg H2o/m2/s) @@ -143,9 +127,18 @@ module FatesHydraulicsMemMod real(r8),allocatable :: sapflow_scpf(:,:) ! flow at base of tree (+ upward) [kg/ha/s] ! discretized by size x pft - ! Root uptake per rhiz layer [kg/ha/s] + + ! Root uptake per SOIL layer [kg/m2/s] + ! !!!!!!!! IMPORTANT: THIS IS FOR DIAGNOSTICS, AND WE OUTPUT + ! AT THE SOIL LAYER, NOT RHIZ LAYER, SO THIS HAS A SOIL LAYER DIMENSION + real(r8),allocatable :: rootuptake_sl(:) + ! Absorbing root length on the soil grid. We need this to + ! disaggregate uptake fluxes from the rhizosphere layers to + ! the soil layers + real(r8),allocatable :: rootl_sl(:) + ! Root uptake per pft x size class, over set layer depths [kg/ha/m/s] ! These are normalized by depth (in case the desired horizon extends ! beyond the actual rhizosphere) @@ -185,10 +178,12 @@ module FatesHydraulicsMemMod real(r8), allocatable :: q_flux(:) real(r8), allocatable :: dftc_dpsi_node(:) real(r8), allocatable :: ftc_node(:) - - real(r8), allocatable :: kmax_up(:) real(r8), allocatable :: kmax_dn(:) + + ! Scratch arrays + real(r8) :: cohort_recruit_water_layer(nlevsoi_hyd_max) ! the recruit water requirement for a cohort + real(r8) :: recruit_water_avail_layer(nlevsoi_hyd_max) ! the recruit water avaibility from soil (kg H2o/m2) contains @@ -196,6 +191,8 @@ module FatesHydraulicsMemMod procedure :: InitHydrSite procedure :: SetConnections procedure :: FlushSiteScratch + procedure :: AggBCToRhiz + end type ed_site_hydr_type @@ -366,17 +363,22 @@ end subroutine DeallocateHydrCohortArrays ! =================================================================================== - subroutine InitHydrSite(this,numpft,numlevsclass) + subroutine InitHydrSite(this,numpft,numlevsclass,hydr_solver_type,nlevsoil) ! Arguments class(ed_site_hydr_type),intent(inout) :: this integer,intent(in) :: numpft integer,intent(in) :: numlevsclass + integer,intent(in) :: hydr_solver_type + integer,intent(in) :: nlevsoil associate(nlevrhiz => this%nlevrhiz) - allocate(this%zi_rhiz(1:nlevrhiz)); this%zi_rhiz(:) = nan + ! In all cases, the 0 index of the layer bottom is a value of 0 + allocate(this%zi_rhiz(1:nlevrhiz)); this%zi_rhiz(:) = nan allocate(this%dz_rhiz(1:nlevrhiz)); this%dz_rhiz(:) = nan + allocate(this%map_s2r(1:nlevrhiz)); this%map_s2r(:) = -999 + allocate(this%map_r2s(1:nlevrhiz,1:2)); this%map_r2s(:,:) = -999 allocate(this%v_shell(1:nlevrhiz,1:nshell)) ; this%v_shell = nan allocate(this%v_shell_init(1:nlevrhiz,1:nshell)) ; this%v_shell_init = nan allocate(this%r_node_shell(1:nlevrhiz,1:nshell)) ; this%r_node_shell = nan @@ -388,12 +390,13 @@ subroutine InitHydrSite(this,numpft,numlevsclass) allocate(this%kmax_lower_shell(1:nlevrhiz,1:nshell)); this%kmax_lower_shell = nan allocate(this%supsub_flag(1:nlevrhiz)) ; this%supsub_flag = -999 allocate(this%h2osoi_liqvol_shell(1:nlevrhiz,1:nshell)) ; this%h2osoi_liqvol_shell = nan - allocate(this%h2osoi_liq_prev(1:nlevrhiz)) ; this%h2osoi_liq_prev = nan allocate(this%rs1(1:nlevrhiz)); this%rs1(:) = fine_root_radius_const allocate(this%recruit_w_uptake(1:nlevrhiz)); this%recruit_w_uptake = nan + allocate(this%rootuptake_sl(1:nlevsoil)) ; this%rootuptake_sl = nan + allocate(this%rootl_sl(1:nlevsoil)) ; this%rootl_sl = 0._r8 + allocate(this%sapflow_scpf(1:numlevsclass,1:numpft)) ; this%sapflow_scpf = nan - allocate(this%rootuptake_sl(1:nlevrhiz)) ; this%rootuptake_sl = nan allocate(this%rootuptake0_scpf(1:numlevsclass,1:numpft)) ; this%rootuptake0_scpf = nan allocate(this%rootuptake10_scpf(1:numlevsclass,1:numpft)) ; this%rootuptake10_scpf = nan allocate(this%rootuptake50_scpf(1:numlevsclass,1:numpft)) ; this%rootuptake50_scpf = nan @@ -413,8 +416,9 @@ subroutine InitHydrSite(this,numpft,numlevsclass) allocate(this%wrf_soil(1:nlevrhiz)) allocate(this%wkf_soil(1:nlevrhiz)) - if(use_2d_hydrosolve) then - + if((hydr_solver_type == hydr_solver_2DNewton) .or. & + (hydr_solver_type == hydr_solver_2DPicard)) then + this%num_connections = n_hypool_leaf + n_hypool_stem + n_hypool_troot - 1 & + (n_hypool_aroot + nshell) * nlevrhiz @@ -459,7 +463,7 @@ subroutine InitHydrSite(this,numpft,numlevsclass) end if - call this%SetConnections() + call this%SetConnections(hydr_solver_type) end associate @@ -469,35 +473,76 @@ end subroutine InitHydrSite ! =================================================================================== - subroutine FlushSiteScratch(this) - class(ed_site_hydr_type),intent(inout) :: this - - if(use_2d_hydrosolve) then - this%residual(:) = fates_unset_r8 - this%ajac(:,:) = fates_unset_r8 - this%th_node_init(:) = fates_unset_r8 - this%th_node_prev(:) = fates_unset_r8 - this%th_node(:) = fates_unset_r8 - this%dth_node(:) = fates_unset_r8 - this%h_node(:) = fates_unset_r8 - this%v_node(:) = fates_unset_r8 - this%z_node(:) = fates_unset_r8 - this%psi_node(:) = fates_unset_r8 - this%ftc_node(:) = fates_unset_r8 - this%dftc_dpsi_node(:) = fates_unset_r8 -! this%kmax_up(:) = fates_unset_r8 -! this%kmax_dn(:) = fates_unset_r8 - this%q_flux(:) = fates_unset_r8 - end if + subroutine FlushSiteScratch(this,hydr_solver_type) + + class(ed_site_hydr_type),intent(inout) :: this + integer,intent(in) :: hydr_solver_type + + if((hydr_solver_type == hydr_solver_2DNewton) .or. & + (hydr_solver_type == hydr_solver_2DPicard)) then + this%residual(:) = fates_unset_r8 + this%ajac(:,:) = fates_unset_r8 + this%th_node_init(:) = fates_unset_r8 + this%th_node_prev(:) = fates_unset_r8 + this%th_node(:) = fates_unset_r8 + this%dth_node(:) = fates_unset_r8 + this%h_node(:) = fates_unset_r8 + this%v_node(:) = fates_unset_r8 + this%z_node(:) = fates_unset_r8 + this%psi_node(:) = fates_unset_r8 + this%ftc_node(:) = fates_unset_r8 + this%dftc_dpsi_node(:) = fates_unset_r8 + ! this%kmax_up(:) = fates_unset_r8 + ! this%kmax_dn(:) = fates_unset_r8 + this%q_flux(:) = fates_unset_r8 + end if end subroutine FlushSiteScratch + ! =================================================================================== + + function AggBCToRhiz(this,var_in,j,weight) result(var_out) + + class(ed_site_hydr_type) :: this + real(r8) :: var_in(:) + real(r8) :: weight(:) + integer :: j + integer :: j_t,j_b + real(r8) :: var_out + + integer, parameter :: arithmetic_mean = 0 + integer, parameter :: harmonic_mean = 1 + integer, parameter :: mean_type = harmonic_mean + + ! This function aggregates properties on the soil layer to + ! the root(rhiz) layer + + j_t = this%map_r2s(j,1) + j_b = this%map_r2s(j,2) + - subroutine SetConnections(this) + if(mean_type.eq.arithmetic_mean) then + var_out = sum(var_in(j_t:j_b)*weight(j_t:j_b))/sum(weight(j_t:j_b)) + else + + var_out = sum(weight(j_t:j_b)) / sum( weight(j_t:j_b) / var_in(j_t:j_b) ) + + end if + - class(ed_site_hydr_type),intent(inout) :: this + end function AggBCToRhiz + + ! =================================================================================== + + subroutine SetConnections(this,hydr_solver_type) + + ! This routine should be updated + ! when new layers are added as plants grow into them? + class(ed_site_hydr_type),intent(inout) :: this + integer,intent(in) :: hydr_solver_type + integer :: k, j integer :: num_cnxs integer :: num_nds @@ -521,7 +566,8 @@ subroutine SetConnections(this) this%pm_node(num_nds) = stem_p_media enddo - if(use_2d_hydrosolve) then + if((hydr_solver_type == hydr_solver_2DNewton) .or. & + (hydr_solver_type == hydr_solver_2DPicard)) then num_nds = n_hypool_ag+n_hypool_troot node_tr_end = num_nds diff --git a/main/FatesIODimensionsMod.F90 b/main/FatesIODimensionsMod.F90 index 522da97653..6760bf0dbe 100644 --- a/main/FatesIODimensionsMod.F90 +++ b/main/FatesIODimensionsMod.F90 @@ -11,9 +11,8 @@ module FatesIODimensionsMod character(*), parameter, public :: levcacls = 'fates_levcacls' ! matches histFileMod character(*), parameter, public :: cohort = 'cohort' ! matches clm_varcon - character(*), parameter, public :: patch = 'patch' ! matches clm_varcon character(*), parameter, public :: column = 'column' ! matches clm_varcon - character(*), parameter, public :: levgrnd = 'levgrnd' ! matches clm_varcon + character(*), parameter, public :: levsoil = 'levsoi' ! matches clm_varcon character(*), parameter, public :: levscag = 'fates_levscag' ! matches histFileMod character(*), parameter, public :: levscagpft = 'fates_levscagpf' ! matches histFileMod character(*), parameter, public :: levagepft = 'fates_levagepft' ! matches histFileMod @@ -34,16 +33,12 @@ module FatesIODimensionsMod character(*), parameter, public :: levelcwd = 'fates_levelcwd' character(*), parameter, public :: levelage = 'fates_levelage' - ! patch = This is a structure that records where FATES patch boundaries - ! on each thread point to in the host IO array, this structure - ! is allocated by number of threads - ! column = This is a structure that records where FATES column boundaries ! on each thread point to in the host IO array, this structure ! is allocated by number of threads - ! ground = This is a structure that records the boundaries for the - ! ground level (includes rock) dimension + ! levsoil = This is a structure that records the boundaries for the + ! soil level (includes rock) dimension ! levscpf = This is a structure that records the boundaries for the ! number of size-class x pft dimension @@ -100,14 +95,12 @@ module FatesIODimensionsMod type, public :: fates_bounds_type - integer :: patch_begin - integer :: patch_end integer :: cohort_begin integer :: cohort_end integer :: column_begin ! FATES does not have a "column" type integer :: column_end ! we call this a "site" (rgk 11-2016) - integer :: ground_begin - integer :: ground_end + integer :: soil_begin + integer :: soil_end integer :: sizeage_class_begin integer :: sizeage_class_end integer :: sizeagepft_class_begin diff --git a/main/FatesIOVariableKindMod.F90 b/main/FatesIOVariableKindMod.F90 index 93b34ebab3..daba4f3c20 100644 --- a/main/FatesIOVariableKindMod.F90 +++ b/main/FatesIOVariableKindMod.F90 @@ -10,17 +10,13 @@ module FatesIOVariableKindMod ! FIXME(bja, 2016-10) do these need to be strings, or can they be integer enumerations? ! FIXME(rgk, 2016-11) these should probably be moved to varkindmod? - character(*), parameter, public :: patch_r8 = 'PA_R8' - character(*), parameter, public :: patch_ground_r8 = 'PA_GRND_R8' - character(*), parameter, public :: patch_size_pft_r8 = 'PA_SCPF_R8' character(*), parameter, public :: site_r8 = 'SI_R8' character(*), parameter, public :: site_int = 'SI_INT' - character(*), parameter, public :: site_ground_r8 = 'SI_GRND_R8' + character(*), parameter, public :: site_soil_r8 = 'SI_SOIL_R8' character(*), parameter, public :: site_size_pft_r8 = 'SI_SCPF_R8' character(*), parameter, public :: site_size_r8 = 'SI_SCLS_R8' character(*), parameter, public :: site_coage_pft_r8 = 'SI_CAPF_R8' character(*), parameter, public :: site_coage_r8 = 'SI_CACLS_R8' - character(*), parameter, public :: patch_int = 'PA_INT' character(*), parameter, public :: cohort_r8 = 'CO_R8' character(*), parameter, public :: cohort_int = 'CO_INT' character(*), parameter, public :: site_pft_r8 = 'SI_PFT_R8' diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 16f0607e7d..e6e73b80df 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -12,6 +12,10 @@ module FatesInterfaceMod use EDTypesMod , only : ed_site_type use EDTypesMod , only : maxPatchesPerSite use EDTypesMod , only : maxCohortsPerPatch + use EDTypesMod , only : dinc_vai + use EDTypesMod , only : dlower_vai + use EDParamsMod , only : ED_val_vai_top_bin_width + use EDParamsMod , only : ED_val_vai_width_increase_factor use EDTypesMod , only : maxSWb use EDTypesMod , only : ivis use EDTypesMod , only : inir @@ -21,9 +25,14 @@ module FatesInterfaceMod use EDTypesMod , only : do_fates_salinity use EDTypesMod , only : numWaterMem use EDTypesMod , only : numlevsoil_max + use EDTypesMod , only : ed_site_type + use EDTypesMod , only : ed_patch_type + use EDTypesMod , only : ed_cohort_type + use EDTypesMod , only : area_inv use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue,ifalse use FatesConstantsMod , only : nearzero + use FatesConstantsMod , only : sec_per_day use FatesGlobals , only : fates_global_verbose use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun @@ -36,6 +45,7 @@ module FatesInterfaceMod use EDParamsMod , only : FatesReportParams use EDParamsMod , only : bgc_soil_salinity use FatesPlantHydraulicsMod , only : InitHydroGlobals + use EDParamsMod , only : photo_temp_acclim_timescale use EDParamsMod , only : ED_val_history_sizeclass_bin_edges use EDParamsMod , only : ED_val_history_ageclass_bin_edges use EDParamsMod , only : ED_val_history_height_bin_edges @@ -43,6 +53,7 @@ module FatesInterfaceMod use CLMFatesParamInterfaceMod , only : FatesReadParameters use EDTypesMod , only : p_uptake_mode use EDTypesMod , only : n_uptake_mode + use EDTypesMod , only : ed_site_type use FatesConstantsMod , only : prescribed_p_uptake use FatesConstantsMod , only : prescribed_n_uptake use FatesConstantsMod , only : coupled_p_uptake @@ -63,11 +74,17 @@ module FatesInterfaceMod use PRTGenericMod , only : leaf_organ, fnrt_organ, store_organ use PRTGenericMod , only : sapw_organ, struct_organ, repro_organ use PRTParametersMod , only : prt_params - use PRTInitParamsFatesMod , only : PRTCheckParams + use PRTInitParamsFatesMod , only : PRTCheckParams, PRTDerivedParams use PRTAllometricCarbonMod , only : InitPRTGlobalAllometricCarbon use PRTAllometricCNPMod , only : InitPRTGlobalAllometricCNP + use FatesRunningMeanMod , only : ema_24hr + use FatesRunningMeanMod , only : fixed_24hr + use FatesRunningMeanMod , only : ema_lpa + use FatesRunningMeanMod , only : moving_ema_window + use FatesRunningMeanMod , only : fixed_window + use FatesHistoryInterfaceMod , only : fates_hist - + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) @@ -76,11 +93,48 @@ module FatesInterfaceMod ! its sister code use FatesInterfaceTypesMod - implicit none private + type, public :: fates_interface_type + + ! This is the root of the ED/FATES hierarchy of instantaneous state variables + ! ie the root of the linked lists. Each path list is currently associated with a + ! grid-cell, this is intended to be migrated to columns + + integer :: nsites + + type(ed_site_type), pointer :: sites(:) + + ! These are boundary conditions that the FATES models are required to be filled. + ! These values are filled by the driver or HLM. Once filled, these have an + ! intent(in) status. Each site has a derived type structure, which may include + ! a scalar for site level data, a patch vector, potentially cohort vectors (but + ! not yet atm) and other dimensions such as soil-depth or pft. These vectors + ! are initialized by maximums, and the allocations are static in time to avoid + ! having to allocate/de-allocate memory + + type(bc_in_type), allocatable :: bc_in(:) + + ! These are the boundary conditions that the FATES model returns to its HLM or + ! driver. It has the same allocation strategy and similar vector types. + + type(bc_out_type), allocatable :: bc_out(:) + + + ! These are parameter constants that FATES may need to provide a host model + ! We have other methods of reading in input parameters. Since these + ! are parameter constants, we don't need them allocated over every site,one + ! instance is fine. + + type(bc_pconst_type) :: bc_pconst + + + end type fates_interface_type + + + character(len=*), parameter :: sourcefile = & __FILE__ @@ -96,7 +150,9 @@ module FatesInterfaceMod public :: set_bcpconst public :: zero_bcs public :: set_bcs - + public :: UpdateFatesRMeansTStep + public :: InitTimeAveragingGlobals + contains ! ==================================================================================== @@ -196,13 +252,12 @@ subroutine zero_bcs(fates,s) ! Input boundaries - fates%bc_in(s)%t_veg24_pa(:) = 0.0_r8 - fates%bc_in(s)%precip24_pa(:) = 0.0_r8 - fates%bc_in(s)%relhumid24_pa(:) = 0.0_r8 - fates%bc_in(s)%wind24_pa(:) = 0.0_r8 - fates%bc_in(s)%lightning24(:) = 0.0_r8 fates%bc_in(s)%pop_density(:) = 0.0_r8 + fates%bc_in(s)%precip24_pa(:) = 0.0_r8 + fates%bc_in(s)%relhumid24_pa(:) = 0.0_r8 + fates%bc_in(s)%wind24_pa(:) = 0.0_r8 + fates%bc_in(s)%solad_parb(:,:) = 0.0_r8 fates%bc_in(s)%solai_parb(:,:) = 0.0_r8 fates%bc_in(s)%smp_sl(:) = 0.0_r8 @@ -212,6 +267,7 @@ subroutine zero_bcs(fates,s) fates%bc_in(s)%h2o_liqvol_sl(:) = 0.0_r8 fates%bc_in(s)%filter_vegzen_pa(:) = .false. fates%bc_in(s)%coszen_pa(:) = 0.0_r8 + fates%bc_in(s)%fcansno_pa(:) = 0.0_r8 fates%bc_in(s)%albgr_dir_rb(:) = 0.0_r8 fates%bc_in(s)%albgr_dif_rb(:) = 0.0_r8 fates%bc_in(s)%max_rooting_depth_index_col = 0 @@ -256,7 +312,8 @@ subroutine zero_bcs(fates,s) fates%bc_out(s)%litt_flux_lab_c_si(:) = 0._r8 case(prt_cnp_flex_allom_hyp) - fates%bc_in(s)%plant_n_uptake_flux(:,:) = 0._r8 + fates%bc_in(s)%plant_nh4_uptake_flux(:,:) = 0._r8 + fates%bc_in(s)%plant_no3_uptake_flux(:,:) = 0._r8 fates%bc_in(s)%plant_p_uptake_flux(:,:) = 0._r8 fates%bc_out(s)%source_p(:) = 0._r8 fates%bc_out(s)%source_nh4(:) = 0._r8 @@ -297,6 +354,7 @@ subroutine zero_bcs(fates,s) fates%bc_out(s)%displa_pa(:) = 0.0_r8 fates%bc_out(s)%z0m_pa(:) = 0.0_r8 fates%bc_out(s)%dleaf_pa(:) = 0.0_r8 + fates%bc_out(s)%nocomp_pft_label_pa(:) = 0 fates%bc_out(s)%canopy_fraction_pa(:) = 0.0_r8 fates%bc_out(s)%frac_veg_nosno_alb_pa(:) = 0.0_r8 @@ -386,17 +444,21 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then - allocate(bc_in%plant_n_uptake_flux(max_comp_per_site,1)) + allocate(bc_in%plant_nh4_uptake_flux(max_comp_per_site,1)) + allocate(bc_in%plant_no3_uptake_flux(max_comp_per_site,1)) allocate(bc_in%plant_p_uptake_flux(max_comp_per_site,1)) else - allocate(bc_in%plant_n_uptake_flux(max_comp_per_site,bc_in%nlevdecomp)) + allocate(bc_in%plant_nh4_uptake_flux(max_comp_per_site,bc_in%nlevdecomp)) + allocate(bc_in%plant_no3_uptake_flux(max_comp_per_site,bc_in%nlevdecomp)) allocate(bc_in%plant_p_uptake_flux(max_comp_per_site,bc_in%nlevdecomp)) end if else - allocate(bc_in%plant_n_uptake_flux(1,1)) + allocate(bc_in%plant_nh4_uptake_flux(1,1)) + allocate(bc_in%plant_no3_uptake_flux(1,1)) allocate(bc_in%plant_p_uptake_flux(1,1)) end if + allocate(bc_in%zi_sisl(0:nlevsoil_in)) allocate(bc_in%dz_sisl(nlevsoil_in)) allocate(bc_in%z_sisl(nlevsoil_in)) @@ -406,12 +468,9 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) allocate(bc_in%t_scalar_sisl(nlevsoil_in)) ! Lightning (or successful ignitions) and population density + ! Fire related variables allocate(bc_in%lightning24(maxPatchesPerSite)) allocate(bc_in%pop_density(maxPatchesPerSite)) - - ! Vegetation Dynamics - allocate(bc_in%t_veg24_pa(maxPatchesPerSite)) - allocate(bc_in%wind24_pa(maxPatchesPerSite)) allocate(bc_in%relhumid24_pa(maxPatchesPerSite)) allocate(bc_in%precip24_pa(maxPatchesPerSite)) @@ -432,6 +491,8 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) allocate(bc_in%salinity_sl(nlevsoil_in)) endif + + ! Photosynthesis allocate(bc_in%filter_photo_pa(maxPatchesPerSite)) allocate(bc_in%dayl_factor_pa(maxPatchesPerSite)) @@ -447,6 +508,7 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) ! Canopy Radiation allocate(bc_in%filter_vegzen_pa(maxPatchesPerSite)) allocate(bc_in%coszen_pa(maxPatchesPerSite)) + allocate(bc_in%fcansno_pa(maxPatchesPerSite)) allocate(bc_in%albgr_dir_rb(hlm_numSWb)) allocate(bc_in%albgr_dif_rb(hlm_numSWb)) @@ -477,8 +539,14 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) allocate(bc_in%hlm_harvest_catnames(0)) end if - allocate(bc_in%pft_areafrac(maxpft)) + allocate(bc_in%pft_areafrac(0:maxpft)) + ! Variables for SP mode. + if(hlm_use_sp.eq.itrue) then + allocate(bc_in%hlm_sp_tlai(0:maxpft)) + allocate(bc_in%hlm_sp_tsai(0:maxpft)) + allocate(bc_in%hlm_sp_htop(0:maxpft)) + end if return end subroutine allocate_bcin @@ -543,7 +611,23 @@ subroutine allocate_bcout(bc_out, nlevsoil_in, nlevdecomp_in) allocate(bc_out%cp_scalar(max_comp_per_site)) end if - + ! Include the bare-ground patch for these patch-level boundary conditions + ! (it will always be zero for all of these) + if(hlm_use_ch4.eq.itrue) then + allocate(bc_out%annavg_agnpp_pa(0:maxPatchesPerSite));bc_out%annavg_agnpp_pa(:)=nan + allocate(bc_out%annavg_bgnpp_pa(0:maxPatchesPerSite));bc_out%annavg_bgnpp_pa(:)=nan + allocate(bc_out%annsum_npp_pa(0:maxPatchesPerSite));bc_out%annsum_npp_pa(:)=nan + allocate(bc_out%frootc_pa(0:maxPatchesPerSite));bc_out%frootc_pa(:)=nan + allocate(bc_out%root_resp(nlevsoil_in));bc_out%root_resp(:)=nan + allocate(bc_out%woody_frac_aere_pa(0:maxPatchesPerSite));bc_out%woody_frac_aere_pa(:)=nan + allocate(bc_out%rootfr_pa(0:maxPatchesPerSite,nlevsoil_in)) + bc_out%rootfr_pa(:,:)=nan + + ! Give the bare-ground root fractions a nominal fraction of unity over depth + bc_out%rootfr_pa(0,1:nlevsoil_in)=1._r8/real(nlevsoil_in,r8) + end if + + ! Fates -> BGC fragmentation mass fluxes select case(hlm_parteh_mode) case(prt_carbon_allom_hyp) @@ -588,6 +672,8 @@ subroutine allocate_bcout(bc_out, nlevsoil_in, nlevdecomp_in) allocate(bc_out%canopy_fraction_pa(maxPatchesPerSite)) allocate(bc_out%frac_veg_nosno_alb_pa(maxPatchesPerSite)) + allocate(bc_out%nocomp_pft_label_pa(maxPatchesPerSite)) + ! Plant-Hydro BC's if (hlm_use_planthydro.eq.itrue) then allocate(bc_out%qflx_soil2root_sisl(nlevsoil_in)) @@ -654,7 +740,7 @@ subroutine SetFatesGlobalElements(use_fates) if (use_fates) then - ! first read the non-PFT parameters + ! Self explanatory, read the fates parameter file call FatesReadParameters() ! Identify the number of PFTs by evaluating a pft array @@ -700,7 +786,7 @@ subroutine SetFatesGlobalElements(use_fates) ! These values are used to define the restart file allocations and general structure ! of memory for the cohort arrays - fates_maxElementsPerPatch = max(maxCohortsPerPatch, ndcmpy*numlevsoil_max ,ncwd*numlevsoil_max) + fates_maxElementsPerPatch = max(maxCohortsPerPatch, ndcmpy*hlm_maxlevsoil ,ncwd*hlm_maxlevsoil) if (maxPatchesPerSite * fates_maxElementsPerPatch < numWaterMem) then write(fates_log(), *) 'By using such a tiny number of maximum patches and maximum cohorts' @@ -730,7 +816,16 @@ subroutine SetFatesGlobalElements(use_fates) max_comp_per_site = 1 end if + ! calculate the bin edges for radiative transfer calculations + ! VAI bin widths array + do i = 1,nlevleaf + dinc_vai(i) = ED_val_vai_top_bin_width * ED_val_vai_width_increase_factor ** (i-1) + end do + ! lower edges of VAI bins + do i = 1,nlevleaf + dlower_vai(i) = sum(dinc_vai(1:i)) + end do ! Identify number of size and age class bins for history output ! assume these arrays are 1-indexed @@ -797,6 +892,7 @@ subroutine SetFatesGlobalElements(use_fates) ! These will not be used if use_ed or use_fates is false call fates_history_maps() + else ! If we are not using FATES, the cohort dimension is still @@ -813,6 +909,27 @@ subroutine SetFatesGlobalElements(use_fates) end subroutine SetFatesGlobalElements + ! ====================================================================== + + subroutine InitTimeAveragingGlobals() + + ! Instantiate the time-averaging method globals + ! NOTE: It may be possible in the future that the HLM model timesteps + ! are dynamic in time or space, in that case, these would no longer + ! be global constants. + + allocate(ema_24hr) + call ema_24hr%define(sec_per_day, hlm_stepsize, moving_ema_window) + allocate(fixed_24hr) + call fixed_24hr%define(sec_per_day, hlm_stepsize, fixed_window) + allocate(ema_lpa) + call ema_lpa%define(photo_temp_acclim_timescale*sec_per_day, & + hlm_stepsize,moving_ema_window) + + return + end subroutine InitTimeAveragingGlobals + + ! ====================================================================== subroutine InitPARTEHGlobals() @@ -906,6 +1023,7 @@ subroutine fates_history_maps allocate( fates_hdim_levcan(nclmax)) allocate( fates_hdim_levelem(num_elements)) + allocate( fates_hdim_levleaf(nlevleaf)) allocate( fates_hdim_canmap_levcnlf(nlevleaf*nclmax)) allocate( fates_hdim_lfmap_levcnlf(nlevleaf*nclmax)) allocate( fates_hdim_canmap_levcnlfpf(nlevleaf*nclmax*numpft)) @@ -934,6 +1052,7 @@ subroutine fates_history_maps fates_hdim_levage(:) = ED_val_history_ageclass_bin_edges(:) fates_hdim_levheight(:) = ED_val_history_height_bin_edges(:) fates_hdim_levcoage(:) = ED_val_history_coageclass_bin_edges(:) + fates_hdim_levleaf(:) = dlower_vai(:) ! make pft array do ipft=1,numpft @@ -1123,7 +1242,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) ! call set_fates_ctrlparms('flush_to_unset') ! call set_fates_ctrlparms('num_sw_bbands',numrad) ! or other variable ! ... - ! call set_fates_ctrlparms('num_lev_ground',nlevgrnd) ! or other variable + ! call set_fates_ctrlparms('num_lev_soil',nlevsoi) ! or other variable ! call set_fates_ctrlparms('check_allset') ! ! RGK-2016 @@ -1153,7 +1272,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_inir = unset_int hlm_ivis = unset_int hlm_is_restart = unset_int - hlm_numlevgrnd = unset_int + hlm_maxlevsoil = unset_int hlm_name = 'unset' hlm_hio_ignore_val = unset_double hlm_masterproc = unset_int @@ -1162,6 +1281,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_nitrogen_spec = unset_int hlm_phosphorus_spec = unset_int hlm_max_patch_per_site = unset_int + hlm_use_ch4 = unset_int hlm_use_vertsoilc = unset_int hlm_parteh_mode = unset_int hlm_spitfire_mode = unset_int @@ -1177,7 +1297,8 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_use_ed_st3 = unset_int hlm_use_ed_prescribed_phys = unset_int hlm_use_fixed_biogeog = unset_int - !hlm_use_nocomp = unset_int ! future reduced complexity mode + hlm_use_nocomp = unset_int + hlm_use_sp = unset_int hlm_use_inventory_init = unset_int hlm_inventory_ctrl_file = 'unset' @@ -1328,9 +1449,9 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - if(hlm_numlevgrnd .eq. unset_int) then + if(hlm_maxlevsoil .eq. unset_int) then if (fates_global_verbose()) then - write(fates_log(), *) 'FATES dimension/parameter unset: numlevground, exiting' + write(fates_log(), *) 'FATES dimension/parameter unset: hlm_maxlevsoil, exiting' end if call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1400,6 +1521,13 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if(hlm_use_ch4 .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'switch for the HLMs CH4 module unset: hlm_use_ch4, exiting' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if(hlm_use_vertsoilc .eq. unset_int) then if (fates_global_verbose()) then write(fates_log(), *) 'switch for the HLMs soil carbon discretization unset: hlm_use_vertsoilc, exiting' @@ -1448,6 +1576,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) end if end if + if(hlm_use_fixed_biogeog.eq.unset_int) then if(fates_global_verbose()) then write(fates_log(), *) 'switch for fixed biogeog unset: him_use_fixed_biogeog, exiting' @@ -1455,13 +1584,19 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - ! Future reduced complexity mode - !if(hlm_use_nocomp.eq.unset_int) then - ! if(fates_global_verbose()) then - ! write(fates_log(), *) 'switch for no competition mode. ' - ! end if - ! call endrun(msg=errMsg(sourcefile, __LINE__)) - ! end if + if(hlm_use_nocomp.eq.unset_int) then + if(fates_global_verbose()) then + write(fates_log(), *) 'switch for no competition mode. ' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_use_sp.eq.unset_int) then + if(fates_global_verbose()) then + write(fates_log(), *) 'switch for SP mode. ' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if if(hlm_use_cohort_age_tracking .eq. unset_int) then if (fates_global_verbose()) then @@ -1470,6 +1605,16 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if(hlm_use_sp.eq.itrue.and.hlm_use_nocomp.eq.ifalse)then + write(fates_log(), *) 'SP cannot be on if nocomp mode is off. Exiting. ' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + if(hlm_use_sp.eq.itrue.and.hlm_use_fixed_biogeog.eq.ifalse)then + write(fates_log(), *) 'SP cannot be on if fixed biogeog mode is off. Exiting. ' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if if (fates_global_verbose()) then write(fates_log(), *) 'Checked. All control parameters sent to FATES.' @@ -1511,10 +1656,10 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering flag signaling restart / not-restart = ',ival,' to FATES' end if - case('num_lev_ground') - hlm_numlevgrnd = ival + case('num_lev_soil') + hlm_maxlevsoil = ival if (fates_global_verbose()) then - write(fates_log(),*) 'Transfering num_lev_ground = ',ival,' to FATES' + write(fates_log(),*) 'Transfering num_lev_soil = ',ival,' to FATES' end if case('soilwater_ipedof') @@ -1542,6 +1687,12 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering hlm_max_patch_per_site = ',ival,' to FATES' end if + case('use_ch4') + hlm_use_ch4 = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_use_ch4 = ',ival,' to FATES' + end if + case('use_vertsoilc') hlm_use_vertsoilc = ival if (fates_global_verbose()) then @@ -1591,13 +1742,17 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering hlm_use_fixed_biogeog= ',ival,' to FATES' end if - ! Future reduced complexity mode - !case('use_nocomp') - ! hlm_use_nocomp = ival - ! if (fates_global_verbose()) then - ! write(fates_log(),*) 'Transfering hlm_use_nocomp= ',ival,' to FATES' - ! end if + case('use_nocomp') + hlm_use_nocomp = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_use_nocomp= ',ival,' to FATES' + end if + case('use_sp') + hlm_use_sp = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_use_sp= ',ival,' to FATES' + end if case('use_planthydro') hlm_use_planthydro = ival @@ -1720,15 +1875,51 @@ subroutine FatesReportParameters(masterproc) call FatesReportPFTParams(masterproc) call FatesReportParams(masterproc) call FatesCheckParams(masterproc) ! Check general fates parameters + call PRTDerivedParams() ! Update PARTEH derived constants call PRTCheckParams(masterproc) ! Check PARTEH parameters call SpitFireCheckParams(masterproc) + + return end subroutine FatesReportParameters - ! ===================================================================================== - + ! ===================================================================================== + subroutine UpdateFatesRMeansTStep(sites,bc_in) + ! In this routine, we update any FATES buffers where + ! we calculate running means. It is assumed that this buffer is updated + ! on the model time-step. -end module FatesInterfaceMod + type(ed_site_type), intent(inout) :: sites(:) + type(bc_in_type), intent(in) :: bc_in(:) + + type(ed_patch_type), pointer :: cpatch + type(ed_cohort_type), pointer :: ccohort + integer :: s, ifp, io_si + + do s = 1,size(sites,dim=1) + + ifp=0 + cpatch => sites(s)%oldest_patch + do while(associated(cpatch)) + ifp=ifp+1 + call cpatch%tveg24%UpdateRMean(bc_in(s)%t_veg_pa(ifp)) + call cpatch%tveg_lpa%UpdateRMean(bc_in(s)%t_veg_pa(ifp)) + + ! (Keeping as an example) + !ccohort => cpatch%tallest + !do while (associated(ccohort)) + ! call ccohort%tveg_lpa%UpdateRMean(bc_in(s)%t_veg_pa(ifp)) + ! ccohort => ccohort%shorter + !end do + + cpatch => cpatch%younger + enddo + end do + + return + end subroutine UpdateFatesRMeansTStep + + end module FatesInterfaceMod diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index f3982f235a..4acf6db391 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -7,7 +7,6 @@ module FatesInterfaceTypesMod use FatesGlobals , only : endrun => fates_endrun use shr_log_mod , only : errMsg => shr_log_errMsg use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) - use EDTypesMod , only : ed_site_type implicit none @@ -32,10 +31,8 @@ module FatesInterfaceTypesMod integer, public :: hlm_inir ! The HLMs assumption of the array index associated with the ! NIR portion of the spectrum in short-wave radiation arrays + integer, public :: hlm_maxlevsoil ! Max number of soil layers - integer, public :: hlm_numlevgrnd ! Number of ground layers - ! NOTE! SOIL LAYERS ARE NOT A GLOBAL, THEY - ! ARE VARIABLE BY SITE integer, public :: hlm_is_restart ! Is the HLM signalling that this is a restart ! type simulation? @@ -69,7 +66,9 @@ module FatesInterfaceTypesMod ! 0: none ! 1: p is on - + real(r8), public :: hlm_stepsize ! The step-size of the host land model (s) + ! moreover, this is the shortest main-model timestep + ! at which fates will be called on the main model integration loop real(r8), public :: hlm_hio_ignore_val ! This value can be flushed to history ! diagnostics, such that the @@ -101,6 +100,10 @@ module FatesInterfaceTypesMod ! Transport (exensible) Hypothesis (PARTEH) to use + integer, public :: hlm_use_ch4 ! This flag signals whether the methane model in ELM/CLM is + ! active, and therefore whether or not boundary conditions + ! need to be prepped + integer, public :: hlm_use_vertsoilc ! This flag signals whether or not the ! host model is using vertically discretized ! soil carbon @@ -183,6 +186,11 @@ module FatesInterfaceTypesMod integer, public :: hlm_use_fixed_biogeog ! Flag to use FATES fixed biogeography mode ! 1 = TRUE, 0 = FALSE + integer, public :: hlm_use_nocomp ! Flag to use FATES no competition mode + ! 1 = TRUE, 0 = FALSE + + integer, public :: hlm_use_sp ! Flag to use FATES satellite phenology (LAI) mode + ! 1 = TRUE, 0 = FALSE ! ------------------------------------------------------------------------------------- ! Parameters that are dictated by FATES and known to be required knowledge ! needed by the HLMs @@ -229,6 +237,7 @@ module FatesInterfaceTypesMod integer , public, allocatable :: fates_hdim_levfuel(:) ! fire fuel size class (fsc) dimension integer , public, allocatable :: fates_hdim_levcwdsc(:) ! cwd class dimension integer , public, allocatable :: fates_hdim_levcan(:) ! canopy-layer dimension + integer , public, allocatable :: fates_hdim_levleaf(:) ! leaf-layer dimension integer , public, allocatable :: fates_hdim_levelem(:) ! element dimension integer , public, allocatable :: fates_hdim_canmap_levcnlf(:) ! canopy-layer map into the canopy-layer x leaf-layer dim integer , public, allocatable :: fates_hdim_lfmap_levcnlf(:) ! leaf-layer map into the can-layer x leaf-layer dimension @@ -335,31 +344,23 @@ module FatesInterfaceTypesMod real(r8),allocatable :: w_scalar_sisl(:) ! fraction by which decomposition is limited by moisture availability real(r8),allocatable :: t_scalar_sisl(:) ! fraction by which decomposition is limited by temperature - - ! Vegetation Dynamics - ! --------------------------------------------------------------------------------- + ! Fire Model ! 24-hour lightning or ignitions [#/km2/day] real(r8),allocatable :: lightning24(:) ! Population density [#/km2] real(r8),allocatable :: pop_density(:) - - ! Patch 24 hour vegetation temperature [K] - real(r8),allocatable :: t_veg24_pa(:) - ! Fire Model - ! Average precipitation over the last 24 hours [mm/s] real(r8), allocatable :: precip24_pa(:) - + ! 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 ! --------------------------------------------------------------------------------- @@ -377,8 +378,12 @@ module FatesInterfaceTypesMod ! Note 1: If these are indexed by COHORT, they don't also need to be indexed ! by decomposition layer. So it is allocated with 2nd dim=1. ! Note 2: Has it's own zero'ing call - real(r8), pointer :: plant_n_uptake_flux(:,:) ! Nitrogen input flux for + real(r8), pointer :: plant_nh4_uptake_flux(:,:) ! Ammonium uptake flux for ! each competitor [gN/m2/day] + + real(r8), pointer :: plant_no3_uptake_flux(:,:) ! Nitrate uptake flux for + ! each competitor [gN/m2/day] + real(r8), pointer :: plant_p_uptake_flux(:,:) ! Phosphorus input flux for ! each competitor [gP/m2/day] @@ -435,7 +440,10 @@ module FatesInterfaceTypesMod ! I am leaving it at this scale for simplicity. Patches should ! have no spacially variable information real(r8), allocatable :: coszen_pa(:) - + + ! fraction of canopy that is covered in snow + real(r8), allocatable :: fcansno_pa(:) + ! Abledo of the ground for direct radiation, by site broadband (0-1) real(r8), allocatable :: albgr_dir_rb(:) @@ -473,10 +481,10 @@ module FatesInterfaceTypesMod ! volumetric soil water at saturation (porosity) real(r8), allocatable :: watsat_sl(:) - ! Temperature of ground layers [K] + ! Temperature of soil layers [K] real(r8), allocatable :: tempk_sl(:) - ! Liquid volume in ground layer (m3/m3) + ! Liquid volume in soil layer (m3/m3) real(r8), allocatable :: h2o_liqvol_sl(:) ! Site level filter for uptake response functions @@ -511,6 +519,12 @@ module FatesInterfaceTypesMod ! Fixed biogeography mode real(r8), allocatable :: pft_areafrac(:) ! Fractional area of the FATES column occupied by each PFT + ! Satellite Phenology (SP) input variables. (where each patch only has one PFT) + ! --------------------------------------------------------------------------------- + real(r8),allocatable :: hlm_sp_tlai(:) ! Interpolated daily total LAI (leaf area index) input from HLM per patch/pft + real(r8),allocatable :: hlm_sp_tsai(:) ! Interpolated sailt total SAI (stem area index) input from HLM per patch/pft + real(r8),allocatable :: hlm_sp_htop(:) ! Interpolated daily canopy vegetation height input from HLM per patch/pft + end type bc_in_type @@ -525,7 +539,7 @@ module FatesInterfaceTypesMod ! Shaded canopy LAI real(r8),allocatable :: laisha_pa(:) - ! Logical stating whether a ground layer can have water uptake by plants + ! Logical stating whether a soil layer can have water uptake by plants ! The only condition right now is that liquid water exists ! The name (suction) is used to indicate that soil suction should be calculated logical, allocatable :: active_suction_sl(:) @@ -618,7 +632,7 @@ module FatesInterfaceTypesMod - ! CTC/RD Nutrient Boundary Conditions + ! RD Nutrient Boundary Conditions ! --------------------------------------------------------------------------------- real(r8), pointer :: n_demand(:) ! Nitrogen demand from each competitor @@ -627,8 +641,16 @@ module FatesInterfaceTypesMod ! for use in ELMs CTC/RD [g/m2/s] - - + ! CH4 Boundary Conditions + ! ----------------------------------------------------------------------------------- + real(r8), pointer :: annavg_agnpp_pa(:) ! annual average patch npp above ground (gC/m2/s) + real(r8), pointer :: annavg_bgnpp_pa(:) ! annual average patch npp below ground (gC/m2/s) + real(r8), pointer :: annsum_npp_pa(:) ! annual sum patch npp (gC/m2/yr) + real(r8), pointer :: frootc_pa(:) ! Carbon in fine roots (gC/m2) + real(r8), pointer :: root_resp(:) ! (gC/m2/s) root respiration (fine root MR + total root GR) + real(r8), pointer :: rootfr_pa(:,:) ! Rooting fraction with depth + real(r8), pointer :: woody_frac_aere_pa(:) ! Woody plant fraction (by crown area) of all plants + ! used for calculating patch-level aerenchyma porosity ! Canopy Structure @@ -653,6 +675,8 @@ module FatesInterfaceTypesMod ! vegetation in the patch is exposed. ! [0,1] + integer, allocatable :: nocomp_pft_label_pa(:) ! in nocomp and SP mode, each patch has a PFT identity. + ! FATES Hydraulics @@ -710,43 +734,7 @@ module FatesInterfaceTypesMod ! increasing, or all 1s) end type bc_pconst_type - - - type, public :: fates_interface_type - - ! This is the root of the ED/FATES hierarchy of instantaneous state variables - ! ie the root of the linked lists. Each path list is currently associated with a - ! grid-cell, this is intended to be migrated to columns - - integer :: nsites - - type(ed_site_type), pointer :: sites(:) - - ! These are boundary conditions that the FATES models are required to be filled. - ! These values are filled by the driver or HLM. Once filled, these have an - ! intent(in) status. Each site has a derived type structure, which may include - ! a scalar for site level data, a patch vector, potentially cohort vectors (but - ! not yet atm) and other dimensions such as soil-depth or pft. These vectors - ! are initialized by maximums, and the allocations are static in time to avoid - ! having to allocate/de-allocate memory - - type(bc_in_type), allocatable :: bc_in(:) - - ! These are the boundary conditions that the FATES model returns to its HLM or - ! driver. It has the same allocation strategy and similar vector types. - - type(bc_out_type), allocatable :: bc_out(:) - - - ! These are parameter constants that FATES may need to provide a host model - ! We have other methods of reading in input parameters. Since these - ! are parameter constants, we don't need them allocated over every site,one - ! instance is fine. - - type(bc_pconst_type) :: bc_pconst - - - end type fates_interface_type + contains diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 74d88d7e9b..507f01dbee 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -3,7 +3,7 @@ module FatesInventoryInitMod !----------------------------------------------------------------------------------------------- ! This module contains the majority of the code used to read forest inventory data and ! initialize a simulation from that data. Some important points: - ! - This procedure is called through the host model's "cold-start" initialization and not a + ! - This procedure is called through the host model's "cold-start" initialization and not a ! restart type of simulation. ! - This procedure, if called from a massive grid, is both probably inappropriate, and probably ! time consuming. @@ -34,7 +34,7 @@ module FatesInventoryInitMod use FatesLitterMod , only : litter_type use EDTypesMod , only : ed_site_type use EDTypesMod , only : ed_patch_type - use EDTypesMod , only : ed_cohort_type + use EDTypesMod , only : ed_cohort_type use EDTypesMod , only : area use EDTypesMod , only : leaves_on use EDTypesMod , only : leaves_off @@ -47,21 +47,24 @@ module FatesInventoryInitMod use PRTParametersMod , only : prt_params use EDPftvarcon , only : EDPftvarcon_inst use FatesInterfaceTypesMod, only : hlm_parteh_mode - use EDCohortDynamicsMod, only : InitPRTObject - use PRTGenericMod, only : prt_carbon_allom_hyp - use PRTGenericMod, only : prt_cnp_flex_allom_hyp - use PRTGenericMod, only : prt_vartypes - use PRTGenericMod, only : leaf_organ - use PRTGenericMod, only : fnrt_organ - use PRTGenericMod, only : sapw_organ - use PRTGenericMod, only : store_organ - use PRTGenericMod, only : struct_organ - use PRTGenericMod, only : repro_organ - use PRTGenericMod, only : carbon12_element - use PRTGenericMod, only : nitrogen_element - use PRTGenericMod, only : phosphorus_element - use PRTGenericMod, only : SetState - use FatesConstantsMod, only : primaryforest + use EDCohortDynamicsMod, only : InitPRTObject + use PRTGenericMod, only : prt_carbon_allom_hyp + use PRTGenericMod, only : prt_cnp_flex_allom_hyp + use PRTGenericMod, only : prt_vartypes + use PRTGenericMod, only : leaf_organ + use PRTGenericMod, only : fnrt_organ + use PRTGenericMod, only : sapw_organ + use PRTGenericMod, only : store_organ + use PRTGenericMod, only : struct_organ + use PRTGenericMod, only : repro_organ + use PRTGenericMod, only : carbon12_element + use PRTGenericMod, only : nitrogen_element + use PRTGenericMod, only : phosphorus_element + use PRTGenericMod, only : SetState + use FatesConstantsMod, only : primaryforest + use FatesRunningMeanMod, only : ema_lpa + use PRTGenericMod, only : StorageNutrientTarget + use FatesConstantsMod, only : fates_unset_int implicit none private @@ -80,7 +83,7 @@ module FatesInventoryInitMod logical, parameter :: debug_inv = .false. ! Debug flag for devs ! String length specifiers - integer, parameter :: patchname_strlen = 64 + integer, parameter :: patchname_strlen = 64 integer, parameter :: cohortname_strlen = 64 integer, parameter :: line_strlen = 512 integer, parameter :: path_strlen = 256 @@ -142,10 +145,10 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) integer, allocatable :: inv_format_list(:) ! list of format specs character(len=path_strlen), allocatable :: inv_css_list(:) ! list of css file names character(len=path_strlen), allocatable :: inv_pss_list(:) ! list of pss file names - + real(r8), allocatable :: inv_lat_list(:) ! list of lat coords real(r8), allocatable :: inv_lon_list(:) ! list of lon coords - integer :: invsite ! index of inventory site + integer :: invsite ! index of inventory site ! closest to actual site integer :: el ! loop counter for number of elements character(len=patchname_strlen) :: patch_name ! patch ID string in the file @@ -159,7 +162,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! ------------------------------------------------------------------------------------------ sitelist_file_unit = shr_file_getUnit() - + inquire(file=trim(hlm_inventory_ctrl_file),exist=lexist,opened=lopen) if( .not.lexist ) then ! The inventory file list DNE @@ -270,13 +273,13 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! This call doesn't do much asside from initializing the patch with ! nominal values, NaNs, zero's and allocating some vectors. We should - ! be able to get the following values from the patch files. But on + ! be able to get the following values from the patch files. But on ! the patch creation step, we don't have that information. age_init = 0.0_r8 - area_init = 0.0_r8 + area_init = 0.0_r8 - call create_patch(sites(s), newpatch, age_init, area_init, primaryforest ) + call create_patch(sites(s), newpatch, age_init, area_init, primaryforest, fates_unset_int ) if( inv_format_list(invsite) == 1 ) then @@ -352,7 +355,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) currentPatch => currentpatch%older enddo end if - + ! OPEN THE CSS FILE ! --------------------------------------------------------------------------------------- css_file_unit = shr_file_getUnit() @@ -364,7 +367,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! Read in each cohort line. Each line is associated with a patch from the PSS ! file via a patch name identification string. We pass the whole site pointer ! to this routine, because inside the routine we identify the patch by making - ! comparisons with patch_name_vec and identifying the patch pointer + ! comparisons with patch_name_vec and identifying the patch pointer ! from patch_pointer_vec invcohortloop: do @@ -414,7 +417,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! first keep track of the next patch in the old (unsorted) linked list next_in_unsorted_patch_list => head_of_unsorted_patch_list%older - + ! check the two end-cases ! Youngest Patch @@ -462,7 +465,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) head_of_unsorted_patch_list => next_in_unsorted_patch_list end do endif - + ! Report Basal Area (as a check on if things were read in) ! ------------------------------------------------------------------------------ basal_area_pref = 0.0_r8 @@ -491,7 +494,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) do while(associated(currentpatch)) currentpatch%patchno = ipa ipa=ipa+1 - + ! Perform Cohort Fusion call fuse_cohorts(sites(s), currentpatch,bc_in(s)) call sort_cohorts(currentpatch) @@ -511,7 +514,7 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) ! Fuse patches ! ---------------------------------------------------------------------------------------- - call fuse_patches(sites(s), bc_in(s) ) + call fuse_patches(sites(s), bc_in(s) ) ! Report Basal Area (as a check on if things were read in) ! ---------------------------------------------------------------------------------------- @@ -526,13 +529,13 @@ subroutine initialize_sites_by_inventory(nsites,sites,bc_in) end do currentPatch => currentpatch%older enddo - + write(fates_log(),*) '-------------------------------------------------------' write(fates_log(),*) 'Basal Area from inventory, AFTER fusion' write(fates_log(),*) 'Lat: ',sites(s)%lat,' Lon: ',sites(s)%lon write(fates_log(),*) basal_area_postf,' [m2/ha]' write(fates_log(),*) '-------------------------------------------------------' - + ! If this is flagged as true, the post-fusion inventory will be written to file ! in the run directory. if(do_inventory_out)then @@ -599,10 +602,10 @@ subroutine assess_inventory_sites(sitelist_file_unit,nsites, inv_format_list, & ! ! ! type integer We will accomodate different file format with different - ! field values as the need arises. format 1 will read in - ! datasets via "set_inventory_edpatch_type1()", + ! field values as the need arises. format 1 will read in + ! datasets via "set_inventory_edpatch_type1()", ! "set_inventory_edcohort_type1()" - ! + ! ! latitude float The geographic latitude coordinate of the site ! longitude float The geogarphic longitude coordinate of the site ! pss-name string The full path to the patch descriptor file (PSS) @@ -719,7 +722,7 @@ subroutine set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name ! This subroutine reads in a line of an inventory patch file (pss) ! And populates a new patch with that information. ! This routine specifically reads PSS files that are "Type 1" formatted - ! + ! ! The file is formatted text, which contains 1 header line to label columns ! and then 1 line for each patch containing the following fields: ! @@ -812,14 +815,14 @@ subroutine set_inventory_edpatch_type1(newpatch,pss_file_unit,ipa,ios,patch_name do el=1,num_elements litt => newpatch%litter(el) - + call litt%InitConditions(init_leaf_fines=0._r8, & init_root_fines=0._r8, & init_ag_cwd=0._r8, & init_bg_cwd=0._r8, & init_seed=0._r8, & init_seed_germ=0._r8) - + end do return @@ -835,10 +838,10 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & ! This subroutine reads in a line of an inventory cohort file (css) ! And populates a new cohort with that information. ! This routine specifically reads CSS files that are "Type 1" formatted - ! + ! ! The file formatted text, which contains 1 header line to label columns ! and then 1 line for each cohort containing the following fields: - ! + ! ! FILE FORMAT: ! time (year) year of measurement ! patch (string) patch id string associated with this cohort @@ -873,7 +876,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & type(pp_array), intent(in) :: patch_pointer_vec(npatches) character(len=patchname_strlen), intent(in) :: patch_name_vec(npatches) integer,intent(out) :: ios ! Return flag - + ! Locals class(prt_vartypes), pointer :: prt_obj real(r8) :: c_time ! Time patch was recorded @@ -924,7 +927,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & read(css_file_unit,fmt=*,iostat=ios) c_time, p_name, c_name, c_dbh, c_height, & c_pft, c_nplant, c_bdead, c_balive, c_avgRG - + if( debug_inv) then write(*,fmt=wr_fmt) & c_time, p_name, c_name, c_dbh, c_height, & @@ -972,7 +975,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & write(fates_log(), *) 'The inventory produced a cohort with <= 0 dbh' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + if (c_dbh > abnormal_large_dbh ) then write(fates_log(), *) 'inventory dbh: ', c_nplant write(fates_log(), *) 'The inventory produced a cohort with very large diameter [cm]' @@ -1010,7 +1013,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & ! special case, make an identical cohort for each PFT temp_cohort%pft = i_pft endif - + temp_cohort%n = c_nplant * cpatch%area / real(ncohorts_to_create,r8) temp_cohort%dbh = c_dbh @@ -1021,33 +1024,33 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & call bagw_allom(temp_cohort%dbh,temp_cohort%pft,c_agw) ! Calculate coarse root biomass from allometry call bbgw_allom(temp_cohort%dbh,temp_cohort%pft,c_bgw) - + ! Calculate the leaf biomass (calculates a maximum first, then applies canopy trim ! and sla scaling factors) call bleaf(temp_cohort%dbh,temp_cohort%pft,temp_cohort%canopy_trim,c_leaf) - + ! Calculate fine root biomass call bfineroot(temp_cohort%dbh,temp_cohort%pft,temp_cohort%canopy_trim,c_fnrt) - + ! Calculate sapwood biomass call bsap_allom(temp_cohort%dbh,temp_cohort%pft,temp_cohort%canopy_trim, a_sapw, c_sapw) - + call bdead_allom( c_agw, c_bgw, c_sapw, temp_cohort%pft, c_struct ) - + call bstore_allom(temp_cohort%dbh, temp_cohort%pft, temp_cohort%canopy_trim, c_store) - + temp_cohort%laimemory = 0._r8 temp_cohort%sapwmemory = 0._r8 - temp_cohort%structmemory = 0._r8 + temp_cohort%structmemory = 0._r8 cstatus = leaves_on - - stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) + + stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) if( prt_params%season_decid(temp_cohort%pft) == itrue .and. & any(csite%cstatus == [phen_cstat_nevercold,phen_cstat_iscold])) then temp_cohort%laimemory = c_leaf temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction + temp_cohort%structmemory = c_struct * stem_drop_fraction c_leaf = 0._r8 c_sapw = (1._r8 - stem_drop_fraction) * c_sapw c_struct = (1._r8 - stem_drop_fraction) * c_struct @@ -1058,16 +1061,21 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & any(csite%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then temp_cohort%laimemory = c_leaf temp_cohort%sapwmemory = c_sapw * stem_drop_fraction - temp_cohort%structmemory = c_struct * stem_drop_fraction + temp_cohort%structmemory = c_struct * stem_drop_fraction c_leaf = 0._r8 c_sapw = (1._r8 - stem_drop_fraction) * c_sapw - c_struct = (1._r8 - stem_drop_fraction) * c_struct + c_struct = (1._r8 - stem_drop_fraction) * c_struct cstatus = leaves_off endif - + prt_obj => null() call InitPRTObject(prt_obj) + ! (Keeping as an example) + ! Allocate running mean functions + !allocate(temp_cohort%tveg_lpa) + !call temp_cohort%tveg_lpa%InitRMean(ema_lpa,init_value=cpatch%tveg_lpa%GetMean()) + do el = 1,num_elements element_id = element_list(el) @@ -1086,21 +1094,49 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & case(nitrogen_element) - m_struct = c_struct*prt_params%nitr_stoich_p1(temp_cohort%pft,struct_organ) - m_leaf = c_leaf*prt_params%nitr_stoich_p1(temp_cohort%pft,leaf_organ) - m_fnrt = c_fnrt*prt_params%nitr_stoich_p1(temp_cohort%pft,fnrt_organ) - m_sapw = c_sapw*prt_params%nitr_stoich_p1(temp_cohort%pft,sapw_organ) - m_store = c_store*prt_params%nitr_stoich_p1(temp_cohort%pft,store_organ) + ! For inventory runs, initialize nutrient contents half way between max and min stoichiometries + m_struct = c_struct * 0.5_r8 * & + (prt_params%nitr_stoich_p1(temp_cohort%pft,prt_params%organ_param_id(struct_organ)) + & + prt_params%nitr_stoich_p2(temp_cohort%pft,prt_params%organ_param_id(struct_organ))) + + m_leaf = c_leaf * 0.5_r8 * & + (prt_params%nitr_stoich_p1(temp_cohort%pft,prt_params%organ_param_id(leaf_organ)) + & + prt_params%nitr_stoich_p2(temp_cohort%pft,prt_params%organ_param_id(leaf_organ))) + + m_fnrt = c_fnrt * 0.5_r8 * & + (prt_params%nitr_stoich_p1(temp_cohort%pft,prt_params%organ_param_id(fnrt_organ)) + & + prt_params%nitr_stoich_p2(temp_cohort%pft,prt_params%organ_param_id(fnrt_organ))) + + m_sapw = c_sapw * 0.5_r8 * & + (prt_params%nitr_stoich_p1(temp_cohort%pft,prt_params%organ_param_id(sapw_organ)) + & + prt_params%nitr_stoich_p2(temp_cohort%pft,prt_params%organ_param_id(sapw_organ))) + m_repro = 0._r8 + m_store = StorageNutrientTarget(temp_cohort%pft, element_id, m_leaf, m_fnrt, m_sapw, m_struct) + case(phosphorus_element) - m_struct = c_struct*prt_params%phos_stoich_p1(temp_cohort%pft,struct_organ) - m_leaf = c_leaf*prt_params%phos_stoich_p1(temp_cohort%pft,leaf_organ) - m_fnrt = c_fnrt*prt_params%phos_stoich_p1(temp_cohort%pft,fnrt_organ) - m_sapw = c_sapw*prt_params%phos_stoich_p1(temp_cohort%pft,sapw_organ) - m_store = c_store*prt_params%phos_stoich_p1(temp_cohort%pft,store_organ) + m_struct = c_struct * 0.5_r8 * & + (prt_params%phos_stoich_p1(temp_cohort%pft,prt_params%organ_param_id(struct_organ)) + & + prt_params%phos_stoich_p2(temp_cohort%pft,prt_params%organ_param_id(struct_organ))) + + m_leaf = c_leaf * 0.5_r8 * & + (prt_params%phos_stoich_p1(temp_cohort%pft,prt_params%organ_param_id(leaf_organ)) + & + prt_params%phos_stoich_p2(temp_cohort%pft,prt_params%organ_param_id(leaf_organ))) + + m_fnrt = c_fnrt * 0.5_r8 * & + (prt_params%phos_stoich_p1(temp_cohort%pft,prt_params%organ_param_id(fnrt_organ)) + & + prt_params%phos_stoich_p2(temp_cohort%pft,prt_params%organ_param_id(fnrt_organ))) + + m_sapw = c_sapw * 0.5_r8 * & + (prt_params%phos_stoich_p1(temp_cohort%pft,prt_params%organ_param_id(sapw_organ)) + & + prt_params%phos_stoich_p2(temp_cohort%pft,prt_params%organ_param_id(sapw_organ))) + m_repro = 0._r8 + + m_store = StorageNutrientTarget(temp_cohort%pft, element_id, m_leaf, m_fnrt, m_sapw, m_struct) + end select select case(hlm_parteh_mode) @@ -1132,7 +1168,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & call create_cohort(csite, cpatch, temp_cohort%pft, temp_cohort%n, temp_cohort%hite, & temp_cohort%coage, temp_cohort%dbh, & prt_obj, temp_cohort%laimemory,temp_cohort%sapwmemory, temp_cohort%structmemory, & - cstatus, rstatus, temp_cohort%canopy_trim, & + cstatus, rstatus, temp_cohort%canopy_trim,temp_cohort%c_area, & 1, csite%spread, bc_in) deallocate(temp_cohort) ! get rid of temporary cohort @@ -1157,14 +1193,14 @@ subroutine write_inventory_type1(currentSite) use shr_file_mod, only : shr_file_getUnit use shr_file_mod, only : shr_file_freeUnit - + ! Arguments type(ed_site_type), target :: currentSite - + ! Locals type(ed_patch_type), pointer :: currentpatch type(ed_cohort_type), pointer :: currentcohort - + character(len=128) :: pss_name_out ! output file string character(len=128) :: css_name_out ! output file string integer :: pss_file_out @@ -1182,7 +1218,7 @@ subroutine write_inventory_type1(currentSite) ilat_dec = int(100000*(abs(currentSite%lat) - real(ilat_int,r8))) ilon_int = abs(int(currentSite%lon)) ilon_dec = int(100000*(abs(currentSite%lon) - real(ilon_int,r8))) - + if(currentSite%lat>=0._r8)then ilat_sign = 'N' else @@ -1201,23 +1237,23 @@ subroutine write_inventory_type1(currentSite) pss_file_out = shr_file_getUnit() css_file_out = shr_file_getUnit() - + open(unit=pss_file_out,file=trim(pss_name_out), status='UNKNOWN',action='WRITE',form='FORMATTED') open(unit=css_file_out,file=trim(css_name_out), status='UNKNOWN',action='WRITE',form='FORMATTED') - + write(pss_file_out,*) 'time patch trk age area water fsc stsc stsl ssc psc msn fsn' write(css_file_out,*) 'time patch cohort dbh hite pft nplant bdead alive Avgrg' - + ipatch=0 currentpatch => currentSite%youngest_patch do while(associated(currentpatch)) ipatch=ipatch+1 - + write(patch_str,'(A7,i4.4,A)') '' - + write(pss_file_out,*) '0000 ',trim(patch_str),' 2 ',currentPatch%age,currentPatch%area/AREA, & '0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000 0.0000' - + icohort=0 currentcohort => currentpatch%tallest do while(associated(currentcohort)) @@ -1225,18 +1261,18 @@ subroutine write_inventory_type1(currentSite) write(cohort_str,'(A7,i4.4,A)') '' write(css_file_out,*) '0000 ',trim(patch_str),' ',trim(cohort_str), & currentCohort%dbh,0.0,currentCohort%pft,currentCohort%n/currentPatch%area,0.0,0.0,0.0 - + currentcohort => currentcohort%shorter end do currentPatch => currentpatch%older enddo - + close(css_file_out) close(pss_file_out) - + call shr_file_freeUnit(css_file_out) call shr_file_freeUnit(pss_file_out) - + end subroutine write_inventory_type1 end module FatesInventoryInitMod diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 index ebaad3fa7c..f69d4ef5bf 100644 --- a/main/FatesParametersInterface.F90 +++ b/main/FatesParametersInterface.F90 @@ -35,6 +35,7 @@ module FatesParametersInterface character(len=*), parameter, public :: dimension_name_history_age_bins = 'fates_history_age_bins' character(len=*), parameter, public :: dimension_name_history_height_bins = 'fates_history_height_bins' character(len=*), parameter, public :: dimension_name_history_coage_bins = 'fates_history_coage_bins' + character(len=*), parameter, public :: dimension_name_hlm_pftno = 'fates_hlm_pftno' ! Dimensions in the host namespace: character(len=*), parameter, public :: dimension_name_host_allpfts = 'allpfts' diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index bfdc9d4fb3..0605767cd6 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -7,7 +7,7 @@ module FatesRestartInterfaceMod use FatesConstantsMod, only : fates_long_string_length use FatesConstantsMod, only : itrue use FatesConstantsMod, only : ifalse - use FatesConstantsMod, only : fates_unset_r8 + use FatesConstantsMod, only : fates_unset_r8, fates_unset_int use FatesConstantsMod, only : primaryforest use FatesGlobals, only : fates_log use FatesGlobals, only : endrun => fates_endrun @@ -15,9 +15,10 @@ module FatesRestartInterfaceMod use FatesIOVariableKindMod, only : fates_io_variable_kind_type use FatesRestartVariableMod, only : fates_restart_variable_type use FatesInterfaceTypesMod, only : nlevcoage - use FatesInterfaceTypesMod, only : bc_in_type + use FatesInterfaceTypesMod, only : bc_in_type use FatesInterfaceTypesMod, only : bc_out_type use FatesInterfaceTypesMod, only : hlm_use_planthydro + use FatesInterfaceTypesMod, only : hlm_use_sp use FatesInterfaceTypesMod, only : fates_maxElementsPerSite use EDCohortDynamicsMod, only : UpdateCohortBioPhysRates use FatesHydraulicsMemMod, only : nshell @@ -35,9 +36,11 @@ module FatesRestartInterfaceMod use FatesLitterMod, only : litter_type use FatesLitterMod, only : ncwd use FatesLitterMod, only : ndcmpy + use EDTypesMod, only : nfsc use PRTGenericMod, only : prt_global use PRTGenericMod, only : num_elements - + use FatesRunningMeanMod, only : rmean_type + use FatesRunningMeanMod, only : ema_lpa ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg @@ -71,11 +74,11 @@ module FatesRestartInterfaceMod ! ls: layer sublayer dimension (fine discretization of upper,lower) ! wm: the number of memory slots for water (currently 10) ! ------------------------------------------------------------- - - + + ! Indices to the restart variable object - integer :: ir_npatch_si + integer :: ir_npatch_si integer :: ir_cd_status_si integer :: ir_dd_status_si integer :: ir_nchill_days_si @@ -114,8 +117,13 @@ module FatesRestartInterfaceMod integer :: ir_frmort_co integer :: ir_smort_co integer :: ir_asmort_co + integer :: ir_c_area_co + integer :: ir_treelai_co + integer :: ir_treesai_co + integer :: ir_canopy_layer_tlai_pa - integer :: ir_daily_n_uptake_co + integer :: ir_daily_nh4_uptake_co + integer :: ir_daily_no3_uptake_co integer :: ir_daily_p_uptake_co integer :: ir_daily_c_efflux_co integer :: ir_daily_n_efflux_co @@ -124,19 +132,26 @@ module FatesRestartInterfaceMod integer :: ir_daily_p_demand_co integer :: ir_daily_n_need_co integer :: ir_daily_p_need_co - + !Logging integer :: ir_lmort_direct_co integer :: ir_lmort_collateral_co integer :: ir_lmort_infra_co ! Radiation + integer :: ir_fcansno_pa integer :: ir_solar_zenith_flag_pa integer :: ir_solar_zenith_angle_pa integer :: ir_gnd_alb_dif_pasb integer :: ir_gnd_alb_dir_pasb + ! Running Means + integer :: ir_tveg24_pa + integer :: ir_tveglpa_pa + ! (Keeping as an example) + !!integer :: ir_tveglpa_co + integer :: ir_ddbhdt_co integer :: ir_resp_tstep_co integer :: ir_pft_co @@ -158,6 +173,7 @@ module FatesRestartInterfaceMod integer :: ir_area_pa integer :: ir_agesinceanthrodist_pa integer :: ir_patchdistturbcat_pa + integer :: ir_nocomp_pft_label_pa ! Litter Fluxes (needed to restart ! with nutrient dynamics on, restarting @@ -167,6 +183,8 @@ module FatesRestartInterfaceMod integer :: ir_lfines_frag_litt integer :: ir_rfines_frag_litt + integer :: ir_scorch_ht_pa_pft + integer :: ir_litter_moisture_pa_nfsc ! Site level integer :: ir_watermem_siwm @@ -206,7 +224,7 @@ module FatesRestartInterfaceMod ! Hydraulic indices integer :: ir_hydro_th_ag_covec integer :: ir_hydro_th_troot - integer :: ir_hydro_th_aroot_covec + integer :: ir_hydro_th_aroot_covec integer :: ir_hydro_liqvol_shell_si integer :: ir_hydro_recruit_si integer :: ir_hydro_dead_si @@ -220,12 +238,12 @@ module FatesRestartInterfaceMod ! integer constants for storing logical data integer, parameter, public :: old_cohort = 0 - integer, parameter, public :: new_cohort = 1 + integer, parameter, public :: new_cohort = 1 real(r8), parameter, public :: flushinvalid = -9999.0 real(r8), parameter, public :: flushzero = 0.0 real(r8), parameter, public :: flushone = 1.0 - + ! Local debug flag logical, parameter, public :: debug=.false. @@ -252,20 +270,20 @@ module FatesRestartInterfaceMod ! Instanteate one registry of the different dimension/kinds (dk) ! All output variables will have a pointer to one of these dk's type(fates_io_variable_kind_type) :: dim_kinds(fates_restart_num_dim_kinds) - + ! This is a structure that explains where FATES patch boundaries ! on each thread point to in the host IO array, this structure is ! allocated by number of threads. This could be dynamically ! allocated, but is unlikely to change...? ! Note: history io also instanteates fates_io_dimension_type type(fates_io_dimension_type) :: dim_bounds(fates_restart_num_dimensions) - + type(restart_map_type), pointer :: restart_map(:) integer, private :: cohort_index_, column_index_ contains - + ! public functions procedure :: Init procedure :: SetThreadBoundsEach @@ -278,7 +296,7 @@ module FatesRestartInterfaceMod procedure :: create_patchcohort_structure procedure :: get_restart_vectors procedure :: update_3dpatch_radiation - + ! private work functions procedure, private :: init_dim_kinds_maps procedure, private :: set_dim_indices @@ -291,18 +309,20 @@ module FatesRestartInterfaceMod procedure, private :: GetCohortRealVector procedure, private :: SetCohortRealVector procedure, private :: RegisterCohortVector - + procedure, private :: DefineRMeanRestartVar + procedure, private :: GetRMeanRestartVar + procedure, private :: SetRMeanRestartVar end type fates_restart_interface_type - + contains ! ===================================================================================== - + subroutine Init(this, num_threads, fates_bounds) - + use FatesIODimensionsMod, only : fates_bounds_type, column, cohort implicit none @@ -327,13 +347,13 @@ subroutine Init(this, num_threads, fates_bounds) ! Allocate the mapping between FATES indices and the IO indices allocate(this%restart_map(num_threads)) - - end subroutine Init + + end subroutine Init ! ====================================================================== subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) - + use FatesIODimensionsMod, only : fates_bounds_type implicit none @@ -344,25 +364,25 @@ subroutine SetThreadBoundsEach(this, thread_index, thread_bounds) type(fates_bounds_type), intent(in) :: thread_bounds integer :: index - + index = this%cohort_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%cohort_begin, thread_bounds%cohort_end) - + index = this%column_index() call this%dim_bounds(index)%SetThreadBounds(thread_index, & thread_bounds%column_begin, thread_bounds%column_end) - + end subroutine SetThreadBoundsEach ! =================================================================================== subroutine assemble_restart_output_types(this) - + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int implicit none - + class(fates_restart_interface_type), intent(inout) :: this call this%init_dim_kinds_maps() @@ -376,7 +396,7 @@ subroutine assemble_restart_output_types(this) end subroutine assemble_restart_output_types ! =================================================================================== - + subroutine set_dim_indices(this, dk_name, idim, dim_index) use FatesIOVariableKindMod , only : iotype_index @@ -425,13 +445,13 @@ subroutine set_cohort_index(this, index) integer, intent(in) :: index this%cohort_index_ = index end subroutine set_cohort_index - + integer function cohort_index(this) implicit none class(fates_restart_interface_type), intent(in) :: this cohort_index = this%cohort_index_ end function cohort_index - + ! ======================================================================= subroutine set_column_index(this, index) @@ -440,17 +460,17 @@ subroutine set_column_index(this, index) integer, intent(in) :: index this%column_index_ = index end subroutine set_column_index - + integer function column_index(this) implicit none class(fates_restart_interface_type), intent(in) :: this column_index = this%column_index_ end function column_index - + ! ======================================================================= subroutine init_dim_kinds_maps(this) - + ! ---------------------------------------------------------------------------------- ! This subroutine simply initializes the structures that define the different ! array and type formats for different IO variables @@ -465,9 +485,9 @@ subroutine init_dim_kinds_maps(this) ! ! ---------------------------------------------------------------------------------- use FatesIOVariableKindMod, only : site_r8, site_int, cohort_r8, cohort_int - + implicit none - + ! Arguments class(fates_restart_interface_type), intent(inout) :: this @@ -496,17 +516,17 @@ end subroutine init_dim_kinds_maps ! ==================================================================================== integer function num_restart_vars(this) - + implicit none class(fates_restart_interface_type), intent(in) :: this num_restart_vars = this%num_restart_vars_ - + end function num_restart_vars - + ! ==================================================================================== - + subroutine initialize_restart_vars(this) implicit none @@ -519,16 +539,16 @@ subroutine initialize_restart_vars(this) ! Allocate the list of restart output variable objects allocate(this%rvars(this%num_restart_vars())) - + ! construct the object that defines all of the IO variables call this%define_restart_vars(initialize_variables=.true.) - + end subroutine initialize_restart_vars ! ====================================================================================== subroutine flush_rvars(this,nc) - + class(fates_restart_interface_type) :: this integer,intent(in) :: nc @@ -541,17 +561,17 @@ subroutine flush_rvars(this,nc) call rvar%Flush(nc, this%dim_bounds, this%dim_kinds) end associate end do - + end subroutine flush_rvars - + ! ==================================================================================== - + subroutine define_restart_vars(this, initialize_variables) - + ! --------------------------------------------------------------------------------- - ! + ! ! REGISTRY OF RESTART OUTPUT VARIABLES ! ! Please add any restart variables to this registry. This registry will handle @@ -559,19 +579,19 @@ subroutine define_restart_vars(this, initialize_variables) ! variables. Note that restarts are only using 1D vectors in ALM and CLM. If you ! have a multi-dimensional variable that is below the cohort scale, then pack ! that variable into a cohort-sized output array by giving it a vtype "cohort_r8" - ! or "cohort_int". + ! or "cohort_int". ! ! Unlike history variables, restarts flush to zero. ! --------------------------------------------------------------------------------- - + use FatesIOVariableKindMod, only : site_r8, site_int, cohort_int, cohort_r8 implicit none - + class(fates_restart_interface_type), intent(inout) :: this logical, intent(in) :: initialize_variables ! are we 'count'ing or 'initializ'ing? integer :: ivar - - + + ivar=0 ! ----------------------------------------------------------------------------------- @@ -617,7 +637,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_acc_nesterov_id', vtype=site_r8, & long_name='a nesterov index accumulator', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_acc_ni_si ) - + call this%set_restart_var(vname='fates_gdd_site', vtype=site_r8, & long_name='growing degree days at each site', units='degC days', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_gdd_si ) @@ -644,10 +664,14 @@ subroutine define_restart_vars(this, initialize_variables) long_name='the number of cohorts per patch', units='unitless', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_ncohort_pa ) + call this%set_restart_var(vname='fates_fcansno_pa', vtype=cohort_r8, & + long_name='Fraction of canopy covered in snow', units='unitless', flushval = flushinvalid, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fcansno_pa ) + call this%set_restart_var(vname='fates_solar_zenith_flag_pa', vtype=cohort_int, & long_name='switch specifying if zenith is positive', units='unitless', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_solar_zenith_flag_pa ) - + call this%set_restart_var(vname='fates_solar_zenith_angle_pa', vtype=cohort_r8, & long_name='the angle of the solar zenith for each patch', units='radians', flushval = flushinvalid, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_solar_zenith_angle_pa ) @@ -684,7 +708,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_coage', vtype=cohort_r8, & long_name='ed cohort - age in days', units='days', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_coage_co ) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_coage_co ) call this%set_restart_var(vname='fates_height', vtype=cohort_r8, & long_name='ed cohort - plant height', units='m', flushval = flushzero, & @@ -699,12 +723,12 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - target sapwood biomass set from prev year', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_sapwmemory_co ) - + call this%set_restart_var(vname='fates_structmemory', vtype=cohort_r8, & long_name='ed cohort - target structural biomass set from prev year', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_structmemory_co ) - + call this%set_restart_var(vname='fates_nplant', vtype=cohort_r8, & long_name='ed cohort - number of plants in the cohort', & units='/patch', flushval = flushzero, & @@ -744,7 +768,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - maintenance respiration deficit', & units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_resp_m_def_co ) - + call this%set_restart_var(vname='fates_bmort', vtype=cohort_r8, & long_name='ed cohort - background mortality rate', & units='/year', flushval = flushzero, & @@ -760,10 +784,15 @@ subroutine define_restart_vars(this, initialize_variables) units='/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cmort_co ) - call this%set_restart_var(vname='fates_daily_n_uptake', vtype=cohort_r8, & - long_name='fates cohort- daily nitrogen uptake', & + call this%set_restart_var(vname='fates_daily_nh4_uptake', vtype=cohort_r8, & + long_name='fates cohort- daily ammonium [NH4] uptake', & units='kg/plant/day', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_uptake_co ) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_nh4_uptake_co ) + + call this%set_restart_var(vname='fates_daily_no3_uptake', vtype=cohort_r8, & + long_name='fates cohort- daily ammonium [NO3] uptake', & + units='kg/plant/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_no3_uptake_co ) call this%set_restart_var(vname='fates_daily_p_uptake', vtype=cohort_r8, & long_name='fates cohort- daily phosphorus uptake', & @@ -779,7 +808,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates cohort- daily nitrogen efflux', & units='kg/plant/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_efflux_co ) - + call this%set_restart_var(vname='fates_daily_p_efflux', vtype=cohort_r8, & long_name='fates cohort- daily phosphorus efflux', & units='kg/plant/day', flushval = flushzero, & @@ -804,7 +833,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates cohort- daily nitrogen need', & units='kgN/plant/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_need_co ) - + call this%set_restart_var(vname='fates_frmort', vtype=cohort_r8, & long_name='ed cohort - freezing mortality rate', & units='/year', flushval = flushzero, & @@ -817,7 +846,7 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_asmort', vtype=cohort_r8, & long_name='ed cohort - age senescence mortality rate', & - units = '/year', flushval = flushzero, & + units = '/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_asmort_co ) call this%set_restart_var(vname='fates_lmort_direct', vtype=cohort_r8, & @@ -828,12 +857,12 @@ subroutine define_restart_vars(this, initialize_variables) call this%set_restart_var(vname='fates_lmort_collateral', vtype=cohort_r8, & long_name='ed cohort - collateral mortality rate', & units='%/event', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_collateral_co ) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_collateral_co ) + call this%set_restart_var(vname='fates_lmort_in', vtype=cohort_r8, & long_name='ed cohort - mechanical mortality rate', & units='%/event', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_infra_co ) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lmort_infra_co ) call this%set_restart_var(vname='fates_ddbhdt', vtype=cohort_r8, & long_name='ed cohort - differential: ddbh/dt', & @@ -900,10 +929,21 @@ subroutine define_restart_vars(this, initialize_variables) long_name='Disturbance label of patch', units='yr', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_patchdistturbcat_pa ) + call this%set_restart_var(vname='fates_nocomp_pft_label', vtype=cohort_int, & + long_name='PFT label of patch in nocomp mode', units='none', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_nocomp_pft_label_pa ) + call this%set_restart_var(vname='fates_area', vtype=cohort_r8, & long_name='are of the ED patch', units='m2', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_area_pa ) + call this%set_restart_var(vname='fates_scorch_ht_pa_pft', vtype=cohort_r8, & + long_name='scorch height', units='m', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_scorch_ht_pa_pft) + + call this%set_restart_var(vname='fates_litter_moisture_pa_nfsc', vtype=cohort_r8, & + long_name='scorch height', units='m', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_litter_moisture_pa_nfsc) ! Site Level Diagnostics over multiple nutrients @@ -913,23 +953,23 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_ag_cwd', vtype=cohort_r8, & long_name_base='above ground CWD', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_litt) call this%RegisterCohortVector(symbol_base='fates_bg_cwd', vtype=cohort_r8, & long_name_base='below ground CWD', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_litt) call this%RegisterCohortVector(symbol_base='fates_leaf_fines', vtype=cohort_r8, & long_name_base='above ground leaf litter', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_litt) call this%RegisterCohortVector(symbol_base='fates_fnrt_fines', vtype=cohort_r8, & long_name_base='fine root litter', & units='kg/m2', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fnrt_litt) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_fnrt_litt) + call this%RegisterCohortVector(symbol_base='fates_seed', vtype=cohort_r8, & long_name_base='seed bank (non-germinated)', & units='kg/m2', veclength=num_elements, flushval = flushzero, & @@ -941,31 +981,31 @@ subroutine define_restart_vars(this, initialize_variables) hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seedgerm_litt) - call this%RegisterCohortVector(symbol_base='fates_seed_decay', vtype=cohort_r8, & - long_name_base='seed bank (non-germinated)', & + call this%RegisterCohortVector(symbol_base='fates_seed_frag', vtype=cohort_r8, & + long_name_base='seed bank fragmentation flux (non-germinated)', & units='kg/m2', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seed_decay_litt) - call this%RegisterCohortVector(symbol_base='fates_seedgerm_decay', vtype=cohort_r8, & - long_name_base='seed bank (germinated)', & + call this%RegisterCohortVector(symbol_base='fates_seedgerm_frag', vtype=cohort_r8, & + long_name_base='seed bank fragmentation flux (germinated)', & units='kg/m2', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seedgerm_decay_litt) - + call this%RegisterCohortVector(symbol_base='fates_ag_cwd_frag', vtype=cohort_r8, & long_name_base='above ground CWD frag flux', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_frag_litt) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_frag_litt) call this%RegisterCohortVector(symbol_base='fates_bg_cwd_frag', vtype=cohort_r8, & long_name_base='below ground CWD frag flux', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_frag_litt) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_frag_litt) + call this%RegisterCohortVector(symbol_base='fates_lfines_frag', vtype=cohort_r8, & long_name_base='frag flux from leaf fines', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lfines_frag_litt) - + call this%RegisterCohortVector(symbol_base='fates_rfines_frag', vtype=cohort_r8, & long_name_base='frag flux from froot fines', & units='kg/m2/day', veclength=num_elements, flushval = flushzero, & @@ -1004,23 +1044,44 @@ subroutine define_restart_vars(this, initialize_variables) units='kg/day/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_uptake_flxdg) - + ! Site level Mass Balance State Accounting call this%RegisterCohortVector(symbol_base='fates_oldstock', vtype=site_r8, & long_name_base='Previous total mass of all fates state variables', & units='kg/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_oldstock_mbal) - + call this%RegisterCohortVector(symbol_base='fates_errfates', vtype=site_r8, & long_name_base='Previous total mass of error fates state variables', & units='kg/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_errfates_mbal) - - + + + ! Only register satellite phenology related restart variables if it is turned on! + + if(hlm_use_sp .eq. itrue) then + call this%set_restart_var(vname='fates_cohort_area', vtype=cohort_r8, & + long_name='area of the fates cohort', & + units='m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_c_area_co ) + call this%set_restart_var(vname='fates_cohort_treelai', vtype=cohort_r8, & + long_name='leaf area index of fates cohort', & + units='m2/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_treelai_co ) + call this%set_restart_var(vname='fates_cohort_treesai', vtype=cohort_r8, & + long_name='stem area index of fates cohort', & + units='m2/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_treesai_co ) + call this%set_restart_var(vname='fates_canopy_layer_tlai_pa', vtype=cohort_r8, & + long_name='total patch level leaf area index of each fates canopy layer', & + units='m2/m2', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_layer_tlai_pa ) + end if + ! Only register hydraulics restart variables if it is turned on! - + if(hlm_use_planthydro==itrue) then if ( fates_maxElementsPerSite < (nshell * nlevsoi_hyd_max) ) then @@ -1038,17 +1099,17 @@ subroutine define_restart_vars(this, initialize_variables) call this%RegisterCohortVector(symbol_base='fates_hydro_th_ag', vtype=cohort_r8, & long_name_base='water in aboveground compartments', & units='kg/plant', veclength=n_hypool_ag, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_ag_covec) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_ag_covec) + call this%RegisterCohortVector(symbol_base='fates_hydro_th_troot', vtype=cohort_r8, & long_name_base='water in transporting roots', & units='kg/plant', veclength=n_hypool_troot, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_troot) - + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_troot) + call this%RegisterCohortVector(symbol_base='fates_hydro_th_aroot', vtype=cohort_r8, & long_name_base='water in absorbing roots', & units='kg/plant', veclength=nlevsoi_hyd_max, flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_aroot_covec) + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_th_aroot_covec) ! Site-level volumentric liquid water content (shell x layer) call this%set_restart_var(vname='fates_hydro_liqvol_shell', vtype=cohort_r8, & @@ -1061,13 +1122,13 @@ subroutine define_restart_vars(this, initialize_variables) long_name='Site level water mass used for new recruits', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_recruit_si ) - + ! Site-level water bound in dead plants call this%set_restart_var(vname='fates_hydro_dead_h2o', vtype=site_r8, & long_name='Site level water bound in dead plants', & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_dead_si ) - + ! Site-level water balance error due to growth/turnover call this%set_restart_var(vname='fates_hydro_growturn_err', vtype=site_r8, & long_name='Site level error for hydraulics due to growth/turnover', & @@ -1085,7 +1146,7 @@ subroutine define_restart_vars(this, initialize_variables) units='kg/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_hydro_errh2o ) - + end if @@ -1102,7 +1163,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='last 10 days of 24-hour vegetation temperature, by site x day-index', & units='m3/m3', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_vegtempmem_sitm ) - + call this%set_restart_var(vname='fates_recrate', vtype=cohort_r8, & long_name='fates diagnostics on recruitment', & units='indiv/ha/day', flushval = flushzero, & @@ -1158,7 +1219,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='fates diag: rate of indivs moving via fusion', & units='indiv/ha/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_growflx_fusion_siscpf) - + call this%set_restart_var(vname='fates_demorate', vtype=cohort_r8, & long_name='fates diagnoatic rate of indivs demoted', & units='indiv/ha/day', flushval = flushzero, & @@ -1173,7 +1234,7 @@ subroutine define_restart_vars(this, initialize_variables) long_name='biomass of indivs killed due to impact mort', & units='kgC/ha/day', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_imortcflux_si) - + call this%set_restart_var(vname='fates_fmortcflux_canopy', vtype=site_r8, & long_name='fates diagnostic biomass of canopy fire', & units='gC/m2/sec', flushval = flushzero, & @@ -1205,26 +1266,118 @@ subroutine define_restart_vars(this, initialize_variables) hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_promcflux_si ) + call this%DefineRMeanRestartVar(vname='fates_tveg24patch',vtype=cohort_r8, & + long_name='24-hour patch veg temp', & + units='K', initialize=initialize_variables,ivar=ivar, index = ir_tveg24_pa) + call this%DefineRMeanRestartVar(vname='fates_tveglpapatch',vtype=cohort_r8, & + long_name='running average (EMA) of patch veg temp for photo acclim', & + units='K', initialize=initialize_variables,ivar=ivar, index = ir_tveglpa_pa) + + ! (Keeping as an example) + !call this%DefineRMeanRestartVar(vname='fates_tveglpacohort',vtype=cohort_r8, & + ! long_name='running average (EMA) of cohort veg temp for photo acclim', & + ! units='K', initialize=initialize_variables,ivar=ivar, index = ir_tveglpa_co) + ! Register all of the PRT states and fluxes ir_prt_base = ivar call this%DefinePRTRestartVars(initialize_variables,ivar) - - - + + + ! Must be last thing before return this%num_restart_vars_ = ivar - + end subroutine define_restart_vars - + ! ===================================================================================== + subroutine DefineRMeanRestartVar(this,vname,vtype,long_name,units,initialize,ivar,index) + + class(fates_restart_interface_type) :: this + character(len=*),intent(in) :: vname + character(len=*),intent(in) :: vtype + character(len=*),intent(in) :: long_name + character(len=*),intent(in) :: units + logical, intent(in) :: initialize + integer,intent(inout) :: ivar + integer,intent(inout) :: index + + integer :: dummy_index + + call this%set_restart_var(vname= trim(vname)//'_cmean', vtype=vtype, & + long_name=long_name//' current mean', & + units=units, flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize, ivar=ivar, index = index ) + + call this%set_restart_var(vname= trim(vname)//'_lmean', vtype=vtype, & + long_name=long_name//' latest mean', & + units=units, flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize, ivar=ivar, index = dummy_index ) + + call this%set_restart_var(vname= trim(vname)//'_cindex', vtype=vtype, & + long_name=long_name//' index', & + units='index', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize, ivar=ivar, index = dummy_index ) + + + return + end subroutine DefineRMeanRestartVar + + + ! ===================================================================================== + + subroutine GetRMeanRestartVar(this, rmean_var, ir_var_index, position_index) + + class(fates_restart_interface_type) , intent(inout) :: this + class(rmean_type), intent(inout) :: rmean_var + + integer,intent(in) :: ir_var_index + integer,intent(in) :: position_index + + integer :: i_pos ! vector position loop index + integer :: ir_pos_var ! global variable index + + + rmean_var%c_mean = this%rvars(ir_var_index)%r81d(position_index) + + rmean_var%l_mean = this%rvars(ir_var_index+1)%r81d(position_index) + + rmean_var%c_index = nint(this%rvars(ir_var_index+2)%r81d(position_index)) + + return + end subroutine GetRMeanRestartVar + + ! ======================================================================================= + + subroutine SetRMeanRestartVar(this, rmean_var, ir_var_index, position_index) + + class(fates_restart_interface_type) , intent(inout) :: this + class(rmean_type), intent(inout) :: rmean_var + + integer,intent(in) :: ir_var_index + integer,intent(in) :: position_index + + integer :: i_pos ! vector position loop index + integer :: ir_pos_var ! global variable index + + this%rvars(ir_var_index)%r81d(position_index) = rmean_var%c_mean + + this%rvars(ir_var_index+1)%r81d(position_index) = rmean_var%l_mean + + this%rvars(ir_var_index+2)%r81d(position_index) = real(rmean_var%c_index,r8) + + return + end subroutine SetRMeanRestartVar + + ! ===================================================================================== + subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! ---------------------------------------------------------------------------------- - ! PARTEH variables are objects. These objects + ! PARTEH variables are objects. These objects ! each are registered to have things like names units and symbols ! as part of that object. Thus, when defining, reading and writing restarts, ! instead of manually typing out each variable we want, we just loop through @@ -1251,7 +1404,7 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) class(fates_restart_interface_type) :: this logical, intent(in) :: initialize_variables integer,intent(inout) :: ivar ! global variable counter - + integer :: dummy_out ! dummy index for variable ! position in global file integer :: i_var ! loop counter for prt variables @@ -1267,12 +1420,12 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! The base symbol name symbol_base = prt_global%state_descriptor(i_var)%symbol - + ! The long name of the variable name_base = prt_global%state_descriptor(i_var)%longname do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos - + ! String describing the physical position of the variable write(pos_symbol, '(I3.3)') i_pos @@ -1290,7 +1443,7 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) + ivar=ivar, index = dummy_out ) ! Register the turnover flux variables ! ---------------------------------------------------------------------------- @@ -1300,19 +1453,19 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) ! The expanded long name of the variable long_name = trim(name_base)//', turnover, position:'//trim(pos_symbol) - + call this%set_restart_var(vname=trim(symbol), & vtype=cohort_r8, & long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) - + ivar=ivar, index = dummy_out ) + ! Register the net allocation flux variable ! ---------------------------------------------------------------------------- - + ! The symbol that is written to file symbol = trim(symbol_base)//'_net_'//trim(pos_symbol) @@ -1324,8 +1477,8 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) - + ivar=ivar, index = dummy_out ) + ! Register the burn flux variable @@ -1341,11 +1494,11 @@ subroutine DefinePRTRestartVars(this,initialize_variables,ivar) long_name=trim(long_name), & units='kg', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, & - ivar=ivar, index = dummy_out ) + ivar=ivar, index = dummy_out ) end do end do - + return end subroutine DefinePRTRestartVars @@ -1353,20 +1506,20 @@ end subroutine DefinePRTRestartVars subroutine RegisterCohortVector(this,symbol_base, vtype, long_name_base, & units, veclength, flushval, hlms, & - initialize, ivar, index) + initialize, ivar, index) + - ! The basic idea here is that instead of saving cohorts with vector data ! as long arrays in the restart file, we give each index of the vector ! its own variable. This helps reduce the size of the restart files ! considerably. - - + + use FatesIOVariableKindMod, only : cohort_r8 - + class(fates_restart_interface_type) :: this character(*),intent(in) :: symbol_base ! Symbol name without position - character(*),intent(in) :: vtype ! String defining variable type + character(*),intent(in) :: vtype ! String defining variable type character(*),intent(in) :: long_name_base ! name without position character(*),intent(in) :: units ! units for this variable integer,intent(in) :: veclength ! length of the vector @@ -1375,58 +1528,58 @@ subroutine RegisterCohortVector(this,symbol_base, vtype, long_name_base, & logical, intent(in) :: initialize ! Is this registering or counting? integer,intent(inout) :: ivar ! global variable counter integer,intent(out) :: index ! The variable index for this variable - + ! Local Variables character(len=4) :: pos_symbol ! vectors need text strings for each position character(len=128) :: symbol ! symbol name written to file character(len=256) :: long_name ! long name written to file integer :: i_pos ! loop counter for discrete position integer :: dummy_index - + ! We give each vector its own index that points to the first position - + index = ivar + 1 - + do i_pos = 1, veclength - + ! String describing the physical position of the variable write(pos_symbol, '(I3.3)') i_pos - + ! The symbol that is written to file symbol = trim(symbol_base)//'_vec_'//trim(pos_symbol) - + ! The expanded long name of the variable long_name = trim(long_name_base)//', position:'//trim(pos_symbol) - + call this%set_restart_var(vname=trim(symbol), & vtype=vtype, & long_name=trim(long_name), & units=units, flushval = flushval, & hlms='CLM:ALM', initialize=initialize, & - ivar=ivar, index = dummy_index ) - + ivar=ivar, index = dummy_index ) + end do - - end subroutine RegisterCohortVector - ! ===================================================================================== + end subroutine RegisterCohortVector + ! ===================================================================================== + subroutine GetCohortRealVector(this, state_vector, len_state_vector, & variable_index_base, co_global_index) - + ! This subroutine walks through global cohort vector indices ! and pulls from the different associated restart variables - + class(fates_restart_interface_type) , intent(inout) :: this integer,intent(in) :: len_state_vector real(r8),intent(inout) :: state_vector(len_state_vector) integer,intent(in) :: variable_index_base integer,intent(in) :: co_global_index - + integer :: i_pos ! vector position loop index integer :: ir_pos_var ! global variable index - + ir_pos_var = variable_index_base do i_pos = 1, len_state_vector state_vector(i_pos) = this%rvars(ir_pos_var)%r81d(co_global_index) @@ -1434,24 +1587,24 @@ subroutine GetCohortRealVector(this, state_vector, len_state_vector, & end do return end subroutine GetCohortRealVector - - ! ===================================================================================== - + + ! ===================================================================================== + subroutine SetCohortRealVector(this, state_vector, len_state_vector, & variable_index_base, co_global_index) ! This subroutine walks through global cohort vector indices ! and pushes into the restart arrays the different associated restart variables - + class(fates_restart_interface_type) , intent(inout) :: this integer,intent(in) :: len_state_vector real(r8),intent(in) :: state_vector(len_state_vector) integer,intent(in) :: variable_index_base integer,intent(in) :: co_global_index - + integer :: i_pos ! vector position loop index integer :: ir_pos_var ! global variable index - + ir_pos_var = variable_index_base do i_pos = 1, len_state_vector this%rvars(ir_pos_var)%r81d(co_global_index) = state_vector(i_pos) @@ -1459,7 +1612,7 @@ subroutine SetCohortRealVector(this, state_vector, len_state_vector, & end do return end subroutine SetCohortRealVector - + ! ===================================================================================== @@ -1473,7 +1626,7 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & class(fates_restart_interface_type) :: this character(len=*),intent(in) :: vname character(len=*),intent(in) :: vtype - character(len=*),intent(in) :: units + character(len=*),intent(in) :: units real(r8), intent(in) :: flushval character(len=*),intent(in) :: long_name character(len=*),intent(in) :: hlms @@ -1485,32 +1638,32 @@ subroutine set_restart_var(this,vname,vtype,long_name,units,flushval, & ! A zero is passed back when the variable is ! not used - + type(fates_restart_variable_type),pointer :: rvar integer :: ub1,lb1,ub2,lb2 ! Bounds for allocating the var integer :: ityp - + logical :: use_var - + use_var = check_hlm_list(trim(hlms), trim(hlm_name)) if( use_var ) then - + ivar = ivar+1 - index = ivar - + index = ivar + if( initialize )then - + call this%rvars(ivar)%Init(vname, units, long_name, vtype, flushval, & fates_restart_num_dim_kinds, this%dim_kinds, this%dim_bounds) end if else - + index = 0 end if - + return end subroutine set_restart_var @@ -1524,6 +1677,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type use EDTypesMod, only : maxSWb + use EDTypesMod, only : nclmax use EDTypesMod, only : numWaterMem use EDTypesMod, only : num_vegtemp_mem @@ -1563,12 +1717,12 @@ subroutine set_restart_vectors(this,nc,nsites,sites) integer :: io_idx_si_cwd ! each site-cwd index integer :: io_idx_si_pft ! each site-pft index integer :: io_idx_si_vtmem ! indices for veg-temp memory at site - + integer :: io_idx_pa_ncl ! each canopy layer within each patch ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) integer :: patchespersite ! number of patches per site - integer :: cohortsperpatch ! number of cohorts per patch + integer :: cohortsperpatch ! number of cohorts per patch integer :: ft ! functional type index integer :: el ! element loop index @@ -1603,6 +1757,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_snow_depth_si => this%rvars(ir_snow_depth_si)%r81d, & rio_trunk_product_si => this%rvars(ir_trunk_product_si)%r81d, & rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d, & + rio_fcansno_pa => this%rvars(ir_fcansno_pa)%r81d, & rio_solar_zenith_flag_pa => this%rvars(ir_solar_zenith_flag_pa)%int1d, & rio_solar_zenith_angle_pa => this%rvars(ir_solar_zenith_angle_pa)%r81d, & rio_canopy_layer_co => this%rvars(ir_canopy_layer_co)%int1d, & @@ -1624,14 +1779,15 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_gpp_acc_hold_co => this%rvars(ir_gpp_acc_hold_co)%r81d, & rio_resp_acc_hold_co => this%rvars(ir_resp_acc_hold_co)%r81d, & rio_npp_acc_hold_co => this%rvars(ir_npp_acc_hold_co)%r81d, & - rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & + rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & - rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & + rio_daily_nh4_uptake_co => this%rvars(ir_daily_nh4_uptake_co)%r81d, & + rio_daily_no3_uptake_co => this%rvars(ir_daily_no3_uptake_co)%r81d, & rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & - rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & - rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & + rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & + rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & rio_daily_p_efflux_co => this%rvars(ir_daily_p_efflux_co)%r81d, & rio_daily_n_demand_co => this%rvars(ir_daily_n_demand_co)%r81d, & rio_daily_p_demand_co => this%rvars(ir_daily_p_demand_co)%r81d, & @@ -1653,8 +1809,9 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_spread_si => this%rvars(ir_spread_si)%r81d, & rio_livegrass_pa => this%rvars(ir_livegrass_pa)%r81d, & rio_age_pa => this%rvars(ir_age_pa)%r81d, & - rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & - rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & + rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & + rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & + rio_nocomp_pft_label_pa => this%rvars(ir_nocomp_pft_label_pa)%int1d, & rio_area_pa => this%rvars(ir_area_pa)%r81d, & rio_watermem_siwm => this%rvars(ir_watermem_siwm)%r81d, & rio_vegtempmem_sitm => this%rvars(ir_vegtempmem_sitm)%r81d, & @@ -1681,20 +1838,20 @@ subroutine set_restart_vectors(this,nc,nsites,sites) totalCohorts = 0 - + ! --------------------------------------------------------------------------------- ! Flush arrays to values defined by %flushval (see registry entry in ! subroutine define_history_vars() ! --------------------------------------------------------------------------------- call this%flush_rvars(nc) - + do s = 1,nsites - + ! Calculate the offsets ! fcolumn is the global column index of the current site. ! For the first site, if that site aligns with the first column index ! in the clump, than the offset should be be equal to begCohort - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) @@ -1702,39 +1859,39 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_ib = io_idx_co_1st io_idx_si_wmem = io_idx_co_1st io_idx_si_vtmem = io_idx_co_1st - + io_idx_pa_ncl = io_idx_co_1st ! Hydraulics counters lyr = hydraulic layer, shell = rhizosphere shell io_idx_si_lyr_shell = io_idx_co_1st io_idx_si_sc = io_idx_co_1st io_idx_si_capf = io_idx_co_1st io_idx_si_cacls= io_idx_co_1st - + ! recruitment rate do i_pft = 1,numpft rio_recrate_sift(io_idx_co_1st+i_pft-1) = sites(s)%recruitment_rate(i_pft) end do - + do i_pft = 1,numpft - rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%use_this_pft(i_pft) + rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%use_this_pft(i_pft) end do - + do i_pft = 1,numpft rio_area_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%area_pft(i_pft) end do - + do el = 1, num_elements io_idx_si_cwd = io_idx_co_1st io_idx_si_pft = io_idx_co_1st io_idx_si_scpf = io_idx_co_1st - + do i_cwd=1,ncwd this%rvars(ir_cwdagin_flxdg+el-1)%r81d(io_idx_si_cwd) = sites(s)%flux_diags(el)%cwd_ag_input(i_cwd) this%rvars(ir_cwdbgin_flxdg+el-1)%r81d(io_idx_si_cwd) = sites(s)%flux_diags(el)%cwd_bg_input(i_cwd) io_idx_si_cwd = io_idx_si_cwd + 1 end do - + do i_pft=1,numpft this%rvars(ir_leaflittin_flxdg+el-1)%r81d(io_idx_si_pft) = sites(s)%flux_diags(el)%leaf_litter_input(i_pft) this%rvars(ir_rootlittin_flxdg+el-1)%r81d(io_idx_si_pft) = sites(s)%flux_diags(el)%root_litter_input(i_pft) @@ -1750,8 +1907,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_scpf = io_idx_si_scpf + 1 end do end do - - + + this%rvars(ir_oldstock_mbal+el-1)%r81d(io_idx_si) = sites(s)%mass_balance(el)%old_stock this%rvars(ir_errfates_mbal+el-1)%r81d(io_idx_si) = sites(s)%mass_balance(el)%err_fates @@ -1760,31 +1917,31 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! canopy spread term rio_spread_si(io_idx_si) = sites(s)%spread - + cpatch => sites(s)%oldest_patch - + ! new column, reset num patches patchespersite = 0 - + do while(associated(cpatch)) - + ! found patch, increment patchespersite = patchespersite + 1 - + ccohort => cpatch%shortest - + ! new patch, reset num cohorts cohortsperpatch = 0 - + do while(associated(ccohort)) - + ! found cohort, increment cohortsperpatch = cohortsperpatch + 1 totalCohorts = totalCohorts + 1 - + if ( debug ) then write(fates_log(),*) 'CLTV io_idx_co ', io_idx_co - write(fates_log(),*) 'CLTV lowerbound ', lbound(rio_npp_acc_co,1) + write(fates_log(),*) 'CLTV lowerbound ', lbound(rio_npp_acc_co,1) write(fates_log(),*) 'CLTV upperbound ', ubound(rio_npp_acc_co,1) endif @@ -1797,7 +1954,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_base do i_var = 1, prt_global%num_vars do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos - + ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%val(i_pos) @@ -1805,7 +1962,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%turnover(i_pos) - + ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%net_alloc(i_pos) @@ -1813,13 +1970,13 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ir_prt_var = ir_prt_var + 1 this%rvars(ir_prt_var)%r81d(io_idx_co) = & ccohort%prt%variables(i_var)%burned(i_pos) - + end do end do - + if(hlm_use_planthydro==itrue)then - + ! Load the water contents call this%SetCohortRealVector(ccohort%co_hydr%th_ag,n_hypool_ag, & ir_hydro_th_ag_covec,io_idx_co) @@ -1860,21 +2017,22 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_cmort_co(io_idx_co) = ccohort%cmort rio_smort_co(io_idx_co) = ccohort%smort rio_asmort_co(io_idx_co) = ccohort%asmort - rio_frmort_co(io_idx_co) = ccohort%frmort + rio_frmort_co(io_idx_co) = ccohort%frmort ! Nutrient uptake/efflux - rio_daily_n_uptake_co(io_idx_co) = ccohort%daily_n_uptake + rio_daily_no3_uptake_co(io_idx_co) = ccohort%daily_no3_uptake + rio_daily_nh4_uptake_co(io_idx_co) = ccohort%daily_nh4_uptake rio_daily_p_uptake_co(io_idx_co) = ccohort%daily_p_uptake - + rio_daily_c_efflux_co(io_idx_co) = ccohort%daily_c_efflux rio_daily_n_efflux_co(io_idx_co) = ccohort%daily_n_efflux rio_daily_p_efflux_co(io_idx_co) = ccohort%daily_p_efflux rio_daily_n_demand_co(io_idx_co) = ccohort%daily_n_demand rio_daily_p_demand_co(io_idx_co) = ccohort%daily_p_demand - rio_daily_n_need_co(io_idx_co) = ccohort%daily_n_need2 - rio_daily_p_need_co(io_idx_co) = ccohort%daily_p_need2 - + rio_daily_n_need_co(io_idx_co) = ccohort%daily_n_need + rio_daily_p_need_co(io_idx_co) = ccohort%daily_p_need + !Logging rio_lmort_direct_co(io_idx_co) = ccohort%lmort_direct rio_lmort_collateral_co(io_idx_co) = ccohort%lmort_collateral @@ -1889,18 +2047,27 @@ subroutine set_restart_vectors(this,nc,nsites,sites) else rio_isnew_co(io_idx_co) = old_cohort endif - + + if (hlm_use_sp .eq. itrue) then + this%rvars(ir_c_area_co)%r81d(io_idx_co) = ccohort%c_area + this%rvars(ir_treelai_co)%r81d(io_idx_co) = ccohort%treelai + this%rvars(ir_treesai_co)%r81d(io_idx_co) = ccohort%treesai + end if + if ( debug ) then write(fates_log(),*) 'CLTV offsetNumCohorts II ',io_idx_co, & cohortsperpatch endif - + + ! (Keeping as an example) + ! call this%SetRMeanRestartVar(ccohort%tveg_lpa, ir_tveglpa_co, io_idx_co) + io_idx_co = io_idx_co + 1 - + ccohort => ccohort%taller - + enddo ! ccohort do while - + ! ! deal with patch level fields here ! @@ -1908,11 +2075,18 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_age_pa(io_idx_co_1st) = cpatch%age rio_patchdistturbcat_pa(io_idx_co_1st) = cpatch%anthro_disturbance_label rio_agesinceanthrodist_pa(io_idx_co_1st) = cpatch%age_since_anthro_disturbance + rio_nocomp_pft_label_pa(io_idx_co_1st)= cpatch%nocomp_pft_label rio_area_pa(io_idx_co_1st) = cpatch%area + + ! Patch level running means + call this%SetRMeanRestartVar(cpatch%tveg24, ir_tveg24_pa, io_idx_co_1st) + call this%SetRMeanRestartVar(cpatch%tveg_lpa, ir_tveglpa_pa, io_idx_co_1st) ! set cohorts per patch for IO rio_ncohort_pa( io_idx_co_1st ) = cohortsperpatch - + + rio_fcansno_pa( io_idx_co_1st ) = cpatch%fcansno + ! Set zenith angle info if ( cpatch%solar_zenith_flag ) then rio_solar_zenith_flag_pa(io_idx_co_1st) = itrue @@ -1926,20 +2100,32 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ,io_idx_co,cohortsperpatch endif + io_idx_pa_pft = io_idx_co_1st + do i = 1,numpft + this%rvars(ir_scorch_ht_pa_pft)%r81d(io_idx_pa_pft) = cpatch%scorch_ht(i) + io_idx_pa_pft = io_idx_pa_pft + 1 + end do + + io_idx_pa_cwd = io_idx_co_1st + do i = 1,nfsc + this%rvars(ir_litter_moisture_pa_nfsc)%r81d(io_idx_pa_cwd) = cpatch%litter_moisture(i) + io_idx_pa_cwd = io_idx_pa_cwd + 1 + end do + ! -------------------------------------------------------------------------- ! Send litter to the restart arrays - ! Each element has its own variable, so we have to make sure - ! we keep re-setting this + ! Each element has its own variable, so we have to make sure + ! we keep re-setting this ! -------------------------------------------------------------------------- do el = 0, num_elements-1 - + io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_cwsl = io_idx_co_1st io_idx_pa_dcsl = io_idx_co_1st io_idx_pa_dc = io_idx_co_1st - + litt => cpatch%litter(el+1) do i = 1,numpft @@ -1961,7 +2147,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_pa_dcsl = io_idx_pa_dcsl + 1 end do end do - + do i = 1,ncwd this%rvars(ir_agcwd_litt+el)%r81d(io_idx_pa_cwd) = litt%ag_cwd(i) this%rvars(ir_agcwd_frag_litt+el)%r81d(io_idx_pa_cwd) = litt%ag_cwd_frag(i) @@ -1975,39 +2161,47 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end do - + do i = 1,maxSWb rio_gnd_alb_dif_pasb(io_idx_pa_ib) = cpatch%gnd_alb_dif(i) rio_gnd_alb_dir_pasb(io_idx_pa_ib) = cpatch%gnd_alb_dir(i) io_idx_pa_ib = io_idx_pa_ib + 1 end do + if (hlm_use_sp .eq. itrue) then + do i = 1,nclmax + this%rvars(ir_canopy_layer_tlai_pa)%r81d(io_idx_pa_ncl) = cpatch%canopy_layer_tlai(i) + io_idx_pa_ncl = io_idx_pa_ncl + 1 + end do + end if + ! Set the first cohort index to the start of the next patch, increment ! by the maximum number of cohorts per patch io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch - + ! reset counters so that they are all advanced evenly. io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_co = io_idx_co_1st - + io_idx_pa_ncl = io_idx_co_1st + if ( debug ) then write(fates_log(),*) 'CLTV io_idx_co_1st ', io_idx_co_1st write(fates_log(),*) 'CLTV numCohort ', cohortsperpatch write(fates_log(),*) 'CLTV totalCohorts ', totalCohorts end if - + cpatch => cpatch%younger - + enddo ! cpatch do while - + io_idx_si_scpf = io_idx_co_1st - + ! Fill the site level diagnostics arrays do i_scls = 1, nlevsclass do i_pft = 1, numpft - + rio_fmortrate_cano_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_canopy(i_scls, i_pft) rio_fmortrate_usto_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_ustory(i_scls, i_pft) rio_imortrate_siscpf(io_idx_si_scpf) = sites(s)%imort_rate(i_scls, i_pft) @@ -2016,16 +2210,16 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_termnindiv_cano_siscpf(io_idx_si_scpf) = sites(s)%term_nindivs_canopy(i_scls,i_pft) rio_termnindiv_usto_siscpf(io_idx_si_scpf) = sites(s)%term_nindivs_ustory(i_scls,i_pft) rio_growflx_fusion_siscpf(io_idx_si_scpf) = sites(s)%growthflux_fusion(i_scls, i_pft) - + io_idx_si_scpf = io_idx_si_scpf + 1 end do rio_demorate_sisc(io_idx_si_sc) = sites(s)%demotion_rate(i_scls) rio_promrate_sisc(io_idx_si_sc) = sites(s)%promotion_rate(i_scls) - + io_idx_si_sc = io_idx_si_sc + 1 end do - + rio_termcflux_cano_si(io_idx_si) = sites(s)%term_carbonflux_canopy rio_termcflux_usto_si(io_idx_si) = sites(s)%term_carbonflux_ustory rio_democflux_si(io_idx_si) = sites(s)%demotion_carbonflux @@ -2044,15 +2238,15 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_dleafondate_si(io_idx_si) = sites(s)%dleafondate rio_dleafoffdate_si(io_idx_si) = sites(s)%dleafoffdate rio_acc_ni_si(io_idx_si) = sites(s)%acc_NI - rio_gdd_si(io_idx_si) = sites(s)%grow_deg_days + rio_gdd_si(io_idx_si) = sites(s)%grow_deg_days rio_snow_depth_si(io_idx_si) = sites(s)%snow_depth - + ! Accumulated trunk product rio_trunk_product_si(io_idx_si) = sites(s)%resources_management%trunk_product_site ! 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 @@ -2087,20 +2281,20 @@ subroutine set_restart_vectors(this,nc,nsites,sites) end do end do end if - + enddo - + if ( debug ) then write(fates_log(),*) 'CLTV total cohorts ',totalCohorts end if - + return end associate end subroutine set_restart_vectors ! ==================================================================================== - subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) + subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in, bc_out) ! ---------------------------------------------------------------------------------- ! This subroutine takes a peak at the restart file to determine how to allocate @@ -2114,7 +2308,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) use EDTypesMod, only : ed_patch_type use EDTypesMod, only : maxSWb use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch - + use EDTypesMod, only : maxpft use EDTypesMod, only : area use EDPatchDynamicsMod, only : zero_patch @@ -2123,17 +2317,18 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) use EDPatchDynamicsMod, only : create_patch use EDPftvarcon, only : EDPftvarcon_inst use FatesAllometryMod, only : h2d_allom - + ! !ARGUMENTS: class(fates_restart_interface_type) , intent(inout) :: this integer , intent(in) :: nc integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) - type(bc_in_type) , intent(in) :: bc_in(nsites) + type(bc_in_type) :: bc_in(nsites) + type(bc_out_type) :: bc_out(nsites) ! local variables - + type(ed_patch_type) , pointer :: newp type(ed_cohort_type), pointer :: new_cohort type(ed_cohort_type), pointer :: prev_cohort @@ -2147,22 +2342,22 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) integer :: ft integer :: el ! element loop counter integer, parameter :: recruitstatus = 0 - + integer :: nocomp_pft ! PFT patch label for nocomp mode ! ---------------------------------------------------------------------------------- ! We really only need the counts for the number of patches per site ! and the number of cohorts per patch. These values tell us how much ! 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 init_site_vars( sites(s), bc_in(s) ) + call init_site_vars( sites(s), bc_in(s), bc_out(s) ) call zero_site( sites(s) ) if ( rio_npatch_si(io_idx_si)<0 .or. rio_npatch_si(io_idx_si) > 10000 ) then @@ -2170,9 +2365,9 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) write(fates_log(),*) '0 is a valid number, but this column seems uninitialized',rio_npatch_si(io_idx_si) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + ! Initialize the site pointers to null - sites(s)%youngest_patch => null() + sites(s)%youngest_patch => null() sites(s)%oldest_patch => null() do idx_pa = 1,rio_npatch_si(io_idx_si) @@ -2181,12 +2376,13 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) write(fates_log(),*) 'create patch ',idx_pa write(fates_log(),*) 'idx_pa 1-cohortsperpatch : ', rio_ncohort_pa( io_idx_co_1st ) end if - + ! create patch - allocate(newp) - + allocate(newp) + nocomp_pft = fates_unset_int + ! the nocomp_pft label is set after patch creation has occured in 'get_restart_vectors' ! make new patch - call create_patch(sites(s), newp, fates_unset_r8, fates_unset_r8, primaryforest ) + call create_patch(sites(s), newp, fates_unset_r8, fates_unset_r8, primaryforest, nocomp_pft ) ! Initialize the litter pools to zero, these ! pools will be populated by looping over the existing patches @@ -2199,16 +2395,16 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) init_seed=fates_unset_r8, & init_seed_germ=fates_unset_r8) end do - + ! give this patch a unique patch number newp%patchno = idx_pa ! Iterate over the number of cohorts ! the file says are associated with this patch - ! we are just allocating space here, so we do + ! we are just allocating space here, so we do ! a simple list filling routine - + newp%tallest => null() newp%shortest => null() prev_cohort => null() @@ -2216,7 +2412,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) do fto = 1, rio_ncohort_pa( io_idx_co_1st ) allocate(new_cohort) - call nan_cohort(new_cohort) + call nan_cohort(new_cohort) call zero_cohort(new_cohort) new_cohort%patchptr => newp @@ -2224,7 +2420,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) if (.not.associated(newp%tallest)) then newp%tallest => new_cohort endif - + ! Every cohort's taller is the one that came before ! (unless it is first) if(associated(prev_cohort)) then @@ -2240,37 +2436,43 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) new_cohort%prt => null() call InitPRTObject(new_cohort%prt) call InitPRTBoundaryConditions(new_cohort) - - + + ! Allocate hydraulics arrays if( hlm_use_planthydro.eq.itrue ) then call InitHydrCohort(sites(s),new_cohort) end if + ! (Keeping as an example) + ! Allocate running mean functions + !allocate(new_cohort%tveg_lpa) + !call new_cohort%tveg_lpa%InitRMean(ema_lpa) + + ! Update the previous prev_cohort => new_cohort - + enddo ! ends loop over fto - + ! ! insert this patch with cohorts into the site pointer. At this ! point just insert the new patch in the youngest position ! if (idx_pa == 1) then ! nothing associated yet. first patch is pointed to by youngest and oldest - + if ( debug ) write(fates_log(),*) 'idx_pa = 1 ',idx_pa - - sites(s)%youngest_patch => newp - sites(s)%oldest_patch => newp + + sites(s)%youngest_patch => newp + sites(s)%oldest_patch => newp sites(s)%youngest_patch%younger => null() sites(s)%youngest_patch%older => null() sites(s)%oldest_patch%younger => null() sites(s)%oldest_patch%older => null() - + else if (idx_pa == 2) then ! add second patch to list - + if ( debug ) write(fates_log(),*) 'idx_pa = 2 ',idx_pa - + sites(s)%youngest_patch => newp sites(s)%youngest_patch%younger => null() sites(s)%youngest_patch%older => sites(s)%oldest_patch @@ -2278,25 +2480,25 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) sites(s)%oldest_patch%older => null() else ! more than 2 patches, insert patch into youngest slot - + if ( debug ) write(fates_log(),*) 'idx_pa > 2 ',idx_pa - + newp%older => sites(s)%youngest_patch sites(s)%youngest_patch%younger => newp newp%younger => null() sites(s)%youngest_patch => newp - + endif - + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch enddo ! ends loop over idx_pa enddo ! ends loop over s - + end associate end subroutine create_patchcohort_structure - + ! ==================================================================================== subroutine get_restart_vectors(this, nc, nsites, sites) @@ -2305,6 +2507,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : ed_patch_type use EDTypesMod, only : maxSWb + use EDTypesMod, only : nclmax use FatesInterfaceTypesMod, only : numpft use FatesInterfaceTypesMod, only : fates_maxElementsPerPatch use EDTypesMod, only : numWaterMem @@ -2342,7 +2545,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) integer :: io_idx_pa_cwd ! each cwd class within each patch (pa_cwd) integer :: io_idx_pa_cwsl ! each cwd x soil layer integer :: io_idx_pa_dcsl ! each decomposability x soil layer - integer :: io_idx_pa_dc ! each decomposability index + integer :: io_idx_pa_dc ! each decomposability index integer :: io_idx_pa_ib ! each SW radiation band per patch (pa_ib) integer :: io_idx_si_wmem ! each water memory class within each site integer :: io_idx_si_vtmem ! counter for vegetation temp memory @@ -2353,11 +2556,12 @@ subroutine get_restart_vectors(this, nc, nsites, sites) integer :: io_idx_si_capf ! each cohort age class x pft index within site integer :: io_idx_si_cwd integer :: io_idx_si_pft + integer :: io_idx_pa_ncl ! each canopy layer within each patch ! Some counters (for checking mostly) integer :: totalcohorts ! total cohort count on this thread (diagnostic) integer :: patchespersite ! number of patches per site - integer :: cohortsperpatch ! number of cohorts per patch + integer :: cohortsperpatch ! number of cohorts per patch integer :: el ! loop counter for elements integer :: nlevsoil ! number of soil layers integer :: ilyr ! soil layer loop counter @@ -2384,6 +2588,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_snow_depth_si => this%rvars(ir_snow_depth_si)%r81d, & rio_trunk_product_si => this%rvars(ir_trunk_product_si)%r81d, & rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d, & + rio_fcansno_pa => this%rvars(ir_fcansno_pa)%r81d, & rio_solar_zenith_flag_pa => this%rvars(ir_solar_zenith_flag_pa)%int1d, & rio_solar_zenith_angle_pa => this%rvars(ir_solar_zenith_angle_pa)%r81d, & rio_canopy_layer_co => this%rvars(ir_canopy_layer_co)%int1d, & @@ -2392,7 +2597,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_seed_prod_co => this%rvars(ir_seed_prod_co)%r81d, & rio_size_class_lasttimestep => this%rvars(ir_size_class_lasttimestep_co)%int1d, & rio_dbh_co => this%rvars(ir_dbh_co)%r81d, & - rio_coage_co => this%rvars(ir_coage_co)%r81d, & + rio_coage_co => this%rvars(ir_coage_co)%r81d, & rio_g_sb_laweight_co => this%rvars(ir_g_sb_laweight_co)%r81d, & rio_height_co => this%rvars(ir_height_co)%r81d, & rio_laimemory_co => this%rvars(ir_laimemory_co)%r81d, & @@ -2405,14 +2610,15 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_gpp_acc_hold_co => this%rvars(ir_gpp_acc_hold_co)%r81d, & rio_resp_acc_hold_co => this%rvars(ir_resp_acc_hold_co)%r81d, & rio_npp_acc_hold_co => this%rvars(ir_npp_acc_hold_co)%r81d, & - rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & + rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & - rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & - rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & - rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & - rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & + rio_daily_nh4_uptake_co => this%rvars(ir_daily_nh4_uptake_co)%r81d, & + rio_daily_no3_uptake_co => this%rvars(ir_daily_no3_uptake_co)%r81d, & + rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & + rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & + rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & rio_daily_p_efflux_co => this%rvars(ir_daily_p_efflux_co)%r81d, & rio_daily_n_demand_co => this%rvars(ir_daily_n_demand_co)%r81d, & rio_daily_p_demand_co => this%rvars(ir_daily_p_demand_co)%r81d, & @@ -2436,6 +2642,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_age_pa => this%rvars(ir_age_pa)%r81d, & rio_patchdistturbcat_pa => this%rvars(ir_patchdistturbcat_pa)%int1d, & rio_agesinceanthrodist_pa => this%rvars(ir_agesinceanthrodist_pa)%r81d, & + rio_nocomp_pft_label_pa => this%rvars(ir_nocomp_pft_label_pa)%int1d, & rio_area_pa => this%rvars(ir_area_pa)%r81d, & rio_watermem_siwm => this%rvars(ir_watermem_siwm)%r81d, & rio_vegtempmem_sitm => this%rvars(ir_vegtempmem_sitm)%r81d, & @@ -2459,19 +2666,20 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_imortcflux_si => this%rvars(ir_imortcflux_si)%r81d, & rio_fmortcflux_cano_si => this%rvars(ir_fmortcflux_cano_si)%r81d, & rio_fmortcflux_usto_si => this%rvars(ir_fmortcflux_usto_si)%r81d) - + totalcohorts = 0 - + do s = 1,nsites - + io_idx_si = this%restart_map(nc)%site_index(s) io_idx_co_1st = this%restart_map(nc)%cohort1_index(s) - + io_idx_co = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_si_wmem = io_idx_co_1st io_idx_si_vtmem = io_idx_co_1st + io_idx_pa_ncl = io_idx_co_1st ! Hydraulics counters lyr = hydraulic layer, shell = rhizosphere shell io_idx_si_lyr_shell = io_idx_co_1st @@ -2480,13 +2688,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_sc = io_idx_co_1st io_idx_si_capf = io_idx_co_1st io_idx_si_cacls= io_idx_co_1st - + ! read seed_bank info(site-level, but PFT-resolved) - do i_pft = 1,numpft + do i_pft = 1,numpft sites(s)%recruitment_rate(i_pft) = rio_recrate_sift(io_idx_co_1st+i_pft-1) enddo - - !variables for fixed biogeography mode. These are currently used in restart even when this is off. + + !variables for fixed biogeography mode. These are currently used in restart even when this is off. do i_pft = 1,numpft sites(s)%use_this_pft(i_pft) = rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) sites(s)%area_pft(i_pft) = rio_area_pft_sift(io_idx_co_1st+i_pft-1) @@ -2498,13 +2706,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_cwd = io_idx_co_1st io_idx_si_pft = io_idx_co_1st io_idx_si_scpf = io_idx_co_1st - + do i_cwd=1,ncwd sites(s)%flux_diags(el)%cwd_ag_input(i_cwd) = this%rvars(ir_cwdagin_flxdg+el-1)%r81d(io_idx_si_cwd) sites(s)%flux_diags(el)%cwd_bg_input(i_cwd) = this%rvars(ir_cwdbgin_flxdg+el-1)%r81d(io_idx_si_cwd) io_idx_si_cwd = io_idx_si_cwd + 1 end do - + do i_pft=1,numpft sites(s)%flux_diags(el)%leaf_litter_input(i_pft) = this%rvars(ir_leaflittin_flxdg+el-1)%r81d(io_idx_si_pft) sites(s)%flux_diags(el)%root_litter_input(i_pft) = this%rvars(ir_rootlittin_flxdg+el-1)%r81d(io_idx_si_pft) @@ -2520,34 +2728,34 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_scpf = io_idx_si_scpf + 1 end do end do - - + + sites(s)%mass_balance(el)%old_stock = this%rvars(ir_oldstock_mbal+el-1)%r81d(io_idx_si) sites(s)%mass_balance(el)%err_fates = this%rvars(ir_errfates_mbal+el-1)%r81d(io_idx_si) end do - sites(s)%spread = rio_spread_si(io_idx_si) - + sites(s)%spread = rio_spread_si(io_idx_si) + ! Perform a check on the number of patches per site patchespersite = 0 - + cpatch => sites(s)%oldest_patch do while(associated(cpatch)) - + patchespersite = patchespersite + 1 - + ccohort => cpatch%shortest - + ! new patch, reset num cohorts cohortsperpatch = 0 - - do while(associated(ccohort)) - + + do while(associated(ccohort)) + ! found cohort, increment cohortsperpatch = cohortsperpatch + 1 totalcohorts = totalcohorts + 1 - + if ( debug ) then write(fates_log(),*) 'CVTL io_idx_co ',io_idx_co endif @@ -2559,7 +2767,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ir_prt_var = ir_prt_base do i_var = 1, prt_global%num_vars - do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos + do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos ir_prt_var = ir_prt_var + 1 ccohort%prt%variables(i_var)%val(i_pos) = & @@ -2575,13 +2783,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ir_prt_var = ir_prt_var + 1 ccohort%prt%variables(i_var)%burned(i_pos) = & - this%rvars(ir_prt_var)%r81d(io_idx_co) + this%rvars(ir_prt_var)%r81d(io_idx_co) end do end do - !ccohort%vcmax25top + !ccohort%vcmax25top !ccohort%jmax25top - !ccohort%tpu25top + !ccohort%tpu25top !ccohort%kp25top @@ -2612,18 +2820,19 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%smort = rio_smort_co(io_idx_co) ccohort%asmort = rio_asmort_co(io_idx_co) ccohort%frmort = rio_frmort_co(io_idx_co) - + ! Nutrient uptake / efflux - ccohort%daily_n_uptake = rio_daily_n_uptake_co(io_idx_co) + ccohort%daily_nh4_uptake = rio_daily_nh4_uptake_co(io_idx_co) + ccohort%daily_no3_uptake = rio_daily_no3_uptake_co(io_idx_co) ccohort%daily_p_uptake = rio_daily_p_uptake_co(io_idx_co) ccohort%daily_c_efflux = rio_daily_c_efflux_co(io_idx_co) ccohort%daily_n_efflux = rio_daily_n_efflux_co(io_idx_co) ccohort%daily_p_efflux = rio_daily_p_efflux_co(io_idx_co) - - ccohort%daily_n_demand = rio_daily_n_demand_co(io_idx_co) + + ccohort%daily_n_demand = rio_daily_n_demand_co(io_idx_co) ccohort%daily_p_demand = rio_daily_p_demand_co(io_idx_co) - ccohort%daily_n_need2 = rio_daily_n_need_co(io_idx_co) - ccohort%daily_p_need2 = rio_daily_p_need_co(io_idx_co) + ccohort%daily_n_need = rio_daily_n_need_co(io_idx_co) + ccohort%daily_p_need = rio_daily_p_need_co(io_idx_co) !Logging ccohort%lmort_direct = rio_lmort_direct_co(io_idx_co) @@ -2642,24 +2851,33 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Initialize Plant Hydraulics if(hlm_use_planthydro==itrue)then - + ! Load the water contents call this%GetCohortRealVector(ccohort%co_hydr%th_ag,n_hypool_ag, & ir_hydro_th_ag_covec,io_idx_co) call this%GetCohortRealVector(ccohort%co_hydr%th_aroot,sites(s)%si_hydr%nlevrhiz, & ir_hydro_th_aroot_covec,io_idx_co) - + ccohort%co_hydr%th_troot = this%rvars(ir_hydro_th_troot)%r81d(io_idx_co) ccohort%co_hydr%errh2o = this%rvars(ir_hydro_errh2o)%r81d(io_idx_co) call UpdatePlantPsiFTCFromTheta(ccohort,sites(s)%si_hydr) end if + + ! (Keeping as an example) + !call this%GetRMeanRestartVar(ccohort%tveg_lpa, ir_tveglpa_co, io_idx_co) + if (hlm_use_sp .eq. itrue) then + ccohort%c_area = this%rvars(ir_c_area_co)%r81d(io_idx_co) + ccohort%treelai = this%rvars(ir_treelai_co)%r81d(io_idx_co) + ccohort%treesai = this%rvars(ir_treesai_co)%r81d(io_idx_co) + end if + io_idx_co = io_idx_co + 1 - + ccohort => ccohort%taller - + enddo ! current cohort do while if(cohortsperpatch .ne. rio_ncohort_pa(io_idx_co_1st)) then @@ -2675,28 +2893,46 @@ subroutine get_restart_vectors(this, nc, nsites, sites) cpatch%age = rio_age_pa(io_idx_co_1st) cpatch%anthro_disturbance_label = rio_patchdistturbcat_pa(io_idx_co_1st) cpatch%age_since_anthro_disturbance = rio_agesinceanthrodist_pa(io_idx_co_1st) + cpatch%nocomp_pft_label = rio_nocomp_pft_label_pa(io_idx_co_1st) cpatch%area = rio_area_pa(io_idx_co_1st) cpatch%age_class = get_age_class_index(cpatch%age) + cpatch%fcansno = rio_fcansno_pa(io_idx_co_1st) ! Set zenith angle info cpatch%solar_zenith_flag = ( rio_solar_zenith_flag_pa(io_idx_co_1st) .eq. itrue ) cpatch%solar_zenith_angle = rio_solar_zenith_angle_pa(io_idx_co_1st) - ! set cohorts per patch for IO + + call this%GetRMeanRestartVar(cpatch%tveg24, ir_tveg24_pa, io_idx_co_1st) + call this%GetRMeanRestartVar(cpatch%tveg_lpa, ir_tveglpa_pa, io_idx_co_1st) + ! set cohorts per patch for IO + if ( debug ) then write(fates_log(),*) 'CVTL III ' & ,io_idx_co,cohortsperpatch endif - + + io_idx_pa_pft = io_idx_co_1st + do i = 1,numpft + cpatch%scorch_ht(i) = this%rvars(ir_scorch_ht_pa_pft)%r81d(io_idx_pa_pft) + io_idx_pa_pft = io_idx_pa_pft + 1 + end do + + io_idx_pa_cwd = io_idx_co_1st + do i = 1,nfsc + cpatch%litter_moisture(i) = this%rvars(ir_litter_moisture_pa_nfsc)%r81d(io_idx_pa_cwd) + io_idx_pa_cwd = io_idx_pa_cwd + 1 + end do + ! -------------------------------------------------------------------------- ! Pull litter from the restart arrays - ! Each element has its own variable, so we have to make sure - ! we keep re-setting this + ! Each element has its own variable, so we have to make sure + ! we keep re-setting this ! -------------------------------------------------------------------------- do el = 0, num_elements-1 - + io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_cwsl = io_idx_co_1st @@ -2724,13 +2960,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_pa_dcsl = io_idx_pa_dcsl + 1 end do end do - + do i = 1,ncwd litt%ag_cwd(i) = this%rvars(ir_agcwd_litt+el)%r81d(io_idx_pa_cwd) litt%ag_cwd_frag(i) = this%rvars(ir_agcwd_frag_litt+el)%r81d(io_idx_pa_cwd) io_idx_pa_cwd = io_idx_pa_cwd + 1 - + do ilyr=1,nlevsoil litt%bg_cwd(i,ilyr) = this%rvars(ir_bgcwd_litt+el)%r81d(io_idx_pa_cwsl) litt%bg_cwd_frag(i,ilyr) = this%rvars(ir_bgcwd_frag_litt+el)%r81d(io_idx_pa_cwsl) @@ -2746,32 +2982,40 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_pa_ib = io_idx_pa_ib + 1 end do + if (hlm_use_sp .eq. itrue) then + do i = 1,nclmax + cpatch%canopy_layer_tlai(i) = this%rvars(ir_canopy_layer_tlai_pa)%r81d(io_idx_pa_ncl) + io_idx_pa_ncl = io_idx_pa_ncl + 1 + end do + end if + ! Now increment the position of the first cohort to that of the next ! patch - + io_idx_co_1st = io_idx_co_1st + fates_maxElementsPerPatch - + ! and max the number of allowed cohorts per patch io_idx_pa_pft = io_idx_co_1st io_idx_pa_cwd = io_idx_co_1st io_idx_pa_ib = io_idx_co_1st io_idx_co = io_idx_co_1st - + io_idx_pa_ncl = 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 @@ -2786,7 +3030,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Retrieve site-level hydraulics arrays ! Note that Hydraulics structures, their allocations, and the length ! declaration nlevsoi_hyd should be allocated early on when the code first - ! allocates sites (before restart info), and when the soils layer is + ! allocates sites (before restart info), and when the soils layer is ! first known. ! ----------------------------------------------------------------------------- @@ -2808,7 +3052,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) end do end if - + ! Fill the site level diagnostics arrays ! ----------------------------------------------------------------------------- @@ -2821,7 +3065,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%fmort_rate_ustory(i_scls, i_pft) = rio_fmortrate_usto_siscpf(io_idx_si_scpf) sites(s)%imort_rate(i_scls, i_pft) = rio_imortrate_siscpf(io_idx_si_scpf) sites(s)%fmort_rate_crown(i_scls, i_pft) = rio_fmortrate_crown_siscpf(io_idx_si_scpf) - sites(s)%fmort_rate_cambial(i_scls, i_pft) = rio_fmortrate_cambi_siscpf(io_idx_si_scpf) + sites(s)%fmort_rate_cambial(i_scls, i_pft) = rio_fmortrate_cambi_siscpf(io_idx_si_scpf) sites(s)%term_nindivs_canopy(i_scls,i_pft) = rio_termnindiv_cano_siscpf(io_idx_si_scpf) sites(s)%term_nindivs_ustory(i_scls,i_pft) = rio_termnindiv_usto_siscpf(io_idx_si_scpf) sites(s)%growthflux_fusion(i_scls, i_pft) = rio_growflx_fusion_siscpf(io_idx_si_scpf) @@ -2830,7 +3074,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%demotion_rate(i_scls) = rio_demorate_sisc(io_idx_si_sc) sites(s)%promotion_rate(i_scls) = rio_promrate_sisc(io_idx_si_sc) - + io_idx_si_sc = io_idx_si_sc + 1 end do @@ -2842,7 +3086,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%fmort_carbonflux_canopy = rio_fmortcflux_cano_si(io_idx_si) sites(s)%fmort_carbonflux_ustory = rio_fmortcflux_usto_si(io_idx_si) - + ! Site level phenology status flags sites(s)%cstatus = rio_cd_status_si(io_idx_si) @@ -2864,10 +3108,10 @@ subroutine get_restart_vectors(this, nc, nsites, sites) if ( debug ) then write(fates_log(),*) 'CVTL total cohorts ',totalCohorts end if - + end associate end subroutine get_restart_vectors - + ! ==================================================================================== subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) @@ -2896,12 +3140,12 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) integer :: ifp ! patch counter do s = 1, nsites - + ifp = 0 currentpatch => sites(s)%oldest_patch - do while (associated(currentpatch)) + do while (associated(currentpatch)) ifp = ifp+1 - + currentPatch%f_sun (:,:,:) = 0._r8 currentPatch%fabd_sun_z (:,:,:) = 0._r8 currentPatch%fabd_sha_z (:,:,:) = 0._r8 @@ -2915,7 +3159,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) currentPatch%nrmlzd_parprof_pft_dif_z(:,:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_dir_z(:,:,:) = 0._r8 currentPatch%nrmlzd_parprof_dif_z(:,:,:) = 0._r8 - + ! ----------------------------------------------------------- ! When calling norman radiation from the short-timestep ! we are passing in boundary conditions to set the following @@ -2923,9 +3167,9 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) ! currentPatch%solar_zenith_flag (is there daylight?) ! currentPatch%solar_zenith_angle (what is the value?) ! ----------------------------------------------------------- - + if(currentPatch%solar_zenith_flag)then - + bc_out(s)%albd_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%albi_parb(ifp,:) = 0._r8 ! output HLM bc_out(s)%fabi_parb(ifp,:) = 0._r8 ! output HLM @@ -2933,10 +3177,10 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftdd_parb(ifp,:) = 1._r8 ! output HLM bc_out(s)%ftid_parb(ifp,:) = 1._r8 ! output HLM bc_out(s)%ftii_parb(ifp,:) = 1._r8 ! output HLM - + if (maxval(currentPatch%nrad(1,:))==0)then - !there are no leaf layers in this patch. it is effectively bare ground. - ! no radiation is absorbed + !there are no leaf layers in this patch. it is effectively bare ground. + ! no radiation is absorbed bc_out(s)%fabd_parb(ifp,:) = 0.0_r8 bc_out(s)%fabi_parb(ifp,:) = 0.0_r8 do ib = 1,hlm_numSWb @@ -2950,7 +3194,7 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftii_parb(ifp,ib)= 1.0_r8 enddo else - + call PatchNormanRadiation (currentPatch, & bc_out(s)%albd_parb(ifp,:), & bc_out(s)%albi_parb(ifp,:), & @@ -2959,16 +3203,14 @@ subroutine update_3dpatch_radiation(this, nsites, sites, bc_out) bc_out(s)%ftdd_parb(ifp,:), & bc_out(s)%ftid_parb(ifp,:), & bc_out(s)%ftii_parb(ifp,:)) - - endif ! is there vegetation? - - end if ! if the vegetation and zenith filter is active - + endif ! is there vegetation? + + end if ! if the vegetation and zenith filter is active currentPatch => currentPatch%younger end do ! Loop linked-list patches enddo ! Loop Sites - + return end subroutine update_3dpatch_radiation diff --git a/main/FatesRestartVariableType.F90 b/main/FatesRestartVariableType.F90 index 48152ec955..4cec99c349 100644 --- a/main/FatesRestartVariableType.F90 +++ b/main/FatesRestartVariableType.F90 @@ -39,8 +39,8 @@ module FatesRestartVariableMod subroutine Init(this, vname, units, long, vtype, flushval, num_dim_kinds, dim_kinds, dim_bounds) use FatesIODimensionsMod, only : fates_io_dimension_type - use FatesIOVariableKindMod, only : patch_r8, site_r8, cohort_r8 - use FatesIOVariableKindMod, only : patch_int, site_int, cohort_int + use FatesIOVariableKindMod, only : site_r8, cohort_r8 + use FatesIOVariableKindMod, only : site_int, cohort_int use FatesIOVariableKindMod, only : iotype_index implicit none @@ -85,10 +85,6 @@ subroutine Init(this, vname, units, long, vtype, flushval, num_dim_kinds, dim_ki allocate(this%r81d(lb1:ub1)) this%r81d(:) = flushval - case(patch_r8) - allocate(this%r81d(lb1:ub1)) - this%r81d(:) = flushval - case(site_r8) allocate(this%r81d(lb1:ub1)) this%r81d(:) = flushval @@ -97,10 +93,6 @@ subroutine Init(this, vname, units, long, vtype, flushval, num_dim_kinds, dim_ki allocate(this%int1d(lb1:ub1)) this%int1d(:) = idnint(flushval) - case(patch_int) - allocate(this%int1d(lb1:ub1)) - this%int1d(:) = idnint(flushval) - case(site_int) allocate(this%int1d(lb1:ub1)) this%int1d(:) = idnint(flushval) @@ -170,8 +162,8 @@ end subroutine GetBounds subroutine flush(this, thread, dim_bounds, dim_kinds) use FatesIODimensionsMod, only : fates_io_dimension_type - use FatesIOVariableKindMod, only : patch_r8, site_r8, cohort_r8 - use FatesIOVariableKindMod, only : patch_int, site_int, cohort_int + use FatesIOVariableKindMod, only : site_r8, cohort_r8 + use FatesIOVariableKindMod, only : site_int, cohort_int implicit none @@ -185,14 +177,10 @@ subroutine flush(this, thread, dim_bounds, dim_kinds) call this%GetBounds(thread, dim_bounds, dim_kinds, lb1, ub1, lb2, ub2) select case(trim(dim_kinds(this%dim_kinds_index)%name)) - case(patch_r8) - this%r81d(lb1:ub1) = this%flushval case(site_r8) this%r81d(lb1:ub1) = this%flushval case(cohort_r8) this%r81d(lb1:ub1) = this%flushval - case(patch_int) - this%int1d(lb1:ub1) = nint(this%flushval) case(site_int) this%int1d(lb1:ub1) = nint(this%flushval) case(cohort_int) diff --git a/main/FatesRunningMeanMod.F90 b/main/FatesRunningMeanMod.F90 new file mode 100644 index 0000000000..7fa3bfd7cc --- /dev/null +++ b/main/FatesRunningMeanMod.F90 @@ -0,0 +1,337 @@ +module FatesRunningMeanMod + + + use FatesConstantsMod, only : nearzero + use FatesConstantsMod, only : r8 => fates_r8 + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) + use shr_log_mod, only : errMsg => shr_log_errMsg + use FatesGlobals, only : endrun => fates_endrun + use FatesGlobals, only : fates_log + + implicit none + private + + ! These are flags that specify how the averaging window works. + ! Exponential moving average (EMA) windows have an arbitrary size and update frequency) + ! and it is technically never reset, it just averages indefinitely. + ! But hourly, six-hourly, daily, monthly and yearly fixed windows have pre-set + ! window sizes associated with their namesake, and more importantly, they + ! are zero'd at the beginning of the interval, and get equal average weighting + ! over their construction period. + + + integer, public, parameter :: moving_ema_window = 0 ! (exponential moving average) + integer, public, parameter :: fixed_window = 1 + + ! This type defines a type of mean. It does not + ! define the variable, but it defines how + ! often it is updated, how long its + ! memory period is, and if it should be zero'd + ! These are globally defined on the proc. + + type, public :: rmean_def_type + + real(r8) :: mem_period ! The total integration period (s) + real(r8) :: up_period ! The period between updates (s) + integer :: n_mem ! How many updates per integration period? + integer :: method ! Is this a fixed or moving window? + + contains + + procedure :: define + + end type rmean_def_type + + + ! This holds the time varying information for the mean + ! which is instantiated on sites, patches, and cohorts + + type, public :: rmean_type + + real(r8) :: c_mean ! The current mean value, if this + ! is a moving window, it is the mean. + ! If this is a fixed window, it is only a partial mean + ! as the value uses equal update weights and is not + ! necessarily fully constructed. + + real(r8) :: l_mean ! The latest reportable mean value + ! this value is actually the same + ! as c_mean for moving windows, and for fixed windows + ! it is the mean value when the time integration window + ! last completed. + + integer :: c_index ! The number of values that have + ! been added to the mean so far + ! once this is >= n_mem then + ! the ema weight hits its cap + + ! This points to the global structure that + ! defines the nature of this mean/avg + type(rmean_def_type), pointer :: def_type + + contains + + procedure :: GetMean + procedure :: InitRMean + procedure :: UpdateRMean + procedure :: FuseRMean + procedure :: CopyFromDonor + + end type rmean_type + + + logical, parameter :: debug = .true. + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + + ! Define the time methods that we want to have available to us + + class(rmean_def_type), public, pointer :: ema_24hr ! Exponential moving average - 24hr window + class(rmean_def_type), public, pointer :: fixed_24hr ! Fixed, 24-hour window + class(rmean_def_type), public, pointer :: ema_lpa ! Exponential moving average - leaf photo acclimation + +contains + + + subroutine define(this,mem_period,up_period,method) + + class(rmean_def_type) :: this + + real(r8),intent(in) :: mem_period + real(r8),intent(in) :: up_period + integer,intent(in) :: method + + ! Check the memory and update periods + if(debug) then + if( abs(nint(mem_period/up_period)-mem_period/up_period) > nearzero ) then + write(fates_log(), *) 'While defining a running mean definition' + write(fates_log(), *) 'an update and memory period was specified' + write(fates_log(), *) 'where the update period is not an exact fraction of the period' + write(fates_log(), *) 'mem_period: ',mem_period + write(fates_log(), *) 'up_period: ',up_period + write(fates_log(), *) 'exiting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + this%mem_period = mem_period + this%up_period = up_period + this%method = method + this%n_mem = nint(mem_period/up_period) + + return + end subroutine define + + ! ===================================================================================== + + function GetMean(this) + + class(rmean_type) :: this + real(r8) :: GetMean + + if(this%def_type%method .eq. moving_ema_window) then + if(this%c_index == 0 .and. debug) then + write(fates_log(), *) 'attempting to get a running mean from a variable' + write(fates_log(), *) 'that has not been given a value yet' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + GetMean = this%l_mean + + end function GetMean + + ! ===================================================================================== + + subroutine InitRMean(this,rmean_def,init_value,init_offset) + + class(rmean_type) :: this + type(rmean_def_type), target :: rmean_def + real(r8),intent(in),optional :: init_value + real(r8),intent(in),optional :: init_offset + + ! If the initialization happens part-way through a fixed averaging window + ! we need to account for this. The current method moves the position + ! index to match the offset, and then assumes that the init_value provided + ! was a constant over the offset period. + + ! If the first value is offset, such that the we are a portion of the + ! way through the window, we need to account for this. + + ! Point to the averaging type + this%def_type => rmean_def + + if(this%def_type%method .eq. fixed_window) then + + if(debug) then + if(.not.(present(init_offset).and.present(init_value)) )then + write(fates_log(), *) 'when initializing a temporal mean on a fixed window' + write(fates_log(), *) 'there must be an initial value and a time offset' + write(fates_log(), *) 'specified.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Check to see if the offset is an even increment of the update frequency + if( abs(real(nint(init_offset/rmean_def%up_period),r8)-(init_offset/rmean_def%up_period)) > nearzero ) then + write(fates_log(), *) 'when initializing a temporal mean on a fixed window' + write(fates_log(), *) 'the time offset must be an inrement of the update frequency' + write(fates_log(), *) 'offset: ',init_offset + write(fates_log(), *) 'up freq: ',rmean_def%up_period + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(init_offset<-nearzero) then + write(fates_log(), *) 'offset must be positive: ',init_offset + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end if + + this%c_index = modulo(nint(init_offset/rmean_def%up_period),rmean_def%n_mem) + this%c_mean = real(this%c_index,r8)/real(rmean_def%n_mem,r8)*init_value + this%l_mean = init_value + + elseif(this%def_type%method .eq. moving_ema_window) then + + if(present(init_value))then + this%c_mean = init_value + this%l_mean = init_value + this%c_index = 1 + else + this%c_mean = nan + this%l_mean = nan + this%c_index = 0 + end if + + end if + + return + end subroutine InitRMean + + + ! ===================================================================================== + + + subroutine CopyFromDonor(this, donor) + + class(rmean_type) :: this + class(rmean_type),intent(in) :: donor + + if( .not.associated(this%def_type)) then + write(fates_log(), *) 'Attempted to copy over running mean' + write(fates_log(), *) 'info from a donor into a new structure' + write(fates_log(), *) 'but the new structure did not have its' + write(fates_log(), *) 'def_type pointer associated' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + this%c_mean = donor%c_mean + this%l_mean = donor%l_mean + this%c_index = donor%c_index + + + return + end subroutine CopyFromDonor + + + + ! ===================================================================================== + + subroutine UpdateRMean(this, new_value) + + class(rmean_type) :: this + real(r8) :: new_value ! The newest value added to the running mean + real(r8) :: wgt + + if(this%def_type%method.eq.moving_ema_window) then + + this%c_index = min(this%def_type%n_mem,this%c_index + 1) + + if(this%c_index==1) then + this%c_mean = new_value + else + wgt = 1._r8/real(this%c_index,r8) + this%c_mean = this%c_mean*(1._r8-wgt) + wgt*new_value + end if + + this%l_mean = this%c_mean + + else + + ! If the last time we updated we had hit the + ! end of the averaging memory period, and + ! we are not using an indefinite running + ! average, then zero things out + + this%c_index = this%c_index + 1 + wgt = this%def_type%up_period/this%def_type%mem_period + this%c_mean = this%c_mean + new_value*wgt + + if(this%c_index == this%def_type%n_mem) then + this%l_mean = this%c_mean + this%c_mean = 0._r8 + this%c_index = 0 + end if + + + end if + + return + end subroutine UpdateRmean + + ! ===================================================================================== + + subroutine FuseRMean(this,donor,recip_wgt) + + ! Rules for fusion: + ! If both entities have valid means already, then you simply use the + ! weight provided to combine them. + ! If this is a moving average, then update the index to be the larger of + ! the two. + ! if this is a fixed window, check that the index is the same between + ! both. + + + class(rmean_type) :: this + class(rmean_type), pointer :: donor + real(r8),intent(in) :: recip_wgt ! Weighting factor for recipient (0-1) + + if(this%def_type%n_mem .ne. donor%def_type%n_mem) then + write(fates_log(), *) 'memory size is somehow different during fusion' + write(fates_log(), *) 'of two running mean variables: '!,this%name,donor%name + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(this%def_type%method .eq. fixed_window ) then + if (this%c_index .ne. donor%c_index) then + write(fates_log(), *) 'trying to fuse two fixed-window averages' + write(fates_log(), *) 'that are at different points in the window?' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! This last logic clause just simply prevents us from doing math + ! on uninitialized values. If both are unintiailized, then + ! leave the result as uninitialized + if( .not. (donor%c_index==0) ) then + + if(this%c_index==0) then + this%c_mean = donor%c_mean + this%l_mean = donor%l_mean + this%c_index = donor%c_index + else + ! Take the weighted mean between the two + this%c_mean = this%c_mean*recip_wgt + donor%c_mean*(1._r8-recip_wgt) + this%l_mean = this%l_mean*recip_wgt + donor%l_mean*(1._r8-recip_wgt) + ! Update the index to the larger of the two + this%c_index = max(this%c_index,donor%c_index) + end if + + end if + + return + end subroutine FuseRMean + + +end module FatesRunningMeanMod diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 370f3f5d9e..c69b2b8df8 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -1,4 +1,4 @@ -netcdf fates_params_default { +netcdf fates_params_default.c210629_sorted { dimensions: fates_NCWD = 4 ; fates_history_age_bins = 7 ; @@ -9,8 +9,9 @@ dimensions: fates_leafage_class = 1 ; fates_litterclass = 6 ; fates_pft = 12 ; - fates_prt_organs = 6 ; + fates_prt_organs = 4 ; fates_string_length = 60 ; + fates_hlm_pftno = 14 ; variables: double fates_history_ageclass_bin_edges(fates_history_age_bins) ; fates_history_ageclass_bin_edges:units = "yr" ; @@ -24,12 +25,25 @@ variables: double fates_history_sizeclass_bin_edges(fates_history_size_bins) ; fates_history_sizeclass_bin_edges:units = "cm" ; fates_history_sizeclass_bin_edges:long_name = "Lower edges for DBH size class bins used in size-resolved cohort history output" ; + double fates_hydr_htftype_node(fates_hydr_organs) ; + fates_hydr_htftype_node:units = "unitless" ; + fates_hydr_htftype_node:long_name = "Switch that defines the hydraulic transfer functions for each organ." ; + fates_hydr_htftype_node:possible_values = "1: Christofferson et al. 2016 (TFS); 2: Van Genuchten 1980" ; + double fates_prt_organ_id(fates_prt_organs) ; + fates_prt_organ_id:units = "index, unitless" ; + fates_prt_organ_id:long_name = "This is the global index the organ in this file is associated with in PRTGenericMod.F90" ; char fates_pftname(fates_pft, fates_string_length) ; fates_pftname:units = "unitless - string" ; fates_pftname:long_name = "Description of plant type" ; + char fates_hydr_organname_node(fates_hydr_organs, fates_string_length) ; + fates_hydr_organname_node:units = "unitless - string" ; + fates_hydr_organname_node:long_name = "Name of plant hydraulics organs (DONT CHANGE, order matches media list in FatesHydraulicsMemMod.F90)" ; + char fates_litterclass_name(fates_litterclass, fates_string_length) ; + fates_litterclass_name:units = "unitless - string" ; + fates_litterclass_name:long_name = "Name of the litter classes, for variables associated with dimension fates_litterclass" ; char fates_prt_organ_name(fates_prt_organs, fates_string_length) ; fates_prt_organ_name:units = "unitless - string" ; - fates_prt_organ_name:long_name = "Plant organ name (order must match PRTGenericMod.F90)" ; + fates_prt_organ_name:long_name = "Name of plant organs (order must match PRTGenericMod.F90)" ; double fates_alloc_storage_cushion(fates_pft) ; fates_alloc_storage_cushion:units = "fraction" ; fates_alloc_storage_cushion:long_name = "maximum size of storage C pool, relative to maximum size of leaf C pool" ; @@ -121,12 +135,30 @@ variables: fates_allom_stmode:units = "index" ; fates_allom_stmode:long_name = "storage allometry function index." ; fates_allom_stmode:possible_values = "1: target storage proportional to trimmed maximum leaf biomass." ; + double fates_allom_zroot_k(fates_pft) ; + fates_allom_zroot_k:units = "unitless" ; + fates_allom_zroot_k:long_name = "scale coefficient of logistic rooting depth model" ; + double fates_allom_zroot_max_dbh(fates_pft) ; + fates_allom_zroot_max_dbh:units = "cm" ; + fates_allom_zroot_max_dbh:long_name = "dbh at which a plant reaches the maximum value for its maximum rooting depth" ; + double fates_allom_zroot_max_z(fates_pft) ; + fates_allom_zroot_max_z:units = "m" ; + fates_allom_zroot_max_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_max_dbh. note: max_z=min_z=large, sets rooting depth to soil depth" ; + double fates_allom_zroot_min_dbh(fates_pft) ; + fates_allom_zroot_min_dbh:units = "cm" ; + fates_allom_zroot_min_dbh:long_name = "dbh at which the maximum rooting depth for a recruit is defined" ; + double fates_allom_zroot_min_z(fates_pft) ; + fates_allom_zroot_min_z:units = "m" ; + fates_allom_zroot_min_z:long_name = "the maximum rooting depth defined at dbh = fates_allom_zroot_min_dbh. note: max_z=min_z=large, sets rooting depth to soil depth" ; double fates_branch_turnover(fates_pft) ; fates_branch_turnover:units = "yr" ; fates_branch_turnover:long_name = "turnover time of branches" ; double fates_c2b(fates_pft) ; fates_c2b:units = "ratio" ; fates_c2b:long_name = "Carbon to biomass multiplier of bulk structural tissues" ; + double fates_dev_arbitrary_pft(fates_pft) ; + fates_dev_arbitrary_pft:units = "unknown" ; + fates_dev_arbitrary_pft:long_name = "Unassociated pft dimensioned free parameter that developers can use for testing arbitrary new hypotheses" ; double fates_displar(fates_pft) ; fates_displar:units = "unitless" ; fates_displar:long_name = "Ratio of displacement height to canopy top height" ; @@ -208,6 +240,10 @@ variables: double fates_hydr_fcap_node(fates_hydr_organs, fates_pft) ; fates_hydr_fcap_node:units = "unitless" ; fates_hydr_fcap_node:long_name = "fraction of non-residual water that is capillary in source" ; + double fates_hydr_k_lwp(fates_pft) ; + fates_hydr_k_lwp:units = "unitless" ; + fates_hydr_k_lwp:long_name = "inner leaf humidity scaling coefficient" ; + fates_hydr_k_lwp:possible_values = "0: turns off leaf humidity effects on conductance. 1-10 activates humidity effects" ; double fates_hydr_kmax_node(fates_hydr_organs, fates_pft) ; fates_hydr_kmax_node:units = "kg/MPa/m/s" ; fates_hydr_kmax_node:long_name = "maximum xylem conductivity per unit conducting xylem area" ; @@ -241,6 +277,15 @@ variables: double fates_hydr_thetas_node(fates_hydr_organs, fates_pft) ; fates_hydr_thetas_node:units = "cm3/cm3" ; fates_hydr_thetas_node:long_name = "saturated water content" ; + double fates_hydr_vg_alpha_node(fates_hydr_organs, fates_pft) ; + fates_hydr_vg_alpha_node:units = "MPa-1" ; + fates_hydr_vg_alpha_node:long_name = "(used if hydr_htftype_node = 2), capillary length parameter in van Genuchten model" ; + double fates_hydr_vg_m_node(fates_hydr_organs, fates_pft) ; + fates_hydr_vg_m_node:units = "unitless" ; + fates_hydr_vg_m_node:long_name = "(used if hydr_htftype_node = 2),m in van Genuchten 1980 model, 2nd pore size distribution parameter" ; + double fates_hydr_vg_n_node(fates_hydr_organs, fates_pft) ; + fates_hydr_vg_n_node:units = "unitless" ; + fates_hydr_vg_n_node:long_name = "(used if hydr_htftype_node = 2),n in van Genuchten 1980 model, pore size distribution parameter" ; double fates_leaf_c3psn(fates_pft) ; fates_leaf_c3psn:units = "flag" ; fates_leaf_c3psn:long_name = "Photosynthetic pathway (1=c3, 0=c4)" ; @@ -349,6 +394,9 @@ variables: double fates_nfix2(fates_pft) ; fates_nfix2:units = "NA" ; fates_nfix2:long_name = "place-holder for future n-fixation parameter (NOT IMPLEMENTED)" ; + double fates_nitr_store_ratio(fates_pft) ; + fates_nitr_store_ratio:units = "(gN/gN)" ; + fates_nitr_store_ratio:long_name = "ratio of storeable N, to functional N bound in cell structures of leaf,root,sap" ; double fates_phen_cold_size_threshold(fates_pft) ; fates_phen_cold_size_threshold:units = "cm" ; fates_phen_cold_size_threshold:long_name = "the dbh size above which will lead to phenology-related stem and leaf drop" ; @@ -367,6 +415,9 @@ variables: double fates_phenflush_fraction(fates_pft) ; fates_phenflush_fraction:units = "fraction" ; fates_phenflush_fraction:long_name = "Upon bud-burst, the maximum fraction of storage carbon used for flushing leaves" ; + double fates_phos_store_ratio(fates_pft) ; + fates_phos_store_ratio:units = "(gP/gP)" ; + fates_phos_store_ratio:long_name = "ratio of storeable P, to functional P bound in cell structures of leaf,root,sap" ; double fates_prescribed_mortality_canopy(fates_pft) ; fates_prescribed_mortality_canopy:units = "1/yr" ; fates_prescribed_mortality_canopy:long_name = "mortality rate of canopy trees for prescribed physiology mode" ; @@ -381,16 +432,16 @@ variables: fates_prescribed_npp_understory:long_name = "NPP per unit crown area of understory trees for prescribed physiology mode" ; double fates_prescribed_nuptake(fates_pft) ; fates_prescribed_nuptake:units = "fraction" ; - fates_prescribed_nuptake:long_name = "Nitrogen uptake flux as fraction of NPP demand. 0=fully coupled simulation" ; + fates_prescribed_nuptake:long_name = "Prescribed N uptake flux. 0=fully coupled simulation >0=prescribed (experimental)" ; double fates_prescribed_puptake(fates_pft) ; fates_prescribed_puptake:units = "fraction" ; - fates_prescribed_puptake:long_name = "Phosphorus uptake flux as fraction of NPP demand. 0=fully coupled simulation" ; + fates_prescribed_puptake:long_name = "Prescribed P uptake flux. 0=fully coupled simulation, >0=prescribed (experimental)" ; double fates_prescribed_recruitment(fates_pft) ; fates_prescribed_recruitment:units = "n/yr" ; fates_prescribed_recruitment:long_name = "recruitment rate for prescribed physiology mode" ; double fates_prt_alloc_priority(fates_prt_organs, fates_pft) ; fates_prt_alloc_priority:units = "index (0-fates_prt_organs)" ; - fates_prt_alloc_priority:long_name = "Priority order for allocation" ; + fates_prt_alloc_priority:long_name = "Priority order for allocation (C storage=2)" ; double fates_prt_nitr_stoich_p1(fates_prt_organs, fates_pft) ; fates_prt_nitr_stoich_p1:units = "(gN/gC)" ; fates_prt_nitr_stoich_p1:long_name = "nitrogen stoichiometry, parameter 1" ; @@ -491,6 +542,9 @@ variables: double fates_z0mr(fates_pft) ; fates_z0mr:units = "unitless" ; fates_z0mr:long_name = "Ratio of momentum roughness length to canopy top height" ; + double fates_hlm_pft_map(fates_hlm_pftno, fates_pft) ; + fates_hlm_pft_map:units = "area fraction" ; + fates_hlm_pft_map:long_name = "In fixed biogeog mode, fraction of HLM area associated with each FATES PFT" ; double fates_fire_FBD(fates_litterclass) ; fates_fire_FBD:units = "kg Biomass/m3" ; fates_fire_FBD:long_name = "fuel bulk density" ; @@ -542,6 +596,9 @@ variables: double fates_cwd_flig ; fates_cwd_flig:units = "unitless" ; fates_cwd_flig:long_name = "Lignin fraction of coarse woody debris" ; + double fates_dev_arbitrary ; + fates_dev_arbitrary:units = "unknown" ; + fates_dev_arbitrary:long_name = "Unassociated free parameter that developers can use for testing arbitrary new hypotheses" ; double fates_eca_plant_escalar ; fates_eca_plant_escalar:units = "" ; fates_eca_plant_escalar:long_name = "scaling factor for plant fine root biomass to calculate nutrient carrier enzyme abundance (ECA)" ; @@ -635,6 +692,9 @@ variables: double fates_pprodharv10_forest_mean ; fates_pprodharv10_forest_mean:units = "fraction" ; fates_pprodharv10_forest_mean:long_name = "mean harvest mortality proportion of deadstem to 10-yr product (pprodharv10) of all woody PFT types." ; + double fates_maintresp_model ; + fates_maintresp_model:units = "unitless" ; + fates_maintresp_model:long_name = "switch for choosing between maintenance respiration models. 1=Ryan (1991) (NOT USED)" ; double fates_mort_disturb_frac ; fates_mort_disturb_frac:units = "fraction" ; fates_mort_disturb_frac:long_name = "fraction of canopy mortality that results in disturbance (i.e. transfer of area from new to old patch)" ; @@ -671,6 +731,12 @@ variables: double fates_phen_ncolddayslim ; fates_phen_ncolddayslim:units = "days" ; fates_phen_ncolddayslim:long_name = "day threshold exceedance for temperature leaf-drop" ; + double fates_photo_temp_acclim_timescale ; + fates_photo_temp_acclim_timescale:units = "days" ; + fates_photo_temp_acclim_timescale:long_name = "Length of the window for the exponential moving average (ema) of vegetation temperature used in photosynthesis temperature acclimation (NOT USED)" ; + double fates_photo_tempsens_model ; + fates_photo_tempsens_model:units = "unitless" ; + fates_photo_tempsens_model:long_name = "switch for choosing the model that defines the temperature sensitivity of photosynthetic parameters (vcmax, jmax). 1=non-acclimating (NOT USED)" ; double fates_q10_froz ; fates_q10_froz:units = "unitless" ; fates_q10_froz:long_name = "Q10 for frozen-soil respiration rates" ; @@ -680,6 +746,18 @@ variables: double fates_soil_salinity ; fates_soil_salinity:units = "ppt" ; fates_soil_salinity:long_name = "soil salinity used for model when not coupled to dynamic soil salinity" ; + double fates_theta_cj_c3 ; + fates_theta_cj_c3:units = "unitless" ; + fates_theta_cj_c3:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c3 plants" ; + double fates_theta_cj_c4 ; + fates_theta_cj_c4:units = "unitless" ; + fates_theta_cj_c4:long_name = "Empirical curvature parameter for ac, aj photosynthesis co-limitation in c4 plants" ; + double fates_vai_top_bin_width ; + fates_vai_top_bin_width:units = "m2/m2" ; + fates_vai_top_bin_width:long_name = "width in VAI units of uppermost leaf+stem layer scattering element in each canopy layer (NOT USED)" ; + double fates_vai_width_increase_factor ; + fates_vai_width_increase_factor:units = "unitless" ; + fates_vai_width_increase_factor:long_name = "factor by which each leaf+stem scattering element increases in VAI width (1 = uniform spacing) (NOT USED)" ; // global attributes: :history = "This parameter file is maintained in version control\nSee https://github.com/NGEET/fates/blob/master/parameter_files/fates_params_default.cdl \nFor changes, use git blame \n" ; @@ -691,9 +769,13 @@ data: fates_history_height_bin_edges = 0, 0.1, 0.3, 1, 3, 10 ; - fates_history_sizeclass_bin_edges = 0, 5, 10, 15, 20, 30, 40, 50, 60, 70, + fates_history_sizeclass_bin_edges = 0, 5, 10, 15, 20, 30, 40, 50, 60, 70, 80, 90, 100 ; + fates_hydr_htftype_node = 1, 1, 1, 1 ; + + fates_prt_organ_id = 1, 2, 3, 6 ; + fates_pftname = "broadleaf_evergreen_tropical_tree ", "needleleaf_evergreen_extratrop_tree ", @@ -708,30 +790,42 @@ data: "cool_c3_grass ", "c4_grass " ; + fates_hydr_organname_node = + "leaf ", + "stem ", + "transporting root ", + "absorbing root " ; + + fates_litterclass_name = + "twig ", + "small branch ", + "large branch ", + "trunk ", + "dead leaves ", + "live grass " ; + fates_prt_organ_name = "leaf ", "fine root ", "sapwood ", - "storage ", - "reproduction ", "structure " ; - fates_alloc_storage_cushion = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, + fates_alloc_storage_cushion = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2 ; - fates_allom_agb1 = 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, + fates_allom_agb1 = 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, 0.06896, 0.01, 0.01, 0.01 ; - fates_allom_agb2 = 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, + fates_allom_agb2 = 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572, 0.572 ; - fates_allom_agb3 = 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, + fates_allom_agb3 = 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94, 1.94 ; - fates_allom_agb4 = 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, + fates_allom_agb4 = 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931, 0.931 ; - fates_allom_agb_frac = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, + fates_allom_agb_frac = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6 ; fates_allom_amode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; @@ -740,30 +834,30 @@ data: fates_allom_cmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_allom_d2bl1 = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, + fates_allom_d2bl1 = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07 ; - fates_allom_d2bl2 = 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, + fates_allom_d2bl2 = 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 1.3 ; - fates_allom_d2bl3 = 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, + fates_allom_d2bl3 = 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55 ; - fates_allom_d2ca_coefficient_max = 0.6568464, 0.6568464, 0.6568464, - 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464, + fates_allom_d2ca_coefficient_max = 0.6568464, 0.6568464, 0.6568464, + 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464, 0.6568464 ; - fates_allom_d2ca_coefficient_min = 0.3381119, 0.3381119, 0.3381119, - 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119, + fates_allom_d2ca_coefficient_min = 0.3381119, 0.3381119, 0.3381119, + 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119, 0.3381119 ; - fates_allom_d2h1 = 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, + fates_allom_d2h1 = 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64, 0.64 ; - fates_allom_d2h2 = 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, + fates_allom_d2h2 = 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37, 0.37 ; - fates_allom_d2h3 = -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, + fates_allom_d2h3 = -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9, -999.9 ; fates_allom_dbh_maxheight = 90, 90, 90, 90, 90, 90, 3, 3, 2, 0.35, 0.35, 0.35 ; @@ -776,37 +870,52 @@ data: fates_allom_l2fr = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_allom_la_per_sa_int = 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, + fates_allom_la_per_sa_int = 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 ; fates_allom_la_per_sa_slp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_allom_lmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_allom_sai_scaler = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + fates_allom_sai_scaler = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 ; fates_allom_smode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; fates_allom_stmode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; + fates_allom_zroot_k = 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10, 10 ; + + fates_allom_zroot_max_dbh = 100, 100, 100, 100, 100, 100, 2, 2, 2, 2, 2, 2 ; + + fates_allom_zroot_max_z = 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100 ; + + fates_allom_zroot_min_dbh = 1, 1, 1, 2.5, 2.5, 2.5, 0.1, 0.1, 0.1, 0.1, 0.1, + 0.1 ; + + fates_allom_zroot_min_z = 100, 100, 100, 100, 100, 100, 100, 100, 100, 100, + 100, 100 ; + fates_branch_turnover = 150, 150, 150, 150, 150, 150, 150, 150, 150, 0, 0, 0 ; fates_c2b = 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 ; - fates_displar = 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, + fates_dev_arbitrary_pft = _, _, _, _, _, _, _, _, _, _, _, _ ; + + fates_displar = 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67 ; - fates_eca_alpha_ptase = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + fates_eca_alpha_ptase = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; - fates_eca_decompmicc = 280, 280, 280, 280, 280, 280, 280, 280, 280, 280, + fates_eca_decompmicc = 280, 280, 280, 280, 280, 280, 280, 280, 280, 280, 280, 280 ; - fates_eca_km_nh4 = 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, + fates_eca_km_nh4 = 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14 ; - fates_eca_km_no3 = 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, + fates_eca_km_no3 = 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27 ; fates_eca_km_p = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 ; @@ -815,28 +924,28 @@ data: fates_eca_lambda_ptase = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_eca_vmax_nh4 = 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, + fates_eca_vmax_nh4 = 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07 ; - fates_eca_vmax_no3 = 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, + fates_eca_vmax_no3 = 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08 ; - fates_eca_vmax_p = 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, + fates_eca_vmax_p = 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09 ; - fates_eca_vmax_ptase = 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, + fates_eca_vmax_ptase = 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09 ; - fates_fire_alpha_SH = 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, + fates_fire_alpha_SH = 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2 ; - fates_fire_bark_scaler = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, + fates_fire_bark_scaler = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07 ; - fates_fire_crown_depth_frac = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.95, 0.95, + fates_fire_crown_depth_frac = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.95, 0.95, 0.95, 1, 1, 1 ; - fates_fire_crown_kill = 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, + fates_fire_crown_kill = 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, 0.775, 0.775 ; fates_fnrt_prof_a = 7, 7, 7, 7, 6, 6, 7, 7, 7, 11, 11, 11 ; @@ -847,16 +956,16 @@ data: fates_fr_fcel = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; - fates_fr_flab = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + fates_fr_flab = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25 ; - fates_fr_flig = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + fates_fr_flig = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25 ; - fates_grperc = 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, + fates_grperc = 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11 ; - fates_hydr_avuln_gs = 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, + fates_hydr_avuln_gs = 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5, 2.5 ; fates_hydr_avuln_node = @@ -877,40 +986,42 @@ data: 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0.08, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + fates_hydr_k_lwp = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; + fates_hydr_kmax_node = -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999, -999 ; - fates_hydr_p50_gs = -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, + fates_hydr_p50_gs = -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5, -1.5 ; fates_hydr_p50_node = - -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, - -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, - -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, - -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, + -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25, -2.25 ; - fates_hydr_p_taper = 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, + fates_hydr_p_taper = 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333, 0.333 ; fates_hydr_pinot_node = - -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, + -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, -1.465984, - -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, + -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, - -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, + -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, -1.22807, - -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, + -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478, -1.043478 ; fates_hydr_pitlp_node = - -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, + -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.67, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, -1.4, @@ -922,10 +1033,10 @@ data: 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11 ; - fates_hydr_rfrac_stem = 0.625, 0.625, 0.625, 0.625, 0.625, 0.625, 0.625, + fates_hydr_rfrac_stem = 0.625, 0.625, 0.625, 0.625, 0.625, 0.625, 0.625, 0.625, 0.625, 0.625, 0.625, 0.625 ; - fates_hydr_rs2 = 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, + fates_hydr_rs2 = 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001, 0.0001 ; fates_hydr_srl = 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25, 25 ; @@ -936,81 +1047,103 @@ data: 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75 ; + fates_hydr_vg_alpha_node = + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005, + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005, + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005, + 0.0005, 0.0005, 0.0005, 0.0005, 0.0005, 0.005, 0.005, 0.005, 0.005, 0.005, + 0.005, 0.005 ; + + fates_hydr_vg_m_node = + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; + + fates_hydr_vg_n_node = + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2 ; + fates_leaf_c3psn = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0 ; - fates_leaf_clumping_index = 0.85, 0.85, 0.8, 0.85, 0.85, 0.9, 0.85, 0.9, + fates_leaf_clumping_index = 0.85, 0.85, 0.8, 0.85, 0.85, 0.9, 0.85, 0.9, 0.9, 0.75, 0.75, 0.75 ; - fates_leaf_diameter = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, + fates_leaf_diameter = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04 ; - fates_leaf_jmaxha = 43540, 43540, 43540, 43540, 43540, 43540, 43540, 43540, + fates_leaf_jmaxha = 43540, 43540, 43540, 43540, 43540, 43540, 43540, 43540, 43540, 43540, 43540, 43540 ; - fates_leaf_jmaxhd = 152040, 152040, 152040, 152040, 152040, 152040, 152040, + fates_leaf_jmaxhd = 152040, 152040, 152040, 152040, 152040, 152040, 152040, 152040, 152040, 152040, 152040, 152040 ; - fates_leaf_jmaxse = 495, 495, 495, 495, 495, 495, 495, 495, 495, 495, 495, + fates_leaf_jmaxse = 495, 495, 495, 495, 495, 495, 495, 495, 495, 495, 495, 495 ; fates_leaf_long = 1.5, 4, 1, 1.5, 1, 1, 1.5, 1, 1, 1, 1, 1 ; - fates_leaf_slamax = 0.0954, 0.0954, 0.0954, 0.0954, 0.0954, 0.0954, 0.012, + fates_leaf_slamax = 0.0954, 0.0954, 0.0954, 0.0954, 0.0954, 0.0954, 0.012, 0.03, 0.03, 0.03, 0.03, 0.03 ; - fates_leaf_slatop = 0.012, 0.01, 0.024, 0.012, 0.03, 0.03, 0.012, 0.03, + fates_leaf_slatop = 0.012, 0.01, 0.024, 0.012, 0.03, 0.03, 0.012, 0.03, 0.03, 0.03, 0.03, 0.03 ; - fates_leaf_stomatal_intercept = 10000, 10000, 10000, 10000, 10000, 10000, + fates_leaf_stomatal_intercept = 10000, 10000, 10000, 10000, 10000, 10000, 10000, 10000, 10000, 10000, 10000, 40000 ; fates_leaf_stomatal_slope_ballberry = 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8 ; - fates_leaf_stomatal_slope_medlyn = 4.1, 2.3, 2.3, 4.1, 4.4, 4.4, 4.7, 4.7, + fates_leaf_stomatal_slope_medlyn = 4.1, 2.3, 2.3, 4.1, 4.4, 4.4, 4.7, 4.7, 4.7, 2.2, 5.3, 1.6 ; - fates_leaf_stor_priority = 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, + fates_leaf_stor_priority = 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8 ; fates_leaf_vcmax25top = 50, 65, 39, 62, 41, 58, 62, 54, 54, 78, 78, 78 ; - fates_leaf_vcmaxha = 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330, + fates_leaf_vcmaxha = 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330, 65330 ; - fates_leaf_vcmaxhd = 149250, 149250, 149250, 149250, 149250, 149250, 149250, + fates_leaf_vcmaxhd = 149250, 149250, 149250, 149250, 149250, 149250, 149250, 149250, 149250, 149250, 149250, 149250 ; - fates_leaf_vcmaxse = 485, 485, 485, 485, 485, 485, 485, 485, 485, 485, 485, + fates_leaf_vcmaxse = 485, 485, 485, 485, 485, 485, 485, 485, 485, 485, 485, 485 ; - fates_leaf_xl = 0.1, 0.01, 0.01, 0.1, 0.01, 0.25, 0.01, 0.25, 0.25, -0.3, - -0.3, -0.3 ; + fates_leaf_xl = 0.32, 0.01, 0.01, 0.32, 0.2, 0.59, 0.32, 0.59, 0.59, -0.23, + -0.23, -0.23 ; fates_lf_fcel = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; - fates_lf_flab = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + fates_lf_flab = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25 ; - fates_lf_flig = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + fates_lf_flig = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25 ; - fates_maintresp_reduction_curvature = 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, + fates_maintresp_reduction_curvature = 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01 ; - fates_maintresp_reduction_intercept = 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1 ; + fates_maintresp_reduction_intercept = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_mort_bmort = 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, + fates_mort_bmort = 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014, 0.014 ; - fates_mort_freezetol = 2.5, -55, -80, -30, 2.5, -30, -60, -10, -80, -80, + fates_mort_freezetol = 2.5, -55, -80, -30, 2.5, -30, -60, -10, -80, -80, -20, 2.5 ; - fates_mort_hf_flc_threshold = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + fates_mort_hf_flc_threshold = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; - fates_mort_hf_sm_threshold = 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, + fates_mort_hf_sm_threshold = 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06, 1e-06 ; fates_mort_ip_age_senescence = _, _, _, _, _, _, _, _, _, _, _, _ ; @@ -1023,16 +1156,19 @@ data: fates_mort_scalar_coldstress = 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3 ; - fates_mort_scalar_cstarvation = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, + fates_mort_scalar_cstarvation = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6 ; - fates_mort_scalar_hydrfailure = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, + fates_mort_scalar_hydrfailure = 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6 ; fates_nfix1 = _, _, _, _, _, _, _, _, _, _, _, _ ; fates_nfix2 = _, _, _, _, _, _, _, _, _, _, _, _ ; + fates_nitr_store_ratio = 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, + 1.5, 1.5 ; + fates_phen_cold_size_threshold = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_phen_evergreen = 1, 1, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0 ; @@ -1045,98 +1181,87 @@ data: fates_phenflush_fraction = _, _, 0.5, _, 0.5, 0.5, _, 0.5, 0.5, 0.5, 0.5, 0.5 ; - fates_prescribed_mortality_canopy = 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, + fates_phos_store_ratio = 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, + 1.5, 1.5 ; + + fates_prescribed_mortality_canopy = 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194, 0.0194 ; - fates_prescribed_mortality_understory = 0.025, 0.025, 0.025, 0.025, 0.025, + fates_prescribed_mortality_understory = 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025 ; - fates_prescribed_npp_canopy = 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, + fates_prescribed_npp_canopy = 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4 ; - fates_prescribed_npp_understory = 0.03125, 0.03125, 0.03125, 0.03125, + fates_prescribed_npp_understory = 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125 ; - fates_prescribed_nuptake = 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0 ; + fates_prescribed_nuptake = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_prescribed_puptake = 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0 ; + fates_prescribed_puptake = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_prescribed_recruitment = 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, + fates_prescribed_recruitment = 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02 ; fates_prt_alloc_priority = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 ; fates_prt_nitr_stoich_p1 = 0.033, 0.029, 0.04, 0.033, 0.04, 0.04, 0.033, 0.04, 0.04, 0.04, 0.04, 0.04, - 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, + 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, - 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, + 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, - 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, - 1e-08, 1e-08, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, + 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047 ; fates_prt_nitr_stoich_p2 = 0.033, 0.029, 0.04, 0.033, 0.04, 0.04, 0.033, 0.04, 0.04, 0.04, 0.04, 0.04, - 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, + 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, - 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, + 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, - 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, - 1e-08, 1e-08, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, + 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047 ; fates_prt_phos_stoich_p1 = - 0.0033, 0.0029, 0.004, 0.0033, 0.004, 0.004, 0.0033, 0.004, 0.004, 0.004, + 0.0033, 0.0029, 0.004, 0.0033, 0.004, 0.004, 0.0033, 0.004, 0.004, 0.004, 0.004, 0.004, - 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, + 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, - 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, - 1e-09, 1e-09, - 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, + 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, + 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047 ; fates_prt_phos_stoich_p2 = - 0.0033, 0.0029, 0.004, 0.0033, 0.004, 0.004, 0.0033, 0.004, 0.004, 0.004, + 0.0033, 0.0029, 0.004, 0.0033, 0.004, 0.004, 0.0033, 0.004, 0.004, 0.004, 0.004, 0.004, - 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, + 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, - 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, - 1e-09, 1e-09, - 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, + 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, + 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047 ; - fates_recruit_hgt_min = 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 0.75, 0.75, 0.75, + fates_recruit_hgt_min = 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 0.75, 0.75, 0.75, 0.125, 0.125, 0.125 ; - fates_recruit_initd = 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, + fates_recruit_initd = 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2 ; - fates_rholnir = 0.45, 0.35, 0.35, 0.45, 0.45, 0.45, 0.35, 0.45, 0.45, 0.35, - 0.35, 0.35 ; + fates_rholnir = 0.46, 0.41, 0.39, 0.46, 0.41, 0.41, 0.46, 0.41, 0.41, 0.28, + 0.28, 0.28 ; - fates_rholvis = 0.1, 0.07, 0.07, 0.1, 0.1, 0.1, 0.07, 0.1, 0.1, 0.1, 0.1, 0.1 ; + fates_rholvis = 0.11, 0.09, 0.08, 0.11, 0.08, 0.08, 0.11, 0.08, 0.08, 0.05, 0.05, 0.05 ; - fates_rhosnir = 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.53, + fates_rhosnir = 0.49, 0.36, 0.36, 0.49, 0.49, 0.49, 0.49, 0.49, 0.49, 0.53, 0.53, 0.53 ; - fates_rhosvis = 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.31, + fates_rhosvis = 0.21, 0.12, 0.12, 0.21, 0.21, 0.21, 0.21, 0.21, 0.21, 0.31, 0.31, 0.31 ; fates_root_long = 1, 2, 1, 1.5, 1, 1, 1.5, 1, 1, 1, 1, 1 ; @@ -1145,45 +1270,43 @@ data: fates_seed_alloc_mature = 0, 0, 0, 0, 0, 0, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9 ; - fates_seed_dbh_repro_threshold = 150, 90, 90, 90, 90, 90, 3, 3, 2, 1.47, + fates_seed_dbh_repro_threshold = 150, 90, 90, 90, 90, 90, 3, 3, 2, 1.47, 1.47, 1.47 ; - fates_seed_decay_rate = 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, + fates_seed_decay_rate = 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51, 0.51 ; - fates_seed_germination_rate = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + fates_seed_germination_rate = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5 ; fates_seed_suppl = 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_senleaf_long_fdrought = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_smpsc = -255000, -255000, -255000, -255000, -255000, -255000, -255000, + fates_smpsc = -255000, -255000, -255000, -255000, -255000, -255000, -255000, -255000, -255000, -255000, -255000, -255000 ; - fates_smpso = -66000, -66000, -66000, -66000, -66000, -66000, -66000, + fates_smpso = -66000, -66000, -66000, -66000, -66000, -66000, -66000, -66000, -66000, -66000, -66000, -66000 ; - fates_taulnir = 0.25, 0.1, 0.1, 0.25, 0.25, 0.25, 0.1, 0.25, 0.25, 0.34, - 0.34, 0.34 ; + fates_taulnir = 0.33, 0.32, 0.42, 0.33, 0.43, 0.43, 0.33, 0.43, 0.43, 0.4, + 0.4, 0.4 ; - fates_taulvis = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, + fates_taulvis = 0.06, 0.04, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.05, 0.05, 0.05 ; - fates_tausnir = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, + fates_tausnir = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.25, 0.25, 0.25 ; - fates_tausvis = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, + fates_tausvis = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.12, 0.12, 0.12 ; - fates_trim_inc = 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, + fates_trim_inc = 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03, 0.03 ; fates_trim_limit = 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3 ; fates_turnover_carb_retrans = - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, @@ -1193,28 +1316,40 @@ data: 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_turnover_phos_retrans = 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_turnover_retrans_mode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_wood_density = 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, + fates_wood_density = 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7 ; fates_woody = 1, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 0 ; - fates_z0mr = 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, + fates_z0mr = 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055, 0.055 ; + fates_hlm_pft_map = + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1 ; + fates_fire_FBD = 15.4, 16.8, 19.6, 999, 4, 4 ; fates_fire_low_moisture_Coeff = 1.12, 1.09, 0.98, 0.8, 1.15, 1.15 ; @@ -1249,6 +1384,8 @@ data: fates_cwd_flig = 0.24 ; + fates_dev_arbitrary = _ ; + fates_eca_plant_escalar = 1.25e-05 ; fates_fire_active_crown_fire = 0 ; @@ -1311,6 +1448,8 @@ data: fates_pprodharv10_forest_mean = 0.8125 ; + fates_maintresp_model = 1 ; + fates_mort_disturb_frac = 1 ; fates_mort_understorey_death = 0.55983 ; @@ -1335,9 +1474,21 @@ data: fates_phen_ncolddayslim = 5 ; + fates_photo_temp_acclim_timescale = 30 ; + + fates_photo_tempsens_model = 1 ; + fates_q10_froz = 1.5 ; fates_q10_mr = 1.5 ; fates_soil_salinity = 0.4 ; + + fates_theta_cj_c3 = 0.999 ; + + fates_theta_cj_c4 = 0.999 ; + + fates_vai_top_bin_width = 1 ; + + fates_vai_width_increase_factor = 1 ; } diff --git a/parameter_files/patch_default_bciopt224.xml b/parameter_files/patch_default_bciopt224.xml new file mode 100644 index 0000000000..bfcc288efa --- /dev/null +++ b/parameter_files/patch_default_bciopt224.xml @@ -0,0 +1,52 @@ + + + This parameter dataset was created by Ryan Knox rgknox@lbl.gov. Please contact if using in published work. The calibration uses the following datasets: [1] Ely et al. 2019. Leaf mass area, Panama. NGEE-Tropics data collection.http://dx.doi.org/10.15486/ngt/1411973 and [2] Condit et al. 2019. Complete data from the Barro Colorado 50-ha plot. https://doi.org/10.15146/5xcp-0d46. [3] Koven et al. 2019. Benchmarking and parameter sensitivity of physiological and vegetation dynamics using the functionally assembled terrestrial ecosystem simulator. Biogeosciences. The ECA nutrient aquisition parmeters are unconstrained, the file output naming convention vmn6phi is shorthand for vmax for nitrogen uptake is order e-6 and for phosphorus is excessively high. These parameters were calibrated with the special fates modification in main/EDTypesMod.F90: nclmax = 3 + fates_params_default.cdl + fates_params_opt224_vmn6phi_080621.cdl + 1 + + 0 + 0 + 1,1,3,4 + 0.03347526,0.024,1e-08,0.0047 + 0.03347526,0.024,1e-08,0.0047 + 0.025,0,0,0 + 0.45,0.25,0,0 + 0.8012471 + 30.94711 + 0.0673 + 0.976 + -9 + -9 + 3 + 0.1266844 + 1.281329 + -9 + 0.768654 + 0.768654 + 57.6 + 0.74 + 21.6 + 200 + 2 + 5 + 0.4863088 + 3 + 3e-06 + 3e-06 + 3e-07 + 3e-08 + 0.03991654 + 0.01995827 + 0.01303514 + 0.02955703 + 3 + 3 + 0.04680188 + 0.001 + 0.8374751 + -1 + 0.5 + 1 + + diff --git a/parameter_files/patch_default_e3smtest.xml b/parameter_files/patch_default_e3smtest.xml new file mode 100644 index 0000000000..01111c2200 --- /dev/null +++ b/parameter_files/patch_default_e3smtest.xml @@ -0,0 +1,10 @@ + + + fates_params_default.cdl + fates_params_e3smtest.cdl + 1,2,3,4,5,6,7,8,9,10,11,12 + + 0,0,0,0,0,0,0,0,0,0,0,0 + 0,0,0,0,0,0,0,0,0,0,0,0 + + diff --git a/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 index ccefa67924..5617d71e5d 100644 --- a/parteh/PRTAllometricCNPMod.F90 +++ b/parteh/PRTAllometricCNPMod.F90 @@ -27,7 +27,8 @@ module PRTAllometricCNPMod use PRTGenericMod , only : struct_organ use PRTGenericMod , only : all_organs use PRTGenericMod , only : prt_cnp_flex_allom_hyp - + use PRTGenericMod , only : StorageNutrientTarget + use FatesAllometryMod , only : bleaf use FatesAllometryMod , only : bsap_allom use FatesAllometryMod , only : bfineroot @@ -94,9 +95,9 @@ module PRTAllometricCNPMod ! Global identifiers for the two stoichiometry values - integer, parameter :: stoich_growth_min = 1 ! Flag for stoichiometry associated with + integer,public, parameter :: stoich_growth_min = 1 ! Flag for stoichiometry associated with ! minimum needed for growth - integer, parameter :: stoich_max = 2 ! Flag for stoichiometry associated with + integer,public, parameter :: stoich_max = 2 ! Flag for stoichiometry associated with ! maximum for that organ @@ -146,11 +147,12 @@ module PRTAllometricCNPMod integer, public, parameter :: acnp_bc_in_id_ctrim = 2 ! Index for the canopy trim function integer, public, parameter :: acnp_bc_in_id_lstat = 3 ! phenology status logical integer, public, parameter :: acnp_bc_in_id_netdc = 4 ! Index for the net daily C input BC - integer, public, parameter :: acnp_bc_in_id_netdn = 5 ! Index for the net daily N input BC - integer, public, parameter :: acnp_bc_in_id_netdp = 6 ! Index for the net daily P input BC + integer, public, parameter :: acnp_bc_in_id_netdnh4 = 5 ! Index for the net daily NH4 input BC + integer, public, parameter :: acnp_bc_in_id_netdno3 = 6 ! Index for the net daily NO3 input BC + integer, public, parameter :: acnp_bc_in_id_netdp = 7 ! Index for the net daily P input BC ! 0=leaf off, 1=leaf on - integer, parameter :: num_bc_in = 6 + integer, parameter :: num_bc_in = 7 ! ------------------------------------------------------------------------------------- ! Output Boundary Indices (These are public) @@ -159,14 +161,14 @@ module PRTAllometricCNPMod integer, public, parameter :: acnp_bc_out_id_cefflux = 1 ! Daily exudation of C [kg] integer, public, parameter :: acnp_bc_out_id_nefflux = 2 ! Daily exudation of N [kg] integer, public, parameter :: acnp_bc_out_id_pefflux = 3 ! Daily exudation of P [kg] - integer, public, parameter :: acnp_bc_out_id_ngrow = 4 ! N needed to match C growth at low N/C - integer, public, parameter :: acnp_bc_out_id_nmax = 5 ! N needed to match C growth at max N/C - integer, public, parameter :: acnp_bc_out_id_pgrow = 6 ! P needed to match C growth at low P/C - integer, public, parameter :: acnp_bc_out_id_pmax = 7 ! P needed to match C growth at max P/C + integer, public, parameter :: acnp_bc_out_id_nneed = 4 ! N need [kgN] + integer, public, parameter :: acnp_bc_out_id_pneed = 5 ! P need [kgP] - integer, parameter :: num_bc_out = 7 ! Total number of + integer, parameter :: num_bc_out = 5 ! Total number of + + ! ------------------------------------------------------------------------------------- ! Define the size of the coorindate vector. For this hypothesis, there is only ! one pool per each species x organ combination, except for leaves (WHICH HAVE AGE) @@ -207,13 +209,13 @@ module PRTAllometricCNPMod procedure :: DailyPRT => DailyPRTAllometricCNP procedure :: FastPRT => FastPRTAllometricCNP - + procedure :: GetNutrientTarget => GetNutrientTargetCNP + ! Extended functions specific to Allometric CNP procedure :: CNPPrioritizedReplacement procedure :: CNPStatureGrowth procedure :: CNPAllocateRemainder procedure :: GetDeficit - procedure :: GetNutrientTarget procedure :: GrowEquivC procedure :: NAndPToMatchC end type cnp_allom_prt_vartypes @@ -234,7 +236,7 @@ module PRTAllometricCNPMod logical, parameter :: debug = .false. public :: InitPRTGlobalAllometricCNP - + contains @@ -337,10 +339,8 @@ subroutine DailyPRTAllometricCNP(this) real(r8),pointer :: c_efflux ! Total plant efflux of carbon (kgC) real(r8),pointer :: n_efflux ! Total plant efflux of nitrogen (kgN) real(r8),pointer :: p_efflux ! Total plant efflux of phosphorus (kgP) - real(r8),pointer :: n_grow ! N needed to match C stature growth (kgN) - real(r8),pointer :: n_max ! N needed to reach max stoich at final C (kgN) - real(r8),pointer :: p_grow ! P needed to match C stature growth (kgP) - real(r8),pointer :: p_max ! P needed to reach max stoich at final C (kgP) + real(r8),pointer :: n_need ! N need (algorithm dependant) (kgN) + real(r8),pointer :: p_need ! P need (algorithm dependant) (kgP) real(r8),pointer :: growth_r ! Total plant growth respiration this step (kgC) ! These are pointers to the state variables, rearranged in organ dimensioned @@ -357,7 +357,7 @@ subroutine DailyPRTAllometricCNP(this) real(r8) :: bgw_c_target,bgw_dcdd_target real(r8) :: sapw_area integer :: cnp_limiter - + real(r8) :: max_store_n ! These arrays hold various support variables dimensioned by organ ! Zero suffix indicates the initial state values at the beginning of the routine ! _unl suffix indicates values used for tracking nutrient need (ie unlimited) @@ -374,21 +374,14 @@ subroutine DailyPRTAllometricCNP(this) real(r8) :: p_gain0 real(r8) :: maint_r_def0 - ! These are mass gains and fluxes used for the N&P non-limiting case - real(r8) :: c_gain_unl - real(r8) :: n_gain_unl,n_gain_unl0 - real(r8) :: p_gain_unl,p_gain_unl0 - ! Used for mass checking, total mass allocated based ! on change in the states, should match gain0's real(r8) :: allocated_c real(r8) :: allocated_n real(r8) :: allocated_p - + real(r8) :: target_n,target_p real(r8) :: sum_c ! error checking sum - logical, parameter :: prt_assess_nutr_need = .true. - ! integrator variables ! Copy the input only boundary conditions into readable local variables @@ -397,7 +390,9 @@ subroutine DailyPRTAllometricCNP(this) ! for checking and resetting if needed ! ----------------------------------------------------------------------------------- c_gain = this%bc_in(acnp_bc_in_id_netdc)%rval; c_gain0 = c_gain - n_gain = this%bc_in(acnp_bc_in_id_netdn)%rval; n_gain0 = n_gain + n_gain = this%bc_in(acnp_bc_in_id_netdnh4)%rval + & + this%bc_in(acnp_bc_in_id_netdno3)%rval + n_gain0 = n_gain p_gain = this%bc_in(acnp_bc_in_id_netdp)%rval; p_gain0 = p_gain canopy_trim = this%bc_in(acnp_bc_in_id_ctrim)%rval ipft = this%bc_in(acnp_bc_in_id_pft)%ival @@ -406,27 +401,15 @@ subroutine DailyPRTAllometricCNP(this) c_efflux => this%bc_out(acnp_bc_out_id_cefflux)%rval; c_efflux = 0._r8 n_efflux => this%bc_out(acnp_bc_out_id_nefflux)%rval; n_efflux = 0._r8 p_efflux => this%bc_out(acnp_bc_out_id_pefflux)%rval; p_efflux = 0._r8 - n_grow => this%bc_out(acnp_bc_out_id_ngrow)%rval; n_grow = fates_unset_r8 - n_max => this%bc_out(acnp_bc_out_id_nmax)%rval; n_max = fates_unset_r8 - p_grow => this%bc_out(acnp_bc_out_id_pgrow)%rval; p_grow = fates_unset_r8 - p_max => this%bc_out(acnp_bc_out_id_pmax)%rval; p_max = fates_unset_r8 + n_need => this%bc_out(acnp_bc_out_id_nneed)%rval; n_need = fates_unset_r8 + p_need => this%bc_out(acnp_bc_out_id_pneed)%rval; p_need = fates_unset_r8 + ! In/out boundary conditions maint_r_def => this%bc_inout(acnp_bc_inout_id_rmaint_def)%rval; maint_r_def0 = maint_r_def dbh => this%bc_inout(acnp_bc_inout_id_dbh)%rval; dbh0 = dbh - ! Initialize fields used for assessing N/P needs - ! (these run the allocation scheme with ample - ! N+P, to determine how much - ! availability was needed (in hindsight) drive - ! non-limited C allocaiton. - - c_gain_unl = c_gain - n_gain_unl = abs(10._r8*c_gain) - n_gain_unl0 = n_gain_unl - p_gain_unl = abs(10._r8*c_gain) - p_gain_unl0 = p_gain_unl ! If more than 1 leaf age bin is present, this ! call advances leaves in their age, but does @@ -478,73 +461,6 @@ subroutine DailyPRTAllometricCNP(this) end do - assess_need_if: if(prt_assess_nutr_need) then - - ! =================================================================================== - ! Step 1. Prioritized allocation to replace tissues from turnover, and/or pay - ! any un-paid maintenance respiration from storage. - ! =================================================================================== - - call this%CNPPrioritizedReplacement(maint_r_def, c_gain_unl, n_gain_unl, p_gain_unl, & - state_c, state_n, state_p, target_c) - - ! Uncomment to see intermediate n and p needs - !n_grow = n_gain_unl0 - n_gain_unl - !p_grow = p_gain_unl0 - p_gain_unl - - ! =================================================================================== - ! Step 2. Grow out the stature of the plant by allocating to tissues beyond - ! current targets. - ! Attempts have been made to get all pools and species closest to allometric - ! targets based on prioritized relative demand and allometry functions. - ! =================================================================================== - - call this%CNPStatureGrowth(c_gain_unl, n_gain_unl, p_gain_unl, & - state_c, state_n, state_p, target_c, target_dcdd, cnp_limiter) - - n_grow = max(0._r8,(n_gain_unl0 - n_gain_unl)) - p_grow = max(0._r8,(p_gain_unl0 - p_gain_unl)) - - ! =================================================================================== - ! Step 3. - ! At this point, 1 of the 3 resources (C,N,P) has been used up for stature growth. - ! Allocate the remaining resources, or as a last resort, efflux them. - ! =================================================================================== - - call this%CNPAllocateRemainder(c_gain_unl, n_gain_unl, p_gain_unl, & - state_c, state_n, state_p, c_efflux, n_efflux, p_efflux) - - - n_max = max(n_gain_unl0 - n_efflux,0._r8) - p_max = max(p_gain_unl0 - p_efflux,0._r8) - - - ! We must now reset the state so that we can perform nutrient limited allocation - ! Note: Even if there is more than 1 leaf pool, allocation only modifies - ! the first pool, so no need to reset the others - do i_org = 1,num_organs - - i_var = prt_global%sp_organ_map(organ_list(i_org),carbon12_element) - this%variables(i_var)%val(1) = state_c0(i_org) - state_c(i_org)%ptr => this%variables(i_var)%val(1) - - i_var = prt_global%sp_organ_map(organ_list(i_org),nitrogen_element) - this%variables(i_var)%val(1) = state_n0(i_org) - state_n(i_org)%ptr => this%variables(i_var)%val(1) - - i_var = prt_global%sp_organ_map(organ_list(i_org),phosphorus_element) - this%variables(i_var)%val(1) = state_p0(i_org) - state_p(i_org)%ptr => this%variables(i_var)%val(1) - - end do - - ! Reset the maintenance respiration deficit and the growth - ! respiration - maint_r_def = maint_r_def0 - dbh = dbh0 - - end if assess_need_if - ! =================================================================================== ! Step 0. Transfer all stored nutrient into the daily uptake pool. ! Storage in nutrients does not need to have a buffer like @@ -560,7 +476,6 @@ subroutine DailyPRTAllometricCNP(this) p_gain = p_gain + sum(this%variables(i_var)%val(:)) this%variables(i_var)%val(:) = 0._r8 - ! =================================================================================== ! Step 1. Prioritized allocation to replace tissues from turnover, and/or pay ! any un-paid maintenance respiration from storage. @@ -660,8 +575,7 @@ subroutine DailyPRTAllometricCNP(this) allocated_p = allocated_p + (state_p(i_org)%ptr - state_p0(i_org)) end do - - + if(debug) then ! Error Check: Do a final balance between how much mass @@ -683,6 +597,11 @@ subroutine DailyPRTAllometricCNP(this) end if end if + target_n = this%GetNutrientTarget(nitrogen_element,store_organ) + target_p = this%GetNutrientTarget(phosphorus_element,store_organ) + + n_need = target_n - state_n(store_id)%ptr + p_need = target_p - state_p(store_id)%ptr deallocate(state_c) deallocate(state_n) @@ -765,17 +684,19 @@ subroutine CNPPrioritizedReplacement(this, & ! If it is, then we track the variable ids associated with that pool for each CNP ! species. It "should" work fine if there are NO priority=1 pools... ! ----------------------------------------------------------------------------------- - curpri_org(:) = fates_unset_int ! reset "current-priority" organ ids i = 0 do ii = 1, num_organs - - deficit_c(ii) = max(0._r8,this%GetDeficit(carbon12_element,organ_list(ii),target_c(ii))) + deficit_c(ii) = max(0._r8,this%GetDeficit(carbon12_element,organ_list(ii),target_c(ii))) + + ! The following logic bars any organs that were not given allocation priority + if( prt_params%organ_param_id(organ_list(ii)) < 1 ) cycle + ! The priority code associated with this organ - priority_code = int(prt_params%alloc_priority(ipft, organ_list(ii))) - + priority_code = int(prt_params%alloc_priority(ipft, prt_params%organ_param_id(organ_list(ii)))) + ! Don't allow allocation to leaves if they are in an "off" status. ! Also, dont allocate to replace turnover if this is not evergreen ! (this prevents accidental re-flushing on the day they drop) @@ -920,7 +841,7 @@ subroutine CNPPrioritizedReplacement(this, & ! Bring all pools, in priority order, up to allometric targets if possible ! ----------------------------------------------------------------------------------- - do i_pri = 1, n_max_priority + priority_loop: do i_pri = 1, n_max_priority curpri_org(:) = fates_unset_int ! "current-priority" organ indices @@ -928,7 +849,19 @@ subroutine CNPPrioritizedReplacement(this, & do ii = 1, num_organs ! The priority code associated with this organ - priority_code = int(prt_params%alloc_priority(ipft, organ_list(ii))) + ! Storage has a special hard-coded priority level of 2 + ! Note that it is also implicitly part of step 1 + + if( organ_list(ii).eq.store_organ ) then + priority_code = 2 + else + if( prt_params%organ_param_id(organ_list(ii)) <1 ) then + priority_code = -1 + else + priority_code = int(prt_params%alloc_priority(ipft,prt_params%organ_param_id(organ_list(ii)))) + end if + end if + ! Don't allow allocation to leaves if they are in an "off" status. ! (this prevents accidental re-flushing on the day they drop) @@ -1048,7 +981,7 @@ subroutine CNPPrioritizedReplacement(this, & p_gain, phosphorus_element, curpri_org(1:n_curpri_org)) - end do + end do priority_loop return end subroutine CNPPrioritizedReplacement @@ -1364,7 +1297,11 @@ subroutine CNPStatureGrowth(this,c_gain, n_gain, p_gain, & case(3) - ! HACK, ALLOW FULL C ALLOCATION AND LET REST OF ALGORITHM LIMIT + ! No mathematical co-limitation of growth + ! This assumes that limitations will prevent + ! organs from allowing the growth step to even occur + ! and thus from an algorithmic level limit growth + c_gstature = c_gain @@ -1532,36 +1469,54 @@ subroutine CNPStatureGrowth(this,c_gain, n_gain, p_gain, & end if if_completed_solve end do do_solve_check - + ! Prioritize nutrient transfer to the reproductive pool + ! Note, that if we do not keep reproductive tissues on stoichiometry, the seed + ! pool for that pft will be off stoichiometry, and one of C,N or P will limit + ! recruitment. Per the current model formulation, new recruits are forced to + ! have their maximum stoichiometry in each organ. The total stoichiometry + ! of the recruits should match the stoichiometry of the seeds + + !!target_n = this%GetNutrientTarget(nitrogen_element,repro_organ,stoich_growth_min) + !!deficit_n(repro_id) = this%GetDeficit(nitrogen_element,repro_organ,target_n) + + !!target_p = this%GetNutrientTarget(phosphorus_element,repro_organ,stoich_growth_min) + !!deficit_p(repro_id) = this%GetDeficit(phosphorus_element,repro_organ,target_p) + + ! Nitrogen for + !!call ProportionalNutrAllocation(state_n, deficit_n, n_gain, nitrogen_element,[repro_id]) + + ! Phosphorus + !!call ProportionalNutrAllocation(state_p, deficit_p, p_gain, phosphorus_element,[repro_id]) + + ! ----------------------------------------------------------------------------------- ! Nutrient Fluxes proportionally to each pool (these should be fully actualized) ! (this also removes from the gain pools) ! ----------------------------------------------------------------------------------- - sum_n_demand = 0._r8 ! For error checking - sum_p_demand = 0._r8 ! For error checking - do ii = 1, n_mask_organs - i = mask_organs(ii) - if(organ_list(i).ne.store_organ)then - ! Update the nitrogen deficits (which are based off of carbon actual..) - ! Note that the nitrogen target is tied to the stoichiometry of thegrowing pool only - target_n = this%GetNutrientTarget(nitrogen_element,organ_list(i),stoich_growth_min) - deficit_n(i) = this%GetDeficit(nitrogen_element,organ_list(i),target_n) - sum_n_demand = sum_n_demand+max(0._r8,deficit_n(i)) - - ! Update the nitrogen deficits (which are based off of carbon actual..) - ! Note that the nitrogen target is tied to the stoichiometry of thegrowing pool only - target_p = this%GetNutrientTarget(phosphorus_element,organ_list(i),stoich_growth_min) - deficit_p(i) = this%GetDeficit(phosphorus_element,organ_list(i),target_p) - sum_p_demand = sum_p_demand+max(0._r8,deficit_p(i)) - else - deficit_n(i) = 0._r8 - deficit_p(i) = 0._r8 - end if - - end do - + sum_n_demand = 0._r8 ! For error checking + sum_p_demand = 0._r8 ! For error checking + do ii = 1, n_mask_organs + i = mask_organs(ii) + if(organ_list(i).ne.store_organ)then + ! Update the nitrogen deficits (which are based off of carbon actual..) + ! Note that the nitrogen target is tied to the stoichiometry of thegrowing pool only + target_n = this%GetNutrientTarget(nitrogen_element,organ_list(i),stoich_growth_min) + deficit_n(i) = this%GetDeficit(nitrogen_element,organ_list(i),target_n) + sum_n_demand = sum_n_demand+max(0._r8,deficit_n(i)) + + ! Update the nitrogen deficits (which are based off of carbon actual..) + ! Note that the nitrogen target is tied to the stoichiometry of thegrowing pool only + target_p = this%GetNutrientTarget(phosphorus_element,organ_list(i),stoich_growth_min) + deficit_p(i) = this%GetDeficit(phosphorus_element,organ_list(i),target_p) + sum_p_demand = sum_p_demand+max(0._r8,deficit_p(i)) + else + deficit_n(i) = 0._r8 + deficit_p(i) = 0._r8 + end if + + end do ! Nitrogen call ProportionalNutrAllocation(state_n,deficit_n, & @@ -1618,18 +1573,14 @@ subroutine CNPAllocateRemainder(this,c_gain, n_gain, p_gain, & ! ----------------------------------------------------------------------------------- do i = 1, num_organs - - ! Update the nitrogen deficits (which are based off of carbon actual..) - ! Note that the nitrogen target is tied to the stoichiometry of thegrowing pool only + + ! Update the nitrogen and phosphorus deficits target_n = this%GetNutrientTarget(nitrogen_element,organ_list(i),stoich_max) deficit_n(i) = max(0._r8,this%GetDeficit(nitrogen_element,organ_list(i),target_n)) - - ! Update the nitrogen deficits (which are based off of carbon actual..) - ! Note that the nitrogen target is tied to the stoichiometry of thegrowing pool only target_p = this%GetNutrientTarget(phosphorus_element,organ_list(i),stoich_max) deficit_p(i) = max(0._r8,this%GetDeficit(phosphorus_element,organ_list(i),target_p)) - + end do ! ----------------------------------------------------------------------------------- @@ -1648,6 +1599,15 @@ subroutine CNPAllocateRemainder(this,c_gain, n_gain, p_gain, & p_gain, phosphorus_element, all_organs) + ! If any N or P is still hanging around, put it in storage + + state_n(store_id)%ptr = state_n(store_id)%ptr + n_gain + state_p(store_id)%ptr = state_p(store_id)%ptr + p_gain + + n_gain = 0._r8 + p_gain = 0._r8 + + ! ----------------------------------------------------------------------------------- ! If carbon is still available, lets cram some into storage overflow ! We will do this last, because we wanted the non-overflow storage @@ -1678,13 +1638,13 @@ subroutine CNPAllocateRemainder(this,c_gain, n_gain, p_gain, & ! ----------------------------------------------------------------------------------- c_efflux = max(0.0_r8,c_gain) - n_efflux = max(0.0_r8,n_gain) - p_efflux = max(0.0_r8,p_gain) +! n_efflux = max(0.0_r8,n_gain) +! p_efflux = max(0.0_r8,p_gain) c_gain = 0.0_r8 - n_gain = 0.0_r8 - p_gain = 0.0_r8 +! n_gain = 0.0_r8 +! p_gain = 0.0_r8 return end subroutine CNPAllocateRemainder @@ -1733,12 +1693,12 @@ end function GetDeficit ! ===================================================================================== - function GetNutrientTarget(this,element_id,organ_id,stoich_mode) result(target_m) + function GetNutrientTargetCNP(this,element_id,organ_id,stoich_mode) result(target_m) class(cnp_allom_prt_vartypes) :: this integer, intent(in) :: element_id integer, intent(in) :: organ_id - integer, intent(in) :: stoich_mode + integer, intent(in),optional :: stoich_mode real(r8) :: target_m ! Target amount of nutrient for this organ [kg] real(r8) :: target_c @@ -1746,6 +1706,13 @@ function GetNutrientTarget(this,element_id,organ_id,stoich_mode) result(target_m real(r8) :: canopy_trim integer :: ipft integer :: i_cvar + real(r8) :: sapw_area + real(r8) :: leaf_c_target,fnrt_c_target + real(r8) :: sapw_c_target,agw_c_target + real(r8) :: bgw_c_target,struct_c_target + + + dbh => this%bc_inout(acnp_bc_inout_id_dbh)%rval canopy_trim = this%bc_in(acnp_bc_in_id_ctrim)%rval @@ -1753,40 +1720,87 @@ function GetNutrientTarget(this,element_id,organ_id,stoich_mode) result(target_m i_cvar = prt_global%sp_organ_map(organ_id,carbon12_element) ! Storage of nutrients are assumed to have different compartments than - ! for carbon, and thus their targets are not associated with the current amount of carbon - ! but the plant's carrying capacity + ! for carbon, and thus their targets are not associated with a tissue + ! but is more represented as a fraction of the maximum amount of nutrient + ! that can be bound in non-reproductive tissues if(organ_id == store_organ) then - call bstore_allom(dbh,ipft,canopy_trim, target_c) + + call bleaf(dbh,ipft,canopy_trim,leaf_c_target) + call bfineroot(dbh,ipft,canopy_trim,fnrt_c_target) + call bsap_allom(dbh,ipft,canopy_trim,sapw_area,sapw_c_target) + call bagw_allom(dbh,ipft,agw_c_target) + call bbgw_allom(dbh,ipft,bgw_c_target) + call bdead_allom(agw_c_target,bgw_c_target, sapw_c_target, ipft, struct_c_target) + + ! Target for storage is a fraction of the sum target of all + ! non-reproductive organs + + if( element_id == nitrogen_element) then + + target_m = StorageNutrientTarget(ipft, element_id, & + leaf_c_target*prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(leaf_organ)), & + fnrt_c_target*prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(fnrt_organ)), & + sapw_c_target*prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(sapw_organ)), & + struct_c_target*prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(struct_organ))) + else + + target_m = StorageNutrientTarget(ipft, element_id, & + leaf_c_target*prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(leaf_organ)), & + fnrt_c_target*prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(fnrt_organ)), & + sapw_c_target*prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(sapw_organ)), & + struct_c_target*prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(struct_organ))) + + end if + + elseif(organ_id == repro_organ) then + + target_c = this%variables(i_cvar)%val(1) + if( element_id == nitrogen_element) then + target_m = target_c * prt_params%nitr_recr_stoich(ipft) + else + target_m = target_c * prt_params%phos_recr_stoich(ipft) + end if + else + + + if(.not.present(stoich_mode))then + write(fates_log(),*) 'Must specify if nutrient target is growthmin or max' + write(fates_log(),*) 'for non-reproductive and non-storage organs' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + ! In all cases, we want the first index because for non-leaves ! that is the only index, and for leaves, that is the newly ! growing index. target_c = this%variables(i_cvar)%val(1) - end if - if( stoich_mode == stoich_growth_min ) then - if( element_id == nitrogen_element) then - target_m = target_c * prt_params%nitr_stoich_p1(ipft,organ_id) - else - target_m = target_c * prt_params%phos_stoich_p1(ipft,organ_id) - end if - elseif( stoich_mode == stoich_max ) then - if( element_id == nitrogen_element) then - target_m = target_c * prt_params%nitr_stoich_p2(ipft,organ_id) + if( stoich_mode == stoich_growth_min ) then + if( element_id == nitrogen_element) then + target_m = target_c * prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(organ_id)) + else + target_m = target_c * prt_params%phos_stoich_p1(ipft,prt_params%organ_param_id(organ_id)) + end if + elseif( stoich_mode == stoich_max ) then + if( element_id == nitrogen_element) then + target_m = target_c * prt_params%nitr_stoich_p2(ipft,prt_params%organ_param_id(organ_id)) + else + target_m = target_c * prt_params%phos_stoich_p2(ipft,prt_params%organ_param_id(organ_id)) + end if else - target_m = target_c * prt_params%phos_stoich_p2(ipft,organ_id) + write(fates_log(),*) 'invalid stoichiometry mode specified while getting' + write(fates_log(),*) 'nutrient targets' + write(fates_log(),*) 'stoich_mode: ',stoich_mode + call endrun(msg=errMsg(sourcefile, __LINE__)) end if - else - write(fates_log(),*) 'invalid stoichiometry mode specified while getting' - write(fates_log(),*) 'nutrient targets' - write(fates_log(),*) 'stoich_mode: ',stoich_mode - call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + return - end function GetNutrientTarget + end function GetNutrientTargetCNP + + ! ===================================================================================== subroutine ProportionalNutrAllocation(state_m, deficit_m, gain_m, element_id, list) @@ -1803,7 +1817,7 @@ subroutine ProportionalNutrAllocation(state_m, deficit_m, gain_m, element_id, li ! over some arbitrary set of organs real(r8),intent(inout) :: deficit_m(:) ! Nutrient mass deficit of species ! over set of organs - integer, intent(in) :: list(:)! List of indices if sparse + integer, intent(in) :: list(:) ! List of indices if sparse real(r8),intent(inout) :: gain_m ! Total nutrient mass gain to ! work with integer,intent(in) :: element_id ! Element global index (for debugging) @@ -1980,10 +1994,10 @@ subroutine GrowEquivC(this,carbon_gain,nitrogen_gain,phosphorus_gain, & ! Calculate gains from Nitrogen ! ----------------------------------------------------------------------------------- - if(prt_params%nitr_stoich_p1(ipft,organ_id)>nearzero)then + if(prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(organ_id))>nearzero)then ! The amount of C we could match with N in the aquisition pool - c_from_n_gain = nitrogen_gain * alloc_frac / prt_params%nitr_stoich_p1(ipft,organ_id) + c_from_n_gain = nitrogen_gain * alloc_frac / prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(organ_id)) ! It is possible that the nutrient pool of interest is already above the minimum ! requirement. In this case, we add that into the amount that the equivalent @@ -1993,7 +2007,7 @@ subroutine GrowEquivC(this,carbon_gain,nitrogen_gain,phosphorus_gain, & n_target = this%GetNutrientTarget(nitrogen_element,organ_id,stoich_growth_min) c_from_n_headstart = max(0.0_r8, sum(this%variables(n_var_id)%val(:),dim=1) - n_target ) / & - prt_params%nitr_stoich_p1(ipft,organ_id) + prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(organ_id)) ! Increment the amount of C that we could match with N, as the minimum @@ -2009,10 +2023,10 @@ subroutine GrowEquivC(this,carbon_gain,nitrogen_gain,phosphorus_gain, & ! Calculate gains from phosphorus ! ----------------------------------------------------------------------------------- - if(prt_params%phos_stoich_p1(ipft,organ_id)>nearzero) then + if(prt_params%phos_stoich_p1(ipft,prt_params%organ_param_id(organ_id))>nearzero) then - c_from_p_gain = phosphorus_gain * alloc_frac / prt_params%phos_stoich_p1(ipft,organ_id) + c_from_p_gain = phosphorus_gain * alloc_frac / prt_params%phos_stoich_p1(ipft,prt_params%organ_param_id(organ_id)) ! It is possible that the nutrient pool of interest is already above the minimum ! requirement. In this case, we add that into the amount that the equivalent @@ -2022,7 +2036,7 @@ subroutine GrowEquivC(this,carbon_gain,nitrogen_gain,phosphorus_gain, & p_target = this%GetNutrientTarget(phosphorus_element,organ_id,stoich_growth_min) c_from_p_headstart = max(0.0_r8,sum(this%variables(p_var_id)%val(:),dim=1) - p_target ) / & - prt_params%phos_stoich_p1(ipft,organ_id) + prt_params%phos_stoich_p1(ipft,prt_params%organ_param_id(organ_id)) ! Increment the amount of C that we could match with P, as the minimum ! of what C could do itself, and what P could do. We need this minimum @@ -2276,5 +2290,8 @@ subroutine TargetAllometryCheck(bleaf,bfroot,bsap,bstore,bdead, & end if end subroutine TargetAllometryCheck + + + end module PRTAllometricCNPMod diff --git a/parteh/PRTGenericMod.F90 b/parteh/PRTGenericMod.F90 index 8c348cad50..3dab9563a3 100644 --- a/parteh/PRTGenericMod.F90 +++ b/parteh/PRTGenericMod.F90 @@ -241,7 +241,8 @@ module PRTGenericMod procedure :: DailyPRT => DailyPRTBase procedure :: FastPRT => FastPRTBase - + procedure :: GetNutrientTarget => GetNutrientTargetBase + ! These are generic functions that should work on all hypotheses procedure, non_overridable :: InitAllocate @@ -390,7 +391,8 @@ module PRTGenericMod ! Make necessary procedures public public :: GetCoordVal public :: SetState - + public :: StorageNutrientTarget + contains ! ===================================================================================== @@ -1384,6 +1386,94 @@ subroutine AgeLeaves(this,ipft,period_sec) end do end subroutine AgeLeaves + + + function GetNutrientTargetBase(this,element_id,organ_id,stoich_mode) result(target_m) + + class(prt_vartypes) :: this + integer, intent(in) :: element_id + integer, intent(in) :: organ_id + integer, intent(in),optional :: stoich_mode + real(r8) :: target_m ! Target amount of nutrient for this organ [kg] + + target_m = 0._r8 + + write(fates_log(),*)'GetNutrientTargetBase must be extended by a child class.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + return + end function GetNutrientTargetBase + + + ! ==================================================================================== + function StorageNutrientTarget(pft, element_id, leaf_target, fnrt_target, sapw_target, struct_target) result(store_target) + + integer :: pft + integer :: element_id + real(r8) :: leaf_target ! Target leaf nutrient mass [kg] + real(r8) :: fnrt_target ! Target fineroot nutrient mass [kg] + real(r8) :: sapw_target ! Target sapwood nutrient mass [kg] + real(r8) :: struct_target ! Target structural nutrient mass [kg] + + real(r8) :: store_target ! Output: Target storage nutrient mass [kg] + + + ! ------------------------------------------------------------------------------------- + ! Choice of how nutrient storage target is proportioned to + ! Each choice makes the nutrient storage proportional the the "in-tissue" + ! total nitrogen content of 1 or more sets of organs + ! ------------------------------------------------------------------------------------- + + integer, parameter :: lfs_store_prop = 1 ! leaf-fnrt-sapw proportional storage + integer, parameter :: lfss_store_prop = 2 ! leaf-fnrt-sapw-struct proportional storage + integer, parameter :: fnrt_store_prop = 3 ! fineroot proportional storage + integer, parameter :: store_prop = fnrt_store_prop + + + select case(element_id) + case(carbon12_element) + write(fates_log(),*) 'Cannot call StorageNutrientTarget() for carbon' + write(fates_log(),*) 'exiting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + case(nitrogen_element) + + if (store_prop == lfs_store_prop) then + + store_target = prt_params%nitr_store_ratio(pft) * (leaf_target + fnrt_target + sapw_target) + + elseif(store_prop==lfss_store_prop) then + + store_target = prt_params%nitr_store_ratio(pft) * (leaf_target + fnrt_target + sapw_target + struct_target) + + elseif(store_prop==fnrt_store_prop) then + + store_target = prt_params%nitr_store_ratio(pft) * fnrt_target + + end if + + + case(phosphorus_element) + + if (store_prop == lfs_store_prop) then + + store_target = prt_params%phos_store_ratio(pft) * (leaf_target + fnrt_target + sapw_target) + + elseif(store_prop==lfss_store_prop) then + + store_target = prt_params%nitr_store_ratio(pft) * (leaf_target + fnrt_target + sapw_target + struct_target) + + elseif(store_prop==fnrt_store_prop) then + + store_target = prt_params%phos_store_ratio(pft) * fnrt_target + + end if + end select + + + end function StorageNutrientTarget + + end module PRTGenericMod diff --git a/parteh/PRTLossFluxesMod.F90 b/parteh/PRTLossFluxesMod.F90 index 526613b37d..13b09b2e37 100644 --- a/parteh/PRTLossFluxesMod.F90 +++ b/parteh/PRTLossFluxesMod.F90 @@ -117,6 +117,14 @@ subroutine PRTPhenologyFlush(prt, ipft, organ_id, c_store_transfer_frac) call endrun(msg=errMsg(__FILE__, __LINE__)) end if + if(prt_params%organ_param_id(organ_id)<1) then + write(fates_log(),*) 'Attempting to flush an organ that does not have a stoichiometry defined' + write(fates_log(),*) 'global organ id (fyi, leaf=1):',organ_id + write(fates_log(),*) 'prt_params%organ_param_id(:):',prt_params%organ_param_id(:) + write(fates_log(),*) 'Exiting' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + if(prt_global%hyp_id .le. 2) then i_leaf_pos = 1 ! also used for sapwood and structural for grass i_store_pos = 1 ! hypothesis 1/2 only have @@ -222,9 +230,9 @@ subroutine PRTPhenologyFlush(prt, ipft, organ_id, c_store_transfer_frac) ! Calculate the stoichiometry with C for this element if( element_id == nitrogen_element ) then - target_stoich = prt_params%nitr_stoich_p1(ipft,organ_id) + target_stoich = prt_params%nitr_stoich_p1(ipft,prt_params%organ_param_id(organ_id)) else if( element_id == phosphorus_element ) then - target_stoich = prt_params%phos_stoich_p1(ipft,organ_id) + target_stoich = prt_params%phos_stoich_p1(ipft,prt_params%organ_param_id(organ_id)) else write(fates_log(),*) ' Trying to calculate nutrient flushing target' write(fates_log(),*) ' for element that DNE' @@ -505,21 +513,25 @@ subroutine DeciduousTurnoverSimpleRetranslocation(prt,ipft,organ_id,mass_fractio i_var = organ_map(organ_id)%var_id(i_var_of_organ) element_id = prt_global%state_descriptor(i_var)%element_id - - if ( any(element_id == carbon_elements_list) ) then - retrans = prt_params%turnover_carb_retrans(ipft,organ_id) - else if( element_id == nitrogen_element ) then - retrans = prt_params%turnover_nitr_retrans(ipft,organ_id) - else if( element_id == phosphorus_element ) then - retrans = prt_params%turnover_phos_retrans(ipft,organ_id) + + if( prt_params%organ_param_id(organ_id) < 1 ) then + retrans = 0._r8 else - write(fates_log(),*) 'Please add a new re-translocation clause to your ' - write(fates_log(),*) ' organ x element combination' - write(fates_log(),*) ' organ: ',leaf_organ,' element: ',element_id - write(fates_log(),*) 'Exiting' - call endrun(msg=errMsg(__FILE__, __LINE__)) + if ( any(element_id == carbon_elements_list) ) then + retrans = prt_params%turnover_carb_retrans(ipft,prt_params%organ_param_id(organ_id)) + else if( element_id == nitrogen_element ) then + retrans = prt_params%turnover_nitr_retrans(ipft,prt_params%organ_param_id(organ_id)) + else if( element_id == phosphorus_element ) then + retrans = prt_params%turnover_phos_retrans(ipft,prt_params%organ_param_id(organ_id)) + else + write(fates_log(),*) 'Please add a new re-translocation clause to your ' + write(fates_log(),*) ' organ x element combination' + write(fates_log(),*) ' organ: ',leaf_organ,' element: ',element_id + write(fates_log(),*) 'Exiting' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if end if - + ! Get the variable id of the storage pool for this element store_var_id = prt_global%sp_organ_map(store_organ,element_id) @@ -707,22 +719,28 @@ subroutine MaintTurnoverSimpleRetranslocation(prt,ipft,is_drought) base_turnover(repro_organ) = 0.0_r8 do i_var = 1, prt_global%num_vars - + organ_id = prt_global%state_descriptor(i_var)%organ_id element_id = prt_global%state_descriptor(i_var)%element_id - if ( any(element_id == carbon_elements_list) ) then - retrans_frac = prt_params%turnover_carb_retrans(ipft,organ_id) - else if( element_id == nitrogen_element ) then - retrans_frac = prt_params%turnover_nitr_retrans(ipft,organ_id) - else if( element_id == phosphorus_element ) then - retrans_frac = prt_params%turnover_phos_retrans(ipft,organ_id) + ! If this organ does not have a retranslocation rate + ! then it is not valid for turnover + if( prt_params%organ_param_id(organ_id) < 1 ) then + retrans_frac = 0._r8 else - write(fates_log(),*) 'Please add a new re-translocation clause to your ' - write(fates_log(),*) ' organ x element combination' - write(fates_log(),*) ' organ: ',organ_id,' element: ',element_id - write(fates_log(),*) 'Exiting' - call endrun(msg=errMsg(__FILE__, __LINE__)) + if ( any(element_id == carbon_elements_list) ) then + retrans_frac = prt_params%turnover_carb_retrans(ipft,prt_params%organ_param_id(organ_id)) + else if( element_id == nitrogen_element ) then + retrans_frac = prt_params%turnover_nitr_retrans(ipft,prt_params%organ_param_id(organ_id)) + else if( element_id == phosphorus_element ) then + retrans_frac = prt_params%turnover_phos_retrans(ipft,prt_params%organ_param_id(organ_id)) + else + write(fates_log(),*) 'Please add a new re-translocation clause to your ' + write(fates_log(),*) ' organ x element combination' + write(fates_log(),*) ' organ: ',organ_id,' element: ',element_id + write(fates_log(),*) 'Exiting' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if end if if(base_turnover(organ_id) < check_initialized) then @@ -790,7 +808,6 @@ subroutine MaintTurnoverSimpleRetranslocation(prt,ipft,is_drought) end do end do - return end subroutine MaintTurnoverSimpleRetranslocation diff --git a/parteh/PRTParametersMod.F90 b/parteh/PRTParametersMod.F90 index 2acb706f8d..04a0f5dda0 100644 --- a/parteh/PRTParametersMod.F90 +++ b/parteh/PRTParametersMod.F90 @@ -13,9 +13,9 @@ module PRTParametersMod ! The following three PFT classes ! are mutually exclusive - real(r8), allocatable :: stress_decid(:) ! Is the plant stress deciduous? (1=yes, 0=no) - real(r8), allocatable :: season_decid(:) ! Is the plant seasonally deciduous (1=yes, 0=no) - real(r8), allocatable :: evergreen(:) ! Is the plant an evergreen (1=yes, 0=no) + integer, allocatable :: stress_decid(:) ! Is the plant stress deciduous? (1=yes, 0=no) + integer, allocatable :: season_decid(:) ! Is the plant seasonally deciduous (1=yes, 0=no) + integer, allocatable :: evergreen(:) ! Is the plant an evergreen (1=yes, 0=no) ! Growth and Turnover Parameters @@ -48,7 +48,23 @@ module PRTParametersMod real(r8), allocatable :: nitr_stoich_p1(:,:) ! Parameter 1 for nitrogen stoichiometry (pft x organ) real(r8), allocatable :: nitr_stoich_p2(:,:) ! Parameter 2 for nitrogen stoichiometry (pft x organ) real(r8), allocatable :: phos_stoich_p1(:,:) ! Parameter 1 for phosphorus stoichiometry (pft x organ) - real(r8), allocatable :: phos_stoich_p2(:,:) ! Parameter 2 for phosphorus stoichiometry (pft x organ) + real(r8), allocatable :: phos_stoich_p2(:,:) ! Parameter 2 for phosphorus stoichiometry (pft x organ) + + real(r8), allocatable :: nitr_store_ratio(:) ! This is the ratio of the target nitrogen stored per + ! target nitrogen that is bound into the tissues + ! of leaves, fine-roots and sapwood + + + real(r8), allocatable :: phos_store_ratio(:) ! This is the ratio of the target phosphorus stored per + ! target phosphorus is bound into the tissues + ! of leaves, fine-roots and sapwood + + integer, allocatable :: organ_id(:) ! Mapping of the organ index in the parameter file, to the + ! global list of organs found in PRTGenericMod.F90 + + + + real(r8), allocatable :: alloc_priority(:,:) ! Allocation priority for each organ (pft x organ) [integer 0-6] real(r8), allocatable :: cushion(:) ! labile carbon storage target as multiple of leaf pool. real(r8), allocatable :: leaf_stor_priority(:) ! leaf turnover vs labile carbon use prioritisation @@ -59,6 +75,19 @@ module PRTParametersMod real(r8), allocatable :: seed_alloc(:) ! fraction of carbon balance allocated to seeds. + ! Derived parameters + + integer, allocatable :: organ_param_id(:) ! This is the sparse reverse lookup index map. This is dimensioned + ! by all the possible organs in parteh, and each index + ! may point to the index in the parameter file, or will be -1 + + real(r8), allocatable :: nitr_recr_stoich(:) ! This is the N:C ratio of newly recruited plants that are + ! on allometry at their recruitment diameter + + real(r8), allocatable :: phos_recr_stoich(:) ! This is the P:C ratio of newly recruited plants that are + ! on allometry at their recruitment diameter + + ! Allometry Parameters ! -------------------------------------------------------------------------------------------- @@ -72,7 +101,8 @@ module PRTParametersMod real(r8), allocatable :: c2b(:) ! Carbon to biomass multiplier [kg/kgC] real(r8), allocatable :: wood_density(:) ! wood density g cm^-3 ... real(r8), allocatable :: woody(:) ! Does the plant have wood? (1=yes, 0=no) - + real(r8), allocatable :: crown(:) ! fraction of the height of the plant + ! that is occupied by crown real(r8), allocatable :: slamax(:) ! Maximum specific leaf area of plant (at bottom) [m2/gC] real(r8), allocatable :: slatop(:) ! Specific leaf area at canopy top [m2/gC] real(r8), allocatable :: allom_sai_scaler(:) ! @@ -108,6 +138,12 @@ module PRTParametersMod real(r8), allocatable :: allom_agb3(:) ! Parameter 3 for agb allometry real(r8), allocatable :: allom_agb4(:) ! Parameter 3 for agb allometry + real(r8), allocatable :: allom_zroot_max_dbh(:) ! dbh at which maximum rooting depth saturates (largest possible) [cm] + real(r8), allocatable :: allom_zroot_max_z(:) ! the maximum rooting depth defined at dbh = fates_allom_zroot_max_dbh [m] + real(r8), allocatable :: allom_zroot_min_dbh(:) ! dbh at which the maximum rooting depth for a recruit is defined [cm] + real(r8), allocatable :: allom_zroot_min_z(:) ! the maximum rooting depth defined at dbh = fates_allom_zroot_min_dbh [m] + real(r8), allocatable :: allom_zroot_k(:) ! scale coefficient of logistic rooting depth model + end type prt_param_type diff --git a/parteh/PRTParamsFATESMod.F90 b/parteh/PRTParamsFATESMod.F90 index 3b56c571ff..208ff848fb 100644 --- a/parteh/PRTParamsFATESMod.F90 +++ b/parteh/PRTParamsFATESMod.F90 @@ -12,10 +12,26 @@ module PRTInitParamsFatesMod use PRTGenericMod, only : num_organ_types use PRTGenericMod, only : leaf_organ, fnrt_organ, store_organ use PRTGenericMod, only : sapw_organ, struct_organ, repro_organ + use PRTGenericMod, only : nitrogen_element, phosphorus_element use FatesGlobals, only : endrun => fates_endrun use FatesGlobals, only : fates_log use shr_log_mod, only : errMsg => shr_log_errMsg + use EDPftvarcon, only : EDPftvarcon_inst use PRTGenericMod, only : prt_cnp_flex_allom_hyp,prt_carbon_allom_hyp + use FatesAllometryMod , only : h_allom + use FatesAllometryMod , only : h2d_allom + use FatesAllometryMod , only : bagw_allom + use FatesAllometryMod , only : bsap_allom + use FatesAllometryMod , only : bleaf + use FatesAllometryMod , only : bfineroot + use FatesAllometryMod , only : bdead_allom + use FatesAllometryMod , only : bstore_allom + use FatesAllometryMod , only : bbgw_allom + use FatesAllometryMod , only : carea_allom + use FatesAllometryMod , only : CheckIntegratedAllometries + use FatesAllometryMod, only : set_root_fraction + use PRTGenericMod, only : StorageNutrientTarget + use EDTypesMod, only : init_recruit_trim ! ! !PUBLIC TYPES: @@ -33,6 +49,7 @@ module PRTInitParamsFatesMod public :: PRTRegisterParams public :: PRTReceiveParams public :: PRTCheckParams + public :: PRTDerivedParams !----------------------------------------------------------------------- contains @@ -51,7 +68,8 @@ subroutine PRTRegisterParams(fates_params) call PRTRegisterPFTOrgans(fates_params) call PRTRegisterPFTLeafAge(fates_params) call Register_PFT_nvariants(fates_params) - + call PRTRegisterOrgan(fates_params) + end subroutine PRTRegisterParams !----------------------------------------------------------------------- @@ -67,10 +85,58 @@ subroutine PRTReceiveParams(fates_params) call PRTReceivePFTOrgans(fates_params) call PRTReceivePFTLeafAge(fates_params) call Receive_PFT_nvariants(fates_params) + call PRTReceiveOrgan(fates_params) end subroutine PRTReceiveParams - !----------------------------------------------------------------------- + ! ===================================================================================== + + subroutine PRTRegisterOrgan(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + use FatesParametersInterface, only : dimension_name_prt_organs, dimension_shape_1d + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_prt_organs/) + integer, parameter :: dim_lower_bound(1) = (/ lower_bound_general /) + character(len=param_string_length) :: name + + name = 'fates_prt_organ_id' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + end subroutine PRTRegisterOrgan + + ! ===================================================================================== + + subroutine PRTReceiveOrgan(fates_params) + + ! Make sure to call this after PRTRegisterPFTOrgans + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length) :: name + + real(r8), allocatable :: tmpreal(:) ! Temporary variable to hold floats + + name = 'fates_prt_organ_id' + call fates_params%RetreiveParameterAllocate(name=name, & + data=tmpreal) + allocate(prt_params%organ_id(size(tmpreal,dim=1))) + call ArrayNint(tmpreal,prt_params%organ_id) + deallocate(tmpreal) + + end subroutine PRTReceiveOrgan + + ! ===================================================================================== + subroutine PRTRegisterPFT(fates_params) use FatesParametersInterface, only : fates_parameters_type, param_string_length @@ -97,11 +163,6 @@ subroutine PRTRegisterPFT(fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - - !X! name = '' - !X! call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - !X! dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_fnrt_prof_a' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -117,6 +178,10 @@ subroutine PRTRegisterPFT(fates_params) 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_fire_crown_depth_frac' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'fates_wood_density' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & @@ -270,6 +335,26 @@ subroutine PRTRegisterPFT(fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_allom_zroot_max_dbh' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_zroot_max_z' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_zroot_min_dbh' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_zroot_min_z' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_zroot_k' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_turnover_retrans_mode' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -277,6 +362,16 @@ subroutine PRTRegisterPFT(fates_params) name = 'fates_branch_turnover' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) + + + + name = 'fates_nitr_store_ratio' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_phos_store_ratio' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) end subroutine PRTRegisterPFT @@ -292,22 +387,30 @@ subroutine PRTReceivePFT(fates_params) character(len=param_string_length) :: name - !X! name = '' - !X! call fates_params%RetreiveParameter(name=name, & - !X! data=prt_params%) + real(r8), allocatable :: tmpreal(:) ! Temporary variable to hold floats + ! that are converted to ints name = 'fates_phen_stress_decid' call fates_params%RetreiveParameterAllocate(name=name, & - data=prt_params%stress_decid) - + data=tmpreal) + allocate(prt_params%stress_decid(size(tmpreal,dim=1))) + call ArrayNint(tmpreal,prt_params%stress_decid) + deallocate(tmpreal) + name = 'fates_phen_season_decid' call fates_params%RetreiveParameterAllocate(name=name, & - data=prt_params%season_decid) - + data=tmpreal) + allocate(prt_params%season_decid(size(tmpreal,dim=1))) + call ArrayNint(tmpreal,prt_params%season_decid) + deallocate(tmpreal) + name = 'fates_phen_evergreen' call fates_params%RetreiveParameterAllocate(name=name, & - data=prt_params%evergreen) - + data=tmpreal) + allocate(prt_params%evergreen(size(tmpreal,dim=1))) + call ArrayNint(tmpreal,prt_params%evergreen) + deallocate(tmpreal) + name = 'fates_leaf_slamax' call fates_params%RetreiveParameterAllocate(name=name, & data=prt_params%slamax) @@ -331,6 +434,10 @@ subroutine PRTReceivePFT(fates_params) name = 'fates_fnrt_prof_mode' call fates_params%RetreiveParameterAllocate(name=name, & data=prt_params%fnrt_prof_mode) + + name = 'fates_fire_crown_depth_frac' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%crown) name = 'fates_woody' call fates_params%RetreiveParameterAllocate(name=name, & @@ -475,7 +582,27 @@ subroutine PRTReceivePFT(fates_params) name = 'fates_allom_agb4' call fates_params%RetreiveParameterAllocate(name=name, & data=prt_params%allom_agb4) - + + name = 'fates_allom_zroot_max_dbh' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_zroot_max_dbh) + + name = 'fates_allom_zroot_max_z' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_zroot_max_z) + + name = 'fates_allom_zroot_min_dbh' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_zroot_min_dbh) + + name = 'fates_allom_zroot_min_z' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_zroot_min_z) + + name = 'fates_allom_zroot_k' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_zroot_k) + name = 'fates_branch_turnover' call fates_params%RetreiveParameterAllocate(name=name, & data=prt_params%branch_long) @@ -484,7 +611,15 @@ subroutine PRTReceivePFT(fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=prt_params%turnover_retrans_mode) - + name = 'fates_nitr_store_ratio' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%nitr_store_ratio) + + name = 'fates_phos_store_ratio' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%phos_store_ratio) + + end subroutine PRTReceivePFT !----------------------------------------------------------------------- @@ -513,6 +648,21 @@ subroutine PRTRegisterPFTLeafAge(fates_params) return end subroutine PRTRegisterPFTLeafAge + ! ===================================================================================== + + subroutine ArrayNint(realarr,intarr) + + real(r8),intent(in) :: realarr(:) + integer,intent(out) :: intarr(:) + integer :: i + + do i = 1,size(realarr,dim=1) + intarr(i) = nint(realarr(i)) + end do + + return + end subroutine ArrayNint + ! ===================================================================================== subroutine Register_PFT_nvariants(fates_params) @@ -748,24 +898,74 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'allom_agb2 = ',prt_params%allom_agb2 write(fates_log(),fmt0) 'allom_agb3 = ',prt_params%allom_agb3 write(fates_log(),fmt0) 'allom_agb4 = ',prt_params%allom_agb4 + + write(fates_log(),fmt0) 'allom_zroot_max_dbh = ',prt_params%allom_zroot_max_dbh + write(fates_log(),fmt0) 'allom_zroot_max_z = ',prt_params%allom_zroot_max_z + write(fates_log(),fmt0) 'allom_zroot_min_dbh = ',prt_params%allom_zroot_min_dbh + write(fates_log(),fmt0) 'allom_zroot_min_z = ',prt_params%allom_zroot_min_z + write(fates_log(),fmt0) 'allom_zroot_k = ',prt_params%allom_zroot_k + write(fates_log(),fmt0) 'prt_nitr_stoich_p1 = ',prt_params%nitr_stoich_p1 write(fates_log(),fmt0) 'prt_nitr_stoich_p2 = ',prt_params%nitr_stoich_p2 write(fates_log(),fmt0) 'prt_phos_stoich_p1 = ',prt_params%phos_stoich_p1 write(fates_log(),fmt0) 'prt_phos_stoich_p2 = ',prt_params%phos_stoich_p2 write(fates_log(),fmt0) 'prt_alloc_priority = ',prt_params%alloc_priority write(fates_log(),fmt0) 'woody = ',prt_params%woody + write(fates_log(),fmt0) 'crown = ',prt_params%crown write(fates_log(),fmt0) 'roota_par = ',prt_params%fnrt_prof_a write(fates_log(),fmt0) 'rootb_par = ',prt_params%fnrt_prof_b write(fates_log(),fmt0) 'fnrt_prof_mode = ',prt_params%fnrt_prof_mode write(fates_log(),fmt0) 'turnover_carb_retrans = ',prt_params%turnover_carb_retrans write(fates_log(),fmt0) 'turnover_nitr_retrans = ',prt_params%turnover_nitr_retrans write(fates_log(),fmt0) 'turnover_phos_retrans = ',prt_params%turnover_phos_retrans + write(fates_log(),fmt0) 'organ_id = ',prt_params%organ_id + write(fates_log(),fmt0) 'nitr_store_ratio = ',prt_params%nitr_store_ratio + write(fates_log(),fmt0) 'phos_store_ratio = ',prt_params%phos_store_ratio write(fates_log(),*) '-------------------------------------------------' end if end subroutine FatesReportPFTParams + ! ===================================================================================== + + subroutine PRTDerivedParams() + + integer :: npft ! number of PFTs + integer :: ft ! pft index + integer :: norgans ! number of organs in the parameter file + integer :: i, io ! generic loop index and organ loop index + + norgans = size(prt_params%organ_id,1) + npft = size(prt_params%evergreen,1) + + ! Set the reverse lookup map for organs to the parameter file index + allocate(prt_params%organ_param_id(num_organ_types)) + allocate(prt_params%nitr_recr_stoich(npft)) + allocate(prt_params%phos_recr_stoich(npft)) + + ! Initialize them as invalid + prt_params%organ_param_id(:) = -1 + + do i = 1,norgans + prt_params%organ_param_id(prt_params%organ_id(i)) = i + end do + + + ! Calculate the stoichiometry of a new recruit, and use this for defining + ! seed stoichiometry and + + do ft = 1,npft + + prt_params%nitr_recr_stoich(ft) = NewRecruitTotalStoichiometry(ft,nitrogen_element) + prt_params%phos_recr_stoich(ft) = NewRecruitTotalStoichiometry(ft,phosphorus_element) + + end do + + + return + end subroutine PRTDerivedParams + ! ===================================================================================== subroutine PRTCheckParams(is_master) @@ -793,37 +993,53 @@ subroutine PRTCheckParams(is_master) integer :: norgans ! size of the plant organ dimension integer :: i, io ! generic loop index and organ loop index - - integer, parameter,dimension(6) :: cnpflex_organs = & - [leaf_organ, fnrt_organ, sapw_organ, store_organ, repro_organ, struct_organ] - - npft = size(prt_params%evergreen,1) ! Prior to performing checks copy grperc to the ! organ dimensioned version - norgans = size(prt_params%nitr_stoich_p1,2) + norgans = size(prt_params%organ_id,1) if(.not.is_master) return - - - if (norgans .ne. num_organ_types) then - write(fates_log(),*) 'The size of the organ dimension for PRT parameters' - write(fates_log(),*) 'as specified in the parameter file is incompatible.' - write(fates_log(),*) 'All currently acceptable hypothesese are using' - write(fates_log(),*) 'the full set of num_organ_types = ',num_organ_types - write(fates_log(),*) 'The parameter file listed ',norgans - write(fates_log(),*) 'Exiting' + if( any(prt_params%organ_id(:)<1) .or. & + any(prt_params%organ_id(:)>num_organ_types) ) then + write(fates_log(),*) 'prt_organ_ids should match the global ids' + write(fates_log(),*) 'of organ types found in PRTGenericMod.F90' + write(fates_log(),*) 'organ_ids: ',prt_params%organ_id(:) + write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + ! Check to make sure the organ ids are valid if this is the + ! cnp_flex_allom_hypothesis + if ((hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) .or. & + (hlm_parteh_mode .eq. prt_carbon_allom_hyp) ) then + + do io = 1,norgans + if(prt_params%organ_id(io) == repro_organ) then + write(fates_log(),*) 'with flexible cnp or c-only alloc hypothesese' + write(fates_log(),*) 'reproductive tissues are a special case' + write(fates_log(),*) 'and therefore should not be included in' + write(fates_log(),*) 'the parameter file organ list' + write(fates_log(),*) 'fates_prt_organ_id: ',prt_params%organ_id(:) + write(fates_log(),*) 'Aborting' + end if + if(prt_params%organ_id(io) == store_organ) then + write(fates_log(),*) 'with flexible cnp or c-only alloc hypothesese' + write(fates_log(),*) 'storage is a special case' + write(fates_log(),*) 'and therefore should not be included in' + write(fates_log(),*) 'the parameter file organ list' + write(fates_log(),*) 'fates_prt_organ_id: ',prt_params%organ_id(:) + write(fates_log(),*) 'Aborting' + end if + + end do + end if - do ipft = 1,npft - + pftloop: do ipft = 1,npft + ! Check to see if evergreen, deciduous flags are mutually exclusive ! ---------------------------------------------------------------------------------- @@ -912,134 +1128,116 @@ subroutine PRTCheckParams(is_master) ! should not be re-translocating mass upon turnover. ! Note to advanced users. Feel free to remove these checks... ! ------------------------------------------------------------------- - - if ( (prt_params%turnover_carb_retrans(ipft,repro_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of reproductive tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,repro_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((prt_params%turnover_nitr_retrans(ipft,repro_organ) > nearzero) .or. & - (prt_params%turnover_phos_retrans(ipft,repro_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of reproductive tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,repro_organ) - write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,repro_organ) - write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,repro_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if ((prt_params%turnover_carb_retrans(ipft,sapw_organ) > nearzero)) then - write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,sapw_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((prt_params%turnover_nitr_retrans(ipft,sapw_organ) > nearzero) .or. & - (prt_params%turnover_phos_retrans(ipft,sapw_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,sapw_organ) - write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,sapw_organ) - write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,sapw_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - if ((prt_params%turnover_carb_retrans(ipft,struct_organ) > nearzero)) then - write(fates_log(),*) ' Retranslocation of structural(dead) tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,struct_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((prt_params%turnover_nitr_retrans(ipft,struct_organ) > nearzero) .or. & - (prt_params%turnover_phos_retrans(ipft,struct_organ) > nearzero) ) then - write(fates_log(),*) ' Retranslocation of structural(dead) tissues should be zero.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,struct_organ) - write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,struct_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + if ((hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) .or. & + (hlm_parteh_mode .eq. prt_carbon_allom_hyp) ) then + + do i = 1,norgans + io = prt_params%organ_id(i) + + if(io == sapw_organ) then + if ((prt_params%turnover_carb_retrans(ipft,i) > nearzero)) then + write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon retrans: ',prt_params%turnover_carb_retrans(ipft,i) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + elseif(io == struct_organ) then + if ((prt_params%turnover_carb_retrans(ipft,i) > nearzero)) then + write(fates_log(),*) ' Retranslocation of structural tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon retrans: ',prt_params%turnover_carb_retrans(ipft,i) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! Otherwise, all other retranslocations should be between 0 and 1 + if ( (prt_params%turnover_carb_retrans(ipft,i) > 1.0_r8) .or. & + (prt_params%turnover_carb_retrans(ipft,i) < 0.0_r8) ) then + write(fates_log(),*) ' Retranslocation rates should be between 0 and 1.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' parameter file index: ',i,' global index: ',io + write(fates_log(),*) ' retranslocation rate: ',prt_params%turnover_carb_retrans(ipft,i) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end do end if - ! Leaf retranslocation should be between 0 and 1 - if ( (prt_params%turnover_carb_retrans(ipft,leaf_organ) > 1.0_r8) .or. & - (prt_params%turnover_carb_retrans(ipft,leaf_organ) < 0.0_r8) ) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,leaf_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((prt_params%turnover_nitr_retrans(ipft,leaf_organ) > 1.0_r8) .or. & - (prt_params%turnover_phos_retrans(ipft,leaf_organ) > 1.0_r8) .or. & - (prt_params%turnover_nitr_retrans(ipft,leaf_organ) < 0.0_r8) .or. & - (prt_params%turnover_phos_retrans(ipft,leaf_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,leaf_organ) - write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,leaf_organ) - write(fates_log(),*) ' Aborting' + + ! Make sure nutrient storage fractions are positive + if( prt_params%nitr_store_ratio(ipft) < 0._r8 ) then + write(fates_log(),*) 'With parteh allometric CNP hypothesis' + write(fates_log(),*) 'nitr_store_ratio must be > 0' + write(fates_log(),*) 'PFT#: ',ipft + write(fates_log(),*) 'nitr_store_ratio = ',prt_params%nitr_store_ratio(ipft) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - end if - - ! Fineroot retranslocation should be between 0-1 - if ((prt_params%turnover_carb_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & - (prt_params%turnover_carb_retrans(ipft,fnrt_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,fnrt_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((prt_params%turnover_nitr_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & - (prt_params%turnover_phos_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & - (prt_params%turnover_nitr_retrans(ipft,fnrt_organ) < 0.0_r8) .or. & - (prt_params%turnover_phos_retrans(ipft,fnrt_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,fnrt_organ) - write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,fnrt_organ) - write(fates_log(),*) ' Aborting' + if( prt_params%phos_store_ratio(ipft) < 0._r8 ) then + write(fates_log(),*) 'With parteh allometric CNP hypothesis' + write(fates_log(),*) 'phos_store_ratio must be > 0' + write(fates_log(),*) 'PFT#: ',ipft + write(fates_log(),*) 'nitr_store_ratio = ',prt_params%phos_store_ratio(ipft) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - end if - ! Storage retranslocation should be between 0-1 (storage retrans seems weird, but who knows) - if ((prt_params%turnover_carb_retrans(ipft,store_organ) > 1.0_r8) .or. & - (prt_params%turnover_carb_retrans(ipft,store_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,store_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then - if ((prt_params%turnover_nitr_retrans(ipft,store_organ) > 1.0_r8) .or. & - (prt_params%turnover_phos_retrans(ipft,store_organ) > 1.0_r8) .or. & - (prt_params%turnover_nitr_retrans(ipft,store_organ) < 0.0_r8) .or. & - (prt_params%turnover_phos_retrans(ipft,store_organ) < 0.0_r8)) then - write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,store_organ) - write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,store_organ) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + do i = 1,norgans + io = prt_params%organ_id(i) + + if(io == sapw_organ) then + if ((prt_params%turnover_nitr_retrans(ipft,i) > nearzero)) then + write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' nitrogen retrans: ',prt_params%turnover_nitr_retrans(ipft,i) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if ((prt_params%turnover_phos_retrans(ipft,i) > nearzero)) then + write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' phosphorus retrans: ',prt_params%turnover_nitr_retrans(ipft,i) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + elseif(io == struct_organ) then + if ((prt_params%turnover_nitr_retrans(ipft,i) > nearzero)) then + write(fates_log(),*) ' Retranslocation of structural tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon retrans: ',prt_params%turnover_nitr_retrans(ipft,i) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if ((prt_params%turnover_phos_retrans(ipft,i) > nearzero)) then + write(fates_log(),*) ' Retranslocation of structural tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' phosphorus retrans: ',prt_params%turnover_nitr_retrans(ipft,i) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! Otherwise, all other retranslocations should be between 0 and 1 + if ((prt_params%turnover_nitr_retrans(ipft,i) > 1.0_r8) .or. & + (prt_params%turnover_phos_retrans(ipft,i) > 1.0_r8) .or. & + (prt_params%turnover_nitr_retrans(ipft,i) < 0.0_r8) .or. & + (prt_params%turnover_phos_retrans(ipft,i) < 0.0_r8)) then + write(fates_log(),*) ' Retranslocation should range from 0 to 1.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' parameter file organ index: ',i,' global index: ',io + write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,i) + write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,i) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end do + end if + ! Growth respiration ! if (parteh_mode .eq. prt_carbon_allom_hyp) then @@ -1060,30 +1258,30 @@ subroutine PRTCheckParams(is_master) ! end if ! end if - - ! The first nitrogen stoichiometry is used in all cases - if ( (any(prt_params%nitr_stoich_p1(ipft,:) < 0.0_r8)) .or. & - (any(prt_params%nitr_stoich_p1(ipft,:) >= 1.0_r8))) then - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' N per C stoichiometry must bet between 0-1' - write(fates_log(),*) prt_params%nitr_stoich_p1(ipft,:) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) + if ((hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) .or. & + (hlm_parteh_mode .eq. prt_carbon_allom_hyp) ) then + ! The first nitrogen stoichiometry is used in all cases + if ( (any(prt_params%nitr_stoich_p1(ipft,:) < 0.0_r8)) .or. & + (any(prt_params%nitr_stoich_p1(ipft,:) >= 1.0_r8))) then + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' N per C stoichiometry must bet between 0-1' + write(fates_log(),*) prt_params%nitr_stoich_p1(ipft,:) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if end if - if(hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then - do i = 1,size(cnpflex_organs,dim=1) - io = cnpflex_organs(i) - if ( (prt_params%nitr_stoich_p1(ipft,io) < 0._r8) .or. & - (prt_params%nitr_stoich_p2(ipft,io) < 0._r8) .or. & - (prt_params%phos_stoich_p1(ipft,io) < 0._r8) .or. & - (prt_params%phos_stoich_p2(ipft,io) < 0._r8) .or. & - (prt_params%nitr_stoich_p1(ipft,io) > 1._r8) .or. & - (prt_params%nitr_stoich_p2(ipft,io) > 1._r8) .or. & - (prt_params%phos_stoich_p1(ipft,io) > 1._r8) .or. & - (prt_params%phos_stoich_p2(ipft,io) > 1._r8) ) then + do i = 1,norgans + if ( (prt_params%nitr_stoich_p1(ipft,i) < 0._r8) .or. & + (prt_params%nitr_stoich_p2(ipft,i) < 0._r8) .or. & + (prt_params%phos_stoich_p1(ipft,i) < 0._r8) .or. & + (prt_params%phos_stoich_p2(ipft,i) < 0._r8) .or. & + (prt_params%nitr_stoich_p1(ipft,i) > 1._r8) .or. & + (prt_params%nitr_stoich_p2(ipft,i) > 1._r8) .or. & + (prt_params%phos_stoich_p1(ipft,i) > 1._r8) .or. & + (prt_params%phos_stoich_p2(ipft,i) > 1._r8) ) then write(fates_log(),*) 'When the C,N,P allocation hypothesis with flexible' write(fates_log(),*) 'stoichiometry is turned on (prt_cnp_flex_allom_hyp),' write(fates_log(),*) 'all stoichiometries must be greater than or equal to zero,' @@ -1093,10 +1291,10 @@ subroutine PRTCheckParams(is_master) write(fates_log(),*) 'You specified an organ/pft less than zero.' write(fates_log(),*) 'PFT: ',ipft write(fates_log(),*) 'organ index (see head of PRTGenericMod): ',io - write(fates_log(),*) 'nitr_stoich_p1: ',prt_params%nitr_stoich_p1(ipft,io) - write(fates_log(),*) 'nitr_stoich_p2: ',prt_params%phos_stoich_p1(ipft,io) - write(fates_log(),*) 'phos_stoich_p1: ',prt_params%nitr_stoich_p2(ipft,io) - write(fates_log(),*) 'phos_stoich_p2: ',prt_params%phos_stoich_p2(ipft,io) + write(fates_log(),*) 'nitr_stoich_p1: ',prt_params%nitr_stoich_p1(ipft,i) + write(fates_log(),*) 'nitr_stoich_p2: ',prt_params%phos_stoich_p1(ipft,i) + write(fates_log(),*) 'phos_stoich_p1: ',prt_params%nitr_stoich_p2(ipft,i) + write(fates_log(),*) 'phos_stoich_p2: ',prt_params%phos_stoich_p2(ipft,i) write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end if @@ -1114,8 +1312,6 @@ subroutine PRTCheckParams(is_master) end if - - ! Check turnover time-scales nleafage = size(prt_params%leaf_long,dim=2) @@ -1224,11 +1420,92 @@ subroutine PRTCheckParams(is_master) end if - end do + end do pftloop return end subroutine PRTCheckParams + ! ==================================================================================== + + function NewRecruitTotalStoichiometry(ft,element_id) result(recruit_stoich) + + ! ---------------------------------------------------------------------------------- + ! This function calculates the total N:C or P:C ratio for a newly recruited plant + ! It does this by first identifying the dbh of a new plant, then uses + ! allometry to calculate the starting amount of carbon, and then uses + ! the stoichiometry parameters to determine the proportional mass of N or P + ! + ! This process only has to be called once, and is then stored in parameter + ! constants for each PFT. These values are used for determining nutrient + ! fluxes into seed pools (on plant), and also from germinated seed polls (on ground) + ! into new recruits. + ! ---------------------------------------------------------------------------------- + + + integer,intent(in) :: ft + integer,intent(in) :: element_id + real(r8) :: recruit_stoich ! nutrient to carbon ratio of recruit + + real(r8) :: dbh ! dbh of the new recruit [cm] + real(r8) :: c_leaf ! target leaf biomass [kgC] + real(r8) :: c_fnrt ! target fine root biomass [kgC] + real(r8) :: c_sapw ! target sapwood biomass [kgC] + real(r8) :: a_sapw ! target sapwood cross section are [m2] (dummy) + real(r8) :: c_agw ! target Above ground biomass [kgC] + real(r8) :: c_bgw ! target Below ground biomass [kgC] + real(r8) :: c_struct ! target Structural biomass [kgc] + real(r8) :: c_store ! target Storage biomass [kgC] + real(r8) :: c_total ! total target carbon + real(r8) :: nutr_total ! total target nutrient + + call h2d_allom(EDPftvarcon_inst%hgt_min(ft),ft,dbh) + call bleaf(dbh,ft,init_recruit_trim,c_leaf) + call bfineroot(dbh,ft,init_recruit_trim,c_fnrt) + call bsap_allom(dbh,ft,init_recruit_trim,a_sapw, c_sapw) + call bagw_allom(dbh,ft,c_agw) + call bbgw_allom(dbh,ft,c_bgw) + call bdead_allom(c_agw,c_bgw,c_sapw,ft,c_struct) + call bstore_allom(dbh,ft,init_recruit_trim,c_store) + + ! Total carbon in a newly recruited plant + c_total = c_leaf + c_fnrt + c_sapw + c_struct + c_store + + ! Total nutrient in a newly recruited plant + select case(element_id) + case(nitrogen_element) + + nutr_total = & + c_struct*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + & + c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & + c_fnrt*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & + c_sapw*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) + & + StorageNutrientTarget(ft, element_id, & + c_leaf*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)), & + c_fnrt*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)), & + c_sapw*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)), & + c_struct*prt_params%nitr_stoich_p2(ft,prt_params%organ_param_id(struct_organ))) + + case(phosphorus_element) + + nutr_total = & + c_struct*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(struct_organ)) + & + c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)) + & + c_fnrt*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)) + & + c_sapw*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)) + & + StorageNutrientTarget(ft, element_id, & + c_leaf*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(leaf_organ)), & + c_fnrt*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(fnrt_organ)), & + c_sapw*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(sapw_organ)), & + c_struct*prt_params%phos_stoich_p2(ft,prt_params%organ_param_id(struct_organ))) + + + end select + + recruit_stoich = nutr_total/c_total + + + return + end function NewRecruitTotalStoichiometry end module PRTInitParamsFatesMod diff --git a/tools/BatchPatchParams.py b/tools/BatchPatchParams.py new file mode 100755 index 0000000000..ee78ebcbd0 --- /dev/null +++ b/tools/BatchPatchParams.py @@ -0,0 +1,114 @@ +#!/usr/bin/env python + +#### this script modifies the default FATES parameter file to generate +# a file used in testing E3SM +# Parser code was based off of modify_fates_paramfile.py + +import os +import argparse +import code # For development: code.interact(local=dict(globals(), **locals())) +from scipy.io import netcdf + + +# --------------------------------------------------------------------------------------- + +class param_type: + def __init__(self,name,values_text): + self.name = name + self.values = values_text.replace(" ","") #[float(x) for x in values_text.split(',')] + +# --------------------------------------------------------------------------------------- + + +def load_xml(xmlfile): + + import xml.etree.ElementTree as et + + xmlroot = et.parse(xmlfile).getroot() + print("\nOpenend: "+xmlfile) + + base_cdl = xmlroot.find('base_file').text + new_cdl = xmlroot.find('new_file').text + + pftparams = xmlroot.find('pft_list').text.replace(" ","") + + paramroot = xmlroot.find('parameters') + paramlist = [] + for param in paramroot: + print("parsing "+param.tag) + paramlist.append(param_type(param.tag,param.text)) + + + + return(base_cdl,new_cdl,pftparams,paramlist) + + + +# Little function for assembling the call to the system to make the modification +# ---------------------------------------------------------------------------------------- + +def parse_syscall_str(fnamein,fnameout,param_name,param_val): + + sys_call_str = "../tools/modify_fates_paramfile.py"+" --fin " + fnamein + \ + " --fout " + fnameout + " --var " + param_name + " --silent " +\ + " --val " + "\" "+param_val+"\"" + " --overwrite --all" + + + print(sys_call_str) + + return(sys_call_str) + + + +def main(): + + # Parse arguments + parser = argparse.ArgumentParser(description='Parse command line arguments to this script.') + parser.add_argument('--f', dest='xmlfile', type=str, help="XML control file Required.", required=True) + args = parser.parse_args() + + + # Load the xml file, which contains the base cdl, the output cdl, + # and the parameters to be modified + [base_cdl,new_cdl,pftlist,paramlist] = load_xml(args.xmlfile) + + + # Convert the base cdl file into a temp nc binary + base_nc = os.popen('mktemp').read().rstrip('\n') + gencmd = "ncgen -o "+base_nc+" "+base_cdl + os.system(gencmd) + + # Generate a temp output file name + new_nc = os.popen('mktemp').read().rstrip('\n') + + + # Use FatesPFTIndexSwapper.py to prune out unwanted PFTs + swapcmd="../tools/FatesPFTIndexSwapper.py --pft-indices="+pftlist+" --fin="+base_nc+" --fout="+new_nc #+" 1>/dev/null" + os.system(swapcmd) + + # We open the new parameter file. We only use this + # to do some dimension checking. + fp_nc = netcdf.netcdf_file(base_nc, 'r') + + # On subsequent parameters, overwrite the file + for param in paramlist: + + change_str = parse_syscall_str(new_nc,new_nc,param.name,param.values) + os.system(change_str) + + # Sort the new file + newer_nc = os.popen('mktemp').read().rstrip('\n') + os.system("../tools/ncvarsort.py --fin "+new_nc+" --fout "+newer_nc+" --overwrite") + + # Dump the new file to the cdl + os.system("ncdump "+newer_nc+" > "+new_cdl) + + fp_nc.close() + + print("\nBatch parameter transfer complete\n") + + +# This is the actual call to main + +if __name__ == "__main__": + main() diff --git a/tools/FatesPFTIndexSwapper.py b/tools/FatesPFTIndexSwapper.py index a42d95da10..7e39056fa8 100755 --- a/tools/FatesPFTIndexSwapper.py +++ b/tools/FatesPFTIndexSwapper.py @@ -25,7 +25,9 @@ pft_dim_name = 'fates_pft' prt_dim_name = 'fates_prt_organs' - +hydro_dim_name = 'fates_hydr_organs' +litt_dim_name = 'fates_litterclass' +string_dim_name = 'fates_string_length' class timetype: @@ -165,22 +167,31 @@ def main(argv): # Idenfity if this variable has pft dimension pft_dim_found = -1 prt_dim_found = -1 + hydro_dim_found = -1 + litt_dim_found = -1 + string_dim_found = -1 pft_dim_len = len(fp_in.variables.get(key).dimensions) for idim, name in enumerate(fp_in.variables.get(key).dimensions): + # Manipulate data if(name==pft_dim_name): pft_dim_found = idim if(name==prt_dim_name): prt_dim_found = idim - + if(name==litt_dim_name): + litt_dim_found = idim + if(name==hydro_dim_name): + hydro_dim_found = idim + if(name==string_dim_name): + string_dim_found = idim # Copy over the input data # Tedious, but I have to permute through all combinations of dimension position if( pft_dim_len == 0 ): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var.assignValue(float(fp_in.variables.get(key).data)) - elif( (pft_dim_found==-1) & (prt_dim_found==-1) ): + elif( (pft_dim_found==-1) & (prt_dim_found==-1) & (litt_dim_found==-1) & (hydro_dim_found==-1) ): out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] elif( (pft_dim_found==0) & (pft_dim_len==1) ): # 1D fates_pft @@ -207,13 +218,29 @@ def main(argv): out_var[:] = np.empty([num_pft_out,dim2_len], dtype="S{}".format(dim2_len)) for id,ipft in enumerate(donor_pft_indices): out_var[id] = fp_in.variables.get(key).data[ipft-1] + + elif( (prt_dim_found==0) & (pft_dim_len==2) ): + out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] - - elif( (prt_dim_found==0) & (pft_dim_len==2) ): # fates_prt_organs - string_length + elif( (hydro_dim_found==0) & (string_dim_found>=0) ): out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) out_var[:] = in_var[:] + + elif( (litt_dim_found==0) & (string_dim_found>=0) ): + out_var = fp_out.createVariable(key,'c',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + elif( prt_dim_found==0 ): # fates_prt_organs - indices + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + elif( litt_dim_found==0 ): + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] + elif( hydro_dim_found==0): + out_var = fp_out.createVariable(key,'d',(fp_in.variables.get(key).dimensions)) + out_var[:] = in_var[:] else: print('This variable has a dimensioning that we have not considered yet.') print('Please add this condition to the logic above this statement.') diff --git a/tools/modify_fates_paramfile.py b/tools/modify_fates_paramfile.py index 12fb552cdc..5ab1116500 100755 --- a/tools/modify_fates_paramfile.py +++ b/tools/modify_fates_paramfile.py @@ -25,6 +25,7 @@ import datetime import time import numpy as np +import code # For development: code.interact(local=dict(globals(), **locals())) # ======================================================================================== # ======================================================================================== @@ -46,30 +47,39 @@ def main(): parser.add_argument('--silent', '--s', dest='silent', help="prevent writing of output.", action="store_true") parser.add_argument('--nohist', dest='nohist', help="prevent recording of the edit in the history attribute of the output file", action="store_true") parser.add_argument('--changeshape', dest='changeshape', help="allow script to change shape of specified variable, and all other variables with the relevant dimension, if necessary", action="store_true") + parser.add_argument('--all',dest='varall',help="replace all values for the specified parameter, supercedes other flags",action="store_true") # args = parser.parse_args() # - # work with the file in some random temporary place so that if something goes wrong, then nothing happens to original file and it doesn't make a persistent output file + # work with the file in some random temporary place so that if something goes wrong, + # then nothing happens to original file and it doesn't make a persistent output file tempdir = tempfile.mkdtemp() tempfilename = os.path.join(tempdir, 'temp_fates_param_file.nc') ncfile_old = None rename_pft = False - # - try: - outputval = float(args.val) - if args.changeshape: - raise Exception - except: + + if args.varall: + # val_list = args.val.split(',') + # output_vec = [float(valstr) for valstr in val_list] + outputval = np.fromstring(args.val, sep=',', dtype=np.float64) + + else: + try: - #print('output variable not interpretable as real. trying array') - outputval = np.fromstring(args.val, sep=',', dtype=np.float32) - if len(outputval) == 0: - raise RuntimeError('output variable needs to have size greater than zero') + outputval = float(args.val) + if args.changeshape: + raise Exception except: - if args.varname != 'fates_pftname': - raise RuntimeError('output variable not interpretable as real or array') - else: - rename_pft = True + try: + #print('output variable not interpretable as real. trying array') + outputval = np.fromstring(args.val, sep=',', dtype=np.float32) + if len(outputval) == 0: + raise RuntimeError('output variable needs to have size greater than zero') + except: + if args.varname != 'fates_pftname': + raise RuntimeError('output variable not interpretable as real or array') + else: + rename_pft = True # # try: @@ -78,169 +88,219 @@ def main(): ncfile = nc.netcdf_file(tempfilename, 'a') # var = ncfile.variables[args.varname] + # - ### check to make sure that, if a PFT is specified, the variable has a PFT dimension, and if not, then it doesn't. and also that shape is reasonable. + ### check to make sure that, if a PFT is specified, the variable has a PFT dimension, + ### and if not, then it doesn't. and also that shape is reasonable. ndim_file = len(var.dimensions) - ispftvar = False - # for purposes of current state of this script, assume 1D - if ndim_file > 2: - raise ValueError('variable dimensionality is too high for this script') - for i in range(ndim_file): - if var.dimensions[i] == 'fates_pft': - ispftvar = True - npft_file = var.shape[i] - pftdim = i - otherdimpresent = False - elif var.dimensions[i] in ['fates_history_age_bins','fates_history_size_bins','fates_history_coage_bins','fates_history_height_bins','fates_NCWD','fates_litterclass','fates_leafage_class','fates_prt_organs','fates_hydr_organs','fates_variants']: - otherdimpresent = True - otherdimname = var.dimensions[i] - otherdimlength = var.shape[i] - elif var.dimensions[i] == 'fates_string_length' and rename_pft: - otherdimpresent = True - otherdimname = var.dimensions[i] - otherdimlength = var.shape[i] + + if args.varall: + + # Calculate total number of values expected + nvals = 1 + #code.interact(local=dict(globals(), **locals())) + for i in range(ndim_file): + nvals = nvals*np.prod(var.shape[i]) + if(len(outputval) != nvals): + print('Input vector is not the same size as the in-file array for {}'.format(args.varname)) + print('total size = {}, you specified = {} values'.format(nvals,len(outputval))) + exit(2) + + if(ndim_file==2): + ii = 0 + for i in range(var.shape[0]): + for j in range(var.shape[1]): + var[i,j] = outputval[ii] + ii=ii+1 + + elif(ndim_file==1): + for i in range(var.shape[0]): + var[i] = outputval[i] + elif(ndim_file==0): + var.assignValue(outputval[0]) + else: - raise ValueError('variable is not on either the PFT or scalar dimension') - # - if args.changeshape: - ### if we are allowing the script to change the shape of the variable, then we need to figure out if that's really a thing that needs to happen. - ### first identify what dimension we would change the shape of if we had to. - length_specified = len(outputval) - if length_specified != otherdimlength: - ### ok, we find ourselves in the situation where we need to rewrite the netcdf from scratch with its revised shape. - # - # first lets chech to make sure the dimension we are changing can be changed without breaking things. - plastic_dimensions_list = ['fates_history_age_bins','fates_history_size_bins','fates_history_coage_bins','fates_history_height_bins','fates_leafage_class'] - if otherdimname not in plastic_dimensions_list: - raise ValueError('asking to change the shape of a dimension, '+otherdimname+', that will probably break things') + print("Unhandled dimension size in modify_fates_paramfile.py") + print("using --all flag") + exit(2) + + else: + + ispftvar = False + # for purposes of current state of this script, assume 1D + if ndim_file > 2: + raise ValueError('variable dimensionality is too high for this script') + for i in range(ndim_file): + if var.dimensions[i] == 'fates_pft': + ispftvar = True + npft_file = var.shape[i] + pftdim = i + otherdimpresent = False + elif var.dimensions[i] in ['fates_history_age_bins','fates_history_size_bins', \ + 'fates_history_coage_bins','fates_history_height_bins', \ + 'fates_NCWD','fates_litterclass','fates_leafage_class', \ + 'fates_prt_organs','fates_hydr_organs','fates_hlm_pftno']: + otherdimpresent = True + otherdimname = var.dimensions[i] + otherdimlength = var.shape[i] + elif var.dimensions[i] == 'fates_string_length' and rename_pft: + otherdimpresent = True + otherdimname = var.dimensions[i] + otherdimlength = var.shape[i] else: - print('WARNING: we need to change the dimension of '+otherdimname) - ### close the file that's open and start over. - ncfile.close() - os.remove(tempfilename) - ncfile = nc.netcdf_file(tempfilename, 'w') - ncfile_old = nc.netcdf_file(args.inputfname, 'r') - # - try: - ncfile.history = ncfile_old.history - except: - print('no history') - # - ### copy over and, when needed, modify the dimensions - for name, dimlength in ncfile_old.dimensions.items(): - #print(name, dimlength) - if name != otherdimname: - ncfile.createDimension(name, dimlength) + raise ValueError('variable dimension not handled in this script') + + # + if args.changeshape: + ### if we are allowing the script to change the shape of the variable, + ### then we need to figure out if that's really a thing that needs to happen. + ### first identify what dimension we would change the shape of if we had to. + length_specified = len(outputval) + if length_specified != otherdimlength: + ### ok, we find ourselves in the situation where we need to rewrite the netcdf + ### from scratch with its revised shape. + # + # first lets chech to make sure the dimension we are changing can be changed without breaking things. + plastic_dimensions_list = ['fates_history_age_bins','fates_history_size_bins', \ + 'fates_history_coage_bins','fates_history_height_bins', \ + 'fates_leafage_class'] + if otherdimname not in plastic_dimensions_list: + raise ValueError('asking to change the shape of a dimension, '+\ + otherdimname+', that will probably break things') else: - ncfile.createDimension(name, length_specified) - #print(name, length_specified) - # - ### copy over and, when needed, modify the variables - for name, variable in ncfile_old.variables.items(): - variabledims = variable.dimensions - #print(name, variabledims) - x = ncfile.createVariable(name, variable.data.dtype, variable.dimensions) - try: - x.units = variable.units - except: - print('no units') + print('WARNING: we need to change the dimension of '+otherdimname) + ### close the file that's open and start over. + ncfile.close() + os.remove(tempfilename) + ncfile = nc.netcdf_file(tempfilename, 'w') + ncfile_old = nc.netcdf_file(args.inputfname, 'r') + # try: - x.long_name = variable.long_name + ncfile.history = ncfile_old.history except: - print('no long name') + print('no history') # - if len(variable.dimensions) > 0: - if not otherdimname in variable.dimensions: - x[:] = variable[:] + ### copy over and, when needed, modify the dimensions + for name, dimlength in ncfile_old.dimensions.items(): + #print(name, dimlength) + if name != otherdimname: + ncfile.createDimension(name, dimlength) else: - if len(variable.dimensions) == 1: - if length_specified > otherdimlength: - print('WARNING: Variable '+name+' has a dimension that has been reshaped. New length is longer than old, so its been filled in with zeros.') - x[0:otherdimlength] = variable[0:otherdimlength] - x[otherdimlength:length_specified] = 0 - else: - print('WARNING: Variable '+name+' has a dimension that has been reshaped. New length is shorter than old, so its been truncated.') - x[0:length_specified] = variable[0:length_specified] - elif len(variable.dimensions) == 2: - if length_specified > otherdimlength: - print('WARNING: Variable '+name+' has a dimension that has been reshaped. New length is longer than old, so its been filled in with zeros.') - x[0:otherdimlength,:] = variable[0:otherdimlength,:] - x[otherdimlength:length_specified,:] = 0 - else: - print('WARNING: Variable '+name+' has a dimension that has been reshaped. New length is shorter than old, so its been truncated.') - x[0:length_specified,:] = variable[0:length_specified,:] - else: - x.assignValue(float(variable.data)) - # - var = ncfile.variables[args.varname] - else: - # declare as none for now - ncfile_old = None - # - if (args.pftnum == None and args.pftname == None and ispftvar) and not args.allpfts: - raise ValueError('pft value is missing but variable has pft dimension.') - if (args.pftnum != None or args.pftname != None) and args.allpfts: - raise ValueError("can't specify both a PFT number and the argument allPFTs.") - if (args.pftnum != None or args.pftname != None) and not ispftvar: - raise ValueError('pft value is present but variable does not have pft dimension.') - if (args.pftnum != None and args.pftname != None): - raise ValueError('can only specify pft number or name, not both.') - if (args.pftnum == None or args.pftname != None) and not args.allpfts and ispftvar: - ## now we need to figure out what the number of the pft that has been given a name argument - pftnamelist = [] - npftnames = ncfile.variables['fates_pftname'].shape[0] - for i in range(npftnames): - pftname_bytelist = list(ncfile.variables['fates_pftname'][i,:]) - pftname_stringlist = [i.decode('utf-8') for i in pftname_bytelist] - pftnamelist.append(''.join(pftname_stringlist).strip()) - n_times_pft_listed = pftnamelist.count(args.pftname.strip()) - if n_times_pft_listed != 1: - raise ValueError('can only index by PFT name if the chosen PFT name occurs once and only once.') - pftnum = pftnamelist.index(args.pftname.strip()) - args.pftnum=pftnum +1 - if args.pftnum != None and ispftvar: - if not rename_pft: - if args.pftnum > npft_file: - raise ValueError('PFT specified ('+str(args.pftnum)+') is larger than the number of PFTs in the file ('+str(npft_file)+').') + ncfile.createDimension(name, length_specified) + #print(name, length_specified) + # + ### copy over and, when needed, modify the variables + for name, variable in ncfile_old.variables.items(): + variabledims = variable.dimensions + #print(name, variabledims) + x = ncfile.createVariable(name, variable.data.dtype, variable.dimensions) + try: + x.units = variable.units + except: + print('no units') + try: + x.long_name = variable.long_name + except: + print('no long name') + # + if len(variable.dimensions) > 0: + if not otherdimname in variable.dimensions: + x[:] = variable[:] + else: + if len(variable.dimensions) == 1: + if length_specified > otherdimlength: + print('WARNING: Variable '+name+ \ + ' has a dimension that has been reshaped.'+\ + ' New length is longer than old, so its been filled in with zeros.') + x[0:otherdimlength] = variable[0:otherdimlength] + x[otherdimlength:length_specified] = 0 + else: + print('WARNING: Variable '+name+' has a dimension that has been reshaped.'+\ + ' New length is shorter than old, so its been truncated.') + x[0:length_specified] = variable[0:length_specified] + elif len(variable.dimensions) == 2: + if length_specified > otherdimlength: + print('WARNING: Variable '+name+' has a dimension that has been reshaped.'+\ + ' New length is longer than old, so its been filled in with zeros.') + x[0:otherdimlength,:] = variable[0:otherdimlength,:] + x[otherdimlength:length_specified,:] = 0 + else: + print('WARNING: Variable '+name+' has a dimension that has been reshaped.'+\ + ' New length is shorter than old, so its been truncated.') + x[0:length_specified,:] = variable[0:length_specified,:] + else: + x.assignValue(float(variable.data)) + # + var = ncfile.variables[args.varname] + else: + # declare as none for now + ncfile_old = None + # + if (args.pftnum == None and args.pftname == None and ispftvar) and not args.allpfts: + raise ValueError('pft value is missing but variable has pft dimension.') + if (args.pftnum != None or args.pftname != None) and args.allpfts: + raise ValueError("can't specify both a PFT number and the argument allPFTs.") + if (args.pftnum != None or args.pftname != None) and not ispftvar: + raise ValueError('pft value is present but variable does not have pft dimension.') + if (args.pftnum != None and args.pftname != None): + raise ValueError('can only specify pft number or name, not both.') + if (args.pftnum == None or args.pftname != None) and not args.allpfts and ispftvar: + ## now we need to figure out what the number of the pft that has been given a name argument + pftnamelist = [] + npftnames = ncfile.variables['fates_pftname'].shape[0] + for i in range(npftnames): + pftname_bytelist = list(ncfile.variables['fates_pftname'][i,:]) + pftname_stringlist = [i.decode('utf-8') for i in pftname_bytelist] + pftnamelist.append(''.join(pftname_stringlist).strip()) + n_times_pft_listed = pftnamelist.count(args.pftname.strip()) + if n_times_pft_listed != 1: + raise ValueError('can only index by PFT name if the chosen PFT name occurs once and only once.') + pftnum = pftnamelist.index(args.pftname.strip()) + args.pftnum=pftnum +1 + if args.pftnum != None and ispftvar: + if not rename_pft: + if args.pftnum > npft_file: + raise ValueError('PFT specified ('+str(args.pftnum)+') is larger than the number of PFTs in the file ('+str(npft_file)+').') + if pftdim == 0: + if not args.silent: + print('replacing prior value of variable '+args.varname+', for PFT '+str(args.pftnum)+', which was '+str(var[args.pftnum-1])+', with new value of '+str(outputval)) + var[args.pftnum-1] = outputval + if pftdim == 1: + if not args.silent: + print('replacing prior value of variable '+args.varname+', for PFT '+str(args.pftnum)+', which was '+str(var[:,args.pftnum-1])+', with new value of '+str(outputval)) + var[:,args.pftnum-1] = outputval + else: + pftname_in_bytelist = list(ncfile.variables['fates_pftname'][args.pftnum-1,:]) + pftname_in_stringlist = [i.decode('utf-8') for i in pftname_in_bytelist] + print('replacing prior value of pft name for PFT '+str(args.pftnum)+', which was "'+''.join(pftname_in_stringlist).strip()+'", with new value of "'+args.val+'"') + var[args.pftnum-1] = args.val.ljust(otherdimlength) + elif args.allpfts and ispftvar: if pftdim == 0: if not args.silent: - print('replacing prior value of variable '+args.varname+', for PFT '+str(args.pftnum)+', which was '+str(var[args.pftnum-1])+', with new value of '+str(outputval)) - var[args.pftnum-1] = outputval + print('replacing prior values of variable '+args.varname+', for all PFTs, which were '+str(var[:])+', with new value of '+str(outputval)) + var[:] = outputval if pftdim == 1: if not args.silent: - print('replacing prior value of variable '+args.varname+', for PFT '+str(args.pftnum)+', which was '+str(var[:,args.pftnum-1])+', with new value of '+str(outputval)) - var[:,args.pftnum-1] = outputval - else: - pftname_in_bytelist = list(ncfile.variables['fates_pftname'][args.pftnum-1,:]) - pftname_in_stringlist = [i.decode('utf-8') for i in pftname_in_bytelist] - print('replacing prior value of pft name for PFT '+str(args.pftnum)+', which was "'+''.join(pftname_in_stringlist).strip()+'", with new value of "'+args.val+'"') - var[args.pftnum-1] = args.val.ljust(otherdimlength) - elif args.allpfts and ispftvar: - if pftdim == 0: - if not args.silent: - print('replacing prior values of variable '+args.varname+', for all PFTs, which were '+str(var[:])+', with new value of '+str(outputval)) - var[:] = outputval - if pftdim == 1: - if not args.silent: - print('replacing prior values of variable '+args.varname+', for all PFTs, which were '+str(var[:])+', with new value of '+str(outputval)) - var[:] = outputval - elif args.pftnum == None and not ispftvar and ndim_file > 0: - if not otherdimpresent: + print('replacing prior values of variable '+args.varname+', for all PFTs, which were '+str(var[:])+', with new value of '+str(outputval)) + var[:] = outputval + elif args.pftnum == None and not ispftvar and ndim_file > 0: + if not otherdimpresent: + if not args.silent: + print('replacing prior value of variable '+args.varname+', which was '+str(var[:])+', with new value of '+str(outputval)) + var[:] = outputval + else: + #print(var.shape) + #print(outputval.shape) + if not args.silent: + print('replacing prior value of variable '+args.varname+', which was '+str(var[:])+', with new value of '+str(outputval)) + var[:] = outputval + elif ndim_file < 1: if not args.silent: - print('replacing prior value of variable '+args.varname+', which was '+str(var[:])+', with new value of '+str(outputval)) - var[:] = outputval + print('replacing prior value of scalar variable '+args.varname+', which was '+str(var.data)+', with new value of '+str(outputval)) + var.assignValue(outputval) else: - #print(var.shape) - #print(outputval.shape) - if not args.silent: - print('replacing prior value of variable '+args.varname+', which was '+str(var[:])+', with new value of '+str(outputval)) - var[:] = outputval - elif ndim_file < 1: - if not args.silent: - print('replacing prior value of scalar variable '+args.varname+', which was '+str(var.data)+', with new value of '+str(outputval)) - var.assignValue(outputval) - else: - raise ValueError('Nothing happened somehow.') + raise ValueError('Nothing happened somehow.') + # if not args.nohist: # write to the netcdf file history attribute what you just did. @@ -250,6 +310,9 @@ def main(): oldhiststr = ncfile.history.decode('utf-8') newhiststr = oldhiststr + "\n "+timestampstring + ': ' + actionstring ncfile.history = newhiststr + + + # ncfile.close() if type(ncfile_old) != type(None): diff --git a/tools/ncdiff b/tools/ncdiff new file mode 100755 index 0000000000..37709b4ad1 --- /dev/null +++ b/tools/ncdiff @@ -0,0 +1,21 @@ +#!/usr/bin/env bash + +while getopts ":h" option; do + case $option in + h) # display Help + echo "script that compares the differences between two netcdf files." + echo "two arguments are the paths to two files to compare" + exit;; + esac +done + +tempfile1=$(mktemp) +tempfile2=$(mktemp) + +ncdump $1 >> ${tempfile1} +ncdump $2 >> ${tempfile2} + +diff ${tempfile1} ${tempfile2} + +rm ${tempfile1} +rm ${tempfile2} diff --git a/tools/ncvarsort.py b/tools/ncvarsort.py index bd6587378d..e9cdc422b4 100755 --- a/tools/ncvarsort.py +++ b/tools/ncvarsort.py @@ -29,7 +29,7 @@ def main(): # make empty lists to hold the variable names in. the first of these is a list of sub-lists, # one for each type of variable (based on dimensionality). # the second is the master list that will contain all variables. - varnames_list = [[],[],[],[],[],[],[],[],[],[]] + varnames_list = [[],[],[],[],[],[],[],[],[],[],[],[],[]] varnames_list_sorted = [] # # sort the variables by dimensionality, but mix the PFT x other dimension in with the regular PFT-indexed variables @@ -38,15 +38,20 @@ def main(): (u'fates_history_coage_bins',):1, (u'fates_history_height_bins',):2, (u'fates_history_size_bins',):3, - (u'fates_pft', u'fates_string_length'):4, - (u'fates_prt_organs', u'fates_string_length'):5, - (u'fates_pft',):6, - (u'fates_hydr_organs', u'fates_pft'):6, - (u'fates_leafage_class', u'fates_pft'):6, - (u'fates_prt_organs', u'fates_pft'):6, - (u'fates_litterclass',):7, - (u'fates_NCWD',):8, - ():9} + (u'fates_hydr_organs',):4, + (u'fates_prt_organs',):4, + (u'fates_pft', u'fates_string_length'):5, + (u'fates_hydr_organs', u'fates_string_length'):6, + (u'fates_prt_organs', u'fates_string_length'):7, + (u'fates_litterclass', u'fates_string_length'):7, + (u'fates_pft',):8, + (u'fates_hydr_organs', u'fates_pft'):8, + (u'fates_leafage_class', u'fates_pft'):8, + (u'fates_prt_organs', u'fates_pft'):8, + (u'fates_hlm_pftno', u'fates_pft'):9, + (u'fates_litterclass',):10, + (u'fates_NCWD',):11, + ():12} # # go through each of the variables and assign it to one of the sub-lists based on its dimensionality for v_name, varin in dsin.variables.items(): @@ -78,7 +83,8 @@ def main(): # #Copy dimensions for dname, the_dim in dsin.dimensions.items(): - print(dname, the_dim.size) + if args.debug: + print(dname, the_dim.size) dsout.createDimension(dname, the_dim.size ) # print() @@ -95,7 +101,8 @@ def main(): v_name = varnames_list_sorted[i] varin = dsin.variables[v_name] outVar = dsout.createVariable(v_name, varin.datatype, varin.dimensions) - print(v_name) + if args.debug: + print(v_name) # outVar.setncatts({k: varin.getncattr(k) for k in varin.ncattrs()}) outVar[:] = varin[:] diff --git a/tools/pftdiff b/tools/pftdiff new file mode 100755 index 0000000000..a2d7305bb2 --- /dev/null +++ b/tools/pftdiff @@ -0,0 +1,33 @@ +#!/usr/bin/env bash + +while getopts ":h" option; do + case $option in + h) # display Help + echo "script to compare two PFTs in a FATES parameter file. takes three arguments: " + echo "first argument is the parameter file name" + echo "second argument is the first pft number (PFT numbering starts with 1)" + echo "third argument is the second pft number (PFT numbering starts with 1)" + exit;; + esac +done + + +tempfile1=$(mktemp) +tempfile2=$(mktemp) +tempfile3=$(mktemp) +tempfile4=$(mktemp) + +toolsdir=$(dirname "$0") + +$toolsdir/FatesPFTIndexSwapper.py --pft-indices=$2 --fin=$1 --fout=${tempfile1} 1>/dev/null +$toolsdir/FatesPFTIndexSwapper.py --pft-indices=$3 --fin=$1 --fout=${tempfile2} 1>/dev/null + +ncdump ${tempfile1} >> ${tempfile3} +ncdump ${tempfile2} >> ${tempfile4} + +diff ${tempfile3} ${tempfile4} + +rm ${tempfile1} +rm ${tempfile2} +rm ${tempfile3} +rm ${tempfile4}