diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000000..7ee0dc8765 --- /dev/null +++ b/.gitignore @@ -0,0 +1,51 @@ +# Compiled source # +################### +*.com +*.class +*.dll +*.exe +*.o +*.so +*.mod +*.pyc +*.pdf + +# Packages # +############ +# it's better to unpack these files and commit the raw source +# git has its own built in compression methods +*.7z +*.dmg +*.gz +*.iso +*.jar +*.rar +*.tar +*.zip +*.nc + +# Logs and databases # +###################### +*.log +*.sql +*.out +*.sqlite + +# OS generated files # +###################### +.DS_Store +.DS_Store? +._* +.Spotlight-V100 +.Trashes +ehthumbs.db +Thumbs.db + +# Latex/Tex files # +*.aux +*.dvi +*.toc + + +# Old Files +*~ \ No newline at end of file diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index b65b356e0e..caf6861577 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -14,6 +14,7 @@ module EDCanopyStructureMod use EDPftvarcon , only : EDPftvarcon_inst use FatesAllometryMod , only : carea_allom use EDCohortDynamicsMod , only : copy_cohort, terminate_cohorts, fuse_cohorts + use EDCohortDynamicsMod , only : InitPRTCohort use FatesAllometryMod , only : tree_lai use FatesAllometryMod , only : tree_sai use EDtypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type, ncwd @@ -26,6 +27,16 @@ module EDCanopyStructureMod use FatesInterfaceMod , only : numpft use FatesPlantHydraulicsMod, only : UpdateH2OVeg,InitHydrCohort + use PRTGenericMod, only : leaf_organ + use PRTGenericMod, only : all_carbon_elements + 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 PRTGenericMod, only : SetState + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -319,6 +330,11 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) type(ed_cohort_type), pointer :: currentCohort,copyc 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) :: lossarea real(r8) :: newarea real(r8) :: demote_area @@ -454,6 +470,12 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) 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(currentCohort%canopy_layer == i_lyr .and. cc_loss>nearzero )then if ( (cc_loss-currentCohort%c_area) > -nearzero .and. & @@ -468,7 +490,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) currentSite%demotion_rate(currentCohort%size_class) = & currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & - currentCohort%b_total() * currentCohort%n + (leaf_c + store_c + fnrt_c + sapw_c + struct_c) * currentCohort%n elseif(cc_loss > nearzero .and. cc_loss < currentCohort%c_area )then @@ -481,10 +503,11 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) ! demoted to the understory allocate(copyc) - call copy_cohort(currentCohort, copyc) + call InitPRTCohort(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 @@ -499,7 +522,7 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) currentSite%demotion_rate(currentCohort%size_class) = & currentSite%demotion_rate(currentCohort%size_class) + currentCohort%n currentSite%demotion_carbonflux = currentSite%demotion_carbonflux + & - currentCohort%b_total() * currentCohort%n + (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, & @@ -532,46 +555,46 @@ subroutine DemoteFromLayer(currentSite,currentPatch,i_lyr) do i_cwd=1,ncwd currentPatch%CWD_AG(i_cwd) = currentPatch%CWD_AG(i_cwd) + & - (currentCohort%bdead+currentCohort%bsw) * & + (struct_c + sapw_c ) * & EDPftvarcon_inst%allom_agb_frac(currentCohort%pft) * & SF_val_CWD_frac(i_cwd)*currentCohort%n/currentPatch%area currentPatch%CWD_BG(i_cwd) = currentPatch%CWD_BG(i_cwd) + & - (currentCohort%bdead+currentCohort%bsw) * & + (struct_c + sapw_c) * & (1.0_r8-EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)) * & SF_val_CWD_frac(i_cwd)*currentCohort%n/currentPatch%area !litter flux per m2. enddo currentPatch%leaf_litter(currentCohort%pft) = & - currentPatch%leaf_litter(currentCohort%pft) + (currentCohort%bl)* & - currentCohort%n/currentPatch%area ! leaf litter flux per m2. + currentPatch%leaf_litter(currentCohort%pft) + & + leaf_c * currentCohort%n/currentPatch%area ! leaf litter flux per m2. currentPatch%root_litter(currentCohort%pft) = & currentPatch%root_litter(currentCohort%pft) + & - (currentCohort%br+currentCohort%bstore)*currentCohort%n/currentPatch%area + (fnrt_c + store_c) * currentCohort%n/currentPatch%area ! keep track of the above fluxes at the site level as a ! CWD/litter input flux (in kg / site-m2 / yr) do i_cwd=1,ncwd currentSite%CWD_AG_diagnostic_input_carbonflux(i_cwd) = & currentSite%CWD_AG_diagnostic_input_carbonflux(i_cwd) & - + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & + + currentCohort%n * (struct_c + sapw_c) * & SF_val_CWD_frac(i_cwd) * EDPftvarcon_inst%allom_agb_frac(currentCohort%pft) & * hlm_days_per_year / AREA currentSite%CWD_BG_diagnostic_input_carbonflux(i_cwd) = & currentSite%CWD_BG_diagnostic_input_carbonflux(i_cwd) & - + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & + + currentCohort%n * (struct_c + sapw_c) * & SF_val_CWD_frac(i_cwd) * (1.0_r8 - & EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)) * hlm_days_per_year / AREA enddo currentSite%leaf_litter_diagnostic_input_carbonflux(currentCohort%pft) = & currentSite%leaf_litter_diagnostic_input_carbonflux(currentCohort%pft) + & - currentCohort%n * (currentCohort%bl) * hlm_days_per_year / AREA + currentCohort%n * leaf_c * hlm_days_per_year / AREA currentSite%root_litter_diagnostic_input_carbonflux(currentCohort%pft) = & currentSite%root_litter_diagnostic_input_carbonflux(currentCohort%pft) + & - currentCohort%n * (currentCohort%br+currentCohort%bstore) * hlm_days_per_year / AREA + currentCohort%n * (fnrt_c + store_c) * hlm_days_per_year / AREA currentCohort%n = 0.0_r8 currentCohort%c_area = 0.0_r8 @@ -641,7 +664,11 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) 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] call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr,arealayer_current) call CanopyLayerArea(currentPatch,currentSite%spread,i_lyr+1,arealayer_below) @@ -663,15 +690,22 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) 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_rate(currentCohort%size_class) + currentCohort%n currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & - currentCohort%b_total() * currentCohort%n - + (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n + endif currentCohort => currentCohort%shorter enddo @@ -787,7 +821,9 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) 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 @@ -801,17 +837,25 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,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 + + 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) + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & - currentCohort%b_total() * currentCohort%n + (leaf_c + fnrt_c + store_c + sapw_c + struct_c) * currentCohort%n elseif ( cc_gain > nearzero .and. cc_gain < currentCohort%c_area) then allocate(copyc) - call copy_cohort(currentCohort, copyc) !makes an identical copy... + call InitPRTCohort(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, & @@ -829,8 +873,15 @@ subroutine PromoteIntoLayer(currentSite,currentPatch,i_lyr) ! keep track of number and biomass of promoted cohort currentSite%promotion_rate(copyc%size_class) = & currentSite%promotion_rate(copyc%size_class) + copyc%n + + leaf_c = copyc%prt%GetState(leaf_organ,all_carbon_elements) + store_c = copyc%prt%GetState(store_organ,all_carbon_elements) + fnrt_c = copyc%prt%GetState(fnrt_organ,all_carbon_elements) + sapw_c = copyc%prt%GetState(sapw_organ,all_carbon_elements) + struct_c = copyc%prt%GetState(struct_organ,all_carbon_elements) + currentSite%promotion_carbonflux = currentSite%promotion_carbonflux + & - copyc%b_total() * copyc%n + (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) @@ -964,7 +1015,11 @@ subroutine canopy_summarization( nsites, sites, bc_in ) integer :: ifp integer :: patchn ! identification number for each patch. real(r8) :: canopy_leaf_area ! total amount of leaf area in the vegetated area. m2. - + real(r8) :: leaf_c ! leaf carbon [kg] + real(r8) :: fnrt_c ! fineroot carbon [kg] + real(r8) :: sapw_c ! sapwood carbon [kg] + real(r8) :: store_c ! storage carbon [kg] + real(r8) :: struct_c ! structure carbon [kg] !---------------------------------------------------------------------- if ( debug ) then @@ -1007,7 +1062,12 @@ subroutine canopy_summarization( nsites, sites, bc_in ) ft = currentCohort%pft - + + 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) + 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 @@ -1017,7 +1077,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) call carea_allom(currentCohort%dbh,currentCohort%n,sites(s)%spread,& currentCohort%pft,currentCohort%c_area) - currentCohort%treelai = tree_lai(currentCohort%bl, & + currentCohort%treelai = tree_lai(leaf_c, & currentCohort%pft, currentCohort%c_area, currentCohort%n, & currentCohort%canopy_layer, currentPatch%canopy_layer_tlai ) @@ -1041,9 +1101,9 @@ subroutine canopy_summarization( nsites, sites, bc_in ) currentCohort%pft,currentCohort%canopy_trim call endrun(msg=errMsg(sourcefile, __LINE__)) endif - if( (currentCohort%bsw + currentCohort%bl + currentCohort%br) <= 0._r8)then + if( (sapw_c + leaf_c + fnrt_c) <= 0._r8)then write(fates_log(),*) 'FATES: alive biomass is zero in canopy_summarization', & - currentCohort%bsw + currentCohort%bl + currentCohort%br + sapw_c + leaf_c + fnrt_c call endrun(msg=errMsg(sourcefile, __LINE__)) endif @@ -1139,6 +1199,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) real(r8) :: max_chite ! top of cohort canopy (m) real(r8) :: lai ! summed lai for checking m2 m-2 real(r8) :: snow_depth_avg ! avg snow over whole site + real(r8) :: leaf_c ! leaf carbon [kg] !---------------------------------------------------------------------- @@ -1189,7 +1250,9 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) ! 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 - currentCohort%treelai = tree_lai(currentCohort%bl, currentCohort%pft, currentCohort%c_area, & + 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 ) @@ -1359,11 +1422,11 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) ! is obscured by snow. layer_top_hite = currentCohort%hite - & - ( dble(iv-1.0)/currentCohort%NV * currentCohort%hite * & + ( real(iv-1,r8)/currentCohort%NV * currentCohort%hite * & EDPftvarcon_inst%crown(currentCohort%pft) ) layer_bottom_hite = currentCohort%hite - & - ( dble(iv)/currentCohort%NV * currentCohort%hite * & + ( real(iv,r8)/currentCohort%NV * currentCohort%hite * & EDPftvarcon_inst%crown(currentCohort%pft) ) fraction_exposed = 1.0_r8 @@ -1386,7 +1449,7 @@ subroutine leaf_area_profile( currentSite , snow_depth_si, frac_sno_eff_si) if(iv==currentCohort%NV) then remainder = (currentCohort%treelai + currentCohort%treesai) - & - (dinc_ed*dble(currentCohort%nv-1.0_r8)) + (dinc_ed*real(currentCohort%nv-1,r8)) if(remainder > dinc_ed )then write(fates_log(), *)'ED: issue with remainder', & currentCohort%treelai,currentCohort%treesai,dinc_ed, & diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index 1da7190006..71a1416cfc 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -22,6 +22,7 @@ module EDCohortDynamicsMod use EDTypesMod , only : min_n_safemath use EDTypesMod , only : nlevleaf use FatesInterfaceMod , only : hlm_use_planthydro + use FatesInterfaceMod , only : hlm_parteh_mode use FatesPlantHydraulicsMod, only : FuseCohortHydraulics use FatesPlantHydraulicsMod, only : CopyCohortHydraulics use FatesPlantHydraulicsMod, only : updateSizeDepTreeHydProps @@ -36,6 +37,31 @@ module EDCohortDynamicsMod use FatesAllometryMod , only : carea_allom use FatesAllometryMod , only : StructureResetOfDH use FatesAllometryMod , only : tree_lai, tree_sai + + use PRTGenericMod, only : prt_carbon_allom_hyp + use PRTGenericMod, only : prt_cnp_flex_allom_hyp + use PRTGenericMod, only : InitPRTVartype + use PRTGenericMod, only : prt_vartypes + use PRTGenericMod, only : all_carbon_elements + use PRTGenericMod, only : carbon12_element + use PRTGenericMod, only : nitrogen_element + use PRTGenericMod, only : phosphorous_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 PRTGenericMod, only : SetState + + use PRTAllometricCarbonMod, only : callom_prt_vartypes + use PRTAllometricCarbonMod, only : ac_bc_inout_id_netdc + use PRTAllometricCarbonMod, only : ac_bc_in_id_pft + use PRTAllometricCarbonMod, only : ac_bc_in_id_ctrim + use PRTAllometricCarbonMod, only : ac_bc_inout_id_dbh + + + ! CIME globals use shr_log_mod , only : errMsg => shr_log_errMsg ! @@ -51,6 +77,7 @@ module EDCohortDynamicsMod public :: sort_cohorts public :: copy_cohort public :: count_cohorts + public :: InitPRTCohort logical, parameter :: debug = .false. ! local debug flag @@ -124,12 +151,39 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, dbh, bleaf, bfine new_cohort%canopy_layer = clayer new_cohort%canopy_layer_yesterday = real(clayer, r8) new_cohort%laimemory = laimemory - new_cohort%bdead = bdead - new_cohort%bstore = bstore - new_cohort%bl = bleaf - new_cohort%br = bfineroot - new_cohort%bsw = bsap - new_cohort%ode_opt_step = 1.0e6_r8 ! Initialize the integrator step size as super-huge + + + ! Initialize the Plant allocative Reactive Transport (PaRT) module + ! Choose from one of the extensible hypotheses (EH) + ! ----------------------------------------------------------------------------------- + + call InitPRTCohort(new_cohort) + + ! The initialization allocates memory, but the boundary and initial + ! contitions must be set. All new cohorts go through create_cohort() + ! so this should be the only place this is called. Alternatively + ! cohorts can be copied and fused, but special routines handle that. + ! ----------------------------------------------------------------------------------- + + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp) + + call SetState(new_cohort%prt,leaf_organ, carbon12_element, bleaf) + call SetState(new_cohort%prt,fnrt_organ, carbon12_element, bfineroot) + call SetState(new_cohort%prt,sapw_organ, carbon12_element, bsap) + call SetState(new_cohort%prt,store_organ, carbon12_element, bstore) + call SetState(new_cohort%prt,struct_organ , carbon12_element, bdead) + call SetState(new_cohort%prt,repro_organ , carbon12_element, 0.0_r8) + + end select + + + ! This call cycles through the initial conditions, and makes sure that they + ! are all initialized. + ! ----------------------------------------------------------------------------------- + + call new_cohort%prt%CheckInitialConditions() + call sizetype_class_index(new_cohort%dbh,new_cohort%pft, & new_cohort%size_class,new_cohort%size_by_pft_class) @@ -150,7 +204,7 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, dbh, bleaf, bfine ! Assign canopy extent and depth call carea_allom(new_cohort%dbh,new_cohort%n,spread,new_cohort%pft,new_cohort%c_area) - new_cohort%treelai = tree_lai(new_cohort%bl, new_cohort%pft, new_cohort%c_area, & + new_cohort%treelai = tree_lai(bleaf, new_cohort%pft, new_cohort%c_area, & new_cohort%n, new_cohort%canopy_layer, & patchptr%canopy_layer_tlai ) @@ -203,6 +257,84 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, dbh, bleaf, bfine end subroutine create_cohort + ! ------------------------------------------------------------------------------------- + + subroutine InitPRTCohort(new_cohort) + + ! ---------------------------------------------------------------------------------- + ! This subroutine simply allocates and attaches the correct PRT object. + ! The call to InitPRTVartype() performs the allocation of the variables + ! and boundary conditions inside the object. It also initializes + ! all values as unitialized (large bogus values). + ! + ! Each PARTEH allocation hypothesis has different expectations of boundary conditions. + ! These are specified by pointers to values in the host model. Because these + ! are pointers, they just need to be set once when the prt object is first initalized. + ! The calls below to "RegisterBCINOut", "RegisterBCIn" and "RegisterBCOut" are + ! setting those pointers. + ! ----------------------------------------------------------------------------------- + + ! + ! !ARGUMENTS + type(ed_cohort_type), intent(inout), target :: new_cohort + type(callom_prt_vartypes), pointer :: callom_prt + + + ! Allocate the PRT class object + ! Each hypothesis has a different object which is an extension + ! of the base class. + + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp) + + allocate(callom_prt) + new_cohort%prt => callom_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 new_cohort%prt%InitPRTVartype() + + + ! Set the boundary conditions that flow in an out of the PARTEH + ! allocation hypotheses. These are pointers in the PRT objects that + ! point to values outside in the FATES model. + + ! Example: + ! "ac_bc_inout_id_dbh" is the unique integer that defines the object index + ! for the allometric carbon "ac" boundary condition "bc" for DBH "dbh" + ! that is classified as input and output "inout". + ! See PRTAllometricCarbonMod.F90 to track its usage. + ! bc_rval is used as the optional argument identifyer to specify a real + ! value boundary condition. + ! bc_ival is used as the optional argument identifyer to specify an integer + ! value boundary condition. + + + 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) + call new_cohort%prt%RegisterBCIn(ac_bc_in_id_ctrim,bc_rval = new_cohort%canopy_trim) + + end select + + + return + end subroutine InitPRTCohort + !-------------------------------------------------------------------------------------! subroutine nan_cohort(cc_p) @@ -240,17 +372,13 @@ subroutine nan_cohort(cc_p) 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%n = nan ! number of individuals in cohort per 'area' (10000m2 default) currentCohort%dbh = nan ! 'diameter at breast height' in cm currentCohort%hite = nan ! height: meters - currentCohort%bdead = nan ! dead biomass: kGC per indiv - currentCohort%bstore = nan ! stored carbon: kGC per indiv currentCohort%laimemory = nan ! target leaf biomass- set from previous year: kGC per indiv - currentCohort%bsw = nan ! sapwood in stem and roots: kGC per indiv - currentCohort%bl = nan ! leaf biomass: kGC per indiv - currentCohort%br = nan ! fine root biomass: kGC per indiv currentCohort%lai = nan ! leaf area index of cohort m2/m2 currentCohort%sai = nan ! stem area index of cohort m2/m2 currentCohort%g_sb_laweight = nan ! Total leaf conductance of cohort (stomata+blayer) weighted by leaf-area [m/s]*[m2] @@ -275,13 +403,6 @@ subroutine nan_cohort(cc_p) currentCohort%resp_tstep = nan ! RESP: kgC/indiv/timestep currentCohort%resp_acc = nan ! RESP: kGC/cohort/day - currentCohort%npp_leaf = nan - currentCohort%npp_fnrt = nan - currentCohort%npp_sapw = nan - currentCohort%npp_dead = nan - currentCohort%npp_seed = nan - currentCohort%npp_stor = nan - !RESPIRATION currentCohort%rdark = nan currentCohort%resp_m = nan ! Maintenance respiration. kGC/cohort/year @@ -291,12 +412,6 @@ subroutine nan_cohort(cc_p) currentCohort%froot_mr = nan ! Fine root maintenance respiration. kgC/indiv/s-1 ! ALLOCATION - currentCohort%md = nan ! plant maintenance demand: kgC/indiv/year - currentCohort%leaf_md = nan ! leaf maintenance demand: kgC/indiv/year - currentCohort%root_md = nan ! root maintenance demand: kgC/indiv/year - currentCohort%bsw_md = nan - currentCohort%bdead_md = nan - currentCohort%bstore_md = nan currentCohort%dmort = nan ! proportional mortality rate. (year-1) currentCohort%lmort_direct = nan currentCohort%lmort_infra = nan @@ -307,14 +422,12 @@ subroutine nan_cohort(cc_p) currentCohort%c_area = nan ! areal extent of canopy (m2) currentCohort%treelai = nan ! lai of tree (total leaf area (m2) / canopy area (m2) currentCohort%treesai = nan ! stem area index of tree (total stem area (m2) / canopy area (m2) - currentCohort%leaf_litter = nan ! leaf litter from phenology: KgC/m2 + ! VARIABLES NEEDED FOR INTEGRATION currentCohort%dndt = nan ! time derivative of cohort size currentCohort%dhdt = nan ! time derivative of height currentCohort%ddbhdt = nan ! time derivative of dbh - currentCohort%dbdeaddt = nan ! time derivative of dead biomass - currentCohort%dbstoredt = nan ! time derivative of stored biomass ! FIRE currentCohort%fraction_crown_burned = nan ! proportion of crown affected by fire @@ -322,11 +435,10 @@ subroutine nan_cohort(cc_p) currentCohort%crownfire_mort = nan ! probability of tree post-fire mortality due to crown scorch currentCohort%fire_mort = nan ! post-fire mortality from cambial and crown damage assuming two are independent - currentCohort%ode_opt_step = nan ! integrator step size - end subroutine nan_cohort !-------------------------------------------------------------------------------------! + subroutine zero_cohort(cc_p) ! ! !DESCRIPTION: @@ -344,52 +456,42 @@ subroutine zero_cohort(cc_p) currentCohort => cc_p - currentCohort%NV = 0 - currentCohort%status_coh = 0 - currentCohort%rdark = 0._r8 - currentCohort%resp_m = 0._r8 - currentCohort%resp_g = 0._r8 - currentCohort%livestem_mr = 0._r8 - currentCohort%livecroot_mr = 0._r8 - currentCohort%froot_mr = 0._r8 - currentCohort%fire_mort = 0._r8 - currentcohort%npp_acc = 0._r8 - currentcohort%gpp_acc = 0._r8 - currentcohort%resp_acc = 0._r8 - currentcohort%npp_tstep = 0._r8 - currentcohort%gpp_tstep = 0._r8 - currentcohort%resp_tstep = 0._r8 - currentcohort%resp_acc_hold = 0._r8 - currentcohort%leaf_litter = 0._r8 - 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%seed_prod = 0._r8 + currentCohort%NV = 0 + currentCohort%status_coh = 0 + currentCohort%rdark = 0._r8 + currentCohort%resp_m = 0._r8 + currentCohort%resp_g = 0._r8 + currentCohort%livestem_mr = 0._r8 + currentCohort%livecroot_mr = 0._r8 + currentCohort%froot_mr = 0._r8 + currentCohort%fire_mort = 0._r8 + currentcohort%npp_acc = 0._r8 + currentcohort%gpp_acc = 0._r8 + currentcohort%resp_acc = 0._r8 + currentcohort%npp_tstep = 0._r8 + currentcohort%gpp_tstep = 0._r8 + currentcohort%resp_tstep = 0._r8 + currentcohort%resp_acc_hold = 0._r8 + + currentcohort%year_net_uptake(:) = 999._r8 ! this needs to be 999, or trimming of new cohorts will break. + currentcohort%ts_net_uptake(:) = 0._r8 + currentcohort%seed_prod = 0._r8 currentcohort%fraction_crown_burned = 0._r8 - currentcohort%md = 0._r8 - currentcohort%root_md = 0._r8 - currentcohort%leaf_md = 0._r8 - currentcohort%bstore_md = 0._r8 - currentcohort%bsw_md = 0._r8 - currentcohort%bdead_md = 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%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%npp_leaf = 0._r8 - currentCohort%npp_fnrt = 0._r8 - currentCohort%npp_sapw = 0._r8 - currentCohort%npp_dead = 0._r8 - currentCohort%npp_seed = 0._r8 - currentCohort%npp_stor = 0._r8 + currentCohort%size_class = 1 + 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%lmort_direct = 0._r8 + currentCohort%lmort_infra = 0._r8 + currentCohort%lmort_collateral = 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 end subroutine zero_cohort @@ -421,6 +523,13 @@ subroutine terminate_cohorts( currentSite, currentPatch, level ) 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 (1) or not (0) integer :: c ! counter for litter size class. integer :: levcan ! canopy level @@ -433,6 +542,13 @@ subroutine terminate_cohorts( currentSite, currentPatch, level ) terminate = 0 tallerCohort => currentCohort%taller + leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) + store_c = currentCohort%prt%GetState(store_organ, all_carbon_elements) + sapw_c = currentCohort%prt%GetState(sapw_organ, all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ, all_carbon_elements) + struct_c = currentCohort%prt%GetState(struct_organ, all_carbon_elements) + repro_c = currentCohort%prt%GetState(repro_organ, all_carbon_elements) + ! Check if number density is so low is breaks math (level 1) if (currentcohort%n < min_n_safemath .and. level == 1) then terminate = 1 @@ -447,7 +563,7 @@ subroutine terminate_cohorts( currentSite, currentPatch, level ) ! Not enough n or dbh if (currentCohort%n/currentPatch%area <= min_npm2 .or. & ! currentCohort%n <= min_nppatch .or. & - (currentCohort%dbh < 0.00001_r8.and.currentCohort%bstore < 0._r8) ) then + (currentCohort%dbh < 0.00001_r8 .and. store_c < 0._r8) ) then terminate = 1 if ( debug ) then @@ -464,25 +580,22 @@ subroutine terminate_cohorts( currentSite, currentPatch, level ) endif ! live biomass pools are terminally depleted - if ( (currentCohort%bsw+currentCohort%bl+currentCohort%br) < 1e-10_r8 .or. & - currentCohort%bstore < 1e-10_r8) then + if ( ( sapw_c+leaf_c+fnrt_c ) < 1e-10_r8 .or. & + store_c < 1e-10_r8) then terminate = 1 if ( debug ) then write(fates_log(),*) 'terminating cohorts 3', & - currentCohort%bsw,currentCohort%bl,currentCohort%br,currentCohort%bstore + sapw_c,leaf_c,fnrt_c,store_c endif endif ! Total cohort biomass is negative - if ( (currentCohort%b_total()) < 0._r8) then + if ( ( struct_c+sapw_c+leaf_c+fnrt_c+store_c ) < 0._r8) then terminate = 1 if ( debug ) then write(fates_log(),*) 'terminating cohorts 4', & - currentCohort%bsw, & - currentCohort%bl, & - currentCohort%br, & - currentCohort%bdead, & - currentCohort%bstore + struct_c,sapw_c,leaf_c,fnrt_c,store_c + endif endif @@ -495,50 +608,60 @@ subroutine terminate_cohorts( currentSite, currentPatch, level ) else levcan = 2 endif + currentSite%terminated_nindivs(currentCohort%size_class,currentCohort%pft,levcan) = & currentSite%terminated_nindivs(currentCohort%size_class,currentCohort%pft,levcan) + currentCohort%n ! currentSite%termination_carbonflux(levcan) = currentSite%termination_carbonflux(levcan) + & - currentCohort%n * currentCohort%b_total() - + currentCohort%n * (struct_c+sapw_c+leaf_c+fnrt_c+store_c+repro_c) !put the litter from the terminated cohorts straight into the fragmenting pools if (currentCohort%n.gt.0.0_r8) then do c=1,ncwd - currentPatch%CWD_AG(c) = currentPatch%CWD_AG(c) + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) / & + currentPatch%CWD_AG(c) = currentPatch%CWD_AG(c) + currentCohort%n*(struct_c+sapw_c) / & currentPatch%area & * SF_val_CWD_frac(c) * EDPftvarcon_inst%allom_agb_frac(currentCohort%pft) - currentPatch%CWD_BG(c) = currentPatch%CWD_BG(c) + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) / & + currentPatch%CWD_BG(c) = currentPatch%CWD_BG(c) + currentCohort%n*(struct_c+sapw_c) / & currentPatch%area & * SF_val_CWD_frac(c) * (1.0_r8 - EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)) enddo - + currentPatch%leaf_litter(currentCohort%pft) = currentPatch%leaf_litter(currentCohort%pft) + currentCohort%n* & - (currentCohort%bl)/currentPatch%area + (leaf_c)/currentPatch%area + currentPatch%root_litter(currentCohort%pft) = currentPatch%root_litter(currentCohort%pft) + currentCohort%n* & - (currentCohort%br+currentCohort%bstore)/currentPatch%area + (fnrt_c+store_c)/currentPatch%area + ! keep track of the above fluxes at the site level as a CWD/litter input flux (in kg / site-m2 / yr) do c=1,ncwd currentSite%CWD_AG_diagnostic_input_carbonflux(c) = currentSite%CWD_AG_diagnostic_input_carbonflux(c) & - + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & + + currentCohort%n*(struct_c + sapw_c) * & SF_val_CWD_frac(c) * EDPftvarcon_inst%allom_agb_frac(currentCohort%pft) * hlm_days_per_year / AREA currentSite%CWD_BG_diagnostic_input_carbonflux(c) = currentSite%CWD_BG_diagnostic_input_carbonflux(c) & - + currentCohort%n*(currentCohort%bdead+currentCohort%bsw) * & + + currentCohort%n*(struct_c + sapw_c) * & SF_val_CWD_frac(c) * (1.0_r8 - EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)) * hlm_days_per_year / AREA enddo currentSite%leaf_litter_diagnostic_input_carbonflux(currentCohort%pft) = & currentSite%leaf_litter_diagnostic_input_carbonflux(currentCohort%pft) + & - currentCohort%n * (currentCohort%bl) * hlm_days_per_year / AREA + currentCohort%n * (leaf_c) * hlm_days_per_year / AREA currentSite%root_litter_diagnostic_input_carbonflux(currentCohort%pft) = & currentSite%root_litter_diagnostic_input_carbonflux(currentCohort%pft) + & - currentCohort%n * (currentCohort%br+currentCohort%bstore) * hlm_days_per_year / AREA + currentCohort%n * (fnrt_c + store_c) * hlm_days_per_year / AREA end if + ! Zero out the state pools + call SetState(currentCohort%prt,leaf_organ,carbon12_element,0.0_r8) + call SetState(currentCohort%prt,fnrt_organ,carbon12_element,0.0_r8) + call SetState(currentCohort%prt,sapw_organ,carbon12_element,0.0_r8) + call SetState(currentCohort%prt,struct_organ,carbon12_element,0.0_r8) + call SetState(currentCohort%prt,repro_organ,carbon12_element,0.0_r8) + call SetState(currentCohort%prt,store_organ,carbon12_element,0.0_r8) + ! Set pointers and remove the current cohort from the list shorterCohort => currentCohort%shorter @@ -559,6 +682,11 @@ subroutine terminate_cohorts( currentSite, currentPatch, level ) ! At this point, nothing should be pointing to current Cohort if (hlm_use_planthydro.eq.itrue) call DeallocateHydrCohort(currentCohort) + + ! Deallocate the cohort's PRT structure + call currentCohort%prt%DeallocatePRTVartypes() + deallocate(currentCohort%prt) + deallocate(currentCohort) nullify(currentCohort) @@ -602,6 +730,9 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) real(r8) :: diff real(r8) :: dynamic_fusion_tolerance + integer :: largersc, smallersc, sc_i ! indices for tracking the growth flux caused by fusion + real(r8) :: larger_n, smaller_n + logical, parameter :: fuse_debug = .false. ! This debug is over-verbose ! and gets its own flag @@ -671,12 +802,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) write(fates_log(),*) 'Cohort I, Cohort II' write(fates_log(),*) 'n:',currentCohort%n,nextc%n write(fates_log(),*) 'isnew:',currentCohort%isnew,nextc%isnew - write(fates_log(),*) 'bdead:',currentCohort%bdead,nextc%bdead - write(fates_log(),*) 'bstore:',currentCohort%bstore,nextc%bstore write(fates_log(),*) 'laimemory:',currentCohort%laimemory,nextc%laimemory - write(fates_log(),*) 'bsw:',currentCohort%bsw,nextc%bsw - write(fates_log(),*) 'bl:',currentCohort%bl ,nextc%bl - write(fates_log(),*) 'br:',currentCohort%br,nextc%br write(fates_log(),*) 'hite:',currentCohort%hite,nextc%hite write(fates_log(),*) 'dbh:',currentCohort%dbh,nextc%dbh write(fates_log(),*) 'pft:',currentCohort%pft,nextc%pft @@ -688,19 +814,14 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) currentCohort%year_net_uptake(i),nextc%year_net_uptake(i) end do end if - - currentCohort%bdead = (currentCohort%n*currentCohort%bdead & - + nextc%n*nextc%bdead)/newn - currentCohort%bstore = (currentCohort%n*currentCohort%bstore & - + nextc%n*nextc%bstore)/newn + + + ! Fuse all mass pools + call currentCohort%prt%WeightedFusePRTVartypes(nextc%prt, currentCohort%n/newn ) + currentCohort%laimemory = (currentCohort%n*currentCohort%laimemory & + nextc%n*nextc%laimemory)/newn - currentCohort%bsw = (currentCohort%n*currentCohort%bsw & - + nextc%n*nextc%bsw)/newn - currentCohort%bl = (currentCohort%n*currentCohort%bl & - + nextc%n*nextc%bl)/newn - currentCohort%br = (currentCohort%n*currentCohort%br & - + nextc%n*nextc%br)/newn + currentCohort%dbh = (currentCohort%n*currentCohort%dbh & + nextc%n*nextc%dbh)/newn @@ -718,7 +839,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) ! ----------------------------------------------------------------- if( EDPftvarcon_inst%woody(currentCohort%pft) == itrue ) then - call StructureResetOfDH( currentCohort%bdead, currentCohort%pft, & + call StructureResetOfDH( currentCohort%prt%GetState(struct_organ,all_carbon_elements), currentCohort%pft, & currentCohort%canopy_trim, currentCohort%dbh, currentCohort%hite ) end if @@ -731,25 +852,49 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) currentCohort%canopy_layer_yesterday = (currentCohort%n*currentCohort%canopy_layer_yesterday + & nextc%n*nextc%canopy_layer_yesterday)/newn + ! keep track of the size class bins so that we can monitor growth fluxes + ! compare the values. if they are the same, then nothing needs to be done. if not, track the diagnostic flux + if (currentCohort%size_class_lasttimestep .ne. nextc%size_class_lasttimestep ) then + ! + ! keep track of which was which, irresespective of which cohort they were in + if (currentCohort%size_class_lasttimestep .gt. nextc%size_class_lasttimestep) then + largersc = currentCohort%size_class_lasttimestep + smallersc = nextc%size_class_lasttimestep + larger_n = currentCohort%n + smaller_n = nextc%n + else + largersc = nextc%size_class_lasttimestep + smallersc = currentCohort%size_class_lasttimestep + larger_n = nextc%n + smaller_n = currentCohort%n + endif + ! + ! it is possible that fusion has caused cohorts separated by at least two size bin deltas to join. + ! so slightly complicated to keep track of because the resulting cohort could be in one of the old bins or in between + ! structure as a loop to handle the general case + ! + ! first the positive growth case + do sc_i = smallersc + 1, currentCohort%size_class + currentSite%growthflux_fusion(sc_i, currentCohort%pft) = & + currentSite%growthflux_fusion(sc_i, currentCohort%pft) + smaller_n + end do + ! + ! next the negative growth case + do sc_i = currentCohort%size_class + 1, largersc + currentSite%growthflux_fusion(sc_i, currentCohort%pft) = & + currentSite%growthflux_fusion(sc_i, currentCohort%pft) - larger_n + end do + ! now that we've tracked the change flux. reset the memory of the prior timestep + currentCohort%size_class_lasttimestep = currentCohort%size_class + endif + ! Flux and biophysics variables have not been calculated for recruits we just default to ! their initization values, which should be the same for eahc if ( .not.currentCohort%isnew) then - currentCohort%md = (currentCohort%n*currentCohort%md + & - nextc%n*nextc%md)/newn currentCohort%seed_prod = (currentCohort%n*currentCohort%seed_prod + & nextc%n*nextc%seed_prod)/newn - currentCohort%root_md = (currentCohort%n*currentCohort%root_md + & - nextc%n*nextc%root_md)/newn - currentCohort%leaf_md = (currentCohort%n*currentCohort%leaf_md + & - nextc%n*nextc%leaf_md)/newn - currentCohort%bstore_md = (currentCohort%n*currentCohort%bstore_md + & - nextc%n*nextc%bstore_md)/newn - currentCohort%bsw_md = (currentCohort%n*currentCohort%bsw_md + & - nextc%n*nextc%bsw_md)/newn - currentCohort%bdead_md = (currentCohort%n*currentCohort%bdead_md + & - nextc%n*nextc%bdead_md)/newn currentCohort%gpp_acc = (currentCohort%n*currentCohort%gpp_acc + & nextc%n*nextc%gpp_acc)/newn currentCohort%npp_acc = (currentCohort%n*currentCohort%npp_acc + & @@ -777,8 +922,6 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) currentCohort%fire_mort = (currentCohort%n*currentCohort%fire_mort + & nextc%n*nextc%fire_mort)/newn - currentCohort%leaf_litter = (currentCohort%n*currentCohort%leaf_litter + & - nextc%n*nextc%leaf_litter)/newn ! mortality diagnostics currentCohort%cmort = (currentCohort%n*currentCohort%cmort + nextc%n*nextc%cmort)/newn @@ -795,31 +938,9 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) currentCohort%lmort_infra = (currentCohort%n*currentCohort%lmort_infra + & nextc%n*nextc%lmort_infra)/newn - ! npp diagnostics - currentCohort%npp_leaf = (currentCohort%n*currentCohort%npp_leaf + & - nextc%n*nextc%npp_leaf)/newn - currentCohort%npp_fnrt = (currentCohort%n*currentCohort%npp_fnrt + & - nextc%n*nextc%npp_fnrt)/newn - currentCohort%npp_sapw = (currentCohort%n*currentCohort%npp_sapw + & - nextc%n*nextc%npp_sapw)/newn - currentCohort%npp_dead = (currentCohort%n*currentCohort%npp_dead + & - nextc%n*nextc%npp_dead)/newn - currentCohort%npp_seed = (currentCohort%n*currentCohort%npp_seed + & - nextc%n*nextc%npp_seed)/newn - currentCohort%npp_stor = (currentCohort%n*currentCohort%npp_stor + & - nextc%n*nextc%npp_stor)/newn - ! biomass and dbh tendencies currentCohort%ddbhdt = (currentCohort%n*currentCohort%ddbhdt + & nextc%n*nextc%ddbhdt)/newn - currentCohort%dbdeaddt = (currentCohort%n*currentCohort%dbdeaddt + & - nextc%n*nextc%dbdeaddt)/newn - currentCohort%dbstoredt = (currentCohort%n*currentCohort%dbstoredt + & - nextc%n*nextc%dbstoredt)/newn - - ! Integration step size - currentCohort%ode_opt_step = (currentCohort%n*currentCohort%ode_opt_step + & - nextc%n*nextc%ode_opt_step)/newn do i=1, nlevleaf if (currentCohort%year_net_uptake(i) == 999._r8 .or. nextc%year_net_uptake(i) == 999._r8) then @@ -856,6 +977,11 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) ! At this point, nothing should be pointing to current Cohort if (hlm_use_planthydro.eq.itrue) call DeallocateHydrCohort(nextc) + + ! Deallocate the cohort's PRT structure + call nextc%prt%DeallocatePRTVartypes() + deallocate(nextc%prt) + deallocate(nextc) nullify(nextc) @@ -1118,12 +1244,7 @@ subroutine copy_cohort( currentCohort,copyc ) n%n = o%n n%dbh = o%dbh n%hite = o%hite - n%bdead = o%bdead - n%bstore = o%bstore n%laimemory = o%laimemory - n%bsw = o%bsw - n%bl = o%bl - n%br = o%br n%lai = o%lai n%sai = o%sai n%g_sb_laweight = o%g_sb_laweight @@ -1136,8 +1257,13 @@ subroutine copy_cohort( currentCohort,copyc ) 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 + ! This transfers the PRT objects over. + call n%prt%CopyPRTVartypes(o%prt) + + ! CARBON FLUXES n%gpp_acc_hold = o%gpp_acc_hold n%gpp_acc = o%gpp_acc @@ -1156,13 +1282,6 @@ subroutine copy_cohort( currentCohort,copyc ) n%year_net_uptake = o%year_net_uptake n%ts_net_uptake = o%ts_net_uptake - n%npp_leaf = o%npp_leaf - n%npp_fnrt = o%npp_fnrt - n%npp_sapw = o%npp_sapw - n%npp_dead = o%npp_dead - n%npp_seed = o%npp_seed - n%npp_stor = o%npp_stor - !RESPIRATION n%rdark = o%rdark n%resp_m = o%resp_m @@ -1172,12 +1291,6 @@ subroutine copy_cohort( currentCohort,copyc ) n%froot_mr = o%froot_mr ! ALLOCATION - n%md = o%md - n%leaf_md = o%leaf_md - n%root_md = o%root_md - n%bsw_md = o%bsw_md - n%bdead_md = o%bdead_md - n%bstore_md = o%bstore_md n%dmort = o%dmort n%lmort_direct = o%lmort_direct n%lmort_infra = o%lmort_infra @@ -1185,7 +1298,6 @@ subroutine copy_cohort( currentCohort,copyc ) n%seed_prod = o%seed_prod n%treelai = o%treelai n%treesai = o%treesai - n%leaf_litter = o%leaf_litter n%c_area = o%c_area ! Mortality diagnostics @@ -1203,15 +1315,10 @@ subroutine copy_cohort( currentCohort,copyc ) ! Flags n%isnew = o%isnew - ! Integrator memory - n%ode_opt_step = o%ode_opt_step - ! VARIABLES NEEDED FOR INTEGRATION n%dndt = o%dndt n%dhdt = o%dhdt n%ddbhdt = o%ddbhdt - n%dbdeaddt = o%dbdeaddt - n%dbstoredt = o%dbstoredt if ( debug ) write(fates_log(),*) 'EDCohortDyn dpstoredt ',o%dbstoredt @@ -1229,6 +1336,7 @@ subroutine copy_cohort( currentCohort,copyc ) ! indices for binning n%size_class = o%size_class + n%size_class_lasttimestep = o%size_class_lasttimestep n%size_by_pft_class = o%size_by_pft_class !Pointers diff --git a/biogeochem/EDLoggingMortalityMod.F90 b/biogeochem/EDLoggingMortalityMod.F90 index 6ef6f1d1f1..4976d3ab55 100644 --- a/biogeochem/EDLoggingMortalityMod.F90 +++ b/biogeochem/EDLoggingMortalityMod.F90 @@ -45,7 +45,12 @@ module EDLoggingMortalityMod use FatesGlobals , only : fates_log use shr_log_mod , only : errMsg => shr_log_errMsg use FatesPlantHydraulicsMod, only : AccumulateMortalityWaterStorage - + + use PRTGenericMod , only : all_carbon_elements + use PRTGenericMod , only : sapw_organ, struct_organ, leaf_organ + use PRTGenericMod , only : fnrt_organ, store_organ, repro_organ + + implicit none private @@ -260,6 +265,11 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site real(r8) :: leaf_litter ! Leafy biomass transferred through mortality [kgC/site] real(r8) :: root_litter ! Rooty + storage biomass transferred through mort [kgC/site] real(r8) :: agb_frac ! local copy of the above ground biomass fraction [fraction] + 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] integer :: p ! pft index integer :: c ! cwd index @@ -274,8 +284,13 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site currentCohort => currentPatch%shortest do while(associated(currentCohort)) p = currentCohort%pft + + sapw_c = currentCohort%prt%GetState(sapw_organ, all_carbon_elements) + struct_c = currentCohort%prt%GetState(struct_organ, all_carbon_elements) + leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ, all_carbon_elements) + store_c = currentCohort%prt%GetState(store_organ, all_carbon_elements) - if(currentCohort%canopy_layer == 1)then direct_dead = currentCohort%n * currentCohort%lmort_direct indirect_dead = currentCohort%n * & @@ -315,7 +330,7 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site do c = 1,ncwd-1 woody_litter = (direct_dead+indirect_dead) * & - (currentCohort%bdead+currentCohort%bsw) + (struct_c + sapw_c ) cwd_litter_density = SF_val_CWD_frac(c) * woody_litter / litter_area newPatch%cwd_ag(c) = newPatch%cwd_ag(c) + agb_frac * cwd_litter_density * np_mult @@ -344,7 +359,7 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site ! collateral damange and infrastructure logging is applied to bole litter ! ---------------------------------------------------------------------------------------- - woody_litter = indirect_dead * (currentCohort%bdead+currentCohort%bsw) + woody_litter = indirect_dead * (struct_c + sapw_c) cwd_litter_density = SF_val_CWD_frac(ncwd) * woody_litter / litter_area @@ -368,7 +383,7 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site ! Handle litter flux for the belowground portion of directly logged boles ! ---------------------------------------------------------------------------------------- - woody_litter = direct_dead * (currentCohort%bdead+currentCohort%bsw) + woody_litter = direct_dead * (struct_c + sapw_c) cwd_litter_density = SF_val_CWD_frac(ncwd) * woody_litter / litter_area newPatch%cwd_bg(ncwd) = newPatch%cwd_bg(ncwd) + & @@ -393,7 +408,7 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site ! ---------------------------------------------------------------------------------------- trunk_product_site = trunk_product_site + & - SF_val_CWD_frac(ncwd) * agb_frac * direct_dead * (currentCohort%bdead+currentCohort%bsw) + SF_val_CWD_frac(ncwd) * agb_frac * direct_dead * (struct_c + sapw_c) ! ---------------------------------------------------------------------------------------- @@ -401,8 +416,8 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site ! (none of these are exported) ! ---------------------------------------------------------------------------------------- - leaf_litter = (direct_dead+indirect_dead)*currentCohort%bl - root_litter = (direct_dead+indirect_dead)*(currentCohort%br+currentCohort%bstore) + leaf_litter = (direct_dead+indirect_dead) * leaf_c + root_litter = (direct_dead+indirect_dead) * (fnrt_c + store_c) newPatch%leaf_litter(p) = newPatch%leaf_litter(p) + leaf_litter / litter_area * np_mult newPatch%root_litter(p) = newPatch%root_litter(p) + root_litter / litter_area * np_mult @@ -431,7 +446,7 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site delta_biomass_stock = delta_biomass_stock + & leaf_litter + & root_litter + & - (direct_dead+indirect_dead) * (currentCohort%bdead+currentCohort%bsw) + (direct_dead+indirect_dead) * (struct_c + sapw_c) delta_individual = delta_individual + & direct_dead + & diff --git a/biogeochem/EDMortalityFunctionsMod.F90 b/biogeochem/EDMortalityFunctionsMod.F90 index fc797d1080..b052d34773 100644 --- a/biogeochem/EDMortalityFunctionsMod.F90 +++ b/biogeochem/EDMortalityFunctionsMod.F90 @@ -20,6 +20,8 @@ module EDMortalityFunctionsMod use EDParamsMod , only : fates_mortality_disturbance_fraction use FatesInterfaceMod , only : bc_in_type + use PRTGenericMod, only : all_carbon_elements + use PRTGenericMod, only : store_organ implicit none private @@ -57,7 +59,8 @@ subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort ) real(r8),intent(out) :: frmort ! freezing stress mortality real(r8) :: frac ! relativised stored carbohydrate - real(r8) :: b_leaf ! target leaf biomass kgC + real(r8) :: leaf_c_target ! target leaf biomass kgC + real(r8) :: store_c real(r8) :: hf_sm_threshold ! hydraulic failure soil moisture threshold real(r8) :: temp_dep_fraction ! Temp. function (freezing mortality) real(r8) :: temp_in_C ! Daily averaged temperature in Celcius @@ -83,8 +86,11 @@ subroutine mortality_rates( cohort_in,bc_in,cmort,hmort,bmort,frmort ) ! Carbon Starvation induced mortality. if ( cohort_in%dbh > 0._r8 ) then - call bleaf(cohort_in%dbh,cohort_in%pft,cohort_in%canopy_trim,b_leaf) - call storage_fraction_of_target(b_leaf, cohort_in%bstore, frac) + + call bleaf(cohort_in%dbh,cohort_in%pft,cohort_in%canopy_trim,leaf_c_target) + store_c = cohort_in%prt%GetState(store_organ,all_carbon_elements) + + call storage_fraction_of_target(leaf_c_target, store_c, frac) if( frac .lt. 1._r8) then cmort = max(0.0_r8,EDPftvarcon_inst%mort_scalar_cstarvation(cohort_in%pft) * & (1.0_r8 - frac)) diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index ecaf2e1753..67206f73e1 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -38,6 +38,17 @@ module EDPatchDynamicsMod use FatesConstantsMod , only : years_per_day use FatesConstantsMod , only : nearzero + use EDCohortDynamicsMod , only : InitPRTCohort + + use PRTGenericMod, only : all_carbon_elements + 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 PRTLossFluxesMod, only : PRTBurnLosses + ! CIME globals use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) @@ -312,6 +323,12 @@ subroutine spawn_patches( currentSite, bc_in) real(r8) :: leaf_litter_local(maxpft) ! initial value of leaf litter. KgC/m2 real(r8) :: cwd_ag_local(ncwd) ! initial value of above ground coarse woody debris. KgC/m2 real(r8) :: cwd_bg_local(ncwd) ! initial value of below ground coarse woody debris. KgC/m2 + real(r8) :: 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) :: total_c ! total carbon of plant [kg] !--------------------------------------------------------------------- storesmallcohort => null() ! storage of the smallest cohort for insertion routine @@ -385,6 +402,7 @@ subroutine spawn_patches( currentSite, bc_in) allocate(nc) if(hlm_use_planthydro.eq.itrue) call InitHydrCohort(CurrentSite,nc) + call InitPRTCohort(nc) call zero_cohort(nc) ! nc is the new cohort that goes in the disturbed patch (new_patch)... currentCohort @@ -396,6 +414,15 @@ subroutine spawn_patches( currentSite, bc_in) nc%canopy_layer = 1 nc%canopy_layer_yesterday = 1._r8 + sapw_c = currentCohort%prt%GetState(sapw_organ, all_carbon_elements) + struct_c = currentCohort%prt%GetState(struct_organ, all_carbon_elements) + leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ, all_carbon_elements) + store_c = currentCohort%prt%GetState(store_organ, all_carbon_elements) + + total_c = sapw_c + struct_c + leaf_c + fnrt_c + store_c + + ! treefall mortality is the dominant disturbance if(currentPatch%disturbance_rates(dtype_ifall) > currentPatch%disturbance_rates(dtype_ifire) .and. & currentPatch%disturbance_rates(dtype_ifall) > currentPatch%disturbance_rates(dtype_ilog))then @@ -439,9 +466,12 @@ subroutine spawn_patches( currentSite, bc_in) currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) = & currentSite%imort_rate(currentCohort%size_class, currentCohort%pft) + & nc%n * ED_val_understorey_death / hlm_freq_day + + + currentSite%imort_carbonflux = currentSite%imort_carbonflux + & (nc%n * ED_val_understorey_death / hlm_freq_day ) * & - currentCohort%b_total() * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + total_c * g_per_kg * days_per_sec * years_per_day * ha_per_m2 ! Step 2: Apply survivor ship function based on the understory death fraction ! remaining of understory plants of those that are knocked over by the overstorey trees dying... @@ -565,7 +595,7 @@ subroutine spawn_patches( currentSite, bc_in) nc%n * logging_coll_under_frac / hlm_freq_day currentSite%imort_carbonflux = currentSite%imort_carbonflux + & (nc%n * logging_coll_under_frac/ hlm_freq_day ) * & - currentCohort%b_total() * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + total_c * g_per_kg * days_per_sec * years_per_day * ha_per_m2 ! Step 2: Apply survivor ship function based on the understory death fraction @@ -605,7 +635,7 @@ subroutine spawn_patches( currentSite, bc_in) nc%bmort = currentCohort%bmort nc%frmort = currentCohort%frmort nc%dmort = currentCohort%dmort - nc%lmort_direct = currentCohort%lmort_direct + nc%lmort_direct = currentCohort%lmort_direct nc%lmort_collateral = currentCohort%lmort_collateral nc%lmort_infra = currentCohort%lmort_infra @@ -639,8 +669,13 @@ subroutine spawn_patches( currentSite, bc_in) new_patch%tallest => storebigcohort new_patch%shortest => storesmallcohort else + + ! Get rid of the new temporary cohort if(hlm_use_planthydro.eq.itrue) call DeallocateHydrCohort(nc) - deallocate(nc) !get rid of the new memory. + call nc%prt%DeallocatePRTVartypes() + deallocate(nc%prt) + deallocate(nc) + endif currentCohort => currentCohort%taller @@ -844,7 +879,13 @@ subroutine fire_litter_fluxes(currentSite, cp_target, new_patch_target, patch_si real(r8) :: bstem ! amount of above ground stem biomass per cohort kgC.(goes into CWG_AG) real(r8) :: dead_tree_density ! no trees killed by fire per m2 reaL(r8) :: burned_litter ! amount of each litter pool burned by fire. kgC/m2/day - real(r8) :: burned_leaves ! amount of tissue consumed by fire for grass. KgC/individual/day + real(r8) :: burned_leaves ! amount of tissue consumed by fire for leaves. KgC/individual/day + real(r8) :: leaf_burn_frac ! fraction of leaves burned + 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] integer :: c, p !--------------------------------------------------------------------- @@ -884,15 +925,23 @@ subroutine fire_litter_fluxes(currentSite, cp_target, new_patch_target, patch_si currentCohort => currentPatch%shortest do while(associated(currentCohort)) p = currentCohort%pft + if(EDPftvarcon_inst%woody(p) == 1)then !DEAD (FROM FIRE) TREES !************************************/ ! Number of trees that died because of the fire, per m2 of ground. ! Divide their litter into the four litter streams, and spread evenly across ground surface. !************************************/ + + sapw_c = currentCohort%prt%GetState(sapw_organ, all_carbon_elements) + struct_c = currentCohort%prt%GetState(struct_organ, all_carbon_elements) + leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ, all_carbon_elements) + store_c = currentCohort%prt%GetState(store_organ, all_carbon_elements) + ! stem biomass per tree - bstem = (currentCohort%bsw + currentCohort%bdead) * EDPftvarcon_inst%allom_agb_frac(p) + bstem = (sapw_c + struct_c) * EDPftvarcon_inst%allom_agb_frac(p) ! coarse root biomass per tree - bcroot = (currentCohort%bsw + currentCohort%bdead) * (1.0_r8 - EDPftvarcon_inst%allom_agb_frac(p) ) + bcroot = (sapw_c + struct_c) * (1.0_r8 - EDPftvarcon_inst%allom_agb_frac(p) ) ! density of dead trees per m2. dead_tree_density = (currentCohort%fire_mort * currentCohort%n*patch_site_areadis/currentPatch%area) / AREA @@ -903,21 +952,24 @@ subroutine fire_litter_fluxes(currentSite, cp_target, new_patch_target, patch_si ! Unburned parts of dead tree pool. ! Unburned leaves and roots - new_patch%leaf_litter(p) = new_patch%leaf_litter(p) + dead_tree_density * (currentCohort%bl) & - * (1.0_r8-currentCohort%fraction_crown_burned) - new_patch%root_litter(p) = new_patch%root_litter(p) + dead_tree_density * (currentCohort%br+currentCohort%bstore) + new_patch%leaf_litter(p) = new_patch%leaf_litter(p) + dead_tree_density * leaf_c * (1.0_r8-currentCohort%fraction_crown_burned) + + new_patch%root_litter(p) = new_patch%root_litter(p) + dead_tree_density * (fnrt_c+store_c) + currentPatch%leaf_litter(p) = currentPatch%leaf_litter(p) + dead_tree_density * & - (currentCohort%bl) * (1.0_r8-currentCohort%fraction_crown_burned) + leaf_c * (1.0_r8-currentCohort%fraction_crown_burned) + currentPatch%root_litter(p) = currentPatch%root_litter(p) + dead_tree_density * & - (currentCohort%br+currentCohort%bstore) + (fnrt_c + store_c) ! track as diagnostic fluxes currentSite%leaf_litter_diagnostic_input_carbonflux(p) = currentSite%leaf_litter_diagnostic_input_carbonflux(p) + & - (currentCohort%bl) * (1.0_r8-currentCohort%fraction_crown_burned) * currentCohort%fire_mort * & - currentCohort%n * hlm_days_per_year / AREA + leaf_c * (1.0_r8-currentCohort%fraction_crown_burned) * currentCohort%fire_mort * currentCohort%n * & + hlm_days_per_year / AREA + currentSite%root_litter_diagnostic_input_carbonflux(p) = currentSite%root_litter_diagnostic_input_carbonflux(p) + & - (currentCohort%br+currentCohort%bstore) * (1.0_r8-currentCohort%fraction_crown_burned) & - * currentCohort%fire_mort * currentCohort%n * hlm_days_per_year / AREA + (fnrt_c + store_c) * (1.0_r8-currentCohort%fraction_crown_burned) * currentCohort%fire_mort * & + currentCohort%n * hlm_days_per_year / AREA ! below ground coarse woody debris from burned trees do c = 1,ncwd @@ -971,11 +1023,13 @@ subroutine fire_litter_fluxes(currentSite, cp_target, new_patch_target, patch_si do p = 1,numpft currentSite%leaf_litter_burned(p) = currentSite%leaf_litter_burned(p) + & - dead_tree_density * currentCohort%bl * currentCohort%fraction_crown_burned + dead_tree_density * leaf_c * currentCohort%fraction_crown_burned + currentSite%flux_out = currentSite%flux_out + & - dead_tree_density * AREA * currentCohort%bl * currentCohort%fraction_crown_burned + dead_tree_density * AREA * leaf_c * currentCohort%fraction_crown_burned + currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm + & - dead_tree_density * AREA * currentCohort%bl * currentCohort%fraction_crown_burned + dead_tree_density * AREA * leaf_c * currentCohort%fraction_crown_burned enddo @@ -994,19 +1048,31 @@ subroutine fire_litter_fluxes(currentSite, cp_target, new_patch_target, patch_si currentCohort => new_patch%shortest do while(associated(currentCohort)) + sapw_c = currentCohort%prt%GetState(sapw_organ, all_carbon_elements) + leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) + call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread,currentCohort%pft,currentCohort%c_area) + if(EDPftvarcon_inst%woody(currentCohort%pft) == 1)then - burned_leaves = currentCohort%bl * currentCohort%fraction_crown_burned + burned_leaves = leaf_c * currentCohort%fraction_crown_burned else - burned_leaves = currentCohort%bl * currentPatch%burnt_frac_litter(6) + burned_leaves = leaf_c * currentPatch%burnt_frac_litter(6) endif - if (burned_leaves > 0.0_r8) then - currentCohort%bl = currentCohort%bl - burned_leaves + if (burned_leaves > 0.0_r8) then + ! Remove burned leaves from the pool + if(leaf_c>nearzero) then + leaf_burn_frac = burned_leaves/leaf_c + else + leaf_burn_frac = 0.0_r8 + end if + call PRTBurnLosses(currentCohort%prt, leaf_organ, leaf_burn_frac) + !KgC/gridcell/day currentSite%flux_out = currentSite%flux_out + burned_leaves * currentCohort%n * & patch_site_areadis/currentPatch%area * AREA + currentSite%total_burn_flux_to_atm = currentSite%total_burn_flux_to_atm+ burned_leaves * currentCohort%n * & patch_site_areadis/currentPatch%area * AREA @@ -1046,6 +1112,11 @@ subroutine mortality_litter_fluxes(currentSite, cp_target, new_patch_target, pat real(r8) :: understorey_dead !Number of individual dead from the canopy layer /day real(r8) :: canopy_dead !Number of individual dead from the understorey layer /day real(r8) :: np_mult !Fraction of the new patch which came from the current patch (and so needs the same litter) + 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] integer :: p,c real(r8) :: canopy_mortality_woody_litter(maxpft) ! flux of wood litter in to litter pool: KgC/m2/day real(r8) :: canopy_mortality_leaf_litter(maxpft) ! flux in to leaf litter from tree death: KgC/m2/day @@ -1061,6 +1132,12 @@ subroutine mortality_litter_fluxes(currentSite, cp_target, new_patch_target, pat currentCohort => currentPatch%shortest do while(associated(currentCohort)) p = currentCohort%pft + + sapw_c = currentCohort%prt%GetState(sapw_organ, all_carbon_elements) + struct_c = currentCohort%prt%GetState(struct_organ, all_carbon_elements) + leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) + fnrt_c = currentCohort%prt%GetState(fnrt_organ, all_carbon_elements) + store_c = currentCohort%prt%GetState(store_organ, all_carbon_elements) if(currentCohort%canopy_layer == 1)then !currentCohort%dmort = mortality_rates(currentCohort) @@ -1068,12 +1145,14 @@ subroutine mortality_litter_fluxes(currentSite, cp_target, new_patch_target, pat !not right to recalcualte dmort here. canopy_dead = currentCohort%n * min(1.0_r8,currentCohort%dmort * hlm_freq_day * fates_mortality_disturbance_fraction) + + canopy_mortality_woody_litter(p)= canopy_mortality_woody_litter(p) + & - canopy_dead*(currentCohort%bdead+currentCohort%bsw) + canopy_dead*(struct_c + sapw_c) canopy_mortality_leaf_litter(p) = canopy_mortality_leaf_litter(p) + & - canopy_dead*(currentCohort%bl) + canopy_dead*leaf_c canopy_mortality_root_litter(p) = canopy_mortality_root_litter(p) + & - canopy_dead*(currentCohort%br+currentCohort%bstore) + canopy_dead*(fnrt_c + store_c) if( hlm_use_planthydro == itrue ) then call AccumulateMortalityWaterStorage(currentSite,currentCohort, canopy_dead) @@ -1084,11 +1163,11 @@ subroutine mortality_litter_fluxes(currentSite, cp_target, new_patch_target, pat understorey_dead = ED_val_understorey_death * currentCohort%n * (patch_site_areadis/currentPatch%area) !kgC/site/day canopy_mortality_woody_litter(p) = canopy_mortality_woody_litter(p) + & - understorey_dead*(currentCohort%bdead+currentCohort%bsw) + understorey_dead*(struct_c + sapw_c) canopy_mortality_leaf_litter(p)= canopy_mortality_leaf_litter(p)+ & - understorey_dead* currentCohort%bl + understorey_dead*leaf_c canopy_mortality_root_litter(p)= canopy_mortality_root_litter(p)+ & - understorey_dead*(currentCohort%br+currentCohort%bstore) + understorey_dead*(fnrt_c + store_c) if( hlm_use_planthydro == itrue ) then call AccumulateMortalityWaterStorage(currentSite,currentCohort, understorey_dead) @@ -1831,6 +1910,8 @@ subroutine dealloc_patch(cpatch) ncohort => ccohort%taller if(hlm_use_planthydro.eq.itrue) call DeallocateHydrCohort(ccohort) + call ccohort%prt%DeallocatePRTVartypes() + deallocate(ccohort%prt) deallocate(ccohort) ccohort => ncohort @@ -1896,7 +1977,8 @@ subroutine patch_pft_size_profile(cp_pnt) currentPatch%pft_agb_profile(currentCohort%pft,j) = & currentPatch%pft_agb_profile(currentCohort%pft,j) + & - currentCohort%bdead*currentCohort%n/currentPatch%area + currentCohort%prt%GetState(struct_organ, all_carbon_elements) * & + currentCohort%n/currentPatch%area endif enddo ! dbh bins diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 6669998c7c..5207dbcd44 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -14,6 +14,7 @@ module EDPhysiologyMod use FatesInterfaceMod, only : numpft use FatesInterfaceMod, only : hlm_use_planthydro use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : nearzero use EDPftvarcon , only : EDPftvarcon_inst use FatesInterfaceMod, only : bc_in_type use EDCohortDynamicsMod , only : zero_cohort @@ -54,9 +55,20 @@ module EDPhysiologyMod use FatesAllometryMod , only : CheckIntegratedAllometries use FatesAllometryMod , only : StructureResetOfDH - use FatesIntegratorsMod, only : RKF45 - use FatesIntegratorsMod, only : Euler - + use PRTGenericMod, only : leaf_organ + use PRTGenericMod, only : all_carbon_elements + use PRTGenericMod, only : carbon12_element + use PRTGenericMod, only : nitrogen_element + use PRTGenericMod, only : phosphorous_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 PRTGenericMod, only : SetState + use PRTLossFluxesMod, only : PRTPhenologyFlush + use PRTLossFluxesMod, only : PRTDeciduousTurnover implicit none private @@ -65,7 +77,6 @@ module EDPhysiologyMod public :: trim_canopy public :: phenology private :: phenology_leafonoff - public :: PlantGrowth public :: recruitment private :: cwd_input private :: cwd_out @@ -74,6 +85,7 @@ module EDPhysiologyMod private :: seed_decay private :: seed_germination public :: flux_into_litter_pools + public :: ZeroAllocationRates logical, parameter :: debug = .false. ! local debug flag @@ -93,6 +105,31 @@ module EDPhysiologyMod contains + subroutine ZeroAllocationRates( currentSite ) + + ! !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)) + + ! This sets turnover and growth rates to zero + call currentCohort%prt%ZeroRates() + + currentCohort => currentCohort%shorter + enddo + currentPatch => currentPatch%older + end do + + return + end subroutine ZeroAllocationRates + + ! ============================================================================ subroutine non_canopy_derivs( currentSite, currentPatch, bc_in ) @@ -171,24 +208,28 @@ subroutine trim_canopy( currentSite ) type (ed_cohort_type) , pointer :: currentCohort type (ed_patch_type) , pointer :: currentPatch - integer :: z ! leaf layer - integer :: ipft ! pft index - 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 - real(r8) :: sla_levleaf ! sla at leaf level z - real(r8) :: nscaler_levleaf ! nscaler value at leaf level z - integer :: cl ! canopy layer index - real(r8) :: kn ! nitrogen decay coefficient - real(r8) :: sla_max ! Observational constraint on how large sla (m2/gC) can become - - real(r8) :: leaf_inc ! LAI-only portion of the vegetation increment of dinc_ed - real(r8) :: lai_canopy_above ! the LAI in the canopy layers above the layer of interest - real(r8) :: lai_layers_above ! the LAI in the leaf layers, within the current canopy, - ! above the leaf layer of interest - 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 + integer :: z ! leaf layer + integer :: ipft ! pft index + 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 + real(r8) :: sla_levleaf ! sla at leaf level z + real(r8) :: nscaler_levleaf ! nscaler value at leaf level z + integer :: cl ! canopy layer index + real(r8) :: kn ! nitrogen decay coefficient + real(r8) :: sla_max ! Observational constraint on how large sla (m2/gC) can become + 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) :: leaf_inc ! LAI-only portion of the vegetation increment of dinc_ed + real(r8) :: lai_canopy_above ! the LAI in the canopy layers above the layer of interest + real(r8) :: lai_layers_above ! the LAI in the leaf layers, within the current canopy, + ! above the leaf layer of interest + 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 !---------------------------------------------------------------------- @@ -201,7 +242,10 @@ subroutine trim_canopy( currentSite ) trimmed = .false. ipft = currentCohort%pft call carea_allom(currentCohort%dbh,currentCohort%n,currentSite%spread,currentCohort%pft,currentCohort%c_area) - currentCohort%treelai = tree_lai(currentCohort%bl, currentCohort%pft, currentCohort%c_area, & + + 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 ) @@ -214,7 +258,7 @@ subroutine trim_canopy( currentSite ) if (currentCohort%nv > nlevleaf)then write(fates_log(),*) 'nv > nlevleaf',currentCohort%nv, & currentCohort%treelai,currentCohort%treesai, & - currentCohort%c_area,currentCohort%n,currentCohort%bl + currentCohort%c_area,currentCohort%n,leaf_c call endrun(msg=errMsg(sourcefile, __LINE__)) endif @@ -366,6 +410,12 @@ subroutine phenology( currentSite, bc_in ) integer :: day ! day of month (1, ..., 31) integer :: sec ! seconds of the day + 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) :: gdd_threshold integer :: ncdstart ! beginning of counting period for chilling degree days. integer :: gddstart ! beginning of counting period for growing degree days. @@ -539,7 +589,7 @@ subroutine phenology( currentSite, bc_in ) if ((t >= currentSite%dleafondate - 30.and.t <= currentSite%dleafondate + 30).or.(t > 360 - 15.and. & currentSite%dleafondate < 15))then ! are we in the window? ! TODO: CHANGE THIS MATH, MOVE THE DENOMENATOR OUTSIDE OF THE SUM (rgk 01-2017) - if (sum(currentSite%water_memory(1:numWaterMem)/dble(numWaterMem)) & + if (sum(currentSite%water_memory(1:numWaterMem)/real(numWaterMem,r8)) & >= ED_val_phen_drought_threshold.and.currentSite%dstatus == 1.and.t >= 10)then ! leave some minimum time between leaf off and leaf on to prevent 'flickering'. if (timesincedleafoff > ED_val_phen_doff_time)then @@ -595,41 +645,46 @@ subroutine phenology_leafonoff(currentSite) type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort - real(r8) :: store_output ! the amount of the store to put into leaves - - ! is a barrier against negative storage and C starvation. + real(r8) :: leaf_c ! leaf carbon [kg] + real(r8) :: store_c ! storage carbon [kg] + real(r8) :: store_c_transfer_frac ! Fraction of storage carbon used to flush leaves + integer :: ipft + real(r8), parameter :: leaf_drop_fraction = 1.0_r8 !------------------------------------------------------------------------ currentPatch => CurrentSite%oldest_patch - store_output = 0.5_r8 - do while(associated(currentPatch)) currentCohort => currentPatch%tallest do while(associated(currentCohort)) - currentCohort%leaf_litter = 0.0_r8 !zero leaf litter for today. - + ipft = currentCohort%pft + + ! Retrieve existing leaf and storage carbon + + call currentCohort%prt%CheckMassConservation(ipft,0) + + store_c = currentCohort%prt%GetState(store_organ, all_carbon_elements) + leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) + !COLD LEAF ON - if (EDPftvarcon_inst%season_decid(currentCohort%pft) == 1)then + if (EDPftvarcon_inst%season_decid(ipft) == 1)then if (currentSite%status == 2)then !we have just moved to leaves being on . if (currentCohort%status_coh == 1)then !Are the leaves currently off? - currentCohort%status_coh = 2 !Leaves are on, so change status to stop flow of carbon out of bstore. - if (currentCohort%laimemory <= currentCohort%bstore)then - currentCohort%bl = currentCohort%laimemory !extract stored carbon to make new leaves. + currentCohort%status_coh = 2 ! Leaves are on, so change status to + ! stop flow of carbon out of bstore. + + if(store_c>nearzero) then + store_c_transfer_frac = & + min(EDPftvarcon_inst%phenflush_fraction(ipft)*currentCohort%laimemory, store_c)/store_c else - ! we can only put on as much carbon as there is in the store... - ! nb. Putting all of bstore into leaves is C-starvation suicidal. - ! The tendency for this could be parameterized - currentCohort%bl = currentCohort%bstore * store_output - endif - - - if ( debug ) write(fates_log(),*) 'EDPhysMod 1 ',currentCohort%bstore + store_c_transfer_frac = 0.0_r8 + end if - currentCohort%bstore = currentCohort%bstore - currentCohort%bl ! Drain store - - if ( debug ) write(fates_log(),*) 'EDPhysMod 2 ',currentCohort%bstore + ! This call will request that storage carbon will be transferred to + ! leaf tissues. It is specified as a fraction of the available storage + call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, store_c_transfer_frac) currentCohort%laimemory = 0.0_r8 @@ -637,39 +692,52 @@ subroutine phenology_leafonoff(currentSite) endif ! growing season !COLD LEAF OFF -! currentCohort%leaf_litter = 0.0_r8 !zero leaf litter for today. if (currentSite%status == 1)then !past leaf drop day? Leaves still on tree? if (currentCohort%status_coh == 2)then ! leaves have not dropped - currentCohort%status_coh = 1 - !remember what the lai was this year to put the same amount back on in the spring... - currentCohort%laimemory = currentCohort%bl + + ! This sets the cohort to the "leaves off" flag + currentCohort%status_coh = 1 + + ! Remember what the lai was (leaf mass actually) was for next year + ! the same amount back on in the spring... + + currentCohort%laimemory = leaf_c + + ! 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) - ! add lost carbon to litter - currentCohort%leaf_litter = currentCohort%bl - currentCohort%bl = 0.0_r8 + call PRTDeciduousTurnover(currentCohort%prt,ipft, & + leaf_organ, leaf_drop_fraction) endif !leaf status endif !currentSite status endif !season_decid !DROUGHT LEAF ON - if (EDPftvarcon_inst%stress_decid(currentCohort%pft) == 1)then - if (currentSite%dstatus == 2)then !we have just moved to leaves being on . - if (currentCohort%status_coh == 1)then !is it the leaf-on day? Are the leaves currently off? - currentCohort%status_coh = 2 !Leaves are on, so change status to stop flow of carbon out of bstore. - if (currentCohort%laimemory <= currentCohort%bstore)then - currentCohort%bl = currentCohort%laimemory !extract stored carbon to make new leaves. - else + if (EDPftvarcon_inst%stress_decid(ipft) == 1)then + + if (currentSite%dstatus == 2)then - !we can only put on as much carbon as there is in the store. - currentCohort%bl = currentCohort%bstore * store_output - endif + ! we have just moved to leaves being on . + if (currentCohort%status_coh == 1)then - if ( debug ) write(fates_log(),*) 'EDPhysMod 3 ',currentCohort%bstore + !is it the leaf-on day? Are the leaves currently off? - currentCohort%bstore = currentCohort%bstore - currentCohort%bl ! empty store + currentCohort%status_coh = 2 ! Leaves are on, so change status to + ! stop flow of carbon out of bstore. - if ( debug ) write(fates_log(),*) 'EDPhysMod 4 ',currentCohort%bstore + if(store_c>nearzero) then + store_c_transfer_frac = & + min(EDPftvarcon_inst%phenflush_fraction(ipft)*currentCohort%laimemory, store_c)/store_c + else + store_c_transfer_frac = 0.0_r8 + end if + + ! This call will request that storage carbon will be transferred to + ! leaf tissues. It is specified as a fraction of the available storage + call PRTPhenologyFlush(currentCohort%prt, ipft, & + leaf_organ, store_c_transfer_frac) currentCohort%laimemory = 0.0_r8 @@ -679,17 +747,22 @@ subroutine phenology_leafonoff(currentSite) !DROUGHT LEAF OFF if (currentSite%dstatus == 1)then if (currentCohort%status_coh == 2)then ! leaves have not dropped + + ! This sets the cohort to the "leaves off" flag currentCohort%status_coh = 1 - currentCohort%laimemory = currentCohort%bl - ! add retranslocated carbon (very small) to store. - currentCohort%bstore = currentCohort%bstore - ! add falling leaves to litter pools . convert to KgC/m2 - currentCohort%leaf_litter = currentCohort%bl - currentCohort%bl = 0.0_r8 + + ! 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) endif endif !status endif !drought dec. + + call currentCohort%prt%CheckMassConservation(ipft,1) + currentCohort => currentCohort%shorter enddo !currentCohort @@ -846,821 +919,7 @@ subroutine seed_germination( currentSite, currentPatch ) end subroutine seed_germination ! ============================================================================ - subroutine PlantGrowth( currentSite, currentCohort, bc_in ) - ! - ! !DESCRIPTION: - ! Main subroutine for plant allocation and growth - ! - ! !USES: - ! Original: Rosie Fisher - ! Updated: Ryan Knox - - use FatesInterfaceMod, only : hlm_use_ed_prescribed_phys - - ! - ! !ARGUMENTS - type(ed_site_type), intent(inout), target :: currentSite - type(ed_cohort_type),intent(inout), target :: currentCohort - type(bc_in_type), intent(in) :: bc_in - ! - ! !LOCAL VARIABLES: - - integer :: ipft ! PFT index - - - real(r8) :: carbon_balance ! daily carbon balance for this cohort - - ! Per plant allocation targets - real(r8) :: bt_leaf ! leaf biomass (kgC) - real(r8) :: dbt_leaf_dd ! change in leaf biomass wrt diameter (kgC/cm) - real(r8) :: bt_fineroot ! fine root biomass (kgC) - real(r8) :: dbt_fineroot_dd ! change in fine root biomass wrt diameter (kgC/cm) - real(r8) :: at_sap ! sapwood cross-section area at referenc (m2) - real(r8) :: bt_sap ! sapwood biomass (kgC) - real(r8) :: dbt_sap_dd ! change in sapwood biomass wrt diameter (kgC/cm) - real(r8) :: bt_agw ! above ground biomass (kgC/cm) - real(r8) :: dbt_agw_dd ! change in above ground biomass wrt diameter (kgC/cm) - real(r8) :: bt_bgw ! coarse root biomass (kgC) - real(r8) :: dbt_bgw_dd ! change in coarse root biomass (kgC/cm) - real(r8) :: bt_dead ! dead (structural) biomass (kgC) - real(r8) :: dbt_dead_dd ! change in dead biomass wrt diameter (kgC/cm) - real(r8) :: bt_store ! target storage biomass (kgC) - real(r8) :: dbt_store_dd ! target rate of change in storage (kgC/cm) - real(r8) :: dbt_total_dd ! total target biomass rate of change (kgC/cm) - - real(r8) :: leaf_below_target ! leaf biomass below target amount [kgC] - real(r8) :: froot_below_target ! fineroot biomass below target amount [kgC] - real(r8) :: sap_below_target ! sapwood biomass below target amount [kgC] - real(r8) :: store_below_target ! storage biomass below target amount [kgC] - real(r8) :: dead_below_target ! dead (structural) biomass below target amount [kgC] - real(r8) :: total_below_target ! total biomass below the allometric target [kgC] - - real(r8) :: bstore_flux ! carbon fluxing into storage [kgC] - real(r8) :: bl_flux ! carbon fluxing into leaves [kgC] - real(r8) :: br_flux ! carbon fluxing into fineroots [kgC] - real(r8) :: bsw_flux ! carbon fluxing into sapwood [kgC] - real(r8) :: bdead_flux ! carbon fluxing into structure [kgC] - real(r8) :: brepro_flux ! carbon fluxing into reproductive tissues [kgC] - real(r8) :: flux_adj ! adjustment made to growth flux term to minimize error [kgC] - - real(r8) :: store_target_fraction ! ratio between storage and leaf biomass when on allometry [kgC] - real(r8) :: repro_fraction ! fraction of carbon gain sent to reproduction when on-allometry - - real(r8) :: leaf_turnover_demand ! leaf carbon that is demanded to replace maintenance turnover [kgC] - real(r8) :: root_turnover_demand ! fineroot carbon that is demanded to replace - ! maintenance turnover [kgC] - real(r8) :: total_turnover_demand ! total carbon that is demanded to replace maintenance turnover [kgC] - - real(r8),dimension(n_cplantpools) :: c_pool ! Vector of carbon pools passed to integrator - real(r8),dimension(n_cplantpools) :: c_pool_out ! Vector of carbon pools passed back from integrator - logical,dimension(n_cplantpools) :: c_mask ! Mask of active pools during integration - - logical :: step_pass ! Did the integration step pass? - - logical :: grow_leaf ! Are leaves at allometric target and should be grown? - logical :: grow_froot ! Are fine-roots at allometric target and should be grown? - logical :: grow_sap ! Is sapwood at allometric target and should be grown? - logical :: grow_store ! Is storage at allometric target and should be grown? - - ! integrator variables - real(r8) :: deltaC ! trial value for substep - integer :: ierr ! error flag for allometric growth step - integer :: nsteps ! number of sub-steps - integer :: istep ! current substep index - real(r8) :: totalC ! total carbon allocated over alometric growth step - real(r8) :: dbh_sub ! substep dbh - real(r8) :: h_sub ! substep h - real(r8) :: bl_sub ! substep leaf biomass - real(r8) :: br_sub ! substep root biomass - real(r8) :: bsw_sub ! substep sapwood biomass - real(r8) :: bstore_sub ! substep storage biomass - real(r8) :: bdead_sub ! substep structural biomass - real(r8) :: brepro_sub ! substep reproductive biomass - - - ! Woody turnover timescale [years] - real(r8), parameter :: cbal_prec = 1.0e-15_r8 ! Desired precision in carbon balance - ! non-integrator part - integer , parameter :: max_substeps = 300 ! Number of step attempts before - ! giving up - real(r8), parameter :: max_trunc_error = 1.0_r8 ! allowable numerical truncation error - integer, parameter :: ODESolve = 2 ! 1=RKF45, 2=Euler - - - ipft = currentCohort%pft - - ! Initialize seed production - currentCohort%seed_prod = 0.0_r8 - - ! Initialize NPP flux diagnostics - currentCohort%npp_stor = 0.0_r8 - currentCohort%npp_leaf = 0.0_r8 - currentCohort%npp_fnrt = 0.0_r8 - currentCohort%npp_dead = 0.0_r8 - currentCohort%npp_seed = 0.0_r8 - currentCohort%npp_sapw = 0.0_r8 - - ! Initialize rates of change - currentCohort%dhdt = 0.0_r8 - currentCohort%dbdeaddt = 0.0_r8 - currentCohort%dbstoredt = 0.0_r8 - currentCohort%ddbhdt = 0.0_r8 - - ! If the cohort has grown, it is not new - currentCohort%isnew=.false. - - ! ----------------------------------------------------------------------------------- - ! I. Identify the net carbon gain for this dynamics interval - ! Set the available carbon pool, identify allocation portions, and decrement - ! the available carbon pool to zero. - ! ----------------------------------------------------------------------------------- - - ! convert from kgC/indiv/day into kgC/indiv/year - ! _acc_hold is remembered until the next dynamics step (used for I/O) - ! _acc will be reset soon and will be accumulated on the next leaf photosynthesis - ! step - - if (hlm_use_ed_prescribed_phys .eq. itrue) then - if (currentCohort%canopy_layer .eq. 1) then - currentCohort%npp_acc_hold = EDPftvarcon_inst%prescribed_npp_canopy(ipft) & - * currentCohort%c_area / currentCohort%n - ! add these for balance checking purposes - currentCohort%npp_acc = currentCohort%npp_acc_hold / hlm_days_per_year - else - currentCohort%npp_acc_hold = EDPftvarcon_inst%prescribed_npp_understory(ipft) & - * currentCohort%c_area / currentCohort%n - ! add these for balance checking purposes - currentCohort%npp_acc = currentCohort%npp_acc_hold / hlm_days_per_year - endif - else - currentCohort%npp_acc_hold = currentCohort%npp_acc * dble(hlm_days_per_year) - currentCohort%gpp_acc_hold = currentCohort%gpp_acc * dble(hlm_days_per_year) - currentCohort%resp_acc_hold = currentCohort%resp_acc * dble(hlm_days_per_year) - endif - - currentSite%flux_in = currentSite%flux_in + currentCohort%npp_acc * currentCohort%n - - - ! Available carbon for growth [kgC] - carbon_balance = currentCohort%npp_acc - - ! ----------------------------------------------------------------------------------- - ! II. Calculate target size of living biomass compartment for a given dbh. - ! ----------------------------------------------------------------------------------- - - ! Target sapwood biomass and deriv. according to allometry and trimming [kgC, kgC/cm] - call bsap_allom(currentCohort%dbh,ipft,currentCohort%canopy_trim,at_sap,bt_sap,dbt_sap_dd) - - ! Target total above ground deriv. biomass in woody/fibrous tissues [kgC, kgC/cm] - call bagw_allom(currentCohort%dbh,ipft,bt_agw,dbt_agw_dd) - - ! Target total below ground deriv. biomass in woody/fibrous tissues [kgC, kgC/cm] - call bbgw_allom(currentCohort%dbh,ipft,bt_bgw,dbt_bgw_dd) - - ! Target total dead (structrual) biomass and deriv. [kgC, kgC/cm] - call bdead_allom( bt_agw, bt_bgw, bt_sap, ipft, bt_dead, & - dbt_agw_dd, dbt_bgw_dd, dbt_sap_dd, dbt_dead_dd ) - - ! ------------------------------------------------------------------------------------ - ! If structure is larger than target, then we need to correct some integration errors - ! by slightly increasing dbh to match it. - ! ----------------------------------------------------------------------------------- - if( ((currentCohort%bdead-bt_dead) > calloc_abs_error) .and. & - (EDPftvarcon_inst%woody(ipft) == itrue) ) then - call StructureResetOfDH( currentCohort%bdead, ipft, & - currentCohort%canopy_trim, currentCohort%dbh, currentCohort%hite ) - - ! Re-calculate the sapwood and structural wood targets based on the new dbh - ! ------------------------------------------------------------------------------------------ - - ! Target sapwood biomass and deriv. according to allometry and trimming [kgC, kgC/cm] - call bsap_allom(currentCohort%dbh,ipft,currentCohort%canopy_trim,at_sap,bt_sap,dbt_sap_dd) - - ! Target total above ground deriv. biomass in woody/fibrous tissues [kgC, kgC/cm] - call bagw_allom(currentCohort%dbh,ipft,bt_agw,dbt_agw_dd) - - ! Target total below ground deriv. biomass in woody/fibrous tissues [kgC, kgC/cm] - call bbgw_allom(currentCohort%dbh,ipft,bt_bgw,dbt_bgw_dd) - - ! Target total dead (structrual) biomass and deriv. [kgC, kgC/cm] - call bdead_allom( bt_agw, bt_bgw, bt_sap, ipft, bt_dead, & - dbt_agw_dd, dbt_bgw_dd, dbt_sap_dd, dbt_dead_dd ) - - end if - - ! Target leaf biomass according to allometry and trimming - call bleaf(currentCohort%dbh,ipft,currentCohort%canopy_trim,bt_leaf,dbt_leaf_dd) - - ! Target fine-root biomass and deriv. according to allometry and trimming [kgC, kgC/cm] - call bfineroot(currentCohort%dbh,ipft,currentCohort%canopy_trim,bt_fineroot,dbt_fineroot_dd) - - ! Target storage carbon [kgC,kgC/cm] - call bstore_allom(currentCohort%dbh,ipft,currentCohort%canopy_trim,bt_store,dbt_store_dd) - - - ! ----------------------------------------------------------------------------------- - ! III(b). Calculate the maintenance turnover demands - ! NOTE(RGK): If branches are falling all year, even on deciduous trees, we should - ! be pulling some leaves with them when leaves are out... - ! - ! If the turnover time-scales are zero, that means there is no turnover. - ! - ! ----------------------------------------------------------------------------------- - currentCohort%leaf_md = 0.0_r8 - currentCohort%bsw_md = 0.0_r8 - currentCohort%bdead_md = 0.0_r8 - currentCohort%bstore_md = 0.0_r8 - currentCohort%root_md = 0.0_r8 - - if ( EDPftvarcon_inst%branch_turnover(ipft) > tiny(EDPftvarcon_inst%branch_turnover(ipft)) ) then - currentCohort%bsw_md = currentCohort%bsw / EDPftvarcon_inst%branch_turnover(ipft) - currentCohort%bdead_md = currentCohort%bdead / EDPftvarcon_inst%branch_turnover(ipft) - currentCohort%bstore_md = currentCohort%bstore / EDPftvarcon_inst%branch_turnover(ipft) - end if - - if (EDPftvarcon_inst%evergreen(ipft) == 1)then - currentCohort%leaf_md = currentCohort%bl / EDPftvarcon_inst%leaf_long(ipft) - currentCohort%root_md = currentCohort%br / EDPftvarcon_inst%root_long(ipft) - endif - - if (EDPftvarcon_inst%season_decid(ipft) == 1)then - currentCohort%root_md = currentCohort%br /EDPftvarcon_inst%root_long(ipft) - endif - - if (EDPftvarcon_inst%stress_decid(ipft) == 1)then - currentCohort%root_md = currentCohort%br /EDPftvarcon_inst%root_long(ipft) - endif - - ! ----------------------------------------------------------------------------------- - ! IV. Remove turnover from the appropriate pools - ! - ! Units: kgC/year * (year/days_per_year) = kgC/day -> (day elapsed) -> kgC - ! ----------------------------------------------------------------------------------- - - currentCohort%bl = currentCohort%bl - currentCohort%leaf_md*hlm_freq_day - currentcohort%br = currentcohort%br - currentCohort%root_md*hlm_freq_day - currentcohort%bsw = currentcohort%bsw - currentCohort%bsw_md*hlm_freq_day - currentCohort%bdead = currentCohort%bdead - currentCohort%bdead_md*hlm_freq_day - currentCohort%bstore = currentCohort%bstore - currentCohort%bstore_md*hlm_freq_day - - - ! ----------------------------------------------------------------------------------- - ! V. Prioritize some amount of carbon to replace leaf/root turnover - ! Make sure it isnt a negative payment, and either pay what is available - ! or forcefully pay from storage. - ! ----------------------------------------------------------------------------------- - - leaf_turnover_demand = currentCohort%leaf_md*EDPftvarcon_inst%leaf_stor_priority(ipft)*hlm_freq_day - root_turnover_demand = currentCohort%root_md*EDPftvarcon_inst%leaf_stor_priority(ipft)*hlm_freq_day - total_turnover_demand = leaf_turnover_demand + root_turnover_demand - - if(total_turnover_demand>0.0_r8)then - - ! If we are testing b4b, then we pay this even if we don't have the carbon - ! Just don't pay so much carbon that storage+carbon_balance can't pay for it - bl_flux = min(leaf_turnover_demand, & - max(0.0_r8,(currentCohort%bstore+carbon_balance)* & - (leaf_turnover_demand/total_turnover_demand))) - - carbon_balance = carbon_balance - bl_flux - currentCohort%bl = currentCohort%bl + bl_flux - currentCohort%npp_leaf = currentCohort%npp_leaf + bl_flux / hlm_freq_day - - ! If we are testing b4b, then we pay this even if we don't have the carbon - br_flux = min(root_turnover_demand, & - max(0.0_r8, (currentCohort%bstore+carbon_balance)* & - (root_turnover_demand/total_turnover_demand))) - - carbon_balance = carbon_balance - br_flux - currentCohort%br = currentCohort%br + br_flux - currentCohort%npp_fnrt = currentCohort%npp_fnrt + br_flux / hlm_freq_day - - end if - - - ! ----------------------------------------------------------------------------------- - ! VI. if carbon balance is negative, re-coup the losses from storage - ! if it is positive, give some love to storage carbon - ! NOTE: WE ARE STILL ALLOWING STORAGE CARBON TO GO NEGATIVE, AT LEAST IN THIS - ! PART OF THE CODE. - ! ----------------------------------------------------------------------------------- - - if( carbon_balance < 0.0_r8 ) then - - bstore_flux = carbon_balance - carbon_balance = carbon_balance - bstore_flux - currentCohort%bstore = currentCohort%bstore + bstore_flux - currentCohort%npp_stor = currentCohort%npp_stor + bstore_flux / hlm_freq_day - ! We have pushed to net-zero carbon, the rest of this routine can be ignored - return - - else - - store_below_target = max(bt_store - currentCohort%bstore,0.0_r8) - store_target_fraction = max(0.0_r8,currentCohort%bstore/bt_store) - - bstore_flux = min(store_below_target,carbon_balance * & - max(exp(-1.*store_target_fraction**4._r8) - exp( -1.0_r8 ),0.0_r8)) - carbon_balance = carbon_balance - bstore_flux - currentCohort%bstore = currentCohort%bstore + bstore_flux - currentCohort%npp_stor = currentCohort%npp_stor + bstore_flux / hlm_freq_day - - end if - - ! ----------------------------------------------------------------------------------- - ! VII. If carbon is still available, prioritize some allocation to replace - ! the rest of the leaf/fineroot turnover demand - ! carbon balance is guaranteed to be >=0 beyond this point - ! ----------------------------------------------------------------------------------- - - leaf_turnover_demand = currentCohort%leaf_md * & - (1.0_r8-EDPftvarcon_inst%leaf_stor_priority(ipft))*hlm_freq_day - root_turnover_demand = currentCohort%root_md * & - (1.0_r8-EDPftvarcon_inst%leaf_stor_priority(ipft))*hlm_freq_day - total_turnover_demand = leaf_turnover_demand + root_turnover_demand - - if(total_turnover_demand>0.0_r8)then - - bl_flux = min(leaf_turnover_demand, carbon_balance*(leaf_turnover_demand/total_turnover_demand)) - carbon_balance = carbon_balance - bl_flux - currentCohort%bl = currentCohort%bl + bl_flux - currentCohort%npp_leaf = currentCohort%npp_leaf + bl_flux / hlm_freq_day - - br_flux = min(root_turnover_demand, carbon_balance*(root_turnover_demand/total_turnover_demand)) - carbon_balance = carbon_balance - br_flux - currentCohort%br = currentCohort%br + br_flux - currentCohort%npp_fnrt = currentCohort%npp_fnrt + br_flux / hlm_freq_day - - end if - - - ! ----------------------------------------------------------------------------------- - ! VIII. If carbon is still available, we try to push all live - ! pools back towards allometry. But only upwards, if fusion happened - ! to generate some pools above allometric target, don't reduce the pool, - ! just ignore it until the rest of the plant grows to meet it. - ! ----------------------------------------------------------------------------------- - - if( carbon_balance0.0_r8) then - - if( total_below_target > carbon_balance) then - bl_flux = carbon_balance * leaf_below_target/total_below_target - br_flux = carbon_balance * froot_below_target/total_below_target - bsw_flux = carbon_balance * sap_below_target/total_below_target - bstore_flux = carbon_balance * store_below_target/total_below_target - else - bl_flux = leaf_below_target - br_flux = froot_below_target - bsw_flux = sap_below_target - bstore_flux = store_below_target - end if - - carbon_balance = carbon_balance - bl_flux - currentCohort%bl = currentCohort%bl + bl_flux - currentCohort%npp_leaf = currentCohort%npp_leaf + bl_flux / hlm_freq_day - - carbon_balance = carbon_balance - br_flux - currentCohort%br = currentCohort%br + br_flux - currentCohort%npp_fnrt = currentCohort%npp_fnrt + br_flux / hlm_freq_day - - carbon_balance = carbon_balance - bsw_flux - currentCohort%bsw = currentCohort%bsw + bsw_flux - currentCohort%npp_sapw = currentCohort%npp_sapw + bsw_flux / hlm_freq_day - - carbon_balance = carbon_balance - bstore_flux - currentCohort%bstore = currentCohort%bstore + bstore_flux - currentCohort%npp_stor = currentCohort%npp_stor + bstore_flux / hlm_freq_day - - end if - - ! ----------------------------------------------------------------------------------- - ! IX. If carbon is still available, replenish the structural pool to get - ! back on allometry - ! ----------------------------------------------------------------------------------- - - if( carbon_balance 0.0_r8 .and. dead_below_target>0.0_r8) then - - bdead_flux = min(carbon_balance,dead_below_target) - carbon_balance = carbon_balance - bdead_flux - currentCohort%bdead = currentCohort%bdead + bdead_flux - currentCohort%npp_dead = currentCohort%npp_dead + bdead_flux / hlm_freq_day - - end if - - ! ----------------------------------------------------------------------------------- - ! X. If carbon is yet still available ... - ! Our pools are now either on allometry or above (from fusion). - ! We we can increment those pools at or below, - ! including structure and reproduction according to their rates - ! Use an adaptive euler integration. If the error is not nominal, - ! the carbon balance sub-step (deltaC) will be halved and tried again - ! ----------------------------------------------------------------------------------- - - if( carbon_balance" flag, allowing the plant to grow into these pools. - ! Again this is possible due to erors in numerical integration and/or the fusion - ! process. - ! It also checks to make sure that structural biomass is not below the target. - ! Note that we assume structural biomass is always on allometry. - ! For non-woody plants, we do not perform this partial growth logic (ie - ! allowing only some pools to grow), we let all pools at or above allometry to - ! grow. This is because we can't force any single pool to be on-allometry, and - ! thus a condition could potentially occur where all pools, either from fusion or - ! numerical errors, are above allometry and would be flagged to not grow, in which - ! case the plant would be frozen in time - - if ( EDPftvarcon_inst%woody(ipft) == itrue ) then - call TargetAllometryCheck(currentCohort%bl,currentCohort%br,currentCohort%bsw, & - currentCohort%bstore,currentCohort%bdead, & - bt_leaf,bt_fineroot,bt_sap,bt_store,bt_dead, & - grow_leaf,grow_froot,grow_sap,grow_store) - else - grow_leaf = .true. - grow_froot = .true. - grow_sap = .true. - grow_store = .true. - end if - - - ! Initialize the adaptive integrator arrays and flags - ! ----------------------------------------------------------------------------------- - ierr = 1 - totalC = carbon_balance - nsteps = 0 - c_pool(i_dbh) = currentCohort%dbh - c_pool(i_cleaf) = currentCohort%bl - c_pool(i_cfroot) = currentCohort%br - c_pool(i_csap) = currentCohort%bsw - c_pool(i_cstore) = currentCohort%bstore - c_pool(i_cdead) = currentCohort%bdead - c_pool(i_crepro) = 0.0_r8 - c_mask(i_dbh) = .true. ! Always increment dbh on growth step - c_mask(i_cleaf) = grow_leaf - c_mask(i_cfroot) = grow_froot - c_mask(i_csap) = grow_sap - c_mask(i_cstore) = grow_store - c_mask(i_cdead) = .true. ! Always increment dead on growth step - c_mask(i_crepro) = .true. ! Always calculate reproduction on growth - if(ODESolve == 2) then - currentCohort%ode_opt_step = totalC - end if - - do while( ierr .ne. 0 ) - - deltaC = min(totalC,currentCohort%ode_opt_step) - if(ODESolve == 1) then - call RKF45(AllomCGrowthDeriv,c_pool,c_mask,deltaC,totalC,currentCohort, & - max_trunc_error,c_pool_out,step_pass) - - elseif(ODESolve == 2) then - call Euler(AllomCGrowthDeriv,c_pool,c_mask,deltaC,totalC,currentCohort,c_pool_out) -! step_pass = .true. - call CheckIntegratedAllometries(c_pool_out(i_dbh),ipft,currentCohort%canopy_trim, & - c_pool_out(i_cleaf), c_pool_out(i_cfroot), c_pool_out(i_csap), & - c_pool_out(i_cstore), c_pool_out(i_cdead), & - c_mask(i_cleaf), c_mask(i_cfroot), c_mask(i_csap), & - c_mask(i_cstore),c_mask(i_cdead), max_trunc_error, step_pass) - if(step_pass) then - currentCohort%ode_opt_step = deltaC - else - currentCohort%ode_opt_step = 0.5*deltaC - end if - else - write(fates_log(),*) 'An integrator was chosen that DNE' - write(fates_log(),*) 'ODESolve = ',ODESolve - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - nsteps = nsteps + 1 - - if (step_pass) then ! If true, then step is accepted - totalC = totalC - deltaC - c_pool(:) = c_pool_out(:) - end if - - if(nsteps > max_substeps ) then - write(fates_log(),*) 'Plant Growth Integrator could not find' - write(fates_log(),*) 'a solution in less than ',max_substeps,' tries' - write(fates_log(),*) 'Aborting' - write(fates_log(),*) 'carbon_balance',carbon_balance - write(fates_log(),*) 'deltaC',deltaC - write(fates_log(),*) 'totalC',totalC - write(fates_log(),*) 'leaf:',grow_leaf,c_pool_out(i_cleaf),bt_leaf,bt_leaf-currentCohort%bl - write(fates_log(),*) 'froot:',grow_froot,c_pool_out(i_cfroot),bt_fineroot,currentCohort%br - write(fates_log(),*) 'sap:',grow_sap,c_pool_out(i_csap),bt_sap,currentCohort%bsw - write(fates_log(),*) 'store:',grow_store, c_pool_out(i_cstore),bt_store,currentCohort%bstore - write(fates_log(),*) 'dead:',c_pool_out(i_cdead),bt_dead,currentCohort%bdead - call dump_cohort(currentCohort) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! TotalC should eventually be whittled down to near zero - ! At that point, update the actual states - ! -------------------------------------------------------------------------------- - if( (totalC < calloc_abs_error) .and. (step_pass) )then - ierr = 0 - - bl_flux = c_pool(i_cleaf) - currentCohort%bl - br_flux = c_pool(i_cfroot) - currentCohort%br - bsw_flux = c_pool(i_csap) - currentCohort%bsw - bstore_flux = c_pool(i_cstore) - currentCohort%bstore - bdead_flux = c_pool(i_cdead) - currentCohort%bdead - brepro_flux = c_pool(i_crepro) - - ! Make an adjustment to flux partitions to make it match remaining c balance - flux_adj = carbon_balance/(bl_flux+br_flux+bsw_flux + & - bstore_flux+bdead_flux+brepro_flux) - - bl_flux = bl_flux*flux_adj - br_flux = br_flux*flux_adj - bsw_flux = bsw_flux*flux_adj - bstore_flux = bstore_flux*flux_adj - bdead_flux = bdead_flux*flux_adj - brepro_flux = brepro_flux*flux_adj - - carbon_balance = carbon_balance - bl_flux - currentCohort%bl = currentCohort%bl + bl_flux - currentCohort%npp_leaf = currentCohort%npp_leaf + bl_flux / hlm_freq_day - - carbon_balance = carbon_balance - br_flux - currentCohort%br = currentCohort%br + br_flux - currentCohort%npp_fnrt = currentCohort%npp_fnrt + br_flux / hlm_freq_day - - carbon_balance = carbon_balance - bsw_flux - currentCohort%bsw = currentCohort%bsw + bsw_flux - currentCohort%npp_sapw = currentCohort%npp_sapw + bsw_flux / hlm_freq_day - - carbon_balance = carbon_balance - bstore_flux - currentCohort%bstore = currentCohort%bstore + bstore_flux - currentCohort%npp_stor = currentCohort%npp_stor + bstore_flux / hlm_freq_day - - carbon_balance = carbon_balance - bdead_flux - currentCohort%bdead = currentCohort%bdead + bdead_flux - currentCohort%npp_dead = currentCohort%npp_dead + bdead_flux / hlm_freq_day - - carbon_balance = carbon_balance - brepro_flux - currentCohort%npp_seed = currentCohort%npp_seed + brepro_flux / hlm_freq_day - currentCohort%seed_prod = currentCohort%seed_prod + brepro_flux / hlm_freq_day - - dbh_sub = c_pool(i_dbh) - call h_allom(dbh_sub,ipft,h_sub) - - ! Set derivatives used as diagnostics - currentCohort%dhdt = (h_sub-currentCohort%hite)/hlm_freq_day - currentCohort%dbdeaddt = bdead_flux/hlm_freq_day - currentCohort%dbstoredt = bstore_flux/hlm_freq_day - currentCohort%ddbhdt = (dbh_sub-currentCohort%dbh)/hlm_freq_day - - currentCohort%dbh = dbh_sub - currentCohort%hite = h_sub - - if( abs(carbon_balance)>calloc_abs_error ) then - write(fates_log(),*) 'carbon conservation error while integrating pools' - write(fates_log(),*) 'along alometric curve' - write(fates_log(),*) 'carbon_balance = ',carbon_balance,totalC - write(fates_log(),*) 'exiting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - end if - end do - - return - end subroutine PlantGrowth - - ! ====================================================================================== - - function AllomCGrowthDeriv(c_pools,c_mask,cbalance,currentCohort) result(dCdx) - - ! --------------------------------------------------------------------------------- - ! This function calculates the derivatives for the carbon pools - ! relative to the amount of carbon balance. This function is based completely - ! off of allometry, and assumes that there are no other species (ie nutrients) that - ! govern allocation. - ! --------------------------------------------------------------------------------- - - ! Arguments - real(r8),intent(in), dimension(:) :: c_pools ! Vector of carbon pools - ! dbh,leaf,root,sap,store,dead - logical,intent(in), dimension(:) :: c_mask ! logical mask of active pools - ! some may be turned off - real(r8),intent(in) :: cbalance ! The carbon balance of the - ! partial step (independant var) - ! THIS IS A DUMMY VAR - type(ed_cohort_type),intent(in),target :: currentCohort ! Cohort derived type - - - ! Return Value - real(r8),dimension(lbound(c_pools,dim=1):ubound(c_pools,dim=1)) :: dCdx - - ! locals - integer :: ipft ! pft index - real(r8) :: ct_leaf ! target leaf biomass, dummy var (kgC) - real(r8) :: ct_froot ! target fine-root biomass, dummy var (kgC) - real(r8) :: at_sap ! target sapwood cross section, dummy var (m2) - real(r8) :: ct_sap ! target sapwood biomass, dummy var (kgC) - real(r8) :: ct_agw ! target aboveground wood, dummy var (kgC) - real(r8) :: ct_bgw ! target belowground wood, dummy var (kgC) - real(r8) :: ct_store ! target storage, dummy var (kgC) - real(r8) :: ct_dead ! target structural biomas, dummy var (kgC) - - real(r8) :: ct_dleafdd ! target leaf biomass derivative wrt d, (kgC/cm) - real(r8) :: ct_dfrootdd ! target fine-root biomass derivative wrt d, (kgC/cm) - real(r8) :: ct_dsapdd ! target sapwood biomass derivative wrt d, (kgC/cm) - real(r8) :: ct_dagwdd ! target AG wood biomass derivative wrt d, (kgC/cm) - real(r8) :: ct_dbgwdd ! target BG wood biomass derivative wrt d, (kgC/cm) - real(r8) :: ct_dstoredd ! target storage biomass derivative wrt d, (kgC/cm) - real(r8) :: ct_ddeaddd ! target structural biomass derivative wrt d, (kgC/cm) - real(r8) :: ct_dtotaldd ! target total (not reproductive) biomass derivative wrt d, (kgC/cm) - real(r8) :: repro_fraction ! fraction of carbon balance directed towards reproduction (kgC/kgC) - - - - associate( dbh => c_pools(i_dbh), & - cleaf => c_pools(i_cleaf), & - cfroot => c_pools(i_cfroot), & - csap => c_pools(i_csap), & - cstore => c_pools(i_cstore), & - cdead => c_pools(i_cdead), & - crepro => c_pools(i_crepro), & ! Unused (memoryless) - mask_dbh => c_mask(i_dbh), & ! Unused (dbh always grows) - mask_leaf => c_mask(i_cleaf), & - mask_froot=> c_mask(i_cfroot), & - mask_sap => c_mask(i_csap), & - mask_store=> c_mask(i_cstore), & - mask_dead => c_mask(i_cdead), & ! Unused (dead always grows) - mask_repro=> c_mask(i_crepro) ) ! Unused (memoryless) - - ipft = currentCohort%pft - - call bleaf(dbh,ipft,currentCohort%canopy_trim,ct_leaf,ct_dleafdd) - call bfineroot(dbh,ipft,currentCohort%canopy_trim,ct_froot,ct_dfrootdd) - call bsap_allom(dbh,ipft,currentCohort%canopy_trim,at_sap,ct_sap,ct_dsapdd) - call bagw_allom(dbh,ipft,ct_agw,ct_dagwdd) - call bbgw_allom(dbh,ipft,ct_bgw,ct_dbgwdd) - call bdead_allom(ct_agw,ct_bgw, ct_sap, ipft, ct_dead, & - ct_dagwdd, ct_dbgwdd, ct_dsapdd, ct_ddeaddd) - call bstore_allom(dbh,ipft,currentCohort%canopy_trim,ct_store,ct_dstoredd) - - ! fraction of carbon going towards reproduction - if (dbh <= EDPftvarcon_inst%dbh_repro_threshold(ipft)) then ! cap on leaf biomass - repro_fraction = EDPftvarcon_inst%seed_alloc(ipft) - else - repro_fraction = EDPftvarcon_inst%seed_alloc(ipft) + EDPftvarcon_inst%seed_alloc_mature(ipft) - end if - - dCdx = 0.0_r8 - - ct_dtotaldd = ct_ddeaddd - if (mask_leaf) ct_dtotaldd = ct_dtotaldd + ct_dleafdd - if (mask_froot) ct_dtotaldd = ct_dtotaldd + ct_dfrootdd - if (mask_sap) ct_dtotaldd = ct_dtotaldd + ct_dsapdd - if (mask_store) ct_dtotaldd = ct_dtotaldd + ct_dstoredd - - ! It is possible that with some asymptotic, or hard - ! capped allometries, that all growth rates reach zero. - ! In this case, if there is carbon, give it to reproduction - -! repro_fraction = 0.0_r8 - - if(ct_dtotaldd<=tiny(ct_dtotaldd))then - - dCdx(i_cdead) = 0.0_r8 - dCdx(i_dbh) = 0.0_r8 - dCdx(i_cleaf) = 0.0_r8 - dCdx(i_cfroot) = 0.0_r8 - dCdx(i_csap) = 0.0_r8 - dCdx(i_cstore) = 0.0_r8 - dCdx(i_crepro) = 1.0_r8 - - else - - dCdx(i_cdead) = (ct_ddeaddd/ct_dtotaldd)*(1.0_r8-repro_fraction) - dCdx(i_dbh) = (1.0_r8/ct_dtotaldd)*(1.0_r8-repro_fraction) - - if (mask_leaf) then - dCdx(i_cleaf) = (ct_dleafdd/ct_dtotaldd)*(1.0_r8-repro_fraction) - else - dCdx(i_cleaf) = 0.0_r8 - end if - - if (mask_froot) then - dCdx(i_cfroot) = (ct_dfrootdd/ct_dtotaldd)*(1.0_r8-repro_fraction) - else - dCdx(i_cfroot) = 0.0_r8 - end if - - if (mask_sap) then - dCdx(i_csap) = (ct_dsapdd/ct_dtotaldd)*(1.0_r8-repro_fraction) - else - dCdx(i_csap) = 0.0_r8 - end if - - if (mask_store) then - dCdx(i_cstore) = (ct_dstoredd/ct_dtotaldd)*(1.0_r8-repro_fraction) - else - dCdx(i_cstore) = 0.0_r8 - end if - - dCdx(i_crepro) = repro_fraction - - end if - - - end associate - - return - end function AllomCGrowthDeriv - - ! ====================================================================================== - - subroutine TargetAllometryCheck(bleaf,bfroot,bsap,bstore,bdead, & - bt_leaf,bt_froot,bt_sap,bt_store,bt_dead, & - grow_leaf,grow_froot,grow_sap,grow_store) - - ! Arguments - real(r8),intent(in) :: bleaf !actual - real(r8),intent(in) :: bfroot - real(r8),intent(in) :: bsap - real(r8),intent(in) :: bstore - real(r8),intent(in) :: bdead - real(r8),intent(in) :: bt_leaf !target - real(r8),intent(in) :: bt_froot - real(r8),intent(in) :: bt_sap - real(r8),intent(in) :: bt_store - real(r8),intent(in) :: bt_dead - logical,intent(out) :: grow_leaf !growth flag - logical,intent(out) :: grow_froot - logical,intent(out) :: grow_sap - logical,intent(out) :: grow_store - - if( (bt_leaf - bleaf)>calloc_abs_error) then - write(fates_log(),*) 'leaves are not on-allometry at the growth step' - write(fates_log(),*) 'exiting',bleaf,bt_leaf - call endrun(msg=errMsg(sourcefile, __LINE__)) - elseif( (bleaf - bt_leaf)>calloc_abs_error) then - ! leaf is above allometry, ignore - grow_leaf = .false. - else - grow_leaf = .true. - end if - - if( (bt_froot - bfroot)>calloc_abs_error) then - write(fates_log(),*) 'fineroots are not on-allometry at the growth step' - write(fates_log(),*) 'exiting',bfroot, bt_froot - call endrun(msg=errMsg(sourcefile, __LINE__)) - elseif( ( bfroot-bt_froot)>calloc_abs_error ) then - grow_froot = .false. - else - grow_froot = .true. - end if - - if( (bt_sap - bsap)>calloc_abs_error) then - write(fates_log(),*) 'sapwood is not on-allometry at the growth step' - write(fates_log(),*) 'exiting',bsap, bt_sap - call endrun(msg=errMsg(sourcefile, __LINE__)) - elseif( ( bsap-bt_sap)>calloc_abs_error ) then - grow_sap = .false. - else - grow_sap = .true. - end if - - if( (bt_store - bstore)>calloc_abs_error) then - write(fates_log(),*) 'storage is not on-allometry at the growth step' - write(fates_log(),*) 'exiting',bstore,bt_store - call endrun(msg=errMsg(sourcefile, __LINE__)) - elseif( ( bstore-bt_store)>calloc_abs_error ) then - grow_store = .false. - else - grow_store = .true. - end if - - if( (bt_dead - bdead)>calloc_abs_error) then - write(fates_log(),*) 'structure not on-allometry at the growth step' - write(fates_log(),*) 'exiting',bdead,bt_dead - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end subroutine TargetAllometryCheck - - ! ============================================================================ subroutine recruitment( currentSite, currentPatch, bc_in ) ! ! !DESCRIPTION: @@ -1685,7 +944,8 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) real(r8) :: a_sapwood ! sapwood cross section are [m2] (dummy) real(r8) :: b_agw ! Above ground biomass [kgC] real(r8) :: b_bgw ! Below ground biomass [kgC] - + real(r8) :: b_dead + real(r8) :: b_store !---------------------------------------------------------------------- allocate(temp_cohort) ! create temporary cohort @@ -1704,8 +964,8 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) call bsap_allom(temp_cohort%dbh,ft,temp_cohort%canopy_trim,a_sapwood, b_sapwood) call bagw_allom(temp_cohort%dbh,ft,b_agw) call bbgw_allom(temp_cohort%dbh,ft,b_bgw) - call bdead_allom(b_agw,b_bgw,b_sapwood,ft,temp_cohort%bdead) - call bstore_allom(temp_cohort%dbh,ft,temp_cohort%canopy_trim,temp_cohort%bstore) + call bdead_allom(b_agw,b_bgw,b_sapwood,ft,b_dead) + call bstore_allom(temp_cohort%dbh,ft,temp_cohort%canopy_trim,b_store) temp_cohort%laimemory = 0.0_r8 if (EDPftvarcon_inst%season_decid(temp_cohort%pft) == 1.and.currentSite%status == 1)then @@ -1729,7 +989,7 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) if (hlm_use_ed_prescribed_phys .eq. ifalse .or. EDPftvarcon_inst%prescribed_recruitment(ft) .lt. 0. ) then temp_cohort%n = currentPatch%area * currentPatch%seed_germination(ft)*hlm_freq_day & - / (temp_cohort%bdead+b_leaf+b_fineroot+b_sapwood+temp_cohort%bstore) + / (b_dead+b_leaf+b_fineroot+b_sapwood+b_store) else ! prescribed recruitment rates. number per sq. meter per year temp_cohort%n = currentPatch%area * EDPftvarcon_inst%prescribed_recruitment(ft) * hlm_freq_day @@ -1737,14 +997,14 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) ! add prescribed rates as an input C flux, and the recruitment that would have otherwise occured as an output flux ! (since the carbon associated with them effectively vanishes) currentSite%flux_in = currentSite%flux_in + temp_cohort%n * & - (temp_cohort%bstore + b_leaf + b_fineroot + b_sapwood + temp_cohort%bdead) + (b_store + b_leaf + b_fineroot + b_sapwood + b_dead) currentSite%flux_out = currentSite%flux_out + currentPatch%area * currentPatch%seed_germination(ft)*hlm_freq_day endif if (temp_cohort%n > 0.0_r8 )then if ( debug ) write(fates_log(),*) 'EDPhysiologyMod.F90 call create_cohort ' call create_cohort(currentSite,currentPatch, temp_cohort%pft, temp_cohort%n, temp_cohort%hite, temp_cohort%dbh, & - b_leaf, b_fineroot, b_sapwood, temp_cohort%bdead, temp_cohort%bstore, & + b_leaf, b_fineroot, b_sapwood, b_dead, b_store, & temp_cohort%laimemory, cohortstatus,recruitstatus, temp_cohort%canopy_trim, currentPatch%NCL_p, & currentSite%spread, bc_in) @@ -1781,6 +1041,17 @@ subroutine CWD_Input( currentSite, currentPatch) 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_c ! leaf carbon [kg] + real(r8) :: fnrt_c + real(r8) :: sapw_c + real(r8) :: struct_c + real(r8) :: store_c + real(r8) :: leaf_c_turnover ! leaf turnover [kg] + real(r8) :: fnrt_c_turnover + real(r8) :: sapw_c_turnover + real(r8) :: struct_c_turnover + real(r8) :: store_c_turnover + real(r8) :: trunk_product ! carbon flux into trunk products kgC/day/site integer :: pft !---------------------------------------------------------------------- @@ -1793,32 +1064,47 @@ subroutine CWD_Input( currentSite, currentPatch) do while(associated(currentCohort)) pft = currentCohort%pft + + leaf_c_turnover = currentCohort%prt%GetTurnover(leaf_organ,all_carbon_elements) + store_c_turnover = currentCohort%prt%GetTurnover(store_organ,all_carbon_elements) + fnrt_c_turnover = currentCohort%prt%GetTurnover(fnrt_organ,all_carbon_elements) + sapw_c_turnover = currentCohort%prt%GetTurnover(sapw_organ,all_carbon_elements) + struct_c_turnover = currentCohort%prt%GetTurnover(struct_organ,all_carbon_elements) + + 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) + ! ================================================ ! Litter from tissue turnover. KgC/m2/year ! ================================================ - currentPatch%leaf_litter_in(pft) = currentPatch%leaf_litter_in(pft) + & - currentCohort%leaf_md * currentCohort%n/currentPatch%area !turnover - - currentPatch%root_litter_in(pft) = currentPatch%root_litter_in(pft) + & - (currentCohort%root_md + currentCohort%bstore_md) & - * currentCohort%n/currentPatch%area !turnover currentPatch%leaf_litter_in(pft) = currentPatch%leaf_litter_in(pft) + & - currentCohort%leaf_litter * currentCohort%n/currentPatch%area/hlm_freq_day - + leaf_c_turnover * currentCohort%n/currentPatch%area/hlm_freq_day + + currentPatch%root_litter_in(pft) = currentPatch%root_litter_in(pft) + & + (fnrt_c_turnover + store_c_turnover ) * & + currentCohort%n/currentPatch%area/hlm_freq_day + + !daily leaf loss needs to be scaled up to the annual scale here. ! --------------------------------------------------------------------------------- ! Assumption: turnover from deadwood and sapwood are lumped together in CWD pool ! --------------------------------------------------------------------------------- - + do c = 1,ncwd currentPatch%cwd_AG_in(c) = currentPatch%cwd_AG_in(c) + & - (currentCohort%bdead_md + currentCohort%bsw_md) * & - SF_val_CWD_frac(c) * currentCohort%n/currentPatch%area * EDPftvarcon_inst%allom_agb_frac(currentCohort%pft) + (sapw_c_turnover + struct_c_turnover)/hlm_freq_day * & + SF_val_CWD_frac(c) * currentCohort%n/currentPatch%area * & + EDPftvarcon_inst%allom_agb_frac(currentCohort%pft) + currentPatch%cwd_BG_in(c) = currentPatch%cwd_BG_in(c) + & - (currentCohort%bdead_md + currentCohort%bsw_md) * & - SF_val_CWD_frac(c) * currentCohort%n/currentPatch%area *(1.0_r8-EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)) + (sapw_c_turnover + struct_c_turnover)/hlm_freq_day * & + SF_val_CWD_frac(c) * currentCohort%n/currentPatch%area * & + (1.0_r8-EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)) enddo !if (currentCohort%canopy_layer > 1)then @@ -1833,7 +1119,7 @@ subroutine CWD_Input( currentSite, currentPatch) ! 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/hlm_freq_day/currentPatch%area + currentCohort%n/hlm_freq_day/currentPatch%area ! Total number of dead understory from indirect logging dead_n_ilogging = ( currentCohort%lmort_collateral + currentCohort%lmort_infra) * & @@ -1841,27 +1127,28 @@ subroutine CWD_Input( currentSite, currentPatch) dead_n_natural = dead_n - dead_n_dlogging - dead_n_ilogging - + currentPatch%leaf_litter_in(pft) = currentPatch%leaf_litter_in(pft) + & - (currentCohort%bl)* dead_n + (leaf_c)* dead_n ! %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 - !(currentCohort%bl+currentCohort%leaf_litter/hlm_freq_day)* dead_n + currentPatch%root_litter_in(pft) = currentPatch%root_litter_in(pft) + & - (currentCohort%br+currentCohort%bstore) * dead_n + (fnrt_c + store_c ) * dead_n ! Update diagnostics that track resource management currentSite%resources_management%delta_litter_stock = & currentSite%resources_management%delta_litter_stock + & - (currentCohort%bl+currentCohort%br+currentCohort%bstore) * & + (leaf_c + fnrt_c + store_c ) * & (dead_n_ilogging+dead_n_dlogging) * & hlm_freq_day * currentPatch%area + ! Update diagnostics that track resource management currentSite%resources_management%delta_biomass_stock = & currentSite%resources_management%delta_biomass_stock + & - (currentCohort%bl+currentCohort%br+currentCohort%bstore) * & + (leaf_c + fnrt_c + store_c ) * & (dead_n_ilogging+dead_n_dlogging) * & hlm_freq_day * currentPatch%area @@ -1872,25 +1159,25 @@ subroutine CWD_Input( currentSite, currentPatch) do c = 1,ncwd - currentPatch%cwd_BG_in(c) = currentPatch%cwd_BG_in(c) + (currentCohort%bdead+currentCohort%bsw) * & + currentPatch%cwd_BG_in(c) = currentPatch%cwd_BG_in(c) + (struct_c + sapw_c) * & SF_val_CWD_frac(c) * dead_n * (1.0_r8-EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)) ! Send AGB component of boles from non direct-logging activities to AGB litter pool if (c==ncwd) then - currentPatch%cwd_AG_in(c) = currentPatch%cwd_AG_in(c) + (currentCohort%bdead+currentCohort%bsw) * & + currentPatch%cwd_AG_in(c) = currentPatch%cwd_AG_in(c) + (struct_c + sapw_c) * & SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & EDPftvarcon_inst%allom_agb_frac(currentCohort%pft) else - currentPatch%cwd_AG_in(c) = currentPatch%cwd_AG_in(c) + (currentCohort%bdead+currentCohort%bsw) * & + currentPatch%cwd_AG_in(c) = currentPatch%cwd_AG_in(c) + (struct_c + sapw_c) * & SF_val_CWD_frac(c) * dead_n * & EDPftvarcon_inst%allom_agb_frac(currentCohort%pft) ! Send AGB component of boles from direct-logging activities to export/harvest pool ! Generate trunk product (kgC/day/site) - trunk_product = (currentCohort%bdead+currentCohort%bsw) * & + trunk_product = (struct_c + sapw_c) * & SF_val_CWD_frac(c) * dead_n_dlogging * EDPftvarcon_inst%allom_agb_frac(currentCohort%pft) * & hlm_freq_day * currentPatch%area @@ -1909,19 +1196,19 @@ subroutine CWD_Input( currentSite, currentPatch) ! Update diagnostics that track resource management currentSite%resources_management%delta_litter_stock = & currentSite%resources_management%delta_litter_stock + & - (currentCohort%bdead+currentCohort%bsw) * & + (struct_c + sapw_c) * & SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & hlm_freq_day * currentPatch%area ! Update diagnostics that track resource management currentSite%resources_management%delta_biomass_stock = & currentSite%resources_management%delta_biomass_stock + & - (currentCohort%bdead+currentCohort%bsw) * & + (struct_c + sapw_c) * & SF_val_CWD_frac(c) * dead_n * & hlm_freq_day * currentPatch%area if (currentPatch%cwd_AG_in(c) < 0.0_r8)then write(fates_log(),*) 'negative CWD in flux',currentPatch%cwd_AG_in(c), & - (currentCohort%bdead+currentCohort%bsw), dead_n + (struct_c + sapw_c), dead_n endif end do @@ -2150,6 +1437,11 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) real(r8) :: biomass_bg_ft(1:maxpft) real(r8) :: surface_prof_tot, leaf_prof_sum, stem_prof_sum, froot_prof_sum, biomass_bg_tot real(r8) :: delta + real(r8) :: leaf_c + real(r8) :: store_c + real(r8) :: fnrt_c + real(r8) :: sapw_c + real(r8) :: struct_c ! NOTE(rgk, 201705) this parameter was brought over from SoilBiogeochemVerticalProfile ! how steep profile is for surface components (1/ e_folding depth) (1/m) @@ -2160,6 +1452,8 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) real(r8) :: croot_prof(1:nsites, 1:hlm_numlevgrnd) real(r8) :: stem_prof(1:nsites, 1:hlm_numlevgrnd) + + delta = 0.001_r8 !no of seconds in a year. time_convert = 365.0_r8*sec_per_day @@ -2348,11 +1642,19 @@ subroutine flux_into_litter_pools(nsites, sites, bc_in, bc_out) biomass_bg_ft(1:numpft) = 0._r8 currentCohort => currentPatch%tallest do while(associated(currentCohort)) + + 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) + biomass_bg_ft(currentCohort%pft) = biomass_bg_ft(currentCohort%pft) + & - ((currentCohort%bdead + currentCohort%bsw ) * & - (1.0_r8-EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)) + & - (currentCohort%br + currentCohort%bstore )) * & - (currentCohort%n / currentPatch%area) + ( (struct_c + sapw_c) * & + (1.0_r8-EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)) + & + (fnrt_c + store_c ) ) * & + (currentCohort%n / currentPatch%area) + currentCohort => currentCohort%shorter enddo !currentCohort ! diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index 943f162e39..81881a190a 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -89,6 +89,7 @@ module FatesAllometryMod use FatesConstantsMod, only : g_per_kg use FatesConstantsMod, only : cm2_per_m2 use FatesConstantsMod, only : kg_per_Megag + use FatesConstantsMod, only : calloc_abs_error use shr_log_mod , only : errMsg => shr_log_errMsg use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun @@ -548,7 +549,7 @@ end subroutine storage_fraction_of_target ! ===================================================================================== - real(r8) function tree_lai( bl, pft, c_area, nplant, cl, canopy_lai) + real(r8) function tree_lai( leaf_c, pft, c_area, nplant, cl, canopy_lai) ! ----------------------------------------------------------------------------------- ! LAI of individual trees is a function of the total leaf area and the total @@ -556,8 +557,8 @@ real(r8) function tree_lai( bl, pft, c_area, nplant, cl, canopy_lai) ! ---------------------------------------------------------------------------------- ! !ARGUMENTS - real(r8), intent(in) :: bl ! plant leaf biomass [kg] - integer, intent(in) :: pft + real(r8), intent(in) :: leaf_c ! plant leaf carbon [kg] + 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 @@ -579,12 +580,15 @@ real(r8) function tree_lai( bl, pft, c_area, nplant, cl, canopy_lai) ! tree_lai function !---------------------------------------------------------------------- - if( bl < 0._r8 .or. pft == 0 ) then - write(fates_log(),*) 'problem in treelai',bl,pft + if( leaf_c < -1.1_r8*calloc_abs_error .or. pft == 0 ) then + write(fates_log(),*) 'negative leaf carbon in LAI calculation?' + write(fates_log(),*) 'or.. pft was zero?' + write(fates_log(),*) 'problem in treelai',leaf_c,pft + call endrun(msg=errMsg(sourcefile, __LINE__)) endif slat = g_per_kg * EDPftvarcon_inst%slatop(pft) ! m2/g to m2/kg - leafc_per_unitarea = bl/(c_area/nplant) !KgC/m2 + leafc_per_unitarea = leaf_c/(c_area/nplant) !KgC/m2 if(leafc_per_unitarea > 0.0_r8)then diff --git a/biogeophys/EDBtranMod.F90 b/biogeophys/EDBtranMod.F90 index 7f046dfe68..1b095a87a5 100644 --- a/biogeophys/EDBtranMod.F90 +++ b/biogeophys/EDBtranMod.F90 @@ -197,7 +197,7 @@ subroutine btran_ed( nsites, sites, bc_in, bc_out) cpatch%rootr_ft(ft,j) * pftgs(ft)/sum_pftgs else bc_out(s)%rootr_pasl(ifp,j) = bc_out(s)%rootr_pasl(ifp,j) + & - cpatch%rootr_ft(ft,j) * 1._r8/dble(numpft) + cpatch%rootr_ft(ft,j) * 1._r8/real(numpft,r8) end if enddo enddo diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index 8c28170455..d27f6ebb63 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -71,6 +71,10 @@ module FatesPlantHydraulicsMod use FatesHydraulicsMemMod, only: InitHydraulicsDerived use FatesHydraulicsMemMod, only: nlevsoi_hyd_max + use PRTGenericMod, only : all_carbon_elements + use PRTGenericMod, only : leaf_organ, fnrt_organ, sapw_organ + use PRTGenericMod, only : store_organ, repro_organ, struct_organ + use clm_time_manager , only : get_step_size, get_nstep use FatesConstantsMod, only: cm2_per_m2 @@ -312,6 +316,10 @@ subroutine updateSizeDepTreeHydProps(currentSite,cc_p,bc_in) real(r8) :: kmax_tot ! total tree (leaf to root tip) hydraulic conductance [kg s-1 MPa-1] real(r8) :: dz_node1_nodekplus1 ! cumulative distance between canopy node and node k + 1 [m] real(r8) :: dz_node1_lowerk ! cumulative distance between canopy node and upper boundary of node k [m] + real(r8) :: leaf_c + real(r8) :: fnrt_c + real(r8) :: sapw_c + real(r8) :: struct_c integer :: nlevsoi_hyd ! Number of soil hydraulic layers integer :: nlevsoil ! Number of total soil layers type(ed_cohort_hydr_type), pointer :: ccohort_hydr @@ -326,16 +334,22 @@ subroutine updateSizeDepTreeHydProps(currentSite,cc_p,bc_in) FT = cCohort%pft roota = EDPftvarcon_inst%roota_par(FT) rootb = EDPftvarcon_inst%rootb_par(FT) + + leaf_c = cCohort%prt%GetState(leaf_organ, all_carbon_elements) + sapw_c = cCohort%prt%GetState(sapw_organ, all_carbon_elements) + fnrt_c = cCohort%prt%GetState(fnrt_organ, all_carbon_elements) + struct_c = cCohort%prt%GetState(struct_organ, all_carbon_elements) + !roota = 4.372_r8 ! TESTING: deep (see Zeng 2001 Table 1) !rootb = 0.978_r8 ! TESTING: deep (see Zeng 2001 Table 1) !roota = 8.992_r8 ! TESTING: shallow (see Zeng 2001 Table 1) !rootb = 8.992_r8 ! TESTING: shallow (see Zeng 2001 Table 1) - if(cCohort%bl>0.0) then !only update when bleaf >0 - b_woody_carb = cCohort%bsw + cCohort%bdead + if(leaf_c>0.0) then !only update when bleaf >0 + b_woody_carb = sapw_c + struct_c b_woody_bg_carb = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(FT)) * b_woody_carb - b_tot_carb = cCohort%bsw + cCohort%bdead + cCohort%bl + cCohort%br - b_canopy_carb = cCohort%bl + b_tot_carb = sapw_c + struct_c + leaf_c + fnrt_c + b_canopy_carb = leaf_c b_bg_carb = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(FT)) * b_tot_carb ! SAVE INITIAL VOLUMES @@ -388,15 +402,16 @@ subroutine updateSizeDepTreeHydProps(currentSite,cc_p,bc_in) ! a_sapwood = a_leaf_tot / EDPftvarcon_inst%allom_latosa_int(FT)*1.e-4_r8 ! m2 sapwood = m2 leaf * cm2 sapwood/m2 leaf *1.0e-4m2 - - + ! or ... + ! a_sapwood = a_leaf_tot / ( 0.001_r8 + 0.025_r8 * cCohort%hite ) * 1.e-4_r8 + v_sapwood = a_sapwood * z_stem ccohort_hydr%v_ag(n_hypool_leaf+1:n_hypool_ag) = v_sapwood / n_hypool_stem ! TRANSPORTING ROOT DEPTH & VOLUME !in special case where n_hypool_troot = 1, the node depth of the single troot pool !is the depth at which 50% total root distribution is attained - dcumul_rf = 1._r8/dble(n_hypool_troot) + dcumul_rf = 1._r8/real(n_hypool_troot,r8) do k=1,n_hypool_troot cumul_rf = dcumul_rf*k @@ -417,7 +432,7 @@ subroutine updateSizeDepTreeHydProps(currentSite,cc_p,bc_in) !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 - !b_troot_carb = b_bg_carb - cCohort%br ! this can give negative values + b_troot_carb = b_woody_bg_carb b_troot_biom = b_troot_carb * C2B v_troot = b_troot_biom / (EDPftvarcon_inst%wood_density(FT)*1.e3_r8) @@ -427,8 +442,8 @@ subroutine updateSizeDepTreeHydProps(currentSite,cc_p,bc_in) ccohort_hydr%z_node_aroot(1:nlevsoi_hyd) = -bc_in%z_sisl(1:nlevsoi_hyd) - ccohort_hydr%l_aroot_tot = cCohort%br*C2B*EDPftvarcon_inst%hydr_srl(FT) - !ccohort_hydr%v_aroot_tot = cCohort%br/EDecophyscon%ccontent(FT)/EDecophyscon%rootdens(FT) + ccohort_hydr%l_aroot_tot = fnrt_c*C2B*EDPftvarcon_inst%hydr_srl(FT) + !ccohort_hydr%v_aroot_tot = fnrt_c/EDecophyscon%ccontent(FT)/EDecophyscon%rootdens(FT) ccohort_hydr%v_aroot_tot = pi_const*(EDPftvarcon_inst%hydr_rs2(FT)**2._r8)*ccohort_hydr%l_aroot_tot !ccohort_hydr%l_aroot_tot = ccohort_hydr%v_aroot_tot/(pi_const*EDecophyscon%rs2(FT)**2) if(nlevsoi_hyd == 1) then @@ -890,7 +905,10 @@ subroutine UpdateH2OVeg(nsites,sites,bc_out) currentCohort=>currentPatch%tallest do while(associated(currentCohort)) balive_patch = balive_patch + & - (currentCohort%bl + currentCohort%bsw + currentCohort%br ) * currentCohort%n + (currentCohort%prt%GetState(fnrt_organ, all_carbon_elements) + & + currentCohort%prt%GetState(sapw_organ, all_carbon_elements) + & + currentCohort%prt%GetState(leaf_organ, all_carbon_elements)) * currentCohort%n + currentCohort => currentCohort%shorter enddo !cohort @@ -1009,11 +1027,11 @@ subroutine updateSizeDepRhizHydProps(currentSite, bc_in ) kmax_soil_total = 2._r8*pi_const*csite_hydr%l_aroot_layer(j) / & log(csite_hydr%r_node_shell(j,k)/csite_hydr%rs1(j))*hksat_s csite_hydr%kmax_upper_shell(j,k) = (1._r8/kmax_root_surf_total + & - 1._r8/kmax_soil_total)**-1._r8 + 1._r8/kmax_soil_total)**(-1._r8) csite_hydr%kmax_bound_shell(j,k) = (1._r8/kmax_root_surf_total + & - 1._r8/kmax_soil_total)**-1._r8 + 1._r8/kmax_soil_total)**(-1._r8) csite_hydr%kmax_lower_shell(j,k) = (1._r8/kmax_root_surf_total + & - 1._r8/kmax_soil_total)**-1._r8 + 1._r8/kmax_soil_total)**(-1._r8) end if if(j == 1) then if(csite_hydr%r_node_shell(j,k) <= csite_hydr%rs1(j)) then @@ -1024,11 +1042,11 @@ subroutine updateSizeDepRhizHydProps(currentSite, bc_in ) kmax_soil_total = 2._r8*pi_const*csite_hydr%l_aroot_1D / & log(csite_hydr%r_node_shell_1D(k)/csite_hydr%rs1(j))*hksat_s csite_hydr%kmax_upper_shell_1D(k) = (1._r8/kmax_root_surf_total + & - 1._r8/kmax_soil_total)**-1._r8 + 1._r8/kmax_soil_total)**(-1._r8) csite_hydr%kmax_bound_shell_1D(k) = (1._r8/kmax_root_surf_total + & - 1._r8/kmax_soil_total)**-1._r8 + 1._r8/kmax_soil_total)**(-1._r8) csite_hydr%kmax_lower_shell_1D(k) = (1._r8/kmax_root_surf_total + & - 1._r8/kmax_soil_total)**-1._r8 + 1._r8/kmax_soil_total)**(-1._r8) end if end if else @@ -1295,7 +1313,9 @@ subroutine BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) ccohort=>cpatch%tallest do while(associated(ccohort)) balive_patch = balive_patch + & - (cCohort%bl + cCohort%bsw + cCohort%br) * ccohort%n + (cCohort%prt%GetState(fnrt_organ, all_carbon_elements) + & + cCohort%prt%GetState(sapw_organ, all_carbon_elements) + & + cCohort%prt%GetState(leaf_organ, all_carbon_elements))* ccohort%n ccohort => ccohort%shorter enddo !cohort @@ -1303,8 +1323,11 @@ subroutine BTranForHLMDiagnosticsFromCohortHydr(nsites,sites,bc_out) ccohort=>cpatch%tallest do while(associated(ccohort)) bc_out(s)%btran_pa(ifp) = bc_out(s)%btran_pa(ifp) + & - ccohort%co_hydr%btran(1) * (cCohort%bl + cCohort%bsw + cCohort%br) * & - ccohort%n / balive_patch + ccohort%co_hydr%btran(1) * & + (cCohort%prt%GetState(fnrt_organ, all_carbon_elements) + & + cCohort%prt%GetState(sapw_organ, all_carbon_elements) + & + cCohort%prt%GetState(leaf_organ, all_carbon_elements)) * & + ccohort%n / balive_patch ccohort => ccohort%shorter enddo !cohort cpatch => cpatch%younger @@ -2532,7 +2555,7 @@ subroutine Hydraulics_1DSolve(cc_p, ft, z_node, v_node, ths_node, thr_node, kmax iterh1 = 0 do while( iterh1 == 0 .or. ((abs(we_local) > thresh .or. supsub_flag /= 0) .and. iterh1 < maxiter) ) dt_fac = max(imult*iterh1,1) - dt_fac2 = DBLE(dt_fac) + dt_fac2 = real(dt_fac,r8) dt_new = dtime/dt_fac2 !! restore initial states for a fresh attempt using new sub-timesteps @@ -4078,7 +4101,7 @@ subroutine swcCampbell_satfrac_from_psi(psi, psisat, B, satfrac) ! !LOCAL VARIABLES: !------------------------------------------------------------------------------ - satfrac = (psi/psisat)**(-1/B) + satfrac = (psi/psisat)**(-1.0_r8/B) end subroutine swcCampbell_satfrac_from_psi @@ -4416,7 +4439,7 @@ subroutine shellGeom(l_aroot, rs1, area, dz, r_out_shell, r_node_shell, v_shell) r_out_shell(nshell) = (pi_const*l_aroot/(area*dz))**(-0.5_r8) ! eqn(8) S98 if(nshell > 1) then do k = 1,nshell-1 - r_out_shell(k) = rs1*(r_out_shell(nshell)/rs1)**((k+0._r8)/nshell) ! eqn(7) S98 + r_out_shell(k) = rs1*(r_out_shell(nshell)/rs1)**((real(k,r8))/real(nshell,r8)) ! eqn(7) S98 enddo end if diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index a70c3eff4a..56ca97ea23 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -25,11 +25,23 @@ module FATESPlantRespPhotosynthMod use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : itrue use FatesInterfaceMod, only : hlm_use_planthydro + use FatesInterfaceMod, only : hlm_parteh_mode use FatesInterfaceMod, only : numpft use EDTypesMod, only : maxpft use EDTypesMod, only : nlevleaf use EDTypesMod, only : nclmax - + + 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 + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -158,7 +170,11 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! nitrogen content (kgN/plant) real(r8) :: live_croot_n ! Live coarse root (below-ground sapwood) ! nitrogen content (kgN/plant) - real(r8) :: froot_n ! Fine root nitrogen content (kgN/plant) + real(r8) :: sapw_c ! Sapwood carbon (kgC/plant) + real(r8) :: fnrt_c ! Fine root carbon (kgC/plant) + real(r8) :: fnrt_n ! Fine root nitrogen content (kgN/plant) + 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. @@ -176,7 +192,9 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: check_elai ! This is a check on the effective LAI that is calculated ! 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) :: 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, @@ -184,6 +202,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) 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 + ! ----------------------------------------------------------------------------------- ! Keeping these two definitions in case they need to be added later @@ -223,9 +242,6 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) slatop => EDPftvarcon_inst%slatop , & ! specific leaf area at top of canopy, ! projected area basis [m^2/gC] woody => EDPftvarcon_inst%woody , & ! Is vegetation woody or not? - leafcn => EDPftvarcon_inst%leafcn , & ! leaf C:N (gC/gN) - frootcn => EDPftvarcon_inst%frootcn, & ! froot C:N (gc/gN) - woodcn => EDPftvarcon_inst%woodcn, & ! wood C:N (gc/gN) q10 => FatesSynchronizedParamsInst%Q10 ) bbbopt(0) = ED_val_bbopt_c4 @@ -349,7 +365,9 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) cl = currentCohort%canopy_layer call bleaf(currentCohort%dbh,currentCohort%pft,currentCohort%canopy_trim,b_leaf) - call storage_fraction_of_target(b_leaf, currentCohort%bstore, frac) + call storage_fraction_of_target(b_leaf, & + currentCohort%prt%GetState(store_organ, all_carbon_elements), & + frac) call lowstorage_maintresp_reduction(frac,currentCohort%pft, & maintresp_reduction_factor) @@ -369,7 +387,9 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! not been done yet. ! ------------------------------------------------------------ - if ( .not.rate_mask_z(iv,ft,cl) .or. (hlm_use_planthydro.eq.itrue) ) then + if ( .not.rate_mask_z(iv,ft,cl) .or. & + (hlm_use_planthydro.eq.itrue) .or. & + (hlm_parteh_mode .ne. prt_carbon_allom_hyp ) ) then if (hlm_use_planthydro.eq.itrue) then @@ -407,9 +427,34 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! Scale for leaf nitrogen profile nscaler = exp(-kn(ft) * 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 = EDPftvarcon_inst%prt_nitr_stoich_p1(ft,leaf_organ)/slatop(ft) + + case (prt_cnp_flex_allom_hyp) + + leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) + leaf_n = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) + lnc_top = leaf_n / (slatop(ft) * leaf_c ) + + 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( param_derived%lmr25top(ft),& ! in + call LeafLayerMaintenanceRespiration( lmr25top, & ! in nscaler, & ! in ft, & ! in bc_in(s)%t_veg_pa(ifp), & ! in @@ -533,13 +578,36 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! the sapwood pools. ! Units are in (kgN/plant) ! ------------------------------------------------------------------ - live_stem_n = EDPftvarcon_inst%allom_agb_frac(currentCohort%pft) * currentCohort%bsw / & - woodcn(currentCohort%pft) - live_croot_n = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)) * currentCohort%bsw / & - woodcn(currentCohort%pft) - froot_n = currentCohort%br / frootcn(currentCohort%pft) - + + 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 = EDPftvarcon_inst%allom_agb_frac(currentCohort%pft) * & + sapw_c * EDPftvarcon_inst%prt_nitr_stoich_p1(ft,sapw_organ) + + live_croot_n = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)) * & + sapw_c * EDPftvarcon_inst%prt_nitr_stoich_p1(ft,sapw_organ) + + fnrt_n = fnrt_c * EDPftvarcon_inst%prt_nitr_stoich_p1(ft,fnrt_organ) + + case(prt_cnp_flex_allom_hyp) + live_stem_n = EDPftvarcon_inst%allom_agb_frac(currentCohort%pft) * & + currentCohort%prt%GetState(sapw_organ, nitrogen_element) + + live_croot_n = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)) * & + currentCohort%prt%GetState(sapw_organ, nitrogen_element) + + fnrt_n = currentCohort%prt%GetState(fnrt_organ, nitrogen_element) + + case default + + + end select + !------------------------------------------------------------------------------ ! Calculate Whole Plant Respiration ! (this doesn't really need to be in this iteration at all, surely?) @@ -566,7 +634,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) do j = 1,bc_in(s)%nlevsoil tcsoi = q10**((bc_in(s)%t_soisno_sl(j)-tfrz - 20.0_r8)/10.0_r8) currentCohort%froot_mr = currentCohort%froot_mr + & - froot_n * ED_val_base_mr_20 * tcsoi * currentPatch%rootfr_ft(ft,j) * maintresp_reduction_factor + fnrt_n * ED_val_base_mr_20 * tcsoi * currentPatch%rootfr_ft(ft,j) * maintresp_reduction_factor enddo ! Coarse Root MR (kgC/plant/s) (below ground sapwood) @@ -1604,6 +1672,10 @@ subroutine LeafLayerMaintenanceRespiration(lmr25top_ft, & 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 diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index ffd83f8261..2a7a1ca01c 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -28,6 +28,17 @@ module SFMainMod use EDtypesMod , only : NFSC use EDtypesMod , only : TR_SF + use PRTGenericMod, only : leaf_organ + use PRTGenericMod, only : all_carbon_elements + 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 PRTGenericMod, only : SetState + + implicit none private @@ -167,7 +178,11 @@ subroutine charecteristics_of_fuel ( currentSite ) currentCohort => currentPatch%tallest do while(associated(currentCohort)) if(EDPftvarcon_inst%woody(currentCohort%pft) == 0)then - currentPatch%livegrass = currentPatch%livegrass + currentCohort%bl*currentCohort%n/currentPatch%area + + currentPatch%livegrass = currentPatch%livegrass + & + currentCohort%prt%GetState(leaf_organ, all_carbon_elements) * & + currentCohort%n/currentPatch%area + endif currentCohort => currentCohort%shorter enddo @@ -230,7 +245,7 @@ subroutine charecteristics_of_fuel ( currentSite ) endif ! FIX(RF,032414): needs refactoring. ! average water content !is this the correct metric? - timeav_swc = sum(currentSite%water_memory(1:numWaterMem)) / dble(numWaterMem) + timeav_swc = sum(currentSite%water_memory(1:numWaterMem)) / real(numWaterMem,r8) ! Equation B2 in Thonicke et al. 2010 ! live grass moisture content depends on upper soil layer fuel_moisture(lg_sf) = max(0.0_r8, 10.0_r8/9._r8 * timeav_swc - 1.0_r8/9.0_r8) @@ -754,7 +769,8 @@ subroutine area_burnt ( currentSite ) ! THIS SHOULD HAVE THE COLUMN AND LU AREA WEIGHT ALSO, NO? gridarea = km2_to_m2 ! 1M m2 in a km2 - !NF = number of lighting strikes per day per km2 + + ! NF = number of lighting strikes per day per km2 currentPatch%NF = ED_val_nignitions * currentPatch%area/area /365 ! If there are 15 lightening strickes per year, per km2. (approx from NASA product) @@ -769,9 +785,10 @@ subroutine area_burnt ( currentSite ) size_of_fire = ((3.1416_r8/(4.0_r8*lb))*((df+db)**2.0_r8)) !AB = daily area burnt = size fires in m2 * num ignitions * prob ignition starts fire + ! m2 per km2 per day currentPatch%AB = size_of_fire * currentPatch%NF * currentSite%FDI - patch_area_in_m2 = gridarea*currentPatch%area/area + patch_area_in_m2 = gridarea *currentPatch%area/area currentPatch%frac_burnt = currentPatch%AB / patch_area_in_m2 if(write_SF == itrue)then @@ -810,8 +827,12 @@ subroutine crown_scorching ( currentSite ) type(ed_patch_type), pointer :: currentPatch type(ed_cohort_type), pointer :: currentCohort - real f_ag_bmass !fraction of a tree cohort's above-ground biomass as a proportion of total patch ag tree biomass. - real tree_ag_biomass !total amount of above-ground tree biomass in patch. kgC/m2 + real(r8) :: f_ag_bmass !fraction of a tree cohort's above-ground biomass as a proportion of total patch ag tree biomass. + real(r8) :: tree_ag_biomass !total amount of above-ground tree biomass in patch. kgC/m2 + real(r8) :: leaf_c ! leaf carbon [kg] + real(r8) :: sapw_c ! sapwood carbon [kg] + real(r8) :: struct_c ! structure carbon [kg] + currentPatch => currentSite%oldest_patch; do while(associated(currentPatch)) @@ -822,8 +843,14 @@ subroutine crown_scorching ( currentSite ) currentCohort => currentPatch%tallest; do while(associated(currentCohort)) if (EDPftvarcon_inst%woody(currentCohort%pft) == 1) then !trees only - tree_ag_biomass = tree_ag_biomass+(currentCohort%bl+EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)* & - (currentCohort%bsw + currentCohort%bdead))*currentCohort%n + + 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) + + tree_ag_biomass = tree_ag_biomass + & + currentCohort%n * (leaf_c + & + EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)*(sapw_c + struct_c)) endif !trees only currentCohort=>currentCohort%shorter; @@ -838,8 +865,15 @@ subroutine crown_scorching ( currentSite ) do while(associated(currentCohort)) if (EDPftvarcon_inst%woody(currentCohort%pft) == 1 & .and. (tree_ag_biomass > 0.0_r8)) then !trees only - f_ag_bmass = ((currentCohort%bl+EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)*(currentCohort%bsw + & - currentCohort%bdead))*currentCohort%n)/tree_ag_biomass + + 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) + + f_ag_bmass = currentCohort%n * (leaf_c + & + EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)*(sapw_c + struct_c)) & + / tree_ag_biomass + !equation 16 in Thonicke et al. 2010 if(write_SF == itrue)then if ( hlm_masterproc == itrue ) write(fates_log(),*) 'currentPatch%SH',currentPatch%SH,f_ag_bmass diff --git a/functional_unit_testing/parteh/PartehDriver.py b/functional_unit_testing/parteh/PartehDriver.py new file mode 100644 index 0000000000..c567039696 --- /dev/null +++ b/functional_unit_testing/parteh/PartehDriver.py @@ -0,0 +1,770 @@ +# ======================================================================================= +# +## @package PARTEH (Plant Allocatoin and Reactive Transport Exensible Hypotheses +# +# For usage: $python PartehDriver.py --help +# +# This script is designed to run PARTEH offline (ie not coupled with an ecosystem model). +# It will interpret user input, and provide synthetic initial conditions and boundary +# conditions to the plant. +# +# Step 1) Read in User arguments +# 1a) Define simulation conditions (initial conditions,timing,parameters,etc) +# 1b) Define state variables +# 1c) Define fluxes terms (and their forms) +# 1d) Define source-sink (boundary conditions) terms +# Step 2) Cycle through flux terms, perform allocations and determine construction of Dx/Dt +# Step 3) Initialize Simulation +# Step 4) Time-step simulation +# 4a) calculate derivative +# 4b) Integrate (either internally or via numerical integration package) +# +# ======================================================================================= + +import matplotlib as mpl +#mpl.use('Agg') +import matplotlib.pyplot as plt +from datetime import datetime +#from matplotlib.backends.backend_pdf import PdfPages +import platform +import numpy as np +import os +import sys +import getopt +import code # For development: code.interact(local=locals()) +import time +import imp +import ctypes +from ctypes import * +from operator import add + +PartehInterpretParameters = imp.load_source('PartehInterpretParameters', \ + 'py_modules/PartehInterpretParameters.py') +PartehTypes = imp.load_source('PartehTypes', 'py_modules/PartehTypes.py') +SyntheticBoundaries = imp.load_source('SyntheticBoundaries','py_modules/SyntheticBoundaries.py') + +from PartehInterpretParameters import load_xml + +f90_fates_wrap_obj_name = 'bld/FatesWrapMod.o' +f90_fates_integrators_obj_name = 'bld/FatesIntegratorsMod.o' +f90_fates_partehwrap_obj_name = 'bld/FatesPARTEHWrapMod.o' +f90_fates_lossfluxes_obj_name = 'bld/PRTLossFluxesMod.o' +f90_fates_parteh_generic_obj_name = 'bld/PRTGenericMod.o' +f90_fates_pftwrap_obj_name = 'bld/FatesPFTWrapMod.o' +f90_fates_parteh_callom_obj_name = 'bld/PRTAllometricCarbonMod.o' +f90_fates_parteh_cnpallom_obj_name = 'bld/PRTAllometricCNPMod.o' +f90_fates_cohortwrap_obj_name = 'bld/FatesCohortWrapMod.o' +f90_fates_allom_obj_name = 'bld/FatesAllometryMod.o' + +# ======================================================================================= +# Some Global Parmaeters + +## The name of the xml file containing site data (should not change) +xml_file = '' + + +# ======================================================================================== +# ======================================================================================== +# Main +# ======================================================================================== +# ======================================================================================== + + +def main(argv): + + # First check to make sure python 2.7 is being used + version = platform.python_version() + verlist = version.split('.') + + if( not ((verlist[0] == '2') & (verlist[1] == '7') & (int(verlist[2])>=15) ) ): + print("The PARTEH driver mus be run with python 2.7") + print(" with tertiary version >=15.") + print(" your version is {}".format(version)) + print(" exiting...") + sys.exit(2) + + + # Retrieve the name and path to the xml control file + # from the input arguments + xml_file = interp_args(argv) + + # Initialize the time structure + time_control = PartehTypes.timetype() + + # Initialize the parameter structure + parameters = PartehTypes.param_type() + + # This loads the dictionaries of, and lists of objects that + # define the variables, parameters and forms that govern the + # system of equations and solution + load_xml(xml_file,time_control,parameters) + + # ----------------------------------------------------------------------------------- + # + # We may be calling fortran, if so, we need to initialize the modules + # This includes building the library objects, calling those objects + # and possibly allocating memory in those objects. The fortran libraries + # and functions are held inside globally defined objects fates_f90_obj + # + # ----------------------------------------------------------------------------------- + + # Define the F90 objects + # These must be loaded according to the module dependency order + # Note that these calls instantiate the modules + f90_fates_wrap_obj = ctypes.CDLL(f90_fates_wrap_obj_name,mode=ctypes.RTLD_GLOBAL) + f90_fates_integrators_obj = ctypes.CDLL(f90_fates_integrators_obj_name,mode=ctypes.RTLD_GLOBAL) + f90_fates_pftwrap_obj = ctypes.CDLL(f90_fates_pftwrap_obj_name,mode=ctypes.RTLD_GLOBAL) + f90_fates_parteh_generic_obj = ctypes.CDLL(f90_fates_parteh_generic_obj_name,mode=ctypes.RTLD_GLOBAL) + f90_fates_allom_obj = ctypes.CDLL(f90_fates_allom_obj_name,mode=ctypes.RTLD_GLOBAL) + f90_fates_parteh_callom_obj = ctypes.CDLL(f90_fates_parteh_callom_obj_name,mode=ctypes.RTLD_GLOBAL) + f90_fates_lossfluxes_obj = ctypes.CDLL(f90_fates_lossfluxes_obj_name,mode=ctypes.RTLD_GLOBAL) + f90_fates_parteh_cnpallom_obj = ctypes.CDLL(f90_fates_parteh_cnpallom_obj_name,mode=ctypes.RTLD_GLOBAL) + f90_fates_partehwrap_obj = ctypes.CDLL(f90_fates_partehwrap_obj_name,mode=ctypes.RTLD_GLOBAL) + f90_fates_cohortwrap_obj = ctypes.CDLL(f90_fates_cohortwrap_obj_name,mode=ctypes.RTLD_GLOBAL) + + # Initialize the PARTEH instance + iret=f90_fates_partehwrap_obj.__fatespartehwrapmod_MOD_spmappyset() #byref(c_int(parameters.prt_model))) + + # Allocate the PFT and ORGAN arrays (leaf+root+sap+store+structure+repro = 6) + max_num_organs = 6 + iret=f90_fates_pftwrap_obj.__edpftvarcon_MOD_edpftvarconalloc(byref(c_int(parameters.num_pfts)), \ + byref(c_int(max_num_organs))) + + # Set the phenology type + phen_type = [] + for pft_idx,pft_obj in enumerate(parameters.parteh_pfts): + + evergreen = np.int(parameters.parteh_pfts[pft_idx].param_dic['fates_phen_evergreen'][0]) + cold_deciduous = np.int(parameters.parteh_pfts[pft_idx].param_dic['fates_phen_season_decid'][0]) + stress_deciduous = np.int(parameters.parteh_pfts[pft_idx].param_dic['fates_phen_stress_decid'][0]) + if(evergreen==1): + if(cold_deciduous==1): + print("Poorly defined phenology mode 0") + exit(2) + if(stress_deciduous==1): + print("Poorly defined phenology mode 1") + exit(2) + phen_type.append(1) + elif(cold_deciduous==1): + if(evergreen==1): + print("Poorly defined phenology mode 2") + exit(2) + if(stress_deciduous==1): + print("Poorly defined phenology mode 3") + exit(2) + phen_type.append(2) + elif(stress_deciduous==1): + if(evergreen==1): + print("Poorly defined phenology mode 4") + exit(2) + if(cold_deciduous==1): + print("Poorly defined phenology mode 5") + exit(2) + phen_type.append(3) + else: + print("Unknown phenology mode ? {} {} {}".format(evergreen,cold_deciduous,stress_deciduous)) + exit(2) + + + + # Loop through each pft and pft's parameters and pass them to the fortran object + # Also, some parameters may be arrays (like organ number) + for pft_idx,pft_obj in enumerate(parameters.parteh_pfts): + + for par_idx, par_key in enumerate(pft_obj.param_dic.iterkeys()): + pval = pft_obj.param_dic[par_key] + print("{} {} {}".format(par_idx,par_key,pval)) + + # The dictionary of parameters is populated with lists of floats, even + # scalars are single entry lists + + if( len(pval)==1 ): + iret = f90_fates_pftwrap_obj.__edpftvarcon_MOD_edpftvarconpyset(byref(c_int(pft_idx+1)), \ + byref(c_int(0)), \ + byref(c_double(pval[0])), \ + c_char_p(par_key.strip()), \ + c_long(len(par_key.strip()))) + else: + for i2d in range(len(pval)): + iret = f90_fates_pftwrap_obj.__edpftvarcon_MOD_edpftvarconpyset(byref(c_int(pft_idx+1)), \ + byref(c_int(i2d+1)), \ + byref(c_double(pval[i2d])), \ + c_char_p(par_key.strip()), \ + c_long(len(par_key.strip()))) + + # Allocate the cohort array (We create on cohort per PFT) + iret=f90_fates_cohortwrap_obj.__fatescohortwrapmod_MOD_cohortinitalloc(byref(c_int(parameters.num_pfts))) + + for pft_idx, pft_obj in enumerate(parameters.parteh_pfts): + hgt_min = pft_obj.param_dic['fates_recruit_hgt_min'] + init_canopy_trim = 1.0 + iret=f90_fates_cohortwrap_obj.__fatescohortwrapmod_MOD_cohortpyset(byref(c_int(pft_idx+1)), \ + byref(c_double(hgt_min[0])), \ + byref(c_double(init_canopy_trim))) #, \ + # byref(c_int(parameters.prt_model))) + + # Initialize diagnostics + diagnostics = [] + for pft_idx, pft_obj in enumerate(parameters.parteh_pfts): + diagnostics.append(PartehTypes.diagnostics_type()) + + + # -------------------------------------------------------------------------------- + # Time Initialization + # -------------------------------------------------------------------------------- + time_control.ResetTime() + + # -------------------------------------------------------------------------------- + # Time integration (outer) loop + # -------------------------------------------------------------------------------- + while (time_control.sim_complete != True): + + print('Simulating Date: {}'.format(time_control.datetime.item())) + + # Start the integration substep loop + endtime = time_control.datetime+np.timedelta64(int(time_control.dt_fullstep),'s') + + for pft_idx, pft_obj in enumerate(parameters.parteh_pfts): + + + # Generate the boundary condition for the current time-step + # --------------------------------------------------------------------------- + + # First lets query this pft-cohort and return a smattering of indices + + leaf_area = c_double(0.0) + agb = c_double(0.0) + crown_area = c_double(0.0) + dbh = c_double(0.0) + target_leaf_c = c_double(-9.9) + leaf_c = c_double(0.0) + fnrt_c = c_double(0.0) + sapw_c = c_double(0.0) + store_c = c_double(0.0) + struct_c = c_double(0.0) + repro_c = c_double(0.0) + root_c_exudate = c_double(0.0) + growth_resp = c_double(0.0) + leaf_cturn = c_double(0.0) + fnrt_cturn = c_double(0.0) + sapw_cturn = c_double(0.0) + store_cturn = c_double(0.0) + struct_cturn = c_double(0.0) + + leaf_n = c_double(0.0) + fnrt_n = c_double(0.0) + sapw_n = c_double(0.0) + store_n = c_double(0.0) + struct_n = c_double(0.0) + repro_n = c_double(0.0) + root_n_exudate = c_double(0.0) + leaf_nturn = c_double(0.0) + fnrt_nturn = c_double(0.0) + sapw_nturn = c_double(0.0) + store_nturn = c_double(0.0) + struct_nturn = c_double(0.0) + + leaf_p = c_double(0.0) + fnrt_p = c_double(0.0) + sapw_p = c_double(0.0) + store_p = c_double(0.0) + struct_p = c_double(0.0) + repro_p = c_double(0.0) + root_p_exudate = c_double(0.0) + leaf_pturn = c_double(0.0) + fnrt_pturn = c_double(0.0) + sapw_pturn = c_double(0.0) + store_pturn = c_double(0.0) + struct_pturn = c_double(0.0) + + iret=f90_fates_cohortwrap_obj.__fatescohortwrapmod_MOD_wrapqueryvars(byref(c_int(pft_idx+1)), \ + byref(leaf_area), \ + byref(crown_area), \ + byref(agb), \ + byref(store_c),\ + byref(target_leaf_c)) + + + + doy = time_control.datetime.astype(object).timetuple().tm_yday + + + + # Call phenology module, if no leaves... then npp should be zero... + flush_c,drop_frac_c,leaf_status = SyntheticBoundaries.DeciduousPhenology(doy, \ + target_leaf_c.value, \ + store_c.value, phen_type[pft_idx]) + + if(parameters.boundary_method=="DailyCFromCArea"): + + presc_npp_p1 = parameters.boundary_pfts[pft_idx].param_dic['fates_prescribed_npp_p1'] + + net_daily_c = SyntheticBoundaries.DailyCFromCArea(presc_npp_p1, \ + crown_area.value, \ + phen_type[pft_idx], \ + leaf_status) + net_daily_n = 0.0 + net_daily_p = 0.0 + r_maint_demand = 0.0 + + + elif(parameters.boundary_method=="DailyCNPFromCArea"): + + presc_npp_p1 = parameters.boundary_pfts[pft_idx].param_dic['fates_prescribed_npp_p1'] + presc_nflux_p1 = parameters.boundary_pfts[pft_idx].param_dic['fates_prescribed_nflux_p1'] + presc_pflux_p1 = parameters.boundary_pfts[pft_idx].param_dic['fates_prescribed_pflux_p1'] + + net_daily_c, net_daily_n, net_daily_p = SyntheticBoundaries.DailyCNPFromCArea(presc_npp_p1, \ + presc_nflux_p1, \ + presc_pflux_p1, \ + crown_area.value, \ + phen_type[pft_idx], \ + leaf_status) + r_maint_demand = 0.0 + + + elif(parameters.boundary_method=="DailyCNPFromStorageSinWaveNoMaint"): + + presc_npp_amp = parameters.boundary_pfts[pft_idx].param_dic['fates_prescribed_npp_amp'] + presc_npp_p1 = parameters.boundary_pfts[pft_idx].param_dic['fates_prescribed_npp_p1'] + presc_nflux_p1 = parameters.boundary_pfts[pft_idx].param_dic['fates_prescribed_nflux_p1'] + presc_pflux_p1 = parameters.boundary_pfts[pft_idx].param_dic['fates_prescribed_pflux_p1'] + + + + + net_daily_c, net_daily_n, net_daily_p = SyntheticBoundaries.DailyCNPFromStorageSinWave(doy,\ + store_c.value,\ + presc_npp_p1, \ + presc_nflux_p1, \ + presc_pflux_p1, \ + crown_area.value, \ + presc_npp_amp, \ + phen_type[pft_idx], \ + leaf_status ) + r_maint_demand = 0.0 + + else: + print("An unknown boundary method was specified\n") + print("type: {} ? ... quitting.".format(parameters.boundary_method)) + exit() + + + + + + + # This function will pass in all boundary conditions, some will be dummy arguments + init_canopy_trim = 1.0 + iret=f90_fates_cohortwrap_obj.__fatescohortwrapmod_MOD_wrapdailyprt(byref(c_int(pft_idx+1)), \ + byref(c_double(net_daily_c)), \ + byref(c_double(init_canopy_trim)), \ + byref(c_double(flush_c)), \ + byref(c_double(drop_frac_c)), \ + byref(c_int(leaf_status)), \ + byref(c_double(net_daily_n)), \ + byref(c_double(net_daily_p)), \ + byref(c_double(r_maint_demand))) + + + + # This function will retrieve diagnostics + iret=f90_fates_cohortwrap_obj.__fatescohortwrapmod_MOD_wrapquerydiagnostics(byref(c_int(pft_idx+1)), \ + byref(dbh), \ + byref(leaf_c), \ + byref(fnrt_c), \ + byref(sapw_c), \ + byref(store_c), \ + byref(struct_c), \ + byref(repro_c), \ + byref(leaf_cturn), \ + byref(fnrt_cturn), \ + byref(sapw_cturn), \ + byref(store_cturn), \ + byref(struct_cturn), \ + byref(leaf_n), \ + byref(fnrt_n), \ + byref(sapw_n), \ + byref(store_n), \ + byref(struct_n), \ + byref(repro_n), \ + byref(leaf_nturn), \ + byref(fnrt_nturn), \ + byref(sapw_nturn), \ + byref(store_nturn), \ + byref(struct_nturn), \ + byref(leaf_p), \ + byref(fnrt_p), \ + byref(sapw_p), \ + byref(store_p), \ + byref(struct_p), \ + byref(repro_p), \ + byref(leaf_pturn), \ + byref(fnrt_pturn), \ + byref(sapw_pturn), \ + byref(store_pturn), \ + byref(struct_pturn), \ + byref(crown_area), \ + byref(root_c_exudate), \ + byref(root_n_exudate), \ + byref(root_p_exudate), \ + byref(growth_resp)) + + + diagnostics[pft_idx].dates.append(time_control.datetime.astype(datetime)) + diagnostics[pft_idx].dbh.append(dbh.value) + diagnostics[pft_idx].leaf_c.append(leaf_c.value) + diagnostics[pft_idx].fnrt_c.append(fnrt_c.value) + diagnostics[pft_idx].sapw_c.append(sapw_c.value) + diagnostics[pft_idx].store_c.append(store_c.value) + diagnostics[pft_idx].struct_c.append(struct_c.value) + diagnostics[pft_idx].repro_c.append(repro_c.value) + diagnostics[pft_idx].leaf_cturn.append(leaf_cturn.value) + diagnostics[pft_idx].fnrt_cturn.append(fnrt_cturn.value) + diagnostics[pft_idx].sapw_cturn.append(sapw_cturn.value) + diagnostics[pft_idx].store_cturn.append(store_cturn.value) + diagnostics[pft_idx].struct_cturn.append(struct_cturn.value) + diagnostics[pft_idx].dailyc.append(net_daily_c) + diagnostics[pft_idx].crown_area.append(crown_area.value) + + diagnostics[pft_idx].growth_resp.append(growth_resp.value) + + diagnostics[pft_idx].leaf_n.append(leaf_n.value) + diagnostics[pft_idx].fnrt_n.append(fnrt_n.value) + diagnostics[pft_idx].sapw_n.append(sapw_n.value) + diagnostics[pft_idx].store_n.append(store_n.value) + diagnostics[pft_idx].struct_n.append(struct_n.value) + diagnostics[pft_idx].repro_n.append(repro_n.value) + diagnostics[pft_idx].leaf_nturn.append(leaf_nturn.value) + diagnostics[pft_idx].fnrt_nturn.append(fnrt_nturn.value) + diagnostics[pft_idx].sapw_nturn.append(sapw_nturn.value) + diagnostics[pft_idx].store_nturn.append(store_nturn.value) + diagnostics[pft_idx].struct_nturn.append(struct_nturn.value) + + diagnostics[pft_idx].leaf_p.append(leaf_p.value) + diagnostics[pft_idx].fnrt_p.append(fnrt_p.value) + diagnostics[pft_idx].sapw_p.append(sapw_p.value) + diagnostics[pft_idx].store_p.append(store_p.value) + diagnostics[pft_idx].struct_p.append(struct_p.value) + diagnostics[pft_idx].repro_p.append(repro_p.value) + diagnostics[pft_idx].leaf_pturn.append(leaf_pturn.value) + diagnostics[pft_idx].fnrt_pturn.append(fnrt_pturn.value) + diagnostics[pft_idx].sapw_pturn.append(sapw_pturn.value) + diagnostics[pft_idx].store_pturn.append(store_pturn.value) + diagnostics[pft_idx].struct_pturn.append(struct_pturn.value) + + diagnostics[pft_idx].root_c_exudate.append(root_c_exudate.value) + diagnostics[pft_idx].root_n_exudate.append(root_n_exudate.value) + diagnostics[pft_idx].root_p_exudate.append(root_p_exudate.value) + + + # We don't have a fancy time integrator so we simply update with + # a full step + + time_control.UpdateTime() + + # --------------------------------------------------------------------------- + # Timestep complete, check the time + # --------------------------------------------------------------------------- + # time_control.CheckFullStepTime(endtime) + + +# fig0, ax = plt.subplots() +# for ipft in range(parameters.num_pfts): +# ax.plot_date(diagnostics[0].dates,diagnostics[0].dbh) +# ax.set_xlim(diagnostics[0].dates[0],diagnostics[0].dates[-1]) + +# plt.show() +# code.interact(local=locals()) + + + linestyles = ['-','-.','--','-',':','-.','--',':','-','-.','--',':' ] + + + + + fig1, ((ax1, ax2, ax3, ax4), (ax5, ax6, ax7, ax8)) = plt.subplots(2, 4 , sharex='col') #, sharey='row') + fig1.set_size_inches(12, 6) + for ipft in range(parameters.num_pfts): + ax1.plot_date(diagnostics[ipft].dates,diagnostics[ipft].struct_c,linestyles[ipft],label=parameters.parteh_pfts[ipft].name) + ax1.set_title('Structural\n Carbon') + ax1.legend(loc='upper left') + ax1.set_ylabel('[kg C]') + ax1.grid(True) + + for ipft in range(parameters.num_pfts): + ax2.plot_date(diagnostics[ipft].dates,diagnostics[ipft].leaf_c,linestyles[ipft]) + ax2.set_title('Leaf\n Carbon') + ax2.grid(True) + + for ipft in range(parameters.num_pfts): + ax3.plot_date(diagnostics[ipft].dates,diagnostics[ipft].fnrt_c,linestyles[ipft]) + ax3.set_title('Fineroot\n Carbon') + ax3.grid(True) + + for ipft in range(parameters.num_pfts): + ax4.plot_date(diagnostics[ipft].dates,diagnostics[ipft].sapw_c,linestyles[ipft]) + ax4.set_title('Sapwood\n Carbon') + ax4.set_ylabel('[kg C]') + ax4.grid(True) + + for ipft in range(parameters.num_pfts): + ax5.plot_date(diagnostics[ipft].dates,diagnostics[ipft].store_c,linestyles[ipft]) + ax5.set_title('Storage\n Carbon') + ax5.set_xlabel('Year') + ax5.grid(True) + + for ipft in range(parameters.num_pfts): + ax6.plot_date(diagnostics[ipft].dates,diagnostics[ipft].repro_c,linestyles[ipft]) + ax6.set_title('Integrated\n Reproductive\n Carbon') + ax6.set_xlabel('Year') + ax6.grid(True) + + for ipft in range(parameters.num_pfts): + ax7.plot_date(diagnostics[ipft].dates,np.cumsum(diagnostics[ipft].root_c_exudate),linestyles[ipft]) + ax7.set_title('Integrated\n Exudated\n Carbon') + ax7.set_xlabel('Year') + ax7.grid(True) + + for ipft in range(parameters.num_pfts): + ax8.plot_date(diagnostics[ipft].dates,np.cumsum(diagnostics[ipft].growth_resp),linestyles[ipft]) + ax8.set_title('Integrated\n Growth\n Respiration') + ax8.set_xlabel('Year') + ax8.grid(True) + + + + + + plt.tight_layout() + + # Plant proportions + # --------------------------------------------------------------------------------- + fig2, ( (ax1,ax2),(ax3,ax4) ) = plt.subplots(2,2) + fig2.set_size_inches(7, 6) + for ipft in range(parameters.num_pfts): + ax1.plot_date(diagnostics[ipft].dates,diagnostics[ipft].dbh,linestyles[ipft],label=parameters.parteh_pfts[ipft].name) + ax1.set_xlabel('Date') + ax1.set_title('DBH [cm]') + ax1.legend(loc='upper left') + ax1.grid(True) + + for ipft in range(parameters.num_pfts): + ax2.plot_date(diagnostics[ipft].dates,diagnostics[ipft].crown_area,linestyles[ipft]) + ax2.set_xlabel('Date') + ax2.set_title('Crown Area [m2]') + ax2.grid(True) + + for ipft in range(parameters.num_pfts): + ax3.plot(diagnostics[ipft].dbh,1000.0*np.array(diagnostics[ipft].dailyc)) + + ax3.set_xlabel('DBH [cm]') + ax3.set_title('Daily Carbon Gain [g]') + ax3.grid(True) + + for ipft in range(parameters.num_pfts): + ax4.plot(diagnostics[ipft].dbh,diagnostics[ipft].crown_area) + ax4.set_xlabel('DBH [cm]') + ax4.set_title('Crown Area [m2]') + ax4.grid(True) + + + + + + + + plt.tight_layout() + + + # Error (bias) + # --------------------------------------------------------------------------------- + + fig4 = plt.figure() + for ipft in range(parameters.num_pfts): + + total_plant_carbon0 = np.array(diagnostics[ipft].struct_c[0]) + \ + np.array(diagnostics[ipft].leaf_c[0]) + \ + np.array(diagnostics[ipft].fnrt_c[0]) + \ + np.array(diagnostics[ipft].sapw_c[0]) + \ + np.array(diagnostics[ipft].store_c[0]) + \ + np.array(diagnostics[ipft].repro_c[0]) + + total_plant_carbon = np.array(diagnostics[ipft].struct_c) + \ + np.array(diagnostics[ipft].leaf_c) + \ + np.array(diagnostics[ipft].fnrt_c) + \ + np.array(diagnostics[ipft].sapw_c) + \ + np.array(diagnostics[ipft].store_c) + \ + np.array(diagnostics[ipft].repro_c) + + integrated_plant_turnover = np.cumsum(diagnostics[ipft].struct_cturn) + \ + np.cumsum(diagnostics[ipft].leaf_cturn) + \ + np.cumsum(diagnostics[ipft].fnrt_cturn) + \ + np.cumsum(diagnostics[ipft].sapw_cturn) + \ + np.cumsum(diagnostics[ipft].store_cturn) + + + plt.plot(np.cumsum(diagnostics[ipft].dailyc), \ + (np.cumsum(diagnostics[ipft].dailyc) - \ + (total_plant_carbon + \ + integrated_plant_turnover - \ + total_plant_carbon0 ) ) / total_plant_carbon ) + + plt.xlabel('Integrated Daily Carbon Gain [kg]') + plt.ylabel('Integrated Bias [kg]') + plt.grid(True) + + # Plot out the input fluxes + + fig5= plt.figure() + for ipft in range(parameters.num_pfts): + plt.plot_date(diagnostics[ipft].dates,diagnostics[ipft].dailyc,linestyles[ipft],label=parameters.parteh_pfts[ipft].name) + + plt.xlabel('Date') + plt.ylabel('Daily Carbon Flux') + plt.grid(True) + plt.legend(loc='upper left') + + + # Special Focus plots for a PFT of interest + + figs = {} + for ipft in range(parameters.num_pfts): + figs[ipft], (ax1, ax2, ax3) = plt.subplots(1, 3) + + figs[ipft].set_size_inches(8, 4) + ax1.stackplot(np.cumsum(diagnostics[ipft].dailyc), \ + np.array(diagnostics[ipft].struct_c)+np.cumsum(diagnostics[ipft].struct_cturn), \ + np.array(diagnostics[ipft].leaf_c)+np.cumsum(diagnostics[ipft].leaf_cturn), \ + np.array(diagnostics[ipft].fnrt_c)+np.cumsum(diagnostics[ipft].fnrt_cturn), \ + np.array(diagnostics[ipft].sapw_c)+np.cumsum(diagnostics[ipft].sapw_cturn), \ + np.array(diagnostics[ipft].store_c)+np.cumsum(diagnostics[ipft].store_cturn), \ + np.array(diagnostics[ipft].repro_c), \ + labels = ["Struct","Leaf","FRoot","Sapw","Storage","Repro"]) + ax1.set_title('Allocated Mass \nby Pool [kg]') + ax1.grid(True) + + ax2.stackplot(np.cumsum(diagnostics[ipft].dailyc), \ + np.cumsum(diagnostics[ipft].struct_cturn), \ + np.cumsum(diagnostics[ipft].leaf_cturn), \ + np.cumsum(diagnostics[ipft].fnrt_cturn), \ + np.cumsum(diagnostics[ipft].sapw_cturn), \ + np.cumsum(diagnostics[ipft].store_cturn), \ + np.array(diagnostics[ipft].repro_c), \ + labels = ["Struct","Leaf","FRoot","Sapw","Storage","Repro"] ) + ax2.legend(loc=2) + ax2.grid(True) + ax2.set_xlabel('Integrated Daily\n Carbon Gain [kg]') + ax2.set_title('Integrated Turnover\n by Pool [kg]') + + + #code.interact(local=locals()) + npp_leaf = np.array(diagnostics[ipft].leaf_c[1:]) - \ + np.array(diagnostics[ipft].leaf_c[0:-1]) + \ + np.array(diagnostics[ipft].leaf_cturn[1:]) + npp_fnrt = np.array(diagnostics[ipft].fnrt_c[1:]) - \ + np.array(diagnostics[ipft].fnrt_c[0:-1]) + \ + np.array(diagnostics[ipft].fnrt_cturn[1:]) + npp_sapw = np.array(diagnostics[ipft].sapw_c[1:]) - \ + np.array(diagnostics[ipft].sapw_c[0:-1]) + \ + np.array(diagnostics[ipft].sapw_cturn[1:]) + npp_store = np.array(diagnostics[ipft].store_c[1:]) - \ + np.array(diagnostics[ipft].store_c[0:-1]) + \ + np.array(diagnostics[ipft].store_cturn[1:]) + npp_struct = np.array(diagnostics[ipft].struct_c[1:]) - \ + np.array(diagnostics[ipft].struct_c[0:-1]) + \ + np.array(diagnostics[ipft].struct_cturn[1:]) + npp_repro = np.array(diagnostics[ipft].repro_c[1:]) - \ + np.array(diagnostics[ipft].repro_c[0:-1]) + + ax3.stackplot(np.cumsum(diagnostics[ipft].dailyc[1:]), \ + npp_struct, npp_leaf, npp_fnrt, npp_sapw, npp_store, npp_repro) + + ax3.grid(True) + ax3.set_title('Daily NPP \nby Pool [kg]') + + plt.figtext(0.1,0.05,"PFT: {}".format(ipft+1),bbox={'facecolor':'red', 'alpha':0.5, 'pad':10}, fontsize=15) + + + plt.tight_layout() + + + plt.show() + + print('\nSimulation Complete \nThank You Come Again') + #exit(0) + + + +# ======================================================================================= + + + +def usage(): + print('') + print('=======================================================================') + print('') + print(' python PartehDriver.py --help --xmlfile=') + print('') + print(' This is a driver script for PARTEH') + print(' (Plant Allocation and Reactive Transport Extensible Hypotheses)') + print(' Only 1 option is currently relevent, and that is a path to the ') + print(' XML file that controls this simulation. ') + print('') + print(' Arguments:') + print('') + print(' -h --help ') + print(' print this help message') + print('') + print(' --xmlfile = ') + print(' the relative or full file path to the xml file that controls') + print(' this simulation.') + print('') + +def interp_args(argv): + + argv.pop(0) # The script itself is the first argument, forget it + + ## File path to the xml control card + xmlfile = '' + + try: + opts, args = getopt.getopt(argv, 'h',["help","xmlfile="]) + + except getopt.GetoptError as err: + print('Argument error, see usage') + usage() + sys.exit(2) + + + if(len(opts)==0): + print('\n\n') + print('No arguments were specified') + print('Exiting, see Usage below') + print('\n\n') + usage() + sys.exit(0) + + for o, a in opts: + if o in ("-h", "--help"): + usage() + sys.exit(0) + elif o in ("--xmlfile"): + xmlfile = a.strip() + if(not os.path.isfile(xmlfile)): + print('\n\n') + print('The XML control file could not be found') + print(' via argument --xmlfile') + print(' xmlfile = ',xmlfile) + print('\n\n') + usage() + sys.exit(0) + else: + assert False, "unhandled option" + + return(xmlfile) +# ======================================================================================= +# This is the actual call to main + +if __name__ == "__main__": + main(sys.argv) diff --git a/functional_unit_testing/parteh/bld/README b/functional_unit_testing/parteh/bld/README new file mode 100644 index 0000000000..044ed8e494 --- /dev/null +++ b/functional_unit_testing/parteh/bld/README @@ -0,0 +1 @@ +shared object fortran modules are compiled and placed in this directory \ No newline at end of file diff --git a/functional_unit_testing/parteh/build_fortran_objects.sh b/functional_unit_testing/parteh/build_fortran_objects.sh new file mode 100755 index 0000000000..544fec9bbd --- /dev/null +++ b/functional_unit_testing/parteh/build_fortran_objects.sh @@ -0,0 +1,49 @@ +#!/bin/bash + +# Path to FATES src + +FATES_SRC=../../ + +CNP_SRC=/home/rgknox/SyncLRC/PARTEH/FModules/ + +F_OPTS="-shared -fPIC -g -ffpe-trap=zero,overflow,underflow -fbacktrace -fbounds-check" + +MOD_FLAG="-J" + +rm -f bld/*.o +rm -f bld/*.mod + +gfortran $F_OPTS $MOD_FLAG bld/ -o bld/FatesConstants.o ${FATES_SRC}/main/FatesConstantsMod.F90 + +# Generic Integration routines (all native types except defined constants) +gfortran $F_OPTS $MOD_FLAG bld/ -I bld/ -o bld/FatesIntegratorsMod.o ${FATES_SRC}/main/FatesIntegratorsMod.F90 + +# Support Modules, fairly trivial contents +gfortran $F_OPTS $MOD_FLAG bld/ -I bld/ -o bld/FatesWrapMod.o f_wrapper_modules/FatesWrapMod.F90 + +# This defines and fills the global pft parameter structures (stripped down from fates version) +gfortran $F_OPTS $MOD_FLAG bld/ -I bld/ -o bld/FatesPFTWrapMod.o f_wrapper_modules/FatesPFTWrapMod.F90 + +# Allometry Module, take this from FATES directly +gfortran $F_OPTS $MOD_FLAG bld/ -I bld/ -o bld/FatesAllometryMod.o ${FATES_SRC}/biogeochem/FatesAllometryMod.F90 + +# The Generic (parent) PARTEH module +gfortran $F_OPTS $MOD_FLAG bld/ -I bld/ -o bld/PRTGenericMod.o ${FATES_SRC}/parteh/PRTGenericMod.F90 + +# Loss Fluxes and phenology +gfortran $F_OPTS $MOD_FLAG bld/ -I bld/ -o bld/PRTLossFluxesMod.o ${FATES_SRC}/parteh/PRTLossFluxesMod.F90 + +# The carbon-only PARTEH module +gfortran $F_OPTS $MOD_FLAG bld/ -I bld/ -o bld/PRTAllometricCarbonMod.o ${FATES_SRC}/parteh/PRTAllometricCarbonMod.F90 + +# The CNP allometric target model +gfortran $F_OPTS $MOD_FLAG bld/ -I bld/ -o bld/PRTAllometricCNPMod.o ${CNP_SRC}/PRTAllometricCNPMod.F90 + +# Initialize PARTEH instance and mapping functions +gfortran $F_OPTS $MOD_FLAG bld/ -I bld/ bld/PRTGenericMod.o bld/PRTAllometricCarbonMod.o -o bld/FatesPARTEHWrapMod.o f_wrapper_modules/FatesPARTEHWrapMod.F90 + +# The cohort instances and initialization +gfortran $F_OPTS $MOD_FLAG bld/ -I bld/ -o bld/FatesCohortWrapMod.o f_wrapper_modules/FatesCohortWrapMod.F90 + + + diff --git a/functional_unit_testing/parteh/f_wrapper_modules/FatesCohortWrapMod.F90 b/functional_unit_testing/parteh/f_wrapper_modules/FatesCohortWrapMod.F90 new file mode 100644 index 0000000000..9907c567b9 --- /dev/null +++ b/functional_unit_testing/parteh/f_wrapper_modules/FatesCohortWrapMod.F90 @@ -0,0 +1,579 @@ +! ======================================================================================= +! +! This is the wrapper module that provides FATES data structures +! +! ======================================================================================= + +module FatesCohortWrapMod + + use iso_c_binding, only : r8 => c_double + use iso_c_binding, only : i4 => c_int + use iso_c_binding, only : c_char + use FatesAllometryMod, only : bleaf + use FatesAllometryMod, only : bfineroot + use FatesAllometryMod, only : bsap_allom + use FatesAllometryMod, only : bagw_allom + use FatesAllometryMod, only : bbgw_allom + use FatesAllometryMod, only : bdead_allom + use FatesAllometryMod, only : bstore_allom + use FatesAllometryMod, only : h2d_allom + use FatesAllometryMod, only : tree_lai + use FatesAllometryMod, only : carea_allom + + use EDPftvarcon, only : EDPftvarcon_inst + + use PRTGenericMod, only : InitPRTVartype + use PRTGenericMod, only : prt_vartypes + use PRTGenericMod, only : leaf_organ + use PRTGenericMod, only : all_carbon_elements + use PRTGenericMod, only : carbon12_element + use PRTGenericMod, only : nitrogen_element + use PRTGenericMod, only : phosphorous_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 PRTGenericMod, only : carbon12_element + use PRTGenericMod, only : SetState + use PRTGenericMod, only : prt_global + + use PRTAllometricCarbonMod, only : callom_prt_vartypes + use PRTAllometricCarbonMod, only : ac_bc_inout_id_netdc + use PRTAllometricCarbonMod, only : ac_bc_in_id_pft + use PRTAllometricCarbonMod, only : ac_bc_in_id_ctrim + use PRTAllometricCarbonMod, only : ac_bc_inout_id_dbh + use PRTAllometricCarbonMod, only : prt_global_ac + + use PRTLossFluxesMod, only : PRTMaintTurnover + use PRTLossFluxesMod, only : PRTDeciduousTurnover + use PRTLossFluxesMod, only : PRTPhenologyFlush + + use PRTAllometricCNPMod, only : prt_global_acnp + use PRTAllometricCNPMod, only : cnp_allom_prt_vartypes + use PRTAllometricCNPMod, only : acnp_bc_inout_id_dbh + use PRTAllometricCNPMod, only : acnp_bc_inout_id_netdc + use PRTAllometricCNPMod, only : acnp_bc_inout_id_rmaint_def + use PRTAllometricCNPMod, only : acnp_bc_inout_id_netdn + use PRTAllometricCNPMod, only : acnp_bc_inout_id_netdp + use PRTAllometricCNPMod, only : acnp_bc_in_id_ctrim + use PRTAllometricCNPMod, only : acnp_bc_in_id_pft + use PRTAllometricCNPMod, only : acnp_bc_in_id_status + use PRTAllometricCNPMod, only : acnp_bc_out_id_rootcexude + use PRTAllometricCNPMod, only : acnp_bc_out_id_rootnexude + use PRTAllometricCNPMod, only : acnp_bc_out_id_rootpexude + use PRTAllometricCNPMod, only : acnp_bc_out_id_growresp + + + use FatesConstantsMod , only : nearzero + + use EDTypesMod , only : nclmax + + use FatesGlobals , only : endrun => fates_endrun + use FatesGlobals , only : fates_log + use shr_log_mod , only : errMsg => shr_log_errMsg + + + + implicit none + + + type ed_cohort_type + + integer :: pft ! pft number + integer :: parteh_model ! The PARTEH allocation hypothesis used + real(r8) :: dbh ! dbh: cm + integer :: status_coh ! leaf status 1=off, 2=on + real(r8) :: canopy_trim ! Trimming function for the canopy + + real(r8) :: dhdt ! time derivative of height : m/year + real(r8) :: ddbhdt ! time derivative of dbh : cm/year + + real(r8) :: daily_carbon_gain ! + real(r8) :: daily_nitrogen_gain ! + real(r8) :: daily_phosphorous_gain ! + real(r8) :: daily_r_grow ! + real(r8) :: daily_r_maint ! + real(r8) :: daily_r_maint_demand ! + real(r8) :: accum_r_maint_deficit ! + real(r8) :: carbon_root_exudate ! + real(r8) :: nitrogen_root_exudate ! + real(r8) :: phosphorous_root_exudate ! + + + ! Multi-species, multi-pool Reactive Transport + class(prt_vartypes), pointer :: prt + + end type ed_cohort_type + + ! Global Instances + + type(ed_cohort_type), pointer :: cohort_array(:) + integer :: numcohort + + character(len=*), parameter, private :: sourcefile = __FILE__ + +contains + + subroutine CohortInitAlloc(numcohorts) + + ! Arguments + integer(i4), intent(in) :: numcohorts + + ! Locals + integer(i4) :: ico + type(ed_cohort_type), pointer :: ccohort + + + allocate(cohort_array(numcohorts)) + + do ico = 1,numcohorts + ccohort => cohort_array(ico) + ccohort%parteh_model = -1 + ccohort%pft = -9 + ccohort%dbh = -999.9_r8 + ccohort%status_coh = -1 + ccohort%canopy_trim = -999.9_r8 + ccohort%dhdt = -999.9_r8 + ccohort%ddbhdt = -999.9_r8 + ccohort%daily_carbon_gain = -999.9_r8 + ccohort%daily_nitrogen_gain = -999.9_r8 + ccohort%daily_phosphorous_gain = -999.9_r8 + ccohort%daily_r_grow = -999.9_r8 + ccohort%daily_r_maint = -999.9_r8 + ccohort%daily_r_maint_demand = -999.9_r8 + ccohort%accum_r_maint_deficit = -999.9_r8 + ccohort%carbon_root_exudate = -999.9_r8 + ccohort%nitrogen_root_exudate = -999.9_r8 + ccohort%phosphorous_root_exudate = -999.9_r8 + end do + + return + end subroutine CohortInitAlloc + + ! ===================================================================================== + + subroutine CohortPySet(ipft,hgt_min,canopy_trim) + + implicit none + ! Arguments + integer(i4),intent(in) :: ipft + real(r8),intent(in) :: hgt_min + real(r8),intent(in) :: canopy_trim + + ! Locals + + type(ed_cohort_type), pointer :: ccohort ! Current cohort + real(r8) :: leaf_c + real(r8) :: fnrt_c + real(r8) :: sapw_c + real(r8) :: agw_c + real(r8) :: bgw_c + real(r8) :: struct_c + real(r8) :: repro_c + real(r8) :: store_c + + real(r8) :: sapw_area ! dummy area cross-sec + + real(r8) :: leaf_n + real(r8) :: fnrt_n + real(r8) :: sapw_n + real(r8) :: struct_n + real(r8) :: repro_n + real(r8) :: store_n + real(r8) :: leaf_p + real(r8) :: fnrt_p + real(r8) :: sapw_p + real(r8) :: struct_p + real(r8) :: repro_p + real(r8) :: store_p + + + class(callom_prt_vartypes), pointer :: callom_prt + class(cnp_allom_prt_vartypes), pointer :: cnpallom_prt + + + ccohort => cohort_array(ipft) + + + ccohort%pft = int(ipft) + ccohort%parteh_model = int(EDPftvarcon_inst%parteh_model(ipft)) + + call h2d_allom(hgt_min,ipft,ccohort%dbh) + ccohort%canopy_trim = canopy_trim + + ! Use allometry to compute initial values + + ! Leaf biomass (carbon) + call bleaf(ccohort%dbh, ipft, canopy_trim, leaf_c) + + ! Fine-root biomass (carbon) + call bfineroot(ccohort%dbh, ipft, canopy_trim, fnrt_c) + + ! Sapwood biomass (carbon) + call bsap_allom(ccohort%dbh, ipft, canopy_trim, sapw_area, sapw_c) + + ! Above ground woody biomass (carbon) + call bagw_allom(ccohort%dbh, ipft, agw_c) + + ! Below ground woody biomass (carbon) + call bbgw_allom(ccohort%dbh, ipft, bgw_c) + + ! Total structural biomass (carbon) + call bdead_allom(agw_c, bgw_c, sapw_c, ipft, struct_c) + + ! Target storage carbon [kgC,kgC/cm] + call bstore_allom(ccohort%dbh, ipft, canopy_trim, store_c) + + repro_c = 0.0_r8 + + + select case(ccohort%parteh_model) + case (1) + prt_global => prt_global_ac + allocate(callom_prt) + ccohort%prt => callom_prt + + case(2) + prt_global => prt_global_acnp + allocate(cnpallom_prt) + ccohort%prt => cnpallom_prt + + case DEFAULT + write(fates_log(),*) 'You specified an unknown PRT module' + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + call ccohort%prt%InitPRTVartype() + + select case(ccohort%parteh_model) + case (1) + + call SetState(ccohort%prt,leaf_organ, carbon12_element, leaf_c) + call SetState(ccohort%prt,fnrt_organ, carbon12_element, fnrt_c) + call SetState(ccohort%prt,sapw_organ, carbon12_element, sapw_c) + call SetState(ccohort%prt,store_organ, carbon12_element, store_c) + call SetState(ccohort%prt,struct_organ , carbon12_element, struct_c) + call SetState(ccohort%prt,repro_organ , carbon12_element, repro_c) + + call ccohort%prt%RegisterBCInOut(ac_bc_inout_id_dbh,bc_rval = ccohort%dbh) + call ccohort%prt%RegisterBCInOut(ac_bc_inout_id_netdc,bc_rval = ccohort%daily_carbon_gain) + + call ccohort%prt%RegisterBCIn(ac_bc_in_id_pft,bc_ival = ccohort%pft) + call ccohort%prt%RegisterBCIn(ac_bc_in_id_ctrim,bc_rval = ccohort%canopy_trim) + + case (2) + + ! Initializing with the target stoichiometric ratios + ! (OR you can initialize with the minimum ratios too.... p2) + leaf_n = leaf_c * EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,leaf_organ) + fnrt_n = fnrt_c * EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,fnrt_organ) + sapw_n = sapw_c * EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,sapw_organ) + store_n = store_c * EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,store_organ) + struct_n = struct_c * EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,struct_organ) + repro_n = repro_c * EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,repro_organ) + + leaf_p = leaf_c * EDPftvarcon_inst%prt_phos_stoich_p1(ipft,leaf_organ) + fnrt_p = fnrt_c * EDPftvarcon_inst%prt_phos_stoich_p1(ipft,fnrt_organ) + sapw_p = sapw_c * EDPftvarcon_inst%prt_phos_stoich_p1(ipft,sapw_organ) + store_p = store_c * EDPftvarcon_inst%prt_phos_stoich_p1(ipft,store_organ) + struct_p = struct_c * EDPftvarcon_inst%prt_phos_stoich_p1(ipft,struct_organ) + repro_p = repro_c * EDPftvarcon_inst%prt_phos_stoich_p1(ipft,repro_organ) + + ccohort%accum_r_maint_deficit = 0.0_r8 + + call SetState(ccohort%prt,leaf_organ, carbon12_element, leaf_c) + call SetState(ccohort%prt,fnrt_organ, carbon12_element, fnrt_c) + call SetState(ccohort%prt,sapw_organ, carbon12_element, sapw_c) + call SetState(ccohort%prt,store_organ, carbon12_element, store_c) + call SetState(ccohort%prt,struct_organ , carbon12_element, struct_c) + call SetState(ccohort%prt,repro_organ , carbon12_element, repro_c) + + call SetState(ccohort%prt,leaf_organ, nitrogen_element, leaf_n) + call SetState(ccohort%prt,fnrt_organ, nitrogen_element, fnrt_n) + call SetState(ccohort%prt,sapw_organ, nitrogen_element, sapw_n) + call SetState(ccohort%prt,store_organ, nitrogen_element, store_n) + call SetState(ccohort%prt,struct_organ , nitrogen_element, struct_n) + call SetState(ccohort%prt,repro_organ , nitrogen_element, repro_n) + + call SetState(ccohort%prt,leaf_organ, phosphorous_element, leaf_p) + call SetState(ccohort%prt,fnrt_organ, phosphorous_element, fnrt_p) + call SetState(ccohort%prt,sapw_organ, phosphorous_element, sapw_p) + call SetState(ccohort%prt,store_organ, phosphorous_element, store_p) + call SetState(ccohort%prt,struct_organ , phosphorous_element, struct_p) + call SetState(ccohort%prt,repro_organ , phosphorous_element, repro_p) + + ! Register In/Out Boundary Conditions + call ccohort%prt%RegisterBCInOut(acnp_bc_inout_id_dbh,bc_rval = ccohort%dbh) + call ccohort%prt%RegisterBCInOut(acnp_bc_inout_id_netdc,bc_rval = ccohort%daily_carbon_gain) + call ccohort%prt%RegisterBCInOut(acnp_bc_inout_id_netdn,bc_rval = ccohort%daily_nitrogen_gain) + call ccohort%prt%RegisterBCInOut(acnp_bc_inout_id_netdp,bc_rval = ccohort%daily_phosphorous_gain) + call ccohort%prt%RegisterBCInOut(acnp_bc_inout_id_rmaint_def, bc_rval = ccohort%accum_r_maint_deficit) + + ! Register Input only BC's + call ccohort%prt%RegisterBCIn(acnp_bc_in_id_pft,bc_ival = ccohort%pft) + call ccohort%prt%RegisterBCIn(acnp_bc_in_id_ctrim,bc_rval = ccohort%canopy_trim) + call ccohort%prt%RegisterBCIn(acnp_bc_in_id_status,bc_ival = ccohort%status_coh) + + ! Register Output Boundary Conditions + call ccohort%prt%RegisterBCOut(acnp_bc_out_id_rootcexude,bc_rval = ccohort%carbon_root_exudate) + call ccohort%prt%RegisterBCOut(acnp_bc_out_id_rootnexude,bc_rval = ccohort%nitrogen_root_exudate) + call ccohort%prt%RegisterBCOut(acnp_bc_out_id_rootpexude,bc_rval = ccohort%phosphorous_root_exudate) + call ccohort%prt%RegisterBCOut(acnp_bc_out_id_growresp,bc_rval = ccohort%daily_r_grow ) + + + end select + + call ccohort%prt%CheckInitialConditions() + + + end subroutine CohortPySet + + ! ===================================================================================== + + subroutine WrapDailyPRT(ipft,daily_carbon_gain,canopy_trim,flush_c,drop_frac_c,leaf_status, & + daily_nitrogen_gain, daily_phosphorous_gain,daily_r_maint_demand ) + + implicit none + ! Arguments + integer(i4),intent(in) :: ipft + real(r8),intent(in) :: daily_carbon_gain + real(r8),intent(in) :: canopy_trim + real(r8),intent(in) :: flush_c + real(r8),intent(in) :: drop_frac_c + integer,intent(in) :: leaf_status + real(r8), intent(in), optional :: daily_nitrogen_gain + real(r8), intent(in), optional :: daily_phosphorous_gain + real(r8), intent(in), optional :: daily_r_maint_demand + + type(ed_cohort_type), pointer :: ccohort + + + ccohort => cohort_array(ipft) + + ccohort%status_coh = leaf_status + + ! Zero the rate of change and the turnover arrays + + call ccohort%prt%ZeroRates() + + call PRTDeciduousTurnover(ccohort%prt, ipft, leaf_organ , drop_frac_c) + + call PRTPhenologyFlush(ccohort%prt, ipft, leaf_organ, flush_c) + + call PRTMaintTurnover(ccohort%prt, ipft) + + select case(int(ccohort%parteh_model)) + case (1) + prt_global => prt_global_ac + ccohort%daily_carbon_gain = daily_carbon_gain + + call ccohort%prt%DailyPRT() + + ccohort%daily_r_grow = 0.0_r8 + ccohort%carbon_root_exudate = 0.0_r8 + + case (2) + prt_global => prt_global_acnp + ccohort%daily_carbon_gain = daily_carbon_gain + ccohort%daily_nitrogen_gain = daily_nitrogen_gain + ccohort%daily_phosphorous_gain = daily_phosphorous_gain + ccohort%accum_r_maint_deficit = ccohort%accum_r_maint_deficit + & + daily_r_maint_demand + + call ccohort%prt%DailyPRT() + + + case DEFAULT + write(fates_log(),*) 'You specified an unknown PRT module' + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + + + call ccohort%prt%CheckMassConservation(ipft,1) + + + + return + end subroutine WrapDailyPRT + + ! ===================================================================================== + + subroutine WrapQueryVars(ipft,leaf_area,crown_area,agb,store_c,target_leaf_c) + + implicit none + ! Arguments + integer(i4),intent(in) :: ipft + real(r8),intent(out) :: leaf_area + real(r8),intent(out) :: crown_area + real(r8),intent(out) :: agb + real(r8),intent(out) :: store_c + real(r8),intent(out) :: target_leaf_c + + real(r8) :: leaf_c + type(ed_cohort_type), pointer :: ccohort + + real(r8),parameter :: nplant = 1.0_r8 + real(r8),parameter :: site_spread = 1.0_r8 + + real(r8), parameter, dimension(nclmax) :: canopy_lai = [0.0_r8,0.0_r8,0.0_r8,0.0_r8] + integer, parameter :: cl1 = 1 + + ccohort => cohort_array(ipft) + + + select case(int(ccohort%parteh_model)) + case (1) + prt_global => prt_global_ac + case (2) + prt_global => prt_global_acnp + end select + + + leaf_c = ccohort%prt%GetState(leaf_organ, all_carbon_elements ) + store_c = ccohort%prt%GetState(store_organ, all_carbon_elements ) + + call carea_allom(ccohort%dbh,nplant,site_spread,ipft,crown_area) + + leaf_area = crown_area*tree_lai(leaf_c, ipft, crown_area, nplant, cl1, canopy_lai) + + call bagw_allom(ccohort%dbh,ipft,agb) + + call bleaf(ccohort%dbh,ipft, ccohort%canopy_trim, target_leaf_c) + + + return + end subroutine WrapQueryVars + + + subroutine WrapQueryDiagnostics(ipft, dbh, & + leaf_c, fnrt_c, sapw_c, store_c, struct_c, repro_c, & + leaf_cturn, fnrt_cturn, sapw_cturn, store_cturn, struct_cturn, & + leaf_n, fnrt_n, sapw_n, store_n, struct_n, repro_n, & + leaf_nturn, fnrt_nturn, sapw_nturn, store_nturn, struct_nturn, & + leaf_p, fnrt_p, sapw_p, store_p, struct_p, repro_p, & + leaf_pturn, fnrt_pturn, sapw_pturn, store_pturn, struct_pturn, & + crown_area, & + carbon_root_exudate, nitrogen_root_exudate, phosphorous_root_exudate, & + growth_resp ) + + implicit none + ! Arguments + integer(i4),intent(in) :: ipft + real(r8),intent(out) :: dbh + + real(r8),intent(out) :: leaf_c + real(r8),intent(out) :: fnrt_c + real(r8),intent(out) :: sapw_c + real(r8),intent(out) :: store_c + real(r8),intent(out) :: struct_c + real(r8),intent(out) :: repro_c + real(r8),intent(out) :: leaf_cturn + real(r8),intent(out) :: fnrt_cturn + real(r8),intent(out) :: sapw_cturn + real(r8),intent(out) :: store_cturn + real(r8),intent(out) :: struct_cturn + + real(r8),intent(out) :: leaf_n + real(r8),intent(out) :: fnrt_n + real(r8),intent(out) :: sapw_n + real(r8),intent(out) :: store_n + real(r8),intent(out) :: struct_n + real(r8),intent(out) :: repro_n + real(r8),intent(out) :: leaf_nturn + real(r8),intent(out) :: fnrt_nturn + real(r8),intent(out) :: sapw_nturn + real(r8),intent(out) :: store_nturn + real(r8),intent(out) :: struct_nturn + + real(r8),intent(out) :: leaf_p + real(r8),intent(out) :: fnrt_p + real(r8),intent(out) :: sapw_p + real(r8),intent(out) :: store_p + real(r8),intent(out) :: struct_p + real(r8),intent(out) :: repro_p + real(r8),intent(out) :: leaf_pturn + real(r8),intent(out) :: fnrt_pturn + real(r8),intent(out) :: sapw_pturn + real(r8),intent(out) :: store_pturn + real(r8),intent(out) :: struct_pturn + + + real(r8),intent(out) :: carbon_root_exudate + real(r8),intent(out) :: nitrogen_root_exudate + real(r8),intent(out) :: phosphorous_root_exudate + real(r8),intent(out) :: growth_resp + + real(r8),intent(out) :: crown_area + type(ed_cohort_type), pointer :: ccohort + real(r8),parameter :: nplant = 1.0_r8 + real(r8),parameter :: site_spread = 1.0_r8 + + ccohort => cohort_array(ipft) + + select case(int(ccohort%parteh_model)) + case (1) + prt_global => prt_global_ac + case (2) + prt_global => prt_global_acnp + end select + + dbh = ccohort%dbh + + leaf_c = ccohort%prt%GetState(organ_id=leaf_organ, species_id=all_carbon_elements) + fnrt_c = ccohort%prt%GetState(organ_id=fnrt_organ, species_id=all_carbon_elements) + sapw_c = ccohort%prt%GetState(organ_id=sapw_organ, species_id=all_carbon_elements) + store_c = ccohort%prt%GetState(organ_id=store_organ, species_id=all_carbon_elements) + struct_c = ccohort%prt%GetState(organ_id=struct_organ, species_id=all_carbon_elements) + repro_c = ccohort%prt%GetState(organ_id=repro_organ, species_id=all_carbon_elements) + + leaf_cturn = ccohort%prt%GetTurnover(organ_id=leaf_organ, species_id=all_carbon_elements) + fnrt_cturn = ccohort%prt%GetTurnover(organ_id=fnrt_organ, species_id=all_carbon_elements) + sapw_cturn = ccohort%prt%GetTurnover(organ_id=sapw_organ, species_id=all_carbon_elements) + store_cturn = ccohort%prt%GetTurnover(organ_id=store_organ, species_id=all_carbon_elements) + struct_cturn = ccohort%prt%GetTurnover(organ_id=struct_organ, species_id=all_carbon_elements) + + leaf_n = ccohort%prt%GetState(organ_id=leaf_organ, species_id=nitrogen_element) + fnrt_n = ccohort%prt%GetState(organ_id=fnrt_organ, species_id=nitrogen_element) + sapw_n = ccohort%prt%GetState(organ_id=sapw_organ, species_id=nitrogen_element) + store_n = ccohort%prt%GetState(organ_id=store_organ, species_id=nitrogen_element) + struct_n = ccohort%prt%GetState(organ_id=struct_organ, species_id=nitrogen_element) + repro_n = ccohort%prt%GetState(organ_id=repro_organ, species_id=nitrogen_element) + + leaf_nturn = ccohort%prt%GetTurnover(organ_id=leaf_organ, species_id=nitrogen_element) + fnrt_nturn = ccohort%prt%GetTurnover(organ_id=fnrt_organ, species_id=nitrogen_element) + sapw_nturn = ccohort%prt%GetTurnover(organ_id=sapw_organ, species_id=nitrogen_element) + store_nturn = ccohort%prt%GetTurnover(organ_id=store_organ, species_id=nitrogen_element) + struct_nturn = ccohort%prt%GetTurnover(organ_id=struct_organ, species_id=nitrogen_element) + + leaf_p = ccohort%prt%GetState(organ_id=leaf_organ, species_id=phosphorous_element) + fnrt_p = ccohort%prt%GetState(organ_id=fnrt_organ, species_id=phosphorous_element) + sapw_p = ccohort%prt%GetState(organ_id=sapw_organ, species_id=phosphorous_element) + store_p = ccohort%prt%GetState(organ_id=store_organ, species_id=phosphorous_element) + struct_p = ccohort%prt%GetState(organ_id=struct_organ, species_id=phosphorous_element) + repro_p = ccohort%prt%GetState(organ_id=repro_organ, species_id=phosphorous_element) + + leaf_pturn = ccohort%prt%GetTurnover(organ_id=leaf_organ, species_id=phosphorous_element) + fnrt_pturn = ccohort%prt%GetTurnover(organ_id=fnrt_organ, species_id=phosphorous_element) + sapw_pturn = ccohort%prt%GetTurnover(organ_id=sapw_organ, species_id=phosphorous_element) + store_pturn = ccohort%prt%GetTurnover(organ_id=store_organ, species_id=phosphorous_element) + struct_pturn = ccohort%prt%GetTurnover(organ_id=struct_organ, species_id=phosphorous_element) + + growth_resp = ccohort%daily_r_grow + + call carea_allom(ccohort%dbh,nplant,site_spread,ipft,crown_area) + + carbon_root_exudate = ccohort%carbon_root_exudate + nitrogen_root_exudate = ccohort%nitrogen_root_exudate + phosphorous_root_exudate = ccohort%phosphorous_root_exudate + + return + end subroutine WrapQueryDiagnostics + + + + +end module FatesCohortWrapMod diff --git a/functional_unit_testing/parteh/f_wrapper_modules/FatesPARTEHWrapMod.F90 b/functional_unit_testing/parteh/f_wrapper_modules/FatesPARTEHWrapMod.F90 new file mode 100644 index 0000000000..1b5b363377 --- /dev/null +++ b/functional_unit_testing/parteh/f_wrapper_modules/FatesPARTEHWrapMod.F90 @@ -0,0 +1,65 @@ +! ======================================================================================= +! +! This is the wrapper module that provides callable functions +! so that PARTEH fortran data structures can be intsantiated from python +! Half of the instantiation will occur by binding inherited data structures +! to cohorts, but the other half is the creation of a mapping table, +! of which we have only 1 per instance. That happens here. +! +! Note: In FATES, the equivalent routine would probably live in FatesInterfaceMod.F90 +! +! ======================================================================================= + +module FatesPARTEHWrapMod + + use PRTAllometricCarbonMod, only : InitPRTGlobalAllometricCarbon + use PRTAllometricCNPMod, only : InitPRTGlobalAllometricCNP + use FatesGlobals , only : endrun => fates_endrun + use FatesGlobals , only : fates_log + use shr_log_mod , only : errMsg => shr_log_errMsg + use iso_c_binding, only : r8 => c_double + use iso_c_binding, only : i4 => c_int + use iso_c_binding, only : c_char + + implicit none + + character(len=*), parameter, private :: sourcefile = __FILE__ + +contains + + + subroutine SPMapPyset() !prt_mode) + + + ! Update... Instantiate all of them? + +! integer(i4), intent(in) :: prt_mode + +! select case(int(prt_mode)) +! case (1) + + ! We actually initialize all hypotheses, since we are intercomparing. + + + call InitPRTGlobalAllometricCarbon() + +! case(2) + + call InitPRTGlobalAllometricCNP() + +! 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 SPMapPyset + + + + + + +end module FatesPARTEHWrapMod diff --git a/functional_unit_testing/parteh/f_wrapper_modules/FatesPFTWrapMod.F90 b/functional_unit_testing/parteh/f_wrapper_modules/FatesPFTWrapMod.F90 new file mode 100644 index 0000000000..f186be1b84 --- /dev/null +++ b/functional_unit_testing/parteh/f_wrapper_modules/FatesPFTWrapMod.F90 @@ -0,0 +1,578 @@ +! ======================================================================================= +! +! This is the wrapper module that provides FATES data structures +! +! ======================================================================================= + +module EDPftvarcon + + use iso_c_binding, only : r8 => c_double + use iso_c_binding, only : i4 => c_int + use iso_c_binding, only : c_char + + integer,parameter :: SHR_KIND_CS = 80 ! short char + + type, public :: EDPftvarcon_inst_type + + real(r8), pointer :: parteh_model(:) ! The PARTEH model to use + + real(r8), pointer :: prescribed_npp_canopy(:) ! this is only for the special + ! prescribed_physiology_mode + real(r8), pointer :: prescribed_npp_understory(:) ! this is only for the special + ! prescribed_physiology_mode + real(r8), pointer :: seed_alloc(:) + real(r8), pointer :: seed_alloc_mature(:) + real(r8), pointer :: dbh_repro_threshold(:) + real(r8), pointer :: evergreen(:) + real(r8), pointer :: season_decid(:) + real(r8), pointer :: stress_decid(:) + real(r8), pointer :: woody(:) + real(r8), pointer :: hgt_min(:) + real(r8), pointer :: allom_hmode(:) + real(r8), pointer :: allom_amode(:) + real(r8), pointer :: allom_lmode(:) + real(r8), pointer :: allom_smode(:) + real(r8), pointer :: allom_stmode(:) + real(r8), pointer :: allom_cmode(:) + real(r8), pointer :: allom_fmode(:) + real(r8), pointer :: allom_d2h1(:) + real(r8), pointer :: allom_d2h2(:) + real(r8), pointer :: allom_d2h3(:) + real(r8), pointer :: allom_dbh_maxheight(:) + real(r8), pointer :: allom_agb1(:) + real(r8), pointer :: allom_agb2(:) + real(r8), pointer :: allom_agb3(:) + real(r8), pointer :: allom_agb4(:) + real(r8), pointer :: allom_d2bl1(:) + real(r8), pointer :: allom_d2bl2(:) + real(r8), pointer :: allom_d2bl3(:) + real(r8), pointer :: wood_density(:) + real(r8), pointer :: cushion(:) + real(r8), pointer :: c2b(:) + real(r8), pointer :: vcmax25top(:) + real(r8), pointer :: allom_la_per_sa_int(:) + real(r8), pointer :: allom_la_per_sa_slp(:) + real(r8), pointer :: slatop(:) + real(r8), pointer :: slamax(:) + real(r8), pointer :: allom_l2fr(:) + real(r8), pointer :: allom_agb_frac(:) + real(r8), pointer :: allom_blca_expnt_diff(:) + real(r8), pointer :: allom_d2ca_coefficient_min(:) + real(r8), pointer :: allom_d2ca_coefficient_max(:) + real(r8), pointer :: allom_sai_scaler(:) + real(r8), pointer :: branch_turnover(:) + real(r8), pointer :: leaf_long(:) + real(r8), pointer :: root_long(:) + real(r8), pointer :: leaf_stor_priority(:) + real(r8), pointer :: roota_par(:) + real(r8), pointer :: rootb_par(:) + real(r8), pointer :: rootprof_beta(:,:) + + + + ! This array matches organ indices in the parameter file + ! with global indices in PRTGeneric. The basic global + ! indices are leaf = 1 + ! fine-root = 2 + ! sapwood = 3 + ! storage = 4 + ! reproduction = 5 + ! structural = 6 + ! But, its possible that some organs may be added in + ! the future, and then all hypotheses will not use the same + ! set, or some hypotheses will sub-divide. + + ! These arrays hold the stoichiometric parameters + ! The arrays are dimensioned by PFT X ORGAN + ! Different formulations may use these parameters differently + + ! Hypothesis 1: Unused [na] + + + real(r8), pointer :: prt_unit_gr_resp(:,:) + real(r8), pointer :: prt_nitr_stoich_p1(:,:) + real(r8), pointer :: prt_nitr_stoich_p2(:,:) + real(r8), pointer :: prt_phos_stoich_p1(:,:) + real(r8), pointer :: prt_phos_stoich_p2(:,:) + real(r8), pointer :: prt_alloc_priority(:,:) + + ! THese are new, but not necessarily PARTEH labeled + real(r8), pointer :: turnover_retrans_mode(:) + + real(r8), pointer :: turnover_carb_retrans(:,:) + real(r8), pointer :: turnover_nitr_retrans(:,:) + real(r8), pointer :: turnover_phos_retrans(:,:) + + + end type EDPftvarcon_inst_type + + type pftptr_var + real(r8), dimension(:), pointer :: rp_1d + real(r8), dimension(:,:), pointer :: rp_2d + character(len=shr_kind_cs) :: var_name + end type pftptr_var + + type EDPftvarcon_ptr_type + type(pftptr_var), allocatable :: var(:) + end type EDPftvarcon_ptr_type + + type(EDPftvarcon_inst_type), public :: EDPftvarcon_inst ! ED ecophysiological constants structure + type(EDPftvarcon_ptr_type), public :: EDPftvarcon_ptr ! Pointer structure for obj-oriented id + + integer :: numparm ! Number of different PFT parameters + integer :: num_pft ! Number of PFTs + integer :: num_organs ! Number of organs + + +contains + + + subroutine EDPftvarconPySet(ipft,i2d,rval,name) + + implicit none + ! Arguments + integer(i4),intent(in) :: ipft + integer(i4),intent(in) :: i2d ! Second dimension index + ! if this is >0, use it + character(kind=c_char,len=*), intent(in) :: name + real(r8),intent(in) :: rval + + ! Locals + logical :: npfound + integer :: ip + integer :: namelen + + namelen = len(trim(name)) + + ip=0 + npfound = .false. + do ip=1,numparm + if (trim(name) == trim(EDPftvarcon_ptr%var(ip)%var_name ) ) then + if(i2d==0) then + EDPftvarcon_ptr%var(ip)%rp_1d(ipft) = rval + else + EDPftvarcon_ptr%var(ip)%rp_2d(ipft,i2d) = rval + end if + npfound = .true. + end if + end do + + if(.not.npfound)then + print*,"Could not find parameter passed in from python driver" + print*,"registerred in the fortran wrapper" + print*,"--",trim(name),"--" + stop + end if + + ! Performa a check to see if the target array is being filled + + if (trim(name) == 'fates_wood_density' ) then + if (EDPftvarcon_inst%wood_density(ipft) .ne. rval) then + print*,"F90: POINTER CHECK FAILS:",rval," != ",EDPftvarcon_inst%wood_density(ipft) + stop + end if + end if + + return + end subroutine EDPftvarconPySet + + ! ==================================================================================== + + subroutine EDPftvarconAlloc(numpft_in, numorgans_in) + + ! !ARGUMENTS: + integer(i4), intent(in) :: numpft_in + integer(i4), intent(in) :: numorgans_in + + ! LOCALS: + integer :: iv ! The parameter incrementer + integer, parameter :: n_beta_dims = 1 + !------------------------------------------------------------------------ + + num_pft = numpft_in + num_organs = numorgans_in + + allocate( EDPftvarcon_ptr%var (100) ) ! Make this plenty large + + iv=0 + + allocate( EDPftvarcon_inst%parteh_model(1:num_pft)); + EDPftvarcon_inst%parteh_model (:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "parteh_model" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%parteh_model + + + allocate( EDPftvarcon_inst%dbh_repro_threshold(1:num_pft)); + EDPftvarcon_inst%dbh_repro_threshold (:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_dbh_repro_threshold" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%dbh_repro_threshold + + + allocate( EDPftvarcon_inst%prescribed_npp_canopy(1:num_pft)); + EDPftvarcon_inst%prescribed_npp_canopy (:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_prescribed_npp_canopy" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%prescribed_npp_canopy + + allocate( EDPftvarcon_inst%prescribed_npp_understory(1:num_pft)); + EDPftvarcon_inst%prescribed_npp_understory (:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_prescribed_npp_understory" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%prescribed_npp_understory + + allocate( EDPftvarcon_inst%seed_alloc(1:num_pft)); + EDPftvarcon_inst%seed_alloc (:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_seed_alloc" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%seed_alloc + + + allocate( EDPftvarcon_inst%seed_alloc_mature(1:num_pft)); + EDPftvarcon_inst%seed_alloc_mature(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_seed_alloc_mature" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%seed_alloc_mature + + allocate( EDPftvarcon_inst%evergreen(1:num_pft)); + EDPftvarcon_inst%evergreen (:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_phen_evergreen" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%evergreen + + allocate( EDPftvarcon_inst%season_decid(1:num_pft)); + EDPftvarcon_inst%season_decid (:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_phen_season_decid" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%season_decid + + allocate( EDPftvarcon_inst%stress_decid(1:num_pft)); + EDPftvarcon_inst%stress_decid (:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_phen_stress_decid" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%stress_decid + + + allocate( EDPftvarcon_inst%woody(1:num_pft)); + EDPftvarcon_inst%woody (:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_woody" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%woody + + allocate( EDPftvarcon_inst%hgt_min(1:num_pft)); + EDPftvarcon_inst%hgt_min (:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_recruit_hgt_min" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%hgt_min + + allocate( EDPftvarcon_inst%allom_dbh_maxheight(1:num_pft)); + EDPftvarcon_inst%allom_dbh_maxheight (:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_dbh_maxheight" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_dbh_maxheight + + allocate( EDPftvarcon_inst%allom_hmode(1:num_pft)); + EDPftvarcon_inst%allom_hmode(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_hmode" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_hmode + + allocate( EDPftvarcon_inst%allom_amode(1:num_pft)); + EDPftvarcon_inst%allom_amode(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_amode" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_amode + + allocate( EDPftvarcon_inst%allom_lmode(1:num_pft)); + EDPftvarcon_inst%allom_lmode(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_lmode" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_lmode + + allocate( EDPftvarcon_inst%allom_smode(1:num_pft)); + EDPftvarcon_inst%allom_smode(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_smode" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_smode + + allocate( EDPftvarcon_inst%allom_stmode(1:num_pft)); + EDPftvarcon_inst%allom_stmode(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_stmode" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_stmode + + allocate( EDPftvarcon_inst%allom_cmode(1:num_pft)); + EDPftvarcon_inst%allom_cmode(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_cmode" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_cmode + + allocate( EDPftvarcon_inst%allom_fmode(1:num_pft)); + EDPftvarcon_inst%allom_fmode(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_fmode" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_fmode + + allocate( EDPftvarcon_inst%allom_d2h1(1:num_pft)); + EDPftvarcon_inst%allom_d2h1(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_d2h1" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_d2h1 + + allocate( EDPftvarcon_inst%allom_d2h2(1:num_pft)); + EDPftvarcon_inst%allom_d2h2(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_d2h2" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_d2h2 + + allocate( EDPftvarcon_inst%allom_d2h3(1:num_pft)); + EDPftvarcon_inst%allom_d2h3(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_d2h3" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_d2h3 + + allocate( EDPftvarcon_inst%allom_agb1(1:num_pft)); + EDPftvarcon_inst%allom_agb1(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_agb1" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_agb1 + + allocate( EDPftvarcon_inst%allom_agb2(1:num_pft)); + EDPftvarcon_inst%allom_agb2(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_agb2" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_agb2 + + allocate( EDPftvarcon_inst%allom_agb3(1:num_pft)); + EDPftvarcon_inst%allom_agb3(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_agb3" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_agb3 + + allocate( EDPftvarcon_inst%allom_agb4(1:num_pft)); + EDPftvarcon_inst%allom_agb4(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_agb4" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_agb4 + + allocate( EDPftvarcon_inst%allom_d2bl1(1:num_pft)); + EDPftvarcon_inst%allom_d2bl1(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_d2bl1" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_d2bl1 + + allocate( EDPftvarcon_inst%allom_d2bl2(1:num_pft)); + EDPftvarcon_inst%allom_d2bl2(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_d2bl2" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_d2bl2 + + allocate( EDPftvarcon_inst%allom_d2bl3(1:num_pft)); + EDPftvarcon_inst%allom_d2bl3(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_d2bl3" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_d2bl3 + + allocate( EDPftvarcon_inst%cushion(1:num_pft)); + EDPftvarcon_inst%cushion(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_cushion" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%cushion + + allocate( EDPftvarcon_inst%wood_density(1:num_pft)); + EDPftvarcon_inst%wood_density(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_wood_density" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%wood_density + + allocate( EDPftvarcon_inst%c2b(1:num_pft)); + EDPftvarcon_inst%c2b(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_c2b" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%c2b + + allocate( EDPftvarcon_inst%vcmax25top(1:num_pft)); + EDPftvarcon_inst%vcmax25top(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_vcmax25top" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%vcmax25top + + allocate( EDPftvarcon_inst%allom_la_per_sa_int(1:num_pft)); + EDPftvarcon_inst%allom_la_per_sa_int(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_la_per_sa_int" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_la_per_sa_int + + allocate( EDPftvarcon_inst%allom_la_per_sa_slp(1:num_pft)); + EDPftvarcon_inst%allom_la_per_sa_slp(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_la_per_sa_slp" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_la_per_sa_slp + + allocate( EDPftvarcon_inst%slatop(1:num_pft)); + EDPftvarcon_inst%slatop(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_slatop" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%slatop + + allocate( EDPftvarcon_inst%slamax(1:num_pft)); + EDPftvarcon_inst%slamax(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_slamax" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%slamax + + + allocate( EDPftvarcon_inst%allom_l2fr(1:num_pft)); + EDPftvarcon_inst%allom_l2fr(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_l2fr" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_l2fr + + allocate( EDPftvarcon_inst%allom_agb_frac(1:num_pft)); + EDPftvarcon_inst%allom_agb_frac(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_agb_frac" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_agb_frac + + allocate( EDPftvarcon_inst%allom_sai_scaler(1:num_pft)); + EDPftvarcon_inst%allom_sai_scaler(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_sai_scaler" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_sai_scaler + + allocate( EDPftvarcon_inst%allom_blca_expnt_diff(1:num_pft)); + EDPftvarcon_inst%allom_blca_expnt_diff(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_blca_expnt_diff" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_blca_expnt_diff + + allocate( EDPftvarcon_inst%allom_d2ca_coefficient_min(1:num_pft)); + EDPftvarcon_inst%allom_d2ca_coefficient_min(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_d2ca_coefficient_min" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_d2ca_coefficient_min + + allocate( EDPftvarcon_inst%allom_d2ca_coefficient_max(1:num_pft)); + EDPftvarcon_inst%allom_d2ca_coefficient_max(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_allom_d2ca_coefficient_max" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%allom_d2ca_coefficient_max + + allocate( EDPftvarcon_inst%branch_turnover(1:num_pft)); + EDPftvarcon_inst%branch_turnover(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_branch_turnover" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%branch_turnover + + allocate( EDPftvarcon_inst%leaf_long(1:num_pft)); + EDPftvarcon_inst%leaf_long(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_leaf_long" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%leaf_long + + allocate( EDPftvarcon_inst%root_long(1:num_pft)); + EDPftvarcon_inst%root_long(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_root_long" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%root_long + + allocate( EDPftvarcon_inst%leaf_stor_priority(1:num_pft)); + EDPftvarcon_inst%leaf_stor_priority(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_leaf_stor_priority" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%leaf_stor_priority + + allocate( EDPftvarcon_inst%roota_par(1:num_pft)); + EDPftvarcon_inst%roota_par(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_roota_par" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%roota_par + + allocate( EDPftvarcon_inst%rootb_par(1:num_pft)); + EDPftvarcon_inst%rootb_par(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_rootb_par" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%rootb_par + + + allocate( EDPftvarcon_inst%prt_nitr_stoich_p1(1:num_pft,1:num_organs)); + EDPftvarcon_inst%prt_nitr_stoich_p1(:,:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_prt_nitr_stoich_p1" + EDPftvarcon_ptr%var(iv)%rp_2d => EDPftvarcon_inst%prt_nitr_stoich_p1 + + + allocate( EDPftvarcon_inst%prt_phos_stoich_p1(1:num_pft,1:num_organs)); + EDPftvarcon_inst%prt_phos_stoich_p1(:,:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_prt_phos_stoich_p1" + EDPftvarcon_ptr%var(iv)%rp_2d => EDPftvarcon_inst%prt_phos_stoich_p1 + + + allocate( EDPftvarcon_inst%prt_nitr_stoich_p2(1:num_pft,1:num_organs)); + EDPftvarcon_inst%prt_nitr_stoich_p2(:,:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_prt_nitr_stoich_p2" + EDPftvarcon_ptr%var(iv)%rp_2d => EDPftvarcon_inst%prt_nitr_stoich_p2 + + + allocate( EDPftvarcon_inst%prt_phos_stoich_p2(1:num_pft,1:num_organs)); + EDPftvarcon_inst%prt_phos_stoich_p2(:,:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_prt_phos_stoich_p2" + EDPftvarcon_ptr%var(iv)%rp_2d => EDPftvarcon_inst%prt_phos_stoich_p2 + + + allocate( EDPftvarcon_inst%prt_unit_gr_resp(1:num_pft,1:num_organs)); + EDPftvarcon_inst%prt_unit_gr_resp(:,:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_prt_unit_gr_resp" + EDPftvarcon_ptr%var(iv)%rp_2d => EDPftvarcon_inst%prt_unit_gr_resp + + + allocate( EDPftvarcon_inst%prt_alloc_priority(1:num_pft,1:num_organs)); + EDPftvarcon_inst%prt_alloc_priority(:,:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_prt_alloc_priority" + EDPftvarcon_ptr%var(iv)%rp_2d => EDPftvarcon_inst%prt_alloc_priority + + allocate( EDPftvarcon_inst%turnover_retrans_mode(1:num_pft) ) + EDPftvarcon_inst%turnover_retrans_mode(:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_turnover_retrans_mode" + EDPftvarcon_ptr%var(iv)%rp_1d => EDPftvarcon_inst%turnover_retrans_mode + + allocate( EDPftvarcon_inst%turnover_carb_retrans(1:num_pft,1:num_organs) ) + EDPftvarcon_inst%turnover_carb_retrans(:,:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_turnover_carb_retrans" + EDPftvarcon_ptr%var(iv)%rp_2d => EDPftvarcon_inst%turnover_carb_retrans + + allocate( EDPftvarcon_inst%turnover_nitr_retrans(1:num_pft,1:num_organs) ) + EDPftvarcon_inst%turnover_nitr_retrans(:,:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_turnover_nitr_retrans" + EDPftvarcon_ptr%var(iv)%rp_2d => EDPftvarcon_inst%turnover_nitr_retrans + + allocate( EDPftvarcon_inst%turnover_phos_retrans(1:num_pft,1:num_organs) ) + EDPftvarcon_inst%turnover_phos_retrans(:,:) = nan + iv = iv + 1 + EDPftvarcon_ptr%var(iv)%var_name = "fates_turnover_phos_retrans" + EDPftvarcon_ptr%var(iv)%rp_2d => EDPftvarcon_inst%turnover_phos_retrans + + + ! We should gracefully fail if rootprof_beta is requested + allocate( EDPftvarcon_inst%rootprof_beta(1:num_pft,n_beta_dims)); + EDPftvarcon_inst%rootprof_beta(:,:) = nan + + + numparm = iv + + print*,"F90: ALLOCATED ",numparm," PARAMETERS, FOR ",num_pft," PFTs" + + + return + end subroutine EDPftvarconAlloc + +end module EDPftvarcon diff --git a/functional_unit_testing/parteh/f_wrapper_modules/FatesWrapMod.F90 b/functional_unit_testing/parteh/f_wrapper_modules/FatesWrapMod.F90 new file mode 100644 index 0000000000..31d1d51a2d --- /dev/null +++ b/functional_unit_testing/parteh/f_wrapper_modules/FatesWrapMod.F90 @@ -0,0 +1,59 @@ +! ======================================================================================= +! +! This is the wrapper module that provides FATES data structures +! +! ======================================================================================= + +module EDTypesMod + + use iso_c_binding, only: fates_r8 => c_double + use iso_c_binding, only: fates_int => c_int + + integer(fates_int), parameter :: nlevleaf = 40 + real(fates_r8), parameter :: dinc_ed = 1.0_fates_r8 + integer(fates_int), parameter :: nclmax = 4 + +end module EDTypesMod + + +module shr_log_mod + + use iso_c_binding, only : c_char + use iso_c_binding, only : c_int + + contains + + function shr_log_errMsg(source, line) result(ans) + character(kind=c_char,len=*), intent(in) :: source + integer(c_int), intent(in) :: line + character(kind=c_char,len=128) :: ans + + ans = "source: " // trim(source) // " line: " + end function shr_log_errMsg + +end module shr_log_mod + +module FatesInterfaceMod + + use iso_c_binding, only: fates_r8 => c_double + real(fates_r8), parameter :: hlm_freq_day = 1.0_fates_r8/365.0_fates_r8 + +end module FatesInterfaceMod + + +module FatesGlobals + +contains + + integer function fates_log() + fates_log = 6 ! usually stdout + end function fates_log + + subroutine fates_endrun(msg) + + implicit none + character(len=*), intent(in) :: msg ! string to be printed + stop + end subroutine fates_endrun + +end module FatesGlobals diff --git a/functional_unit_testing/parteh/parteh_controls_defaults.xml b/functional_unit_testing/parteh/parteh_controls_defaults.xml new file mode 100644 index 0000000000..5582212aef --- /dev/null +++ b/functional_unit_testing/parteh/parteh_controls_defaults.xml @@ -0,0 +1,124 @@ + + + + + + + + + + + 0 + + + + + + + + + 86400 + 1500-01-01 + 1520-01-01 + 0.001 + + + + + + + + + AllometricCNP + + + DailyCNPFromStorageSinWaveNoMaint + + + + + + + Carbon Only, constant NPP + Carbon Only, 120% sin NPP + + + + leaf + fine root + sapwood + storage + reproductive + structural + + + + 1 , 1 + 1 , 1 + 0 , 0 + 0 , 0 + 0.2 , 0.2 + 0.2 , 0.2 + 30.0 , 30.0 + 1.0 , 1.0 + 1.5 , 1.5 + 50.0 , 50.0 + 5 , 5 + 3 , 3 + 1 , 1 + 1 , 1 + 1 , 1 + 1 , 1 + 1 , 1 + 57.6 , 57.6 + 0.74 , 0.74 + 21.6 , 21.6 + 0.0673 , 0.0673 + 0.976 , 0.976 + -999.9 , -999.9 + -999.9 , -999.9 + 0.07 , 0.07 + 1.3 , 1.3 + 0.55 , 0.55 + 2.0 , 2.0 + 0.7 , 0.7 + 2.0 , 2.0 + 1.00 , 1.00 + 0.0 , 0.0 + 0.012 , 0.012 + 0.012 , 0.012 + 1.0 , 1.0 + 0.65 , 0.65 + 0.1 , 0.1 + 0.0 , 0.0 + 0.33 , 0.33 + 0.65 , 0.65 + 300.0 , 300.0 + 1.5 , 1.5 + 1.5 , 1.5 + 0.5 , 0.5 + 50.0 , 50.0 + + 1,1 + + 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025 + -9, -9, -9, -9, -9, -9, -9, -9, -9, -9, -9, -9 + -9, -9, -9, -9, -9, -9, -9, -9, -9, -9, -9, -9 + -9, -9, -9, -9, -9, -9, -9, -9, -9, -9, -9, -9 + -9, -9, -9, -9, -9, -9, -9, -9, -9, -9, -9, -9 + -9, -9, -9, -9, -9, -9, -9, -9, -9, -9, -9, -9 + -9, -9, -9, -9, -9, -9, -9, -9, -9, -9, -9, -9 + + + + + 0.4, 0.4 + -9.9, -9.9 + -9.9, -9.9 + 0.0, 1.2 + + + + + + diff --git a/functional_unit_testing/parteh/parteh_controls_phenevents_v2.xml b/functional_unit_testing/parteh/parteh_controls_phenevents_v2.xml new file mode 100644 index 0000000000..18cf824c62 --- /dev/null +++ b/functional_unit_testing/parteh/parteh_controls_phenevents_v2.xml @@ -0,0 +1,170 @@ + + + + + + + + + + + 0 + + + + + + + + + 86400 + 1500-01-01 + 1505-01-01 + 0.001 + + + + + + + + + AllometricCNP + + + DailyCNPFromCArea + + + + + + + Carbon Only, evergreen + Carbon Only, deciduous + CNP, evergreen + CNP, deciduous + CNP, deciduous 0.5 NP + + + + leaf + fine root + sapwood + storage + reproductive + structural + + + + 1 , 1 , 2 , 2 , 2 + 1 , 0 , 1 , 0 , 0 + 0 , 1 , 0 , 1 , 1 + 0 , 0 , 0 , 0 , 0 + 0.2 , 0.2 , 0.2 , 0.2 , 0.2 + 0.2 , 0.2, 0.2, 0.2, 0.2 + 30.0 , 30.0 , 30.0, 30.0 , 30.0 + 1.0 , 1.0 , 1.0, 1.0 , 1.0 + 1.5 , 1.5 , 1.5, 1.5 , 1.5 + 50.0 , 50.0 , 50.0, 50.0 , 50.0 + 5 , 5 , 5, 5 , 5 + 3 , 3 , 3, 3 , 3 + 1 , 1 , 1, 1 , 1 + 1 , 1 , 1, 1 , 1 + 1 , 1 , 1, 1 , 1 + 1 , 1 , 1, 1 , 1 + 1 , 1 , 1, 1 , 1 + 57.6 , 57.6 , 57.6, 57.6 , 57.6 + 0.74 , 0.74 , 0.74, 0.74 , 0.74 + 21.6 , 21.6 , 21.6, 21.6 , 21.6 + 0.0673 , 0.0673 , 0.0673, 0.0673 , 0.0673 + 0.976 , 0.976 , 0.976, 0.976 , 0.976 + -999.9 , -999.9 , -999.9, -999.9 , -999.9 + -999.9 , -999.9 , -999.9, -999.9 , -999.9 + 0.07 , 0.07 , 0.07, 0.07 , 0.07 + 1.3 , 1.3 , 1.3, 1.3 , 1.3 + 0.55 , 0.55 , 0.55 , 0.55 , 0.55 + 2.0 , 2.0 , 2.0, 2.0 , 2.0 + 0.7 , 0.7 , 0.7, 0.7 , 0.7 + 2.0 , 2.0 , 2.0, 2.0 , 2.0 + 1.00 , 1.00 , 1.00 , 1.00 , 1.00 + 0.0 , 0.0 , 0.0, 0.0 , 0.0 + 0.012 , 0.012 , 0.012, 0.012 , 0.012 + 0.012 , 0.012 , 0.012, 0.012 , 0.012 + 1.0 , 1.0 , 1.0, 1.0 , 1.0 + 0.65 , 0.65 , 0.65 , 0.65 , 0.65 + 0.1 , 0.1 , 0.1, 0.1 , 0.1 + 0.0 , 0.0 , 0.0, 0.0 , 0.0 + 0.33 , 0.33 , 0.33, 0.33 , 0.33 + 0.65 , 0.65 , 0.65, 0.65 , 0.65 + 300.0 , 300.0 , 300.0, 300.0 , 300.0 + 1.5 , 1.5 ,1.5, 1.5 ,1.5 + 1.5 , 1.5 ,1.5, 1.5 ,1.5 + 0.5 , 0.5 ,0.5, 0.5 ,0.5 + 50.0 , 50.0 , 50.0 , 50.0 , 50.0 + + 1,1,1,1,1 + + 0.05,0.05,0,0,0,0, + 0.05,0.05,0,0,0,0, + 0.05,0.05,0,0,0,0, + 0.05,0.05,0,0,0,0, + 0.05,0.05,0,0,0,0 + 0,0,0,0,0,0, + 0,0,0,0,0,0, + 0.25,0,0,0,0,0, + 0.25,0,0,0,0,0, + 0.25,0,0,0,0,0 + 0,0,0,0,0,0, + 0,0,0,0,0,0, + 0.25,0,0,0,0,0, + 0.25,0,0,0,0,0, + 0.25,0,0,0,0,0 + + -9,-9,-9,-9,-9,-9, + -9,-9,-9,-9,-9,-9, + 0.05,0.05,0.05,0.05,0.05,0.05, + 0.05,0.05,0.05,0.05,0.05,0.05, + 0.05,0.05,0.05,0.05,0.05,0.05 + + -9,-9,-9,-9,-9,-9, + -9,-9,-9,-9,-9,-9, + 0.05,0.05,0.05,0.05,0.05,0.05, + 0.05,0.05,0.05,0.05,0.05,0.05, + 0.05,0.05,0.05,0.05,0.05,0.05 + -9,-9,-9,-9,-9,-9, + -9,-9,-9,-9,-9,-9, + 0.05,0.05,0.05,0.05,0.05,0.05, + 0.05,0.05,0.05,0.05,0.05,0.05, + 0.05,0.05,0.05,0.05,0.05,0.05 + -9,-9,-9,-9,-9,-9, + -9,-9,-9,-9,-9,-9, + 0.05,0.05,0.05,0.05,0.05,0.05, + 0.05,0.05,0.05,0.05,0.05,0.05, + 0.05,0.05,0.05,0.05,0.05,0.05 + + -9,-9,-9,-9,-9,-9, + -9,-9,-9,-9,-9,-9, + 1,1,2,2,0,3, + 1,1,2,2,0,3, + 1,1,2,2,0,3 + + -9,-9,-9,-9,-9,-9, + -9,-9,-9,-9,-9,-9, + 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, + 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, + 0.01, 0.01, 0.01, 0.01, 0.01, 0.01 + + + + + + 0.4, 0.4, 0.4, 0.4, 0.4 + -9.9, -9.9, 0.5, 0.5, 0.01 + -9.9, -9.9, 0.5, 0.5, 0.01 + 1.2, 1.2, 1.2, 1.2, 1.2 + + + + + + diff --git a/functional_unit_testing/parteh/parteh_controls_smoketests.xml b/functional_unit_testing/parteh/parteh_controls_smoketests.xml new file mode 100644 index 0000000000..d7675c7276 --- /dev/null +++ b/functional_unit_testing/parteh/parteh_controls_smoketests.xml @@ -0,0 +1,169 @@ + + + + + + + + + + + 0 + + + + + + + + + 86400 + 1500-01-01 + 1600-01-01 + 0.001 + + + + + + + + + AllometricCNP + + + DailyCNPFromCArea + + + + + + + Carbon Only + CNP, 10x nutrient + CNP, 0 nutrient, p1=p2=0 + CNP, 0.5 equiv N + CNP, 0.5 equiv P + + + + leaf + fine root + sapwood + storage + reproductive + structural + + + + 1 , 2 , 2 , 2 , 2 + 1 , 1 , 1 , 1 , 1 + 0 , 0 , 0 , 0 , 0 + 0 , 0 , 0 , 0 , 0 + 0.2 , 0.2 , 0.2 , 0.2 , 0.2 + 0.2 , 0.2, 0.2, 0.2, 0.2 + 30.0 , 30.0 , 30.0, 30.0 , 30.0 + 1.0 , 1.0 , 1.0, 1.0 , 1.0 + 1.5 , 1.5 , 1.5, 1.5 , 1.5 + 50.0 , 50.0 , 50.0, 50.0 , 50.0 + 5 , 5 , 5, 5 , 5 + 3 , 3 , 3, 3 , 3 + 1 , 1 , 1, 1 , 1 + 1 , 1 , 1, 1 , 1 + 1 , 1 , 1, 1 , 1 + 1 , 1 , 1, 1 , 1 + 1 , 1 , 1, 1 , 1 + 57.6 , 57.6 , 57.6, 57.6 , 57.6 + 0.74 , 0.74 , 0.74, 0.74 , 0.74 + 21.6 , 21.6 , 21.6, 21.6 , 21.6 + 0.0673 , 0.0673 , 0.0673, 0.0673 , 0.0673 + 0.976 , 0.976 , 0.976, 0.976 , 0.976 + -999.9 , -999.9 , -999.9, -999.9 , -999.9 + -999.9 , -999.9 , -999.9, -999.9 , -999.9 + 0.07 , 0.07 , 0.07, 0.07 , 0.07 + 1.3 , 1.3 , 1.3, 1.3 , 1.3 + 0.55 , 0.55 , 0.55 , 0.55 , 0.55 + 2.0 , 2.0 , 2.0, 2.0 , 2.0 + 0.7 , 0.7 , 0.7, 0.7 , 0.7 + 2.0 , 2.0 , 2.0, 2.0 , 2.0 + 1.00 , 1.00 , 1.00 , 1.00 , 1.00 + 0.0 , 0.0 , 0.0, 0.0 , 0.0 + 0.012 , 0.012 , 0.012, 0.012 , 0.012 + 0.012 , 0.012 , 0.012, 0.012 , 0.012 + 1.0 , 1.0 , 1.0, 1.0 , 1.0 + 0.65 , 0.65 , 0.65 , 0.65 , 0.65 + 0.1 , 0.1 , 0.1, 0.1 , 0.1 + 0.0 , 0.0 , 0.0, 0.0 , 0.0 + 0.33 , 0.33 , 0.33, 0.33 , 0.33 + 0.65 , 0.65 , 0.65, 0.65 , 0.65 + 300.0 , 300.0 , 300.0, 300.0 , 300.0 + 1.5 , 1.5 ,1.5, 1.5 ,1.5 + 1.5 , 1.5 ,1.5, 1.5 ,1.5 + 0.5 , 0.5 ,0.5, 0.5 ,0.5 + 50.0 , 50.0 , 50.0 , 50.0 , 50.0 + + 1,1,1,1,1 + + 0,0,0,0,0,0, + 0,0,0,0,0,0, + 0.05,0.05,0,0,0,0, + 0.05,0.05,0,0,0,0, + 0.05,0.05,0,0,0,0 + 0,0,0,0,0,0, + 0,0,0,0,0,0, + 0.25,0.15,0,0,0,0, + 0.25,0,0,0,0,0, + 0.25,0,0,0,0,0 + 0,0,0,0,0,0, + 0,0,0,0,0,0, + 0.25,0.15,0,0,0,0, + 0.25,0,0,0,0,0, + 0.25,0,0,0,0,0 + + -9,-9,-9,-9,-9,-9, + 0.05,0.05,0.05,0.05,0.05,0.05, + 0,0,0,0,0,0, + 0.05,0.05,0.05,0.05,0.05,0.05, + 0.05,0.05,0.05,0.05,0.05,0.05 + + -9,-9,-9,-9,-9,-9, + 0.05,0.05,0.05,0.05,0.05,0.05, + 0,0,0,0,0,0, + 0.05,0.05,0.05,0.05,0.05,0.05, + 0.05,0.05,0.05,0.05,0.05,0.05 + -9,-9,-9,-9,-9,-9, + 0.05,0.05,0.05,0.05,0.05,0.05, + 0,0,0,0,0,0, + 0.05,0.05,0.05,0.05,0.05,0.05, + 0.05,0.05,0.05,0.05,0.05,0.05 + -9,-9,-9,-9,-9,-9, + 0.05,0.05,0.05,0.05,0.05,0.05, + 0,0,0,0,0,0, + 0.05,0.05,0.05,0.05,0.05,0.05, + 0.05,0.05,0.05,0.05,0.05,0.05 + + -9,-9,-9,-9,-9,-9, + 1,1,2,2,0,3, + 1,1,2,2,0,3, + 1,1,2,2,0,3, + 1,1,2,2,0,3 + + -9,-9,-9,-9,-9,-9, + 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, + 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, + 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, + 0.01, 0.01, 0.01, 0.01, 0.01, 0.01 + + + + + + 0.4, 0.4, 0.4, 0.4, 0.4 + -9.9, 40.0, 0.0, 0.01, 40.0 + -9.9, 40.0, 0.0, 40.0, 0.01 + + + + + + diff --git a/functional_unit_testing/parteh/parteh_controls_variable_netc.xml b/functional_unit_testing/parteh/parteh_controls_variable_netc.xml new file mode 100644 index 0000000000..47be70426d --- /dev/null +++ b/functional_unit_testing/parteh/parteh_controls_variable_netc.xml @@ -0,0 +1,135 @@ + + + + + + + + + + + 0 + + + + + + + + + 86400 + 1500-01-01 + 1520-01-01 + 0.001 + + + + + + + + + AllometricCNP + + + DailyCNPFromStorageSinWaveNoMaint + + + + + + + Carbon Only + CNP w/ p1=p2=0 + CNP w/ p1=p2=0, 120% sin NPP + + + + leaf + fine root + sapwood + storage + reproductive + structural + + + + 1 , 2 , 2 + 1 , 1, 1 + 0.2 , 0.2, 0.2 + 0.2 , 0.2 , 0.2 + 30.0 , 30.0 , 30.0 + 1.0 , 1.0, 1.0 + 1.5 , 1.5 , 1.5 + 50.0 , 50.0 , 50.0 + 5 , 5 , 5 + 3 , 3 , 3 + 1 , 1 , 1 + 1 , 1 , 1 + 1 , 1 , 1 + 1 , 1 , 1 + 1 , 1 , 1 + 57.6 , 57.6 , 57.6 + 0.74 , 0.74 , 0.74 + 21.6 , 21.6 , 21.6 + 0.0673 , 0.0673 , 0.0673 + 0.976 , 0.976 , 0.976 + -999.9 , -999.9 , -999.9 + -999.9 , -999.9, -999.9 + 0.07 , 0.07 , 0.07 + 1.3 , 1.3 , 1.3 + 0.55 , 0.55 , 0.55 + 2.0 , 2.0 , 2.0 + 0.7 , 0.7 , 0.7 + 2.0 , 2.0 , 2.0 + 1.00 , 1.00 , 1.00 + 0.0 , 0.0 , 0.0 + 0.012 , 0.012 , 0.012 + 0.012 , 0.012 , 0.012 + 1.0 , 1.0 , 1.0 + 0.65 , 0.65 , 0.65 + 0.1 , 0.1 , 0.1 + 0.0 , 0.0 , 0.0 + 0.33 , 0.33 , 0.33 + 0.65 , 0.65 , 0.65 + 300.0 , 300.0 , 300.0 + 1.5 , 1.5 , 1.5 + 1.5 , 1.5 , 1.5 + 0.5 , 0.5 , 0.5 + 50.0 , 50.0 , 50.0 + + 1,1,1 + 0.05,0,0,0,0,0, + 0.05,0,0,0,0,0, + 0.05,0,0,0,0,0 + -9,0,0,0,0,0, + 0.25,0,0,0,0,0, + 0.25,0,0,0,0,0 + -9,0,0,0,0,0, + 0.25,0,0,0,0,0, + 0.25,0,0,0,0,0 + + 0,0,0,0,0,0,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05 + 0,0,0,0,0,0,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05 + + 0,0,0,0,0,0,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05 + 0,0,0,0,0,0,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05,0.05 + + 1,1,2,2,0,3,1,1,2,2,0,3,1,1,2,2,0,3 + + 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01, 0.01 + + + + + + 0.4, 0.4, 0.4 + -9.9, 40.0, 40.0 + -9.9, 40.0, 40.0 + 1.2, 1.2, 0.0 + + + + + + diff --git a/functional_unit_testing/parteh/py_modules/PartehInterpretParameters.py b/functional_unit_testing/parteh/py_modules/PartehInterpretParameters.py new file mode 100644 index 0000000000..ce9dc0d7ce --- /dev/null +++ b/functional_unit_testing/parteh/py_modules/PartehInterpretParameters.py @@ -0,0 +1,153 @@ +import numpy as np +import os +import sys +import getopt +import code # For development: code.interact(local=locals()) +import time +import imp +PartehTypes = imp.load_source('PartehTypes', 'py_modules/PartehTypes.py') + + +# ======================================================================================== +# Interpret the XML file + +def load_xml(xmlfile, time_control, parameters ): + + import xml.etree.ElementTree as et + + + xmlroot = et.parse(xmlfile).getroot() + print("\nOpenend: "+xmlfile) + + + + # Time control + # ----------------------------------------------------------------------------------- + + elem = xmlroot.find('time_control') + date_start_str = elem.find('date_start').text + date_stop_str = elem.find('date_stop').text + timestep_str = elem.find('timestep_sec').text + max_trunc_err_str = elem.find('max_trunc_error').text + time_control.InitializeTime(date_start_str,date_stop_str,timestep_str,max_trunc_err_str) + + # PARTEH model parameters + + # Read in the hypothesis we are testing + + hypotheses = ('AllometricCarbon','AllometricCNP') + + hypothesis_root = xmlroot.find('hypothesis') + parameters.hypothesis = hypothesis_root.text.strip() + + try: + parameters.prt_model = hypotheses.index(parameters.hypothesis) + 1 + except ValueError: + print('Attempted to identify PARTEH model type: {}'.format(parameters.hypothesis)) + print('Not in the list: {}'.format(hypotheses)) + exit(1) + + boundary_c_check = {} + boundary_c_check['AllometricCarbon']=['DailyCFromCArea'] + boundary_c_check['AllometricCNP']=['DailyCNPFromCArea','DailyCNPFromStorageSinWaveNoMaint'] + + boundary_root = xmlroot.find('boundary_formulation') + parameters.boundary_method = boundary_root.text.strip() + + if ( not any(x in parameters.boundary_method for x in boundary_c_check[parameters.hypothesis]) ): + print("A boundary condition formulation was not associated\n") + print(" with your hypothesis in the XML. Exiting.") + print("hypothesis: {}".format(parameters.hypothesis)) + print("boundary formulation: {}".format(parameters.boundary_method)) + exit(2) + + parameters_root = xmlroot.find('parameters') + + + # PFT parameters for PARTEH Internals + # ----------------------------------------------------------------------------------- + + pft_names_root = parameters_root.find('pft_names') + for pft_idx, pft_elem in enumerate(pft_names_root.iter('pft_par')): + + pft_name = pft_elem.text.strip() + + # Intialize the pft's dictionary of parameters + parameters.parteh_pfts.append(PartehTypes.pft_type(pft_name)) + + # Initialize the pft's parameters for the boundary conditions + parameters.boundary_pfts.append(PartehTypes.pft_type(pft_name)) + + parameters.num_pfts = len(parameters.parteh_pfts) + + + # Simply generate a list of organ names as strings + organ_names_root = parameters_root.find('organ_names') + for organ_idx, organ_elem in enumerate(organ_names_root.iter('organ_par')): + organ_name = organ_elem.text.strip() + parameters.parteh_organs.append(organ_name) + + parameters.num_organs = len(parameters.parteh_organs) + + # Load up all pft parameters that are specific to the PARTEH hypothesis + # ----------------------------------------------------------------------------------- + + for ptype_idx, ptype_elem in enumerate(parameters_root.iter('parteh_parameters')): + + for par_idx, par_elem in enumerate(ptype_elem.iter('pft_par')): + + pft_param_name = par_elem.attrib['name'].strip() + pft_param_val = par_elem.text.strip() + pft_vector = [float(i) for i in pft_param_val.split(',')] + if (len(pft_vector) != parameters.num_pfts): + print('parameter was given no value?') + print('{} is: {}'.format(pft_param_name,pft_param_val)) + print('exiting') + exit(1) + + for idx, value in enumerate(pft_vector): + # Note that dictionary entries are always lists + parameters.parteh_pfts[idx].param_dic[pft_param_name] = [value] + + for par_idx, par_elem in enumerate(ptype_elem.iter('pft_organ_par')): + + param_name = par_elem.attrib['name'].strip() + param_val = par_elem.text.strip() + param_vector = [float(i) for i in param_val.split(',')] + if (len(param_vector) != parameters.num_pfts*parameters.num_organs ): + print('parameter was given incorrect number of values?') + print('Expected size: {}, Total elements: {}'.format(parameters.num_pfts*parameters.num_organs,len(param_vector))) + print('{} is: {}'.format(param_name,param_val)) + print('exiting') + exit(1) + + for idx in range(parameters.num_pfts): + idl = idx*parameters.num_organs + idh = idl + parameters.num_organs + parameters.parteh_pfts[idx].param_dic[param_name] = param_vector[idl:idh] + + + # Load up all the pft parameters that are specific to the Boundary Condition method + # Must add a check to see if all correct parameters are loaded + # ----------------------------------------------------------------------------------- + + for ptype_idx, ptype_elem in enumerate(parameters_root.iter('boundary_parameters')): + + for par_idx, par_elem in enumerate(ptype_elem.iter('pft_par')): + + pft_param_name = par_elem.attrib['name'].strip() + pft_param_val = par_elem.text.strip() + pft_vector = [float(i) for i in pft_param_val.split(',')] + if (len(pft_vector) != parameters.num_pfts): + print('parameter was given no value?') + print('{} is: {}'.format(pft_param_name,pft_param_val)) + print('exiting') + exit(1) + + for idx,value in enumerate(pft_vector): + parameters.boundary_pfts[idx].param_dic[pft_param_name] = value + + + + print("\n\n Completed Interpreting: "+xmlfile) + print("\n Found {} PFT(s)".format(parameters.num_pfts)) diff --git a/functional_unit_testing/parteh/py_modules/PartehTypes.py b/functional_unit_testing/parteh/py_modules/PartehTypes.py new file mode 100644 index 0000000000..1be558385a --- /dev/null +++ b/functional_unit_testing/parteh/py_modules/PartehTypes.py @@ -0,0 +1,184 @@ +import numpy as np +import os +import sys +import getopt +import code # For development: code.interact(local=locals()) +import time + + +# ======================================================================================= +# +# Global Parameters +# +# ======================================================================================= + + +os.environ['TZ'] = 'UTC' +time.tzset() + +time_precision = 1.0e-10 # Acceptable time error for the + # adaptive time-stepper + +class param_type: + + def __init__(self): + + # Initialize the list of parameters + + self.hypothesis = "" + + self.boundary_method = "" + + # These are passed to the PARTEH Fortran code + # This is a list + self.parteh_pfts = [] + + # This is a list of the organ names + # These names must be consistent + # with the indices provided in the parameter file + # and that those indices should match the global + # indices in PRTGenericMod.F90 + self.parteh_organs = [] + + # These are used in the boundary conditions + self.boundary_pfts = [] + + # Save the number of pfts (as a convencience) + self.numpfts = -9 + + # Add other parameter groups as we go + +class pft_type: + + def __init__(self,pft_name): + + # Initialize a dictionary of parameters for any pft + self.name = pft_name + self.param_dic = {} + + +class diagnostics_type: + + def __init__(self): + + self.dates = [] + self.dbh = [] + self.dailyc = [] + self.leaf_c = [] + self.fnrt_c = [] + self.sapw_c = [] + self.store_c = [] + self.struct_c = [] + self.repro_c = [] + self.leaf_cturn = [] + self.fnrt_cturn = [] + self.sapw_cturn = [] + self.store_cturn = [] + self.struct_cturn = [] + + self.leaf_n = [] + self.fnrt_n = [] + self.sapw_n = [] + self.store_n = [] + self.struct_n = [] + self.repro_n = [] + self.leaf_nturn = [] + self.fnrt_nturn = [] + self.sapw_nturn = [] + self.store_nturn = [] + self.struct_nturn = [] + + self.leaf_p = [] + self.fnrt_p = [] + self.sapw_p = [] + self.store_p = [] + self.struct_p = [] + self.repro_p = [] + self.leaf_pturn = [] + self.fnrt_pturn = [] + self.sapw_pturn = [] + self.store_pturn = [] + self.struct_pturn = [] + + self.crown_area = [] + self.root_c_exudate = [] + self.root_n_exudate = [] + self.root_p_exudate = [] + self.growth_resp = [] + + +## Define the state variables and state terms types + +class timetype: + + def __init__(self): + + self.datetime_start = np.datetime64("1600-01-01") + self.datetime_stop = np.datetime64("1400-01-01") + self.datetime = np.datetime64("1300-01-01") + self.dt_fullstep = np.timedelta64(int(86400),'s') + self.sim_complete = False + self.max_err = -9.9 + self.id_substep = -9 + self.dt_substep = np.timedelta64(int(3600),'s') + self.dt_optsubstep = np.timedelta64(int(3600),'s') + + + def InitializeTime(self,date_start_str,date_stop_str,timestep_str,max_trunc_err_str): + + # Perform checks here as well + date_start_str = date_start_str.strip() + date_stop_str = date_stop_str.strip() + timestep_str = timestep_str.strip() + max_trunc_err_str = max_trunc_err_str.strip() + + # Timing for the main time loop + # ------------------------------------------------------------------------------- + self.datetime_start = np.datetime64(date_start_str) + self.datetime_stop = np.datetime64(date_stop_str) + self.datetime = self.datetime_start + self.dt_fullstep = float(timestep_str) + self.sim_complete = False + + # Maximum allowable truncation error on iterator + self.max_err = float(max_trunc_err_str) + + + # Timing for the integrator + # ------------------------------------------------------------------------------- + self.id_substep = 0 + self.dt_substep = self.dt_fullstep + self.dt_optsubstep = self.dt_fullstep + + def ResetTime(self): + + self.datetime = self.datetime_start + self.id_substep = 0 + self.dt_substep = self.dt_fullstep + self.dt_optsubstep = self.dt_fullstep + self.sim_complete = False + + def UpdateTime(self): + + self.datetime += np.timedelta64(int(self.dt_fullstep),'s') + if(self.datetime >= self.datetime_stop): + self.sim_complete = True + + def CheckFullStepTime(self,targettime): + if(np.abs(self.datetime-targettime)>time_precision): + print('The adaptive time-stepper finished') + print(' on a time-stamp that does not match') + print(' the projected timestep') + print(' projected: {}'.format(targettime)) + print(' actual: {}'.format(self.datetime)) + print(' exiting') + exit(2) + else: + self.datetime = targettime + + + + def UpdatePartialTime(self,dt_seconds): + self.datetime += np.timedelta64(int(dt_seconds),'s') + + diff --git a/functional_unit_testing/parteh/py_modules/SyntheticBoundaries.py b/functional_unit_testing/parteh/py_modules/SyntheticBoundaries.py new file mode 100644 index 0000000000..27f6ed5edc --- /dev/null +++ b/functional_unit_testing/parteh/py_modules/SyntheticBoundaries.py @@ -0,0 +1,175 @@ +import numpy as np +import os +import sys +import getopt +import code # For development: code.interact(local=locals()) +import time + +day_per_year = 365.0 + +class pft_bc_type: + + def __init__(self): + + # Initialize a dictionary of parameters for any pft + self.pft_bc_dic = {} + + +def DailyCFromUnitGPPAR(leaf_area,AGB): + + # ----------------------------------------------------------------------------------- + # This routine estimates Net Daily Carbon Gains (GPP-AR) by estimating + # a mean canopy GPP per leaf area per year, and by estimating + # a mean autotrophic respiration per kilogram per year, both from literature. + # Thus to scale to a plant, the plant's leaf area and total biomass are needed. + # + # THese numbers are taken from Chambers et al. 2004 + # from ZF2 Manaus Brazil + # ----------------------------------------------------------------------------------- + + kg_per_Mg = 1000.0 + m2_per_ha = 10000.0 + + site_AGB = 151.35 # MgC/ha + site_NPP = 9.0 # MgC/ha/yr + site_AR = 21.0 # MgC/ha/yr + site_LAI = 4.7 # m2/m2 + + #site_Rleaf = 9.8 # MgC/ha/yr + #site_Rwood = 4.2 # MgC/ha/yr + #site_Rroot = 5.5 # MgC/ha/yr + + + GPP_per_larea_yr = kg_per_Mg * (site_NPP + site_AR) / \ + site_LAI / m2_per_ha + AR_per_kg_yr = kg_per_Mg * site_AR / site_AGB / \ + m2_per_ha + + GPP = 100.8*GPP_per_larea_yr * leaf_area / day_per_year + AR = AR_per_kg_yr * AGB / day_per_year + + NetDailyC = GPP - AR + + return NetDailyC + + +def DailyCFromCArea(presc_npp_p1,c_area,phen_type,leaf_status): + + # ----------------------------------------------------------------------------------- + # This method was provided by Charlie Koven via is inferences from the PPA + # literature. Here, net daily carbon [kg] is based on one of two excluding + # parmaters (NPP per crown area per year), for plants that are either in + # the upper canopy (access to sunlight) or in the understory (low sunlight) + # + # c_area, footprint of the crown area [m2]. + # presc_npp_p1, npp generated per crown area [kgC/m2/yr] + # ----------------------------------------------------------------------------------- + + if( (phen_type == 1) or (leaf_status ==2)): + NetDailyC = presc_npp_p1 * c_area / day_per_year + else: + NetDailyC = 0.0 + + return NetDailyC + + +def DailyCNPFromCArea(presc_npp_p1,presc_nflux_p1, \ + presc_pflux_p1,c_area,phen_type,leaf_status): + + # ----------------------------------------------------------------------------------- + # This method was provided by Charlie Koven via is inferences from the PPA + # literature. Here, net daily carbon [kg] is based on one of two excluding + # parmaters (NPP per crown area per year), for plants that are either in + # the upper canopy (access to sunlight) or in the understory (low sunlight) + # + # c_area, footprint of the crown area [m2]. + # presc_npp_canopy, npp generated per crown area in canopy [kgC/m2/yr] + # presc_npp_understory, npp generated per crown area in understory [kgC/m2/yr] + # presc_nflux_p1, Nitrogen flux per crown area [kgN/m2/yr] + # presc_pflux_p1, Phosphorous flux per crown area [kgP/m2/yr] + # ----------------------------------------------------------------------------------- + + if( (phen_type == 1) or (leaf_status ==2)): + NetDailyC = presc_npp_p1 * c_area / day_per_year + NetDailyN = presc_nflux_p1 * c_area / day_per_year + NetDailyP = presc_pflux_p1 * c_area / day_per_year + else: + NetDailyC = 0.0 + NetDailyN = 0.0 + NetDailyP = 0.0 + + return NetDailyC, NetDailyN, NetDailyP + + +def DailyCNPFromStorageSinWave(doy,store_c,presc_npp_p1, \ + presc_nflux_p1,presc_pflux_p1,c_area,presc_npp_amp, \ + phen_type, leaf_status): + + + # This method is supposed to simulate a seasonal cycle of NPP + # In some cases we pass negative daily carbon gain to the allocation model + # however, we have to be careful to not make negative gains larger + # than available storage in those cases. This is not necessarily the most + # realistic model, but its important to test that the parteh algorithms can handle + # these stressfull negative gain conditions. + + doy0=0.0 + + sin_func = np.sin( (doy-doy0)/366.0 * 2.0 * np.pi ) + + #if (sin_func>0.0): + # NetDailyC = sin_func * presc_npp_p1 * c_area / day_per_year + #else: + # NetDailyC = -np.minimum( -neg_store_frac * sin_func * presc_npp_p1* c_area / day_per_year, 0.98* np.float(store_c)) + + NetDailyC = (presc_npp_amp * sin_func * presc_npp_p1 + presc_npp_p1) * c_area/day_per_year + + # This is a fail-safe, for large negatives, cant be larger than storage + + if (NetDailyC < 0.0): + NetDailyC = -np.minimum(-NetDailyC,0.98* np.float(store_c)) + + #print("sin_func: {}, NetDailyC: {}, store_c: {}, c_area :{}".format(sin_func,NetDailyC,store_c,c_area)) + + if( (phen_type == 1) or (leaf_status ==2)): + NetDailyN = presc_nflux_p1 * c_area / day_per_year + NetDailyP = presc_pflux_p1 * c_area / day_per_year + else: + NetDailyN = 0.0 + NetDailyP = 0.0 + NetDailyC = 0.0 + + return NetDailyC, NetDailyN, NetDailyP + + +def DeciduousPhenology(doy, target_leaf_c, store_c, phen_type): + + # Time leaf-on with rising NPP + leaf_on_doy = np.int(366.0 * 0.01) + + leaf_off_doy = np.int(366.0 * 0.55) + + if ( doy==leaf_on_doy): + flush_c = np.minimum(store_c,target_leaf_c * 0.5) + else: + flush_c = 0.0 + + if ( doy==leaf_off_doy): + drop_frac_c = 1.0 + else: + drop_frac_c = 0.0 + + if(doy>=leaf_on_doy and doy shr_kind_r8 - use shr_const_mod, only: SHR_CONST_CDAY - use EDtypesMod , only : ed_site_type,ed_patch_type,ed_cohort_type - use EDTypesMod , only : AREA + use shr_kind_mod, only : r8 => shr_kind_r8 + use shr_const_mod, only : SHR_CONST_CDAY + use EDtypesMod, only : ed_site_type,ed_patch_type,ed_cohort_type + use EDTypesMod, only : AREA + use FatesConstantsMod, only : g_per_kg + use PRTGenericMod, only : all_carbon_elements + 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 implicit none @@ -78,11 +86,13 @@ subroutine SummarizeNetFluxes( nsites, sites, bc_in, is_beg_day ) ! map biomass pools to column level sites(s)%biomass_stock = sites(s)%biomass_stock + & - (currentCohort%bdead + & - currentCohort%bsw + & - currentCohort%bl + & - currentCohort%br + & - currentCohort%bstore) * n_perm2 * 1.e3_r8 + ( currentCohort%prt%GetState(struct_organ,all_carbon_elements) + & + currentCohort%prt%GetState(sapw_organ,all_carbon_elements) + & + currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + & + currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) + & + currentCohort%prt%GetState(store_organ,all_carbon_elements) + & + currentCohort%prt%GetState(repro_organ,all_carbon_elements) ) & + * n_perm2 * g_per_kg currentCohort => currentCohort%shorter enddo !currentCohort @@ -268,11 +278,13 @@ subroutine SiteCarbonStock(currentSite,total_stock,biomass_stock,litter_stock,se currentCohort => currentPatch%tallest do while(associated(currentCohort)) biomass_stock = biomass_stock + & - (currentCohort%bdead + & - currentCohort%bsw + & - currentCohort%br + & - currentCohort%bl + & - currentCohort%bstore) * currentCohort%n + (currentCohort%prt%GetState(struct_organ,all_carbon_elements) + & + currentCohort%prt%GetState(sapw_organ,all_carbon_elements) + & + currentCohort%prt%GetState(leaf_organ,all_carbon_elements) + & + currentCohort%prt%GetState(fnrt_organ,all_carbon_elements) + & + currentCohort%prt%GetState(store_organ,all_carbon_elements) + & + currentCohort%prt%GetState(repro_organ,all_carbon_elements) ) & + * currentCohort%n currentCohort => currentCohort%shorter enddo !end cohort loop currentPatch => currentPatch%younger diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 7b2d68b6d6..696ba70a72 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -19,7 +19,8 @@ module EDInitMod use EDTypesMod , only : nuMWaterMem use EDTypesMod , only : maxpft use EDTypesMod , only : AREA - use EDTypesMod , only : init_dense_forest + use EDTypesMod , only : init_spread_near_bare_ground + use EDTypesMod , only : init_spread_inventory use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : hlm_use_planthydro use FatesInterfaceMod , only : hlm_use_inventory_init @@ -73,6 +74,7 @@ subroutine init_site_vars( site_in ) allocate(site_in%demotion_rate(1:nlevsclass)) allocate(site_in%promotion_rate(1:nlevsclass)) allocate(site_in%imort_rate(1:nlevsclass,1:numpft)) + allocate(site_in%growthflux_fusion(1:nlevsclass,1:numpft)) ! end subroutine init_site_vars @@ -127,6 +129,9 @@ subroutine zero_site( site_in ) site_in%imort_rate(:,:) = 0._r8 site_in%imort_carbonflux = 0._r8 + ! fusoin-induced growth flux of individuals + site_in%growthflux_fusion(:,:) = 0._r8 + ! demotion/promotion info site_in%demotion_rate(:) = 0._r8 site_in%demotion_carbonflux = 0._r8 @@ -221,8 +226,6 @@ subroutine set_site_properties( nsites, sites) sites(s)%frac_burnt = 0.0_r8 sites(s)%old_stock = 0.0_r8 - sites(s)%spread = 1.0_r8 - if(init_dense_forest)sites(s)%spread = 0._r8 end do return @@ -280,6 +283,13 @@ subroutine init_patches( nsites, sites, bc_in) 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) do s = 1, nsites @@ -294,6 +304,11 @@ subroutine init_patches( nsites, sites, bc_in) !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 @@ -356,7 +371,10 @@ subroutine init_cohorts( site_in, patch_in, bc_in) real(r8) :: b_leaf ! biomass in leaves [kgC] real(r8) :: b_fineroot ! biomass in fine roots [kgC] real(r8) :: b_sapwood ! biomass in sapwood [kgC] + real(r8) :: b_dead ! biomass in structure (dead) [kgC] + real(r8) :: b_store ! biomass in storage [kgC] real(r8) :: a_sapwood ! area in sapwood (dummy) [m2] + integer, parameter :: rstatus = 0 !---------------------------------------------------------------------- @@ -396,9 +414,9 @@ subroutine init_cohorts( site_in, patch_in, bc_in) ! Calculate sapwood biomass call bsap_allom(temp_cohort%dbh,pft,temp_cohort%canopy_trim,a_sapwood,b_sapwood) - call bdead_allom( b_agw, b_bgw, b_sapwood, pft, temp_cohort%bdead ) + call bdead_allom( b_agw, b_bgw, b_sapwood, pft, b_dead ) - call bstore_allom(temp_cohort%dbh, pft, temp_cohort%canopy_trim,temp_cohort%bstore) + call bstore_allom(temp_cohort%dbh, pft, temp_cohort%canopy_trim, b_store) if( EDPftvarcon_inst%evergreen(pft) == 1) then @@ -428,7 +446,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) if ( debug ) write(fates_log(),*) 'EDInitMod.F90 call create_cohort ' call create_cohort(site_in, patch_in, pft, temp_cohort%n, temp_cohort%hite, temp_cohort%dbh, & - b_leaf, b_fineroot, b_sapwood, temp_cohort%bdead, temp_cohort%bstore, & + b_leaf, b_fineroot, b_sapwood, b_dead, b_store, & temp_cohort%laimemory, cstatus, rstatus, temp_cohort%canopy_trim, 1, site_in%spread, bc_in) @@ -438,6 +456,13 @@ subroutine init_cohorts( site_in, patch_in, bc_in) 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 + call fuse_cohorts(site_in, patch_in,bc_in) call sort_cohorts(patch_in) diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index dc42e9728b..aca5a3df14 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -15,6 +15,7 @@ module EDMainMod use FatesInterfaceMod , only : hlm_current_day use FatesInterfaceMod , only : hlm_use_planthydro use FatesInterfaceMod , only : hlm_reference_date + use FatesInterfaceMod , only : hlm_use_ed_prescribed_phys use FatesInterfaceMod , only : hlm_use_ed_st3 use FatesInterfaceMod , only : bc_in_type use FatesInterfaceMod , only : hlm_masterproc @@ -27,11 +28,11 @@ module EDMainMod use EDPatchDynamicsMod , only : fuse_patches use EDPatchDynamicsMod , only : spawn_patches use EDPatchDynamicsMod , only : terminate_patches - use EDPhysiologyMod , only : PlantGrowth use EDPhysiologyMod , only : non_canopy_derivs use EDPhysiologyMod , only : phenology use EDPhysiologyMod , only : recruitment use EDPhysiologyMod , only : trim_canopy + use EDPhysiologyMod , only : ZeroAllocationRates use SFMainMod , only : fire_model use FatesSizeAgeTypeIndicesMod, only : get_age_class_index use EDtypesMod , only : ncwd @@ -52,6 +53,21 @@ module EDMainMod use FatesGlobals , only : endrun => fates_endrun use ChecksBalancesMod , only : SiteCarbonStock use EDMortalityFunctionsMod , only : Mortality_Derivative + + use PRTGenericMod, only : carbon12_element + use PRTGenericMod, only : all_carbon_elements + 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 PRTLossFluxesMod, only : PRTMaintTurnover + use PRTLossFluxesMod, only : PRTReproRelease + + use EDPftvarcon, only : EDPftvarcon_inst + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) @@ -98,6 +114,9 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) 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 + currentSite%flux_in = 0.0_r8 + + ! 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) @@ -108,6 +127,10 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) !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 + + ! Zero turnover rates and growth diagnostics + call ZeroAllocationRates(currentSite) + call ed_total_balance_check(currentSite, 0) @@ -239,6 +262,9 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) integer :: ft ! Counter for PFT real(r8) :: small_no ! to circumvent numerical errors that cause negative values of things that can't be negative real(r8) :: cohort_biomass_store ! remembers the biomass in the cohort for balance checking + real(r8) :: dbh_old ! dbh of plant before daily PRT [cm] + real(r8) :: hite_old ! height of plant before daily PRT [m] + !----------------------------------------------------------------------- small_no = 0.0000000000_r8 ! Obviously, this is arbitrary. RF - changed to zero @@ -246,6 +272,8 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) currentSite%dseed_dt(:) = 0._r8 currentSite%seed_rain_flux(:) = 0._r8 + + currentPatch => currentSite%youngest_patch do while(associated(currentPatch)) @@ -265,12 +293,69 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) do while(associated(currentCohort)) + ft = currentCohort%pft + ! Calculate the mortality derivatives call Mortality_Derivative( currentSite, currentCohort, bc_in ) + ! ----------------------------------------------------------------------------- + ! Apply Plant Allocation and Reactive Transport + ! ----------------------------------------------------------------------------- + + hite_old = currentCohort%hite + dbh_old = currentCohort%dbh + + ! ----------------------------------------------------------------------------- + ! Identify the net carbon gain for this dynamics interval + ! Set the available carbon pool, identify allocation portions, and + ! decrement the available carbon pool to zero. + ! ----------------------------------------------------------------------------- + ! + ! convert from kgC/indiv/day into kgC/indiv/year + ! _acc_hold is remembered until the next dynamics step (used for I/O) + ! _acc will be reset soon and will be accumulated on the next leaf + ! photosynthesis step + ! ----------------------------------------------------------------------------- + + if (hlm_use_ed_prescribed_phys .eq. itrue) then + if (currentCohort%canopy_layer .eq. 1) then + currentCohort%npp_acc_hold = EDPftvarcon_inst%prescribed_npp_canopy(ft) & + * currentCohort%c_area / currentCohort%n + ! add these for balance checking purposes + currentCohort%npp_acc = currentCohort%npp_acc_hold / hlm_days_per_year + else + currentCohort%npp_acc_hold = EDPftvarcon_inst%prescribed_npp_understory(ft) & + * currentCohort%c_area / currentCohort%n + ! add these for balance checking purposes + currentCohort%npp_acc = currentCohort%npp_acc_hold / hlm_days_per_year + endif + else + 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) + endif + + currentSite%flux_in = currentSite%flux_in + currentCohort%npp_acc * currentCohort%n - ! Apply growth to potentially all carbon pools - call PlantGrowth( currentSite, currentCohort, bc_in ) + call currentCohort%prt%CheckMassConservation(ft,3) + call PRTMaintTurnover(currentCohort%prt,ft) + call currentCohort%prt%CheckMassConservation(ft,4) + call currentCohort%prt%DailyPRT() + call currentCohort%prt%CheckMassConservation(ft,5) + + ! Transfer all reproductive tissues into seed production + call PRTReproRelease(currentCohort%prt,repro_organ,carbon12_element, & + 1.0_r8, currentCohort%seed_prod) + currentCohort%seed_prod = currentCohort%seed_prod / hlm_freq_day + + ! 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 ! Carbon assimilate has been spent at this point ! and can now be safely zero'd @@ -522,15 +607,17 @@ subroutine ed_total_balance_check (currentSite, call_index ) write(fates_log(),*)'---' currentCohort => currentPatch%tallest do while(associated(currentCohort)) - write(fates_log(),*) currentCohort%bdead,currentCohort%bstore,currentCohort%n + write(fates_log(),*) 'structure: ',currentCohort%prt%GetState(struct_organ,all_carbon_elements) + write(fates_log(),*) 'storage: ',currentCohort%prt%GetState(store_organ,all_carbon_elements) + write(fates_log(),*) 'N plant: ',currentCohort%n currentCohort => currentCohort%shorter; enddo !end cohort loop currentPatch => currentPatch%younger enddo !end patch loop end if - + 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( int(hlm_current_year*10000 + hlm_current_month*100 + hlm_current_day).ne.hlm_reference_date ) then write(fates_log(),*) 'aborting on date:',hlm_current_year,hlm_current_month,hlm_current_day @@ -570,20 +657,18 @@ subroutine bypass_dynamics(currentSite) currentCohort%isnew=.false. - currentCohort%npp_acc_hold = currentCohort%npp_acc * dble(hlm_days_per_year) - currentCohort%gpp_acc_hold = currentCohort%gpp_acc * dble(hlm_days_per_year) - currentCohort%resp_acc_hold = currentCohort%resp_acc * dble(hlm_days_per_year) + currentCohort%npp_acc_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) currentCohort%npp_acc = 0.0_r8 currentCohort%gpp_acc = 0.0_r8 currentCohort%resp_acc = 0.0_r8 - currentCohort%npp_leaf = 0.0_r8 - currentCohort%npp_fnrt = 0.0_r8 - currentCohort%npp_sapw = 0.0_r8 - currentCohort%npp_dead = 0.0_r8 - currentCohort%npp_seed = 0.0_r8 - currentCohort%npp_stor = 0.0_r8 + ! No need to set the "net_art" terms to zero + ! they are zeroed at the beginning of the daily step + ! If DailyPRT, maintenance, and phenology are not called + ! then these should stay zero. currentCohort%bmort = 0.0_r8 currentCohort%hmort = 0.0_r8 @@ -594,8 +679,6 @@ subroutine bypass_dynamics(currentSite) currentCohort%dndt = 0.0_r8 currentCohort%dhdt = 0.0_r8 currentCohort%ddbhdt = 0.0_r8 - currentCohort%dbdeaddt = 0.0_r8 - currentCohort%dbstoredt = 0.0_r8 currentCohort => currentCohort%taller enddo diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 1750c08b41..a4966fcfad 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -8,9 +8,16 @@ module EDPftvarcon ! !USES: use EDTypesMod , only : maxSWb, ivis, inir use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : nearzero use FatesGlobals, only : fates_log use FatesGlobals, only : endrun => fates_endrun + use PRTGenericMod, only : prt_cnp_flex_allom_hyp + use PRTGenericMod, only : prt_carbon_allom_hyp + use PRTGenericMod, only : num_organ_types + use PRTGenericMod, only : leaf_organ, fnrt_organ, store_organ + use PRTGenericMod, only : sapw_organ, struct_organ, repro_organ + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -43,7 +50,7 @@ module EDPftvarcon real(r8), allocatable :: initd (:) ! initial seedling density real(r8), allocatable :: seed_rain (:) ! seeds that come from outside the gridbox. real(r8), allocatable :: BB_slope (:) ! ball berry slope parameter - real(r8), allocatable :: root_long (:) ! root longevity (yrs) + real(r8), allocatable :: seed_alloc_mature (:) ! fraction of carbon balance allocated to clonal reproduction. real(r8), allocatable :: seed_alloc (:) ! fraction of carbon balance allocated to seeds. real(r8), allocatable :: c2b (:) ! Carbon to biomass multiplier [kg/kgC] @@ -53,7 +60,7 @@ module EDPftvarcon real(r8), allocatable :: evergreen(:) real(r8), allocatable :: slamax(:) real(r8), allocatable :: slatop(:) - real(r8), allocatable :: leaf_long(:) + real(r8), allocatable :: roota_par(:) real(r8), allocatable :: rootb_par(:) real(r8), allocatable :: lf_flab(:) @@ -67,12 +74,9 @@ module EDPftvarcon ! of leaf scattering elements decreases light interception real(r8), allocatable :: c3psn(:) ! index defining the photosynthetic pathway C4 = 0, C3 = 1 real(r8), allocatable :: vcmax25top(:) - real(r8), allocatable :: leafcn(:) - real(r8), allocatable :: frootcn(:) - real(r8), allocatable :: woodcn(:) real(r8), allocatable :: smpso(:) real(r8), allocatable :: smpsc(:) - real(r8), allocatable :: grperc(:) + 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), @@ -93,7 +97,7 @@ module EDPftvarcon real(r8), allocatable :: tpuse(:) real(r8), allocatable :: germination_timescale(:) real(r8), allocatable :: seed_decay_turnover(:) - real(r8), allocatable :: branch_turnover(:) ! Turnover time for branchfall on live trees [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(:, :) @@ -157,12 +161,49 @@ module EDPftvarcon ! prescribed_physiology_mode + ! Plant Reactive Transport (allocation) + + real(r8), allocatable :: grperc(:) ! Growth respiration per unit Carbon gained + ! One value for whole plant + ! ONLY parteh_mode == 1 [kg/kg] + + real(r8), allocatable :: prt_grperc_organ(:,:) ! Unit growth respiration (pft x organ) [kg/kg] + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! THIS IS NOT READ IN BY THE PARAMETER FILE + ! THIS IS JUST FILLED BY GRPERC. WE KEEP THIS + ! PARAMETER FOR HYPOTHESIS TESTING (ADVANCED USE) + ! IT HAS THE PRT_ TAG BECAUSE THIS PARAMETER + ! IS USED INSIDE PARTEH, WHILE GRPERC IS APPLIED + ! IN THE LEAF BIOPHYSICS SCHEME + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + real(r8), allocatable :: prt_nitr_stoich_p1(:,:) ! Parameter 1 for nitrogen stoichiometry (pft x organ) + real(r8), allocatable :: prt_nitr_stoich_p2(:,:) ! Parameter 2 for nitrogen stoichiometry (pft x organ) + real(r8), allocatable :: prt_phos_stoich_p1(:,:) ! Parameter 1 for phosphorous stoichiometry (pft x organ) + real(r8), allocatable :: prt_phos_stoich_p2(:,:) ! Parameter 2 for phosphorous stoichiometry (pft x organ) + real(r8), allocatable :: prt_alloc_priority(:,:) ! Allocation priority for each organ (pft x organ) [integer 0-6] + + ! 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 :: leaf_long(:) ! Leaf turnover time (longevity) (pft) [yr] + real(r8), allocatable :: root_long(:) ! root turnover time (longevity) (pft) [yr] + real(r8), allocatable :: branch_turnover(:) ! Turnover time for branchfall on live trees (pft) [yr] + real(r8), allocatable :: turnover_retrans_mode(:) ! Retranslocation method (pft) + + real(r8), allocatable :: turnover_carb_retrans(:,:) ! carbon re-translocation fraction (pft x organ) + real(r8), allocatable :: turnover_nitr_retrans(:,:) ! nitrogen re-translocation fraction (pft x organ) + real(r8), allocatable :: turnover_phos_retrans(:,:) ! phosphorous re-translocation fraction (pft x organ) + + ! Plant Hydraulic Parameters ! --------------------------------------------------------------------------------------------- ! PFT Dimension real(r8), allocatable :: hydr_p_taper(:) ! xylem taper exponent - real(r8), allocatable :: hydr_rs2(:) ! absorbing root radius (mm) + 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 @@ -188,7 +229,9 @@ module EDPftvarcon procedure, private :: Register_PFT_nvariants procedure, private :: Receive_PFT_nvariants procedure, private :: Register_PFT_hydr_organs - procedure, private :: Receive_PFT_hydr_organs + procedure, private :: Receive_PFT_hydr_organs + procedure, private :: Register_PFT_prt_organs + procedure, private :: Receive_PFT_prt_organs procedure, private :: Register_PFT_numrad procedure, private :: Receive_PFT_numrad end type EDPftvarcon_type @@ -230,6 +273,7 @@ subroutine Register(this, fates_params) call this%Register_PFT_numrad(fates_params) call this%Register_PFT_nvariants(fates_params) call this%Register_PFT_hydr_organs(fates_params) + call this%Register_PFT_prt_organs(fates_params) end subroutine Register @@ -247,6 +291,7 @@ subroutine Receive(this, fates_params) call this%Receive_PFT_numrad(fates_params) call this%Receive_PFT_nvariants(fates_params) call this%Receive_PFT_hydr_organs(fates_params) + call this%Receive_PFT_prt_organs(fates_params) end subroutine Receive @@ -420,18 +465,6 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_leaf_cn_ratio' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_froot_cn_ratio' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_wood_cn_ratio' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_smpso' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -664,6 +697,10 @@ subroutine Register_PFT(this, fates_params) call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_turnover_retrans_mode' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_branch_turnover' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -688,6 +725,9 @@ 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_phenflush_fraction' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) end subroutine Register_PFT @@ -852,18 +892,6 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%vcmax25top) - name = 'fates_leaf_cn_ratio' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%leafcn) - - name = 'fates_froot_cn_ratio' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%frootcn) - - name = 'fates_wood_cn_ratio' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%woodcn) - name = 'fates_smpso' call fates_params%RetreiveParameterAllocate(name=name, & data=this%smpso) @@ -1103,6 +1131,10 @@ subroutine Receive_PFT(this, fates_params) name = 'fates_branch_turnover' call fates_params%RetreiveParameterAllocate(name=name, & data=this%branch_turnover) + + name = 'fates_turnover_retrans_mode' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%turnover_retrans_mode) name = 'fates_trim_limit' call fates_params%RetreiveParameterAllocate(name=name, & @@ -1124,6 +1156,10 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%displar) + name = 'fates_phenflush_fraction' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%phenflush_fraction) + end subroutine Receive_PFT !----------------------------------------------------------------------- @@ -1346,6 +1382,111 @@ end subroutine Receive_PFT_nvariants ! ----------------------------------------------------------------------- + subroutine Register_PFT_prt_organs(this, fates_params) + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + use FatesParametersInterface, only : max_dimensions, dimension_name_prt_organs + use FatesParametersInterface, only : dimension_name_pft, dimension_shape_2d + + implicit none + + class(EDPftvarcon_type), intent(inout) :: this + class(fates_parameters_type), intent(inout) :: fates_params + + integer, parameter :: dim_lower_bound(2) = (/ lower_bound_pft, lower_bound_general /) + character(len=param_string_length) :: dim_names(2) + character(len=param_string_length) :: name + + ! NOTE(bja, 2017-01) initialization doesn't seem to work correctly + ! if dim_names has a parameter qualifier. + dim_names(1) = dimension_name_pft + dim_names(2) = dimension_name_prt_organs + + name = 'fates_prt_nitr_stoich_p1' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_prt_nitr_stoich_p2' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_prt_phos_stoich_p1' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_prt_phos_stoich_p2' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_prt_alloc_priority' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_turnover_carb_retrans' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_turnover_nitr_retrans' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_turnover_phos_retrans' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + + end subroutine Register_PFT_prt_organs + + ! ===================================================================================== + + subroutine Receive_PFT_prt_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_prt_nitr_stoich_p1' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%prt_nitr_stoich_p1) + + name = 'fates_prt_nitr_stoich_p2' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%prt_nitr_stoich_p2) + + name = 'fates_prt_phos_stoich_p1' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%prt_phos_stoich_p1) + + name = 'fates_prt_phos_stoich_p2' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%prt_phos_stoich_p2) + + name = 'fates_prt_alloc_priority' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%prt_alloc_priority) + + name = 'fates_turnover_carb_retrans' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%turnover_carb_retrans) + + name = 'fates_turnover_nitr_retrans' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%turnover_nitr_retrans) + + name = 'fates_turnover_phos_retrans' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%turnover_phos_retrans) + + end subroutine Receive_PFT_prt_organs + + ! ----------------------------------------------------------------------- + subroutine Register_PFT_hydr_organs(this, fates_params) use FatesParametersInterface, only : fates_parameters_type, param_string_length @@ -1520,9 +1661,6 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'clumping_index = ',EDPftvarcon_inst%clumping_index write(fates_log(),fmt0) 'c3psn = ',EDPftvarcon_inst%c3psn write(fates_log(),fmt0) 'vcmax25top = ',EDPftvarcon_inst%vcmax25top - write(fates_log(),fmt0) 'leafcn = ',EDPftvarcon_inst%leafcn - write(fates_log(),fmt0) 'frootcn = ',EDPftvarcon_inst%frootcn - write(fates_log(),fmt0) 'woodcn = ',EDPftvarcon_inst%woodcn write(fates_log(),fmt0) 'smpso = ',EDPftvarcon_inst%smpso write(fates_log(),fmt0) 'smpsc = ',EDPftvarcon_inst%smpsc write(fates_log(),fmt0) 'grperc = ',EDPftvarcon_inst%grperc @@ -1550,6 +1688,7 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'rhos = ',EDPftvarcon_inst%rhos 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) 'rootprof_beta = ',EDPftvarcon_inst%rootprof_beta write(fates_log(),fmt0) 'fire_alpha_SH = ',EDPftvarcon_inst%fire_alpha_SH write(fates_log(),fmt0) 'allom_hmode = ',EDPftvarcon_inst%allom_hmode @@ -1576,6 +1715,7 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'allom_agb2 = ',EDPftvarcon_inst%allom_agb2 write(fates_log(),fmt0) 'allom_agb3 = ',EDPftvarcon_inst%allom_agb3 write(fates_log(),fmt0) 'allom_agb4 = ',EDPftvarcon_inst%allom_agb4 + write(fates_log(),fmt0) 'hydr_p_taper = ',EDPftvarcon_inst%hydr_p_taper write(fates_log(),fmt0) 'hydr_rs2 = ',EDPftvarcon_inst%hydr_rs2 write(fates_log(),fmt0) 'hydr_srl = ',EDPftvarcon_inst%hydr_srl @@ -1591,6 +1731,19 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'hydr_fcap_node = ',EDPftvarcon_inst%hydr_fcap_node write(fates_log(),fmt0) 'hydr_pinot_node = ',EDPftvarcon_inst%hydr_pinot_node write(fates_log(),fmt0) 'hydr_kmax_node = ',EDPftvarcon_inst%hydr_kmax_node + + + write(fates_log(),fmt0) 'prt_nitr_stoich_p1 = ',EDPftvarcon_inst%prt_nitr_stoich_p1 + write(fates_log(),fmt0) 'prt_nitr_stoich_p2 = ',EDPftvarcon_inst%prt_nitr_stoich_p2 + write(fates_log(),fmt0) 'prt_phos_stoich_p1 = ',EDPftvarcon_inst%prt_phos_stoich_p1 + write(fates_log(),fmt0) 'prt_phos_stoich_p2 = ',EDPftvarcon_inst%prt_phos_stoich_p2 + write(fates_log(),fmt0) 'prt_grperc_organ = ',EDPftvarcon_inst%prt_grperc_organ + write(fates_log(),fmt0) 'prt_alloc_priority = ',EDPftvarcon_inst%prt_alloc_priority + + write(fates_log(),fmt0) 'turnover_carb_retrans = ',EDPftvarcon_inst%turnover_carb_retrans + write(fates_log(),fmt0) 'turnover_nitr_retrans = ',EDPftvarcon_inst%turnover_nitr_retrans + write(fates_log(),fmt0) 'turnover_phos_retrans = ',EDPftvarcon_inst%turnover_phos_retrans + write(fates_log(),*) '-------------------------------------------------' end if @@ -1600,7 +1753,7 @@ end subroutine FatesReportPFTParams ! ===================================================================================== - subroutine FatesCheckParams(is_master) + subroutine FatesCheckParams(is_master, parteh_mode) ! ---------------------------------------------------------------------------------- ! @@ -1614,15 +1767,56 @@ subroutine FatesCheckParams(is_master) ! Argument - logical, intent(in) :: is_master ! Only log if this is the master proc - + logical, intent(in) :: is_master ! Only log if this is the master proc + integer, intent(in) :: parteh_mode ! argument for nl flag hlm_parteh_mode + character(len=32),parameter :: fmt0 = '(a,100(F12.4,1X))' - integer :: npft,ipft + integer :: npft ! number of PFTs + integer :: ipft ! pft index + integer :: norgans ! size of the plant organ dimension npft = size(EDPftvarcon_inst%pft_used,1) + ! Prior to performing checks copy grperc to the + ! organ dimensioned version + + norgans = size(EDPftvarcon_inst%prt_nitr_stoich_p1,2) + allocate(EDPftvarcon_inst%prt_grperc_organ(npft,norgans)) + do ipft = 1,npft + EDPftvarcon_inst%prt_grperc_organ(ipft,1:norgans) = EDPftvarcon_inst%grperc(ipft) + end do + + if(.not.is_master) return + + if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then + write(fates_log(),*) 'FATES Plant Allocation and Reactive Transport' + write(fates_log(),*) 'with flexible target stoichiometry for NP and' + write(fates_log(),*) 'allometrically constrianed C is still under development' + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + elseif (parteh_mode .ne. prt_carbon_allom_hyp) then + + write(fates_log(),*) 'FATES Plant Allocation and Reactive Transport has' + write(fates_log(),*) 'only 1 module supported, allometric carbon only.' + write(fates_log(),*) 'fates_parteh_mode must be set to 1 in the namelist' + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + 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' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + do ipft = 1,npft @@ -1691,6 +1885,26 @@ subroutine FatesCheckParams(is_master) ! call endrun(msg=errMsg(sourcefile, __LINE__)) ! ! end if + + + ! Check if the fraction of storage used for flushing deciduous trees + ! is greater than zero, and less than or equal to 1. + + if ( int(EDPftvarcon_inst%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.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' evergreen flag: (shold be 0):',int(EDPftvarcon_inst%evergreen(ipft)) + write(fates_log(),*) ' phenflush_fraction: ', EDPFtvarcon_inst%phenflush_fraction(ipft) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + ! Check if freezing tolerance is within reasonable bounds ! ---------------------------------------------------------------------------------- @@ -1741,6 +1955,230 @@ subroutine FatesCheckParams(is_master) end if + + ! Check re-translocations + ! Seems reasonable to assume that sapwood, structure and reproduction + ! should not be re-translocating mass upon turnover. + ! Note to advanced users. Feel free to remove these checks... + ! ------------------------------------------------------------------- + + if ( (EDPftvarcon_inst%turnover_carb_retrans(ipft,repro_organ) > nearzero) ) then + write(fates_log(),*) ' Retranslocation of reproductive tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,repro_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then + if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,repro_organ) > nearzero) .or. & + (EDPftvarcon_inst%turnover_phos_retrans(ipft,repro_organ) > nearzero) ) then + write(fates_log(),*) ' Retranslocation of reproductive tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,repro_organ) + write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,repro_organ) + write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,repro_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,sapw_organ) > nearzero)) then + write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,sapw_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then + if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,sapw_organ) > nearzero) .or. & + (EDPftvarcon_inst%turnover_phos_retrans(ipft,sapw_organ) > nearzero) ) then + write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,sapw_organ) + write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,sapw_organ) + write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,sapw_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,struct_organ) > nearzero)) then + write(fates_log(),*) ' Retranslocation of structural(dead) tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,struct_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then + if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,struct_organ) > nearzero) .or. & + (EDPftvarcon_inst%turnover_phos_retrans(ipft,struct_organ) > nearzero) ) then + write(fates_log(),*) ' Retranslocation of structural(dead) tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,struct_organ) + write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,struct_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! Leaf retranslocation should be between 0 and 1 + if ( (EDPftvarcon_inst%turnover_carb_retrans(ipft,leaf_organ) > 1.0_r8) .or. & + (EDPftvarcon_inst%turnover_carb_retrans(ipft,leaf_organ) < 0.0_r8) ) then + write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,leaf_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then + if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,leaf_organ) > 1.0_r8) .or. & + (EDPftvarcon_inst%turnover_phos_retrans(ipft,leaf_organ) > 1.0_r8) .or. & + (EDPftvarcon_inst%turnover_nitr_retrans(ipft,leaf_organ) < 0.0_r8) .or. & + (EDPftvarcon_inst%turnover_phos_retrans(ipft,leaf_organ) < 0.0_r8)) then + write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,leaf_organ) + write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,leaf_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! Fineroot retranslocation should be between 0-1 + if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & + (EDPftvarcon_inst%turnover_carb_retrans(ipft,fnrt_organ) < 0.0_r8)) then + write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,fnrt_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then + if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & + (EDPftvarcon_inst%turnover_phos_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & + (EDPftvarcon_inst%turnover_nitr_retrans(ipft,fnrt_organ) < 0.0_r8) .or. & + (EDPftvarcon_inst%turnover_phos_retrans(ipft,fnrt_organ) < 0.0_r8)) then + write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,fnrt_organ) + write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,fnrt_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! Storage retranslocation should be between 0-1 (storage retrans seems weird, but who knows) + if ((EDPftvarcon_inst%turnover_carb_retrans(ipft,store_organ) > 1.0_r8) .or. & + (EDPftvarcon_inst%turnover_carb_retrans(ipft,store_organ) < 0.0_r8)) then + write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon: ',EDPftvarcon_inst%turnover_carb_retrans(ipft,store_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then + if ((EDPftvarcon_inst%turnover_nitr_retrans(ipft,store_organ) > 1.0_r8) .or. & + (EDPftvarcon_inst%turnover_phos_retrans(ipft,store_organ) > 1.0_r8) .or. & + (EDPftvarcon_inst%turnover_nitr_retrans(ipft,store_organ) < 0.0_r8) .or. & + (EDPftvarcon_inst%turnover_phos_retrans(ipft,store_organ) < 0.0_r8)) then + write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' nitr: ',EDPftvarcon_inst%turnover_nitr_retrans(ipft,store_organ) + write(fates_log(),*) ' phos: ',EDPftvarcon_inst%turnover_phos_retrans(ipft,store_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! Growth respiration + if (parteh_mode .eq. prt_carbon_allom_hyp) then + if ( ( EDPftvarcon_inst%grperc(ipft) < 0.0_r8) .or. & + ( EDPftvarcon_inst%grperc(ipft) > 1.0_r8 ) ) then + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' Growth respiration must be between 0 and 1: ',EDPftvarcon_inst%grperc(ipft) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + elseif(parteh_mode .eq. prt_cnp_flex_allom_hyp) then + if ( ( any(EDPftvarcon_inst%prt_grperc_organ(ipft,:) < 0.0_r8)) .or. & + ( any(EDPftvarcon_inst%prt_grperc_organ(ipft,:) >= 1.0_r8)) ) then + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' Growth respiration must be between 0 and 1: ',EDPftvarcon_inst%prt_grperc_organ(ipft,:) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! Stoichiometric Ratios + + ! Firstly, the seed production and germination models cannot handle nutrients. So + ! we assume (for now) that seeds do not have nutrients (parteh_mode = 1 is c only) + if(parteh_mode .eq. prt_cnp_flex_allom_hyp) then + if ( (EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,repro_organ) > nearzero) .or. & + (EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,repro_organ) < -nearzero) .or. & + (EDPftvarcon_inst%prt_phos_stoich_p1(ipft,repro_organ) > nearzero) .or. & + (EDPftvarcon_inst%prt_phos_stoich_p1(ipft,repro_organ) < -nearzero) .or. & + (EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,repro_organ) > nearzero) .or. & + (EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,repro_organ) < -nearzero) .or. & + (EDPftvarcon_inst%prt_phos_stoich_p2(ipft,repro_organ) > nearzero) .or. & + (EDPftvarcon_inst%prt_phos_stoich_p2(ipft,repro_organ) < -nearzero) ) then + write(fates_log(),*) 'N & P should be zero in reproductive tissues' + write(fates_log(),*) 'until nutrients are coupled into recruitment' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,repro_organ) + write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p1(ipft,repro_organ) + write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,repro_organ) + write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p2(ipft,repro_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! The first nitrogen stoichiometry is used in all cases + if ( (any(EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,:) < 0.0_r8)) .or. & + (any(EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,:) >= 1.0_r8))) then + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' N per C stoichiometry must bet between 0-1' + write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,:) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if(parteh_mode .eq. prt_cnp_flex_allom_hyp) then + if( (any(EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,:) < 0.0_r8)) .or. & + (any(EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,:) >= 1.0_r8)) ) then + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' N per C stoichiometry must bet between 0-1' + write(fates_log(),*) EDPftvarcon_inst%prt_nitr_stoich_p2(ipft,:) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! Stoichiometric Ratios + if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then + if ( (any(EDPftvarcon_inst%prt_phos_stoich_p1(ipft,:) < 0.0_r8)) .or. & + (any(EDPftvarcon_inst%prt_phos_stoich_p1(ipft,:) >= 1.0_r8)) .or. & + (any(EDPftvarcon_inst%prt_phos_stoich_p2(ipft,:) < 0.0_r8)) .or. & + (any(EDPftvarcon_inst%prt_phos_stoich_p2(ipft,:) >= 1.0_r8)) ) then + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' P per C stoichiometry must bet between 0-1' + write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p1(ipft,:) + write(fates_log(),*) EDPftvarcon_inst%prt_phos_stoich_p2(ipft,:) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + if (parteh_mode .eq. prt_cnp_flex_allom_hyp) then + if ( any(EDPftvarcon_inst%prt_alloc_priority(ipft,:) < 0) .or. & + any(EDPftvarcon_inst%prt_alloc_priority(ipft,:) > 6) ) then + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' Allocation priorities should be 0-6 for H1' + write(fates_log(),*) EDPftvarcon_inst%prt_alloc_priority(ipft,:) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + end do diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 6e1ea667b7..06264b5229 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -5,6 +5,10 @@ module EDTypesMod use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) use FatesHydraulicsMemMod, only : ed_cohort_hydr_type use FatesHydraulicsMemMod, only : ed_site_hydr_type + use PRTGenericMod, only : prt_vartypes + use PRTGenericMod, only : leaf_organ, fnrt_organ, sapw_organ + use PRTGenericMod, only : repro_organ, store_organ, struct_organ + use PRTGenericMod, only : all_carbon_elements implicit none save @@ -60,6 +64,13 @@ module EDTypesMod ! can be approximated to be equal to the visible band + integer, parameter :: leaves_on = 2 ! Flag specifying that a deciduous plant has leaves + ! and should be allocating to them as well + integer, parameter :: leaves_off = 1 ! Flag specifying that a deciduous plant has dropped + ! its leaves and should not be trying to allocate + ! towards any growth. + + ! Switches that turn on/off ED dynamics process (names are self explanatory) ! IMPORTANT NOTE!!! THESE SWITCHES ARE EXPERIMENTAL. ! THEY SHOULD CORRECTLY TURN OFF OR ON THE PROCESS, BUT.. THERE ARE VARIOUS @@ -69,7 +80,20 @@ module EDTypesMod ! WAS OUTSIDE THE SCOPE OF THE VERY LARGE CHANGESET WHERE THESE WERE FIRST ! INTRODUCED (RGK 03-2017) logical, parameter :: do_ed_phenology = .true. - logical, parameter :: init_dense_forest = .false. + + + ! This is the community level amount of spread expected in nearly-bare-ground + ! and inventory starting modes. + ! These are used to initialize only. These values will scale between + ! the PFT defined maximum and minimum crown area scaing parameters. + ! + ! A value of 1 indicates that + ! plants should have crown areas at maximum spread for their size and PFT. + ! A value of 0 means that they have the least amount of spread for their + ! size and PFT. + + real(r8), parameter :: init_spread_near_bare_ground = 1.0_r8 + real(r8), parameter :: init_spread_inventory = 0.0_r8 ! MODEL PARAMETERS @@ -133,22 +157,23 @@ module EDTypesMod type (ed_patch_type) , pointer :: patchptr => null() ! pointer to patch that cohort is in + + ! Multi-species, multi-organ Plant Reactive Transport (PRT) + ! Contains carbon and nutrient state variables for various plant organs + + class(prt_vartypes), pointer :: prt + ! VEGETATION STRUCTURE integer :: pft ! pft number real(r8) :: n ! number of individuals in cohort per 'area' (10000m2 default) real(r8) :: dbh ! dbh: cm real(r8) :: hite ! height: meters integer :: indexnumber ! unique number for each cohort. (within clump?) - real(r8) :: bdead ! dead biomass: kGC per indiv - real(r8) :: bstore ! stored carbon: kGC per indiv real(r8) :: laimemory ! target leaf biomass- set from previous year: kGC per indiv integer :: canopy_layer ! canopy status of cohort (1 = canopy, 2 = understorey, etc.) real(r8) :: canopy_layer_yesterday ! recent canopy status of cohort ! (1 = canopy, 2 = understorey, etc.) ! real to be conservative during fusion - real(r8) :: bsw ! sapwood in stem and roots: kGC per indiv - real(r8) :: bl ! leaf biomass: kGC per indiv - real(r8) :: br ! fine root biomass: kGC per indiv real(r8) :: lai ! leaf area index of cohort: m2 leaf area of entire cohort per m2 of canopy area of a patch real(r8) :: sai ! stem area index of cohort: m2 leaf area of entire cohort per m2 of canopy area of a patch real(r8) :: g_sb_laweight ! Total conductance (stomata+boundary layer) of the cohort, weighted by its leaf area [m/s]*[m2] @@ -171,6 +196,7 @@ module EDTypesMod ! type classification. We also maintain this in the main cohort memory ! because we don't want to continually re-calculate the cohort's position when ! performing size diagnostics at high-frequency calls + integer :: size_class_lasttimestep ! size class of the cohort at the end of the previous timestep (used for calculating growth flux) ! CARBON FLUXES @@ -201,16 +227,6 @@ module EDTypesMod real(r8) :: resp_acc real(r8) :: resp_acc_hold - ! Plant Tissue Carbon Fluxes - - ! Fluxes in from Net Primary Production - real(r8) :: npp_leaf ! NPP into leaves (includes replacement of turnover): KgC/indiv/year - real(r8) :: npp_fnrt ! NPP into fine roots (includes replacement of turnover): KgC/indiv/year - real(r8) :: npp_sapw ! NPP into sapwood: KgC/indiv/year - real(r8) :: npp_dead ! NPP into deadwood (structure): KgC/indiv/year - real(r8) :: npp_seed ! NPP into seeds: KgC/indiv/year - real(r8) :: npp_stor ! NPP into storage: KgC/indiv/year - real(r8) :: ts_net_uptake(nlevleaf) ! Net uptake of leaf layers: kgC/m2/timestep real(r8) :: year_net_uptake(nlevleaf) ! Net uptake of leaf layers: kgC/m2/year @@ -225,15 +241,9 @@ module EDTypesMod real(r8) :: froot_mr ! Live fine root maintenance respiration: kgC/indiv/s ! ALLOCATION - real(r8) :: md ! plant maintenance demand: kgC/indiv/year - real(r8) :: leaf_md ! leaf maintenance demand: kgC/indiv/year - real(r8) :: root_md ! root maintenance demand: kgC/indiv/year - real(r8) :: bsw_md ! sawpwood maintenance demand: kgC/indiv/year - real(r8) :: bstore_md ! storage maintenance demand: kgC/indiv/year - real(r8) :: bdead_md ! structural (branch) maintenance demand: kgC/indiv/year real(r8) :: seed_prod ! reproduction seed and clonal: KgC/indiv/year - real(r8) :: leaf_litter ! leaf litter from phenology: KgC/m2 + !MORTALITY real(r8) :: dmort ! proportional mortality rate. (year-1) @@ -271,19 +281,10 @@ module EDTypesMod real(r8) :: crownfire_mort ! probability of tree post-fire mortality due to crown scorch:- real(r8) :: fire_mort ! post-fire mortality from cambial and crown damage assuming two are independent:- - ! Integration - real(r8) :: ode_opt_step ! What is the current optimum step size - ! for the integrator? (variable units, including kgC, - ! and then time when we have multiple species) - ! Hydraulics type(ed_cohort_hydr_type), pointer :: co_hydr ! All cohort hydraulics data, see FatesHydraulicsMemMod.F90 - contains - - procedure, public :: b_total - - end type ed_cohort_type + end type ed_cohort_type @@ -479,7 +480,6 @@ module EDTypesMod ! PLANT HYDRAULICS (not currently used in hydraulics RGK 03-2018) ! type(ed_patch_hydr_type) , pointer :: pa_hydr ! All patch hydraulics data, see FatesHydraulicsMemMod.F90 - contains end type ed_patch_type @@ -597,6 +597,7 @@ module EDTypesMod real(r8) :: promotion_carbonflux ! biomass of promoted individuals from understory to canopy [kgC/ha/day] real(r8), allocatable :: imort_rate(:,:) ! rate of individuals killed due to impact mortality per year. on size x pft array real(r8) :: imort_carbonflux ! biomass of individuals killed due to impact mortality per year. [kgC/ha/day] + real(r8), allocatable :: growthflux_fusion(:,:) ! rate of individuals moving into a given size class bin due to fusion in a given day. on size x pft array ! some diagnostic-only (i.e. not resolved by ODE solver) flux of carbon to CWD and litter pools from termination and canopy mortality real(r8) :: CWD_AG_diagnostic_input_carbonflux(1:ncwd) ! diagnostic flux to AG CWD [kg C / m2 / yr] @@ -609,19 +610,8 @@ module EDTypesMod end type ed_site_type -contains - - function b_total(this) - ! Calculate total plant biomass - - implicit none - class(ed_cohort_type), intent(inout) :: this - real(r8) :: b_total - - b_total = this%bl + this%br + this%bsw + this%bdead + this%bstore - - end function b_total + contains ! ===================================================================================== @@ -751,13 +741,16 @@ subroutine dump_cohort(ccohort) write(fates_log(),*) 'co%pft = ', ccohort%pft write(fates_log(),*) 'co%n = ', ccohort%n write(fates_log(),*) 'co%dbh = ', ccohort%dbh - write(fates_log(),*) 'co%hite = ', ccohort%hite - write(fates_log(),*) 'co%bdead = ', ccohort%bdead - write(fates_log(),*) 'co%bstore = ', ccohort%bstore + write(fates_log(),*) 'co%hite = ', ccohort%hite write(fates_log(),*) 'co%laimemory = ', ccohort%laimemory - write(fates_log(),*) 'co%bsw = ', ccohort%bsw - write(fates_log(),*) 'co%bl = ', ccohort%bl - write(fates_log(),*) 'co%br = ', ccohort%br + + write(fates_log(),*) 'leaf carbon = ', ccohort%prt%GetState(leaf_organ,all_carbon_elements) + write(fates_log(),*) 'fineroot carbon = ', ccohort%prt%GetState(fnrt_organ,all_carbon_elements) + write(fates_log(),*) 'sapwood carbon = ', ccohort%prt%GetState(sapw_organ,all_carbon_elements) + write(fates_log(),*) 'structural (dead) carbon = ', ccohort%prt%GetState(struct_organ,all_carbon_elements) + write(fates_log(),*) 'storage carbon = ', ccohort%prt%GetState(store_organ,all_carbon_elements) + write(fates_log(),*) 'reproductive carbon = ', ccohort%prt%GetState(repro_organ,all_carbon_elements) + write(fates_log(),*) 'co%lai = ', ccohort%lai write(fates_log(),*) 'co%sai = ', ccohort%sai write(fates_log(),*) 'co%g_sb_laweight = ', ccohort%g_sb_laweight @@ -780,30 +773,16 @@ subroutine dump_cohort(ccohort) write(fates_log(),*) 'co%resp_tstep = ', ccohort%resp_tstep write(fates_log(),*) 'co%resp_acc = ', ccohort%resp_acc write(fates_log(),*) 'co%resp_acc_hold = ', ccohort%resp_acc_hold - write(fates_log(),*) 'co%npp_leaf = ', ccohort%npp_leaf - write(fates_log(),*) 'co%npp_fnrt = ', ccohort%npp_fnrt - write(fates_log(),*) 'co%npp_sapw = ', ccohort%npp_sapw - write(fates_log(),*) 'co%npp_dead = ', ccohort%npp_dead - write(fates_log(),*) 'co%npp_seed = ', ccohort%npp_seed - write(fates_log(),*) 'co%npp_stor = ', ccohort%npp_stor - write(fates_log(),*) 'co%ode_opt_step = ', ccohort%ode_opt_step write(fates_log(),*) 'co%rdark = ', ccohort%rdark write(fates_log(),*) 'co%resp_m = ', ccohort%resp_m write(fates_log(),*) 'co%resp_g = ', ccohort%resp_g write(fates_log(),*) 'co%livestem_mr = ', ccohort%livestem_mr write(fates_log(),*) 'co%livecroot_mr = ', ccohort%livecroot_mr write(fates_log(),*) 'co%froot_mr = ', ccohort%froot_mr - write(fates_log(),*) 'co%md = ', ccohort%md - write(fates_log(),*) 'co%leaf_md = ', ccohort%leaf_md - write(fates_log(),*) 'co%root_md = ', ccohort%root_md - write(fates_log(),*) 'co%bstore_md = ', ccohort%bstore_md - write(fates_log(),*) 'co%bdead_md = ', ccohort%bdead_md - write(fates_log(),*) 'co%bsw_md = ', ccohort%bsw_md write(fates_log(),*) 'co%dmort = ', ccohort%dmort write(fates_log(),*) 'co%seed_prod = ', ccohort%seed_prod write(fates_log(),*) 'co%treelai = ', ccohort%treelai write(fates_log(),*) 'co%treesai = ', ccohort%treesai - write(fates_log(),*) 'co%leaf_litter = ', ccohort%leaf_litter write(fates_log(),*) 'co%c_area = ', ccohort%c_area write(fates_log(),*) 'co%cmort = ', ccohort%cmort write(fates_log(),*) 'co%bmort = ', ccohort%bmort diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index 7497d53673..650ff4599f 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -16,6 +16,7 @@ module FatesHistoryInterfaceMod use FatesInterfaceMod , only : hlm_use_planthydro use FatesInterfaceMod , only : hlm_use_ed_st3 use FatesInterfaceMod , only : numpft + use FatesInterfaceMod , only : hlm_freq_day use EDParamsMod , only : ED_val_comp_excln use FatesInterfaceMod , only : nlevsclass, nlevage use FatesInterfaceMod , only : nlevheight @@ -33,6 +34,11 @@ module FatesHistoryInterfaceMod use FatesConstantsMod , only : days_per_year use FatesConstantsMod , only : years_per_day + use PRTGenericMod , only : leaf_organ, fnrt_organ, sapw_organ + use PRTGenericMod , only : struct_organ, store_organ, repro_organ + use PRTGenericMod , only : all_carbon_elements + + implicit none ! These variables hold the index of the history output structure so we don't @@ -175,6 +181,8 @@ module FatesHistoryInterfaceMod integer, private :: ih_ar_understory_si_scpf integer, private :: ih_ddbh_si_scpf + integer, private :: ih_growthflux_si_scpf + integer, private :: ih_growthflux_fusion_si_scpf integer, private :: ih_ba_si_scpf integer, private :: ih_m1_si_scpf integer, private :: ih_m2_si_scpf @@ -185,6 +193,7 @@ module FatesHistoryInterfaceMod integer, private :: ih_m7_si_scpf integer, private :: ih_m8_si_scpf + integer, private :: ih_ar_si_scpf integer, private :: ih_ar_grow_si_scpf integer, private :: ih_ar_maint_si_scpf @@ -193,6 +202,7 @@ module FatesHistoryInterfaceMod integer, private :: ih_ar_crootm_si_scpf integer, private :: ih_ar_frootm_si_scpf + ! indices to (site x scls) variables integer, private :: ih_ba_si_scls integer, private :: ih_nplant_si_scls @@ -239,10 +249,6 @@ module FatesHistoryInterfaceMod integer, private :: ih_bdead_md_canopy_si_scls integer, private :: ih_bsw_md_canopy_si_scls integer, private :: ih_seed_prod_canopy_si_scls - integer, private :: ih_dbalivedt_canopy_si_scls - integer, private :: ih_dbdeaddt_canopy_si_scls - integer, private :: ih_dbstoredt_canopy_si_scls - integer, private :: ih_storage_flux_canopy_si_scls integer, private :: ih_npp_leaf_canopy_si_scls integer, private :: ih_npp_fnrt_canopy_si_scls integer, private :: ih_npp_sapw_canopy_si_scls @@ -263,10 +269,6 @@ module FatesHistoryInterfaceMod integer, private :: ih_bdead_md_understory_si_scls integer, private :: ih_bstore_md_understory_si_scls integer, private :: ih_seed_prod_understory_si_scls - integer, private :: ih_dbalivedt_understory_si_scls - integer, private :: ih_dbdeaddt_understory_si_scls - integer, private :: ih_dbstoredt_understory_si_scls - integer, private :: ih_storage_flux_understory_si_scls integer, private :: ih_npp_leaf_understory_si_scls integer, private :: ih_npp_fnrt_understory_si_scls integer, private :: ih_npp_sapw_understory_si_scls @@ -1270,6 +1272,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) use FatesSizeAgeTypeIndicesMod, only : get_agepft_class_index use FatesSizeAgeTypeIndicesMod, only : get_age_class_index use FatesSizeAgeTypeIndicesMod, only : get_height_index + use FatesSizeAgeTypeIndicesMod, only : sizetype_class_index use EDTypesMod , only : nlevleaf use EDParamsMod, only : ED_val_history_height_bin_edges @@ -1306,6 +1309,27 @@ subroutine update_history_dyn(this,nc,nsites,sites) 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 + ! The following are all carbon states, turnover and net allocation flux variables + ! the organs of relevance should be self explanatory + real(r8) :: sapw_c + real(r8) :: struct_c + real(r8) :: leaf_c + real(r8) :: fnrt_c + real(r8) :: store_c + real(r8) :: alive_c + real(r8) :: total_c + real(r8) :: sapw_c_turnover + real(r8) :: store_c_turnover + real(r8) :: leaf_c_turnover + real(r8) :: fnrt_c_turnover + real(r8) :: struct_c_turnover + real(r8) :: sapw_c_net_alloc + real(r8) :: store_c_net_alloc + real(r8) :: leaf_c_net_alloc + real(r8) :: fnrt_c_net_alloc + real(r8) :: struct_c_net_alloc + real(r8) :: repro_c_net_alloc + type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort @@ -1387,6 +1411,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_ar_canopy_si_scpf => this%hvars(ih_ar_canopy_si_scpf)%r82d, & hio_ar_understory_si_scpf => this%hvars(ih_ar_understory_si_scpf)%r82d, & hio_ddbh_si_scpf => this%hvars(ih_ddbh_si_scpf)%r82d, & + hio_growthflux_si_scpf => this%hvars(ih_growthflux_si_scpf)%r82d, & + hio_growthflux_fusion_si_scpf => this%hvars(ih_growthflux_fusion_si_scpf)%r82d, & hio_ba_si_scpf => this%hvars(ih_ba_si_scpf)%r82d, & hio_nplant_si_scpf => this%hvars(ih_nplant_si_scpf)%r82d, & @@ -1437,10 +1463,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_bdead_md_canopy_si_scls => this%hvars(ih_bdead_md_canopy_si_scls)%r82d, & hio_bstore_md_canopy_si_scls => this%hvars(ih_bstore_md_canopy_si_scls)%r82d, & hio_seed_prod_canopy_si_scls => this%hvars(ih_seed_prod_canopy_si_scls)%r82d, & - hio_dbalivedt_canopy_si_scls => this%hvars(ih_dbalivedt_canopy_si_scls)%r82d, & - hio_dbdeaddt_canopy_si_scls => this%hvars(ih_dbdeaddt_canopy_si_scls)%r82d, & - hio_dbstoredt_canopy_si_scls => this%hvars(ih_dbstoredt_canopy_si_scls)%r82d, & - hio_storage_flux_canopy_si_scls => this%hvars(ih_storage_flux_canopy_si_scls)%r82d, & hio_npp_leaf_canopy_si_scls => this%hvars(ih_npp_leaf_canopy_si_scls)%r82d, & hio_npp_fnrt_canopy_si_scls => this%hvars(ih_npp_fnrt_canopy_si_scls)%r82d, & hio_npp_sapw_canopy_si_scls => this%hvars(ih_npp_sapw_canopy_si_scls)%r82d, & @@ -1454,10 +1476,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_bsw_md_understory_si_scls => this%hvars(ih_bsw_md_understory_si_scls)%r82d, & hio_bdead_md_understory_si_scls => this%hvars(ih_bdead_md_understory_si_scls)%r82d, & hio_seed_prod_understory_si_scls => this%hvars(ih_seed_prod_understory_si_scls)%r82d, & - hio_dbalivedt_understory_si_scls => this%hvars(ih_dbalivedt_understory_si_scls)%r82d, & - hio_dbdeaddt_understory_si_scls => this%hvars(ih_dbdeaddt_understory_si_scls)%r82d, & - hio_dbstoredt_understory_si_scls => this%hvars(ih_dbstoredt_understory_si_scls)%r82d, & - hio_storage_flux_understory_si_scls => this%hvars(ih_storage_flux_understory_si_scls)%r82d, & hio_npp_leaf_understory_si_scls => this%hvars(ih_npp_leaf_understory_si_scls)%r82d, & hio_npp_fnrt_understory_si_scls => this%hvars(ih_npp_fnrt_understory_si_scls)%r82d, & hio_npp_sapw_understory_si_scls => this%hvars(ih_npp_sapw_understory_si_scls)%r82d, & @@ -1555,6 +1573,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) do while(associated(ccohort)) ft = ccohort%pft + + call sizetype_class_index(ccohort%dbh, ccohort%pft, ccohort%size_class, ccohort%size_by_pft_class) ! Increment the number of cohorts per site hio_ncohorts_si(io_si) = hio_ncohorts_si(io_si) + 1._r8 @@ -1625,29 +1645,42 @@ subroutine update_history_dyn(this,nc,nsites,sites) endif ! Update biomass components - hio_bleaf_pa(io_pa) = hio_bleaf_pa(io_pa) + n_density * ccohort%bl * g_per_kg - hio_bstore_pa(io_pa) = hio_bstore_pa(io_pa) + n_density * ccohort%bstore * g_per_kg - hio_bdead_pa(io_pa) = hio_bdead_pa(io_pa) + n_density * ccohort%bdead * g_per_kg - hio_balive_pa(io_pa) = hio_balive_pa(io_pa) + n_density * & - (ccohort%bsw + ccohort%br + ccohort%bl) * g_per_kg - hio_bsapwood_pa(io_pa) = hio_bsapwood_pa(io_pa) + n_density * ccohort%bsw * g_per_kg - hio_bfineroot_pa(io_pa) = hio_bfineroot_pa(io_pa) + n_density * ccohort%br * g_per_kg - hio_btotal_pa(io_pa) = hio_btotal_pa(io_pa) + n_density * ccohort%b_total() * g_per_kg + + + ! Mass pools [kgC] + sapw_c = ccohort%prt%GetState(sapw_organ, all_carbon_elements) + struct_c = ccohort%prt%GetState(struct_organ, all_carbon_elements) + leaf_c = ccohort%prt%GetState(leaf_organ, all_carbon_elements) + fnrt_c = ccohort%prt%GetState(fnrt_organ, all_carbon_elements) + store_c = ccohort%prt%GetState(store_organ, all_carbon_elements) + + alive_c = leaf_c + fnrt_c + sapw_c + total_c = alive_c + store_c + struct_c + + hio_bleaf_pa(io_pa) = hio_bleaf_pa(io_pa) + n_density * leaf_c * g_per_kg + hio_bstore_pa(io_pa) = hio_bstore_pa(io_pa) + n_density * store_c * g_per_kg + hio_bdead_pa(io_pa) = hio_bdead_pa(io_pa) + n_density * struct_c * g_per_kg + hio_balive_pa(io_pa) = hio_balive_pa(io_pa) + n_density * alive_c * g_per_kg + + hio_bsapwood_pa(io_pa) = hio_bsapwood_pa(io_pa) + n_density * sapw_c * g_per_kg + hio_bfineroot_pa(io_pa) = hio_bfineroot_pa(io_pa) + n_density * fnrt_c * g_per_kg + hio_btotal_pa(io_pa) = hio_btotal_pa(io_pa) + n_density * total_c * g_per_kg + hio_agb_pa(io_pa) = hio_agb_pa(io_pa) + n_density * g_per_kg * & - ( ccohort%bl + (ccohort%bsw + ccohort%bdead) * EDPftvarcon_inst%allom_agb_frac(ccohort%pft) ) + ( leaf_c + (sapw_c + struct_c + store_c) * EDPftvarcon_inst%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) * ccohort%bl * g_per_kg + (ccohort%n * AREA_INV) * leaf_c * g_per_kg hio_storebiomass_si_pft(io_si,ft) = hio_storebiomass_si_pft(io_si,ft) + & - (ccohort%n * AREA_INV) * ccohort%bstore * g_per_kg + (ccohort%n * AREA_INV) * store_c * g_per_kg hio_nindivs_si_pft(io_si,ft) = hio_nindivs_si_pft(io_si,ft) + & ccohort%n * AREA_INV hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & - (ccohort%n * AREA_INV) * ccohort%b_total() * g_per_kg + (ccohort%n * AREA_INV) * total_c * g_per_kg ! Update PFT crown area hio_crownarea_si_pft(io_si, ft) = hio_crownarea_si_pft(io_si, ft) + & @@ -1655,18 +1688,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! update total biomass per age bin hio_biomass_si_age(io_si,cpatch%age_class) = hio_biomass_si_age(io_si,cpatch%age_class) & - + ccohort%b_total() * ccohort%n * AREA_INV - - - ! ecosystem-level, organ-partitioned NPP/allocation fluxes - hio_npp_leaf_si(io_si) = hio_npp_leaf_si(io_si) + ccohort%npp_leaf * n_perm2 - hio_npp_seed_si(io_si) = hio_npp_seed_si(io_si) + ccohort%npp_seed * n_perm2 - hio_npp_stem_si(io_si) = hio_npp_stem_si(io_si) + (ccohort%npp_sapw + ccohort%npp_dead) * n_perm2 * & - (EDPftvarcon_inst%allom_agb_frac(ccohort%pft)) - hio_npp_froot_si(io_si) = hio_npp_froot_si(io_si) + ccohort%npp_fnrt * n_perm2 - hio_npp_croot_si(io_si) = hio_npp_croot_si(io_si) + (ccohort%npp_sapw + ccohort%npp_dead) * n_perm2 * & - (1._r8-EDPftvarcon_inst%allom_agb_frac(ccohort%pft)) - hio_npp_stor_si(io_si) = hio_npp_stor_si(io_si) + ccohort%npp_stor * n_perm2 + + total_c * ccohort%n * AREA_INV ! Site by Size-Class x PFT (SCPF) ! ------------------------------------------------------------------------ @@ -1677,6 +1699,33 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! have any meaning, otherwise they are just inialization values if( .not.(ccohort%isnew) ) then + ! Turnover pools [kgC/day] * [day/yr] = [kgC/yr] + sapw_c_turnover = ccohort%prt%GetTurnover(sapw_organ, all_carbon_elements) * days_per_year + store_c_turnover = ccohort%prt%GetTurnover(store_organ, all_carbon_elements) * days_per_year + leaf_c_turnover = ccohort%prt%GetTurnover(leaf_organ, all_carbon_elements) * days_per_year + fnrt_c_turnover = ccohort%prt%GetTurnover(fnrt_organ, all_carbon_elements) * days_per_year + struct_c_turnover = ccohort%prt%GetTurnover(struct_organ, all_carbon_elements) * days_per_year + + ! Net change from allocation and transport [kgC/day] * [day/yr] = [kgC/yr] + sapw_c_net_alloc = ccohort%prt%GetNetAlloc(sapw_organ, all_carbon_elements) * days_per_year + store_c_net_alloc = ccohort%prt%GetNetAlloc(store_organ, all_carbon_elements) * days_per_year + leaf_c_net_alloc = ccohort%prt%GetNetAlloc(leaf_organ, all_carbon_elements) * days_per_year + fnrt_c_net_alloc = ccohort%prt%GetNetAlloc(fnrt_organ, all_carbon_elements) * days_per_year + struct_c_net_alloc = ccohort%prt%GetNetAlloc(struct_organ, all_carbon_elements) * days_per_year + repro_c_net_alloc = ccohort%prt%GetNetAlloc(repro_organ, all_carbon_elements) * days_per_year + + ! ecosystem-level, organ-partitioned NPP/allocation fluxes + hio_npp_leaf_si(io_si) = hio_npp_leaf_si(io_si) + leaf_c_net_alloc * n_perm2 + hio_npp_seed_si(io_si) = hio_npp_seed_si(io_si) + repro_c_net_alloc * n_perm2 + hio_npp_stem_si(io_si) = hio_npp_stem_si(io_si) + (sapw_c_net_alloc + struct_c_net_alloc) * n_perm2 * & + (EDPftvarcon_inst%allom_agb_frac(ccohort%pft)) + hio_npp_froot_si(io_si) = hio_npp_froot_si(io_si) + fnrt_c_net_alloc * n_perm2 + hio_npp_croot_si(io_si) = hio_npp_croot_si(io_si) + (sapw_c_net_alloc + struct_c_net_alloc) * n_perm2 * & + (1._r8-EDPftvarcon_inst%allom_agb_frac(ccohort%pft)) + hio_npp_stor_si(io_si) = hio_npp_stor_si(io_si) + store_c_net_alloc * n_perm2 + + + associate( scpf => ccohort%size_by_pft_class, & scls => ccohort%size_class ) @@ -1685,39 +1734,25 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_npp_totl_si_scpf(io_si,scpf) = hio_npp_totl_si_scpf(io_si,scpf) + & ccohort%npp_acc_hold *n_perm2 hio_npp_leaf_si_scpf(io_si,scpf) = hio_npp_leaf_si_scpf(io_si,scpf) + & - ccohort%npp_leaf*n_perm2 + leaf_c_net_alloc*n_perm2 hio_npp_fnrt_si_scpf(io_si,scpf) = hio_npp_fnrt_si_scpf(io_si,scpf) + & - ccohort%npp_fnrt*n_perm2 + fnrt_c_net_alloc*n_perm2 hio_npp_bgsw_si_scpf(io_si,scpf) = hio_npp_bgsw_si_scpf(io_si,scpf) + & - ccohort%npp_sapw*n_perm2* & + sapw_c_net_alloc*n_perm2* & (1._r8-EDPftvarcon_inst%allom_agb_frac(ccohort%pft)) hio_npp_agsw_si_scpf(io_si,scpf) = hio_npp_agsw_si_scpf(io_si,scpf) + & - ccohort%npp_sapw*n_perm2* & + sapw_c_net_alloc*n_perm2* & EDPftvarcon_inst%allom_agb_frac(ccohort%pft) hio_npp_bgdw_si_scpf(io_si,scpf) = hio_npp_bgdw_si_scpf(io_si,scpf) + & - ccohort%npp_dead*n_perm2* & + struct_c_net_alloc*n_perm2* & (1._r8-EDPftvarcon_inst%allom_agb_frac(ccohort%pft)) hio_npp_agdw_si_scpf(io_si,scpf) = hio_npp_agdw_si_scpf(io_si,scpf) + & - ccohort%npp_dead*n_perm2* & + struct_c_net_alloc*n_perm2* & EDPftvarcon_inst%allom_agb_frac(ccohort%pft) hio_npp_seed_si_scpf(io_si,scpf) = hio_npp_seed_si_scpf(io_si,scpf) + & - ccohort%npp_seed*n_perm2 + repro_c_net_alloc*n_perm2 hio_npp_stor_si_scpf(io_si,scpf) = hio_npp_stor_si_scpf(io_si,scpf) + & - ccohort%npp_stor*n_perm2 - - npp_partition_error = abs(ccohort%npp_acc_hold-(ccohort%npp_leaf+ccohort%npp_fnrt+ & - ccohort%npp_sapw+ccohort%npp_dead+ & - ccohort%npp_seed+ccohort%npp_stor)) - if( npp_partition_error > 100.0_r8*calloc_abs_error ) then - write(fates_log(),*) 'NPP Partitions are not balancing' - write(fates_log(),*) 'Absolute Error [kgC/day]: ',npp_partition_error - write(fates_log(),*) 'Fractional Error: ', abs(npp_partition_error/ccohort%npp_acc_hold) - write(fates_log(),*) 'Terms: ',ccohort%npp_acc_hold,ccohort%npp_leaf,ccohort%npp_fnrt, & - ccohort%npp_sapw,ccohort%npp_dead, & - ccohort%npp_seed,ccohort%npp_stor - write(fates_log(),*) ' NPP components during FATES-HLM linking does not balance ' - call endrun(msg=errMsg(__FILE__, __LINE__)) - end if + store_c_net_alloc*n_perm2 ! Woody State Variables (basal area and number density and mortality) if (EDPftvarcon_inst%woody(ft) == 1) then @@ -1752,13 +1787,14 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! growth increment hio_ddbh_si_scpf(io_si,scpf) = hio_ddbh_si_scpf(io_si,scpf) + & ccohort%ddbhdt*ccohort%n + end if hio_agb_si_scls(io_si,scls) = hio_agb_si_scls(io_si,scls) + & - ccohort%b_total() * ccohort%n * EDPftvarcon_inst%allom_agb_frac(ccohort%pft) * AREA_INV + total_c * ccohort%n * EDPftvarcon_inst%allom_agb_frac(ccohort%pft) * AREA_INV hio_biomass_si_scls(io_si,scls) = hio_biomass_si_scls(io_si,scls) + & - ccohort%b_total() * ccohort%n * AREA_INV + total_c * ccohort%n * AREA_INV ! update size-class x patch-age related quantities @@ -1782,7 +1818,9 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%n * ccohort%npp_acc_hold * AREA_INV hio_biomass_si_agepft(io_si,iagepft) = hio_biomass_si_agepft(io_si,iagepft) + & - ccohort%b_total() * ccohort%n * AREA_INV + total_c * ccohort%n * AREA_INV + + ! update SCPF/SCLS- and canopy/subcanopy- partitioned quantities if (ccohort%canopy_layer .eq. 1) then @@ -1792,11 +1830,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_ddbh_canopy_si_scag(io_si,iscag) = hio_ddbh_canopy_si_scag(io_si,iscag) + & ccohort%ddbhdt*ccohort%n hio_bstor_canopy_si_scpf(io_si,scpf) = hio_bstor_canopy_si_scpf(io_si,scpf) + & - ccohort%bstore * ccohort%n + store_c * ccohort%n hio_bleaf_canopy_si_scpf(io_si,scpf) = hio_bleaf_canopy_si_scpf(io_si,scpf) + & - ccohort%bl * ccohort%n + leaf_c * ccohort%n - hio_canopy_biomass_pa(io_pa) = hio_canopy_biomass_pa(io_pa) + n_density * ccohort%b_total() * g_per_kg + hio_canopy_biomass_pa(io_pa) = hio_canopy_biomass_pa(io_pa) + n_density * total_c * 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%fmort + ccohort%frmort) * ccohort%n @@ -1832,49 +1870,41 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_canopy_mortality_carbonflux_si(io_si) = hio_canopy_mortality_carbonflux_si(io_si) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%fmort + ccohort%frmort) * & - ccohort%b_total() * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + & - (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra)* ccohort%b_total() * & + total_c * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_c * & ccohort%n * g_per_kg * ha_per_m2 - hio_leaf_md_canopy_si_scls(io_si,scls) = hio_leaf_md_canopy_si_scls(io_si,scls) + & - ccohort%leaf_md * ccohort%n - hio_root_md_canopy_si_scls(io_si,scls) = hio_root_md_canopy_si_scls(io_si,scls) + & - ccohort%root_md * ccohort%n hio_carbon_balance_canopy_si_scls(io_si,scls) = hio_carbon_balance_canopy_si_scls(io_si,scls) + & ccohort%n * ccohort%npp_acc_hold - + + + hio_leaf_md_canopy_si_scls(io_si,scls) = hio_leaf_md_canopy_si_scls(io_si,scls) + & + leaf_c_turnover * ccohort%n + hio_root_md_canopy_si_scls(io_si,scls) = hio_root_md_canopy_si_scls(io_si,scls) + & + fnrt_c_turnover * ccohort%n hio_bsw_md_canopy_si_scls(io_si,scls) = hio_bsw_md_canopy_si_scls(io_si,scls) + & - ccohort%bsw_md * ccohort%n + sapw_c_turnover * ccohort%n hio_bstore_md_canopy_si_scls(io_si,scls) = hio_bstore_md_canopy_si_scls(io_si,scls) + & - ccohort%bstore_md * ccohort%n + store_c_turnover * ccohort%n hio_bdead_md_canopy_si_scls(io_si,scls) = hio_bdead_md_canopy_si_scls(io_si,scls) + & - ccohort%bdead_md * ccohort%n + struct_c_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_dbdeaddt_canopy_si_scls(io_si,scls) = hio_dbdeaddt_canopy_si_scls(io_si,scls) + & - ccohort%dbdeaddt * ccohort%n - hio_dbstoredt_canopy_si_scls(io_si,scls) = hio_dbstoredt_canopy_si_scls(io_si,scls) + & - ccohort%dbstoredt * ccohort%n - hio_storage_flux_canopy_si_scls(io_si,scls) = hio_storage_flux_canopy_si_scls(io_si,scls) + & - ccohort%npp_stor * ccohort%n + ccohort%seed_prod * ccohort%n hio_npp_leaf_canopy_si_scls(io_si,scls) = hio_npp_leaf_canopy_si_scls(io_si,scls) + & - ccohort%npp_leaf * ccohort%n + leaf_c_net_alloc * ccohort%n hio_npp_fnrt_canopy_si_scls(io_si,scls) = hio_npp_fnrt_canopy_si_scls(io_si,scls) + & - ccohort%npp_fnrt * ccohort%n + fnrt_c_net_alloc * ccohort%n hio_npp_sapw_canopy_si_scls(io_si,scls) = hio_npp_sapw_canopy_si_scls(io_si,scls) + & - ccohort%npp_sapw * ccohort%n + sapw_c_net_alloc * ccohort%n hio_npp_dead_canopy_si_scls(io_si,scls) = hio_npp_dead_canopy_si_scls(io_si,scls) + & - ccohort%npp_dead * ccohort%n + struct_c_net_alloc * ccohort%n hio_npp_seed_canopy_si_scls(io_si,scls) = hio_npp_seed_canopy_si_scls(io_si,scls) + & - ccohort%npp_seed * ccohort%n + repro_c_net_alloc * ccohort%n hio_npp_stor_canopy_si_scls(io_si,scls) = hio_npp_stor_canopy_si_scls(io_si,scls) + & - ccohort%npp_stor * ccohort%n - - hio_dbalivedt_canopy_si_scls(io_si,scls) = hio_dbalivedt_canopy_si_scls(io_si,scls) + & - (ccohort%npp_leaf+ccohort%npp_fnrt+ccohort%npp_sapw+ccohort%npp_stor)* ccohort%n - + store_c_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 @@ -1885,13 +1915,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_ddbh_understory_si_scag(io_si,iscag) = hio_ddbh_understory_si_scag(io_si,iscag) + & ccohort%ddbhdt*ccohort%n hio_bstor_understory_si_scpf(io_si,scpf) = hio_bstor_understory_si_scpf(io_si,scpf) + & - ccohort%bstore * ccohort%n + store_c * ccohort%n hio_bleaf_understory_si_scpf(io_si,scpf) = hio_bleaf_understory_si_scpf(io_si,scpf) + & - ccohort%bl * ccohort%n + leaf_c * ccohort%n hio_understory_biomass_pa(io_pa) = hio_understory_biomass_pa(io_pa) + & - n_density * ccohort%b_total() * 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%fmort + ccohort%frmort) * ccohort%n + n_density * total_c * 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%fmort + ccohort%frmort ) * ccohort%n + & @@ -1925,48 +1953,39 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_understory_mortality_carbonflux_si(io_si) = hio_understory_mortality_carbonflux_si(io_si) + & (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%fmort + ccohort%frmort) * & - ccohort%b_total() * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + & - (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * ccohort%b_total() * & + total_c * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_c * & 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) + & - ccohort%leaf_md * ccohort%n + leaf_c_turnover * ccohort%n hio_root_md_understory_si_scls(io_si,scls) = hio_root_md_understory_si_scls(io_si,scls) + & - ccohort%root_md * ccohort%n + fnrt_c_turnover * ccohort%n hio_bsw_md_understory_si_scls(io_si,scls) = hio_bsw_md_understory_si_scls(io_si,scls) + & - ccohort%bsw_md * ccohort%n + sapw_c_turnover * ccohort%n hio_bstore_md_understory_si_scls(io_si,scls) = hio_bstore_md_understory_si_scls(io_si,scls) + & - ccohort%bstore_md * ccohort%n + store_c_turnover * ccohort%n hio_bdead_md_understory_si_scls(io_si,scls) = hio_bdead_md_understory_si_scls(io_si,scls) + & - ccohort%bdead_md * ccohort%n + struct_c_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_dbdeaddt_understory_si_scls(io_si,scls) = hio_dbdeaddt_understory_si_scls(io_si,scls) + & - ccohort%dbdeaddt * ccohort%n - hio_dbstoredt_understory_si_scls(io_si,scls) = hio_dbstoredt_understory_si_scls(io_si,scls) + & - ccohort%dbstoredt * ccohort%n - hio_storage_flux_understory_si_scls(io_si,scls) = hio_storage_flux_understory_si_scls(io_si,scls) + & - ccohort%npp_stor * ccohort%n hio_npp_leaf_understory_si_scls(io_si,scls) = hio_npp_leaf_understory_si_scls(io_si,scls) + & - ccohort%npp_leaf * ccohort%n + leaf_c_net_alloc * ccohort%n hio_npp_fnrt_understory_si_scls(io_si,scls) = hio_npp_fnrt_understory_si_scls(io_si,scls) + & - ccohort%npp_fnrt * ccohort%n + fnrt_c_net_alloc * ccohort%n hio_npp_sapw_understory_si_scls(io_si,scls) = hio_npp_sapw_understory_si_scls(io_si,scls) + & - ccohort%npp_sapw * ccohort%n + sapw_c_net_alloc * ccohort%n hio_npp_dead_understory_si_scls(io_si,scls) = hio_npp_dead_understory_si_scls(io_si,scls) + & - ccohort%npp_dead * ccohort%n + struct_c_net_alloc * ccohort%n hio_npp_seed_understory_si_scls(io_si,scls) = hio_npp_seed_understory_si_scls(io_si,scls) + & - ccohort%npp_seed * ccohort%n + repro_c_net_alloc * ccohort%n hio_npp_stor_understory_si_scls(io_si,scls) = hio_npp_stor_understory_si_scls(io_si,scls) + & - ccohort%npp_stor * ccohort%n - - hio_dbalivedt_understory_si_scls(io_si,scls) = hio_dbalivedt_understory_si_scls(io_si,scls) + & - (ccohort%npp_leaf+ccohort%npp_fnrt+ccohort%npp_sapw+ccohort%npp_stor)* ccohort%n - + store_c_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 @@ -1974,8 +1993,26 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! ! 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 + ! end if ! resolve some canopy area profiles, both total and of occupied leaves @@ -2108,6 +2145,10 @@ subroutine update_history_dyn(this,nc,nsites,sites) 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) + ! + ! 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 ! @@ -2118,6 +2159,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) sites(s)%terminated_nindivs(:,:,:) = 0._r8 sites(s)%imort_carbonflux = 0._r8 sites(s)%imort_rate(:,:) = 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 @@ -3744,6 +3787,16 @@ subroutine define_history_vars(this, initialize_variables) 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, & @@ -4048,16 +4101,6 @@ subroutine define_history_vars(this, initialize_variables) 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='DBALIVEDT_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='DBALIVEDT for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_dbalivedt_canopy_si_scls ) - - call this%set_history_var(vname='DBALIVEDT_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='DBALIVEDT for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_dbalivedt_understory_si_scls ) - call this%set_history_var(vname='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, & @@ -4113,21 +4156,6 @@ subroutine define_history_vars(this, initialize_variables) 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='DBDEADDT_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='DBDEADDT for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_dbdeaddt_canopy_si_scls ) - - call this%set_history_var(vname='DBSTOREDT_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='DBSTOREDT for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_dbstoredt_canopy_si_scls ) - - call this%set_history_var(vname='STORAGE_FLUX_CANOPY_SCLS', units = 'kg C / ha / yr', & - long='STORAGE_FLUX for canopy plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storage_flux_canopy_si_scls ) - call this%set_history_var(vname='NPP_LEAF_CANOPY_SCLS', units = 'kg C / ha / yr', & long='NPP_LEAF for canopy plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=-999.9_r8, & @@ -4238,21 +4266,6 @@ subroutine define_history_vars(this, initialize_variables) 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='DBDEADDT_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='DBDEADDT for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_dbdeaddt_understory_si_scls ) - - call this%set_history_var(vname='DBSTOREDT_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='DBSTOREDT for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_dbstoredt_understory_si_scls ) - - call this%set_history_var(vname='STORAGE_FLUX_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & - long='STORAGE_FLUX for understory plants by size class', use_default='inactive', & - avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & - upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storage_flux_understory_si_scls ) - call this%set_history_var(vname='NPP_LEAF_UNDERSTORY_SCLS', units = 'kg C / ha / yr', & long='NPP_LEAF for understory plants by size class', use_default='inactive', & avgflag='A', vtype=site_size_r8, hlms='CLM:ALM', flushval=0.0_r8, & diff --git a/main/FatesIntegratorsMod.F90 b/main/FatesIntegratorsMod.F90 index df51fd6c5d..5171180184 100644 --- a/main/FatesIntegratorsMod.F90 +++ b/main/FatesIntegratorsMod.F90 @@ -1,8 +1,5 @@ module FatesIntegratorsMod - use EDTypesMod , only : ed_site_type - use EDTypesMod , only : ed_patch_type - use EDTypesMod , only : ed_cohort_type use FatesConstantsMod, only : r8 => fates_r8 implicit none @@ -13,7 +10,7 @@ module FatesIntegratorsMod contains - subroutine RKF45(DerivFunction,Y,Ymask,dx,x,ccohort,max_err,Yout,l_pass) + subroutine RKF45(DerivFunction,Y,Ymask,dx,x,max_err,param_array,Yout,opt_dx,l_pass) ! --------------------------------------------------------------------------------- ! Runge-Kutta-Fehlerg 4/5 order adaptive explicit integration @@ -27,9 +24,11 @@ subroutine RKF45(DerivFunction,Y,Ymask,dx,x,ccohort,max_err,Yout,l_pass) logical,intent(in), dimension(:) :: Ymask ! logical mask defining what is on real(r8),intent(in) :: dx ! step size of independent variable real(r8),intent(in) :: x ! independent variable (time?) - type(ed_cohort_type),intent(inout),target :: ccohort ! Cohort derived type real(r8),intent(in) :: max_err ! Maximum allowable error (absolute) + real(r8),intent(in), dimension(:) :: param_array ! Arbitrary space for parameters real(r8),intent(inout), dimension(:) :: Yout ! The output vector + real(r8),intent(out) :: opt_dx ! Optimum step size based + ! on estimated error logical,intent(out) :: l_pass ! Was this a successfully step? ! Locals @@ -84,96 +83,93 @@ subroutine RKF45(DerivFunction,Y,Ymask,dx,x,ccohort,max_err,Yout,l_pass) ! Input Functional Argument interface - function DerivFunction(Y,Ymask,x,ccohort) result(dYdx) - use EDTypesMod , only : ed_site_type - use EDTypesMod , only : ed_patch_type - use EDTypesMod , only : ed_cohort_type - use FatesConstantsMod, only : r8 => fates_r8 - real(r8),intent(in), dimension(:) :: Y ! dependent variable (array) - logical,intent(in), dimension(:) :: Ymask ! logical mask defining what is on - real(r8),intent(in) :: x ! independent variable (time?) - type(ed_cohort_type),intent(in),target :: ccohort ! Cohort derived type - real(r8),dimension(lbound(Y,dim=1):ubound(Y,dim=1)) :: dYdx ! Derivative of dependent variable - end function DerivFunction - end interface - - nY = size(Y,1) - - ! 0th Step - Ytemp(1:nY) = Y(1:nY) - xtemp = x - K0(1:nY) = DerivFunction(Ytemp(1:nY),Ymask,xtemp,ccohort) - - ! 1st Step - Ytemp(1:nY) = Y(1:nY) + dx * (f1_0*K0(1:nY)) - xtemp = x + t1*dx - K1(1:nY) = DerivFunction(Ytemp(1:nY),Ymask,xtemp,ccohort) - - ! 2nd Step - Ytemp(1:nY) = Y(1:nY) + dx * ( f2_0*K0(1:nY) + f2_1*K1(1:nY) ) - xtemp = x + t2*dx - K2(1:nY) = DerivFunction(Ytemp(1:nY),Ymask,xtemp,ccohort) - - ! 3rd Step - Ytemp(1:nY) = Y(1:nY) + dx * ( f3_0*K0(1:nY) + f3_1*K1(1:nY) + & - f3_2*K2(1:nY)) - xtemp = x + t3*dx - K3(1:nY) = DerivFunction(Ytemp(1:nY),Ymask,xtemp,ccohort) - - ! 4th Step - Ytemp(1:nY) = Y(1:nY) + dx * ( f4_0*K0(1:nY) + f4_1*K1(1:nY) + & - f4_2*K2(1:nY) + f4_3*K3(1:nY)) - xtemp = x + t4*dx - K4(1:nY) = DerivFunction(Ytemp(1:nY),Ymask,xtemp,ccohort) - - ! 5th Step - Ytemp(1:nY) = Y(1:nY) + dx * ( f5_0*K0(1:nY) + f5_1*K1(1:nY) + & - f5_2*K2(1:nY) + f5_3*K3(1:nY) + & - f5_4*K4(1:nY)) - xtemp = x + t5*dx - K5(1:nY) = DerivFunction(Ytemp(1:nY),Ymask,xtemp,ccohort) - - - ! Evaluate error on the 4/5 steps - - ! 4th order - Ytemp(1:nY) = Y(1:nY) + dx * ( y_0*K0(1:nY) + y_2*K2(1:nY) + & - y_3*K3(1:nY) + y_4*K4(1:nY) ) - ! 5th order - Yout(1:nY) = Y(1:nY) + dx * ( z_0*K0(1:nY) + z_2*K2(1:nY) + & - z_3*K3(1:nY) + z_4*K4(1:nY) + & - z_5*K5(1:nY) ) - - ! Take the maximum absolute error across all variables - ! To prevent weirdness set a nominal lower bound - err45 = maxval(abs(Yout(1:nY)-Ytemp(1:nY))) - - ! -------------------------------------------------------------------------------- - ! Evaluate error and either approve/reject step. - ! - ! Update our estimate of the optimal time-step. We won't update - ! the current time-step based on this, but we will save this info - ! to help decide the starting sub-step on the next full step - ! The equations may be so smooth that the error estimate is so low that it creates - ! an overflow on the divide, set a lower bound based on max_err. - ! 1e-5, as an error ratio will shorten the timestep to ~5% of original - ! -------------------------------------------------------------------------------- - - ccohort%ode_opt_step = dx * max(min_step_fraction, & - 0.840896 * (max_err/ max(err45,0.00001*max_err))**0.25) - - if(err45 > max_err) then - l_pass = .false. - else - l_pass = .true. - end if + function DerivFunction(Y,Ymask,x,param_array) result(dYdx) + use FatesConstantsMod, only : r8 => fates_r8 + real(r8),intent(in), dimension(:) :: Y ! dependent variable (array) + logical,intent(in), dimension(:) :: Ymask ! logical mask defining what is on + real(r8),intent(in) :: x ! independent variable (time?) + real(r8),intent(in), dimension(:) :: param_array + real(r8),dimension(lbound(Y,dim=1):ubound(Y,dim=1)) :: dYdx ! Derivative of dependent variable + end function DerivFunction + end interface + + nY = size(Y,1) + + ! 0th Step + Ytemp(1:nY) = Y(1:nY) + xtemp = x + K0(1:nY) = DerivFunction(Ytemp(1:nY),Ymask,xtemp,param_array) + + ! 1st Step + Ytemp(1:nY) = Y(1:nY) + dx * (f1_0*K0(1:nY)) + xtemp = x + t1*dx + K1(1:nY) = DerivFunction(Ytemp(1:nY),Ymask,xtemp,param_array) + + ! 2nd Step + Ytemp(1:nY) = Y(1:nY) + dx * ( f2_0*K0(1:nY) + f2_1*K1(1:nY) ) + xtemp = x + t2*dx + K2(1:nY) = DerivFunction(Ytemp(1:nY),Ymask,xtemp,param_array) + + ! 3rd Step + Ytemp(1:nY) = Y(1:nY) + dx * ( f3_0*K0(1:nY) + f3_1*K1(1:nY) + & + f3_2*K2(1:nY)) + xtemp = x + t3*dx + K3(1:nY) = DerivFunction(Ytemp(1:nY),Ymask,xtemp,param_array) + + ! 4th Step + Ytemp(1:nY) = Y(1:nY) + dx * ( f4_0*K0(1:nY) + f4_1*K1(1:nY) + & + f4_2*K2(1:nY) + f4_3*K3(1:nY)) + xtemp = x + t4*dx + K4(1:nY) = DerivFunction(Ytemp(1:nY),Ymask,xtemp,param_array) + + ! 5th Step + Ytemp(1:nY) = Y(1:nY) + dx * ( f5_0*K0(1:nY) + f5_1*K1(1:nY) + & + f5_2*K2(1:nY) + f5_3*K3(1:nY) + & + f5_4*K4(1:nY)) + xtemp = x + t5*dx + K5(1:nY) = DerivFunction(Ytemp(1:nY),Ymask,xtemp,param_array) - return + + ! Evaluate error on the 4/5 steps + + ! 4th order + Ytemp(1:nY) = Y(1:nY) + dx * ( y_0*K0(1:nY) + y_2*K2(1:nY) + & + y_3*K3(1:nY) + y_4*K4(1:nY) ) + ! 5th order + Yout(1:nY) = Y(1:nY) + dx * ( z_0*K0(1:nY) + z_2*K2(1:nY) + & + z_3*K3(1:nY) + z_4*K4(1:nY) + & + z_5*K5(1:nY) ) + + ! Take the maximum absolute error across all variables + ! To prevent weirdness set a nominal lower bound + err45 = maxval(abs(Yout(1:nY)-Ytemp(1:nY))) + + ! -------------------------------------------------------------------------------- + ! Evaluate error and either approve/reject step. + ! + ! Update our estimate of the optimal time-step. We won't update + ! the current time-step based on this, but we will save this info + ! to help decide the starting sub-step on the next full step + ! The equations may be so smooth that the error estimate is so low that it creates + ! an overflow on the divide, set a lower bound based on max_err. + ! 1e-5, as an error ratio will shorten the timestep to ~5% of original + ! -------------------------------------------------------------------------------- + + opt_dx = dx * max(min_step_fraction, & + 0.840896 * (max_err/ max(err45,0.00001*max_err))**0.25) + + if(err45 > max_err) then + l_pass = .false. + else + l_pass = .true. + end if + + return end subroutine RKF45 - + ! =================================================================================== - subroutine Euler(DerivFunction,Y,Ymask,dx,x,ccohort,Yout) + subroutine Euler(DerivFunction,Y,Ymask,dx,x,param_array,Yout) ! --------------------------------------------------------------------------------- ! Simple Euler Integration @@ -185,7 +181,7 @@ subroutine Euler(DerivFunction,Y,Ymask,dx,x,ccohort,Yout) logical,intent(in), dimension(:) :: Ymask ! logical mask defining what is on real(r8),intent(in) :: dx ! step size of independent variable real(r8),intent(in) :: x ! independent variable (time?) - type(ed_cohort_type),intent(inout),target :: ccohort ! Cohort derived type + real(r8),intent(in), dimension(:) :: param_array ! Arbitrary space for parameters real(r8),intent(inout), dimension(:) :: Yout ! The output vector ! Locals @@ -196,22 +192,19 @@ subroutine Euler(DerivFunction,Y,Ymask,dx,x,ccohort,Yout) ! Input Functional Argument interface - function DerivFunction(Y,Ymask,x,ccohort) result(dYdx) - use EDTypesMod , only : ed_site_type - use EDTypesMod , only : ed_patch_type - use EDTypesMod , only : ed_cohort_type - use FatesConstantsMod, only : r8 => fates_r8 - real(r8),intent(in), dimension(:) :: Y ! dependent variable (array) - logical,intent(in), dimension(:) :: Ymask ! logical mask defining what is on - real(r8),intent(in) :: x ! independent variable (time?) - type(ed_cohort_type),intent(in),target :: ccohort ! Cohort derived type + function DerivFunction(Y,Ymask,x,param_array) result(dYdx) + use FatesConstantsMod, only : r8 => fates_r8 + real(r8),intent(in), dimension(:) :: Y ! dependent variable (array) + logical,intent(in), dimension(:) :: Ymask ! logical mask defining what is on + real(r8),intent(in) :: x ! independent variable (time?) + real(r8),intent(in), dimension(:) :: param_array real(r8),dimension(lbound(Y,dim=1):ubound(Y,dim=1)) :: dYdx ! Derivative of dependent variable end function DerivFunction end interface nY = size(Y,1) - dYdx(1:nY) = DerivFunction(Y(1:nY),Ymask,x,ccohort) + dYdx(1:nY) = DerivFunction(Y(1:nY),Ymask,x,param_array) Yout(1:nY) = Y(1:nY) + dx * dYdx(1:nY) diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index 8d97369643..e0af48ddd3 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -27,7 +27,10 @@ module FatesInterfaceMod use EDPftvarcon , only : FatesCheckParams use EDPftvarcon , only : EDPftvarcon_inst use EDParamsMod , only : FatesReportParams - + use PRTGenericMod , only : prt_carbon_allom_hyp + use PRTGenericMod , only : prt_cnp_flex_allom_hyp + use PRTAllometricCarbonMod, only : InitPRTGlobalAllometricCarbon + ! use PRTAllometricCNPMod, only : InitPRTGlobalAllometricCNP ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -40,6 +43,7 @@ module FatesInterfaceMod public :: SetFatesTime public :: set_fates_global_elements public :: FatesReportParameters + public :: InitPARTEHGlobals character(len=*), parameter, private :: sourcefile = & __FILE__ @@ -104,6 +108,10 @@ module FatesInterfaceMod ! compare it to our maxpatchpersite, ! and gracefully halt if we are over-allocating + integer, protected :: hlm_parteh_mode ! This flag signals which Plant Allocation and Reactive + ! Transport (exensible) Hypothesis (PARTEH) to use + + integer, protected :: hlm_use_vertsoilc ! This flag signals whether or not the ! host model is using vertically discretized ! soil carbon @@ -592,7 +600,7 @@ subroutine FatesInterfaceInit(log_unit,global_verbose) logical, intent(in) :: global_verbose call FatesGlobalsInit(log_unit,global_verbose) - + end subroutine FatesInterfaceInit ! ==================================================================================== @@ -1211,6 +1219,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_ipedof = unset_int hlm_max_patch_per_site = unset_int hlm_use_vertsoilc = unset_int + hlm_parteh_mode = unset_int hlm_use_spitfire = unset_int hlm_use_planthydro = unset_int hlm_use_logging = unset_int @@ -1372,6 +1381,13 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if(hlm_parteh_mode .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(), *) 'switch deciding which plant reactive transport model to use is unset, hlm_parteh_mode, exiting' + end if + 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' @@ -1449,6 +1465,12 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) if (fates_global_verbose()) then write(fates_log(),*) 'Transfering hlm_use_vertsoilc= ',ival,' to FATES' end if + + case('parteh_mode') + hlm_parteh_mode = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_parteh_mode= ',ival,' to FATES' + end if case('use_spitfire') hlm_use_spitfire = ival @@ -1551,9 +1573,43 @@ subroutine FatesReportParameters(masterproc) call FatesReportPFTParams(masterproc) call FatesReportParams(masterproc) - call FatesCheckParams(masterproc) + call FatesCheckParams(masterproc,hlm_parteh_mode) return end subroutine FatesReportParameters + ! ==================================================================================== + + subroutine InitPARTEHGlobals() + + ! Initialize the Plant Allocation and Reactive Transport + ! global functions and mapping tables + + select case(hlm_parteh_mode) + case(prt_carbon_allom_hyp) + + call InitPRTGlobalAllometricCarbon() + + case(prt_cnp_flex_allom_hyp) + + !call InitPRTGlobalAllometricCNP() + write(fates_log(),*) 'You specified the allometric CNP mode' + write(fates_log(),*) 'with relaxed target stoichiometry.' + write(fates_log(),*) 'I.e., namelist parametre fates_parteh_mode = 2' + write(fates_log(),*) 'This mode is not available yet. Please set it to 1.' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + case DEFAULT + write(fates_log(),*) 'You specified an unknown PRT module' + write(fates_log(),*) 'Check your setting for fates_parteh_mode' + write(fates_log(),*) 'in the CLM namelist. The only valid value now is 1' + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end select + + + + end subroutine InitPARTEHGlobals + end module FatesInterfaceMod diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 4ec037f746..5c682a9f02 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -34,7 +34,7 @@ module FatesInventoryInitMod use EDTypesMod , only : ed_cohort_type use EDTypesMod , only : area use EDPftvarcon , only : EDPftvarcon_inst - use EDTypesMod , only : init_dense_forest + implicit none private @@ -797,8 +797,11 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & real(r8) :: b_leaf ! biomass in leaves [kgC] real(r8) :: b_fineroot ! biomass in fine roots [kgC] real(r8) :: b_sapwood ! biomass in sapwood [kgC] + real(r8) :: b_dead + real(r8) :: b_store real(r8) :: a_sapwood ! area of sapwood at reference height [m2] + character(len=128),parameter :: wr_fmt = & '(F7.1,2X,A20,2X,A20,2X,F5.2,2X,F5.2,2X,I4,2X,F5.2,2X,F5.2,2X,F5.2,2X,F5.2)' @@ -900,9 +903,9 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & ! Calculate sapwood biomass call bsap_allom(temp_cohort%dbh,c_pft,temp_cohort%canopy_trim, a_sapwood, b_sapwood) - call bdead_allom( b_agw, b_bgw, b_sapwood, c_pft, temp_cohort%bdead ) + call bdead_allom( b_agw, b_bgw, b_sapwood, c_pft, b_dead ) - call bstore_allom(temp_cohort%dbh, c_pft, temp_cohort%canopy_trim,temp_cohort%bstore) + call bstore_allom(temp_cohort%dbh, c_pft, temp_cohort%canopy_trim, b_store) if( EDPftvarcon_inst%evergreen(c_pft) == 1) then temp_cohort%laimemory = 0._r8 @@ -929,11 +932,9 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & endif ! Since spread is a canopy level calculation, we need to provide an initial guess here. - site_spread = 0.5_r8 - if(init_dense_forest)site_spread = 0.0_r8 call create_cohort(csite, cpatch, c_pft, temp_cohort%n, temp_cohort%hite, temp_cohort%dbh, & - b_leaf, b_fineroot, b_sapwood, temp_cohort%bdead, temp_cohort%bstore, & - temp_cohort%laimemory, cstatus, rstatus, temp_cohort%canopy_trim, 1, site_spread, bc_in) + b_leaf, b_fineroot, b_sapwood, b_dead, b_store, & + temp_cohort%laimemory, cstatus, rstatus, temp_cohort%canopy_trim, 1, csite%spread, bc_in) deallocate(temp_cohort) ! get rid of temporary cohort diff --git a/main/FatesParameterDerivedMod.F90 b/main/FatesParameterDerivedMod.F90 index 7bbaec6ad5..9da1eeb01e 100644 --- a/main/FatesParameterDerivedMod.F90 +++ b/main/FatesParameterDerivedMod.F90 @@ -23,8 +23,6 @@ module FatesParameterDerivedMod ! rate at 25C (umol CO2/m**2/s) real(r8), allocatable :: kp25top(:) ! canopy top: initial slope of CO2 response ! curve (C4 plants) at 25C - real(r8), allocatable :: lmr25top(:) ! canopy top: leaf maintenance respiration - ! rate at 25C (umol CO2/m**2/s) contains procedure :: Init @@ -45,7 +43,6 @@ subroutine InitAllocate(this,numpft) allocate(this%jmax25top(numpft)) allocate(this%tpu25top(numpft)) allocate(this%kp25top(numpft)) - allocate(this%lmr25top(numpft)) return end subroutine InitAllocate @@ -63,19 +60,11 @@ subroutine Init(this,numpft) integer :: ft ! pft index real(r8) :: lnc ! leaf N concentration (gN leaf/m^2) - associate( & - - vcmax25top => EDPftvarcon_inst%vcmax25top, & ! - slatop => EDPftvarcon_inst%slatop , & ! specific leaf area at top of canopy, - ! projected area basis [m^2/gC] - leafcn => EDPftvarcon_inst%leafcn ) ! leaf C:N (gC/gN) + associate( vcmax25top => EDPftvarcon_inst%vcmax25top ) call this%InitAllocate(numpft) do ft = 1,numpft - - ! Leaf nitrogen concentration at the top of the canopy (g N leaf / m**2 leaf) - lnc = 1._r8 / (slatop(ft) * leafcn(ft)) ! Parameters derived from vcmax25top. ! Bonan et al (2011) JGR, 116, doi:10.1029/2010JG001593 @@ -92,17 +81,7 @@ subroutine Init(this,numpft) this%tpu25top(ft) = 0.167_r8 * vcmax25top(ft) this%kp25top(ft) = 20000._r8 * vcmax25top(ft) - ! Leaf maintenance respiration to match the base rate used in CN - ! but with the new temperature functions for C3 and C4 plants. - ! - ! - ! CN respiration has units: g C / g N [leaf] / s. This needs to be - ! converted from g C / g N [leaf] / s to umol CO2 / m**2 [leaf] / s - ! - ! Then scale this value at the top of the canopy for canopy depth - this%lmr25top(ft) = 2.525e-6_r8 * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) - this%lmr25top(ft) = this%lmr25top(ft) * lnc / (umolC_to_kgC * g_per_kg) end do !ft diff --git a/main/FatesParametersInterface.F90 b/main/FatesParametersInterface.F90 index 9a310f8aaf..8af57330dc 100644 --- a/main/FatesParametersInterface.F90 +++ b/main/FatesParametersInterface.F90 @@ -29,6 +29,7 @@ module FatesParametersInterface character(len=*), parameter, public :: dimension_name_allpfts = 'fates_allpfts' character(len=*), parameter, public :: dimension_name_variants = 'fates_variants' character(len=*), parameter, public :: dimension_name_hydr_organs = 'fates_hydr_organs' + character(len=*), parameter, public :: dimension_name_prt_organs = 'fates_prt_organs' character(len=*), parameter, public :: dimension_name_history_size_bins = 'fates_history_size_bins' 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' diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index a2309df53c..cfc929580d 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -13,6 +13,9 @@ module FatesRestartInterfaceMod use FatesInterfaceMod, only : bc_in_type use FatesSizeAgeTypeIndicesMod, only : get_sizeage_class_index + use PRTGenericMod, only : prt_global + + ! CIME GLOBALS use shr_log_mod , only : errMsg => shr_log_errMsg @@ -72,22 +75,14 @@ module FatesRestartInterfaceMod integer, private :: ir_seedrainflux_si integer, private :: ir_trunk_product_si integer, private :: ir_ncohort_pa - integer, private :: ir_bsw_co - integer, private :: ir_bdead_co - integer, private :: ir_bleaf_co - integer, private :: ir_broot_co - integer, private :: ir_bstore_co + integer, private :: ir_canopy_layer_co integer, private :: ir_canopy_layer_yesterday_co integer, private :: ir_canopy_trim_co + integer, private :: ir_size_class_lasttimestep_co integer, private :: ir_dbh_co integer, private :: ir_height_co integer, private :: ir_laimemory_co - integer, private :: ir_leaf_md_co - integer, private :: ir_root_md_co - integer, private :: ir_sapwood_md_co - integer, private :: ir_dead_md_co - integer, private :: ir_store_md_co integer, private :: ir_nplant_co integer, private :: ir_gpp_acc_co integer, private :: ir_npp_acc_co @@ -95,15 +90,7 @@ module FatesRestartInterfaceMod integer, private :: ir_gpp_acc_hold_co integer, private :: ir_npp_acc_hold_co integer, private :: ir_resp_acc_hold_co - integer, private :: ir_npp_leaf_co - integer, private :: ir_npp_froot_co - integer, private :: ir_npp_sw_co - integer, private :: ir_npp_dead_co - integer, private :: ir_npp_seed_co - integer, private :: ir_npp_store_co - - integer, private :: ir_ode_opt_step_co - + integer, private :: ir_bmort_co integer, private :: ir_hmort_co integer, private :: ir_cmort_co @@ -117,8 +104,6 @@ module FatesRestartInterfaceMod integer, private :: ir_ddbhdt_co - integer, private :: ir_dbdeaddt_co - integer, private :: ir_dbstoredt_co integer, private :: ir_resp_tstep_co integer, private :: ir_pft_co integer, private :: ir_status_co @@ -141,6 +126,9 @@ module FatesRestartInterfaceMod integer, private :: ir_fabi_sha_paclftls integer, private :: ir_watermem_siwm + integer, private :: ir_prt_base ! Base index for all PRT variables + + ! The number of variable dim/kind types we have defined (static) integer, parameter :: fates_restart_num_dimensions = 2 !(cohort,column) integer, parameter :: fates_restart_num_dim_kinds = 4 !(cohort-int,cohort-r8,site-int,site-r8) @@ -149,6 +137,11 @@ module FatesRestartInterfaceMod integer, parameter :: old_cohort = 0 integer, parameter :: new_cohort = 1 + real(r8), parameter :: flushinvalid = -9999.0 + real(r8), parameter :: flushzero = 0.0 + real(r8), parameter :: flushone = 1.0 + + ! Local debug flag logical, parameter :: debug=.false. @@ -207,6 +200,7 @@ module FatesRestartInterfaceMod procedure, private :: flush_rvars procedure, private :: define_restart_vars procedure, private :: set_restart_var + procedure, private :: DefinePRTRestartVars end type fates_restart_interface_type @@ -486,10 +480,7 @@ subroutine define_restart_vars(this, initialize_variables) class(fates_restart_interface_type), intent(inout) :: this logical, intent(in) :: initialize_variables ! are we 'count'ing or 'initializ'ing? integer :: ivar - real(r8), parameter :: flushinvalid = -9999.0 - real(r8), parameter :: flushzero = 0.0 - real(r8), parameter :: flushone = 1.0 - + ivar=0 @@ -621,27 +612,6 @@ subroutine define_restart_vars(this, initialize_variables) ! 1D cohort Variables ! ----------------------------------------------------------------------------------- - call this%set_restart_var(vname='fates_bsw', vtype=cohort_r8, & - long_name='ed cohort sapwood biomass', units='kgC/indiv', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bsw_co ) - - call this%set_restart_var(vname='fates_bdead', vtype=cohort_r8, & - long_name='ed cohort - dead (structural) biomass in living plants', & - units='kgC/indiv', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bdead_co ) - - call this%set_restart_var(vname='fates_bl', vtype=cohort_r8, & - long_name='ed cohort - leaf biomass', units='kgC/indiv', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bleaf_co ) - - call this%set_restart_var(vname='fates_br', vtype=cohort_r8, & - long_name='ed cohort - fine root biomass', units='kgC/indiv', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_broot_co ) - - call this%set_restart_var(vname='fates_bstore', vtype=cohort_r8, & - long_name='ed cohort - storage biomass', units='kgC/indiv', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bstore_co ) - call this%set_restart_var(vname='fates_canopy_layer', vtype=cohort_r8, & long_name='ed cohort - canopy_layer', units='unitless', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_layer_co ) @@ -654,6 +624,10 @@ subroutine define_restart_vars(this, initialize_variables) long_name='ed cohort - canopy_trim', units='fraction', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_canopy_trim_co ) + call this%set_restart_var(vname='fates_size_class_lasttimestep', vtype=cohort_int, & + long_name='ed cohort - size-class last timestep', units='index', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_size_class_lasttimestep_co ) + call this%set_restart_var(vname='fates_dbh', vtype=cohort_r8, & long_name='ed cohort - diameter at breast height', units='cm', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dbh_co ) @@ -667,31 +641,6 @@ subroutine define_restart_vars(this, initialize_variables) units='kgC/indiv', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_laimemory_co ) - call this%set_restart_var(vname='fates_leaf_maint_dmnd', vtype=cohort_r8, & - long_name='ed cohort - leaf maintenance demand', & - units='kgC/indiv/year', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_leaf_md_co ) - - call this%set_restart_var(vname='fates_root_maint_dmnd', vtype=cohort_r8, & - long_name='ed cohort - fine root maintenance demand', & - units='kgC/indiv', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_root_md_co ) - - call this%set_restart_var(vname='fates_store_maint_dmnd', vtype=cohort_r8, & - long_name='ed cohort - storage maintenance demand', & - units='kgC/indiv', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_store_md_co ) - - call this%set_restart_var(vname='fates_sapwood_maint_dmnd', vtype=cohort_r8, & - long_name='ed cohort - sapwood maintenance demand', & - units='kgC/indiv', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_sapwood_md_co ) - - call this%set_restart_var(vname='fates_dead_maint_dmnd', vtype=cohort_r8, & - long_name='ed cohort - structure maintenance demand', & - units='kgC/indiv', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dead_md_co ) - call this%set_restart_var(vname='fates_nplant', vtype=cohort_r8, & long_name='ed cohort - number of plants in the cohort', & units='/patch', flushval = flushzero, & @@ -727,41 +676,6 @@ subroutine define_restart_vars(this, initialize_variables) units='kgC/indiv/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_resp_acc_hold_co ) - call this%set_restart_var(vname='fates_npp_leaf', vtype=cohort_r8, & - long_name='ed cohort - npp sent to leaves', & - units='kgC/indiv/day', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_leaf_co ) - - call this%set_restart_var(vname='fates_npp_froot', vtype=cohort_r8, & - long_name='ed cohort - npp sent to fine roots', & - units='kgC/indiv/day', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_froot_co ) - - call this%set_restart_var(vname='fates_npp_sapwood', vtype=cohort_r8, & - long_name='ed cohort - npp sent to sapwood', & - units='kgC/indiv/day', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_sw_co ) - - call this%set_restart_var(vname='fates_npp_bdead', vtype=cohort_r8, & - long_name='ed cohort - npp sent to dead (structure) biomass in live plants', & - units='kgC/indiv/day', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_dead_co ) - - call this%set_restart_var(vname='fates_npp_seed', vtype=cohort_r8, & - long_name='ed cohort - npp sent to seed biomass', & - units='kgC/indiv/day', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_seed_co ) - - call this%set_restart_var(vname='fates_npp_store', vtype=cohort_r8, & - long_name='ed cohort - npp sent to storage biomass', & - units='kgC/indiv/day', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_npp_store_co ) - - call this%set_restart_var(vname='fates_ode_opt_step', vtype=cohort_r8, & - long_name='ed cohort - current ode integrator step size', & - units='-', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_ode_opt_step_co) - call this%set_restart_var(vname='fates_bmort', vtype=cohort_r8, & long_name='ed cohort - background mortality rate', & units='/year', flushval = flushzero, & @@ -802,22 +716,11 @@ subroutine define_restart_vars(this, initialize_variables) units='%/event', flushval = flushzero, & 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', & units='cm/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_ddbhdt_co ) - call this%set_restart_var(vname='fates_dbdeaddt', vtype=cohort_r8, & - long_name='ed cohort - differential: ddbh/dt', & - units='cm/year', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dbdeaddt_co ) - - call this%set_restart_var(vname='fates_dbstoredt', vtype=cohort_r8, & - long_name='ed cohort - differential: ddbh/dt', & - units='cm/year', flushval = flushzero, & - hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_dbstoredt_co ) - call this%set_restart_var(vname='fates_resp_tstep', vtype=cohort_r8, & long_name='ed cohort - autotrophic respiration over timestep', & units='kgC/indiv/timestep', flushval = flushzero, & @@ -927,13 +830,149 @@ subroutine define_restart_vars(this, initialize_variables) long_name='last 10 days of volumetric soil water, by site x day-index', & units='m3/m3', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_watermem_siwm ) - + + + ! 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 - + end subroutine define_restart_vars + + ! ===================================================================================== + + subroutine DefinePRTRestartVars(this,initialize_variables,ivar) + + ! ---------------------------------------------------------------------------------- + ! 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 + ! our list of ojbects. + ! + ! We do have to loop through the different parts of the objects indepenently. + ! For instance we can't have one loop that covers the states "val", and + ! the net allocation and reactive transport flux "net_alloc", so we have to loop + ! these each separately. As other fluxes are added in the future, they need + ! their own definition. + ! + ! Some of the code below is about parsing the strings of these objects + ! and automatically building the names of the PARTEH output variables + ! as we go. + ! + ! Note that parteh variables may or may not be scalars. Each variable's + ! position gets its own variable in the restart file. So the variable + ! name will also parse the string for that position. + ! ----------------------------------------------------------------------------------- + + + use FatesIOVariableKindMod, only : cohort_r8 + + 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 + integer :: i_pos ! loop counter for discrete position + + character(len=32) :: symbol_base ! Symbol name without position or flux type + character(len=128) :: name_base ! name without position or flux type + character(len=4) :: pos_symbol + character(len=128) :: symbol + character(len=256) :: long_name + + do i_var = 1, prt_global%num_vars + + ! 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 + + ! Register the instantaneous state variable "val" + ! ---------------------------------------------------------------------------- + + ! The symbol that is written to file + symbol = trim(symbol_base)//'_val_'//trim(pos_symbol) + + ! The expanded long name of the variable + long_name = trim(name_base)//', state var, 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 ) + + ! Register the turnover flux variables + ! ---------------------------------------------------------------------------- + + ! The symbol that is written to file + symbol = trim(symbol_base)//'_turn_'//trim(pos_symbol) + + ! 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 ) + + + + ! Register the net allocation flux variable + ! ---------------------------------------------------------------------------- + + ! The symbol that is written to file + symbol = trim(symbol_base)//'_net_'//trim(pos_symbol) + + ! The expanded long name of the variable + long_name = trim(name_base)//', net allocation/transp, 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 ) + + + + ! Register the burn flux variable + ! ---------------------------------------------------------------------------- + ! The symbol that is written to file + symbol = trim(symbol_base)//'_burned_'//trim(pos_symbol) + + ! The expanded long name of the variable + long_name = trim(name_base)//', burned mass:'//trim(pos_symbol) + + call this%set_restart_var(vname=symbol, & + vtype=cohort_r8, & + long_name=trim(long_name), & + units='kg', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, & + ivar=ivar, index = dummy_out ) + + end do + end do + + return + end subroutine DefinePRTRestartVars ! ===================================================================================== @@ -1034,7 +1073,10 @@ subroutine set_restart_vectors(this,nc,nsites,sites) integer :: ft ! functional type index integer :: k,j,i ! indices to the radiation matrix - + integer :: ir_prt_var ! loop counter for var x position + integer :: i_var ! loop counter for PRT variables + integer :: i_pos ! loop counter for discrete PRT positions + type(fates_restart_variable_type) :: rvar type(ed_patch_type),pointer :: cpatch type(ed_cohort_type),pointer :: ccohort @@ -1065,22 +1107,13 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_seedrainflux_si => this%rvars(ir_seedrainflux_si)%r81d, & rio_trunk_product_si => this%rvars(ir_trunk_product_si)%r81d, & rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d, & - rio_bsw_co => this%rvars(ir_bsw_co)%r81d, & - rio_bdead_co => this%rvars(ir_bdead_co)%r81d, & - rio_bleaf_co => this%rvars(ir_bleaf_co)%r81d, & - rio_broot_co => this%rvars(ir_broot_co)%r81d, & - rio_bstore_co => this%rvars(ir_bstore_co)%r81d, & rio_canopy_layer_co => this%rvars(ir_canopy_layer_co)%r81d, & rio_canopy_layer_yesterday_co => this%rvars(ir_canopy_layer_yesterday_co)%r81d, & rio_canopy_trim_co => this%rvars(ir_canopy_trim_co)%r81d, & + rio_size_class_lasttimestep => this%rvars(ir_size_class_lasttimestep_co)%int1d, & rio_dbh_co => this%rvars(ir_dbh_co)%r81d, & rio_height_co => this%rvars(ir_height_co)%r81d, & rio_laimemory_co => this%rvars(ir_laimemory_co)%r81d, & - rio_leaf_md_co => this%rvars(ir_leaf_md_co)%r81d, & - rio_root_md_co => this%rvars(ir_root_md_co)%r81d, & - rio_store_md_co => this%rvars(ir_store_md_co)%r81d, & - rio_sapwood_md_co => this%rvars(ir_sapwood_md_co)%r81d, & - rio_dead_md_co => this%rvars(ir_dead_md_co)%r81d, & rio_nplant_co => this%rvars(ir_nplant_co)%r81d, & rio_gpp_acc_co => this%rvars(ir_gpp_acc_co)%r81d, & rio_npp_acc_co => this%rvars(ir_npp_acc_co)%r81d, & @@ -1088,14 +1121,6 @@ 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_npp_leaf_co => this%rvars(ir_npp_leaf_co)%r81d, & - rio_npp_froot_co => this%rvars(ir_npp_froot_co)%r81d, & - rio_npp_sw_co => this%rvars(ir_npp_sw_co)%r81d, & - rio_npp_dead_co => this%rvars(ir_npp_dead_co)%r81d, & - rio_npp_seed_co => this%rvars(ir_npp_seed_co)%r81d, & - rio_npp_store_co => this%rvars(ir_npp_store_co)%r81d, & - - rio_ode_opt_step_co => this%rvars(ir_ode_opt_step_co)%r81d, & rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & @@ -1106,8 +1131,6 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_lmort_collateral_co => this%rvars(ir_lmort_collateral_co)%r81d, & rio_lmort_infra_co => this%rvars(ir_lmort_infra_co)%r81d, & rio_ddbhdt_co => this%rvars(ir_ddbhdt_co)%r81d, & - rio_dbdeaddt_co => this%rvars(ir_dbdeaddt_co)%r81d, & - rio_dbstoredt_co => this%rvars(ir_dbstoredt_co)%r81d, & rio_resp_tstep_co => this%rvars(ir_resp_tstep_co)%r81d, & rio_pft_co => this%rvars(ir_pft_co)%int1d, & rio_status_co => this%rvars(ir_status_co)%int1d, & @@ -1188,23 +1211,45 @@ subroutine set_restart_vectors(this,nc,nsites,sites) write(fates_log(),*) 'CLTV lowerbound ', lbound(rio_npp_acc_co,1) write(fates_log(),*) 'CLTV upperbound ', ubound(rio_npp_acc_co,1) endif - - rio_bsw_co(io_idx_co) = ccohort%bsw - rio_bdead_co(io_idx_co) = ccohort%bdead - rio_bleaf_co(io_idx_co) = ccohort%bl - rio_broot_co(io_idx_co) = ccohort%br - rio_bstore_co(io_idx_co) = ccohort%bstore + + + ! Fill output arrays of PRT variables + ! We just loop through the objects, and reference our members relative + ! the base index of the PRT variables + ! ----------------------------------------------------------------------- + + 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) + + 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) + + 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 + + rio_canopy_layer_co(io_idx_co) = ccohort%canopy_layer rio_canopy_layer_yesterday_co(io_idx_co) = ccohort%canopy_layer_yesterday rio_canopy_trim_co(io_idx_co) = ccohort%canopy_trim + rio_size_class_lasttimestep(io_idx_co) = ccohort%size_class_lasttimestep rio_dbh_co(io_idx_co) = ccohort%dbh rio_height_co(io_idx_co) = ccohort%hite rio_laimemory_co(io_idx_co) = ccohort%laimemory - rio_leaf_md_co(io_idx_co) = ccohort%leaf_md - rio_root_md_co(io_idx_co) = ccohort%root_md - rio_store_md_co(io_idx_co) = ccohort%bstore_md - rio_sapwood_md_co(io_idx_co) = ccohort%bsw_md - rio_dead_md_co(io_idx_co) = ccohort%bdead_md + rio_nplant_co(io_idx_co) = ccohort%n rio_gpp_acc_co(io_idx_co) = ccohort%gpp_acc rio_npp_acc_co(io_idx_co) = ccohort%npp_acc @@ -1212,13 +1257,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_gpp_acc_hold_co(io_idx_co) = ccohort%gpp_acc_hold rio_resp_acc_hold_co(io_idx_co) = ccohort%resp_acc_hold rio_npp_acc_hold_co(io_idx_co) = ccohort%npp_acc_hold - rio_npp_leaf_co(io_idx_co) = ccohort%npp_leaf - rio_npp_froot_co(io_idx_co) = ccohort%npp_fnrt - rio_npp_sw_co(io_idx_co) = ccohort%npp_sapw - rio_npp_dead_co(io_idx_co) = ccohort%npp_dead - rio_npp_seed_co(io_idx_co) = ccohort%npp_seed - rio_npp_store_co(io_idx_co) = ccohort%npp_stor - rio_ode_opt_step_co(io_idx_co) = ccohort%ode_opt_step + rio_bmort_co(io_idx_co) = ccohort%bmort rio_hmort_co(io_idx_co) = ccohort%hmort rio_cmort_co(io_idx_co) = ccohort%cmort @@ -1231,8 +1270,6 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_lmort_infra_co(io_idx_co) = ccohort%lmort_infra rio_ddbhdt_co(io_idx_co) = ccohort%ddbhdt - rio_dbdeaddt_co(io_idx_co) = ccohort%dbdeaddt - rio_dbstoredt_co(io_idx_co) = ccohort%dbstoredt rio_resp_tstep_co(io_idx_co) = ccohort%resp_tstep rio_pft_co(io_idx_co) = ccohort%pft rio_status_co(io_idx_co) = ccohort%status_coh @@ -1421,6 +1458,8 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) integer :: idx_pa ! local patch index integer :: io_idx_si ! global site index in IO vector integer :: io_idx_co_1st ! global cohort index in IO vector + real(r8) :: b_dead ! dummy structural biomass (kgC) + real(r8) :: b_store ! dummy storage carbon (kgC) real(r8) :: b_leaf ! leaf biomass dummy var (kgC) real(r8) :: b_fineroot ! fineroot dummy var (kgC) real(r8) :: b_sapwood ! sapwood dummy var (kgC) @@ -1495,8 +1534,7 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) allocate(temp_cohort) temp_cohort%n = 700.0_r8 - temp_cohort%bdead = 0.0_r8 - temp_cohort%bstore = 0.0_r8 + temp_cohort%laimemory = 0.0_r8 temp_cohort%canopy_trim = 1.0_r8 temp_cohort%canopy_layer = 1.0_r8 @@ -1514,14 +1552,16 @@ subroutine create_patchcohort_structure(this, nc, nsites, sites, bc_in) write(fates_log(),*) 'EDRestVectorMod.F90::createPatchCohortStructure call create_cohort ' end if + b_dead = 0.0_r8 + b_store = 0.0_r8 b_leaf = 0.0_r8 b_fineroot = 0.0_r8 b_sapwood = 0.0_r8 site_spread = 0.5_r8 call create_cohort(sites(s),newp, temp_cohort%pft, temp_cohort%n, temp_cohort%hite, temp_cohort%dbh, & - b_leaf, b_fineroot, b_sapwood, temp_cohort%bdead, temp_cohort%bstore, & - temp_cohort%laimemory, cohortstatus,recruitstatus, temp_cohort%canopy_trim, newp%NCL_p, & - site_spread, bc_in(s)) + b_leaf, b_fineroot, b_sapwood, b_dead, b_store, & + temp_cohort%laimemory, cohortstatus,recruitstatus, temp_cohort%canopy_trim, newp%NCL_p, & + site_spread, bc_in(s)) deallocate(temp_cohort) @@ -1623,7 +1663,9 @@ subroutine get_restart_vectors(this, nc, nsites, sites) integer :: totalcohorts ! total cohort count on this thread (diagnostic) integer :: patchespersite ! number of patches per site integer :: cohortsperpatch ! number of cohorts per patch - + integer :: ir_prt_var ! loop counter for var x position + integer :: i_var ! loop counter for PRT variables + integer :: i_pos ! loop counter for discrete PRT positions associate( rio_npatch_si => this%rvars(ir_npatch_si)%int1d, & @@ -1651,22 +1693,13 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_seedrainflux_si => this%rvars(ir_seedrainflux_si)%r81d, & rio_trunk_product_si => this%rvars(ir_trunk_product_si)%r81d, & rio_ncohort_pa => this%rvars(ir_ncohort_pa)%int1d, & - rio_bsw_co => this%rvars(ir_bsw_co)%r81d, & - rio_bdead_co => this%rvars(ir_bdead_co)%r81d, & - rio_bleaf_co => this%rvars(ir_bleaf_co)%r81d, & - rio_broot_co => this%rvars(ir_broot_co)%r81d, & - rio_bstore_co => this%rvars(ir_bstore_co)%r81d, & rio_canopy_layer_co => this%rvars(ir_canopy_layer_co)%r81d, & rio_canopy_layer_yesterday_co => this%rvars(ir_canopy_layer_yesterday_co)%r81d, & rio_canopy_trim_co => this%rvars(ir_canopy_trim_co)%r81d, & + rio_size_class_lasttimestep => this%rvars(ir_size_class_lasttimestep_co)%int1d, & rio_dbh_co => this%rvars(ir_dbh_co)%r81d, & rio_height_co => this%rvars(ir_height_co)%r81d, & rio_laimemory_co => this%rvars(ir_laimemory_co)%r81d, & - rio_leaf_md_co => this%rvars(ir_leaf_md_co)%r81d, & - rio_root_md_co => this%rvars(ir_root_md_co)%r81d, & - rio_sapwood_md_co => this%rvars(ir_sapwood_md_co)%r81d, & - rio_store_md_co => this%rvars(ir_store_md_co)%r81d, & - rio_dead_md_co => this%rvars(ir_dead_md_co)%r81d, & rio_nplant_co => this%rvars(ir_nplant_co)%r81d, & rio_gpp_acc_co => this%rvars(ir_gpp_acc_co)%r81d, & rio_npp_acc_co => this%rvars(ir_npp_acc_co)%r81d, & @@ -1674,15 +1707,7 @@ 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_npp_leaf_co => this%rvars(ir_npp_leaf_co)%r81d, & - rio_npp_froot_co => this%rvars(ir_npp_froot_co)%r81d, & - rio_npp_sw_co => this%rvars(ir_npp_sw_co)%r81d, & - rio_npp_dead_co => this%rvars(ir_npp_dead_co)%r81d, & - rio_npp_seed_co => this%rvars(ir_npp_seed_co)%r81d, & - rio_npp_store_co => this%rvars(ir_npp_store_co)%r81d, & - - rio_ode_opt_step_co => this%rvars(ir_ode_opt_step_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, & @@ -1694,8 +1719,6 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_lmort_infra_co => this%rvars(ir_lmort_infra_co)%r81d, & rio_ddbhdt_co => this%rvars(ir_ddbhdt_co)%r81d, & - rio_dbdeaddt_co => this%rvars(ir_dbdeaddt_co)%r81d, & - rio_dbstoredt_co => this%rvars(ir_dbstoredt_co)%r81d, & rio_resp_tstep_co => this%rvars(ir_resp_tstep_co)%r81d, & rio_pft_co => this%rvars(ir_pft_co)%int1d, & rio_status_co => this%rvars(ir_status_co)%int1d, & @@ -1761,22 +1784,40 @@ subroutine get_restart_vectors(this, nc, nsites, sites) write(fates_log(),*) 'CVTL io_idx_co ',io_idx_co endif - ccohort%bsw = rio_bsw_co(io_idx_co) - ccohort%bdead = rio_bdead_co(io_idx_co) - ccohort%bl = rio_bleaf_co(io_idx_co) - ccohort%br = rio_broot_co(io_idx_co) - ccohort%bstore = rio_bstore_co(io_idx_co) + ! Fill PRT state variables with array data + ! We just loop through the objects, and reference our members relative + ! the base index of the PRT variables + ! ----------------------------------------------------------------------- + + 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 + ccohort%prt%variables(i_var)%val(i_pos) = & + this%rvars(ir_prt_var)%r81d(io_idx_co) + + ir_prt_var = ir_prt_var + 1 + ccohort%prt%variables(i_var)%turnover(i_pos) = & + this%rvars(ir_prt_var)%r81d(io_idx_co) + + ir_prt_var = ir_prt_var + 1 + ccohort%prt%variables(i_var)%net_alloc(i_pos) = & + this%rvars(ir_prt_var)%r81d(io_idx_co) + + ir_prt_var = ir_prt_var + 1 + ccohort%prt%variables(i_var)%burned(i_pos) = & + this%rvars(ir_prt_var)%r81d(io_idx_co) + end do + end do + ccohort%canopy_layer = rio_canopy_layer_co(io_idx_co) ccohort%canopy_layer_yesterday = rio_canopy_layer_yesterday_co(io_idx_co) ccohort%canopy_trim = rio_canopy_trim_co(io_idx_co) + ccohort%size_class_lasttimestep = rio_size_class_lasttimestep(io_idx_co) ccohort%dbh = rio_dbh_co(io_idx_co) ccohort%hite = rio_height_co(io_idx_co) ccohort%laimemory = rio_laimemory_co(io_idx_co) - ccohort%leaf_md = rio_leaf_md_co(io_idx_co) - ccohort%root_md = rio_root_md_co(io_idx_co) - ccohort%bstore_md = rio_store_md_co(io_idx_co) - ccohort%bsw_md = rio_sapwood_md_co(io_idx_co) - ccohort%bdead_md = rio_dead_md_co(io_idx_co) ccohort%n = rio_nplant_co(io_idx_co) ccohort%gpp_acc = rio_gpp_acc_co(io_idx_co) ccohort%npp_acc = rio_npp_acc_co(io_idx_co) @@ -1784,13 +1825,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%gpp_acc_hold = rio_gpp_acc_hold_co(io_idx_co) ccohort%resp_acc_hold = rio_resp_acc_hold_co(io_idx_co) ccohort%npp_acc_hold = rio_npp_acc_hold_co(io_idx_co) - ccohort%npp_leaf = rio_npp_leaf_co(io_idx_co) - ccohort%npp_fnrt = rio_npp_froot_co(io_idx_co) - ccohort%npp_sapw = rio_npp_sw_co(io_idx_co) - ccohort%npp_dead = rio_npp_dead_co(io_idx_co) - ccohort%npp_seed = rio_npp_seed_co(io_idx_co) - ccohort%npp_stor = rio_npp_store_co(io_idx_co) - ccohort%ode_opt_step = rio_ode_opt_step_co(io_idx_co) + ccohort%bmort = rio_bmort_co(io_idx_co) ccohort%hmort = rio_hmort_co(io_idx_co) ccohort%cmort = rio_cmort_co(io_idx_co) @@ -1803,8 +1838,6 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%lmort_infra = rio_lmort_infra_co(io_idx_co) ccohort%ddbhdt = rio_ddbhdt_co(io_idx_co) - ccohort%dbdeaddt = rio_dbdeaddt_co(io_idx_co) - ccohort%dbstoredt = rio_dbstoredt_co(io_idx_co) ccohort%resp_tstep = rio_resp_tstep_co(io_idx_co) ccohort%pft = rio_pft_co(io_idx_co) ccohort%status_coh = rio_status_co(io_idx_co) diff --git a/parameter_files/fates_params_14pfts.cdl b/parameter_files/fates_params_14pfts.cdl index ab90b8fe17..39f1d6ee40 100644 --- a/parameter_files/fates_params_14pfts.cdl +++ b/parameter_files/fates_params_14pfts.cdl @@ -10,6 +10,7 @@ dimensions: fates_scalar = 1 ; fates_string_length = 60 ; fates_variants = 2 ; + fates_prt_organs = 6 ; variables: float fates_history_height_bin_edges(fates_history_height_bins) ; fates_history_height_bin_edges:units = "m" ; @@ -119,6 +120,9 @@ variables: char fates_pftname(fates_pft, fates_string_length) ; fates_pftname:units = "unitless - string" ; fates_pftname:long_name = "Description of plant type" ; + char fates_prt_organ_name(fates_prt_organs, fates_string_length) ; + fates_prt_organ_name:units = "unitless - string" ; + fates_prt_organ_name:long_name = "Plant organ name (order must match PRTGenericMod.F90)" ; float 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" ; @@ -203,6 +207,47 @@ variables: float fates_branch_turnover(fates_pft) ; fates_branch_turnover:units = "yr-1" ; fates_branch_turnover:long_name = "turnover time of branches" ; + + float 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" ; + + float fates_prt_nitr_stoich_p2(fates_prt_organs,fates_pft) ; + fates_prt_nitr_stoich_p2:units = "(gN/gC)" ; + fates_prt_nitr_stoich_p2:long_name = "nitrogen stoichiometry, parameter 2" ; + + float fates_prt_phos_stoich_p1(fates_prt_organs,fates_pft) ; + fates_prt_phos_stoich_p1:units = "(gP/gC)" ; + fates_prt_phos_stoich_p1:long_name = "phosphorous stoichiometry, parameter 1" ; + + float fates_prt_phos_stoich_p2(fates_prt_organs,fates_pft) ; + fates_prt_phos_stoich_p2:units = "(gP/gC)" ; + fates_prt_phos_stoich_p2:long_name = "phosphorous stoichiometry, parameter 2" ; + + float 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" ; + + float 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" ; + + float fates_turnover_retrans_mode(fates_pft) ; + fates_turnover_retrans_mode:units = "index" ; + fates_turnover_retrans_mode:long_name = "retranslocation method for leaf/fineroot turnover" ; + + float fates_turnover_carb_retrans(fates_prt_organs,fates_pft) ; + fates_turnover_carb_retrans:units = "-" ; + fates_turnover_carb_retrans:long_name = "retranslocation fraction of carbon in turnover" ; + + float fates_turnover_nitr_retrans(fates_prt_organs,fates_pft) ; + fates_turnover_nitr_retrans:units = "-" ; + fates_turnover_nitr_retrans:long_name = "retranslocation fraction of nitrogen in turnover" ; + + float fates_turnover_phos_retrans(fates_prt_organs,fates_pft) ; + fates_turnover_phos_retrans:units = "-" ; + fates_turnover_phos_retrans:long_name = "retranslocation fraction of phosphorous in turnover, parameter 1" ; + float fates_c2b(fates_pft) ; fates_c2b:units = "ratio" ; fates_c2b:long_name = "Carbon to biomass multiplier of bulk structural tissues" ; @@ -230,9 +275,6 @@ variables: float fates_fr_flig(fates_pft) ; fates_fr_flig:units = "fraction" ; fates_fr_flig:long_name = "Fine root litter lignin fraction" ; - float fates_froot_cn_ratio(fates_pft) ; - fates_froot_cn_ratio:units = "gC/gN" ; - fates_froot_cn_ratio:long_name = "Fine root C:N" ; float fates_grperc(fates_pft) ; fates_grperc:units = "unitless" ; fates_grperc:long_name = "Growth respiration factor" ; @@ -273,7 +315,7 @@ variables: fates_hydr_rfrac_stem:units = "fraction" ; fates_hydr_rfrac_stem:long_name = "fraction of total tree resistance from troot to canopy" ; float fates_hydr_rs2(fates_pft) ; - fates_hydr_rs2:units = "mm" ; + fates_hydr_rs2:units = "m" ; fates_hydr_rs2:long_name = "absorbing root radius" ; float fates_hydr_srl(fates_pft) ; fates_hydr_srl:units = "m g-1" ; @@ -284,9 +326,6 @@ variables: float fates_leaf_BB_slope(fates_pft) ; fates_leaf_BB_slope:units = "unitless" ; fates_leaf_BB_slope:long_name = "stomatal slope parameter, as per Ball-Berry" ; - float fates_leaf_cn_ratio(fates_pft) ; - fates_leaf_cn_ratio:units = "gC/gN" ; - fates_leaf_cn_ratio:long_name = "Leaf C:N" ; float fates_leaf_c3psn(fates_pft) ; fates_leaf_c3psn:units = "flag" ; fates_leaf_c3psn:long_name = "Photosynthetic pathway (1=c3, 0=c4)" ; @@ -439,7 +478,7 @@ variables: fates_seed_alloc_mature:long_name = "fraction of available carbon balance allocated to seeds in mature plants (adds to fates_seed_alloc)" ; float fates_seed_dbh_repro_threshold(fates_pft) ; fates_seed_dbh_repro_threshold:units = "cm" ; - fates_seed_dbh_repro_threshold:long_name = "the diameter (if any) where the plant will start extra clonal allocation to the seed pool (NOT USED YET)" ; + fates_seed_dbh_repro_threshold:long_name = "the diameter (if any) where the plant will start extra clonal allocation to the seed pool" ; float fates_seed_decay_turnover(fates_pft) ; fates_seed_decay_turnover:units = "1/yr" ; fates_seed_decay_turnover:long_name = "turnover time for seeds with respect to germination" ; @@ -473,9 +512,6 @@ variables: float fates_trim_limit(fates_pft) ; fates_trim_limit:units = "m2/m2" ; fates_trim_limit:long_name = "Arbitrary limit to reductions in leaf area with stress" ; - float fates_wood_cn_ratio(fates_pft) ; - fates_wood_cn_ratio:units = "gC/gN" ; - fates_wood_cn_ratio:long_name = "Wood C:N" ; float fates_wood_density(fates_pft) ; fates_wood_density:units = "g/cm3" ; fates_wood_density:long_name = "mean density of woody tissue in plant" ; @@ -637,17 +673,25 @@ data: "broadleaf_evergreen_tropical_tree ", "needleleaf_evergreen_temperate_tree ", "needleleaf_evergreen_boreal_tree ", - "needleleaf_deciduous_boreal_tree (force evgrn)", + "needleleaf_deciduous_boreal_tree ", "broadleaf_evergreen_temperate_tree ", - "broadleaf_deciduous_tropical_tree (force evgrn)", - "broadleaf_deciduous_temperate_tree (force evgrn)", - "broadleaf_deciduous_boreal_tree (force evgrn)", + "broadleaf_deciduous_tropical_tree ", + "broadleaf_deciduous_temperate_tree ", + "broadleaf_deciduous_boreal_tree ", "broadleaf_evergreen_temperate_shrub ", - "broadleaf_deciduous_temperate_shrub (force evgrn)", - "broadleaf_deciduous_boreal_shrub (force evgrn)", - "arctic_c3_grass (force evgrn)", - "cool_c3_grass (force evgrn)", - "c4_grass (force evgrn)" ; + "broadleaf_deciduous_temperate_shrub ", + "broadleaf_deciduous_boreal_shrub ", + "arctic_c3_grass ", + "cool_c3_grass ", + "c4_grass " ; + + fates_prt_organ_name = + "leaf ", + "fine root ", + "sapwood ", + "storage ", + "reproduction ", + "structure "; fates_alloc_storage_cushion = 2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2 ; @@ -724,6 +768,77 @@ data: fates_branch_turnover = 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 0, 0, 0 ; + fates_prt_nitr_stoich_p1 = + 0.033, 0.029, 0.025, 0.04, 0.033, 0.04, 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.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, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, + 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 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; + + fates_prt_nitr_stoich_p2 = + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _; + + fates_prt_phos_stoich_p1 = + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _; + + fates_prt_phos_stoich_p2 = + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _; + + fates_prt_alloc_priority = + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _; + + fates_phenflush_fraction = + _, _, _, 0.5, _, 0.5, 0.5, 0.5, _, 0.5, 0.5, 0.5, 0.5, 0.5; + + fates_turnover_retrans_mode = + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1; + + fates_turnover_carb_retrans = + 0.025, 0.025, 0.025, 0.05, 0.025, 0.05, 0.05, 0.05, 0.025, 0.05, 0.05, 0.05, 0.05, 0.05, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, + 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00; + + + fates_turnover_nitr_retrans = + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _; + + fates_turnover_phos_retrans = + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _, + _, _, _, _, _, _, _, _, _, _, _, _, _, _; + fates_c2b = 2, 2, 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, @@ -750,8 +865,6 @@ data: 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, 0.25, 0.25 ; - fates_froot_cn_ratio = 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42, 42 ; - 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, 0.11, 0.11 ; @@ -853,8 +966,6 @@ data: fates_leaf_BB_slope = 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8 ; - fates_leaf_cn_ratio = 30, 35, 40, 25, 30, 25, 25, 25, 30, 25, 25, 25, 25, 25 ; - fates_leaf_c3psn = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 0 ; fates_leaf_clumping_index = 0.85, 0.85, 0.675, 0.8, 0.85, 0.85, 0.9, 0.75, @@ -1032,9 +1143,6 @@ data: fates_trim_limit = 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3 ; - fates_wood_cn_ratio = 210, 210, 210, 210, 210, 210, 210, 210, 210, 210, 210, - 210, 210, 210 ; - 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, 0.7, 0.7 ; diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index 946f22b254..9684fd2c27 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -5,6 +5,7 @@ dimensions: fates_history_height_bins = 6 ; fates_history_size_bins = 13 ; fates_hydr_organs = 4 ; + fates_prt_organs = 6 ; fates_litterclass = 6 ; fates_pft = 2 ; fates_scalar = 1 ; @@ -83,6 +84,9 @@ variables: char fates_pftname(fates_pft, fates_string_length) ; fates_pftname:units = "unitless - string" ; fates_pftname:long_name = "Description of plant type" ; + char fates_prt_organ_name(fates_prt_organs, fates_string_length) ; + fates_prt_organ_name:units = "unitless - string" ; + fates_prt_organ_name:long_name = "Plant organ name (order must match PRTGenericMod.F90)" ; float fates_rootprof_beta(fates_variants, fates_pft) ; fates_rootprof_beta:units = "unitless" ; fates_rootprof_beta:long_name = "Rooting beta parameter, for C and N vertical discretization (NOT USED BY DEFAULT)" ; @@ -170,6 +174,47 @@ variables: float fates_branch_turnover(fates_pft) ; fates_branch_turnover:units = "yr-1" ; fates_branch_turnover:long_name = "turnover time of branches" ; + + float 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" ; + + float fates_prt_nitr_stoich_p2(fates_prt_organs,fates_pft) ; + fates_prt_nitr_stoich_p2:units = "(gN/gC)" ; + fates_prt_nitr_stoich_p2:long_name = "nitrogen stoichiometry, parameter 2" ; + + float fates_prt_phos_stoich_p1(fates_prt_organs,fates_pft) ; + fates_prt_phos_stoich_p1:units = "(gP/gC)" ; + fates_prt_phos_stoich_p1:long_name = "phosphorous stoichiometry, parameter 1" ; + + float fates_prt_phos_stoich_p2(fates_prt_organs,fates_pft) ; + fates_prt_phos_stoich_p2:units = "(gP/gC)" ; + fates_prt_phos_stoich_p2:long_name = "phosphorous stoichiometry, parameter 2" ; + + float 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" ; + + float 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" ; + + float fates_turnover_retrans_mode(fates_pft) ; + fates_turnover_retrans_mode:units = "index" ; + fates_turnover_retrans_mode:long_name = "retranslocation method for leaf/fineroot turnover" ; + + float fates_turnover_carb_retrans(fates_prt_organs,fates_pft) ; + fates_turnover_carb_retrans:units = "-" ; + fates_turnover_carb_retrans:long_name = "retranslocation fraction of carbon in turnover" ; + + float fates_turnover_nitr_retrans(fates_prt_organs,fates_pft) ; + fates_turnover_nitr_retrans:units = "-" ; + fates_turnover_nitr_retrans:long_name = "retranslocation fraction of nitrogen in turnover" ; + + float fates_turnover_phos_retrans(fates_prt_organs,fates_pft) ; + fates_turnover_phos_retrans:units = "-" ; + fates_turnover_phos_retrans:long_name = "retranslocation fraction of phosphorous in turnover " ; + float fates_c2b(fates_pft) ; fates_c2b:units = "ratio" ; fates_c2b:long_name = "Carbon to biomass multiplier of bulk structural tissues" ; @@ -197,9 +242,6 @@ variables: float fates_fr_flig(fates_pft) ; fates_fr_flig:units = "fraction" ; fates_fr_flig:long_name = "Fine root litter lignin fraction" ; - float fates_froot_cn_ratio(fates_pft) ; - fates_froot_cn_ratio:units = "gC/gN" ; - fates_froot_cn_ratio:long_name = "Fine root C:N" ; float fates_grperc(fates_pft) ; fates_grperc:units = "unitless" ; fates_grperc:long_name = "Growth respiration factor" ; @@ -216,7 +258,7 @@ variables: fates_hydr_rfrac_stem:units = "fraction" ; fates_hydr_rfrac_stem:long_name = "fraction of total tree resistance from troot to canopy" ; float fates_hydr_rs2(fates_pft) ; - fates_hydr_rs2:units = "mm" ; + fates_hydr_rs2:units = "m" ; fates_hydr_rs2:long_name = "absorbing root radius" ; float fates_hydr_srl(fates_pft) ; fates_hydr_srl:units = "m g-1" ; @@ -230,9 +272,6 @@ variables: float fates_leaf_clumping_index(fates_pft) ; fates_leaf_clumping_index:units = "fraction (0-1)" ; fates_leaf_clumping_index:long_name = "factor describing how much self-occlusion of leaf scattering elements decreases light interception" ; - float fates_leaf_cn_ratio(fates_pft) ; - fates_leaf_cn_ratio:units = "gC/gN" ; - fates_leaf_cn_ratio:long_name = "Leaf C:N" ; float fates_leaf_diameter(fates_pft) ; fates_leaf_diameter:units = "m" ; fates_leaf_diameter:long_name = "Characteristic leaf dimension" ; @@ -376,7 +415,7 @@ variables: fates_seed_alloc_mature:long_name = "fraction of available carbon balance allocated to seeds in mature plants (adds to fates_seed_alloc)" ; float fates_seed_dbh_repro_threshold(fates_pft) ; fates_seed_dbh_repro_threshold:units = "cm" ; - fates_seed_dbh_repro_threshold:long_name = "the diameter (if any) where the plant will start extra clonal allocation to the seed pool (NOT USED YET)" ; + fates_seed_dbh_repro_threshold:long_name = "the diameter (if any) where the plant will start extra clonal allocation to the seed pool" ; float fates_seed_decay_turnover(fates_pft) ; fates_seed_decay_turnover:units = "1/yr" ; fates_seed_decay_turnover:long_name = "turnover time for seeds with respect to germination" ; @@ -410,9 +449,6 @@ variables: float fates_trim_limit(fates_pft) ; fates_trim_limit:units = "m2/m2" ; fates_trim_limit:long_name = "Arbitrary limit to reductions in leaf area with stress" ; - float fates_wood_cn_ratio(fates_pft) ; - fates_wood_cn_ratio:units = "gC/gN" ; - fates_wood_cn_ratio:long_name = "Wood C:N" ; float fates_wood_density(fates_pft) ; fates_wood_density:units = "g/cm3" ; fates_wood_density:long_name = "mean density of woody tissue in plant" ; @@ -621,10 +657,10 @@ data: -2.25, -2.25 ; fates_hydr_pinot_node = - -999, -999, - -999, -999, - -999, -999, - -999, -999 ; + -1.465984, -1.465984, + -1.228070, -1.228070, + -1.228070, -1.228070, + -1.043478, -1.043478 ; fates_hydr_pitlp_node = -1.67, -1.67, @@ -650,6 +686,14 @@ data: "broadleaf_evergreen_tropical_tree ", "broadleaf_evergreen_tropical_tree " ; + fates_prt_organ_name = + "leaf ", + "fine root ", + "sapwood ", + "storage ", + "reproduction ", + "structure "; + fates_rootprof_beta = 0.976, 0.976, _, _ ; @@ -710,6 +754,76 @@ data: fates_branch_turnover = 50, 50 ; + fates_prt_nitr_stoich_p1 = + 0.033, 0.033, + 0.024, 0.024, + 0.0047, 0.0047, + 0.0047, 0.0047, + 0.0, 0.0, + 0.0047, 0.0047; + + fates_prt_nitr_stoich_p2 = + _, _, + _, _, + _, _, + _, _, + _, _, + _, _; + + fates_prt_phos_stoich_p1 = + _, _, + _, _, + _, _, + _, _, + _, _, + _, _; + + fates_prt_phos_stoich_p2 = + _, _, + _, _, + _, _, + _, _, + _, _, + _, _; + + fates_prt_alloc_priority = + _, _, + _, _, + _, _, + _, _, + _, _, + _, _; + + fates_phenflush_fraction = + 0.5, 0.5; + + fates_turnover_retrans_mode = + 1, 1; + + fates_turnover_carb_retrans = + 0.00, 0.00, + 0.00, 0.00, + 0.00, 0.00, + 0.00, 0.00, + 0.00, 0.00, + 0.00, 0.00; + + fates_turnover_nitr_retrans = + _, _, + _, _, + _, _, + _, _, + _, _, + _, _; + + fates_turnover_phos_retrans = + _, _, + _, _, + _, _, + _, _, + _, _, + _, _; + fates_c2b = 2, 2 ; fates_displar = 0.67, 0.67 ; @@ -728,8 +842,6 @@ data: fates_fr_flig = 0.25, 0.25 ; - fates_froot_cn_ratio = 42, 42 ; - fates_grperc = 0.11, 0.11 ; fates_hydr_avuln_gs = 2.5, 2.5 ; @@ -750,8 +862,6 @@ data: fates_leaf_clumping_index = 0.85, 0.85 ; - fates_leaf_cn_ratio = 30, 30 ; - fates_leaf_diameter = 0.04, 0.04 ; fates_leaf_jmaxha = 43540, 43540 ; @@ -870,8 +980,6 @@ data: fates_trim_limit = 0.3, 0.3 ; - fates_wood_cn_ratio = 210, 210 ; - fates_wood_density = 0.7, 0.7 ; fates_woody = 1, 1 ; @@ -896,7 +1004,7 @@ data: fates_fire_nignitions = 15 ; - fates_hydr_kmax_rsurf = 0.001; + fates_hydr_kmax_rsurf = 20; fates_hydr_psi0 = 0 ; diff --git a/parteh/PRTAllometricCarbonMod.F90 b/parteh/PRTAllometricCarbonMod.F90 new file mode 100644 index 0000000000..8a2da57bc2 --- /dev/null +++ b/parteh/PRTAllometricCarbonMod.F90 @@ -0,0 +1,1071 @@ +module PRTAllometricCarbonMod + + ! ------------------------------------------------------------------------------------ + ! + ! This module contains all of the specific functions and types for + ! Plant Allocation and Reactive Transport Extensible Hypotheses (PARTEH) + ! CARBON only, allometric growth hypothesis + ! + ! Adapted from code originally in ED, by Rosie Fisher and Paul Moorcroft + ! This refactor written by : Ryan Knox Apr 2018 + ! + ! ------------------------------------------------------------------------------------ + + use PRTGenericMod , only : prt_global_type + use PRTGenericMod , only : prt_global + use PRTGenericMod , only : prt_vartype + use PRTGenericMod , only : prt_vartypes + use PRTGenericMod , only : carbon12_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 PRTGenericMod , only : un_initialized + + use FatesAllometryMod , only : bleaf + use FatesAllometryMod , only : bsap_allom + use FatesAllometryMod , only : bfineroot + use FatesAllometryMod , only : bstore_allom + use FatesAllometryMod , only : bdead_allom + use FatesAllometryMod , only : bbgw_allom + use FatesAllometryMod , only : bagw_allom + use FatesAllometryMod , only : h_allom + use FatesAllometryMod , only : CheckIntegratedAllometries + use FatesAllometryMod , only : StructureResetOfDH + + use FatesGlobals , only : endrun => fates_endrun + use FatesGlobals , only : fates_log + use shr_log_mod , only : errMsg => shr_log_errMsg + use FatesConstantsMod , only : r8 => fates_r8 + use FatesConstantsMod , only : i4 => fates_int + use FatesIntegratorsMod , only : RKF45 + use FatesIntegratorsMod , only : Euler + use EDPftvarcon , only : EDPftvarcon_inst + use FatesConstantsMod , only : calloc_abs_error + use FatesConstantsMod , only : nearzero + use FatesConstantsMod , only : itrue + + + implicit none + private + + ! ------------------------------------------------------------------------------------- + ! + ! Define the state variables for this specific hypothesis. + ! + ! ------------------------------------------------------------------------------------- + + integer, parameter :: leaf_c_id = 1 ! Unique object index for leaf carbon + integer, parameter :: fnrt_c_id = 2 ! Unique object index for fine-root carbon + integer, parameter :: sapw_c_id = 3 ! Unique object index for sapwood carbon + integer, parameter :: store_c_id = 4 ! Unique object index for storage carbon + integer, parameter :: repro_c_id = 5 ! Unique object index for reproductive carbon + integer, parameter :: struct_c_id = 6 ! Unique object index for structural carbon + integer, parameter :: num_vars = 6 ! THIS MUST MATCH THE LARGEST INDEX ABOVE + + + ! For this hypothesis, we integrate dbh along with the other 6. Since this + ! is a boundary condition, we do not add it to the state array, but we do want + ! to include it with the integrator array. + + integer, parameter :: dbh_id = 7 ! This is just used for the integrator + integer, parameter :: n_integration_vars = 7 + + + ! ------------------------------------------------------------------------------------- + ! Boundary Conditions + ! ------------------------------------------------------------------------------------- + ! Input Boundary Indices (These are public, and therefore + ! each boundary condition across all modules must + ! have a unique name !!!!) + ! ------------------------------------------------------------------------------------- + + integer, public, parameter :: ac_bc_inout_id_dbh = 1 ! Plant DBH + integer, public, parameter :: ac_bc_inout_id_netdc = 2 ! Index for the net daily C input BC + integer, parameter :: num_bc_inout = 2 ! Number of in & output boundary conditions + + + integer, public, parameter :: ac_bc_in_id_pft = 1 ! Index for the PFT input BC + integer, public, parameter :: ac_bc_in_id_ctrim = 2 ! Index for the canopy trim function + integer, parameter :: num_bc_in = 2 ! Number of input boundary condition + + ! THere are no purely output boundary conditions + integer, parameter :: num_bc_out = 0 ! Number of purely output boundary condtions + + ! ------------------------------------------------------------------------------------- + ! Define the size of the coorindate vector. For this hypothesis, there is only + ! one pool per each species x organ combination. + ! ------------------------------------------------------------------------------------- + integer, parameter :: icd = 1 ! Only 1 coordinate per variable + + + ! ------------------------------------------------------------------------------------- + ! This is the core type that holds this specific + ! plant reactive transport (PRT) module + ! ------------------------------------------------------------------------------------- + + + type, public, extends(prt_vartypes) :: callom_prt_vartypes + + contains + + procedure :: DailyPRT => DailyPRTAllometricCarbon + procedure :: FastPRT => FastPRTAllometricCarbon + + end type callom_prt_vartypes + + ! ------------------------------------------------------------------------------------ + ! + ! This next class is an extention of the base instance that maps state variables + ! to the outside model. + ! + ! ------------------------------------------------------------------------------------ + + character(len=*), parameter, private :: sourcefile = __FILE__ + + + ! This is the instance of the mapping table and variable definitions + ! this is only allocated once per node. This should be read-only + ! everywhere in the code, except for where it is populated in this init routine + ! below. + + class(prt_global_type), public, target, allocatable :: prt_global_ac + + + public :: InitPRTGlobalAllometricCarbon + + +contains + + + subroutine InitPRTGlobalAllometricCarbon() + + ! ---------------------------------------------------------------------------------- + ! Initialize and populate the object that holds the descriptions of the variables, + ! and contains the mappings of each variable to the pre-ordained organ + ! and species list, and the number of boundary conditions of each 3 types. + ! + ! This is called very early on in the call sequence of the model, and should occur + ! before any plants start being initialized. These mapping tables must + ! exist before that happens. This initialization only happens once on each + ! machine, and the mapping will be read-only, and a global thing. This step + ! is not initializing the data structures bound to the plants. + ! + ! There are two mapping tables. One mapping table is a 2d array organized + ! by organ and species, that contains the variable index: + ! + ! prt_global%sp_organ_map + ! + ! The other mapping table is similar, but it is a 1D array, a list of the organs. + ! And each of these the in turn points to a list of the indices associated + ! with that organ. This is useful when you want to do lots of stuff to a specified + ! organ. + ! + ! prt_global%organ_map + ! + ! IMPORTANT NOTE: Once this object is populated, we can use this to properly + ! allocate the "prt_vartypes_type" objects that attached to each plant. That process + ! is handled by generic functions, and does not need to be written in each hypothesis. + ! + ! ----------------------------------------------------------------------------------- + + allocate(prt_global_ac) + + ! The "state descriptor" object holds things like the names, the symbols, the units + ! of each variable. By putting it in an object, we can loop through them when + ! doing things like reading/writing history and restarts + + allocate(prt_global_ac%state_descriptor(num_vars)) + + prt_global_ac%hyp_name = 'Allometric Carbon Only' + + ! Set mapping tables to zero + call prt_global_ac%ZeroGlobal() + + ! Register the variables. Each variable must be associated with a global identifier + ! for an organ and species. + + call prt_global_ac%RegisterVarInGlobal(leaf_c_id,"Leaf Carbon","leaf_c",leaf_organ,carbon12_element,icd) + call prt_global_ac%RegisterVarInGlobal(fnrt_c_id,"Fine Root Carbon","fnrt_c",fnrt_organ,carbon12_element,icd) + call prt_global_ac%RegisterVarInGlobal(sapw_c_id,"Sapwood Carbon","sapw_c",sapw_organ,carbon12_element,icd) + call prt_global_ac%RegisterVarInGlobal(store_c_id,"Storage Carbon","store_c",store_organ,carbon12_element,icd) + call prt_global_ac%RegisterVarInGlobal(struct_c_id,"Structural Carbon","struct_c",struct_organ,carbon12_element,icd) + call prt_global_ac%RegisterVarInGlobal(repro_c_id,"Reproductive Carbon","repro_c",repro_organ,carbon12_element,icd) + + ! Set some of the array sizes for input and output boundary conditions + prt_global_ac%num_bc_in = num_bc_in + prt_global_ac%num_bc_out = num_bc_out + prt_global_ac%num_bc_inout = num_bc_inout + prt_global_ac%num_vars = num_vars + + ! Have the global generic pointer, point to this hypothesis' object + prt_global => prt_global_ac + + + return + end subroutine InitPRTGlobalAllometricCarbon + + ! ===================================================================================== + + + subroutine DailyPRTAllometricCarbon(this) + + ! ----------------------------------------------------------------------------------- + ! + ! This is the main routine that handles allocation associated with the 1st + ! hypothesis; carbon only, and growth governed by allometry + ! + ! This routine is explained in the technical documentation in detail. + ! + ! Some points: + ! 1) dbh, while not a PARTEH "state variable", is passed in from FATES (or other + ! model), is integrated along with the mass based state variables, and then + ! passed back to the ecosystem model. It is a "inout" style boundary condition. + ! + ! 2) It is assumed that both growth respiration, and maintenance respiration + ! costs have already been paid, and therefore the "carbon_balance" boundary + ! condition is the net carbon gained by the plant over the coarse of the day. + ! Think of "daily integrated NPP". + ! + ! 3) This routine will completely spend carbon_balance if it enters as a positive + ! value, or replace carbon balance (using storage) if it enters as a negative value. + ! + ! 4) It is assumed that the ecosystem model calling this routine has ensured that + ! the net amount of negative carbon is no greater than that which can be replaced + ! by storage. This routine will crash gracefully if that is not true. + ! + ! 5) Leaves and fine-roots are given top priority, but just to replace maintenance + ! turnover. This can also draw from strorage. + ! + ! 6) Storage is given next available carbon gain, either to push up to zero, + ! or to use it to top off stores. + ! + ! 7) Third priority is then given to leaves and fine-roots again, but can only use + ! carbon gain. Also, this transfer will attempt to get pools up to allometry. + ! + ! 8) Fourth priority is to bring other live pools up to allometry, and then structure. + ! + ! 9) Finally, if carbon is yet still available, it will grow all pools out concurrently + ! including some to reproduction. + ! + ! ---------------------------------------------------------------------------------- + + + ! The class is the only argument + class(callom_prt_vartypes) :: this ! this class + + ! ----------------------------------------------------------------------------------- + ! These are local copies of the in/out boundary condition structure + ! ----------------------------------------------------------------------------------- + + real(r8),pointer :: dbh ! Diameter at breast height [cm] + ! this local will point to both in and out bc's + real(r8),pointer :: carbon_balance ! Daily carbon balance for this cohort [kgC] + + real(r8) :: canopy_trim ! The canopy trimming function [0-1] + integer :: ipft ! Plant Functional Type index + + + real(r8) :: target_leaf_c ! target leaf carbon [kgC] + real(r8) :: target_fnrt_c ! target fine-root carbon [kgC] + real(r8) :: target_sapw_c ! target sapwood carbon [kgC] + real(r8) :: target_store_c ! target storage carbon [kgC] + real(r8) :: target_agw_c ! target above ground carbon in woody tissues [kgC] + real(r8) :: target_bgw_c ! target below ground carbon in woody tissues [kgC] + real(r8) :: target_struct_c ! target structural carbon [kgC] + + real(r8) :: sapw_area ! dummy var, x-section area of sapwood [m2] + + real(r8) :: leaf_below_target ! fineroot biomass below target amount [kgC] + real(r8) :: fnrt_below_target ! fineroot biomass below target amount [kgC] + real(r8) :: sapw_below_target ! sapwood biomass below target amount [kgC] + real(r8) :: store_below_target ! storage biomass below target amount [kgC] + real(r8) :: struct_below_target ! dead (structural) biomass below target amount [kgC] + real(r8) :: total_below_target ! total biomass below the allometric target [kgC] + + real(r8) :: flux_adj ! adjustment made to growth flux term to minimize error [kgC] + real(r8) :: store_target_fraction ! ratio between storage and leaf biomass when on allometry [kgC] + + real(r8) :: leaf_c_demand ! leaf carbon that is demanded to replace maintenance turnover [kgC] + real(r8) :: fnrt_c_demand ! fineroot carbon that is demanded to replace + ! maintenance turnover [kgC] + real(r8) :: total_c_demand ! total carbon that is demanded to replace maintenance turnover [kgC] + logical :: step_pass ! Did the integration step pass? + + real(r8) :: leaf_c_flux ! Transfer into leaves at various stages [kgC] + real(r8) :: fnrt_c_flux ! Transfer into fine-roots at various stages [kgC] + real(r8) :: sapw_c_flux ! Transfer into sapwood at various stages [kgC] + real(r8) :: store_c_flux ! Transfer into storage at various stages [kgC] + real(r8) :: repro_c_flux ! Transfer into reproduction at the final stage [kgC] + real(r8) :: struct_c_flux ! Transfer into structure at various stages [kgC] + + real(r8) :: leaf_c0 ! Initial value of carbon used to determine net flux + real(r8) :: fnrt_c0 ! during this routine + real(r8) :: sapw_c0 ! "" + real(r8) :: store_c0 ! "" + real(r8) :: repro_c0 ! "" + real(r8) :: struct_c0 ! "" + + logical :: grow_leaf ! Are leaves at allometric target and should be grown? + logical :: grow_fnrt ! Are fine-roots at allometric target and should be grown? + logical :: grow_sapw ! Is sapwood at allometric target and should be grown? + logical :: grow_store ! Is storage at allometric target and should be grown? + + ! integrator variables + real(r8) :: deltaC ! trial value for substep + integer :: ierr ! error flag for allometric growth step + integer :: nsteps ! number of sub-steps + integer :: istep ! current substep index + real(r8) :: totalC ! total carbon allocated over alometric growth step + real(r8) :: hite_out ! dummy height variable + + integer :: i_var ! local index for iterating state variables + + + ! Integegrator variables c_pool is "mostly" carbon variables, it also includes + ! dbh... + ! ----------------------------------------------------------------------------------- + + real(r8),dimension(n_integration_vars) :: c_pool ! Vector of carbon pools passed to integrator + real(r8),dimension(n_integration_vars) :: c_pool_out ! Vector of carbon pools passed back from integrator + logical,dimension(n_integration_vars) :: c_mask ! Mask of active pools during integration + + integer , parameter :: max_substeps = 300 ! Maximum allowable iterations + real(r8), parameter :: max_trunc_error = 1.0_r8 ! Maximum allowable truncation error + integer, parameter :: ODESolve = 2 ! 1=RKF45, 2=Euler + + real(r8) :: intgr_params(num_bc_in) ! The boundary conditions to this routine, + ! are pressed into an array that is also + ! passed to the integrators + + associate( & + leaf_c => this%variables(leaf_c_id)%val(icd), & + fnrt_c => this%variables(fnrt_c_id)%val(icd), & + sapw_c => this%variables(sapw_c_id)%val(icd), & + store_c => this%variables(store_c_id)%val(icd), & + repro_c => this%variables(repro_c_id)%val(icd), & + struct_c => this%variables(struct_c_id)%val(icd)) + + + ! ----------------------------------------------------------------------------------- + ! 0. + ! Copy the boundary conditions into readable local variables. + ! We don't use pointers for bc's that ar "in" only, only "in-out" and "out" + ! ----------------------------------------------------------------------------------- + + dbh => this%bc_inout(ac_bc_inout_id_dbh)%rval + carbon_balance => this%bc_inout(ac_bc_inout_id_netdc)%rval + + canopy_trim = this%bc_in(ac_bc_in_id_ctrim)%rval + ipft = this%bc_in(ac_bc_in_id_pft)%ival + + intgr_params(:) = un_initialized + intgr_params(ac_bc_in_id_ctrim) = this%bc_in(ac_bc_in_id_ctrim)%rval + intgr_params(ac_bc_in_id_pft) = real(this%bc_in(ac_bc_in_id_pft)%ival) + + ! ----------------------------------------------------------------------------------- + ! I. Remember the values for the state variables at the beginning of this + ! routines. We will then use that to determine their net allocation and reactive + ! transport flux "%net_alloc" at the end. + ! ----------------------------------------------------------------------------------- + + leaf_c0 = leaf_c ! Set initial leaf carbon + fnrt_c0 = fnrt_c ! Set initial fine-root carbon + sapw_c0 = sapw_c ! Set initial sapwood carbon + store_c0 = store_c ! Set initial storage carbon + repro_c0 = repro_c ! Set initial reproductive carbon + struct_c0 = struct_c ! Set initial structural carbon + + + ! ----------------------------------------------------------------------------------- + ! II. Calculate target size of the biomass compartment for a given dbh. + ! ----------------------------------------------------------------------------------- + + ! Target sapwood biomass and deriv. according to allometry and trimming [kgC, kgC/cm] + call bsap_allom(dbh,ipft,canopy_trim,sapw_area,target_sapw_c) + + ! Target total above ground deriv. biomass in woody/fibrous tissues [kgC, kgC/cm] + call bagw_allom(dbh,ipft,target_agw_c) + + ! Target total below ground deriv. biomass in woody/fibrous tissues [kgC, kgC/cm] + call bbgw_allom(dbh,ipft,target_bgw_c) + + ! Target total dead (structrual) biomass and deriv. [kgC, kgC/cm] + 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) .and. & + (EDPftvarcon_inst%woody(ipft) == itrue) ) then + + call StructureResetOfDH( struct_c, ipft, & + canopy_trim, dbh, hite_out ) + + ! Target sapwood biomass and deriv. according to allometry and trimming [kgC, kgC/cm] + call bsap_allom(dbh,ipft,canopy_trim,sapw_area,target_sapw_c) + + ! Target total above ground deriv. biomass in woody/fibrous tissues [kgC, kgC/cm] + call bagw_allom(dbh,ipft,target_agw_c) + + ! Target total below ground deriv. biomass in woody/fibrous tissues [kgC, kgC/cm] + call bbgw_allom(dbh,ipft,target_bgw_c) + + ! Target total dead (structrual) biomass and deriv. [kgC, kgC/cm] + call bdead_allom( target_agw_c, target_bgw_c, target_sapw_c, ipft, target_struct_c) + + end if + + ! Target leaf biomass according to allometry and trimming + call bleaf(dbh,ipft,canopy_trim,target_leaf_c) + + ! Target fine-root biomass and deriv. according to allometry and trimming [kgC, kgC/cm] + call bfineroot(dbh,ipft,canopy_trim,target_fnrt_c) + + ! Target storage carbon [kgC,kgC/cm] + call bstore_allom(dbh,ipft,canopy_trim,target_store_c) + + + + + ! ----------------------------------------------------------------------------------- + ! III. Prioritize some amount of carbon to replace leaf/root turnover + ! Make sure it isnt a negative payment, and either pay what is available + ! or forcefully pay from storage. + ! ----------------------------------------------------------------------------------- + + if( EDPftvarcon_inst%evergreen(ipft) ==1 ) then + leaf_c_demand = max(0.0_r8, & + EDPftvarcon_inst%leaf_stor_priority(ipft)*this%variables(leaf_c_id)%turnover(icd)) + else + leaf_c_demand = 0.0_r8 + end if + + fnrt_c_demand = max(0.0_r8, & + EDPftvarcon_inst%leaf_stor_priority(ipft)*this%variables(fnrt_c_id)%turnover(icd)) + + total_c_demand = leaf_c_demand + fnrt_c_demand + + if (total_c_demand> nearzero ) then + + ! We pay this even if we don't have the carbon + ! Just don't pay so much carbon that storage+carbon_balance can't pay for it + + leaf_c_flux = min(leaf_c_demand, & + max(0.0_r8,(store_c+carbon_balance)* & + (leaf_c_demand/total_c_demand))) + + carbon_balance = carbon_balance - leaf_c_flux + leaf_c = leaf_c + leaf_c_flux + + ! If we are testing b4b, then we pay this even if we don't have the carbon + fnrt_c_flux = min(fnrt_c_demand, & + max(0.0_r8, (store_c+carbon_balance)* & + (fnrt_c_demand/total_c_demand))) + + carbon_balance = carbon_balance - fnrt_c_flux + fnrt_c = fnrt_c + fnrt_c_flux + + end if + + ! ----------------------------------------------------------------------------------- + ! IV. if carbon balance is negative, re-coup the losses from storage + ! if it is positive, give some love to storage carbon + ! ----------------------------------------------------------------------------------- + + if( carbon_balance < 0.0_r8 ) then + + store_c_flux = carbon_balance + carbon_balance = carbon_balance - store_c_flux + store_c = store_c + store_c_flux + + else + + store_below_target = max(target_store_c - store_c,0.0_r8) + store_target_fraction = max(0.0_r8, store_c/target_store_c ) + + store_c_flux = min(store_below_target,carbon_balance * & + max(exp(-1.*store_target_fraction**4._r8) - exp( -1.0_r8 ),0.0_r8)) + + carbon_balance = carbon_balance - store_c_flux + store_c = store_c + store_c_flux + + end if + + ! ----------------------------------------------------------------------------------- + ! V. If carbon is still available, prioritize some allocation to replace + ! the rest of the leaf/fineroot deficit + ! carbon balance is guaranteed to be >=0 beyond this point + ! ----------------------------------------------------------------------------------- + + leaf_c_demand = max(0.0_r8,(target_leaf_c - leaf_c)) + fnrt_c_demand = max(0.0_r8,(target_fnrt_c - fnrt_c)) + + total_c_demand = leaf_c_demand + fnrt_c_demand + + if( (carbon_balance > nearzero ) .and. (total_c_demand>nearzero)) then + + leaf_c_flux = min(leaf_c_demand, & + carbon_balance*(leaf_c_demand/total_c_demand)) + carbon_balance = carbon_balance - leaf_c_flux + leaf_c = leaf_c + leaf_c_flux + + fnrt_c_flux = min(fnrt_c_demand, & + carbon_balance*(fnrt_c_demand/total_c_demand)) + carbon_balance = carbon_balance - fnrt_c_flux + fnrt_c = fnrt_c + fnrt_c_flux + + end if + + ! ----------------------------------------------------------------------------------- + ! VI. If carbon is still available, we try to push all live + ! pools back towards allometry. But only upwards, if fusion happened + ! to generate some pools above allometric target, don't reduce the pool, + ! just ignore it until the rest of the plant grows to meet it. + ! ----------------------------------------------------------------------------------- + if( carbon_balance > nearzero ) then + + leaf_below_target = max(target_leaf_c - leaf_c,0.0_r8) + fnrt_below_target = max(target_fnrt_c - fnrt_c,0.0_r8) + sapw_below_target = max(target_sapw_c - sapw_c,0.0_r8) + store_below_target = max(target_store_c - store_c,0.0_r8) + + total_below_target = leaf_below_target + fnrt_below_target + & + sapw_below_target + store_below_target + + if ( total_below_target > nearzero ) then + + if( total_below_target > carbon_balance) then + leaf_c_flux = carbon_balance * leaf_below_target/total_below_target + fnrt_c_flux = carbon_balance * fnrt_below_target/total_below_target + sapw_c_flux = carbon_balance * sapw_below_target/total_below_target + store_c_flux = carbon_balance * store_below_target/total_below_target + else + leaf_c_flux = leaf_below_target + fnrt_c_flux = fnrt_below_target + sapw_c_flux = sapw_below_target + store_c_flux = store_below_target + end if + + carbon_balance = carbon_balance - leaf_c_flux + leaf_c = leaf_c + leaf_c_flux + + carbon_balance = carbon_balance - fnrt_c_flux + fnrt_c = fnrt_c + fnrt_c_flux + + carbon_balance = carbon_balance - sapw_c_flux + sapw_c = sapw_c + sapw_c_flux + + carbon_balance = carbon_balance - store_c_flux + store_c = store_c + store_c_flux + + end if + end if + + ! ----------------------------------------------------------------------------------- + ! VII. If carbon is still available, replenish the structural pool to get + ! back on allometry + ! ----------------------------------------------------------------------------------- + + if( carbon_balance > nearzero ) then + + struct_below_target = max(target_struct_c - struct_c ,0.0_r8) + + if ( struct_below_target > 0.0_r8) then + + struct_c_flux = min(carbon_balance,struct_below_target) + carbon_balance = carbon_balance - struct_c_flux + struct_c = struct_c + struct_c_flux + + end if + + end if + + ! ----------------------------------------------------------------------------------- + ! VIII. If carbon is yet still available ... + ! Our pools are now either on allometry or above (from fusion). + ! We we can increment those pools at or below, + ! including structure and reproduction according to their rates + ! Use an adaptive euler integration. If the error is not nominal, + ! the carbon balance sub-step (deltaC) will be halved and tried again + ! + ! Note that we compare against calloc_abs_error here because it is possible + ! that all the carbon was effectively used up, but a miniscule amount + ! remains due to numerical precision (ie -20 or so), so even though + ! the plant has not been brought to be "on allometry", it thinks it has carbon + ! left to allocate, and thus it must be on allometry when its not. + ! ----------------------------------------------------------------------------------- + + if( carbon_balance > calloc_abs_error ) then + + ! This routine checks that actual carbon is not below that targets. It does + ! allow actual pools to be above the target, and in these cases, it sends + ! a false on the "grow_<>" flag, allowing the plant to grow into these pools. + ! It also checks to make sure that structural biomass is not above the target. + if ( EDPftvarcon_inst%woody(ipft) == itrue ) then + + + if( (target_store_c - store_c)>calloc_abs_error) then + write(fates_log(),*) 'storage is not on-allometry at the growth step' + write(fates_log(),*) 'exiting' + write(fates_log(),*) 'cbal: ',carbon_balance + write(fates_log(),*) 'near-zero',nearzero + write(fates_log(),*) 'store_c: ',store_c + write(fates_log(),*) 'target c: ',target_store_c + write(fates_log(),*) 'store_c0:', store_c0 + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + call TargetAllometryCheck(leaf_c, fnrt_c, sapw_c, & + store_c, struct_c, & + target_leaf_c, target_fnrt_c, & + target_sapw_c, target_store_c, target_struct_c, & + grow_leaf, grow_fnrt, grow_sapw, grow_store) + else ! for grasses + grow_leaf = .true. + grow_fnrt = .true. + grow_sapw = .true. + grow_store = .true. + end if + + ! -------------------------------------------------------------------------------- + ! The numerical integration of growth requires that the instantaneous state + ! variables are passed in as an array. We call it "c_pool". + ! + ! Initialize the adaptive integrator arrays and flags + ! -------------------------------------------------------------------------------- + + ierr = 1 + totalC = carbon_balance + nsteps = 0 + + c_pool(:) = 0.0_r8 ! Zero state variable array + c_mask(:) = .false. ! This mask tells the integrator + ! which indices are active. Its possible + ! that due to fusion, or previous numerical + ! truncation errors, that one of these pools + ! may be larger than its target! We check + ! this, and if true, then we flag that + ! pool to be ignored. c_mask(i) = .false. + ! For grasses, since they don't grow very + ! large and thus won't accumulate such large + ! errors, we always mask as true. + + c_pool(leaf_c_id) = leaf_c + c_pool(fnrt_c_id) = fnrt_c + c_pool(sapw_c_id) = sapw_c + c_pool(store_c_id) = store_c + c_pool(struct_c_id) = struct_c + c_pool(repro_c_id) = repro_c + c_pool(dbh_id) = dbh + + c_mask(leaf_c_id) = grow_leaf + c_mask(fnrt_c_id) = grow_fnrt + c_mask(sapw_c_id) = grow_sapw + c_mask(store_c_id) = grow_store + c_mask(struct_c_id) = .true. ! Always increment dead on growth step + c_mask(repro_c_id) = .true. ! Always calculate reproduction on growth + c_mask(dbh_id) = .true. ! Always increment dbh on growth step + + + ! When using the Euler method, we keep things simple. We always try + ! to make the first integration step to span the entirety of the integration + ! window for the independent variable (available carbon) + + if(ODESolve == 2) then + this%ode_opt_step = totalC + end if + + do while( ierr .ne. 0 ) + + deltaC = min(totalC,this%ode_opt_step) + if(ODESolve == 1) then + call RKF45(AllomCGrowthDeriv,c_pool,c_mask,deltaC,totalC, & + max_trunc_error,intgr_params,c_pool_out,this%ode_opt_step,step_pass) + + elseif(ODESolve == 2) then + call Euler(AllomCGrowthDeriv,c_pool,c_mask,deltaC,totalC,intgr_params,c_pool_out) + ! step_pass = .true. + + ! When integrating along the allometric curve, we have the luxury of perfect + ! hindsite. Ie, after we have made our step, we can see if the amount + ! of each carbon we have matches the target associated with the new dbh. + ! The following call evaluates how close we are to the allometically defined + ! targets. If we are too far (governed by max_trunc_error), then we + ! pass back the pass/fail flag (step_pass) as false. If false, then + ! we halve the step-size, and then retry. If that step was fine, then + ! we remember the current step size as a good next guess. + + call CheckIntegratedAllometries(c_pool_out(dbh_id),ipft,canopy_trim, & + c_pool_out(leaf_c_id), c_pool_out(fnrt_c_id), c_pool_out(sapw_c_id), & + c_pool_out(store_c_id), c_pool_out(struct_c_id), & + c_mask(leaf_c_id), c_mask(fnrt_c_id), c_mask(sapw_c_id), & + c_mask(store_c_id),c_mask(struct_c_id), max_trunc_error, step_pass) + if(step_pass) then + this%ode_opt_step = deltaC + else + this%ode_opt_step = 0.5*deltaC + end if + else + write(fates_log(),*) 'An integrator was chosen that does not exist' + write(fates_log(),*) 'ODESolve = ',ODESolve + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + nsteps = nsteps + 1 + + if (step_pass) then ! If true, then step is accepted + totalC = totalC - deltaC + c_pool(:) = c_pool_out(:) + end if + + if(nsteps > max_substeps ) then + write(fates_log(),*) 'Plant Growth Integrator could not find' + write(fates_log(),*) 'a solution in less than ',max_substeps,' tries' + write(fates_log(),*) 'Aborting' + write(fates_log(),*) 'carbon_balance',carbon_balance + write(fates_log(),*) 'deltaC',deltaC + write(fates_log(),*) 'totalC',totalC + write(fates_log(),*) 'leaf:',grow_leaf,target_leaf_c,target_leaf_c - leaf_c + write(fates_log(),*) 'fnrt:',grow_fnrt,target_fnrt_c,target_fnrt_c - fnrt_c + write(fates_log(),*) 'sap:',grow_sapw,target_sapw_c, target_sapw_c - sapw_c + write(fates_log(),*) 'store:',grow_store,target_store_c,target_store_c - store_c + write(fates_log(),*) 'dead:',target_struct_c,target_struct_c - struct_c + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! + ! TotalC should eventually be whittled down to near zero. + ! The solvers are not perfect, so we can't expect it to be perfectly zero. + ! Note that calloc_abs_error is 1e-9, which is really small (1 microgram of carbon) + ! yet also six orders of magnitude greater than typical rounding errors (~1e-15). + + ! At that point, update the actual states + ! -------------------------------------------------------------------------------- + if( (totalC < calloc_abs_error) .and. (step_pass) )then + + ierr = 0 + leaf_c_flux = c_pool(leaf_c_id) - leaf_c + fnrt_c_flux = c_pool(fnrt_c_id) - fnrt_c + sapw_c_flux = c_pool(sapw_c_id) - sapw_c + store_c_flux = c_pool(store_c_id) - store_c + struct_c_flux = c_pool(struct_c_id) - struct_c + repro_c_flux = c_pool(repro_c_id) - repro_c + + ! Make an adjustment to flux partitions to make it match remaining c balance + flux_adj = carbon_balance/(leaf_c_flux+fnrt_c_flux+sapw_c_flux + & + store_c_flux+struct_c_flux+repro_c_flux) + + + leaf_c_flux = leaf_c_flux*flux_adj + fnrt_c_flux = fnrt_c_flux*flux_adj + sapw_c_flux = sapw_c_flux*flux_adj + store_c_flux = store_c_flux*flux_adj + struct_c_flux = struct_c_flux*flux_adj + repro_c_flux = repro_c_flux*flux_adj + + carbon_balance = carbon_balance - leaf_c_flux + leaf_c = leaf_c + leaf_c_flux + + carbon_balance = carbon_balance - fnrt_c_flux + fnrt_c = fnrt_c + fnrt_c_flux + + carbon_balance = carbon_balance - sapw_c_flux + sapw_c = sapw_c + sapw_c_flux + + carbon_balance = carbon_balance - store_c_flux + store_c = store_c + store_c_flux + + carbon_balance = carbon_balance - struct_c_flux + struct_c = struct_c + struct_c_flux + + carbon_balance = carbon_balance - repro_c_flux + repro_c = repro_c + repro_c_flux + + dbh = c_pool(dbh_id) + + ! THESE HAVE TO BE SET OUTSIDE OF THIS ROUTINE + !! cohort%seed_prod = cohort%seed_prod + brepro_flux / hlm_freq_day + !! cohort%dhdt = (h_sub-cohort%hite)/hlm_freq_day + !! cohort%ddbhdt = (dbh_sub-dbh_in)/hlm_freq_day + + if( abs(carbon_balance)>calloc_abs_error ) then + write(fates_log(),*) 'carbon conservation error while integrating pools' + write(fates_log(),*) 'along alometric curve' + write(fates_log(),*) 'carbon_balance = ',carbon_balance,totalC + write(fates_log(),*) 'exiting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end if + end do + end if + + ! Track the net allocations and transport from this routine + + this%variables(leaf_c_id)%net_alloc(icd) = & + this%variables(leaf_c_id)%net_alloc(icd) + (leaf_c - leaf_c0) + + this%variables(fnrt_c_id)%net_alloc(icd) = & + this%variables(fnrt_c_id)%net_alloc(icd) + (fnrt_c - fnrt_c0) + + this%variables(sapw_c_id)%net_alloc(icd) = & + this%variables(sapw_c_id)%net_alloc(icd) + (sapw_c - sapw_c0) + + this%variables(store_c_id)%net_alloc(icd) = & + this%variables(store_c_id)%net_alloc(icd) + (store_c - store_c0) + + this%variables(repro_c_id)%net_alloc(icd) = & + this%variables(repro_c_id)%net_alloc(icd) + (repro_c - repro_c0) + + this%variables(struct_c_id)%net_alloc(icd) = & + this%variables(struct_c_id)%net_alloc(icd) + (struct_c - struct_c0) + + + + + + + end associate + + return + end subroutine DailyPRTAllometricCarbon + + ! ===================================================================================== + + function AllomCGrowthDeriv(c_pools,c_mask,cbalance,intgr_params) result(dCdx) + + ! --------------------------------------------------------------------------------- + ! This function calculates the derivatives for the carbon pools + ! relative to the amount of carbon balance. This function is based completely + ! off of allometry, and assumes that there are no other species (ie nutrients) that + ! govern allocation. + ! --------------------------------------------------------------------------------- + + ! Arguments + real(r8),intent(in), dimension(:) :: c_pools ! Vector of carbon pools + ! dbh,leaf,root,sap,store,dead + logical,intent(in), dimension(:) :: c_mask ! logical mask of active pools + ! some may be turned off + real(r8),intent(in) :: cbalance ! The carbon balance of the + ! partial step (independant var) + + real(r8), intent(in),dimension(:) :: intgr_params ! Generic Array used to pass + ! parameters into this function + + + ! Return Value + ! Change in carbon (each pool) per change in total allocatable carbon (kgC/kgC) + real(r8),dimension(lbound(c_pools,dim=1):ubound(c_pools,dim=1)) :: dCdx + + ! locals + integer :: ipft ! PFT index + real(r8) :: canopy_trim ! Canopy trimming function (boundary condition [0-1] + real(r8) :: ct_leaf ! target leaf biomass, dummy var (kgC) + real(r8) :: ct_fnrt ! target fine-root biomass, dummy var (kgC) + real(r8) :: ct_sap ! target sapwood biomass, dummy var (kgC) + real(r8) :: ct_agw ! target aboveground wood, dummy var (kgC) + real(r8) :: ct_bgw ! target belowground wood, dummy var (kgC) + real(r8) :: ct_store ! target storage, dummy var (kgC) + real(r8) :: ct_dead ! target structural biomas, dummy var (kgC) + real(r8) :: sapw_area ! dummy sapwood area + real(r8) :: ct_dleafdd ! target leaf biomass derivative wrt diameter, (kgC/cm) + real(r8) :: ct_dfnrtdd ! target fine-root biomass derivative wrt diameter, (kgC/cm) + real(r8) :: ct_dsapdd ! target sapwood biomass derivative wrt diameter, (kgC/cm) + real(r8) :: ct_dagwdd ! target AG wood biomass derivative wrt diameter, (kgC/cm) + real(r8) :: ct_dbgwdd ! target BG wood biomass derivative wrt diameter, (kgC/cm) + real(r8) :: ct_dstoredd ! target storage biomass derivative wrt diameter, (kgC/cm) + real(r8) :: ct_ddeaddd ! target structural biomass derivative wrt diameter, (kgC/cm) + real(r8) :: ct_dtotaldd ! target total (not reproductive) biomass derivative wrt diameter, (kgC/cm) + real(r8) :: repro_fraction ! fraction of carbon balance directed towards reproduction (kgC/kgC) + + + associate( dbh => c_pools(dbh_id), & + cleaf => c_pools(leaf_c_id), & + cfnrt => c_pools(fnrt_c_id), & + csap => c_pools(sapw_c_id), & + cstore => c_pools(store_c_id), & + cdead => c_pools(struct_c_id), & + crepro => c_pools(repro_c_id), & ! Unused (memoryless) + mask_dbh => c_mask(dbh_id), & ! Unused (dbh always grows) + mask_leaf => c_mask(leaf_c_id), & + mask_fnrt => c_mask(fnrt_c_id), & + mask_sap => c_mask(sapw_c_id), & + mask_store => c_mask(store_c_id), & + mask_dead => c_mask(struct_c_id), & ! Unused (dead always grows) + mask_repro => c_mask(repro_c_id) ) + + canopy_trim = intgr_params(ac_bc_in_id_ctrim) + ipft = int(intgr_params(ac_bc_in_id_pft)) + + call bleaf(dbh,ipft,canopy_trim,ct_leaf,ct_dleafdd) + call bfineroot(dbh,ipft,canopy_trim,ct_fnrt,ct_dfnrtdd) + call bsap_allom(dbh,ipft,canopy_trim,sapw_area,ct_sap,ct_dsapdd) + + call bagw_allom(dbh,ipft,ct_agw,ct_dagwdd) + call bbgw_allom(dbh,ipft,ct_bgw,ct_dbgwdd) + call bdead_allom(ct_agw,ct_bgw, ct_sap, ipft, ct_dead, & + ct_dagwdd, ct_dbgwdd, ct_dsapdd, ct_ddeaddd) + call bstore_allom(dbh,ipft,canopy_trim,ct_store,ct_dstoredd) + + ! fraction of carbon going towards reproduction + if (dbh <= EDPftvarcon_inst%dbh_repro_threshold(ipft)) then ! cap on leaf biomass + repro_fraction = EDPftvarcon_inst%seed_alloc(ipft) + else + repro_fraction = EDPftvarcon_inst%seed_alloc(ipft) + EDPftvarcon_inst%seed_alloc_mature(ipft) + end if + + dCdx = 0.0_r8 + + ct_dtotaldd = ct_ddeaddd + if (mask_leaf) ct_dtotaldd = ct_dtotaldd + ct_dleafdd + if (mask_fnrt) ct_dtotaldd = ct_dtotaldd + ct_dfnrtdd + if (mask_sap) ct_dtotaldd = ct_dtotaldd + ct_dsapdd + if (mask_store) ct_dtotaldd = ct_dtotaldd + ct_dstoredd + + ! It is possible that with some asymptotic, or hard + ! capped allometries, that all growth rates reach zero. + ! In this case, if there is carbon, give it to reproduction + + if(ct_dtotaldd<=tiny(ct_dtotaldd))then + + dCdx(struct_c_id) = 0.0_r8 + dCdx(dbh_id) = 0.0_r8 + dCdx(leaf_c_id) = 0.0_r8 + dCdx(fnrt_c_id) = 0.0_r8 + dCdx(sapw_c_id) = 0.0_r8 + dCdx(store_c_id) = 0.0_r8 + dCdx(repro_c_id) = 1.0_r8 + + else + + dCdx(struct_c_id) = (ct_ddeaddd/ct_dtotaldd)*(1.0_r8-repro_fraction) + dCdx(dbh_id) = (1.0_r8/ct_dtotaldd)*(1.0_r8-repro_fraction) + + if (mask_leaf) then + dCdx(leaf_c_id) = (ct_dleafdd/ct_dtotaldd)*(1.0_r8-repro_fraction) + else + dCdx(leaf_c_id) = 0.0_r8 + end if + + if (mask_fnrt) then + dCdx(fnrt_c_id) = (ct_dfnrtdd/ct_dtotaldd)*(1.0_r8-repro_fraction) + else + dCdx(fnrt_c_id) = 0.0_r8 + end if + + if (mask_sap) then + dCdx(sapw_c_id) = (ct_dsapdd/ct_dtotaldd)*(1.0_r8-repro_fraction) + else + dCdx(sapw_c_id) = 0.0_r8 + end if + + if (mask_store) then + dCdx(store_c_id) = (ct_dstoredd/ct_dtotaldd)*(1.0_r8-repro_fraction) + else + dCdx(store_c_id) = 0.0_r8 + end if + + dCdx(repro_c_id) = repro_fraction + + end if + + end associate + + return + end function AllomCGrowthDeriv + + ! ==================================================================================== + + subroutine TargetAllometryCheck(bleaf,bfroot,bsap,bstore,bdead, & + bt_leaf,bt_froot,bt_sap,bt_store,bt_dead, & + grow_leaf,grow_froot,grow_sapw,grow_store) + + ! Arguments + real(r8),intent(in) :: bleaf !actual + real(r8),intent(in) :: bfroot + real(r8),intent(in) :: bsap + real(r8),intent(in) :: bstore + real(r8),intent(in) :: bdead + real(r8),intent(in) :: bt_leaf !target + real(r8),intent(in) :: bt_froot + real(r8),intent(in) :: bt_sap + real(r8),intent(in) :: bt_store + real(r8),intent(in) :: bt_dead + logical,intent(out) :: grow_leaf !growth flag + logical,intent(out) :: grow_froot + logical,intent(out) :: grow_sapw + logical,intent(out) :: grow_store + + if( (bt_leaf - bleaf)>calloc_abs_error) then + write(fates_log(),*) 'leaves are not on-allometry at the growth step' + write(fates_log(),*) 'exiting',bleaf,bt_leaf + call endrun(msg=errMsg(sourcefile, __LINE__)) + elseif( (bleaf - bt_leaf)>calloc_abs_error) then + ! leaf is above allometry, ignore + grow_leaf = .false. + else + grow_leaf = .true. + end if + + if( (bt_froot - bfroot)>calloc_abs_error) then + write(fates_log(),*) 'fineroots are not on-allometry at the growth step' + write(fates_log(),*) 'exiting',bfroot, bt_froot + call endrun(msg=errMsg(sourcefile, __LINE__)) + elseif( ( bfroot-bt_froot)>calloc_abs_error ) then + grow_froot = .false. + else + grow_froot = .true. + end if + + if( (bt_sap - bsap)>calloc_abs_error) then + write(fates_log(),*) 'sapwood is not on-allometry at the growth step' + write(fates_log(),*) 'exiting',bsap, bt_sap + call endrun(msg=errMsg(sourcefile, __LINE__)) + elseif( ( bsap-bt_sap)>calloc_abs_error ) then + grow_sapw = .false. + else + grow_sapw = .true. + end if + + if( (bt_store - bstore)>calloc_abs_error) then + write(fates_log(),*) 'storage is not on-allometry at the growth step' + write(fates_log(),*) 'exiting',bstore,bt_store + call endrun(msg=errMsg(sourcefile, __LINE__)) + elseif( ( bstore-bt_store)>calloc_abs_error ) then + grow_store = .false. + else + grow_store = .true. + end if + + if( (bt_dead - bdead)>calloc_abs_error) then + write(fates_log(),*) 'structure not on-allometry at the growth step' + write(fates_log(),*) 'exiting',bdead,bt_dead + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end subroutine TargetAllometryCheck + + ! ===================================================================================== + + subroutine FastPRTAllometricCarbon(this) + + implicit none + class(callom_prt_vartypes) :: this ! this class + + ! This routine does nothing, because in the carbon only allometric RT model + ! we currently don't have any fast-timestep processes + ! Think of this as a stub. + + + return + end subroutine FastPRTAllometricCarbon + + +end module PRTAllometricCarbonMod + diff --git a/parteh/PRTGenericMod.F90 b/parteh/PRTGenericMod.F90 new file mode 100644 index 0000000000..945283694c --- /dev/null +++ b/parteh/PRTGenericMod.F90 @@ -0,0 +1,1286 @@ +module PRTGenericMod + + ! ------------------------------------------------------------------------------------ + ! Plant Allocation and Reactive Transport (PART) + + ! Extensible Hypotheses (EH) = PARTEH + ! + ! Non-Specific (Generic) Classes and Functions + ! This contains the base classes for both the variables and the global class + ! + ! General idea: PARTEH treats its state variables as objects. Each object + ! can be mapped to, or associated with: + ! 1) an organ + ! 2) a spatial position associated with that organ + ! 3) a chemical element (ie carbon isotope or nutrient), aka chemical species + ! + ! + ! THIS ROUTINE SHOULD NOT HAVE TO BE MODIFIED TO ACCOMODATE NEW HYPOTHESES + ! (in principle ...) + ! + ! Ryan Knox, April 2018 + ! ------------------------------------------------------------------------------------ + + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : i4 => fates_int + use FatesConstantsMod, only : nearzero + use FatesConstantsMod, only : calloc_abs_error + use FatesGlobals , only : endrun => fates_endrun + use FatesGlobals , only : fates_log + use shr_log_mod , only : errMsg => shr_log_errMsg + + + implicit none + + integer, parameter :: maxlen_varname = 128 + integer, parameter :: maxlen_varsymbol = 32 + integer, parameter :: maxlen_varunits = 32 + integer, parameter :: len_baseunit = 6 + + + ! We use this parameter as the value for which we set un-initialized values + real(r8), parameter :: un_initialized = -9.9e32_r8 + + ! We use this parameter as the value for which we check un-initialized values + real(r8), parameter :: check_initialized = -8.8e32_r8 + + + ! ------------------------------------------------------------------------------------- + ! IMPORTANT! + ! All elements in all organs should be expressed in terms of KILOGRAMS + ! All rates of change are expressed in terms of kilograms / day + ! This assumption cannot be broken! + ! ------------------------------------------------------------------------------------- + + character(len=len_baseunit), parameter :: mass_unit = 'kg' + character(len=len_baseunit), parameter :: mass_rate_unit = 'kg/day' + + ! ------------------------------------------------------------------------------------- + ! Allocation Hypothesis Types + ! These should each have their own module + ! ------------------------------------------------------------------------------------- + + integer, parameter :: prt_carbon_allom_hyp = 1 + integer, parameter :: prt_cnp_flex_allom_hyp = 2 ! Still under development + + + ! ------------------------------------------------------------------------------------- + ! Organ types + ! These are public indices used to map the organs + ! in each hypothesis to organs that acknowledged in the calling model + ! ------------------------------------------------------------------------------------- + + integer, parameter :: num_organ_types = 6 + integer, parameter :: all_organs = 0 ! index for all organs + integer, parameter :: leaf_organ = 1 ! index for leaf organs + integer, parameter :: fnrt_organ = 2 ! index for fine-root organs + integer, parameter :: sapw_organ = 3 ! index for sapwood organs + integer, parameter :: store_organ = 4 ! index for storage organs + integer, parameter :: repro_organ = 5 ! index for reproductive organs + integer, parameter :: struct_organ = 6 ! index for structure (dead) organs + + ! ------------------------------------------------------------------------------------- + ! Element types + ! These are public indices used to map the elements (chem species) in each hypothesis + ! to the element that are acknowledged in the calling model + ! ------------------------------------------------------------------------------------- + + integer, parameter :: num_element_types = 6 ! Total number of unique element + ! curently recognized by PARTEH + ! should be max index in list below + + ! The following list are the unique indices associated with the + ! element used in each hypothesis. Note these are just POTENTIAL + ! element. At the time of writing this, we are very far away from + ! creating allocation schemes that even use potassium. + + integer, parameter :: all_carbon_elements = 0 + integer, parameter :: carbon12_element = 1 + integer, parameter :: carbon13_element = 2 + integer, parameter :: carbon14_element = 3 + integer, parameter :: nitrogen_element = 4 + integer, parameter :: phosphorous_element = 5 + integer, parameter :: potassium_element = 6 + + ! The following elements are just placeholders. In the future + ! if someone wants to develope an allocation hypothesis + ! that uses nickel, we can just uncomment it from this list + + ! integer, parameter :: calcium_element = 7 + ! integer, parameter :: magnesium_element = 8 + ! integer, parameter :: sulfur_element = 9 + ! integer, parameter :: chlorine_element = 10 + ! integer, parameter :: iron_element = 11 + ! integer, parameter :: manganese_element = 12 + ! integer, parameter :: zinc_element = 13 + ! integer, parameter :: copper_element = 14 + ! integer, parameter :: boron_element = 15 + ! integer, parameter :: molybdenum_element = 16 + ! integer, parameter :: nickel_element = 17 + + + ! We have some lists of elements or lists of organs, such as + ! a list of all carbon elements. To keep routines simple + ! we set a global to the maximum list size for scratch arrays. + + integer, parameter :: max_spec_per_group = 3 ! we may query these lists + ! the carbon elements are the biggest list + ! right now + + + ! List of all carbon elements, the special index "all_carbon_elements" + ! implies the following list of carbon organs + + integer, parameter, dimension(3) :: carbon_elements_list = & + [carbon12_element, carbon13_element, carbon14_element] + + + ! ------------------------------------------------------------------------------------- + ! + ! The following is the data structure that holds the state (ie carbon, + ! nutrients, etc) for each pool of each plant. + ! + ! For example, this could be the carbon 12 of the leaf pool; its instantaneous state, + ! and its fluxes. + ! + ! Note also that these are vectors and not scalars, which indicates that there + ! may be more than 1 discrete spatial positions. For instance, there might be multiple + ! leaf layers or something. + ! + ! Since there are many variables, as well as boundary conditions, this object is + ! NESTED in the prt_vartypes (<---- see the "s" at the end?) structure that follows. + ! + ! Each object will have a unique index associated with it, it will also be mapped + ! to a specific organ and element combination. + ! + ! It is assumed that over the control period (probably 1 day) that + ! changes in the current state (val) relative to the value at the start of the + ! control period (val0), are equal to the time integrated flux terms + ! (net_alloc, turnover, etc) + ! + ! ------------------------------------------------------------------------------------- + + type prt_vartype + + real(r8),allocatable :: val(:) ! Instantaneous state variable [kg] + real(r8),allocatable :: val0(:) ! State variable at the beginning + ! of the control period [kg] + real(r8),allocatable :: net_alloc(:) ! Net change due to allocation/transport [kg] + ! over the control period [kg] + real(r8),allocatable :: turnover(:) ! Losses due to turnover [kg] + ! or, any mass destined for litter + ! over the control period + + real(r8),allocatable :: burned(:) ! Losses due to burn [kg] + +! real(r8),allocatable :: herbiv(:) ! Losses due to herbivory [kg] + + ! Placeholder + ! To save on memory, keep this commented out, or simply + ! add this only in the extension ... ? + ! real(r8),allocatable :: coordinate(:,:) + + end type prt_vartype + + + ! ------------------------------------------------------------------------------------- + ! Input boundary conditions. These will be allocated as an array for each plant. + ! This type will also be broken into 3 types of boundary conditions: input only, + ! output only, and input-output. + ! ------------------------------------------------------------------------------------- + + type prt_bctype + + real(r8), pointer :: rval + integer, pointer :: ival + + end type prt_bctype + + + ! ------------------------------------------------------------------------------------- + ! The following is the object that is directly attached to each plant. + ! + ! ie this is the parent object. + ! It contains the state variable object: variables + ! as well as the boundary condition pointers bc_inout, bc_in and bc_out + ! + ! This object also contains the bulk of the PRT routines, including + ! extended (hypothesis specific routines) and generic routines (eg + ! routines that can operate on any hypothesis) + ! + ! There are procedures that are specialized for each module. And then + ! there are procedures that are supposed to be generic and should support + ! all the different modules. + ! ------------------------------------------------------------------------------------- + + type prt_vartypes + + type(prt_vartype),allocatable :: variables(:) ! The state variables and fluxes + type(prt_bctype), allocatable :: bc_inout(:) ! These boundaries may be changed + type(prt_bctype), allocatable :: bc_in(:) ! These are protected + type(prt_bctype), allocatable :: bc_out(:) ! These are overwritten + real(r8) :: ode_opt_step + + contains + + ! These are extendable procedures that have specialized + ! content in each of the different hypotheses + + procedure :: DailyPRT => DailyPRTBase + procedure :: FastPRT => FastPRTBase + + ! These are generic functions that should work on all hypotheses + + procedure, non_overridable :: InitAllocate + procedure, non_overridable :: InitPRTVartype + procedure, non_overridable :: FlushBCs + procedure, non_overridable :: InitializeInitialConditions + procedure, non_overridable :: CheckInitialConditions + procedure, non_overridable :: RegisterBCIn + procedure, non_overridable :: RegisterBCOut + procedure, non_overridable :: RegisterBCInout + procedure, non_overridable :: GetState + procedure, non_overridable :: GetTurnover + procedure, non_overridable :: GetBurned + procedure, non_overridable :: GetNetAlloc + procedure, non_overridable :: ZeroRates + procedure, non_overridable :: CheckMassConservation + procedure, non_overridable :: DeallocatePRTVartypes + procedure, non_overridable :: WeightedFusePRTVartypes + procedure, non_overridable :: CopyPRTVartypes + end type prt_vartypes + + + + + ! ------------------------------------------------------------------------------------- + ! This next section contains the objects that describe the mapping for each specific + ! hypothesis. It is also a way to call the descriptions of variables for any + ! arbitrary hypothesis. + ! These are things that are globally true, not specific to each plant. + ! For instance the map just contains the list of variable names, not the values for + ! each plant. + ! These are not instanced on every plant, they are just instanced once on every model + ! machine or memory space. They should only be initialized once and used + ! as read-only from that point on. + ! ------------------------------------------------------------------------------------- + + ! ------------------------------------------------------------------------------------- + ! This type simply packs the names and symbols associated with all + ! the variables for any given hypothesis + ! ------------------------------------------------------------------------------------- + + type :: state_descriptor_type + character(len=maxlen_varname) :: longname + character(len=maxlen_varsymbol) :: symbol + integer :: organ_id ! global id for organ + integer :: element_id ! global id for element + integer :: num_pos ! number of descrete spatial positions + + ! Also, will probably need flags to define different types of groups that this variable + ! belongs too, which will control things like fusion, normalization, when to zero, etc... + + end type state_descriptor_type + + + + ! This type will help us loop through all the different variables associated + ! with a specific organ type. Since variables are a combination of organ and + ! element, the number of unique variables is capped at the number of elements + ! per each organ. + + type organ_map_type + integer, dimension(1:num_element_types) :: var_id + integer :: num_vars + end type organ_map_type + + + ! This structure packs both the mapping structure and the variable descriptors + ! ------------------------------------------------------------------------------------- + ! This array should contain the lists of indices to + ! the element x organ variable structure that is used to map variables to the outside + ! world. + ! + ! + ! | carbon | nitrogen | phosphorous | .... | + ! ------------------------------------------ + ! leaf | | | | | + ! fine-root | | | | | + ! sapwood | | | | | + ! storage | | | | | + ! reproduction | | | | | + ! structure | | | | | + ! .... | | | | | + ! ------------------------------------------ + ! + ! ------------------------------------------------------------------------------------- + + type prt_global_type + + ! Note that index 0 is reserved for "all" or "irrelevant" + character(len=maxlen_varname) :: hyp_name + + ! This will save the specific variable id associated with each organ and element + integer, dimension(0:num_organ_types,0:num_element_types) :: sp_organ_map + + ! This holds the verbose descriptions of the variables, symbols, names, etc + type(state_descriptor_type), allocatable :: state_descriptor(:) + + ! This will save the list of variable ids associated with each organ. There + ! are multiple of these because we may have multiple element per organ. + type(organ_map_type), dimension(1:num_organ_types) :: organ_map + + ! The number of input boundary conditions + integer :: num_bc_in + + ! The number of output boundary conditions + integer :: num_bc_out + + ! The number of combo input-output boundary conditions + integer :: num_bc_inout + + ! The number of variables set by each hypothesis + integer :: num_vars + + + contains + + procedure, non_overridable :: ZeroGlobal + procedure, non_overridable :: RegisterVarInGlobal + + end type prt_global_type + + + type(prt_global_type),pointer :: prt_global + + +contains + + ! ===================================================================================== + ! Module Functions and Subroutines + ! ===================================================================================== + + + subroutine ZeroGlobal(this) + + + ! This subroutine zero's out the map between variable indexes and the + ! elements and organs they are associated with. + ! It also sets the counts of the variables and boundary conditions as + ! a nonsense number that will trigger a fail if they are specified later. + ! This routine must be called + + + class(prt_global_type) :: this + + integer :: io ! Organ loop counter + integer :: is ! Element loop counter + + ! First zero out the array + do io = 1,num_organ_types + do is = 1,num_element_types + this%sp_organ_map(io,is) = 0 + this%organ_map(io)%var_id(is) = 0 + end do + this%organ_map(io)%num_vars = 0 + end do + + ! Set the number of boundary conditions as a bogus value + this%num_bc_in = -9 + this%num_bc_out = -9 + this%num_bc_inout = -9 + + ! Set the number of variables to a bogus value. This should be + ! immediately over-written in the routine that is calling this + this%num_vars = -9 + + return + end subroutine ZeroGlobal + + ! ===================================================================================== + + subroutine RegisterVarInGlobal(this, var_id, long_name, symbol, organ_id, element_id, num_pos) + + + ! This subroutine is called for each variable that is defined in each specific hypothesis. + ! For instance, this is called six times in the carbon only hypothesis, + ! each time providing names, symbols, associated organs and element for each pool. + + class(prt_global_type) :: this + integer, intent(in) :: var_id + character(len=*),intent(in) :: long_name + character(len=*),intent(in) :: symbol + integer, intent(in) :: organ_id + integer, intent(in) :: element_id + integer, intent(in) :: num_pos + + ! Set the descriptions and the associated organs/element in the variable's + ! own array + + this%state_descriptor(var_id)%longname = long_name + this%state_descriptor(var_id)%symbol = symbol + this%state_descriptor(var_id)%organ_id = organ_id + this%state_descriptor(var_id)%element_id = element_id + this%state_descriptor(var_id)%num_pos = num_pos + + ! Set the mapping tables for the external model + + this%sp_organ_map(organ_id,element_id) = var_id + + ! Set another map that helps to locate all the relevant pools associated + ! with an organ + + this%organ_map(organ_id)%num_vars = this%organ_map(organ_id)%num_vars + 1 + this%organ_map(organ_id)%var_id(this%organ_map(organ_id)%num_vars) = var_id + + + return + end subroutine RegisterVarInGlobal + + ! ===================================================================================== + + subroutine InitPRTVartype(this) + + class(prt_vartypes) :: this + + + ! This subroutine should be the first call whenever a prt_vartype object is + ! instantiated. + ! + ! Most likely, this will occur whenever a new plant or cohort is created. + ! + ! This routine handles the allocation (extended procedure) + ! and then the initializing of states with bogus information, and then + ! the flushing of all boundary conditions to null. + + call this%InitAllocate() ! Allocate memory spaces + call this%InitializeInitialConditions() ! Set states to a nan-like starter value + call this%FlushBCs() ! Set all boundary condition pointers + ! to null + + + return + end subroutine InitPRTVartype + + ! ===================================================================================== + + subroutine InitAllocate(this) + + ! ---------------------------------------------------------------------------------- + ! This initialization is called everytime a plant/cohort + ! is newly recruited. Like the name implies, we are just allocating space here. + ! ---------------------------------------------------------------------------------- + + class(prt_vartypes) :: this + + integer :: i_var ! Variable loop index + integer :: num_pos ! The number of positions for each variable + + ! Allocate the boundar condition arrays and flush them to no-data flags + ! ---------------------------------------------------------------------------------- + + if(prt_global%num_bc_in > 0) then + allocate(this%bc_in(prt_global%num_bc_in)) + end if + + if(prt_global%num_bc_inout > 0) then + allocate(this%bc_inout(prt_global%num_bc_inout)) + end if + + if(prt_global%num_bc_out > 0) then + allocate(this%bc_out(prt_global%num_bc_out)) + end if + + ! Allocate the state variables + allocate(this%variables(prt_global%num_vars)) + + do i_var = 1, prt_global%num_vars + + num_pos = prt_global%state_descriptor(i_var)%num_pos + + allocate(this%variables(i_var)%val(num_pos)) + allocate(this%variables(i_var)%val0(num_pos)) + allocate(this%variables(i_var)%turnover(num_pos)) + allocate(this%variables(i_var)%net_alloc(num_pos)) + allocate(this%variables(i_var)%burned(num_pos)) + + end do + + + return + end subroutine InitAllocate + + ! ===================================================================================== + + subroutine InitializeInitialConditions(this) + + ! ---------------------------------------------------------------------------------- + ! This routine sets all PARTEH variables to a nonsense value. + ! This ensures that a fail is triggered if a value is not initialized correctly. + ! ---------------------------------------------------------------------------------- + + class(prt_vartypes) :: this + + integer :: i_var ! Variable index + + do i_var = 1, prt_global%num_vars + this%variables(i_var)%val(:) = un_initialized + this%variables(i_var)%val0(:) = un_initialized + this%variables(i_var)%turnover(:) = un_initialized + this%variables(i_var)%burned(:) = un_initialized + this%variables(i_var)%net_alloc(:) = un_initialized + end do + + ! Initialize the optimum step size as very large. + + this%ode_opt_step = 1e6_r8 + + return + end subroutine InitializeInitialConditions + + + ! ============================================================= + + subroutine CheckInitialConditions(this) + + ! This subroutine makes sure that every variable defined + ! in the hypothesis has been given an initial value. + ! + ! This should be called following any blocks where initial + ! conditions are set. In fates, these calls already + ! exist and when new hypotheses are added, they will + ! already be checked if the initial conditions are + ! specified in parallel with the other hypotheses. + + class(prt_vartypes) :: this + + integer :: i_var ! index for iterating variables + integer :: n_cor_ids ! Number of coordinate ids + integer :: i_cor ! index for iterating coordinate dimension + integer :: i_organ ! The global organ id for this variable + integer :: i_element ! The global element id for this variable + + do i_var = 1, prt_global%num_vars + + n_cor_ids = size(this%variables(i_var)%val,1) + + do i_cor = 1, n_cor_ids + + if(this%variables(i_var)%val(i_cor) < check_initialized) then + + i_organ = prt_global%state_descriptor(i_var)%organ_id + i_element = prt_global%state_descriptor(i_var)%element_id + + write(fates_log(),*)'Not all initial conditions for state variables' + write(fates_log(),*)' in PRT hypothesis: ',trim(prt_global%hyp_name) + write(fates_log(),*)' were written out.' + write(fates_log(),*)' i_var: ',i_var + write(fates_log(),*)' i_cor: ',i_cor + write(fates_log(),*)' organ_id:',i_organ + write(fates_log(),*)' element_id',i_element + write(fates_log(),*)'Exiting' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + end do + end do + + return + end subroutine CheckInitialConditions + + ! ===================================================================================== + + subroutine FlushBCs(this) + + ! Boundary conditions are pointers to real's and integers in the calling model. + ! To flush these, we set all pointers to null + + ! Arguments + class(prt_vartypes) :: this + + ! Local + integer :: num_bc_in + integer :: num_bc_out + integer :: num_bc_inout + integer :: i + + if(allocated(this%bc_in))then + num_bc_in = size(this%bc_in,1) + do i = 1,num_bc_in + this%bc_in(i)%rval => null() + this%bc_in(i)%ival => null() + end do + end if + + if(allocated(this%bc_out))then + num_bc_out = size(this%bc_out,1) + do i = 1,num_bc_out + this%bc_out(i)%rval => null() + this%bc_out(i)%ival => null() + end do + end if + + if(allocated(this%bc_inout))then + num_bc_inout = size(this%bc_inout,1) + do i = 1,num_bc_inout + this%bc_inout(i)%rval => null() + this%bc_inout(i)%ival => null() + end do + end if + + return + end subroutine FlushBCs + + ! ===================================================================================== + + subroutine RegisterBCIn(this,bc_id, bc_rval, bc_ival ) + + ! This routine must be called once for each "input only" boundary condition of each + ! hypothesis. + ! The group of calls only needs to happen once, following InitPRTVartype. + ! Since we use pointers, we don't need to constantly ask for new boundary conditions + ! + ! The only complication to this would occur, if the boundary condition variable + ! that these pointers point to is being disassociated. In that case, one would + ! need to re-register that boundary condition variable. + + + ! Input Arguments + + class(prt_vartypes) :: this + integer,intent(in) :: bc_id + real(r8),optional, intent(inout), target :: bc_rval + integer, optional, intent(inout), target :: bc_ival + + if(present(bc_ival)) then + this%bc_in(bc_id)%ival => bc_ival + end if + + if(present(bc_rval)) then + this%bc_in(bc_id)%rval => bc_rval + end if + + + return + end subroutine RegisterBCIn + + ! ===================================================================================== + + subroutine RegisterBCOut(this,bc_id, bc_rval, bc_ival ) + + + ! This routine is similar to the routine above RegisterBCIn, except this + ! is for registering "output only" boundary conditions. + + + ! Input Arguments + + class(prt_vartypes) :: this + integer,intent(in) :: bc_id + real(r8), optional, intent(inout),target :: bc_rval + integer, optional, intent(inout),target :: bc_ival + + if(present(bc_ival)) then + this%bc_out(bc_id)%ival => bc_ival + end if + + if(present(bc_rval)) then + this%bc_out(bc_id)%rval => bc_rval + end if + + return + end subroutine RegisterBCOut + + ! ===================================================================================== + + subroutine RegisterBCInOut(this,bc_id, bc_rval, bc_ival ) + + + ! This routine is similar to the two routines above, except this + ! is for registering "input-output" boundary conditions. + ! These are conditions that are passed into PARTEH, and are expected + ! to be updated (or not), and passed back to the host (FATES). + + ! Input Arguments + + class(prt_vartypes) :: this + integer,intent(in) :: bc_id + real(r8), optional, intent(inout),target :: bc_rval + integer, optional, intent(inout),target :: bc_ival + + if(present(bc_ival)) then + this%bc_inout(bc_id)%ival => bc_ival + end if + + if(present(bc_rval)) then + this%bc_inout(bc_id)%rval => bc_rval + end if + + return + end subroutine RegisterBCInOut + + ! ===================================================================================== + + + subroutine CopyPRTVartypes(this, donor_prt_obj) + + ! Here we copy over all information from a donor_prt_object into the current PRT + ! object. It is assumed that the current PRT object + ! has already been initialized ( ie. InitAllocate() ) + ! variable val0 is omitted, because it is ephemeral and used only during the + ! allocation process + + ! Arguments + class(prt_vartypes) :: this + class(prt_vartypes), intent(in), pointer :: donor_prt_obj + + ! Locals + + integer :: i_var ! loop iterator for variable objects + integer :: i_bc ! loop iterator for boundary pointers + + integer :: num_bc_in + integer :: num_bc_inout + integer :: num_bc_out + + do i_var = 1, prt_global%num_vars + this%variables(i_var)%val(:) = donor_prt_obj%variables(i_var)%val(:) + this%variables(i_var)%val0(:) = donor_prt_obj%variables(i_var)%val0(:) + this%variables(i_var)%net_alloc(:) = donor_prt_obj%variables(i_var)%net_alloc(:) + this%variables(i_var)%turnover(:) = donor_prt_obj%variables(i_var)%turnover(:) + this%variables(i_var)%burned(:) = donor_prt_obj%variables(i_var)%burned(:) + end do + + this%ode_opt_step = donor_prt_obj%ode_opt_step + + return + end subroutine CopyPRTVartypes + + + ! ===================================================================================== + + subroutine WeightedFusePRTVartypes(this,donor_prt_obj, recipient_fuse_weight, position_id) + + ! This subroutine fuses two PRT objects together based on a fusion weighting + ! assigned for the recipient (the class calling this) + + ! Arguments + class(prt_vartypes) :: this + class(prt_vartypes), intent(in), pointer :: donor_prt_obj + real(r8),intent(in) :: recipient_fuse_weight ! This is the weighting + ! for the recipient + integer,intent(in),optional :: position_id + + ! Locals + integer :: i_var ! Loop iterator over variables + integer :: pos_id ! coordinate id (defaults to 1, if not position_id) + + if(present(position_id)) then + pos_id = position_id + else + pos_id = 1 + end if + + do i_var = 1, prt_global%num_vars + + this%variables(i_var)%val(pos_id) = recipient_fuse_weight * this%variables(i_var)%val(pos_id) + & + (1.0_r8-recipient_fuse_weight) * donor_prt_obj%variables(i_var)%val(pos_id) + + this%variables(i_var)%val0(pos_id) = recipient_fuse_weight * this%variables(i_var)%val0(pos_id) + & + (1.0_r8-recipient_fuse_weight) * donor_prt_obj%variables(i_var)%val0(pos_id) + + this%variables(i_var)%net_alloc(pos_id) = recipient_fuse_weight * this%variables(i_var)%net_alloc(pos_id) + & + (1.0_r8-recipient_fuse_weight) * donor_prt_obj%variables(i_var)%net_alloc(pos_id) + + this%variables(i_var)%turnover(pos_id) = recipient_fuse_weight * this%variables(i_var)%turnover(pos_id) + & + (1.0_r8-recipient_fuse_weight) * donor_prt_obj%variables(i_var)%turnover(pos_id) + + this%variables(i_var)%burned(pos_id) = recipient_fuse_weight * this%variables(i_var)%burned(pos_id) + & + (1.0_r8-recipient_fuse_weight) * donor_prt_obj%variables(i_var)%burned(pos_id) + + end do + + this%ode_opt_step = recipient_fuse_weight * this%ode_opt_step + & + (1.0_r8-recipient_fuse_weight) * donor_prt_obj%ode_opt_step + + + return + end subroutine WeightedFusePRTVartypes + + ! ===================================================================================== + + subroutine DeallocatePRTVartypes(this) + + ! --------------------------------------------------------------------------------- + ! Unfortunately ... all plants must die. It is sad, but when this happens + ! we must also deallocate our memory of them. Man, thats really is sad. Why + ! must we also forget them... Well, anyway, any time a plant/cohort + ! is deallocated, we must also deallocate all this memory bound in the PARTEH + ! data structure. But on the bright side, there will always be new recruits, + ! a new generation, to allocate as well. Life must go on. + ! I suppose since we are recording their life in the history output, in a way + ! we are remembering them. I feel better now. + ! --------------------------------------------------------------------------------- + + class(prt_vartypes) :: this + integer :: i_var + + ! Check to see if there is any value in these pools? + ! SHould not deallocate if there is any carbon left + + do i_var = 1, prt_global%num_vars + deallocate(this%variables(i_var)%val) + deallocate(this%variables(i_var)%val0) + deallocate(this%variables(i_var)%net_alloc) + deallocate(this%variables(i_var)%turnover) + deallocate(this%variables(i_var)%burned) + end do + + deallocate(this%variables) + + if(allocated(this%bc_in))then + deallocate(this%bc_in) + end if + + if(allocated(this%bc_out))then + deallocate(this%bc_out) + end if + + if(allocated(this%bc_inout))then + deallocate(this%bc_inout) + end if + + return + end subroutine DeallocatePRTVartypes + + ! ===================================================================================== + + subroutine ZeroRates(this) + + ! --------------------------------------------------------------------------------- + ! This subroutine zeros all of the rates of change for our variables. + ! It also sets the initial value to the current state. + ! This allows us to make mass conservation checks, where + ! val - val0 = net_alloc + turnover + ! + ! This subroutine is called each day in FATES, which is the control interval + ! that we conserve carbon from the allocation and turnover process. + ! --------------------------------------------------------------------------------- + + class(prt_vartypes) :: this + + integer :: i_var ! Variable index + + do i_var = 1, prt_global%num_vars + this%variables(i_var)%val0(:) = this%variables(i_var)%val(:) + this%variables(i_var)%net_alloc(:) = 0.0_r8 + this%variables(i_var)%turnover(:) = 0.0_r8 + this%variables(i_var)%burned(:) = 0.0_r8 + end do + + end subroutine ZeroRates + + ! ==================================================================================== + + subroutine CheckMassConservation(this,ipft,position_id) + + + ! --------------------------------------------------------------------------------- + ! At any time, the sum of fluxes should equal the difference between val and val0. + ! This routine loops over all variables and ensures this is true. + ! The final argument is any uniqely identifying index that can be used + ! to differentiate where in the call sequence a failure in conservation occurs. + ! --------------------------------------------------------------------------------- + + class(prt_vartypes) :: this + integer, intent(in) :: ipft ! functional type of the plant + integer, intent(in) :: position_id ! Helps to know where + ! in the call sequence this was called + + integer :: i_var ! Variable index + integer :: i_pos ! Position (coordinate) index + + real(r8) :: err ! absolute error [kg] + real(r8) :: rel_err ! error relative to the pool's size [kg] + + + do i_var = 1, prt_global%num_vars + + do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos + + err = abs((this%variables(i_var)%val(i_pos) - this%variables(i_var)%val0(i_pos)) - & + (this%variables(i_var)%net_alloc(i_pos) & + -this%variables(i_var)%turnover(i_pos) & + -this%variables(i_var)%burned(i_pos) )) + + if(this%variables(i_var)%val(i_pos) > nearzero ) then + rel_err = err / this%variables(i_var)%val(i_pos) + else + rel_err = 0.0_r8 + end if + + if( abs(err) > calloc_abs_error ) then + write(fates_log(),*) 'PARTEH mass conservation check failed' + write(fates_log(),*) ' Change in mass over control period should' + write(fates_log(),*) ' always equal the integrated fluxes.' + write(fates_log(),*) ' pft id: ',ipft + write(fates_log(),*) ' position id: ',position_id + write(fates_log(),*) ' organ id: ',prt_global%state_descriptor(i_var)%organ_id + write(fates_log(),*) ' element_id: ',prt_global%state_descriptor(i_var)%element_id + write(fates_log(),*) ' position id: ',i_pos + write(fates_log(),*) ' symbol: ',trim(prt_global%state_descriptor(i_var)%symbol) + write(fates_log(),*) ' longname: ',trim(prt_global%state_descriptor(i_var)%longname) + write(fates_log(),*) ' err: ',err,' max error: ',calloc_abs_error + write(fates_log(),*) ' terms: ', this%variables(i_var)%val(i_pos), & + this%variables(i_var)%val0(i_pos), & + this%variables(i_var)%net_alloc(i_pos), & + this%variables(i_var)%turnover(i_pos), & + this%variables(i_var)%burned(i_pos) + write(fates_log(),*) ' Exiting.' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + end do + end do + + return + end subroutine CheckMassConservation + + ! ==================================================================================== + + function GetState(this, organ_id, element_id, position_id) result(state_val) + + ! This function returns the current amount of mass for + ! any combination of organ and element. **IF** a position + ! is provided, it will use it, but otherwise, it will sum over + ! all dimensions. It also can accomodate all_carbon_element, which + ! will return the mass of all carbon isotopes combined. + + class(prt_vartypes) :: this + integer,intent(in) :: organ_id ! Organ type querried + integer,intent(in) :: element_id ! Element type querried + integer,intent(in),optional :: position_id ! Position querried + real(r8) :: state_val ! Mass (value) of state variable [kg] + + integer :: i_pos ! position loop counter + integer :: i_element ! element loop counter + integer :: num_element ! total number of elements + integer,dimension(max_spec_per_group) :: element_ids ! element ids (if element list) + integer :: i_var ! variable id + + state_val = 0.0_r8 + + if(element_id == all_carbon_elements) then + element_ids(1:3) = carbon_elements_list(1:3) + num_element = 3 + else + num_element = 1 + element_ids(1) = element_id + end if + + if(present(position_id)) then + i_pos = position_id + + do i_element = 1,num_element + i_var = prt_global%sp_organ_map(organ_id,element_ids(i_element)) + if (i_var>0) state_val = state_val + this%variables(i_var)%val(i_pos) + end do + + else + + do i_element = 1,num_element + + i_var = prt_global%sp_organ_map(organ_id,element_ids(i_element)) + if(i_var>0)then + do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos + state_val = state_val + this%variables(i_var)%val(i_pos) + end do + end if + + end do + + end if + + return + end function GetState + + + ! ==================================================================================== + + + function GetTurnover(this, organ_id, element_id, position_id) result(turnover_val) + + + ! THis function is very similar to GetState, with the only difference that it + ! returns the turnover mass so-far during the period of interest. + ! + ! NOTE: THIS HAS NOTHING TO DO WITH SPECIFYING TURNOVER. THIS IS JUST A QUERY FUNCTION + + + class(prt_vartypes) :: this + integer,intent(in) :: organ_id ! Organ type querried + integer,intent(in) :: element_id ! Element type querried + integer,intent(in),optional :: position_id ! Position querried + real(r8) :: turnover_val ! Amount (value) of turnover [kg] + + integer :: i_pos ! position loop counter + integer :: i_element ! element loop counter + integer :: num_element ! total number of elements + integer,dimension(max_spec_per_group) :: element_ids ! element ids (if element list) + integer :: i_var ! variable id + + turnover_val = 0.0_r8 + + if(element_id == all_carbon_elements) then + element_ids(1:3) = carbon_elements_list(1:3) + num_element = 3 + else + num_element = 1 + element_ids(1) = element_id + end if + + if(present(position_id)) then + i_pos = position_id + + do i_element = 1,num_element + i_var = prt_global%sp_organ_map(organ_id,element_ids(i_element)) + if(i_var>0) turnover_val = turnover_val + & + this%variables(i_var)%turnover(i_pos) + end do + + else + + do i_element = 1,num_element + i_var = prt_global%sp_organ_map(organ_id,element_ids(i_element)) + if(i_var>0) then + do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos + turnover_val = turnover_val + this%variables(i_var)%turnover(i_pos) + end do + end if + + end do + + end if + + return + end function GetTurnover + + ! ========================================================================= + + function GetBurned(this, organ_id, element_id, position_id) result(burned_val) + + ! THis function is very similar to GetTurnover, with the only difference that it + ! returns the burned mass so-far during the period of interest. + + ! NOTE: THIS HAS NOTHING TO DO WITH SPECIFYING BURNING. THIS IS JUST A QUERY FUNCTION + + class(prt_vartypes) :: this + integer,intent(in) :: organ_id ! Organ type querried + integer,intent(in) :: element_id ! Element type querried + integer,intent(in),optional :: position_id ! Position querried + real(r8) :: burned_val ! Amount (value) of burned [kg] + + integer :: i_pos ! position loop counter + integer :: i_element ! element loop counter + integer :: num_element ! total number of elements + integer,dimension(max_spec_per_group) :: element_ids ! element ids (if element list) + integer :: i_var ! variable id + + + burned_val = 0.0_r8 + + if(element_id == all_carbon_elements) then + element_ids(1:3) = carbon_elements_list(1:3) + num_element = 3 + else + num_element = 1 + element_ids(1) = element_id + end if + + if(present(position_id)) then + i_pos = position_id + + do i_element = 1,num_element + i_var = prt_global%sp_organ_map(organ_id,element_ids(i_element)) + if(i_var>0) burned_val = burned_val + & + this%variables(i_var)%burned(i_pos) + end do + + else + + do i_element = 1,num_element + i_var = prt_global%sp_organ_map(organ_id,element_ids(i_element)) + if(i_var>0) then + do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos + burned_val = burned_val + this%variables(i_var)%burned(i_pos) + end do + end if + + end do + + end if + + return + end function GetBurned + + ! ==================================================================================== + + function GetNetAlloc(this, organ_id, element_id, position_id) result(val_netalloc) + + ! THis function is very similar to GetTurnover, with the only difference that it + ! returns the Net changes due to Allocations Reactions and Transport in that pool + + ! NOTE: THIS HAS NOTHING TO DO WITH SPECIFYING ALLOCATION/TRANSPORT. + ! THIS IS JUST A QUERY FUNCTION + + class(prt_vartypes) :: this + integer,intent(in) :: organ_id ! Organ type querried + integer,intent(in) :: element_id ! Element type querried + integer,intent(in),optional :: position_id ! Position querried + real(r8) :: val_netalloc ! Amount (value) of allocation [kg] + + integer :: i_pos ! position loop counter + integer :: i_element ! element loop counter + integer :: num_element ! total number of elements + integer,dimension(max_spec_per_group) :: element_ids ! element ids (if element list) + integer :: i_var ! variable id + + val_netalloc = 0.0_r8 + + if(element_id == all_carbon_elements) then + element_ids(1:3) = carbon_elements_list(1:3) + num_element = 3 + else + num_element = 1 + element_ids(1) = element_id + end if + + if(present(position_id)) then + i_pos = position_id + + do i_element = 1,num_element + i_var = prt_global%sp_organ_map(organ_id,element_ids(i_element)) + if(i_var>0) val_netalloc = val_netalloc + & + this%variables(i_var)%net_alloc(i_pos) + end do + + else + + do i_element = 1,num_element + i_var = prt_global%sp_organ_map(organ_id,element_ids(i_element)) + if(i_var>0) then + do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos + val_netalloc = val_netalloc + this%variables(i_var)%net_alloc(i_pos) + end do + end if + + end do + + end if + + return + end function GetNetAlloc + + ! ===================================================================================== + + function GetCoordVal(this, organ_id, element_id ) result(prt_val) + + ! This is support code that may be helpful when we have variables in parteh + ! that have multiple discrete spatial positions. + + + class(prt_vartypes) :: this + integer,intent(in) :: organ_id + integer,intent(in) :: element_id + real(r8) :: prt_val + + write(fates_log(),*)'Init must be extended by a child class.' + call endrun(msg=errMsg(__FILE__, __LINE__)) + + end function GetCoordVal + + ! ==================================================================================== + + subroutine DailyPRTBase(this) + + class(prt_vartypes) :: this + + write(fates_log(),*)'Daily PRT Allocation must be extended' + call endrun(msg=errMsg(__FILE__, __LINE__)) + + end subroutine DailyPRTBase + + ! ==================================================================================== + + subroutine FastPRTBase(this) + + class(prt_vartypes) :: this + + write(fates_log(),*)'FastReactiveTransport must be extended by a child class.' + call endrun(msg=errMsg(__FILE__, __LINE__)) + + end subroutine FastPRTBase + + ! ==================================================================================== + + subroutine SetState(prt,organ_id, element_id, state_val, position_id) + + ! This routine should only be called for initalizing the state value + ! of a plant's pools. A value is passed in to set the state of + ! organ and element couplets, and position id if it is provided. + ! A select statement will most definitely bracket the call to this + ! routine. + + class(prt_vartypes) :: prt + integer,intent(in) :: organ_id ! organ of interest + integer,intent(in) :: element_id ! element of interest + real(r8),intent(in) :: state_val ! value to be initialized + integer,intent(in),optional :: position_id ! position of interest + + integer :: i_element ! loop counter for elements + integer :: i_var ! variable loop counter + integer :: i_pos ! position loop counter + + if(element_id == all_carbon_elements) then + write(fates_log(),*) 'You cannot set the state of all isotopes simultaneously.' + write(fates_log(),*) 'You can only set 1. Exiting.' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + if( present(position_id) ) then + i_pos = position_id + else + i_pos = 1 + end if + + i_var = prt_global%sp_organ_map(organ_id,element_id) + + if(i_pos > prt_global%state_descriptor(i_var)%num_pos )then + write(fates_log(),*) 'A position index was specified that is' + write(fates_log(),*) 'greater than the allocated position space' + write(fates_log(),*) ' i_pos: ',i_pos + write(fates_log(),*) ' num_pos: ',prt_global%state_descriptor(i_var)%num_pos + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + + if(i_var>0) then + prt%variables(i_var)%val(i_pos) = state_val + else + write(fates_log(),*) 'A mass was sent to PARTEH to over-write' + write(fates_log(),*) ' a pool with a specie x organ combination. ' + write(fates_log(),*) ' that does not exist.' + write(fates_log(),*) ' organ_id:',organ_id + write(fates_log(),*) ' element_id:',element_id + write(fates_log(),*) 'Exiting' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + + return + end subroutine SetState + + ! ==================================================================================== + + +end module PRTGenericMod diff --git a/parteh/PRTLossFluxesMod.F90 b/parteh/PRTLossFluxesMod.F90 new file mode 100644 index 0000000000..e91ee09bf2 --- /dev/null +++ b/parteh/PRTLossFluxesMod.F90 @@ -0,0 +1,682 @@ +module PRTLossFluxesMod + + use EDPftvarcon, only : EDPftvarcon_inst + 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 : repro_organ + use PRTGenericMod, only : struct_organ + use PRTGenericMod, only : carbon_elements_list + use PRTGenericMod, only : carbon12_element + use PRTGenericMod, only : carbon13_element + use PRTGenericMod, only : carbon14_element + use PRTGenericMod, only : nitrogen_element + use PRTGenericMod, only : phosphorous_element + use PRTGenericMod, only : un_initialized + use PRTGenericMod, only : check_initialized + use PRTGenericMod, only : num_organ_types + use PRTGenericMod, only : prt_global + use FatesInterfaceMod, only : hlm_freq_day + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : i4 => fates_int + use FatesConstantsMod, only : nearzero + use FatesConstantsMod, only : calloc_abs_error + use FatesGlobals , only : endrun => fates_endrun + use FatesGlobals , only : fates_log + use shr_log_mod , only : errMsg => shr_log_errMsg + + + implicit none + private + + ! ------------------------------------------------------------------------------------- + ! These modules house the public functions that handle all things + ! related to loss fluxes. They broadly cover the two types of turnover; + ! that which happens as events (storms, deciduous drop, herbivory + ! fire, etc), and maintenance turnover (constant background) + ! of evergreens, and branchfall). + ! + ! IMPORTANT POINTS! + ! Retranslocation is handled by a single + ! flag that defines the mode for each PFT. So there + ! are assumptions here. A deciduous plant does not + ! have maintenance leaf and fine-root turnover. An evergreen + ! plant does not have seasonal or stress induced phenology. + ! Therefore, the retranslocation parameter + ! will have different meanings potentially, for each PFT. For evergreens, + ! it will be the retranslocation during maintenance turnover. For deciduous, + ! it is during leaf drop. + ! + ! THIS ROUTINE ONLY DEALS WITH LOSSES OF BIOMASS FROM PLANTS THAT ARE SURVIVING + ! AN EVENT. IF A PLANT DIES, THEN THESE ROUTINES DO NOT HANDLE ITS FLUXES. It + ! is however likely that an event like fire will kill a portion of a population, + ! and damage the remaining population, these routines will assist in the latter. + ! + ! EDPftvarcon_inst%turnover_retrans_mode + ! ------------------------------------------------------------------------------------- + + public :: PRTDeciduousTurnover + public :: PRTMaintTurnover + public :: PRTBurnLosses + public :: PRTPhenologyFlush + public :: PRTReproRelease + +contains + + + subroutine PRTPhenologyFlush(prt, ipft, organ_id, c_store_transfer_frac) + + ! ---------------------------------------------------------------------------------- + ! This subroutine is used to flush (leaves) from storage upon bud-burst. + ! Leaves are somewhat implied here, but the function does allow for other + ! pools (fine-roots) to be flushed from storage as well. + ! ---------------------------------------------------------------------------------- + + class(prt_vartypes) :: prt + integer,intent(in) :: ipft + integer,intent(in) :: organ_id + real(r8),intent(in) :: c_store_transfer_frac ! carbon mass fraction + ! transferred from storage + + integer :: i_var ! variable index + integer :: i_var_of_organ ! index for all variables in + ! a given organ (mostly likely + ! synonymous with diff elements) + integer :: i_cvar ! carbon variable index + integer :: i_pos ! spatial position index + integer :: i_store ! storage variable index + integer :: element_id ! global element identifier + real(r8) :: mass_transfer ! The actual mass + ! removed from storage + ! for each pool + real(r8) :: target_stoich ! stoichiometry of pool of interest + real(r8) :: sp_target ! target nutrient mass for element + real(r8) :: sp_demand ! nutrient demand for element + + + ! We currently only allow the flushing and drop of leaves. + ! If other organs should be desired (like seasonality of fine-roots) + ! those parameters and clauses need to be added + + if(organ_id .ne. leaf_organ) then + write(fates_log(),*) 'Deciduous drop and re-flushing only allowed in leaves' + write(fates_log(),*) ' leaf_organ: ',leaf_organ + write(fates_log(),*) ' organ: ',organ_id + write(fates_log(),*) 'Exiting' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + + associate(organ_map => prt_global%organ_map) + + ! Flush carbon variables first, as their transfer + ! rates from storage is dependant on the fraction + ! passed in by the argument. + ! After the values are updated, we can then + ! identify the stoichiometry targets which + ! govern the nutrient fluxes + + do i_var_of_organ = 1, organ_map(organ_id)%num_vars + + ! The variable index + i_var = organ_map(organ_id)%var_id(i_var_of_organ) + + ! The element index of the varible of interest + element_id = prt_global%state_descriptor(i_var)%element_id + + ! This will filter IN all carbon related variables + if( any(element_id == carbon_elements_list) ) then + + ! No hypotheses exist for how to flush carbon isotopes + ! yet. Please fill this in. + if( (element_id == carbon13_element) .or. & + (element_id == carbon14_element) )then + write(fates_log(),*) ' Phenology flushing routine does not know' + write(fates_log(),*) ' how to handle carbon isotopes. Please' + write(fates_log(),*) ' evaluate the code referenced in this message' + write(fates_log(),*) ' and provide a hypothesis.' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + ! Get the variable id of the storage pool for this element (carbon12) + i_store = prt_global%sp_organ_map(store_organ,element_id) + + ! Loop over all of the coordinate ids + do i_pos = 1,prt_global%state_descriptor(i_var)%num_pos + + ! Calculate the mass transferred out of storage into the pool of interest + mass_transfer = prt%variables(i_store)%val(i_pos) * c_store_transfer_frac + + ! Increment the c pool of interest's allocation flux + prt%variables(i_var)%net_alloc(i_pos) = & + prt%variables(i_var)%net_alloc(i_pos) + mass_transfer + + ! Update the c pool + prt%variables(i_var)%val(i_pos) = & + prt%variables(i_var)%val(i_pos) + mass_transfer + + ! Increment the storage pool's allocation flux + prt%variables(i_store)%net_alloc(i_pos) = & + prt%variables(i_store)%net_alloc(i_pos) - mass_transfer + + ! Update the storage c pool + prt%variables(i_store)%val(i_pos) = & + prt%variables(i_store)%val(i_pos) - mass_transfer + + + end do + end if + end do + + + ! Transfer in other elements (nutrients) + ! -------------------------------------------------------------------------------- + + do i_var_of_organ = 1, organ_map(organ_id)%num_vars + + i_var = organ_map(organ_id)%var_id(i_var_of_organ) + + ! Variable index for the element of interest + element_id = prt_global%state_descriptor(i_var)%element_id + + ! This will filter OUT all carbon related elements + if ( .not. any(element_id == carbon_elements_list) ) then + + ! Get the variable id of the storage pool for this element + i_store = prt_global%sp_organ_map(store_organ,element_id) + + ! Calculate the stoichiometry with C for this element + + if( element_id == nitrogen_element ) then + target_stoich = EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,organ_id) + else if( element_id == phosphorous_element ) then + target_stoich = EDPftvarcon_inst%prt_phos_stoich_p1(ipft,organ_id) + else + write(fates_log(),*) ' Trying to calculate nutrient flushing target' + write(fates_log(),*) ' for element that DNE' + write(fates_log(),*) ' organ: ',organ_id,' element: ',element_id + write(fates_log(),*) 'Exiting' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + + ! Loop over all of the coordinate ids + do i_pos = 1,prt_global%state_descriptor(i_var)%num_pos + + ! The target quanitity for this element is based on the amount + ! of carbon + sp_target = prt%variables(i_cvar)%val(i_pos) * target_stoich + + sp_demand = max(0.0_r8,sp_target - prt%variables(i_var)%val(i_pos)) + + ! Assume that all of the storage is transferrable + mass_transfer = min(sp_demand, prt%variables(i_store)%val(i_pos)) + + ! Increment the pool of interest + prt%variables(i_var)%net_alloc(i_pos) = & + prt%variables(i_var)%net_alloc(i_pos) + mass_transfer + + ! Update the c pool + prt%variables(i_var)%val(i_pos) = & + prt%variables(i_var)%val(i_pos) + mass_transfer + + ! Increment the c pool of interest + prt%variables(i_store)%net_alloc(i_pos) = & + prt%variables(i_store)%net_alloc(i_pos) - mass_transfer + + ! Update the c pool + prt%variables(i_store)%val(i_pos) = & + prt%variables(i_store)%val(i_pos) - mass_transfer + + + end do + + end if + + end do + + end associate + return + end subroutine PRTPhenologyFlush + + ! ===================================================================================== + + subroutine PRTBurnLosses(prt, organ_id, mass_fraction) + + ! ---------------------------------------------------------------------------------- + ! This subroutine assumes that there is no re-translocation associated + ! with burn. There is only one destiny for burned mass within + ! the organ, and that is outside the plant. + ! It is also assumed that non PARTEH parts of the code (ie the fire-model) + ! will decide what to do with the burned mass (i.e. sent it to the litter + ! pool or send to atmosphere, or.. other?) + ! ---------------------------------------------------------------------------------- + + class(prt_vartypes) :: prt + integer,intent(in) :: organ_id + real(r8),intent(in) :: mass_fraction + + integer :: i_pos ! position index + integer :: i_var ! index for the variable of interest + integer :: i_var_of_organ ! loop counter for all element in this organ + integer :: element_id ! Element id of the turnover pool + real(r8) :: burned_mass ! Burned mass of each element, in eahc + ! position, in the organ of interest + + associate(organ_map => prt_global%organ_map) + + ! This is the total number of state variables associated + ! with this particular organ + + do i_var_of_organ = 1, organ_map(organ_id)%num_vars + + i_var = organ_map(organ_id)%var_id(i_var_of_organ) + + element_id = prt_global%state_descriptor(i_var)%element_id + + ! Loop over all of the coordinate ids + do i_pos = 1,prt_global%state_descriptor(i_var)%num_pos + + ! The mass that is leaving the plant + burned_mass = mass_fraction * prt%variables(i_var)%val(i_pos) + + ! Track the amount of mass being burned (+ is amount lost) + prt%variables(i_var)%burned(i_pos) = prt%variables(i_var)%burned(i_pos) & + + burned_mass + + ! Update the state of the pool to reflect the mass lost + prt%variables(i_var)%val(i_pos) = prt%variables(i_var)%val(i_pos) & + - burned_mass + + end do + + end do + + end associate + end subroutine PRTBurnLosses + + + ! ===================================================================================== + + + subroutine PRTReproRelease(prt, organ_id, element_id, mass_fraction, mass_out) + + ! ---------------------------------------------------------------------------------- + ! This subroutine assumes that there is no re-translocation associated + ! with the release of reproductive tissues. + ! We also do not have a special flux for the release of reproductive + ! tissues. To not confuse this with turnover, we will provide an output + ! mass flux, and instead of tracking it, we will just set val0 to val + ! to prevent mass imbalances. + ! ---------------------------------------------------------------------------------- + + class(prt_vartypes) :: prt + integer,intent(in) :: organ_id + integer,intent(in) :: element_id + real(r8),intent(in) :: mass_fraction + real(r8),intent(out) :: mass_out + + integer :: i_pos ! position index + integer :: i_var ! index for the variable of interest + + + associate(organ_map => prt_global%organ_map, & + sp_organ_map => prt_global%sp_organ_map, & + state_descriptor => prt_global%state_descriptor) + + ! This is the total number of state variables associated + ! with this particular organ. + ! In the future, we may have more finely resolved reproductive + ! tissues (ie seeds, flowers, etc). but now we just have 1. + + if (organ_id .ne. repro_organ) then + write(fates_log(),*) 'Reproductive tissue releases were called for a non-reproductive' + write(fates_log(),*) 'organ.' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + if (element_id .ne. carbon12_element) then + write(fates_log(),*) 'Reproductive tissue releases were called for a element other than c12' + write(fates_log(),*) 'Only carbon seed masses are curently handled.' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + ! This is the total number of state variables associated + ! with this particular organ + + i_var = sp_organ_map(organ_id,element_id) + + ! Reproductive mass leaving the plant + mass_out = 0.0_r8 + + ! Loop over all of the coordinate ids + do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos + + ! The mass that is leaving the plant + mass_out = mass_out + mass_fraction * prt%variables(i_var)%val(i_pos) + + ! Update the state of the pool to reflect the mass lost + prt%variables(i_var)%val(i_pos) = prt%variables(i_var)%val(i_pos) - & + (mass_fraction * prt%variables(i_var)%val(i_pos)) + + ! Update the val0 (because we don't give this dedicated flux) + ! This is somewhat of a hack + prt%variables(i_var)%val0(i_pos) = prt%variables(i_var)%val(i_pos) - & + prt%variables(i_var)%net_alloc(i_pos) + + + end do + + end associate + end subroutine PRTReproRelease + + ! =================================================================================== + + subroutine PRTDeciduousTurnover(prt,ipft,organ_id,mass_fraction) + + ! --------------------------------------------------------------------------------- + ! Generic subroutine (wrapper) calling specialized routines handling + ! the turnover of tissues in living plants (non-mortal) + ! --------------------------------------------------------------------------------- + + class(prt_vartypes) :: prt + integer,intent(in) :: ipft + integer,intent(in) :: organ_id ! see PRTGenericMod for organ list + real(r8),intent(in) :: mass_fraction ! The fraction of mass in this organ that should + ! leave the indicated organ. + + ! We currently only allow the flushing and drop of leaves. + ! If other organs should be desired (like seasonality of fine-roots) + ! those parameters and clauses need to be added + + if(organ_id .ne. leaf_organ) then + write(fates_log(),*) 'Deciduous drop and re-flushing only allowed in leaves' + write(fates_log(),*) ' leaf_organ: ',leaf_organ + write(fates_log(),*) ' organ: ',organ_id + write(fates_log(),*) 'Exiting' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + + if ( int(EDPftvarcon_inst%turnover_retrans_mode(ipft)) == 1 ) then + call DeciduousTurnoverSimpleRetranslocation(prt,ipft,organ_id,mass_fraction) + else + write(fates_log(),*) 'A retranslocation mode was specified for deciduous drop' + write(fates_log(),*) 'that is unknown.' + write(fates_log(),*) 'turnover_retrans_mode= ',EDPftvarcon_inst%turnover_retrans_mode(ipft) + write(fates_log(),*) 'pft = ',ipft + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + return + end subroutine PRTDeciduousTurnover + + + ! ==================================================================================== + + subroutine DeciduousTurnoverSimpleRetranslocation(prt,ipft,organ_id,mass_fraction) + + ! --------------------------------------------------------------------------------- + ! Calculate losses due to deciduous turnover. + ! the turnover of tissues in living plants (non-mortal) + ! + ! ALERT: NO CODE IS CURRENTLY IN PLACE TO LIMIT THE AMOUNT OF CARBON OR NUTRIENT + ! CAN BE RE-TRANSLOCATED INTO STORAGE. IT IS POSSIBLE THAT THE MAXIMUM IS BEING + ! OVER-SHOT. TO FIX THIS, EACH HYPOTHESIS NEEDS TO HAVE WRAPPER CODE + ! TO PROVIDE A WAY TO CALCULATE MAXIMUM ALLOWABLE STORAGE. + ! + ! --------------------------------------------------------------------------------- + + class(prt_vartypes) :: prt + integer,intent(in) :: ipft + integer,intent(in) :: organ_id ! see PRTGenericMod for organ list + real(r8),intent(in) :: mass_fraction ! The fraction of mass in this organ that should + ! leave the indicated organ. + + integer :: i_var ! index for the variable of interest + integer :: i_var_of_organ ! loop counter for all element in this organ + integer :: element_id ! Element id of the turnover pool + integer :: store_var_id ! Variable id of the storage pool + integer :: i_pos ! position index (spatial) + real(r8) :: retrans ! retranslocated fraction + real(r8) :: turnover_mass ! mass sent to turnover (leaves the plant) + real(r8) :: retranslocated_mass ! mass redistributed to storage + + + associate(organ_map => prt_global%organ_map) + + if( (organ_id == store_organ) .or. & + (organ_id == struct_organ) .or. & + (organ_id == sapw_organ)) then + + write(fates_log(),*) 'Deciduous turnover (leaf drop, etc)' + write(fates_log(),*) ' was specified for an unexpected organ' + write(fates_log(),*) ' organ: ',organ_id + write(fates_log(),*) 'Exiting' + call endrun(msg=errMsg(__FILE__, __LINE__)) + + end if + + do i_var_of_organ = 1, organ_map(organ_id)%num_vars + + i_var = organ_map(organ_id)%var_id(i_var_of_organ) + + element_id = prt_global%state_descriptor(i_var)%element_id + + if ( any(element_id == carbon_elements_list) ) then + retrans = EDPftvarcon_inst%turnover_carb_retrans(ipft,organ_id) + else if( element_id == nitrogen_element ) then + retrans = EDPftvarcon_inst%turnover_nitr_retrans(ipft,organ_id) + else if( element_id == phosphorous_element ) then + retrans = EDPftvarcon_inst%turnover_phos_retrans(ipft,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 + + ! Get the variable id of the storage pool for this element + store_var_id = prt_global%sp_organ_map(store_organ,element_id) + + ! Loop over all of the coordinate ids + do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos + + ! The mass that is leaving the plant + turnover_mass = (1.0_r8 - retrans) * mass_fraction * prt%variables(i_var)%val(i_pos) + + ! The mass that is going towards storage + retranslocated_mass = retrans * mass_fraction * prt%variables(i_var)%val(i_pos) + + ! Track the amount of mass being turned over (+ is amount lost) + prt%variables(i_var)%turnover(i_pos) = prt%variables(i_var)%turnover(i_pos) & + + turnover_mass + + ! Track the amount of mass the is being re-translocated (- is amount lost) + prt%variables(i_var)%net_alloc(i_pos) = prt%variables(i_var)%net_alloc(i_pos) & + - retranslocated_mass + + ! Update the state of the pool to reflect the mass lost + prt%variables(i_var)%val(i_pos) = prt%variables(i_var)%val(i_pos) & + - (turnover_mass + retranslocated_mass) + + ! Now, since re-translocation is handled by the storage pool, + ! we add the re-translocated mass to it + + prt%variables(store_var_id)%net_alloc(i_pos) = & + prt%variables(store_var_id)%net_alloc(i_pos) + retranslocated_mass + + prt%variables(store_var_id)%val(i_pos) = & + prt%variables(store_var_id)%val(i_pos) + retranslocated_mass + + end do + + end do + + end associate + + return + end subroutine DeciduousTurnoverSimpleRetranslocation + + ! ==================================================================================== + + subroutine PRTMaintTurnover(prt,ipft) + + ! --------------------------------------------------------------------------------- + ! Generic subroutine (wrapper) calling specialized routines handling + ! the turnover of tissues in living plants (non-mortal) + ! --------------------------------------------------------------------------------- + class(prt_vartypes) :: prt + integer,intent(in) :: ipft + + if ( int(EDPftvarcon_inst%turnover_retrans_mode(ipft)) == 1 ) then + call MaintTurnoverSimpleRetranslocation(prt,ipft) + else + write(fates_log(),*) 'A maintenance/retranslocation mode was specified' + write(fates_log(),*) 'that is unknown.' + write(fates_log(),*) 'turnover_retrans_mode= ',EDPftvarcon_inst%turnover_retrans_mode(ipft) + write(fates_log(),*) 'pft = ',ipft + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + return + end subroutine PRTMaintTurnover + + ! =================================================================================== + + subroutine MaintTurnoverSimpleRetranslocation(prt,ipft) + + ! --------------------------------------------------------------------------------- + ! This subroutine removes biomass from all applicable pools due to + ! "maintenance turnover". Maintenance turnover, in this context + ! is the loss of biomass on living plants, due to continuous turnover. + ! + ! Notes: + ! 1) It is assumed that this is called daily. + ! 2) This is a completely different thing compared to deciduous leaf drop, + ! or loss of biomass from the death of the plant. + ! 3) Since this is maintenance turnover, and not a complete drop of leaves for + ! deciduous trees, we just re-translocate nutrients (if necessary) from the + ! leaves and roots that leave (no pun intended), into the leaves and roots that + ! are still rooted to the plant (pun intended). For deciduous, event-based + ! phenology, we will re-translocate to the storage pool. + ! 4) There are currently no reaction costs associated with re-translocation + ! --------------------------------------------------------------------------------- + + class(prt_vartypes) :: prt + integer,intent(in) :: ipft + + integer :: i_var ! the variable index + integer :: element_id ! the element associated w/ each variable + integer :: organ_id ! the organ associated w/ each variable + integer :: i_pos ! spatial position loop counter + + real(r8) :: turnover ! Actual turnover removed from each + ! pool [kg] + real(r8) :: retrans ! A temp for the actual re-translocated mass + + ! A temp for the actual turnover removed from pool + real(r8), dimension(num_organ_types) :: base_turnover + + ! ----------------------------------------------------------------------------------- + ! Calculate the turnover rates (maybe this should be done once in the parameter + ! check routine. Perhaps generate a rate in parameters derived? + ! ----------------------------------------------------------------------------------- + + base_turnover(:) = un_initialized + + ! All plants can have branch turnover, if branchfall is nonz-ero, + ! which will reduce sapwood, structure and storage. + ! ----------------------------------------------------------------------------------- + + if ( EDPftvarcon_inst%branch_turnover(ipft) > nearzero ) then + base_turnover(sapw_organ) = hlm_freq_day / EDPftvarcon_inst%branch_turnover(ipft) + base_turnover(struct_organ) = hlm_freq_day / EDPftvarcon_inst%branch_turnover(ipft) + base_turnover(store_organ) = hlm_freq_day / EDPftvarcon_inst%branch_turnover(ipft) + else + base_turnover(sapw_organ) = 0.0_r8 + base_turnover(struct_organ) = 0.0_r8 + base_turnover(store_organ) = 0.0_r8 + end if + + ! All plants are allowed to have fine-root turnover if a non-zero + ! life-span is selected + ! --------------------------------------------------------------------------------- + if ( EDPftvarcon_inst%root_long(ipft) > nearzero ) then + base_turnover(fnrt_organ) = hlm_freq_day / EDPftvarcon_inst%root_long(ipft) + else + base_turnover(fnrt_organ) = 0.0_r8 + end if + + ! Only EVERGREENS HAVE MAINTENANCE LEAF TURNOVER + ! ------------------------------------------------------------------------------------- + if ( (EDPftvarcon_inst%leaf_long(ipft) > nearzero ) .and. & + (EDPftvarcon_inst%evergreen(ipft) == 1) ) then + base_turnover(leaf_organ) = hlm_freq_day / EDPftvarcon_inst%leaf_long(ipft) + else + base_turnover(leaf_organ) = 0.0_r8 + endif + + 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 = EDPftvarcon_inst%turnover_carb_retrans(ipft,organ_id) + else if( element_id == nitrogen_element ) then + retrans = EDPftvarcon_inst%turnover_nitr_retrans(ipft,organ_id) + else if( element_id == phosphorous_element ) then + retrans = EDPftvarcon_inst%turnover_phos_retrans(ipft,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 + + if(base_turnover(organ_id) < check_initialized) then + write(fates_log(),*) 'A maintenance turnover rate for the organ' + write(fates_log(),*) ' was not specified....' + write(fates_log(),*) ' organ: ',organ_id,' element: ',element_id + write(fates_log(),*) ' base turnover rate: ',base_turnover(organ_id) + write(fates_log(),*) 'Exiting' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + ! Loop over all of the coordinate ids + + if(retrans<0.0 .or. retrans>1.0) then + write(fates_log(),*) 'Unacceptable retranslocation calculated' + write(fates_log(),*) ' organ: ',organ_id,' element: ',element_id + write(fates_log(),*) ' retranslocation fraction: ',retrans + write(fates_log(),*) 'Exiting' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + + do i_pos = 1, prt_global%state_descriptor(i_var)%num_pos + + turnover = (1.0_r8 - retrans) * base_turnover(organ_id) * prt%variables(i_var)%val(i_pos) + + prt%variables(i_var)%turnover(i_pos) = prt%variables(i_var)%turnover(i_pos) + turnover + + prt%variables(i_var)%val(i_pos) = prt%variables(i_var)%val(i_pos) - turnover + + end do + + end do + + return + end subroutine MaintTurnoverSimpleRetranslocation + + + + + +end module PRTLossFluxesMod