diff --git a/biogeochem/EDCanopyStructureMod.F90 b/biogeochem/EDCanopyStructureMod.F90 index 0e2de53919..bd34ef9bfc 100644 --- a/biogeochem/EDCanopyStructureMod.F90 +++ b/biogeochem/EDCanopyStructureMod.F90 @@ -12,6 +12,7 @@ module EDCanopyStructureMod use FatesConstantsMod , only : rsnbl_math_prec use FatesGlobals , only : fates_log use EDPftvarcon , only : EDPftvarcon_inst + use PRTParametersMod , only : prt_params use FatesAllometryMod , only : carea_allom use EDCohortDynamicsMod , only : copy_cohort, terminate_cohorts, fuse_cohorts use EDCohortDynamicsMod , only : InitPRTObject @@ -280,12 +281,12 @@ subroutine canopy_structure( currentSite , bc_in ) write(fates_log(),*) 'coh n:',currentCohort%n write(fates_log(),*) 'coh carea:',currentCohort%c_area ipft=currentCohort%pft - write(fates_log(),*) 'maxh:',EDPftvarcon_inst%allom_dbh_maxheight(ipft) - write(fates_log(),*) 'lmode: ',EDPftvarcon_inst%allom_lmode(ipft) - write(fates_log(),*) 'd2bl2: ',EDPftvarcon_inst%allom_d2bl2(ipft) - write(fates_log(),*) 'd2bl_ediff: ',EDPftvarcon_inst%allom_blca_expnt_diff(ipft) - write(fates_log(),*) 'd2ca_min: ',EDPftvarcon_inst%allom_d2ca_coefficient_min(ipft) - write(fates_log(),*) 'd2ca_max: ',EDPftvarcon_inst%allom_d2ca_coefficient_max(ipft) + write(fates_log(),*) 'maxh:',prt_params%allom_dbh_maxheight(ipft) + write(fates_log(),*) 'lmode: ',prt_params%allom_lmode(ipft) + write(fates_log(),*) 'd2bl2: ',prt_params%allom_d2bl2(ipft) + write(fates_log(),*) 'd2bl_ediff: ',prt_params%allom_blca_expnt_diff(ipft) + write(fates_log(),*) 'd2ca_min: ',prt_params%allom_d2ca_coefficient_min(ipft) + write(fates_log(),*) 'd2ca_max: ',prt_params%allom_d2ca_coefficient_max(ipft) currentCohort => currentCohort%shorter enddo call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1223,7 +1224,7 @@ subroutine canopy_spread( currentSite ) do while (associated(currentCohort)) call carea_allom(currentCohort%dbh,currentCohort%n, & currentSite%spread,currentCohort%pft,currentCohort%c_area) - if( (EDPftvarcon_inst%woody(currentCohort%pft) .eq. 1 ) .and. & + if( ( int(prt_params%woody(currentCohort%pft)) .eq. itrue ) .and. & (currentCohort%canopy_layer .eq. 1 ) ) then sitelevel_canopyarea = sitelevel_canopyarea + currentCohort%c_area endif @@ -1262,9 +1263,8 @@ subroutine canopy_summarization( nsites, sites, bc_in ) use FatesSizeAgeTypeIndicesMod, only : sizetype_class_index use FatesSizeAgeTypeIndicesMod, only : coagetype_class_index use EDtypesMod , only : area - use EDPftvarcon , only : EDPftvarcon_inst use FatesConstantsMod , only : itrue - + ! !ARGUMENTS integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) @@ -1342,7 +1342,7 @@ subroutine canopy_summarization( nsites, sites, bc_in ) if(currentCohort%canopy_layer==1)then currentPatch%total_canopy_area = currentPatch%total_canopy_area + currentCohort%c_area - if(EDPftvarcon_inst%woody(ft)==1)then + if( int(prt_params%woody(ft))==itrue)then currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area endif endif @@ -1875,8 +1875,6 @@ subroutine update_hlm_dynamics(nsites,sites,fcolumn,bc_out) use EDTypesMod , only : ed_patch_type, ed_cohort_type, & ed_site_type, AREA use FatesInterfaceTypesMod , only : bc_out_type - use EDPftvarcon , only : EDPftvarcon_inst - ! ! !ARGUMENTS diff --git a/biogeochem/EDCohortDynamicsMod.F90 b/biogeochem/EDCohortDynamicsMod.F90 index a4124d9b34..f29fd27fc4 100644 --- a/biogeochem/EDCohortDynamicsMod.F90 +++ b/biogeochem/EDCohortDynamicsMod.F90 @@ -21,10 +21,11 @@ module EDCohortDynamicsMod use SFParamsMod , only : SF_val_CWD_frac use EDPftvarcon , only : EDPftvarcon_inst use EDPftvarcon , only : GetDecompyFrac + use PRTParametersMod , only : prt_params use FatesParameterDerivedMod, only : param_derived use EDTypesMod , only : ed_site_type, ed_patch_type, ed_cohort_type use EDTypesMod , only : nclmax - use EDTypesMod , only : element_list + use PRTGenericMod , only : element_list use FatesLitterMod , only : ncwd use FatesLitterMod , only : ndcmpy use FatesLitterMod , only : litter_type @@ -33,10 +34,10 @@ module EDCohortDynamicsMod use EDTypesMod , only : min_npm2, min_nppatch use EDTypesMod , only : min_n_safemath use EDTypesMod , only : nlevleaf - use EDTypesMod , only : max_nleafage + use PRTGenericMod , only : max_nleafage use EDTypesMod , only : ican_upper use EDTypesMod , only : site_fluxdiags_type - use EDTypesMod , only : num_elements + use PRTGenericMod , only : num_elements use EDParamsMod , only : ED_val_cohort_age_fusion_tol use FatesInterfaceTypesMod , only : hlm_use_planthydro use FatesInterfaceTypesMod , only : hlm_parteh_mode @@ -86,8 +87,16 @@ module EDCohortDynamicsMod use PRTAllometricCarbonMod, only : ac_bc_in_id_ctrim use PRTAllometricCarbonMod, only : ac_bc_inout_id_dbh use PRTAllometricCarbonMod, only : ac_bc_in_id_lstat - - ! use PRTAllometricCNPMod, only : cnp_allom_prt_vartypes + use PRTAllometricCNPMod, only : cnp_allom_prt_vartypes + use PRTAllometricCNPMod, only : acnp_bc_in_id_pft, acnp_bc_in_id_ctrim + use PRTAllometricCNPMod, only : acnp_bc_in_id_lstat, acnp_bc_inout_id_dbh + use PRTAllometricCNPMod, only : acnp_bc_inout_id_rmaint_def, acnp_bc_in_id_netdc + use PRTAllometricCNPMod, only : acnp_bc_in_id_netdn, acnp_bc_in_id_netdp + use PRTAllometricCNPMod, only : acnp_bc_out_id_cefflux, acnp_bc_out_id_nefflux + use PRTAllometricCNPMod, only : acnp_bc_out_id_pefflux + use PRTAllometricCNPMod, only : acnp_bc_out_id_ngrow,acnp_bc_out_id_nmax + use PRTAllometricCNPMod, only : acnp_bc_out_id_pgrow,acnp_bc_out_id_pmax + use shr_infnan_mod, only : nan => shr_infnan_nan, assignment(=) @@ -291,6 +300,8 @@ subroutine create_cohort(currentSite, patchptr, pft, nn, hite, coage, dbh, & call InitPRTBoundaryConditions(new_cohort) + + ! Recuits do not have mortality rates, nor have they moved any ! carbon when they are created. They will bias our statistics ! until they have experienced a full day. We need a newly recruited flag. @@ -352,10 +363,14 @@ end subroutine create_cohort subroutine InitPRTBoundaryConditions(new_cohort) ! 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: + ! allocation hypotheses. Each of these calls to "RegsterBC" are simply + ! setting pointers. + ! For instance, if the hypothesis wants to know what + ! the DBH of the plant is, then we pass in the dbh as an argument (new_cohort%dbh), + ! and also tell it which boundary condition we are talking about (which is + ! defined by an integer index (ac_bc_inout_id_dbh) + ! + ! Again, elaborated 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". @@ -381,11 +396,25 @@ subroutine InitPRTBoundaryConditions(new_cohort) case (prt_cnp_flex_allom_hyp) - write(fates_log(),*) 'You have not specified the boundary conditions for the' - write(fates_log(),*) 'CNP with flexible stoichiometries hypothesis. Please do so. Dude.' - call endrun(msg=errMsg(sourcefile, __LINE__)) + call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_pft,bc_ival = new_cohort%pft) + call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_ctrim,bc_rval = new_cohort%canopy_trim) + call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_lstat,bc_ival = new_cohort%status_coh) + call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdc, bc_rval = new_cohort%npp_acc) + call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdn, bc_rval = new_cohort%daily_n_uptake) + call new_cohort%prt%RegisterBCIn(acnp_bc_in_id_netdp, bc_rval = new_cohort%daily_p_uptake) + + call new_cohort%prt%RegisterBCInOut(acnp_bc_inout_id_dbh,bc_rval = new_cohort%dbh) + call new_cohort%prt%RegisterBCInOut(acnp_bc_inout_id_rmaint_def,bc_rval = new_cohort%resp_m_def) + + call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_cefflux, bc_rval = new_cohort%daily_c_efflux) + call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_nefflux, bc_rval = new_cohort%daily_n_efflux) + call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_pefflux, bc_rval = new_cohort%daily_p_efflux) + call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_ngrow, bc_rval = new_cohort%daily_n_need1) + call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_nmax, bc_rval = new_cohort%daily_n_need2) + call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_pgrow, bc_rval = new_cohort%daily_p_need1) + call new_cohort%prt%RegisterBCOut(acnp_bc_out_id_pmax, bc_rval = new_cohort%daily_p_need2) + - case DEFAULT write(fates_log(),*) 'You specified an unknown PRT module' @@ -419,7 +448,7 @@ subroutine InitPRTObject(prt) ! Potential Extended types class(callom_prt_vartypes), pointer :: c_allom_prt - ! class(cnp_allom_prt_vartypes), pointer :: cnp_allom_prt + class(cnp_allom_prt_vartypes), pointer :: cnp_allom_prt select case(hlm_parteh_mode) @@ -430,12 +459,8 @@ subroutine InitPRTObject(prt) case (prt_cnp_flex_allom_hyp) - !! allocate(cnp_allom_prt) - !! prt => cnp_allom_prt - - write(fates_log(),*) 'Flexible CNP allocation is still in development' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) + allocate(cnp_allom_prt) + prt => cnp_allom_prt case DEFAULT @@ -532,6 +557,20 @@ subroutine nan_cohort(cc_p) currentCohort%resp_acc_hold = nan ! RESP: kgC/indiv/year currentCohort%resp_tstep = nan ! RESP: kgC/indiv/timestep currentCohort%resp_acc = nan ! RESP: kGC/cohort/day + + ! Fluxes from nutrient allocation + currentCohort%daily_n_uptake = nan + currentCohort%daily_p_uptake = nan + currentCohort%daily_c_efflux = nan + currentCohort%daily_n_efflux = nan + currentCohort%daily_p_efflux = nan + currentCohort%daily_n_need1 = nan + currentCohort%daily_n_need2 = nan + currentCohort%daily_p_need1 = nan + currentCohort%daily_p_need2 = nan + currentCohort%daily_n_demand = nan + currentCohort%daily_p_demand = nan + currentCohort%c13disc_clm = nan ! C13 discrimination, per mil at indiv/timestep currentCohort%c13disc_acc = nan ! C13 discrimination, per mil at indiv/timestep at indiv/daily at the end of a day @@ -539,10 +578,12 @@ subroutine nan_cohort(cc_p) !RESPIRATION currentCohort%rdark = nan currentCohort%resp_m = nan ! Maintenance respiration. kGC/cohort/year - currentCohort%resp_g = nan ! Growth respiration. kGC/cohort/year + currentCohort%resp_m_def = nan ! Maintenance respiration deficit kgC/plant currentCohort%livestem_mr = nan ! Live stem maintenance respiration. kgC/indiv/s-1 currentCohort%livecroot_mr = nan ! Coarse root maintenance respiration. kgC/indiv/s-1 currentCohort%froot_mr = nan ! Fine root maintenance respiration. kgC/indiv/s-1 + currentCohort%resp_g_tstep = nan ! Growth respiration. kGC/indiv/timestep + ! ALLOCATION currentCohort%dmort = nan ! proportional mortality rate. (year-1) @@ -593,8 +634,9 @@ subroutine zero_cohort(cc_p) currentCohort%NV = 0 currentCohort%status_coh = 0 currentCohort%rdark = 0._r8 - currentCohort%resp_m = 0._r8 - currentCohort%resp_g = 0._r8 + currentCohort%resp_m = 0._r8 + currentCohort%resp_m_def = 0._r8 + currentCohort%resp_g_tstep = 0._r8 currentCohort%livestem_mr = 0._r8 currentCohort%livecroot_mr = 0._r8 currentCohort%froot_mr = 0._r8 @@ -630,6 +672,28 @@ subroutine zero_cohort(cc_p) currentcohort%cambial_mort = 0._r8 currentCohort%c13disc_clm = 0._r8 currentCohort%c13disc_acc = 0._r8 + + ! Daily nutrient fluxes are INTEGRATED over the course of the + ! day. This variable MUST be zerod upon creation AND + ! after allocation. These variables exist in + ! carbon-only mode but are not used. + + currentCohort%daily_n_uptake = 0._r8 + currentCohort%daily_p_uptake = 0._r8 + + currentCohort%daily_c_efflux = 0._r8 + currentCohort%daily_n_efflux = 0._r8 + currentCohort%daily_p_efflux = 0._r8 + + currentCohort%daily_n_need1 = 0._r8 + currentCohort%daily_n_need2 = 0._r8 + currentCohort%daily_p_need1 = 0._r8 + currentCohort%daily_p_need2 = 0._r8 + + ! Initialize these as negative + currentCohort%daily_p_demand = -9._r8 + currentCohort%daily_n_demand = -9._r8 + end subroutine zero_cohort @@ -865,25 +929,25 @@ subroutine SendCohortToLitter(csite,cpatch,ccohort,nplant) ! above ground CWD litt%ag_cwd(c) = litt%ag_cwd(c) + plant_dens * & (struct_m+sapw_m) * SF_val_CWD_frac(c) * & - EDPftvarcon_inst%allom_agb_frac(pft) + prt_params%allom_agb_frac(pft) ! below ground CWD do sl=1,csite%nlevsoil litt%bg_cwd(c,sl) = litt%bg_cwd(c,sl) + plant_dens * & (struct_m+sapw_m) * SF_val_CWD_frac(c) * & - (1.0_r8 - EDPftvarcon_inst%allom_agb_frac(pft)) * & + (1.0_r8 - prt_params%allom_agb_frac(pft)) * & csite%rootfrac_scr(sl) enddo ! above ground flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & (struct_m+sapw_m) * SF_val_CWD_frac(c) * & - EDPftvarcon_inst%allom_agb_frac(pft) * nplant + prt_params%allom_agb_frac(pft) * nplant ! below ground flux_diags%cwd_bg_input(c) = flux_diags%cwd_bg_input(c) + & (struct_m + sapw_m) * SF_val_CWD_frac(c) * & - (1.0_r8 - EDPftvarcon_inst%allom_agb_frac(pft)) * nplant + (1.0_r8 - prt_params%allom_agb_frac(pft)) * nplant enddo @@ -1177,7 +1241,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) currentCohort%dbh = (currentCohort%n*currentCohort%dbh & + nextc%n*nextc%dbh)/newn - if( EDPftvarcon_inst%woody(currentCohort%pft) == itrue ) then + if( prt_params%woody(currentCohort%pft) == itrue ) then call ForceDBH( currentCohort%pft, currentCohort%canopy_trim, & currentCohort%dbh, currentCohort%hite, & @@ -1215,7 +1279,7 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) ! we then just let the carbon pools grow to fill out allometry) ! ----------------------------------------------------------------- ! - if( EDPftvarcon_inst%woody(currentCohort%pft) == itrue ) then + if( prt_params%woody(currentCohort%pft) == itrue ) then call ForceDBH( currentCohort%pft, currentCohort%canopy_trim, & currentCohort%dbh, currentCohort%hite, & bdead = currentCohort%prt%GetState(struct_organ,all_carbon_elements)) @@ -1310,6 +1374,12 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) currentCohort%gpp_acc_hold = & (currentCohort%n*currentCohort%gpp_acc_hold + & nextc%n*nextc%gpp_acc_hold)/newn + + ! This carbon variable needs continuity from day to day, as resp_m_def + ! needs to hold mass and be conservative + + currentCohort%resp_m_def = (currentCohort%n*currentCohort%resp_m_def + & + nextc%n*nextc%resp_m_def)/newn currentCohort%dmort = (currentCohort%n*currentCohort%dmort + & nextc%n*nextc%dmort)/newn @@ -1325,6 +1395,35 @@ subroutine fuse_cohorts(currentSite, currentPatch, bc_in) currentCohort%asmort = (currentCohort%n*currentCohort%asmort + nextc%n*nextc%asmort)/newn currentCohort%frmort = (currentCohort%n*currentCohort%frmort + nextc%n*nextc%frmort)/newn + ! Nutrient fluxes + currentCohort%daily_n_uptake = (currentCohort%n*currentCohort%daily_n_uptake + & + nextc%n*nextc%daily_n_uptake)/newn + currentCohort%daily_p_uptake = (currentCohort%n*currentCohort%daily_p_uptake + & + nextc%n*nextc%daily_p_uptake)/newn + + currentCohort%daily_p_demand = (currentCohort%n*currentCohort%daily_p_demand + & + nextc%n*nextc%daily_p_demand)/newn + currentCohort%daily_n_demand = (currentCohort%n*currentCohort%daily_n_demand + & + nextc%n*nextc%daily_n_demand)/newn + + currentCohort%daily_c_efflux = (currentCohort%n*currentCohort%daily_c_efflux + & + nextc%n*nextc%daily_c_efflux)/newn + currentCohort%daily_n_efflux = (currentCohort%n*currentCohort%daily_n_efflux + & + nextc%n*nextc%daily_n_efflux)/newn + currentCohort%daily_p_efflux = (currentCohort%n*currentCohort%daily_p_efflux + & + nextc%n*nextc%daily_p_efflux)/newn + + currentCohort%daily_n_need1 = (currentCohort%n*currentCohort%daily_n_need1 + & + nextc%n*nextc%daily_n_need1)/newn + currentCohort%daily_n_need2 = (currentCohort%n*currentCohort%daily_n_need2 + & + nextc%n*nextc%daily_n_need2)/newn + currentCohort%daily_p_need1 = (currentCohort%n*currentCohort%daily_p_need1 + & + nextc%n*nextc%daily_p_need1)/newn + currentCohort%daily_p_need2 = (currentCohort%n*currentCohort%daily_p_need2 + & + nextc%n*nextc%daily_p_need2)/newn + + + ! logging mortality, Yi Xu currentCohort%lmort_direct = (currentCohort%n*currentCohort%lmort_direct + & nextc%n*nextc%lmort_direct)/newn @@ -1718,6 +1817,18 @@ subroutine copy_cohort( currentCohort,copyc ) n%year_net_uptake = o%year_net_uptake n%ts_net_uptake = o%ts_net_uptake + n%daily_n_uptake = o%daily_n_uptake + n%daily_p_uptake = o%daily_p_uptake + n%daily_c_efflux = o%daily_c_efflux + n%daily_n_efflux = o%daily_n_efflux + n%daily_p_efflux = o%daily_p_efflux + n%daily_n_need1 = o%daily_n_need1 + n%daily_n_need2 = o%daily_n_need2 + n%daily_p_need1 = o%daily_p_need1 + n%daily_p_need2 = o%daily_p_need2 + n%daily_n_demand = o%daily_n_demand + n%daily_p_demand = o%daily_p_demand + ! C13 discrimination n%c13disc_clm = o%c13disc_clm n%c13disc_acc = o%c13disc_acc @@ -1725,7 +1836,8 @@ subroutine copy_cohort( currentCohort,copyc ) !RESPIRATION n%rdark = o%rdark n%resp_m = o%resp_m - n%resp_g = o%resp_g + n%resp_m_def = o%resp_m_def + n%resp_g_tstep = o%resp_g_tstep n%livestem_mr = o%livestem_mr n%livecroot_mr = o%livecroot_mr n%froot_mr = o%froot_mr @@ -1926,7 +2038,7 @@ subroutine EvaluateAndCorrectDBH(currentCohort,delta_dbh,delta_hite) delta_dbh = 0._r8 delta_hite = 0._r8 - if( EDPftvarcon_inst%woody(ipft) == itrue) then + if( int(prt_params%woody(currentCohort%pft)) == itrue) then struct_c = currentCohort%prt%GetState(struct_organ, all_carbon_elements) diff --git a/biogeochem/EDLoggingMortalityMod.F90 b/biogeochem/EDLoggingMortalityMod.F90 index bda8c8cb71..956f388dc0 100644 --- a/biogeochem/EDLoggingMortalityMod.F90 +++ b/biogeochem/EDLoggingMortalityMod.F90 @@ -28,8 +28,9 @@ module EDLoggingMortalityMod use EDTypesMod , only : dtype_ifire use EDPftvarcon , only : EDPftvarcon_inst use EDPftvarcon , only : GetDecompyFrac - use EDTypesMod , only : num_elements - use EDTypesMod , only : element_list + use PRTParametersMod , only : prt_params + use PRTGenericMod , only : num_elements + use PRTGenericMod , only : element_list use EDParamsMod , only : logging_export_frac use EDParamsMod , only : logging_event_code use EDParamsMod , only : logging_dbhmin @@ -220,6 +221,7 @@ subroutine LoggingMortality_frac( pft_i, dbh, canopy_layer, lmort_direct, & ! todo: implement harvested carbon inputs if (logging_time) then + ! Pass logging rates to cohort level if (hlm_use_lu_harvest == ifalse) then @@ -255,7 +257,7 @@ subroutine LoggingMortality_frac( pft_i, dbh, canopy_layer, lmort_direct, & ! transfer of area to secondary land is based on overall area affected, not just logged crown area ! l_degrad accounts for the affected area between logged crowns - if(EDPftvarcon_inst%woody(pft_i) == 1)then ! only set logging rates for trees + if(int(prt_params%woody(pft_i)) == 1)then ! only set logging rates for trees ! direct logging rates, based on dbh min and max criteria if (dbh >= logging_dbhmin .and. .not. & @@ -534,7 +536,7 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site ! plants that were impacted. Thus, no direct dead can occur ! here, and indirect are impacts. - if(EDPftvarcon_inst%woody(currentCohort%pft) == 1)then + if(int(prt_params%woody(pft)) == itrue) then direct_dead = 0.0_r8 indirect_dead = logging_coll_under_frac * & (1._r8-currentPatch%fract_ldist_not_harvested) * currentCohort%n * & @@ -565,9 +567,9 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil) ag_wood = (direct_dead+indirect_dead) * (struct_m + sapw_m ) * & - EDPftvarcon_inst%allom_agb_frac(currentCohort%pft) + prt_params%allom_agb_frac(currentCohort%pft) bg_wood = (direct_dead+indirect_dead) * (struct_m + sapw_m ) * & - (1._r8 - EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)) + (1._r8 - prt_params%allom_agb_frac(currentCohort%pft)) do c = 1,ncwd-1 @@ -608,9 +610,9 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site ! ---------------------------------------------------------------------------------------- ag_wood = indirect_dead * (struct_m + sapw_m ) * & - EDPftvarcon_inst%allom_agb_frac(currentCohort%pft) + prt_params%allom_agb_frac(currentCohort%pft) bg_wood = indirect_dead * (struct_m + sapw_m ) * & - (1._r8 - EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)) + (1._r8 - prt_params%allom_agb_frac(currentCohort%pft)) new_litt%ag_cwd(ncwd) = new_litt%ag_cwd(ncwd) + ag_wood * & SF_val_CWD_frac(ncwd) * donate_frac/newPatch%area @@ -646,7 +648,7 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site ! ---------------------------------------------------------------------------------------- bg_wood = direct_dead * (struct_m + sapw_m ) * SF_val_CWD_frac(ncwd) * & - (1._r8 - EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)) + (1._r8 - prt_params%allom_agb_frac(currentCohort%pft)) do ilyr = 1,nlevsoil new_litt%bg_cwd(ncwd,ilyr) = new_litt%bg_cwd(ncwd,ilyr) + & @@ -671,7 +673,7 @@ subroutine logging_litter_fluxes(currentSite, currentPatch, newPatch, patch_site ! ---------------------------------------------------------------------------------------- ag_wood = direct_dead * (struct_m + sapw_m ) * & - EDPftvarcon_inst%allom_agb_frac(currentCohort%pft) * & + prt_params%allom_agb_frac(currentCohort%pft) * & SF_val_CWD_frac(ncwd) trunk_product_site = trunk_product_site + & diff --git a/biogeochem/EDPatchDynamicsMod.F90 b/biogeochem/EDPatchDynamicsMod.F90 index af0208cf43..f8f71df8cd 100644 --- a/biogeochem/EDPatchDynamicsMod.F90 +++ b/biogeochem/EDPatchDynamicsMod.F90 @@ -7,6 +7,7 @@ module EDPatchDynamicsMod use FatesInterfaceTypesMod , only : hlm_freq_day use EDPftvarcon , only : EDPftvarcon_inst use EDPftvarcon , only : GetDecompyFrac + use PRTParametersMod , only : prt_params use EDCohortDynamicsMod , only : fuse_cohorts, sort_cohorts, insert_cohort use EDCohortDynamicsMod , only : DeallocateCohort use EDTypesMod , only : area_site => area @@ -30,9 +31,8 @@ module EDPatchDynamicsMod use EDTypesMod , only : dtype_ilog use EDTypesMod , only : dtype_ifire use EDTypesMod , only : ican_upper - use EDTypesMod , only : num_elements - use EDTypesMod , only : element_list - use EDTypesMod , only : element_pos + use PRTGenericMod , only : num_elements + use PRTGenericMod , only : element_list use EDTypesMod , only : lg_sf use EDTypesMod , only : dl_sf use EDTypesMod , only : dump_patch @@ -231,7 +231,7 @@ subroutine disturbance_rates( site_in, bc_in) currentCohort%lmort_direct * currentCohort%n * & ( currentCohort%prt%GetState(sapw_organ, all_carbon_elements) + & currentCohort%prt%GetState(struct_organ, all_carbon_elements)) * & - EDPftvarcon_inst%allom_agb_frac(currentCohort%pft) * & + prt_params%allom_agb_frac(currentCohort%pft) * & SF_val_CWD_frac(ncwd) * logging_export_frac endif @@ -733,7 +733,7 @@ subroutine spawn_patches( currentSite, bc_in) else ! small trees - if(EDPftvarcon_inst%woody(currentCohort%pft) == 1)then + if( int(prt_params%woody(currentCohort%pft)) == itrue)then ! Survivorship of undestory woody plants. Two step process. @@ -873,7 +873,7 @@ subroutine spawn_patches( currentSite, bc_in) ! burned off. Here, we remove that mass, and ! tally it in the flux we sent to the atmosphere - if(EDPftvarcon_inst%woody(currentCohort%pft) == 1)then + if(int(prt_params%woody(currentCohort%pft)) == itrue)then leaf_burn_frac = currentCohort%fraction_crown_burned else @@ -890,7 +890,7 @@ subroutine spawn_patches( currentSite, bc_in) (currentCohort%fire_mort < 0._r8) .or. & (currentCohort%fire_mort > 1._r8)) then write(fates_log(),*) 'unexpected fire fractions' - write(fates_log(),*) EDPftvarcon_inst%woody(currentCohort%pft) + write(fates_log(),*) prt_params%woody(currentCohort%pft) write(fates_log(),*) leaf_burn_frac write(fates_log(),*) currentCohort%fire_mort call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -951,7 +951,7 @@ subroutine spawn_patches( currentSite, bc_in) ! WHat to do with cohorts in the understory of a logging generated ! disturbance patch? - if(EDPftvarcon_inst%woody(currentCohort%pft) == 1)then + if(int(prt_params%woody(currentCohort%pft)) == itrue)then ! Survivorship of undestory woody plants. Two step process. @@ -1682,7 +1682,7 @@ subroutine fire_litter_fluxes(currentSite, currentPatch, newPatch, patch_site_ar (fnrt_m + store_m) * num_dead_trees ! coarse root biomass per tree - bcroot = (sapw_m + struct_m) * (1.0_r8 - EDPftvarcon_inst%allom_agb_frac(pft) ) + bcroot = (sapw_m + struct_m) * (1.0_r8 - prt_params%allom_agb_frac(pft) ) ! below ground coarse woody debris from burned trees do c = 1,ncwd @@ -1703,7 +1703,7 @@ subroutine fire_litter_fluxes(currentSite, currentPatch, newPatch, patch_site_ar end do ! stem biomass per tree - bstem = (sapw_m + struct_m) * EDPftvarcon_inst%allom_agb_frac(pft) + bstem = (sapw_m + struct_m) * prt_params%allom_agb_frac(pft) ! Above ground coarse woody debris from twigs and small branches ! a portion of this pool may burn @@ -1829,7 +1829,7 @@ subroutine mortality_litter_fluxes(currentSite, currentPatch, newPatch, patch_si num_dead = currentCohort%n * min(1.0_r8,currentCohort%dmort * & hlm_freq_day * fates_mortality_disturbance_fraction) - elseif(EDPftvarcon_inst%woody(pft) == itrue) then + elseif(int(prt_params%woody(pft)) == itrue) then ! Understorey trees. The total dead is based on their survivorship ! function, and the total area of disturbance. @@ -1864,8 +1864,8 @@ subroutine mortality_litter_fluxes(currentSite, currentPatch, newPatch, patch_si end do ! Pre-calculate Structural and sapwood, below and above ground, total mass [kg] - ag_wood = num_dead * (struct_m + sapw_m) * EDPftvarcon_inst%allom_agb_frac(pft) - bg_wood = num_dead * (struct_m + sapw_m) * (1.0_r8-EDPftvarcon_inst%allom_agb_frac(pft)) + ag_wood = num_dead * (struct_m + sapw_m) * prt_params%allom_agb_frac(pft) + bg_wood = num_dead * (struct_m + sapw_m) * (1.0_r8-prt_params%allom_agb_frac(pft)) call set_root_fraction(currentSite%rootfrac_scr, pft, currentSite%zi_soil) diff --git a/biogeochem/EDPhysiologyMod.F90 b/biogeochem/EDPhysiologyMod.F90 index 0c23795f9a..423f1918d6 100644 --- a/biogeochem/EDPhysiologyMod.F90 +++ b/biogeochem/EDPhysiologyMod.F90 @@ -15,13 +15,15 @@ module EDPhysiologyMod use FatesInterfaceTypesMod, only : nleafage use FatesInterfaceTypesMod, only : hlm_use_planthydro use FatesInterfaceTypesMod, only : hlm_parteh_mode + use FatesInterfaceTypesMod, only : hlm_nitrogen_spec + use FatesInterfaceTypesMod, only : hlm_phosphorus_spec use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : nearzero - use FatesConstantsMod, only : g_per_kg - use FatesConstantsMod, only : days_per_sec use EDPftvarcon , only : EDPftvarcon_inst + use PRTParametersMod , only : prt_params use EDPftvarcon , only : GetDecompyFrac use FatesInterfaceTypesMod, only : bc_in_type + use FatesInterfaceTypesMod, only : bc_out_type use EDCohortDynamicsMod , only : zero_cohort use EDCohortDynamicsMod , only : create_cohort, sort_cohorts use EDCohortDynamicsMod , only : InitPRTObject @@ -38,6 +40,7 @@ module EDPhysiologyMod use FatesLitterMod , only : ilabile use FatesLitterMod , only : ilignin use FatesLitterMod , only : icellulose + use EDTypesMod , only : AREA,AREA_INV use EDTypesMod , only : nlevleaf use EDTypesMod , only : num_vegtemp_mem use EDTypesMod , only : maxpft @@ -45,9 +48,9 @@ module EDPhysiologyMod use EDTypesMod , only : leaves_on use EDTypesMod , only : leaves_off use EDTypesMod , only : min_n_safemath - use EDTypesMod , only : num_elements - use EDTypesMod , only : element_list - use EDTypesMod , only : element_pos + use PRTGenericMod , only : num_elements + use PRTGenericMod , only : element_list + use PRTGenericMod , only : element_pos use EDTypesMod , only : site_fluxdiags_type use EDTypesMod , only : phen_cstat_nevercold use EDTypesMod , only : phen_cstat_iscold @@ -56,7 +59,6 @@ module EDPhysiologyMod use EDTypesMod , only : phen_dstat_moistoff use EDTypesMod , only : phen_dstat_moiston use EDTypesMod , only : phen_dstat_timeon - use shr_log_mod , only : errMsg => shr_log_errMsg use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun @@ -65,7 +67,6 @@ module EDPhysiologyMod use EDParamsMod , only : q10_froz use EDParamsMod , only : logging_export_frac use FatesPlantHydraulicsMod , only : AccumulateMortalityWaterStorage - use FatesConstantsMod , only : itrue,ifalse use FatesConstantsMod , only : calloc_abs_error use FatesConstantsMod , only : years_per_day @@ -81,7 +82,6 @@ module EDPhysiologyMod use FatesAllometryMod , only : carea_allom use FatesAllometryMod , only : CheckIntegratedAllometries use FatesAllometryMod, only : set_root_fraction - use PRTGenericMod, only : prt_carbon_allom_hyp use PRTGenericMod, only : prt_cnp_flex_allom_hyp use PRTGenericMod, only : prt_vartypes @@ -102,25 +102,27 @@ module EDPhysiologyMod use PRTLossFluxesMod, only : PRTDeciduousTurnover use PRTLossFluxesMod, only : PRTReproRelease - implicit none - private + public :: trim_canopy public :: phenology public :: recruitment public :: ZeroLitterFluxes - public :: FluxIntoLitterPools + public :: ZeroAllocationRates public :: PreDisturbanceLitterFluxes public :: PreDisturbanceIntegrateLitter public :: SeedIn - + logical, parameter :: debug = .false. ! local debug flag character(len=*), parameter, private :: sourcefile = & __FILE__ integer, parameter :: dleafon_drycheck = 100 ! Drought deciduous leaves max days on check parameter + + + ! ============================================================================ contains @@ -480,7 +482,7 @@ subroutine trim_canopy( currentSite ) call bleaf(currentcohort%dbh,ipft,currentcohort%canopy_trim,tar_bl) - if ( int(EDPftvarcon_inst%allom_fmode(ipft)) .eq. 1 ) then + if ( int(prt_params%allom_fmode(ipft)) .eq. 1 ) then ! only query fine root biomass if using a fine root allometric model that takes leaf trim into account call bfineroot(currentcohort%dbh,ipft,currentcohort%canopy_trim,tar_bfr) bfr_per_bleaf = tar_bfr/tar_bl @@ -490,7 +492,7 @@ subroutine trim_canopy( currentSite ) cl = currentCohort%canopy_layer ! PFT-level maximum SLA value, even if under a thick canopy (same units as slatop) - sla_max = EDPftvarcon_inst%slamax(ipft) + sla_max = prt_params%slamax(ipft) ! Initialize nnu_clai_a nnu_clai_a(:,:) = 0._r8 @@ -522,7 +524,7 @@ subroutine trim_canopy( currentSite ) ! Nscaler value at leaf level z nscaler_levleaf = exp(-kn * cumulative_lai) ! Sla value at leaf level z after nitrogen profile scaling (m2/gC) - sla_levleaf = EDPftvarcon_inst%slatop(ipft)/nscaler_levleaf + sla_levleaf = prt_params%slatop(ipft)/nscaler_levleaf if(sla_levleaf > sla_max)then sla_levleaf = sla_max @@ -530,38 +532,38 @@ subroutine trim_canopy( currentSite ) !Leaf Cost kgC/m2/year-1 !decidous costs. - if (EDPftvarcon_inst%season_decid(ipft) == itrue .or. & - EDPftvarcon_inst%stress_decid(ipft) == itrue )then + if (prt_params%season_decid(ipft) == itrue .or. & + prt_params%stress_decid(ipft) == itrue )then ! Leaf cost at leaf level z accounting for sla profile (kgC/m2) currentCohort%leaf_cost = 1._r8/(sla_levleaf*1000.0_r8) - if ( int(EDPftvarcon_inst%allom_fmode(ipft)) .eq. 1 ) then + if ( int(prt_params%allom_fmode(ipft)) .eq. 1 ) then ! if using trimmed leaf for fine root biomass allometry, add the cost of the root increment ! to the leaf increment; otherwise do not. currentCohort%leaf_cost = currentCohort%leaf_cost + & 1.0_r8/(sla_levleaf*1000.0_r8) * & - bfr_per_bleaf / EDPftvarcon_inst%root_long(ipft) + bfr_per_bleaf / prt_params%root_long(ipft) endif currentCohort%leaf_cost = currentCohort%leaf_cost * & - (EDPftvarcon_inst%grperc(ipft) + 1._r8) + (prt_params%grperc(ipft) + 1._r8) else !evergreen costs ! Leaf cost at leaf level z accounting for sla profile currentCohort%leaf_cost = 1.0_r8/(sla_levleaf* & - sum(EDPftvarcon_inst%leaf_long(ipft,:))*1000.0_r8) !convert from sla in m2g-1 to m2kg-1 + sum(prt_params%leaf_long(ipft,:))*1000.0_r8) !convert from sla in m2g-1 to m2kg-1 - if ( int(EDPftvarcon_inst%allom_fmode(ipft)) .eq. 1 ) then + if ( int(prt_params%allom_fmode(ipft)) .eq. 1 ) then ! if using trimmed leaf for fine root biomass allometry, add the cost of the root increment ! to the leaf increment; otherwise do not. currentCohort%leaf_cost = currentCohort%leaf_cost + & 1.0_r8/(sla_levleaf*1000.0_r8) * & - bfr_per_bleaf / EDPftvarcon_inst%root_long(ipft) + bfr_per_bleaf / prt_params%root_long(ipft) endif currentCohort%leaf_cost = currentCohort%leaf_cost * & - (EDPftvarcon_inst%grperc(ipft) + 1._r8) + (prt_params%grperc(ipft) + 1._r8) endif ! Construct the arrays for a least square fit of the net_net_uptake versus the cumulative lai @@ -597,8 +599,7 @@ subroutine trim_canopy( currentSite ) if (currentCohort%hite > EDPftvarcon_inst%hgt_min(ipft)) then currentCohort%canopy_trim = currentCohort%canopy_trim - & EDPftvarcon_inst%trim_inc(ipft) - - if (EDPftvarcon_inst%evergreen(ipft) /= 1) then + if (prt_params%evergreen(ipft) /= 1)then currentCohort%laimemory = currentCohort%laimemory * & (1.0_r8 - EDPftvarcon_inst%trim_inc(ipft)) endif @@ -654,7 +655,7 @@ subroutine trim_canopy( currentSite ) currentCohort%canopy_trim = optimum_trim ! If the cohort pft is not evergreen we reduce the laimemory as well - if (EDPftvarcon_inst%evergreen(ipft) /= 1) then + if (prt_params%evergreen(ipft) /= 1) then currentCohort%laimemory = optimum_laimem endif @@ -1113,7 +1114,7 @@ subroutine phenology_leafonoff(currentSite) ! The site level flags signify that it is no-longer too cold ! for leaves. Time to signal flushing - if (EDPftvarcon_inst%season_decid(ipft) == itrue)then + if (prt_params%season_decid(ipft) == itrue)then if ( currentSite%cstatus == phen_cstat_notcold )then ! we have just moved to leaves being on . if (currentCohort%status_coh == leaves_off)then ! Are the leaves currently off? currentCohort%status_coh = leaves_on ! Leaves are on, so change status to @@ -1126,7 +1127,7 @@ subroutine phenology_leafonoff(currentSite) store_c_transfer_frac = min((EDPftvarcon_inst%phenflush_fraction(ipft)* & currentCohort%laimemory)/store_c,(1.0_r8-carbon_store_buffer)) - if(EDPftvarcon_inst%woody(ipft).ne.itrue)then + if(prt_params%woody(ipft).ne.itrue)then totalmemory=currentCohort%laimemory+currentCohort%sapwmemory+currentCohort%structmemory store_c_transfer_frac = min((EDPftvarcon_inst%phenflush_fraction(ipft)* & totalmemory)/store_c, (1.0_r8-carbon_store_buffer)) @@ -1138,7 +1139,7 @@ subroutine phenology_leafonoff(currentSite) ! This call will request that storage carbon will be transferred to ! leaf tissues. It is specified as a fraction of the available storage - if(EDPftvarcon_inst%woody(ipft) == itrue) then + if(prt_params%woody(ipft) == itrue) then call PRTPhenologyFlush(currentCohort%prt, ipft, leaf_organ, store_c_transfer_frac) currentCohort%laimemory = 0.0_r8 @@ -1180,7 +1181,7 @@ subroutine phenology_leafonoff(currentSite) ! leaf off occur on individuals bigger than specific size for grass if (currentCohort%dbh > EDPftvarcon_inst%phen_cold_size_threshold(ipft) & - .or. EDPftvarcon_inst%woody(ipft)==itrue) then + .or. prt_params%woody(ipft)==itrue) then ! This sets the cohort to the "leaves off" flag currentCohort%status_coh = leaves_off @@ -1197,7 +1198,7 @@ subroutine phenology_leafonoff(currentSite) call PRTDeciduousTurnover(currentCohort%prt,ipft, & leaf_organ, leaf_drop_fraction) - if(EDPftvarcon_inst%woody(ipft).ne.itrue)then + if(prt_params%woody(ipft).ne.itrue)then currentCohort%sapwmemory = sapw_c * stem_drop_fraction @@ -1219,7 +1220,7 @@ subroutine phenology_leafonoff(currentSite) ! Site level flag indicates it is no longer in drought condition ! deciduous plants can flush - if (EDPftvarcon_inst%stress_decid(ipft) == itrue )then + if (prt_params%stress_decid(ipft) == itrue )then if (currentSite%dstatus == phen_dstat_moiston .or. & currentSite%dstatus == phen_dstat_timeon )then @@ -1237,7 +1238,7 @@ subroutine phenology_leafonoff(currentSite) store_c_transfer_frac = & min(EDPftvarcon_inst%phenflush_fraction(ipft)*currentCohort%laimemory, store_c)/store_c - if(EDPftvarcon_inst%woody(ipft).ne.itrue)then + if(prt_params%woody(ipft).ne.itrue)then totalmemory=currentCohort%laimemory+currentCohort%sapwmemory+currentCohort%structmemory store_c_transfer_frac = min(EDPftvarcon_inst%phenflush_fraction(ipft)* & @@ -1251,7 +1252,7 @@ subroutine phenology_leafonoff(currentSite) ! This call will request that storage carbon will be transferred to ! leaf tissues. It is specified as a fraction of the available storage - if(EDPftvarcon_inst%woody(ipft) == itrue) then + if(prt_params%woody(ipft) == itrue) then call PRTPhenologyFlush(currentCohort%prt, ipft, & leaf_organ, store_c_transfer_frac) @@ -1302,7 +1303,7 @@ subroutine phenology_leafonoff(currentSite) call PRTDeciduousTurnover(currentCohort%prt,ipft, & leaf_organ, leaf_drop_fraction) - if(EDPftvarcon_inst%woody(ipft).ne.itrue)then + if(prt_params%woody(ipft).ne.itrue)then currentCohort%sapwmemory = sapw_c * stem_drop_fraction currentCohort%structmemory = struct_c * stem_drop_fraction @@ -1430,32 +1431,32 @@ subroutine SeedIn( currentSite, bc_in ) ! Loop over all patches again and disperse the mixed seeds into the input flux ! arrays - ! If there is forced external seed rain, we calculate the input mass flux - ! from the different elements, usung the seed optimal stoichiometry - ! for non-carbon - select case(element_id) - case(carbon12_element) - seed_stoich = 1._r8 - case(nitrogen_element) - seed_stoich = EDPftvarcon_inst%prt_nitr_stoich_p2(pft,repro_organ) - case(phosphorus_element) - seed_stoich = EDPftvarcon_inst%prt_phos_stoich_p2(pft,repro_organ) - case default - write(fates_log(), *) 'undefined element specified' - write(fates_log(), *) 'while defining forced external seed mass flux' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - - ! Loop over all patches and sum up the seed input for each PFT currentPatch => currentSite%oldest_patch do while (associated(currentPatch)) litt => currentPatch%litter(el) do pft = 1,numpft + if(currentSite%use_this_pft(pft).eq.itrue)then ! Seed input from local sources (within site) litt%seed_in_local(pft) = litt%seed_in_local(pft) + site_seed_rain(pft)/area + + ! If there is forced external seed rain, we calculate the input mass flux + ! from the different elements, usung the seed optimal stoichiometry + ! for non-carbon + select case(element_id) + case(carbon12_element) + seed_stoich = 1._r8 + case(nitrogen_element) + seed_stoich = prt_params%nitr_stoich_p2(pft,repro_organ) + case(phosphorus_element) + seed_stoich = prt_params%phos_stoich_p2(pft,repro_organ) + case default + write(fates_log(), *) 'undefined element specified' + write(fates_log(), *) 'while defining forced external seed mass flux' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select ! Seed input from external sources (user param seed rain, or dispersal model) seed_in_external = seed_stoich*EDPftvarcon_inst%seed_suppl(pft)*years_per_day @@ -1546,11 +1547,11 @@ subroutine SeedGermination( litt, cold_stat, drought_stat ) !set the germination only under the growing season...c.xu - if ((EDPftvarcon_inst%season_decid(pft) == itrue ) .and. & + if ((prt_params%season_decid(pft) == itrue ) .and. & (any(cold_stat == [phen_cstat_nevercold,phen_cstat_iscold]))) then litt%seed_germ_in(pft) = 0.0_r8 endif - if ((EDPftvarcon_inst%stress_decid(pft) == itrue ) .and. & + if ((prt_params%stress_decid(pft) == itrue ) .and. & (any(drought_stat == [phen_dstat_timeoff,phen_dstat_moistoff]))) then litt%seed_germ_in(pft) = 0.0_r8 end if @@ -1647,13 +1648,13 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) ! But if the plant is seasonally (cold) deciduous, and the site status is flagged ! as "cold", then set the cohort's status to leaves_off, and remember the leaf biomass - if ((EDPftvarcon_inst%season_decid(ft) == itrue) .and. & + if ((prt_params%season_decid(ft) == itrue) .and. & (any(currentSite%cstatus == [phen_cstat_nevercold,phen_cstat_iscold]))) then temp_cohort%laimemory = c_leaf c_leaf = 0.0_r8 ! If plant is not woody then set sapwood and structural biomass as well - if (EDPftvarcon_inst%woody(ft).ne.itrue) then + if (prt_params%woody(ft).ne.itrue) then temp_cohort%sapwmemory = c_sapw * stem_drop_fraction temp_cohort%structmemory = c_struct * stem_drop_fraction c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw @@ -1665,13 +1666,13 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) ! Or.. if the plant is drought deciduous, and the site status is flagged as ! "in a drought", then likewise, set the cohort's status to leaves_off, and remember leaf ! biomass - if ((EDPftvarcon_inst%stress_decid(ft) == itrue) .and. & + if ((prt_params%stress_decid(ft) == itrue) .and. & (any(currentSite%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff]))) then temp_cohort%laimemory = c_leaf c_leaf = 0.0_r8 ! If plant is not woody then set sapwood and structural biomass as well - if(EDPftvarcon_inst%woody(ft).ne.itrue)then + if(prt_params%woody(ft).ne.itrue)then temp_cohort%sapwmemory = c_sapw * stem_drop_fraction temp_cohort%structmemory = c_struct * stem_drop_fraction c_sapw = (1.0_r8 - stem_drop_fraction) * c_sapw @@ -1699,19 +1700,19 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) case(nitrogen_element) - mass_demand = c_struct*EDPftvarcon_inst%prt_nitr_stoich_p1(ft,struct_organ) + & - c_leaf*EDPftvarcon_inst%prt_nitr_stoich_p1(ft,leaf_organ) + & - c_fnrt*EDPftvarcon_inst%prt_nitr_stoich_p1(ft,fnrt_organ) + & - c_sapw*EDPftvarcon_inst%prt_nitr_stoich_p1(ft,sapw_organ) + & - c_store*EDPftvarcon_inst%prt_nitr_stoich_p1(ft,store_organ) + mass_demand = c_struct*prt_params%nitr_stoich_p1(ft,struct_organ) + & + c_leaf*prt_params%nitr_stoich_p1(ft,leaf_organ) + & + c_fnrt*prt_params%nitr_stoich_p1(ft,fnrt_organ) + & + c_sapw*prt_params%nitr_stoich_p1(ft,sapw_organ) + & + c_store*prt_params%nitr_stoich_p1(ft,store_organ) case(phosphorus_element) - mass_demand = c_struct*EDPftvarcon_inst%prt_phos_stoich_p1(ft,struct_organ) + & - c_leaf*EDPftvarcon_inst%prt_phos_stoich_p1(ft,leaf_organ) + & - c_fnrt*EDPftvarcon_inst%prt_phos_stoich_p1(ft,fnrt_organ) + & - c_sapw*EDPftvarcon_inst%prt_phos_stoich_p1(ft,sapw_organ) + & - c_store*EDPftvarcon_inst%prt_phos_stoich_p1(ft,store_organ) + mass_demand = c_struct*prt_params%phos_stoich_p1(ft,struct_organ) + & + c_leaf*prt_params%phos_stoich_p1(ft,leaf_organ) + & + c_fnrt*prt_params%phos_stoich_p1(ft,fnrt_organ) + & + c_sapw*prt_params%phos_stoich_p1(ft,sapw_organ) + & + c_store*prt_params%phos_stoich_p1(ft,store_organ) case default write(fates_log(),*) 'Undefined element type in recruitment' @@ -1765,20 +1766,20 @@ subroutine recruitment( currentSite, currentPatch, bc_in ) case(nitrogen_element) - m_struct = c_struct*EDPftvarcon_inst%prt_nitr_stoich_p1(ft,struct_organ) - m_leaf = c_leaf*EDPftvarcon_inst%prt_nitr_stoich_p1(ft,leaf_organ) - m_fnrt = c_fnrt*EDPftvarcon_inst%prt_nitr_stoich_p1(ft,fnrt_organ) - m_sapw = c_sapw*EDPftvarcon_inst%prt_nitr_stoich_p1(ft,sapw_organ) - m_store = c_store*EDPftvarcon_inst%prt_nitr_stoich_p1(ft,store_organ) + m_struct = c_struct*prt_params%nitr_stoich_p1(ft,struct_organ) + m_leaf = c_leaf*prt_params%nitr_stoich_p1(ft,leaf_organ) + m_fnrt = c_fnrt*prt_params%nitr_stoich_p1(ft,fnrt_organ) + m_sapw = c_sapw*prt_params%nitr_stoich_p1(ft,sapw_organ) + m_store = c_store*prt_params%nitr_stoich_p1(ft,store_organ) m_repro = 0._r8 case(phosphorus_element) - m_struct = c_struct*EDPftvarcon_inst%prt_phos_stoich_p1(ft,struct_organ) - m_leaf = c_leaf*EDPftvarcon_inst%prt_phos_stoich_p1(ft,leaf_organ) - m_fnrt = c_fnrt*EDPftvarcon_inst%prt_phos_stoich_p1(ft,fnrt_organ) - m_sapw = c_sapw*EDPftvarcon_inst%prt_phos_stoich_p1(ft,sapw_organ) - m_store = c_store*EDPftvarcon_inst%prt_phos_stoich_p1(ft,store_organ) + m_struct = c_struct*prt_params%phos_stoich_p1(ft,struct_organ) + m_leaf = c_leaf*prt_params%phos_stoich_p1(ft,leaf_organ) + m_fnrt = c_fnrt*prt_params%phos_stoich_p1(ft,fnrt_organ) + m_sapw = c_sapw*prt_params%phos_stoich_p1(ft,sapw_organ) + m_store = c_store*prt_params%phos_stoich_p1(ft,store_organ) m_repro = 0._r8 end select @@ -1999,15 +2000,15 @@ subroutine CWDInput( currentSite, currentPatch, litt) litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + & (sapw_m_turnover + struct_m_turnover) * & SF_val_CWD_frac(c) * plant_dens * & - EDPftvarcon_inst%allom_agb_frac(pft) + prt_params%allom_agb_frac(pft) flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & (struct_m_turnover + sapw_m_turnover) * SF_val_CWD_frac(c) * & - EDPftvarcon_inst%allom_agb_frac(pft) * currentCohort%n + prt_params%allom_agb_frac(pft) * currentCohort%n bg_cwd_tot = (sapw_m_turnover + struct_m_turnover) * & SF_val_CWD_frac(c) * plant_dens * & - (1.0_r8-EDPftvarcon_inst%allom_agb_frac(pft)) + (1.0_r8-prt_params%allom_agb_frac(pft)) do ilyr = 1, numlevsoil litt%bg_cwd_in(c,ilyr) = litt%bg_cwd_in(c,ilyr) + & @@ -2088,7 +2089,7 @@ subroutine CWDInput( currentSite, currentPatch, litt) bg_cwd_tot = (struct_m + sapw_m) * & SF_val_CWD_frac(c) * dead_n * & - (1.0_r8-EDPftvarcon_inst%allom_agb_frac(pft)) + (1.0_r8-prt_params%allom_agb_frac(pft)) do ilyr = 1, numlevsoil litt%bg_cwd_in(c,ilyr) = litt%bg_cwd_in(c,ilyr) + & @@ -2107,7 +2108,7 @@ subroutine CWDInput( currentSite, currentPatch, litt) trunk_wood = (struct_m + sapw_m) * & SF_val_CWD_frac(c) * dead_n_dlogging * & - EDPftvarcon_inst%allom_agb_frac(pft) + prt_params%allom_agb_frac(pft) site_mass%wood_product = site_mass%wood_product + & trunk_wood * currentPatch%area * logging_export_frac @@ -2125,21 +2126,21 @@ subroutine CWDInput( currentSite, currentPatch, litt) litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & - EDPftvarcon_inst%allom_agb_frac(pft) + prt_params%allom_agb_frac(pft) flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & SF_val_CWD_frac(c) * (dead_n_natural+dead_n_ilogging) * & - currentPatch%area * EDPftvarcon_inst%allom_agb_frac(pft) + currentPatch%area * prt_params%allom_agb_frac(pft) else litt%ag_cwd_in(c) = litt%ag_cwd_in(c) + (struct_m + sapw_m) * & SF_val_CWD_frac(c) * dead_n * & - EDPftvarcon_inst%allom_agb_frac(pft) + prt_params%allom_agb_frac(pft) flux_diags%cwd_ag_input(c) = flux_diags%cwd_ag_input(c) + & SF_val_CWD_frac(c) * dead_n * (struct_m + sapw_m) * & - currentPatch%area * EDPftvarcon_inst%allom_agb_frac(pft) + currentPatch%area * prt_params%allom_agb_frac(pft) end if @@ -2347,226 +2348,4 @@ subroutine CWDOut( litt, fragmentation_scaler, nlev_eff_decomp ) end subroutine CWDOut - ! ===================================================================================== - - subroutine FluxIntoLitterPools(nsites, sites, bc_in, bc_out) - - ! ----------------------------------------------------------------------------------- - ! Created by Charlie Koven and Rosie Fisher, 2014-2015 - ! take the flux out of the fragmenting litter pools and port into the decomposing - ! litter pools. - ! in this implementation, decomposing pools are assumed to be humus and non-flammable, - ! whereas fragmenting pools are assumed to be physically fragmenting but not - ! respiring. This is a simplification, but allows us to - ! - ! a) reconcile the need to track both chemical fractions (lignin, cellulose, labile) - ! and size fractions (trunk, branch, etc.) - ! b) to impose a realistic delay on the surge of nutrients into the litter pools - ! when large CWD is added to the system via mortality - ! - ! Because of the different subgrid structure, this subroutine includes the functionality - ! that in the big-leaf BGC model, is calculated in SoilBiogeochemVerticalProfileMod - ! - ! The ED code is resolved at a daily timestep, but all of the CN-BGC fluxes are passed - ! in as derivatives per second, and then accumulated in the CNStateUpdate routines. - ! One way of doing this is to pass back the CN fluxes per second, and keep them - ! constant for the whole day (making sure they are not overwritten. This means that - ! the carbon gets passed back and forth between the photosynthesis code - ! (fast timestepping) to the ED code (slow timestepping), back to the BGC code - ! (fast timestepping). This means that the state update for the litter pools and - ! for the CWD pools occurs at different timescales. - ! ----------------------------------------------------------------------------------- - - use EDTypesMod, only : AREA - use FatesConstantsMod, only : sec_per_day - use FatesInterfaceTypesMod, only : bc_in_type, bc_out_type - use FatesInterfaceTypesMod, only : hlm_use_vertsoilc - use FatesInterfaceTypesMod, only : hlm_numlevgrnd - use FatesConstantsMod, only : itrue - use FatesGlobals, only : endrun => fates_endrun - use EDParamsMod , only : ED_val_cwd_flig, ED_val_cwd_fcel - - - - implicit none - - ! !ARGUMENTS - integer , intent(in) :: nsites - type(ed_site_type) , intent(inout) :: sites(nsites) - type(bc_in_type) , intent(in) :: bc_in(:) - type(bc_out_type) , intent(inout), target :: bc_out(:) - - ! !LOCAL VARIABLES: - type (ed_patch_type), pointer :: currentPatch - type (ed_cohort_type), pointer :: currentCohort - real(r8), pointer :: flux_cel_si(:) - real(r8), pointer :: flux_lab_si(:) - real(r8), pointer :: flux_lig_si(:) - type(litter_type), pointer :: litt - - real(r8) :: surface_prof(1:hlm_numlevgrnd) ! this array is used to distribute - ! fragmented litter on the surface - ! into the soil/decomposition - ! layers. It exponentially decays - real(r8) :: surface_prof_tot ! normalizes the surface_prof array - integer :: ft ! PFT number - integer :: nlev_eff_soil ! number of effective soil layers - integer :: nlev_eff_decomp ! number of effective decomp layers - real(r8) :: area_frac ! fraction of site's area of current patch - real(r8) :: z_decomp ! Used for calculating depth midpoints of decomp layers - integer :: s ! Site index - integer :: el ! Element index (C,N,P,etc) - integer :: j ! Soil layer index - integer :: id ! Decomposition layer index - integer :: ic ! CWD type index - - ! NOTE(rgk, 201705) this parameter was brought over from SoilBiogeochemVerticalProfile - ! how steep profile is for surface components (1/ e_folding depth) (1/m) - real(r8), parameter :: surfprof_exp = 10. - - do s = 1,nsites - - ! This is the number of effective soil layers to transfer from - nlev_eff_soil = max(bc_in(s)%max_rooting_depth_index_col, 1) - - ! The decomposition layers are most likely the exact same layers - ! as the soil layers (same depths also), unless it is a simplified - ! single layer case, where nlevdecomp = 1 - - nlev_eff_decomp = min(bc_in(s)%nlevdecomp,nlev_eff_soil) - - ! define a single shallow surface profile for surface additions - ! (leaves, stems, and N deposition). This sends the above ground - ! mass into the soil pools using an exponential depth decay function. - ! Since it is sending an absolute mass [kg] into variable layer - ! widths, we multiply the profile by the layer width, so that - ! wider layers get proportionally more. After the masses - ! are sent, each layer will normalize by depth. - - surface_prof(:) = 0._r8 - z_decomp = 0._r8 - do id = 1,nlev_eff_decomp - z_decomp = z_decomp+0.5*bc_in(s)%dz_decomp_sisl(id) - surface_prof(id) = exp(-surfprof_exp * z_decomp) * bc_in(s)%dz_decomp_sisl(id) - z_decomp = z_decomp+0.5*bc_in(s)%dz_decomp_sisl(id) - end do - surface_prof_tot = sum(surface_prof) - do id = 1,nlev_eff_decomp - surface_prof(id) = surface_prof(id)/surface_prof_tot - end do - - ! Loop over the different elements. - do el = 1, num_elements - - ! Zero out the boundary flux arrays - ! Make a pointer to the cellulose, labile and lignan - ! flux partitions. - - select case (element_list(el)) - case (carbon12_element) - bc_out(s)%litt_flux_cel_c_si(:) = 0._r8 - bc_out(s)%litt_flux_lig_c_si(:) = 0._r8 - bc_out(s)%litt_flux_lab_c_si(:) = 0._r8 - flux_cel_si => bc_out(s)%litt_flux_cel_c_si(:) - flux_lab_si => bc_out(s)%litt_flux_lab_c_si(:) - flux_lig_si => bc_out(s)%litt_flux_lig_c_si(:) - case (nitrogen_element) - bc_out(s)%litt_flux_cel_n_si(:) = 0._r8 - bc_out(s)%litt_flux_lig_n_si(:) = 0._r8 - bc_out(s)%litt_flux_lab_n_si(:) = 0._r8 - flux_cel_si => bc_out(s)%litt_flux_cel_n_si(:) - flux_lab_si => bc_out(s)%litt_flux_lab_n_si(:) - flux_lig_si => bc_out(s)%litt_flux_lig_n_si(:) - case (phosphorus_element) - bc_out(s)%litt_flux_cel_p_si(:) = 0._r8 - bc_out(s)%litt_flux_lig_p_si(:) = 0._r8 - bc_out(s)%litt_flux_lab_p_si(:) = 0._r8 - flux_cel_si => bc_out(s)%litt_flux_cel_p_si(:) - flux_lab_si => bc_out(s)%litt_flux_lab_p_si(:) - flux_lig_si => bc_out(s)%litt_flux_lig_p_si(:) - end select - - currentPatch => sites(s)%oldest_patch - do while (associated(currentPatch)) - - ! Set a pointer to the litter object - ! for the current element on the current - ! patch - litt => currentPatch%litter(el) - area_frac = currentPatch%area/area - - do ic = 1, ncwd - - do id = 1,nlev_eff_decomp - flux_cel_si(id) = flux_cel_si(id) + & - litt%ag_cwd_frag(ic) * ED_val_cwd_fcel * area_frac * surface_prof(id) - - flux_lig_si(id) = flux_lig_si(id) + & - litt%ag_cwd_frag(ic) * ED_val_cwd_flig * area_frac * surface_prof(id) - end do - - do j = 1, nlev_eff_soil - - id = bc_in(s)%decomp_id(j) ! Map from soil layer to decomp layer - - flux_cel_si(id) = flux_cel_si(id) + & - litt%bg_cwd_frag(ic,j) * ED_val_cwd_fcel * area_frac - - flux_lig_si(id) = flux_lig_si(id) + & - litt%bg_cwd_frag(ic,j) * ED_val_cwd_flig * area_frac - - end do - end do - - ! leaf and fine root fragmentation fluxes - - do id = 1,nlev_eff_decomp - - flux_lab_si(id) = flux_lab_si(id) + & - litt%leaf_fines_frag(ilabile) * area_frac* surface_prof(id) - - flux_cel_si(id) = flux_cel_si(id) + & - litt%leaf_fines_frag(icellulose) * area_frac* surface_prof(id) - - flux_lig_si(id) = flux_lig_si(id) + & - litt%leaf_fines_frag(ilignin) * area_frac* surface_prof(id) - - end do - - do j = 1, nlev_eff_soil - - id = bc_in(s)%decomp_id(j) - - flux_lab_si(id) = flux_lab_si(id) + & - litt%root_fines_frag(ilabile,j) * area_frac - flux_cel_si(id) = flux_cel_si(id) + & - litt%root_fines_frag(icellulose,j) * area_frac - flux_lig_si(id) = flux_lig_si(id) + & - litt%root_fines_frag(ilignin,j) * area_frac - enddo - - - currentPatch => currentPatch%younger - end do - - ! Normalize all masses over the decomposition layer's depth - ! Convert from kg/m2/day -> g/m3/s - - do id = 1,nlev_eff_decomp - flux_cel_si(id) = days_per_sec * g_per_kg * & - flux_cel_si(id) / bc_in(s)%dz_decomp_sisl(id) - flux_lig_si(id) = days_per_sec * g_per_kg * & - flux_lig_si(id) / bc_in(s)%dz_decomp_sisl(id) - flux_lab_si(id) = days_per_sec * g_per_kg * & - flux_lab_si(id) / bc_in(s)%dz_decomp_sisl(id) - end do - - end do ! do elements - - end do ! do sites(s) - return -end subroutine FluxIntoLitterPools - - - end module EDPhysiologyMod diff --git a/biogeochem/FatesAllometryMod.F90 b/biogeochem/FatesAllometryMod.F90 index ce56a15e35..d5011760ac 100644 --- a/biogeochem/FatesAllometryMod.F90 +++ b/biogeochem/FatesAllometryMod.F90 @@ -83,7 +83,7 @@ module FatesAllometryMod ! If this is a unit-test, these globals will be provided by a wrapper - use EDPFTvarcon , only : EDPftvarcon_inst + use PRTParametersMod, only : prt_params use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : i4 => fates_int use FatesConstantsMod, only : g_per_kg @@ -287,10 +287,10 @@ subroutine h2d_allom(h,ipft,d,dddh) real(r8),intent(out) :: d ! plant diameter [cm] real(r8),intent(out),optional :: dddh ! change in diameter per height [cm/m] - associate( p1 => EDPftvarcon_inst%allom_d2h1(ipft), & - p2 => EDPftvarcon_inst%allom_d2h2(ipft), & - p3 => EDPftvarcon_inst%allom_d2h3(ipft), & - allom_hmode => EDPftvarcon_inst%allom_hmode(ipft)) + associate( p1 => prt_params%allom_d2h1(ipft), & + p2 => prt_params%allom_d2h2(ipft), & + p3 => prt_params%allom_d2h3(ipft), & + allom_hmode => prt_params%allom_hmode(ipft)) select case(int(allom_hmode)) case (1) ! O'Brien et al 1995, BCI @@ -325,11 +325,11 @@ subroutine h_allom(d,ipft,h,dhdd) real(r8),intent(out) :: h ! plant height [m] real(r8),intent(out),optional :: dhdd ! change in height per diameter [m/cm] - associate( dbh_maxh => EDPftvarcon_inst%allom_dbh_maxheight(ipft), & - p1 => EDPftvarcon_inst%allom_d2h1(ipft), & - p2 => EDPftvarcon_inst%allom_d2h2(ipft), & - p3 => EDPftvarcon_inst%allom_d2h3(ipft), & - allom_hmode => EDPftvarcon_inst%allom_hmode(ipft)) + associate( dbh_maxh => prt_params%allom_dbh_maxheight(ipft), & + p1 => prt_params%allom_d2h1(ipft), & + p2 => prt_params%allom_d2h2(ipft), & + p3 => prt_params%allom_d2h3(ipft), & + allom_hmode => prt_params%allom_hmode(ipft)) select case(int(allom_hmode)) case (1) ! "obrien" @@ -367,14 +367,14 @@ subroutine bagw_allom(d,ipft,bagw,dbagwdd) real(r8) :: h ! height real(r8) :: dhdd ! change in height wrt d - associate( p1 => EDPftvarcon_inst%allom_agb1(ipft), & - p2 => EDPftvarcon_inst%allom_agb2(ipft), & - p3 => EDPftvarcon_inst%allom_agb3(ipft), & - p4 => EDPftvarcon_inst%allom_agb4(ipft), & - wood_density => EDPftvarcon_inst%wood_density(ipft), & - c2b => EDPftvarcon_inst%c2b(ipft), & - agb_frac => EDPftvarcon_inst%allom_agb_frac(ipft), & - allom_amode => EDPftvarcon_inst%allom_amode(ipft)) + associate( p1 => prt_params%allom_agb1(ipft), & + p2 => prt_params%allom_agb2(ipft), & + p3 => prt_params%allom_agb3(ipft), & + p4 => prt_params%allom_agb4(ipft), & + wood_density => prt_params%wood_density(ipft), & + c2b => prt_params%c2b(ipft), & + agb_frac => prt_params%allom_agb_frac(ipft), & + allom_amode => prt_params%allom_amode(ipft)) select case(int(allom_amode)) case (1) !"salda") @@ -407,13 +407,13 @@ subroutine blmax_allom(d,ipft,blmax,dblmaxdd) real(r8),intent(out) :: blmax ! plant leaf biomass [kg] real(r8),intent(out),optional :: dblmaxdd ! change leaf bio per diameter [kgC/cm] - associate( dbh_maxh => EDPftvarcon_inst%allom_dbh_maxheight(ipft), & - rho => EDPftvarcon_inst%wood_density(ipft), & - c2b => EDPftvarcon_inst%c2b(ipft), & - allom_lmode => EDPftvarcon_inst%allom_lmode(ipft), & - p1 => EDPftvarcon_inst%allom_d2bl1(ipft), & - p2 => EDPftvarcon_inst%allom_d2bl2(ipft), & - p3 => EDPftvarcon_inst%allom_d2bl3(ipft)) + associate( dbh_maxh => prt_params%allom_dbh_maxheight(ipft), & + rho => prt_params%wood_density(ipft), & + c2b => prt_params%c2b(ipft), & + allom_lmode => prt_params%allom_lmode(ipft), & + p1 => prt_params%allom_d2bl1(ipft), & + p2 => prt_params%allom_d2bl2(ipft), & + p3 => prt_params%allom_d2bl3(ipft)) select case(int(allom_lmode)) case(1) !"salda") @@ -453,12 +453,12 @@ subroutine carea_allom(dbh,nplant,site_spread,ipft,c_area,inverse) ! crown area at height, we need to make ! special considerations - associate( dbh_maxh => EDPftvarcon_inst%allom_dbh_maxheight(ipft), & - allom_lmode => EDPftvarcon_inst%allom_lmode(ipft), & - d2bl_p2 => EDPftvarcon_inst%allom_d2bl2(ipft), & - d2bl_ediff => EDPftvarcon_inst%allom_blca_expnt_diff(ipft), & - d2ca_min => EDPftvarcon_inst%allom_d2ca_coefficient_min(ipft), & - d2ca_max => EDPftvarcon_inst%allom_d2ca_coefficient_max(ipft)) + associate( dbh_maxh => prt_params%allom_dbh_maxheight(ipft), & + allom_lmode => prt_params%allom_lmode(ipft), & + d2bl_p2 => prt_params%allom_d2bl2(ipft), & + d2bl_ediff => prt_params%allom_blca_expnt_diff(ipft), & + d2ca_min => prt_params%allom_d2ca_coefficient_min(ipft), & + d2ca_max => prt_params%allom_d2ca_coefficient_max(ipft)) if( .not. present(inverse) ) then do_inverse = .false. @@ -609,7 +609,7 @@ real(r8) function tree_lai( leaf_c, pft, c_area, nplant, cl, canopy_lai, vcmax25 call endrun(msg=errMsg(sourcefile, __LINE__)) endif - slat = g_per_kg * EDPftvarcon_inst%slatop(pft) ! m2/g to m2/kg + slat = g_per_kg * prt_params%slatop(pft) ! m2/g to m2/kg leafc_per_unitarea = leaf_c/(c_area/nplant) !KgC/m2 if(leafc_per_unitarea > 0.0_r8)then @@ -626,7 +626,7 @@ real(r8) function tree_lai( leaf_c, pft, c_area, nplant, cl, canopy_lai, vcmax25 ! take PFT-level maximum SLA value, even if under a thick canopy (which has units of m2/gC), ! and put into units of m2/kgC - sla_max = g_per_kg *EDPftvarcon_inst%slamax(pft) + sla_max = g_per_kg*prt_params%slamax(pft) ! Leafc_per_unitarea at which sla_max is reached due to exponential sla profile in canopy: leafc_slamax = (slat - sla_max * exp(-1.0_r8 * kn * canopy_lai_above)) / & (-1.0_r8 * kn * slat * sla_max) @@ -725,7 +725,7 @@ real(r8) function tree_sai( pft, dbh, canopy_trim, c_area, nplant, cl, & target_lai = tree_lai( target_bleaf, pft, c_area, nplant, cl, canopy_lai, vcmax25top) - tree_sai = EDPftvarcon_inst%allom_sai_scaler(pft) * target_lai + tree_sai = prt_params%allom_sai_scaler(pft) * target_lai if( (treelai + tree_sai) > (nlevleaf*dinc_ed) )then @@ -741,7 +741,7 @@ real(r8) function tree_sai( pft, dbh, canopy_trim, c_area, nplant, cl, & write(fates_log(),*) 'call id: ',call_id write(fates_log(),*) 'n: ',nplant write(fates_log(),*) 'c_area: ',c_area - write(fates_log(),*) 'dbh: ',dbh,' dbh_max: ',EDPftvarcon_inst%allom_dbh_maxheight(pft) + write(fates_log(),*) 'dbh: ',dbh,' dbh_max: ',prt_params%allom_dbh_maxheight(pft) write(fates_log(),*) 'h: ',h write(fates_log(),*) 'canopy_trim: ',canopy_trim write(fates_log(),*) 'target_bleaf: ',target_bleaf @@ -787,7 +787,7 @@ subroutine bsap_allom(d,ipft,canopy_trim,sapw_area,bsap,dbsapdd) ! X% of total woody/fibrous (ie non leaf/fineroot) tissues real(r8),parameter :: max_frac = 0.95_r8 - select case(int(EDPftvarcon_inst%allom_smode(ipft))) + select case(int(prt_params%allom_smode(ipft))) ! --------------------------------------------------------------------- ! Currently only one sapwood allometry model. the slope ! of the la:sa to diameter line is zero. @@ -817,7 +817,7 @@ subroutine bsap_allom(d,ipft,canopy_trim,sapw_area,bsap,dbsapdd) case DEFAULT write(fates_log(),*) 'An undefined sapwood allometry was specified: ', & - EDPftvarcon_inst%allom_smode(ipft) + prt_params%allom_smode(ipft) write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end select @@ -840,13 +840,13 @@ subroutine bbgw_allom(d,ipft,bbgw,dbbgwdd) real(r8) :: bagw ! above ground biomass [kgC] real(r8) :: dbagwdd ! change in agb per diameter [kgC/cm] - select case(int(EDPftvarcon_inst%allom_cmode(ipft))) + select case(int(prt_params%allom_cmode(ipft))) case(1) !"constant") call bagw_allom(d,ipft,bagw,dbagwdd) call bbgw_const(d,bagw,dbagwdd,ipft,bbgw,dbbgwdd) case DEFAULT write(fates_log(),*) 'An undefined coarse root allometry was specified: ', & - EDPftvarcon_inst%allom_cmode(ipft) + prt_params%allom_cmode(ipft) write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end select @@ -876,7 +876,7 @@ subroutine bfineroot(d,ipft,canopy_trim,bfr,dbfrdd) real(r8) :: dbfrmaxdd real(r8) :: slascaler - select case(int(EDPftvarcon_inst%allom_fmode(ipft))) + select case(int(prt_params%allom_fmode(ipft))) case(1) ! "constant proportionality with TRIMMED target bleaf" call blmax_allom(d,ipft,blmax,dblmaxdd) @@ -896,7 +896,7 @@ subroutine bfineroot(d,ipft,canopy_trim,bfr,dbfrdd) case DEFAULT write(fates_log(),*) 'An undefined fine root allometry was specified: ', & - EDPftvarcon_inst%allom_fmode(ipft) + prt_params%allom_fmode(ipft) write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) end select @@ -923,8 +923,8 @@ subroutine bstore_allom(d,ipft,canopy_trim,bstore,dbstoredd) ! TODO: allom_stmode needs to be added to the parameter file - associate( allom_stmode => EDPftvarcon_inst%allom_stmode(ipft), & - cushion => EDPftvarcon_inst%cushion(ipft) ) + associate( allom_stmode => prt_params%allom_stmode(ipft), & + cushion => prt_params%cushion(ipft) ) select case(int(allom_stmode)) case(1) ! Storage is constant proportionality of trimmed maximum leaf @@ -971,9 +971,9 @@ subroutine bdead_allom(bagw,bbgw,bsap,ipft,bdead,dbagwdd,dbbgwdd,dbsapdd,dbdeadd ! bbgw. Therefore, it is not removed from AGB and BBGW in the calculation of dead mass. - associate( agb_fraction => EDPftvarcon_inst%allom_agb_frac(ipft)) + associate( agb_fraction => prt_params%allom_agb_frac(ipft)) - select case(int(EDPftvarcon_inst%allom_amode(ipft))) + select case(int(prt_params%allom_amode(ipft))) case(1) ! Saldariagga mass allometry originally calculated bdead directly. ! we assume proportionality between bdead and bagw @@ -993,7 +993,7 @@ subroutine bdead_allom(bagw,bbgw,bsap,ipft,bdead,dbagwdd,dbbgwdd,dbsapdd,dbdeadd case DEFAULT write(fates_log(),*) 'An undefined AGB allometry was specified: ',& - EDPftvarcon_inst%allom_amode(ipft) + prt_params%allom_amode(ipft) write(fates_log(),*) 'Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -1016,7 +1016,7 @@ subroutine bfrmax_const(d,blmax,dblmaxdd,ipft,bfrmax,dbfrmaxdd) real(r8),intent(out) :: bfrmax ! max fine-root root biomass [kgC] real(r8),intent(out),optional :: dbfrmaxdd ! change frmax bio per diam [kgC/cm] - associate( l2fr => EDPftvarcon_inst%allom_l2fr(ipft) ) + associate( l2fr => prt_params%allom_l2fr(ipft) ) bfrmax = blmax*l2fr @@ -1042,7 +1042,7 @@ subroutine bbgw_const(d,bagw,dbagwdd,ipft,bbgw,dbbgwdd) real(r8),intent(out) :: bbgw ! coarse root biomass [kg] real(r8),intent(out),optional :: dbbgwdd ! change croot bio per diam [kg/cm] - associate( agb_fraction => EDPftvarcon_inst%allom_agb_frac(ipft) ) + associate( agb_fraction => prt_params%allom_agb_frac(ipft) ) bbgw = (1.0_r8/agb_fraction-1.0_r8)*bagw @@ -1097,12 +1097,12 @@ subroutine bsap_ltarg_slatop(d,h,dhdd,bleaf,dbleafdd,ipft, & real(r8) :: hbl2bsap ! sapwood biomass per lineal height - associate ( la_per_sa_int => EDPftvarcon_inst%allom_la_per_sa_int(ipft), & - la_per_sa_slp => EDPftvarcon_inst%allom_la_per_sa_slp(ipft), & - slatop => EDPftvarcon_inst%slatop(ipft), & - wood_density => EDPftvarcon_inst%wood_density(ipft), & - c2b => EDPftvarcon_inst%c2b(ipft), & - agb_fraction => EDPftvarcon_inst%allom_agb_frac(ipft) ) + associate ( la_per_sa_int => prt_params%allom_la_per_sa_int(ipft), & + la_per_sa_slp => prt_params%allom_la_per_sa_slp(ipft), & + slatop => prt_params%slatop(ipft), & + wood_density => prt_params%wood_density(ipft), & + c2b => prt_params%c2b(ipft), & + agb_fraction => prt_params%allom_agb_frac(ipft) ) ! Calculate sapwood biomass per linear height and kgC of leaf [m-1] @@ -1984,6 +1984,10 @@ subroutine set_root_fraction(root_fraction, ft, zi) integer, intent(in) :: ft ! functional typpe real(r8),intent(in) :: zi(0:) ! Center of depth [m] + ! locals + real(r8) :: a_par ! local temporary for "a" parameter + real(r8) :: b_par ! "" "b" parameter + ! Parameters ! ! TO-DO: NEXT TIME WE ROLL OUT A NEW PARAMETER INTERFACE, ADD @@ -2017,15 +2021,15 @@ subroutine set_root_fraction(root_fraction, ft, zi) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - - select case(nint(EDPftvarcon_inst%fnrt_prof_mode(ft))) + select case(nint(prt_params%fnrt_prof_mode(ft))) case ( exponential_1p_profile_type ) - call exponential_1p_root_profile(root_fraction, ft, zi, EDPftvarcon_inst%fnrt_prof_a(ft)) + call exponential_1p_root_profile(root_fraction, zi, prt_params%fnrt_prof_a(ft)) case ( jackson_beta_profile_type ) - call jackson_beta_root_profile(root_fraction, ft, zi, EDPftvarcon_inst%fnrt_prof_a(ft)) + call jackson_beta_root_profile(root_fraction, zi, prt_params%fnrt_prof_a(ft)) case ( exponential_2p_profile_type ) - call exponential_2p_root_profile(root_fraction, ft, zi, & - EDPftvarcon_inst%fnrt_prof_a(ft),EDPftvarcon_inst%fnrt_prof_b(ft)) + call exponential_2p_root_profile(root_fraction, zi, & + prt_params%fnrt_prof_a(ft),prt_params%fnrt_prof_b(ft)) + case default write(fates_log(),*) 'An undefined root profile type was specified' write(fates_log(),*) 'Aborting' @@ -2044,11 +2048,11 @@ end subroutine set_root_fraction ! ===================================================================================== - subroutine exponential_2p_root_profile(root_fraction, ft, zi, a, b) + subroutine exponential_2p_root_profile(root_fraction, zi, a, b) + ! ! !ARGUMENTS real(r8),intent(out) :: root_fraction(:) - integer,intent(in) :: ft real(r8),intent(in) :: zi(0:) real(r8),intent(in) :: a ! Exponential shape parameter a real(r8),intent(in) :: b ! Exponential shape parameter b @@ -2079,7 +2083,7 @@ subroutine exponential_2p_root_profile(root_fraction, ft, zi, a, b) nlevsoil = ubound(zi,1) - + sum_rootfr = 0.0_r8 do lev = 1, nlevsoil root_fraction(lev) = .5_r8*( & @@ -2087,10 +2091,10 @@ subroutine exponential_2p_root_profile(root_fraction, ft, zi, a, b) + exp(-b * zi(lev-1)) & - exp(-a * zi(lev)) & - exp(-b * zi(lev))) - + sum_rootfr = sum_rootfr + root_fraction(lev) end do - + ! Normalize the root profile root_fraction(1:nlevsoil) = root_fraction(1:nlevsoil)/sum_rootfr @@ -2099,12 +2103,11 @@ end subroutine exponential_2p_root_profile ! ===================================================================================== - subroutine exponential_1p_root_profile(root_fraction, ft, zi, a) + subroutine exponential_1p_root_profile(root_fraction, zi, a) ! ! !ARGUMENTS real(r8),intent(out) :: root_fraction(:) - integer,intent(in) :: ft real(r8),intent(in) :: zi(0:) real(r8),intent(in) :: a ! Exponential shape parameter a @@ -2137,15 +2140,13 @@ end subroutine exponential_1p_root_profile ! ===================================================================================== - subroutine jackson_beta_root_profile(root_fraction, ft, zi, a) + subroutine jackson_beta_root_profile(root_fraction, zi, a) ! ----------------------------------------------------------------------------------- ! use beta distribution parameter from Jackson et al., 1996 ! ----------------------------------------------------------------------------------- - ! !ARGUMENTS real(r8),intent(out) :: root_fraction(:) ! fraction of root mass in each soil layer - integer,intent(in) :: ft ! functional type real(r8),intent(in) :: zi(0:) ! depth of layer interfaces 0-nlevsoil real(r8),intent(in) :: a ! Exponential shape parameter a @@ -2155,6 +2156,7 @@ subroutine jackson_beta_root_profile(root_fraction, ft, zi, a) integer :: nlevsoil ! number of soil layers real(r8) :: sum_rootfr ! sum of rooting profile, for normalization + ! Original defaults in fates, a = 0.976 (all Pfts) nlevsoil = ubound(zi,1) @@ -2249,7 +2251,7 @@ subroutine ForceDBH( ipft, canopy_trim, d, h, bdead, bl ) integer, parameter :: max_counter = 200 ! Do reduce "if" calls, we break this call into two parts - if ( EDPftvarcon_inst%woody(ipft) == itrue ) then + if ( int(prt_params%woody(ipft)) == itrue ) then if(.not.present(bdead)) then write(fates_log(),*) 'woody plants must use structure for dbh reset' @@ -2334,7 +2336,8 @@ subroutine ForceDBH( ipft, canopy_trim, d, h, bdead, bl ) call h_allom(d,ipft,h) if(counter>10)then - write(fates_log(),*) 'dbh counter: ',counter,EDPftvarcon_inst%woody(ipft) + write(fates_log(),*) 'dbh counter: ',counter,' is woody: ',& + int(prt_params%woody(ipft))==itrue end if diff --git a/biogeochem/FatesSoilBGCFluxMod.F90 b/biogeochem/FatesSoilBGCFluxMod.F90 new file mode 100644 index 0000000000..258c37e847 --- /dev/null +++ b/biogeochem/FatesSoilBGCFluxMod.F90 @@ -0,0 +1,1096 @@ +module FatesSoilBGCFluxMod + + ! ============================================================================ + ! This module contains the routines that handle nutrient and carbon fluxes + ! and states between the land-model's soil and FATES plants (uptake and plant + ! characteristics for aquisition), and sending fragmented litter in FATES to + ! the land-model's litter pool (which may include plant efflux). + ! ============================================================================ + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : nearzero + use shr_log_mod , only : errMsg => shr_log_errMsg + use FatesGlobals , only : fates_log + use FatesGlobals , only : endrun => fates_endrun + use PRTGenericMod , only : num_elements + use PRTGenericMod , only : element_list + use PRTGenericMod , only : element_pos + use PRTGenericMod , only : prt_carbon_allom_hyp + use PRTGenericMod , only : prt_cnp_flex_allom_hyp + use PRTGenericMod , only : prt_vartypes + use PRTGenericMod , only : leaf_organ + use PRTGenericMod , only : sapw_organ, struct_organ + use PRTGenericMod , only : all_carbon_elements + use PRTGenericMod , only : carbon12_element + use PRTGenericMod , only : nitrogen_element + use PRTGenericMod , only : phosphorus_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 FatesAllometryMod, only : set_root_fraction + use FatesAllometryMod , only : h_allom + use FatesAllometryMod , only : h2d_allom + use FatesAllometryMod , only : bagw_allom + use FatesAllometryMod , only : bsap_allom + use FatesAllometryMod , only : bleaf + use FatesAllometryMod , only : bfineroot + use FatesAllometryMod , only : bdead_allom + use FatesAllometryMod , only : bstore_allom + use FatesAllometryMod , only : bbgw_allom + use FatesAllometryMod , only : carea_allom + use EDTypesMod , only : p_uptake_mode + use EDTypesMod , only : n_uptake_mode + use EDTypesMod , only : ed_site_type + use EDTypesMod , only : ed_patch_type + use EDTypesMod , only : ed_cohort_type + use EDTypesMod , only : AREA,AREA_INV + use FatesInterfaceTypesMod, only : bc_in_type + use FatesInterfaceTypesMod, only : bc_out_type + use FatesInterfaceTypesMod, only : numpft + use FatesInterfaceTypesMod, only : hlm_nu_com + use FatesInterfaceTypesMod, only : hlm_parteh_mode + use FatesConstantsMod , only : prescribed_p_uptake + use FatesConstantsMod , only : prescribed_n_uptake + use FatesConstantsMod , only : coupled_p_uptake + use FatesConstantsMod , only : coupled_n_uptake + use FatesConstantsMod, only : days_per_sec + use FatesConstantsMod, only : g_per_kg + use FatesConstantsMod, only : kg_per_g + use FatesConstantsMod, only : fates_np_comp_scaling + use FatesConstantsMod, only : cohort_np_comp_scaling + use FatesConstantsMod, only : pft_np_comp_scaling + use FatesConstantsMod, only : rsnbl_math_prec + use FatesLitterMod, only : litter_type + use FatesLitterMod , only : ncwd + use FatesLitterMod , only : ndcmpy + use FatesLitterMod , only : ilabile + use FatesLitterMod , only : ilignin + use FatesLitterMod , only : icellulose + use PRTParametersMod , only : prt_params + use EDPftvarcon , only : EDPftvarcon_inst + + implicit none + private + + public :: PrepNutrientAquisitionBCs + public :: UnPackNutrientAquisitionBCs + public :: FluxIntoLitterPools + + + logical, parameter :: debug = .false. ! local debug flag + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + +contains + + ! ===================================================================================== + + function GetPlantDemand(ccohort,element_id) result(plant_demand) + + ! ----------------------------------------------------------------------------------- + ! This function calculates the plant's demand for a given nutrient + ! based upon the need to fill its NPP demand and/or the need to + ! get its tissues to their ideal stoichiometry ratios. + ! This routine is used for informing BGC competition schemes, and + ! for generating synthetic upake rates and also for calculating + ! diagnostics. + ! + ! THIS ROUTINE IS UNDERGOING MODIFICATIONS WILL CLEAN UP AFTER + ! A DECENT FIRST HYPOTHESIS MANIFESTS + ! ----------------------------------------------------------------------------------- + + + type(ed_cohort_type),intent(in) :: ccohort + integer,intent(in) :: element_id ! Should match nitrogen_element or + ! phosphorus_element + + real(r8) :: plant_demand ! Nutrient demand per plant [kg] + real(r8) :: plant_x ! Total mass for element of interest [kg] + real(r8) :: plant_max_x ! Maximum mass for element of interest [kg] + integer :: pft + real(r8) :: dbh + + real(r8), parameter :: smth_fac = 0.8_r8 ! Smoothing factor for updating + ! demand. + real(r8), parameter :: init_demand_frac = 0.1_r8 ! Newly recruited plants + ! will specify a demand + ! based on their total nutrient + ! because they have not history + ! of need yet + + + + pft = ccohort%pft + dbh = ccohort%dbh + + + ! If the cohort has not experienced a day of integration + ! (and thus any allocation yet), we specify demand + ! based purely on a fraction of its starting nutrient content + if(ccohort%isnew) then + + if(element_id.eq.nitrogen_element) then + plant_max_x = & + ccohort%prt%GetState(leaf_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,leaf_organ) + & + ccohort%prt%GetState(fnrt_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,fnrt_organ) + & + ccohort%prt%GetState(store_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,store_organ) + & + ccohort%prt%GetState(sapw_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,sapw_organ) + & + ccohort%prt%GetState(struct_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,struct_organ) + & + ccohort%prt%GetState(repro_organ, carbon12_element)*prt_params%nitr_stoich_p2(pft,repro_organ) + + elseif(element_id.eq.phosphorus_element) then + plant_max_x = & + ccohort%prt%GetState(leaf_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,leaf_organ) + & + ccohort%prt%GetState(fnrt_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,fnrt_organ) + & + ccohort%prt%GetState(store_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,store_organ) + & + ccohort%prt%GetState(sapw_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,sapw_organ) + & + ccohort%prt%GetState(struct_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,struct_organ) + & + ccohort%prt%GetState(repro_organ, carbon12_element)*prt_params%phos_stoich_p2(pft,repro_organ) + + end if + + plant_demand = init_demand_frac*plant_max_x + return + end if + + + ! If the plant is not a newly recruited plant + ! We use other methods of specifying nutrient demand + ! ----------------------------------------------------------------------------------- + + if(element_id.eq.nitrogen_element) then + + plant_demand = smth_fac*ccohort%daily_n_demand + (1._r8-smth_fac)*ccohort%daily_n_need2 + + elseif(element_id.eq.phosphorus_element) then + + plant_demand = smth_fac*ccohort%daily_p_demand + (1._r8-smth_fac)*ccohort%daily_p_need2 + + end if + + end function GetPlantDemand + + ! ===================================================================================== + + + subroutine UnPackNutrientAquisitionBCs(sites, bc_in) + + ! ----------------------------------------------------------------------------------- + ! The purpose of this routine is to recieve the nutrient uptake flux + ! boundary conditions, and parse those fluxes out to the cohorts. + ! + ! This routine should be called before FATES dynamics, particularly before + ! any of the PARTEH code is called. It is assumed that these uptake fluxes + ! are being incremented each short-BGC timestep over the course of the day, and + ! thus should be an integrated quantity, total nutrient uptake, over 1 day. + ! At the end of this routine, after we have parsed the uptake to the cohorts, + ! we can then zero out the input boundary conditions again, so they can be + ! integrated. + ! ----------------------------------------------------------------------------------- + + + ! !ARGUMENTS + type(ed_site_type), intent(inout) :: sites(:) + type(bc_in_type), intent(in) :: bc_in(:) + + ! Locals + integer :: nsites ! number of sites + integer :: s ! site loop index + integer :: j ! soil layer + integer :: icomp ! competitor index + integer :: id ! decomp layer index + integer :: pft ! pft index + type(ed_patch_type), pointer :: cpatch ! current patch pointer + type(ed_cohort_type), pointer :: ccohort ! current cohort pointer + real(r8) :: fnrt_c ! fine-root carbon [kg] + real(r8) :: fnrt_c_pft(numpft) ! total mass of root for each PFT [kgC] + + + nsites = size(sites,dim=1) + + + ! Zero the uptake rates + do s = 1, nsites + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ccohort => cpatch%tallest + do while (associated(ccohort)) + ccohort%daily_n_uptake = 0._r8 + ccohort%daily_p_uptake = 0._r8 + ccohort => ccohort%shorter + end do + cpatch => cpatch%younger + end do + + end do + + ! We can exit if this is a c-only simulation + if(hlm_parteh_mode.eq.prt_carbon_allom_hyp) then + ! These can now be zero'd + do s = 1, nsites + bc_in(s)%plant_n_uptake_flux(:,:) = 0._r8 + bc_in(s)%plant_p_uptake_flux(:,:) = 0._r8 + end do + return + end if + + + do s = 1, nsites + + ! If the plant is in "prescribed uptake mode" + ! then we are not coupling with the soil bgc model. + ! In this case, the bc_in structure is meaningless. + ! Instead, we give the plants a parameterized fraction + ! of their demand. Routine GetPlantDemand() returns + ! the plant demand. + + if (n_uptake_mode.eq.prescribed_n_uptake) then + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ccohort => cpatch%tallest + do while (associated(ccohort)) + pft = ccohort%pft + + ccohort%daily_n_demand = GetPlantDemand(ccohort,nitrogen_element) + ccohort%daily_n_uptake = EDPftvarcon_inst%prescribed_nuptake(pft) * ccohort%daily_n_demand + + ccohort => ccohort%shorter + end do + cpatch => cpatch%younger + end do + end if + + if (p_uptake_mode.eq.prescribed_p_uptake) then + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ccohort => cpatch%tallest + do while (associated(ccohort)) + pft = ccohort%pft + + ccohort%daily_p_demand = GetPlantDemand(ccohort,phosphorus_element) + ccohort%daily_p_uptake = EDPftvarcon_inst%prescribed_puptake(pft) * ccohort%daily_p_demand + + ccohort => ccohort%shorter + end do + cpatch => cpatch%younger + end do + end if + + + ! If nutrient competition is sent to the BGC model as PFTs + ! and not as individual cohorts, we need to unravel the input + ! boundary condition and send to cohort. We do this downscaling + ! by finding each cohort's fraction of total fine-root for the group + + n_or_p_coupled_if: if(n_uptake_mode.eq.coupled_n_uptake .or. p_uptake_mode.eq.coupled_p_uptake)then + + ! Note there are two scaling methods. Either competition for + ! N and/or P was performed by cohorts acting individually + ! (cohort_np_comp_scaling) , or as PFTs (pft_np_comp_scaling) + ! If we opt for the latter, then we assume that the nutrient + ! uptake share of the cohort, matches the fraction of root + ! mass it contributes to the group (PFT). + + if(fates_np_comp_scaling.eq.pft_np_comp_scaling) then + + ! *Currently, all cohorts in a PFT have the same root + ! fraction, so all we have to to is find its total mass fraction. + + fnrt_c_pft(:) = 0._r8 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ccohort => cpatch%tallest + do while (associated(ccohort)) + pft = ccohort%pft + fnrt_c_pft(pft) = fnrt_c_pft(pft) + & + ccohort%prt%GetState(fnrt_organ, all_carbon_elements)*ccohort%n + ccohort => ccohort%shorter + end do + cpatch => cpatch%younger + end do + + end if ! end if(fates_np_comp_scaling.eq.pft_np_comp_scaling) then + + ! -------------------------------------------------------------------------------- + ! Now that we have the arrays ready for downscaling (if needed) + ! loop through all cohorts and acquire nutrient + ! -------------------------------------------------------------------------------- + + if(n_uptake_mode.eq.coupled_n_uptake) then + + if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then + + icomp = 0 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ccohort => cpatch%tallest + do while (associated(ccohort)) + icomp = icomp+1 + ! N Uptake: Convert g/m2/day -> kg/plant/day + ccohort%daily_n_uptake = ccohort%daily_n_uptake + & + sum(bc_in(s)%plant_n_uptake_flux(icomp,:))*kg_per_g*AREA/ccohort%n + ccohort => ccohort%shorter + end do + cpatch => cpatch%younger + end do + + else + + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ccohort => cpatch%tallest + do while (associated(ccohort)) + pft = ccohort%pft + + ! Total fine-root carbon of the cohort [kgC/ha] + fnrt_c = ccohort%prt%GetState(fnrt_organ, all_carbon_elements)*ccohort%n + + ! Loop through soil layers, add up the uptake this cohort gets from each layer + do id = 1,bc_in(s)%nlevdecomp + ccohort%daily_n_uptake = ccohort%daily_n_uptake + & + bc_in(s)%plant_n_uptake_flux(pft,id) * & + (fnrt_c/fnrt_c_pft(pft))*kg_per_g*AREA/ccohort%n + end do + + ccohort => ccohort%shorter + end do + cpatch => cpatch%younger + end do + + end if + + end if + + if(p_uptake_mode.eq.coupled_p_uptake) then + + if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then + + icomp = 0 + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ccohort => cpatch%tallest + do while (associated(ccohort)) + icomp = icomp+1 + ! P Uptake: Convert g/m2/day -> kg/plant/day + ccohort%daily_p_uptake = ccohort%daily_p_uptake + & + sum(bc_in(s)%plant_p_uptake_flux(icomp,:))*kg_per_g*AREA/ccohort%n + ccohort => ccohort%shorter + end do + cpatch => cpatch%younger + end do + + else + + cpatch => sites(s)%oldest_patch + do while (associated(cpatch)) + ccohort => cpatch%tallest + do while (associated(ccohort)) + pft = ccohort%pft + ! Total fine-root carbon of the cohort [kgC/ha] + fnrt_c = ccohort%prt%GetState(fnrt_organ, all_carbon_elements)*ccohort%n + ! Loop through soil layers, add up the uptake this cohort gets from each layer + do id = 1,bc_in(s)%nlevdecomp + ccohort%daily_p_uptake = ccohort%daily_p_uptake + & + bc_in(s)%plant_p_uptake_flux(pft,id) * & + (fnrt_c/fnrt_c_pft(pft))*kg_per_g*AREA/ccohort%n + end do + ccohort => ccohort%shorter + end do + cpatch => cpatch%younger + end do + + end if + + end if + + end if n_or_p_coupled_if + + ! These can now be zero'd + bc_in(s)%plant_n_uptake_flux(:,:) = 0._r8 + bc_in(s)%plant_p_uptake_flux(:,:) = 0._r8 + + end do + return + end subroutine UnPackNutrientAquisitionBCs + + ! ===================================================================================== + + subroutine PrepNutrientAquisitionBCs(csite, bc_in, bc_out) + + ! ----------------------------------------------------------------------------------- + ! This subroutine will generate the appropriate boundary condition output + ! structures, depending on: + ! 1) Which soil-bgc competition method is active in the HLM + ! 2) If nitrification/denitrification is turned on + ! 3) Which competitor scaling type is used + ! ----------------------------------------------------------------------------------- + + ! !ARGUMENTS + type(ed_site_type), intent(inout) :: csite + type(bc_in_type), intent(in) :: bc_in + type(bc_out_type), intent(inout) :: bc_out + + ! Locals + integer :: icomp ! competitor index + integer :: j ! soil layer index + integer :: id ! decomp index (might == j) + integer :: pft ! plant functional type + integer :: nlev_eff_soil ! number of active soil layers + type(ed_patch_type), pointer :: cpatch ! current patch pointer + type(ed_cohort_type), pointer :: ccohort ! current cohort pointer + real(r8) :: fnrt_c ! fine-root carbon [kg] + real(r8) :: veg_rootc ! fine root carbon in each layer [g/m3] + real(r8) :: dbh ! dbh (cm) + real(r8) :: npp_n_demand ! Nitrogen needed to keep up with NPP [kgN] + real(r8) :: npp_p_demand ! Phosphorus needed to keep up with NPP [kgP] + real(r8) :: deficit_n_demand ! Nitrogen needed to get stoich back to + ! optimal [kgN] + real(r8) :: deficit_p_demand ! Phosphorus needed to get stoich back to + ! optimal [kgP] + real(r8) :: comp_per_pft(numpft) ! Competitors per PFT, used for averaging + + + ! Run the trivial case where we do not have a nutrient model + ! running in fates, send zero demands to the BGC model + if((hlm_parteh_mode.ne.prt_cnp_flex_allom_hyp)) then + bc_out%num_plant_comps = 1 + if(trim(hlm_nu_com).eq.'ECA')then + bc_out%ft_index(1) = 1 + bc_out%veg_rootc(1,:) = 0._r8 + bc_out%cn_scalar(1) = 0._r8 + bc_out%cp_scalar(1) = 0._r8 + bc_out%decompmicc(1) = 0._r8 + elseif(trim(hlm_nu_com).eq.'RD') then + bc_out%n_demand(1) = 0._r8 + bc_out%p_demand(1) = 0._r8 + end if + return + end if + + ! This is the number of effective soil layers to transfer from + nlev_eff_soil = max(bc_in%max_rooting_depth_index_col, 1) + + ! ECA Specific Parameters + ! -------------------------------------------------------------------------------- + if(trim(hlm_nu_com).eq.'ECA')then + + bc_out%veg_rootc(:,:) = 0._r8 ! Zero this, it will be incremented + bc_out%cn_scalar(:) = 0._r8 + bc_out%cp_scalar(:) = 0._r8 + bc_out%decompmicc(:) = 0._r8 + bc_out%ft_index(:) = -1 + + ! Loop over all patches and sum up the seed input for each PFT + icomp = 0 + comp_per_pft(:) = 0 ! This counts how many competitors per + + ! pft, used for averaging + cpatch => csite%oldest_patch + do while (associated(cpatch)) + + ccohort => cpatch%tallest + do while (associated(ccohort)) + + pft = ccohort%pft + + if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then + icomp = icomp+1 + else + icomp = pft + comp_per_pft(pft) = comp_per_pft(pft) + 1 + end if + + call set_root_fraction(csite%rootfrac_scr, pft, csite%zi_soil) + + fnrt_c = ccohort%prt%GetState(fnrt_organ, all_carbon_elements) + + ! Map the soil layers to the decomposition layers + ! (which may be synonomous) + ! veg_rootc in units: [g/m3] = [kgC/plant] * [plant/ha] * [ha/ 10k m2] * [1000 g / kg] * [1/m] + + do j = 1, nlev_eff_soil + id = bc_in%decomp_id(j) ! Map from soil layer to decomp layer + veg_rootc = fnrt_c * ccohort%n * csite%rootfrac_scr(j) * AREA_INV * g_per_kg / csite%dz_soil(j) + bc_out%veg_rootc(icomp,id) = bc_out%veg_rootc(icomp,id) + veg_rootc + bc_out%decompmicc(id) = bc_out%decompmicc(id) + & + EDPftvarcon_inst%decompmicc(pft) * veg_rootc + end do + + bc_out%ft_index(icomp) = pft + + ccohort => ccohort%shorter + end do + + cpatch => cpatch%younger + end do + + if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then + bc_out%num_plant_comps = icomp + else + bc_out%num_plant_comps = numpft + end if + + ! We calculate the decomposer microbial biomass by weighting with the + ! root biomass. This is just the normalization step + do id = 1,bc_in%nlevdecomp + bc_out%decompmicc(id) = bc_out%decompmicc(id) / & + max(nearzero,sum(bc_out%veg_rootc(:,id),dim=1)) + end do + + coupled_n_if: if(n_uptake_mode.eq.coupled_n_uptake) then + icomp = 0 + cpatch => csite%oldest_patch + do while (associated(cpatch)) + ccohort => cpatch%tallest + do while (associated(ccohort)) + + pft = ccohort%pft + if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then + icomp = icomp+1 + else + icomp = pft + end if + + bc_out%cn_scalar(icomp) = bc_out%cn_scalar(icomp) + & + ECACScalar(ccohort, nitrogen_element) + + ccohort => ccohort%shorter + end do + cpatch => cpatch%younger + end do + + ! Normalize the sum to a mean, if this is a PFT scale + ! boundary flux + if(fates_np_comp_scaling.eq.pft_np_comp_scaling) then + do icomp = 1, numpft + bc_out%cn_scalar(icomp) = bc_out%cn_scalar(icomp)/real(comp_per_pft(icomp),r8) + end do + end if + + end if coupled_n_if + + + coupled_p_if: if(p_uptake_mode.eq.coupled_p_uptake) then + + icomp = 0 + cpatch => csite%oldest_patch + do while (associated(cpatch)) + ccohort => cpatch%tallest + do while (associated(ccohort)) + + pft = ccohort%pft + if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then + icomp = icomp+1 + else + icomp = pft + end if + + bc_out%cp_scalar(icomp) = bc_out%cp_scalar(icomp) + & + ECACScalar(ccohort, phosphorus_element) + + ccohort => ccohort%shorter + end do + cpatch => cpatch%younger + end do + + if(fates_np_comp_scaling.eq.pft_np_comp_scaling) then + do icomp = 1, numpft + bc_out%cp_scalar(icomp) = bc_out%cp_scalar(icomp)/real(comp_per_pft(icomp),r8) + end do + end if + + end if coupled_p_if + + elseif(trim(hlm_nu_com).eq.'RD') then + + ! If we are using RD competition and coupling that into FATES, + ! we must update the plant's demand + ! (if this is un-coupled, the demand is handled completely in + ! the UnPack code) + ! ----------------------------------------------------------------------------------- + + if(n_uptake_mode .eq. coupled_n_uptake ) then + cpatch => csite%oldest_patch + do while (associated(cpatch)) + ccohort => cpatch%tallest + do while (associated(ccohort)) + ccohort%daily_n_demand = GetPlantDemand(ccohort,nitrogen_element) + ccohort => ccohort%shorter + end do + cpatch => cpatch%younger + end do + end if + + if(p_uptake_mode .eq. coupled_p_uptake ) then + cpatch => csite%oldest_patch + do while (associated(cpatch)) + ccohort => cpatch%tallest + do while (associated(ccohort)) + ccohort%daily_p_demand = GetPlantDemand(ccohort,phosphorus_element) + ccohort => ccohort%shorter + end do + cpatch => cpatch%younger + end do + end if + + ! -------------------------------------------------------------------------------- + ! Units on demand: + ! [gX/m2/s] convert [kgX/plant/day] * [plant/ha] * + ! [ha/10000 m2] * [1000 g/kg] * [1 day /86400 sec] + ! -------------------------------------------------------------------------------- + + bc_out%n_demand(:) = 0._r8 + bc_out%p_demand(:) = 0._r8 + + if(n_uptake_mode.eq.coupled_n_uptake) then + icomp = 0 + cpatch => csite%oldest_patch + do while (associated(cpatch)) + ccohort => cpatch%tallest + do while (associated(ccohort)) + pft = ccohort%pft + dbh = ccohort%dbh + if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then + icomp = icomp+1 + else + icomp = pft + end if + bc_out%n_demand(icomp) = bc_out%n_demand(icomp) + & + ccohort%daily_n_demand*ccohort%n*AREA_INV*g_per_kg*days_per_sec + + ccohort => ccohort%shorter + end do + cpatch => cpatch%younger + end do + end if + + if(p_uptake_mode.eq.coupled_p_uptake) then + icomp = 0 + cpatch => csite%oldest_patch + do while (associated(cpatch)) + ccohort => cpatch%tallest + do while (associated(ccohort)) + pft = ccohort%pft + dbh = ccohort%dbh + if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then + icomp = icomp+1 + else + icomp = pft + end if + bc_out%p_demand(icomp) = bc_out%p_demand(icomp) + & + ccohort%daily_p_demand*ccohort%n*AREA_INV*g_per_kg*days_per_sec + ccohort => ccohort%shorter + end do + cpatch => cpatch%younger + end do + end if + + if( (n_uptake_mode.eq.coupled_n_uptake) .or. & + (p_uptake_mode.eq.coupled_p_uptake)) then + if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then + bc_out%num_plant_comps = icomp + else + bc_out%num_plant_comps = numpft + end if + + else + bc_out%num_plant_comps = 1 + + end if + + end if + + + return + end subroutine PrepNutrientAquisitionBCs + + ! ===================================================================================== + + subroutine FluxIntoLitterPools(csite, bc_in, bc_out) + + ! ----------------------------------------------------------------------------------- + ! Created by Charlie Koven and Rosie Fisher, 2014-2015 + ! take the flux out of the fragmenting litter pools and port into the decomposing + ! litter pools. + ! in this implementation, decomposing pools are assumed to be humus and non-flammable, + ! whereas fragmenting pools are assumed to be physically fragmenting but not + ! respiring. This is a simplification, but allows us to + ! + ! a) reconcile the need to track both chemical fractions (lignin, cellulose, labile) + ! and size fractions (trunk, branch, etc.) + ! b) to impose a realistic delay on the surge of nutrients into the litter pools + ! when large CWD is added to the system via mortality + ! + ! Because of the different subgrid structure, this subroutine includes the functionality + ! that in the big-leaf BGC model, is calculated in SoilBiogeochemVerticalProfileMod + ! + ! The ED code is resolved at a daily timestep, but all of the CN-BGC fluxes are passed + ! in as derivatives per second, and then accumulated in the CNStateUpdate routines. + ! One way of doing this is to pass back the CN fluxes per second, and keep them + ! constant for the whole day (making sure they are not overwritten. This means that + ! the carbon gets passed back and forth between the photosynthesis code + ! (fast timestepping) to the ED code (slow timestepping), back to the BGC code + ! (fast timestepping). This means that the state update for the litter pools and + ! for the CWD pools occurs at different timescales. + ! ----------------------------------------------------------------------------------- + + + use FatesConstantsMod, only : sec_per_day + use FatesInterfaceTypesMod, only : bc_in_type, bc_out_type + use FatesInterfaceTypesMod, only : hlm_use_vertsoilc + use FatesInterfaceTypesMod, only : hlm_numlevgrnd + use FatesConstantsMod, only : itrue + use FatesGlobals, only : endrun => fates_endrun + use EDParamsMod , only : ED_val_cwd_flig, ED_val_cwd_fcel + + + + implicit none + + ! !ARGUMENTS + type(ed_site_type) , intent(inout) :: csite + type(bc_in_type) , intent(in) :: bc_in + type(bc_out_type) , intent(inout),target :: bc_out + + ! !LOCAL VARIABLES: + type (ed_patch_type), pointer :: currentPatch + type (ed_cohort_type), pointer :: currentCohort + real(r8), pointer :: flux_cel_si(:) + real(r8), pointer :: flux_lab_si(:) + real(r8), pointer :: flux_lig_si(:) + real(r8), pointer :: efflux_ptr ! Points to the current + ! element's root efflux + type(litter_type), pointer :: litt + + real(r8) :: surface_prof(1:hlm_numlevgrnd) ! this array is used to distribute + ! fragmented litter on the surface + ! into the soil/decomposition + ! layers. It exponentially decays + real(r8) :: surface_prof_tot ! normalizes the surface_prof array + integer :: ft ! PFT number + integer :: nlev_eff_soil ! number of effective soil layers + integer :: nlev_eff_decomp ! number of effective decomp layers + real(r8) :: area_frac ! fraction of site's area of current patch + real(r8) :: z_decomp ! Used for calculating depth midpoints of decomp layers + integer :: s ! Site index + integer :: el ! Element index (C,N,P,etc) + integer :: j ! Soil layer index + integer :: id ! Decomposition layer index + integer :: ic ! CWD type index + + ! NOTE(rgk, 201705) this parameter was brought over from SoilBiogeochemVerticalProfile + ! how steep profile is for surface components (1/ e_folding depth) (1/m) + real(r8), parameter :: surfprof_exp = 10. + + + ! This is the number of effective soil layers to transfer from + nlev_eff_soil = max(bc_in%max_rooting_depth_index_col, 1) + + ! The decomposition layers are most likely the exact same layers + ! as the soil layers (same depths also), unless it is a simplified + ! single layer case, where nlevdecomp = 1 + + nlev_eff_decomp = min(bc_in%nlevdecomp,nlev_eff_soil) + + ! define a single shallow surface profile for surface additions + ! (leaves, stems, and N deposition). This sends the above ground + ! mass into the soil pools using an exponential depth decay function. + ! Since it is sending an absolute mass [kg] into variable layer + ! widths, we multiply the profile by the layer width, so that + ! wider layers get proportionally more. After the masses + ! are sent, each layer will normalize by depth. + + surface_prof(:) = 0._r8 + z_decomp = 0._r8 + do id = 1,nlev_eff_decomp + z_decomp = z_decomp+0.5*bc_in%dz_decomp_sisl(id) + surface_prof(id) = exp(-surfprof_exp * z_decomp) * bc_in%dz_decomp_sisl(id) + z_decomp = z_decomp+0.5*bc_in%dz_decomp_sisl(id) + end do + surface_prof_tot = sum(surface_prof) + do id = 1,nlev_eff_decomp + surface_prof(id) = surface_prof(id)/surface_prof_tot + end do + + ! Loop over the different elements. + do el = 1, num_elements + + ! Zero out the boundary flux arrays + ! Make a pointer to the cellulose, labile and lignan + ! flux partitions. + + select case (element_list(el)) + case (carbon12_element) + bc_out%litt_flux_cel_c_si(:) = 0._r8 + bc_out%litt_flux_lig_c_si(:) = 0._r8 + bc_out%litt_flux_lab_c_si(:) = 0._r8 + flux_cel_si => bc_out%litt_flux_cel_c_si(:) + flux_lab_si => bc_out%litt_flux_lab_c_si(:) + flux_lig_si => bc_out%litt_flux_lig_c_si(:) + + case (nitrogen_element) + bc_out%litt_flux_cel_n_si(:) = 0._r8 + bc_out%litt_flux_lig_n_si(:) = 0._r8 + bc_out%litt_flux_lab_n_si(:) = 0._r8 + flux_cel_si => bc_out%litt_flux_cel_n_si(:) + flux_lab_si => bc_out%litt_flux_lab_n_si(:) + flux_lig_si => bc_out%litt_flux_lig_n_si(:) + + ! If we have prescribed boundary conditions + ! we do not take N out of the BGC model's + ! stores, so nor do we send any back + if(n_uptake_mode.eq.prescribed_n_uptake) cycle + + case (phosphorus_element) + bc_out%litt_flux_cel_p_si(:) = 0._r8 + bc_out%litt_flux_lig_p_si(:) = 0._r8 + bc_out%litt_flux_lab_p_si(:) = 0._r8 + flux_cel_si => bc_out%litt_flux_cel_p_si(:) + flux_lab_si => bc_out%litt_flux_lab_p_si(:) + flux_lig_si => bc_out%litt_flux_lig_p_si(:) + + ! If we have prescribed boundary conditions + ! we do not take N out of the BGC model's + ! stores, so nor do we send any back + if(p_uptake_mode.eq.prescribed_p_uptake) cycle + + end select + + + currentPatch => csite%oldest_patch + do while (associated(currentPatch)) + + ! If there is any efflux (from stores overflowing) + ! than pass that to the labile litter pool + + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + if(.not.currentCohort%isnew)then + if(element_list(el).eq.carbon12_element) then + efflux_ptr => currentCohort%daily_c_efflux + elseif(element_list(el).eq.nitrogen_element) then + efflux_ptr => currentCohort%daily_n_efflux + elseif(element_list(el).eq.phosphorus_element) then + efflux_ptr => currentCohort%daily_p_efflux + end if + do id = 1,nlev_eff_decomp + flux_lab_si(id) = flux_lab_si(id) + & + efflux_ptr*currentCohort%n* AREA_INV * surface_prof(id) + end do + end if + currentCohort => currentCohort%shorter + end do + + ! Set a pointer to the litter object + ! for the current element on the current + ! patch + litt => currentPatch%litter(el) + area_frac = currentPatch%area/area + + do ic = 1, ncwd + + do id = 1,nlev_eff_decomp + flux_cel_si(id) = flux_cel_si(id) + & + litt%ag_cwd_frag(ic) * ED_val_cwd_fcel * area_frac * surface_prof(id) + + flux_lig_si(id) = flux_lig_si(id) + & + litt%ag_cwd_frag(ic) * ED_val_cwd_flig * area_frac * surface_prof(id) + end do + + do j = 1, nlev_eff_soil + + id = bc_in%decomp_id(j) ! Map from soil layer to decomp layer + + flux_cel_si(id) = flux_cel_si(id) + & + litt%bg_cwd_frag(ic,j) * ED_val_cwd_fcel * area_frac + + flux_lig_si(id) = flux_lig_si(id) + & + litt%bg_cwd_frag(ic,j) * ED_val_cwd_flig * area_frac + + end do + end do + + ! leaf and fine root fragmentation fluxes + + do id = 1,nlev_eff_decomp + + flux_lab_si(id) = flux_lab_si(id) + & + litt%leaf_fines_frag(ilabile) * area_frac* surface_prof(id) + + flux_cel_si(id) = flux_cel_si(id) + & + litt%leaf_fines_frag(icellulose) * area_frac* surface_prof(id) + + flux_lig_si(id) = flux_lig_si(id) + & + litt%leaf_fines_frag(ilignin) * area_frac* surface_prof(id) + + end do + + do j = 1, nlev_eff_soil + + id = bc_in%decomp_id(j) + + flux_lab_si(id) = flux_lab_si(id) + & + litt%root_fines_frag(ilabile,j) * area_frac + flux_cel_si(id) = flux_cel_si(id) + & + litt%root_fines_frag(icellulose,j) * area_frac + flux_lig_si(id) = flux_lig_si(id) + & + litt%root_fines_frag(ilignin,j) * area_frac + enddo + + currentPatch => currentPatch%younger + end do + + ! Normalize all masses over the decomposition layer's depth + ! Convert from kg/m2/day -> g/m3/s + + do id = 1,nlev_eff_decomp + flux_cel_si(id) = days_per_sec * g_per_kg * & + flux_cel_si(id) / bc_in%dz_decomp_sisl(id) + flux_lig_si(id) = days_per_sec * g_per_kg * & + flux_lig_si(id) / bc_in%dz_decomp_sisl(id) + flux_lab_si(id) = days_per_sec * g_per_kg * & + flux_lab_si(id) / bc_in%dz_decomp_sisl(id) + end do + + + end do ! do elements + + + return + end subroutine FluxIntoLitterPools + + ! ===================================================================================== + + function ECACScalar(ccohort, element_id) result(c_scalar) + + ! ----------------------------------------------------------------------------------- + ! This function returns the cn_scalar or cp_scalar term + ! described in: + ! Zhu, Q et al. Representing Nitrogen, Phosphorus and Carbon + ! interactions in the E3SM land model: Development and Global benchmarking. + ! Journal of Advances in Modeling Earth Systems, 11, 2238-2258, 2019. + ! https://doi.org/10.1029/2018MS001571 + ! + ! In the manuscript c_scalar is described as: "f(CN) and f(CP) account for the + ! regulation of plant nutritional level on nutrient carrier enzyme activity" + ! Also, see equations 4 and 5. + ! ----------------------------------------------------------------------------------- + + + ! Arguments (in) + type(ed_cohort_type), pointer :: ccohort ! current cohort pointer + integer :: element_id ! element id consistent with parteh/PRTGenericMod.F90 + + ! Arguments (out) + real(r8) :: c_scalar + + ! Locals + + real(r8) :: target_leaf_c ! maximum leaf C for this dbh [kg] + real(r8) :: target_store_c ! maximum store C for this dbh [kg] + ! + ! Where X is the element of interest: + real(r8) :: leaf_store_x ! Mass of current element in leaf and storage + real(r8) :: xc_actual ! Actual X:C ratio of plant + real(r8) :: xc_min ! Minimum allowable X:C ratio to build tissue + real(r8) :: xc_ideal ! Plant's ideal X:C ratio + real(r8) :: cx_actual ! Actual C:X ratio of plant + real(r8) :: cx_ideal ! Ideal C:X ratio of plant + real(r8) :: c_stoich_var ! effective variance of the CN or CP ratio + + ! We are still testing different functional relationships for c_scalar, thus + ! three methods. Methods 1 and 2 are subtly different, but both increase neediness + ! as a plants NC or PC ratio decreases, and vice versa. The variance + ! parameter acts as a buffer on the steepness of the relationship. + ! Method 3 turns off neediness and sets it to 1 (always fully needy) + ! + ! method 1: cn_scalar = (nc_ideal - nc_actual + variance*nc_min)/(nc_ideal - nc_min + variance*nc_min) + ! + ! method 2: cn_scalar = (1/nc_actual - (1-variance)/nc_ideal)/(variance/nc_ideal) + + integer, parameter :: cnp_scalar_method1 = 1 + integer, parameter :: cnp_scalar_method2 = 2 + integer, parameter :: cnp_scalar_method3 = 3 + integer, parameter :: cnp_scalar_method = cnp_scalar_method3 + + real(r8), parameter :: cn_stoich_var=0.2 ! variability of CN ratio + real(r8), parameter :: cp_stoich_var=0.4 ! variability of CP ratio + + + ! Target leaf biomass according to allometry and trimming + call bleaf(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,target_leaf_c) + call bstore_allom(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,target_store_c) + + leaf_store_x = max(rsnbl_math_prec,ccohort%prt%GetState(leaf_organ, element_id) + & + ccohort%prt%GetState(store_organ, element_id)) + + ! Calculate the ideal CN or CP ratio for leaves and storage organs + + if(element_id==nitrogen_element)then + + xc_ideal = ((target_leaf_c*prt_params%nitr_stoich_p2(ccohort%pft,leaf_organ)) + & + (target_store_c*prt_params%nitr_stoich_p2(ccohort%pft,store_organ))) / & + (target_leaf_c+target_store_c) + xc_min = ((target_leaf_c*prt_params%nitr_stoich_p1(ccohort%pft,leaf_organ)) + & + (target_store_c*prt_params%nitr_stoich_p1(ccohort%pft,store_organ))) / & + (target_leaf_c+target_store_c) + + xc_actual = max(leaf_store_x/(target_leaf_c+target_store_c),rsnbl_math_prec) + + c_stoich_var = cn_stoich_var + + elseif(element_id==phosphorus_element) then + + xc_ideal = ((target_leaf_c*prt_params%phos_stoich_p2(ccohort%pft,leaf_organ)) + & + (target_store_c*prt_params%phos_stoich_p2(ccohort%pft,store_organ))) / & + (target_leaf_c+target_store_c) + xc_min = ((target_leaf_c*prt_params%phos_stoich_p1(ccohort%pft,leaf_organ)) + & + (target_store_c*prt_params%phos_stoich_p1(ccohort%pft,store_organ))) / & + (target_leaf_c+target_store_c) + + xc_actual = max(leaf_store_x/(target_leaf_c+target_store_c),rsnbl_math_prec) + + c_stoich_var = cp_stoich_var + + else + write(fates_log(), *) 'attempted to call ECACScalar() for unknown element',element_id + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + select case(cnp_scalar_method) + case(cnp_scalar_method1) + + ! To-do: Add a logistic function here, with a + ! shape parameter so that 95%tile of + ! nutrient concentration matches 95%tile of scalar + ! 0.95 = 1._r8/(1._r8 + exp(-logi_k*( 0.95*(nc_ideal-x0) ))) + ! logi_k = -log(1._r8-0.95/0.95)/ ( 0.95*(nc_ideal-x0) ) + ! bc_out%cn_scalar(icomp) = 1._r8/(1._r8 + exp(-logi_k*(nc_actual-x0))) + + c_scalar = min(1._r8,max(0._r8, & + (xc_ideal - xc_actual + c_stoich_var*xc_min) / & + (xc_ideal - xc_min + c_stoich_var*xc_min))) + + case(cnp_scalar_method2) + + cx_ideal = 1._r8/xc_ideal + cx_actual = 1._r8/xc_actual + c_scalar = min(1._r8,max(0._r8, & + (cx_actual - cx_ideal*(1._r8-c_stoich_var))/(cx_ideal*c_stoich_var))) + + case(cnp_scalar_method3) + + c_scalar = 1 + + end select + + end function ECACScalar + + +end module FatesSoilBGCFluxMod diff --git a/biogeophys/FatesPlantHydraulicsMod.F90 b/biogeophys/FatesPlantHydraulicsMod.F90 index b6ec35febf..57b9870916 100644 --- a/biogeophys/FatesPlantHydraulicsMod.F90 +++ b/biogeophys/FatesPlantHydraulicsMod.F90 @@ -97,6 +97,8 @@ module FatesPlantHydraulicsMod use clm_time_manager , only : get_step_size, get_nstep use EDPftvarcon, only : EDPftvarcon_inst + use PRTParametersMod, only : prt_params + use FatesHydroWTFMod, only : wrf_arr_type use FatesHydroWTFMod, only : wkf_arr_type @@ -672,8 +674,8 @@ subroutine UpdatePlantHydrNodes(ccohort_hydr,ft,plant_height,csite_hydr) ! Crown Nodes ! in special case where n_hypool_leaf = 1, the node height of the canopy ! water pool is 1/2 the distance from the bottom of the canopy to the top of the tree - roota = EDPftvarcon_inst%fnrt_prof_a(ft) - rootb = EDPftvarcon_inst%fnrt_prof_b(ft) + roota = prt_params%fnrt_prof_a(ft) + rootb = prt_params%fnrt_prof_b(ft) nlevrhiz = csite_hydr%nlevrhiz call CrownDepth(plant_height,crown_depth) @@ -835,8 +837,8 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) fnrt_c = ccohort%prt%GetState(fnrt_organ, all_carbon_elements) struct_c = ccohort%prt%GetState(struct_organ, all_carbon_elements) - roota = EDPftvarcon_inst%fnrt_prof_a(ft) - rootb = EDPftvarcon_inst%fnrt_prof_b(ft) + roota = prt_params%fnrt_prof_a(ft) + rootb = prt_params%fnrt_prof_b(ft) ! Leaf Volumes ! ----------------------------------------------------------------------------------- @@ -845,10 +847,10 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! but that may not be so forever. ie sla = slatop (RGK-082017) ! m2/gC * cm2/m2 -> cm2/gC - sla = EDPftvarcon_inst%slatop(ft) * cm2_per_m2 + sla = prt_params%slatop(ft) * cm2_per_m2 ! empirical regression data from leaves at Caxiuana (~ 8 spp) - denleaf = -2.3231_r8*sla/EDPftvarcon_inst%c2b(ft) + 781.899_r8 + denleaf = -2.3231_r8*sla/prt_params%c2b(ft) + 781.899_r8 ! Leaf volumes ! Note: Leaf volumes of zero is problematic for two reasons. Zero volumes create @@ -866,7 +868,6 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! [kgC] * [kg/kgC] / [kg/m3] -> [m3] - ! Get the target, or rather, maximum leaf carrying capacity of plant ! Lets also avoid super-low targets that have very low trimming functions @@ -874,7 +875,7 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) if( (ccohort%status_coh == leaves_on) .or. ccohort_hydr%is_newly_recruited ) then ccohort_hydr%v_ag(1:n_hypool_leaf) = max(leaf_c,min_leaf_frac*leaf_c_target) * & - EDPftvarcon_inst%c2b(ft) / denleaf/ real(n_hypool_leaf,r8) + prt_params%c2b(ft) / denleaf/ real(n_hypool_leaf,r8) end if ! Step sapwood volume @@ -882,7 +883,8 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! BOC...may be needed for testing/comparison w/ v_sapwood ! kg / ( g cm-3 * cm3/m3 * kg/g ) -> m3 - ! v_stem = b_stem_biom / (EDPftvarcon_inst%wood_density(ft) * kg_per_g * cm3_per_m3 ) + ! v_stem = b_stem_biom / (prt_params%wood_density(ft) * kg_per_g * cm3_per_m3 ) + ! calculate the sapwood cross-sectional area call bsap_allom(ccohort%dbh,ccohort%pft,ccohort%canopy_trim,a_sapwood_target,sapw_c_target) @@ -904,17 +906,17 @@ subroutine UpdatePlantHydrLenVol(ccohort,site_hydr) ! leaf, fine root) biomass then subtract out the fine root biomass to get ! coarse (transporting) root biomass - woody_bg_c = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(ft)) * (sapw_c + struct_c) + woody_bg_c = (1.0_r8-prt_params%allom_agb_frac(ft)) * (sapw_c + struct_c) - v_troot = woody_bg_c * EDPftvarcon_inst%c2b(ft) / & - (EDPftvarcon_inst%wood_density(ft)*kg_per_g*cm3_per_m3) + v_troot = woody_bg_c * prt_params%c2b(ft) / & + (prt_params%wood_density(ft)*kg_per_g*cm3_per_m3) ! Estimate absorbing root total length (all layers) ! SRL is in m/g ! [m] = [kgC]*1000[g/kg]*[kg/kgC]*[m/g] ! ------------------------------------------------------------------------------ - l_aroot_tot = fnrt_c*g_per_kg*EDPftvarcon_inst%c2b(ft)*EDPftvarcon_inst%hydr_srl(ft) + l_aroot_tot = fnrt_c*g_per_kg*prt_params%c2b(ft)*EDPftvarcon_inst%hydr_srl(ft) ! Estimate absorbing root volume (all layers) diff --git a/biogeophys/FatesPlantRespPhotosynthMod.F90 b/biogeophys/FatesPlantRespPhotosynthMod.F90 index 5ca03537be..bfe01d25be 100644 --- a/biogeophys/FatesPlantRespPhotosynthMod.F90 +++ b/biogeophys/FatesPlantRespPhotosynthMod.F90 @@ -33,7 +33,7 @@ module FATESPlantRespPhotosynthMod use EDTypesMod, only : maxpft use EDTypesMod, only : nlevleaf use EDTypesMod, only : nclmax - use EDTypesMod, only : max_nleafage + use PRTGenericMod, only : max_nleafage use EDTypesMod, only : do_fates_salinity use EDParamsMod, only : q10_mr use PRTGenericMod, only : prt_carbon_allom_hyp @@ -46,7 +46,8 @@ module FATESPlantRespPhotosynthMod use PRTGenericMod, only : store_organ use PRTGenericMod, only : repro_organ use PRTGenericMod, only : struct_organ - use EDParamsMod, only : ED_val_base_mr_20, stomatal_model + use EDParamsMod, only : ED_val_base_mr_20, stomatal_model + use PRTParametersMod, only : prt_params ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -106,7 +107,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) use FatesConstantsMod, only : tfrz => t_water_freeze_k_1atm use FatesParameterDerivedMod, only : param_derived - use FatesAllometryMod, only : bleaf + use FatesAllometryMod, only : bleaf, bstore_allom use FatesAllometryMod, only : storage_fraction_of_target use FatesAllometryMod, only : set_root_fraction use FatesAllometryMod, only : decay_coeff_kn @@ -184,6 +185,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) real(r8) :: live_croot_n ! Live coarse root (below-ground sapwood) ! nitrogen content (kgN/plant) real(r8) :: sapw_c ! Sapwood carbon (kgC/plant) + real(r8) :: store_c_target ! Target storage carbon (kgC/plant) real(r8) :: fnrt_c ! Fine root carbon (kgC/plant) real(r8) :: fnrt_n ! Fine root nitrogen content (kgN/plant) real(r8) :: leaf_c ! Leaf carbon (kgC/plant) @@ -248,11 +250,12 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) associate( & c3psn => EDPftvarcon_inst%c3psn , & - 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? + slatop => prt_params%slatop , & ! specific leaf area at top of canopy, + ! projected area basis [m^2/gC] + woody => prt_params%woody, & ! Is vegetation woody or not? stomatal_intercept => EDPftvarcon_inst%stomatal_intercept ) !Unstressed minimum stomatal conductance + do s = 1,nsites ! Multi-layer parameters scaled by leaf nitrogen profile. @@ -361,8 +364,11 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ft = currentCohort%pft cl = currentCohort%canopy_layer - call bleaf(currentCohort%dbh,currentCohort%pft,currentCohort%canopy_trim,b_leaf) - call storage_fraction_of_target(b_leaf, & + call bleaf(currentCohort%dbh,currentCohort%pft,currentCohort%canopy_trim,store_c_target) +! call bstore_allom(currentCohort%dbh,currentCohort%pft, & +! currentCohort%canopy_trim,store_c_target) + + call storage_fraction_of_target(store_c_target, & currentCohort%prt%GetState(store_organ, all_carbon_elements), & frac) call lowstorage_maintresp_reduction(frac,currentCohort%pft, & @@ -450,14 +456,22 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) select case(hlm_parteh_mode) case (prt_carbon_allom_hyp) - lnc_top = EDPftvarcon_inst%prt_nitr_stoich_p1(ft,leaf_organ)/slatop(ft) + lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) case (prt_cnp_flex_allom_hyp) leaf_c = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) - leaf_n = currentCohort%prt%GetState(leaf_organ, all_carbon_elements) - lnc_top = leaf_n / (slatop(ft) * leaf_c ) - + if( (leaf_c*slatop(ft)) > nearzero) then + leaf_n = currentCohort%prt%GetState(leaf_organ, nitrogen_element) + lnc_top = leaf_n / (slatop(ft) * leaf_c ) + else + lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) + end if + + ! If one wants to break coupling with dynamic N conentrations, + ! use the stoichiometry parameter + ! lnc_top = prt_params%nitr_stoich_p1(ft,leaf_organ)/slatop(ft) + end select lmr25top = 2.525e-6_r8 * (1.5_r8 ** ((25._r8 - 20._r8)/10._r8)) @@ -602,24 +616,34 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) 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_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & + sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) - live_croot_n = (1.0_r8-EDPftvarcon_inst%allom_agb_frac(currentCohort%pft)) * & - sapw_c * EDPftvarcon_inst%prt_nitr_stoich_p1(ft,sapw_organ) + live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & + sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) - fnrt_n = fnrt_c * EDPftvarcon_inst%prt_nitr_stoich_p1(ft,fnrt_organ) + fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,fnrt_organ) case(prt_cnp_flex_allom_hyp) - live_stem_n = EDPftvarcon_inst%allom_agb_frac(currentCohort%pft) * & + live_stem_n = prt_params%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)) * & + live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & currentCohort%prt%GetState(sapw_organ, nitrogen_element) fnrt_n = currentCohort%prt%GetState(fnrt_organ, nitrogen_element) + ! If one wants to break coupling with dynamic N conentrations, + ! use the stoichiometry parameter + ! + ! live_stem_n = prt_params%allom_agb_frac(currentCohort%pft) * & + ! sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) + ! live_croot_n = (1.0_r8-prt_params%allom_agb_frac(currentCohort%pft)) * & + ! sapw_c * prt_params%nitr_stoich_p1(ft,sapw_organ) + ! fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ft,fnrt_organ) + + case default @@ -636,7 +660,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! Live stem MR (kgC/plant/s) (above ground sapwood) ! ------------------------------------------------------------------ - if (woody(ft) == 1) then + if ( int(woody(ft)) == itrue) then tcwood = q10_mr**((bc_in(s)%t_veg_pa(ifp)-tfrz - 20.0_r8)/10.0_r8) ! kgC/s = kgN * kgC/kgN/s currentCohort%livestem_mr = live_stem_n * ED_val_base_mr_20 * tcwood * maintresp_reduction_factor @@ -656,7 +680,7 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) ! Coarse Root MR (kgC/plant/s) (below ground sapwood) ! ------------------------------------------------------------------ - if (woody(ft) == 1) then + if ( int(woody(ft)) == itrue) then currentCohort%livecroot_mr = 0._r8 do j = 1,bc_in(s)%nlevsoil ! Soil temperature used to adjust base rate of MR @@ -703,11 +727,13 @@ subroutine FatesPlantRespPhotosynthDrive (nsites, sites,bc_in,bc_out,dtime) if ( debug ) write(fates_log(),*) 'EDPhoto 912 ', currentCohort%resp_tstep if ( debug ) write(fates_log(),*) 'EDPhoto 913 ', currentCohort%resp_m - currentCohort%resp_g = EDPftvarcon_inst%grperc(ft) * & - (max(0._r8,currentCohort%gpp_tstep - & - currentCohort%resp_m)) + + currentCohort%resp_g_tstep = prt_params%grperc(ft) * & + (max(0._r8,currentCohort%gpp_tstep - currentCohort%resp_m)) + + currentCohort%resp_tstep = currentCohort%resp_m + & - currentCohort%resp_g ! kgC/indiv/ts + currentCohort%resp_g_tstep ! kgC/indiv/ts currentCohort%npp_tstep = currentCohort%gpp_tstep - & currentCohort%resp_tstep ! kgC/indiv/ts @@ -1278,7 +1304,7 @@ subroutine ScaleLeafLayerFluxToCohort(nv, & ! in currentCohort%nv real(r8) :: cohort_layer_eleaf_area ! the effective leaf area of the cohort's current layer [m2] cohort_eleaf_area = 0.0_r8 - g_sb_laweight = 0.0_r8 + g_sb_laweight = 0.0_r8 gpp = 0.0_r8 rdark = 0.0_r8 diff --git a/fire/SFMainMod.F90 b/fire/SFMainMod.F90 index 2cfa6bd2bc..dd417c9974 100644 --- a/fire/SFMainMod.F90 +++ b/fire/SFMainMod.F90 @@ -18,8 +18,9 @@ module SFMainMod use FatesInterfaceTypesMod, only : bc_in_type use EDPftvarcon , only : EDPftvarcon_inst - - use EDTypesMod , only : element_pos + use PRTParametersMod , only : prt_params + + use PRTGenericMod , only : element_pos use EDtypesMod , only : ed_site_type use EDtypesMod , only : ed_patch_type use EDtypesMod , only : ed_cohort_type @@ -189,7 +190,7 @@ subroutine charecteristics_of_fuel ( currentSite ) currentPatch%livegrass = 0.0_r8 currentCohort => currentPatch%tallest do while(associated(currentCohort)) - if(EDPftvarcon_inst%woody(currentCohort%pft) == 0)then + if( int(prt_params%woody(currentCohort%pft)) == ifalse)then currentPatch%livegrass = currentPatch%livegrass + & currentCohort%prt%GetState(leaf_organ, all_carbon_elements) * & @@ -374,7 +375,7 @@ subroutine wind_effect ( currentSite, bc_in) do while(associated(currentCohort)) if (debug) write(fates_log(),*) 'SF currentCohort%c_area ',currentCohort%c_area - if(EDPftvarcon_inst%woody(currentCohort%pft) == 1)then + if( int(prt_params%woody(currentCohort%pft)) == itrue)then currentPatch%total_tree_area = currentPatch%total_tree_area + currentCohort%c_area else total_grass_area = total_grass_area + currentCohort%c_area @@ -857,26 +858,25 @@ subroutine crown_scorching ( currentSite ) if (currentPatch%fire == 1) then currentCohort => currentPatch%tallest; do while(associated(currentCohort)) - if (EDPftvarcon_inst%woody(currentCohort%pft) == 1) then !trees only - + if ( int(prt_params%woody(currentCohort%pft)) == itrue) then !trees only + 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)) - + currentCohort%n * (leaf_c + & + prt_params%allom_agb_frac(currentCohort%pft)*(sapw_c + struct_c)) endif !trees only currentCohort=>currentCohort%shorter; enddo !end cohort loop do i_pft=1,numpft - if (tree_ag_biomass > 0.0_r8 .and. EDPftvarcon_inst%woody(i_pft) == 1) then + if (tree_ag_biomass > 0.0_r8 .and. int(prt_params%woody(i_pft)) == itrue) then !Equation 16 in Thonicke et al. 2010 !Van Wagner 1973 EQ8 !2/3 Byram (1959) currentPatch%Scorch_ht(i_pft) = EDPftvarcon_inst%fire_alpha_SH(i_pft) * (currentPatch%FI**0.667_r8) - + if(write_SF == itrue)then if ( hlm_masterproc == itrue ) write(fates_log(),*) 'currentPatch%SH',currentPatch%Scorch_ht(i_pft) endif @@ -913,7 +913,7 @@ subroutine crown_damage ( currentSite ) do while(associated(currentCohort)) currentCohort%fraction_crown_burned = 0.0_r8 - if (EDPftvarcon_inst%woody(currentCohort%pft) == 1) then !trees only + if ( int(prt_params%woody(currentCohort%pft)) == itrue) then !trees only ! Flames lower than bottom of canopy. ! c%hite is height of cohort if (currentPatch%Scorch_ht(currentCohort%pft) < & @@ -976,7 +976,7 @@ subroutine cambial_damage_kill ( currentSite ) if (currentPatch%fire == 1) then currentCohort => currentPatch%tallest; do while(associated(currentCohort)) - if (EDPftvarcon_inst%woody(currentCohort%pft) == 1) then !trees only + if ( int(prt_params%woody(currentCohort%pft)) == itrue) then !trees only ! Equation 21 in Thonicke et al 2010 bt = EDPftvarcon_inst%bark_scaler(currentCohort%pft)*currentCohort%dbh ! bark thickness. ! Equation 20 in Thonicke et al. 2010. @@ -1028,7 +1028,7 @@ subroutine post_fire_mortality ( currentSite ) do while(associated(currentCohort)) currentCohort%fire_mort = 0.0_r8 currentCohort%crownfire_mort = 0.0_r8 - if (EDPftvarcon_inst%woody(currentCohort%pft) == 1) then + if ( int(prt_params%woody(currentCohort%pft)) == itrue) then ! Equation 22 in Thonicke et al. 2010. currentCohort%crownfire_mort = EDPftvarcon_inst%crown_kill(currentCohort%pft)*currentCohort%fraction_crown_burned**3.0_r8 ! Equation 18 in Thonicke et al. 2010. diff --git a/functional_unit_testing/parteh/AutoGenVarCon.py b/functional_unit_testing/parteh/AutoGenVarCon.py new file mode 100644 index 0000000000..ac5e43c7f3 --- /dev/null +++ b/functional_unit_testing/parteh/AutoGenVarCon.py @@ -0,0 +1,165 @@ +# ============================================================================= +# Walk through lines of a file, if a line contains +# the string of interest (EDPftvarcon_inst), then +# parse the string to find the variable name, and save that +# to the list +# ============================================================================= + +import imp +import code # For development: code.interact(local=dict(globals(), **locals())) + +F90ParamParse = imp.load_source('F90ParamParse','py_modules/F90ParamParse.py') +CDLParse = imp.load_source('CDLParse','py_modules/CDLParse.py') + + +from F90ParamParse import f90_param_type, GetParamsInFile, GetPFTParmFileSymbols, MakeListUnique +from CDLParse import CDLParseDims, CDLParseParam, cdl_param_type + + +# ------------------------------------------------------------------------------------- +# Check through the fortran Code we are coupling with, determine the list of parameters +# that we need. +# The procedure GetSymbolUsage() returns a list of strings (non-unique) +# ------------------------------------------------------------------------------------- + +var_list = GetParamsInFile('../../parteh/PRTParametersMod.F90') + + +# Now look through EDPftvarcon.F90 to determine the variable name in file +# that is associated with the variable pointer + +var_list = GetPFTParmFileSymbols(var_list,'../../parteh/PRTParamsFATESMod.F90') + +# ------------------------------------------------------------- +# We can now cross reference our list of parameters against +# the parameter file. This will create a new list of parameters +# however in the form of a dictionary. This dictionary of +# entries is accessible by its symbol name, and will also +# read in and store the actual parameter values from the file. +# We will use the default file to get the dimensionality. +# +# NOTE: THE CDLPARSE PROCEDURE WILL LOAD IN THE DATA, +# BUT WE DONT NEED IT. THE CDLPARSE PARAM ROUTINE +# IS JUST USED TO GET THE CORRECT DIMENSIONS. THUS WE +# CAN JUST POINT TO THE DEFAULT CDL FILE IN VERSION CONTROL +# +# ------------------------------------------------------------- + + +default_file_relpath = '../../parameter_files/fates_params_default.cdl' + +dims = CDLParseDims(default_file_relpath) + +parms = {} +for elem in var_list: + parms[elem.var_sym] = CDLParseParam(default_file_relpath,cdl_param_type(elem.var_name,True),dims) + print('Finished loading PFT parameters') + + + +f = open("f90src/UnitWrapMod.F90_in", "r") +contents = f.readlines() +f.close() + +# ADD ARGUMENTS TO EDPFTVARCONALLOC +# --------------------------------- + +for i,str in enumerate(contents): + if 'ARGUMENT_IN1' in str: + index0=i + +str='' +icount=0 +for key, value in dims.iteritems(): + print('{}'.format(key)) + if(icount==0): + str+=key + else: + str+=(', & \n '+key) + icount+=1 + +strsplit = contents[index0].split('ARGUMENT_IN1') +strreplace = strsplit[0]+str+strsplit[1] + +contents[index0] = strreplace + + +for i,str in enumerate(contents): + if 'ARGUMENT_DEF1' in str: + index0=i + +str='' +for key, value in dims.iteritems(): + str+=(' integer,intent(in) :: '+key+'\n') + + +contents[index0] = str + + + + + +# Identify where we define the variables, and insert the variable definitions + +for i,str in enumerate(contents): + if 'VARIABLE-DEFINITIONS-HERE' in str: + index0=i + +# Identify where we do the pointer assignments, and insert the pointer assignments + + +for i,str in enumerate(contents): + if 'POINTER-SPECIFICATION-HERE' in str: + index0=i + +index=index0+2 +for symbol, var in parms.iteritems(): + + # Generate the dimension names + + dim_alloc_str='' + icount=0 + for dimname in reversed(var.dim_namelist): + if(icount==0): + dim_alloc_str+=dimname + else: + dim_alloc_str+=(','+dimname) + icount+=1 + + + if(var.ndims==1): + ins_l1='\t allocate(prt_params%{}({}))\n'.format(symbol,dim_alloc_str) + ins_l2='\t prt_params%{}(:) = fates_unset_r8\n'.format(symbol) + ins_l3='\t iv1 = iv1 + 1\n' + ins_l4='\t prt_params_ptr%var1d(iv1)%var_name = "{}"\n'.format(var.symbol) + ins_l5='\t prt_params_ptr%var1d(iv1)%var_rp => prt_params%{}\n'.format(symbol) + ins_l6='\t prt_params_ptr%var1d(iv1)%vtype = 1\n' + ins_l7='\n' + elif(var.ndims==2): + ins_l1='\t allocate(prt_params%{}({}))\n'.format(symbol,dim_alloc_str) + ins_l2='\t prt_params%{}(:,:) = fates_unset_r8\n'.format(symbol) + ins_l3='\t iv2 = iv2 + 1\n' + ins_l4='\t prt_params_ptr%var2d(iv2)%var_name = "{}"\n'.format(var.symbol) + ins_l5='\t prt_params_ptr%var2d(iv2)%var_rp => prt_params%{}\n'.format(symbol) + ins_l6='\t prt_params_ptr%var2d(iv2)%vtype = 1\n' + ins_l7='\n' + else: + print('Auto-generating FORTRAN parameter code does not handle >2D') + print(symbol) + print(var.ndims) + exit(2) + + contents.insert(index,ins_l1) + contents.insert(index+1,ins_l2) + contents.insert(index+2,ins_l3) + contents.insert(index+3,ins_l4) + contents.insert(index+4,ins_l5) + contents.insert(index+5,ins_l6) + contents.insert(index+6,ins_l7) + index=index+7 + + +f = open("f90src/UnitWrapMod.F90", "w+") +contents = "".join(contents) +f.write(contents) +f.close() diff --git a/functional_unit_testing/parteh/PartehDriver.py b/functional_unit_testing/parteh/PartehDriver.py index c567039696..88ca296255 100644 --- a/functional_unit_testing/parteh/PartehDriver.py +++ b/functional_unit_testing/parteh/PartehDriver.py @@ -25,13 +25,13 @@ #mpl.use('Agg') import matplotlib.pyplot as plt from datetime import datetime -#from matplotlib.backends.backend_pdf import PdfPages +import argparse import platform import numpy as np import os import sys import getopt -import code # For development: code.interact(local=locals()) +import code # For development: code.interact(local=dict(globals(), **locals())) import time import imp import ctypes @@ -42,25 +42,50 @@ 'py_modules/PartehInterpretParameters.py') PartehTypes = imp.load_source('PartehTypes', 'py_modules/PartehTypes.py') SyntheticBoundaries = imp.load_source('SyntheticBoundaries','py_modules/SyntheticBoundaries.py') +CDLParse = imp.load_source('CDLParse','py_modules/CDLParse.py') +F90ParamParse = imp.load_source('F90ParamParse','py_modules/F90ParamParse.py') from PartehInterpretParameters import load_xml +from CDLParse import CDLParseDims, CDLParseParam, cdl_param_type +from F90ParamParse import f90_param_type, GetParamsInFile, GetPFTParmFileSymbols, MakeListUnique -f90_fates_wrap_obj_name = 'bld/FatesWrapMod.o' f90_fates_integrators_obj_name = 'bld/FatesIntegratorsMod.o' +f90_fates_parteh_params_obj_name = 'bld/PRTParametersMod.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_unitwrap_obj_name = 'bld/UnitWrapMod.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 +# ----------------------------------------------------------------------------------- +# +# 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_integrators_obj = ctypes.CDLL(f90_fates_integrators_obj_name,mode=ctypes.RTLD_GLOBAL) +f90_fates_parteh_params_obj = ctypes.CDLL(f90_fates_parteh_params_obj_name,mode=ctypes.RTLD_GLOBAL) +f90_fates_unitwrap_obj = ctypes.CDLL(f90_fates_unitwrap_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) + + -## The name of the xml file containing site data (should not change) -xml_file = '' # ======================================================================================== @@ -70,73 +95,90 @@ # ======================================================================================== -def main(argv): +def main(): # 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("The PARTEH driver must be run with python 2.7") print(" with tertiary version >=15.") print(" your version is {}".format(version)) print(" exiting...") sys.exit(2) + parser = argparse.ArgumentParser(description='Parse command line arguments to this script.') + parser.add_argument('--xml-file', dest='xml_file', type=str, \ + help="The path to the XML file controling this simulation.",required=True) + args = parser.parse_args() - # 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() + xml_file = args.xml_file # 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 - # - # ----------------------------------------------------------------------------------- + [time_control, fates_cdl_file, driver_params, boundary_method,use_pfts] = load_xml(xml_file) + + num_plants = len(use_pfts) - # 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) + + # ------------------------------------------------------------------------------------- + # Check through the fortran Code we are coupling with, determine the list of parameters + # that we need. + # ------------------------------------------------------------------------------------- + + var_list = GetParamsInFile('../../parteh/PRTParametersMod.F90') + + + # Now look through EDPftvarcon.F90 to determine the variable name in file + # that is associated with the variable pointer + + var_list = GetPFTParmFileSymbols(var_list,'../../parteh/PRTParamsFATESMod.F90') - # Initialize the PARTEH instance - iret=f90_fates_partehwrap_obj.__fatespartehwrapmod_MOD_spmappyset() #byref(c_int(parameters.prt_model))) + + # This variable is not added to the list we send to fortran, this + # is only for the initial condition on the python side + var_list.append(f90_param_type('hgt_min','fates_recruit_hgt_min',False)) + + + + # ------------------------------------------------------------- + # We can now cross reference our list of parameters against + # the parameter file. This will create a new list of parameters + # however in the form of a dictionary. This dictionary of + # entries is accessible by its symbol name, and will also + # read in and store the actual parameter values from the file. + # ------------------------------------------------------------- + + dims = CDLParseDims(fates_cdl_file) + + fates_params = {} + for elem in var_list: + fates_params[elem.var_sym] = CDLParseParam(fates_cdl_file,cdl_param_type(elem.var_name,elem.in_f90),dims) + print('Finished loading PFT parameters') + + + num_pfts = dims['fates_pft'] + num_organs = dims['fates_prt_organs'] + + # Initialize the PARTEH instance + iret=f90_fates_partehwrap_obj.__fatespartehwrapmod_MOD_spmappyset() + # 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))) + + WrapPFTAllocArbitrary([val for key,val in dims.iteritems()]) + # Set the phenology type phen_type = [] - for pft_idx,pft_obj in enumerate(parameters.parteh_pfts): + for iplnt in range(num_plants): - 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]) + ipft = use_pfts[iplnt] + evergreen = np.int(fates_params['evergreen'].data[ipft]) + cold_deciduous = np.int(fates_params['season_decid'].data[ipft]) + stress_deciduous = np.int(fates_params['stress_decid'].data[ipft]) if(evergreen==1): if(cold_deciduous==1): print("Poorly defined phenology mode 0") @@ -166,46 +208,59 @@ def main(argv): exit(2) + # ------------------------------------------------------------------------- + # Loop through all parameters in the "fates_params" + # dictionary, send their data to the FORTRAN code + # ------------------------------------------------------------------------ - # 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): + # Loop through parameters + for parm_key, parm_obj in fates_params.iteritems(): - 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)) + # Loop through their dimensions + # 2D case + if(parm_obj.in_f90): + if(parm_obj.ndims>1): + for idx0 in range(parm_obj.dim_sizelist[0]): + for idx1 in range(parm_obj.dim_sizelist[1]): + iret = f90_fates_unitwrap_obj.__prtparamsgeneric_MOD_prtparamspyset(byref(c_double(parm_obj.data[idx0,idx1])), \ + byref(c_int(0)), \ + byref(c_int(idx1+1)), \ + byref(c_int(idx0+1)), \ + c_char_p(parm_obj.symbol), \ + c_long(len(parm_obj.symbol ))) - # 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()))) - + idx1=0 + for idx0 in range(parm_obj.dim_sizelist[0]): + iret = f90_fates_unitwrap_obj.__prtparamsgeneric_MOD_prtparamspyset(byref(c_double(parm_obj.data[idx0])), \ + byref(c_int(0)), \ + byref(c_int(idx0+1)), \ + byref(c_int(idx1+1)), \ + c_char_p(parm_obj.symbol), \ + c_long(len(parm_obj.symbol ))) + + + # Allocate the cohort array (We create on cohort per PFT) - iret=f90_fates_cohortwrap_obj.__fatescohortwrapmod_MOD_cohortinitalloc(byref(c_int(parameters.num_pfts))) + iret=f90_fates_cohortwrap_obj.__fatescohortwrapmod_MOD_cohortinitalloc(byref(c_int(num_plants))) - 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))) + + for iplnt in range(num_plants): + ipft = use_pfts[iplnt] + hgt_min = np.float(fates_params['hgt_min'].data[ipft]) + init_canopy_trim = 1.0 + iret=f90_fates_cohortwrap_obj.__fatescohortwrapmod_MOD_cohortmodeset(byref(c_int(ipft)), \ + byref(c_int(int(driver_params['parteh_model'].param_vals[ipft])))) + iret=f90_fates_cohortwrap_obj.__fatescohortwrapmod_MOD_cohortpyset(byref(c_int(ipft)), \ + byref(c_double(hgt_min)), \ + byref(c_double(init_canopy_trim))) + + # Initialize diagnostics - diagnostics = [] - for pft_idx, pft_obj in enumerate(parameters.parteh_pfts): + diagnostics = [] + for iplnt in range(num_plants): + ipft = use_pfts[iplnt] diagnostics.append(PartehTypes.diagnostics_type()) @@ -213,8 +268,8 @@ def main(argv): # Time Initialization # -------------------------------------------------------------------------------- time_control.ResetTime() - - # -------------------------------------------------------------------------------- + + # -------------------------------------------------------------------------------- # Time integration (outer) loop # -------------------------------------------------------------------------------- while (time_control.sim_complete != True): @@ -224,9 +279,9 @@ def main(argv): # 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): + for iplnt in range(num_plants): - + ipft = use_pfts[iplnt] # Generate the boundary condition for the current time-step # --------------------------------------------------------------------------- @@ -277,14 +332,14 @@ def main(argv): 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)), \ + iret=f90_fates_cohortwrap_obj.__fatescohortwrapmod_MOD_wrapqueryvars(byref(c_int(ipft)), \ byref(leaf_area), \ byref(crown_area), \ byref(agb), \ byref(store_c),\ byref(target_leaf_c)) - + doy = time_control.datetime.astype(object).timetuple().tm_yday @@ -293,45 +348,44 @@ def main(argv): # 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]) + store_c.value, phen_type[iplnt]) + + - if(parameters.boundary_method=="DailyCFromCArea"): - - presc_npp_p1 = parameters.boundary_pfts[pft_idx].param_dic['fates_prescribed_npp_p1'] + if(boundary_method=="DailyCFromCArea"): + + presc_npp_p1 = driver_params['fates_prescribed_npp_p1'].param_vals[iplnt] net_daily_c = SyntheticBoundaries.DailyCFromCArea(presc_npp_p1, \ crown_area.value, \ - phen_type[pft_idx], \ + phen_type[iplnt], \ 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'] + elif(boundary_method=="DailyCNPFromCArea"): + + presc_npp_p1 = driver_params['fates_prescribed_npp_p1'].param_vals[iplnt] + presc_nflux_p1 = driver_params['fates_prescribed_nflux_p1'].param_vals[iplnt] + presc_pflux_p1 = driver_params['fates_prescribed_pflux_p1'].param_vals[iplnt] 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], \ + phen_type[iplnt], \ leaf_status) r_maint_demand = 0.0 - elif(parameters.boundary_method=="DailyCNPFromStorageSinWaveNoMaint"): + elif(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'] - - - + presc_npp_amp = driver_params['fates_prescribed_npp_amp'].param_vals[iplnt] + presc_npp_p1 = driver_params['fates_prescribed_npp_p1'].param_vals[iplnt] + presc_nflux_p1 = driver_params['fates_prescribed_nflux_p1'].param_vals[iplnt] + presc_pflux_p1 = driver_params['fates_prescribed_pflux_p1'].param_vals[iplnt] net_daily_c, net_daily_n, net_daily_p = SyntheticBoundaries.DailyCNPFromStorageSinWave(doy,\ store_c.value,\ @@ -340,23 +394,23 @@ def main(argv): presc_pflux_p1, \ crown_area.value, \ presc_npp_amp, \ - phen_type[pft_idx], \ + phen_type[iplnt], \ leaf_status ) r_maint_demand = 0.0 else: print("An unknown boundary method was specified\n") - print("type: {} ? ... quitting.".format(parameters.boundary_method)) + print("type: {} ? ... quitting.".format(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)), \ + iret=f90_fates_cohortwrap_obj.__fatescohortwrapmod_MOD_wrapdailyprt(byref(c_int(ipft)), \ byref(c_double(net_daily_c)), \ byref(c_double(init_canopy_trim)), \ byref(c_double(flush_c)), \ @@ -365,11 +419,11 @@ def main(argv): 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)), \ + iret=f90_fates_cohortwrap_obj.__fatescohortwrapmod_MOD_wrapquerydiagnostics(byref(c_int(ipft)), \ byref(dbh), \ byref(leaf_c), \ byref(fnrt_c), \ @@ -411,51 +465,51 @@ def main(argv): 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) + diagnostics[iplnt].dates.append(time_control.datetime.astype(datetime)) + diagnostics[iplnt].dbh.append(dbh.value) + diagnostics[iplnt].leaf_c.append(leaf_c.value) + diagnostics[iplnt].fnrt_c.append(fnrt_c.value) + diagnostics[iplnt].sapw_c.append(sapw_c.value) + diagnostics[iplnt].store_c.append(store_c.value) + diagnostics[iplnt].struct_c.append(struct_c.value) + diagnostics[iplnt].repro_c.append(repro_c.value) + diagnostics[iplnt].leaf_cturn.append(leaf_cturn.value) + diagnostics[iplnt].fnrt_cturn.append(fnrt_cturn.value) + diagnostics[iplnt].sapw_cturn.append(sapw_cturn.value) + diagnostics[iplnt].store_cturn.append(store_cturn.value) + diagnostics[iplnt].struct_cturn.append(struct_cturn.value) + diagnostics[iplnt].dailyc.append(net_daily_c) + diagnostics[iplnt].crown_area.append(crown_area.value) + + diagnostics[iplnt].growth_resp.append(growth_resp.value) + + diagnostics[iplnt].leaf_n.append(leaf_n.value) + diagnostics[iplnt].fnrt_n.append(fnrt_n.value) + diagnostics[iplnt].sapw_n.append(sapw_n.value) + diagnostics[iplnt].store_n.append(store_n.value) + diagnostics[iplnt].struct_n.append(struct_n.value) + diagnostics[iplnt].repro_n.append(repro_n.value) + diagnostics[iplnt].leaf_nturn.append(leaf_nturn.value) + diagnostics[iplnt].fnrt_nturn.append(fnrt_nturn.value) + diagnostics[iplnt].sapw_nturn.append(sapw_nturn.value) + diagnostics[iplnt].store_nturn.append(store_nturn.value) + diagnostics[iplnt].struct_nturn.append(struct_nturn.value) + + diagnostics[iplnt].leaf_p.append(leaf_p.value) + diagnostics[iplnt].fnrt_p.append(fnrt_p.value) + diagnostics[iplnt].sapw_p.append(sapw_p.value) + diagnostics[iplnt].store_p.append(store_p.value) + diagnostics[iplnt].struct_p.append(struct_p.value) + diagnostics[iplnt].repro_p.append(repro_p.value) + diagnostics[iplnt].leaf_pturn.append(leaf_pturn.value) + diagnostics[iplnt].fnrt_pturn.append(fnrt_pturn.value) + diagnostics[iplnt].sapw_pturn.append(sapw_pturn.value) + diagnostics[iplnt].store_pturn.append(store_pturn.value) + diagnostics[iplnt].struct_pturn.append(struct_pturn.value) + + diagnostics[iplnt].root_c_exudate.append(root_c_exudate.value) + diagnostics[iplnt].root_n_exudate.append(root_n_exudate.value) + diagnostics[iplnt].root_p_exudate.append(root_p_exudate.value) # We don't have a fancy time integrator so we simply update with @@ -481,59 +535,60 @@ def main(argv): 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) + for iplnt in range(num_plants): + ipft = use_pfts[iplnt] + ax1.plot_date(diagnostics[iplnt].dates,diagnostics[iplnt].struct_c,linestyles[iplnt],label='{}'.format(iplnt)) 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]) + for iplnt in range(num_plants): + ax2.plot_date(diagnostics[iplnt].dates,diagnostics[iplnt].leaf_c,linestyles[iplnt]) 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]) + for iplnt in range(num_plants): + ax3.plot_date(diagnostics[iplnt].dates,diagnostics[iplnt].fnrt_c,linestyles[iplnt]) 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]) + for iplnt in range(num_plants): + ax4.plot_date(diagnostics[iplnt].dates,diagnostics[iplnt].sapw_c,linestyles[iplnt]) 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]) + for iplnt in range(num_plants): + ax5.plot_date(diagnostics[iplnt].dates,diagnostics[iplnt].store_c,linestyles[iplnt]) 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]) + for iplnt in range(num_plants): + ax6.plot_date(diagnostics[iplnt].dates,diagnostics[iplnt].repro_c,linestyles[iplnt]) 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]) + for iplnt in range(num_plants): + ax7.plot_date(diagnostics[iplnt].dates,np.cumsum(diagnostics[iplnt].root_c_exudate),linestyles[iplnt]) 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]) + for iplnt in range(num_plants): + ax8.plot_date(diagnostics[iplnt].dates,np.cumsum(diagnostics[iplnt].growth_resp),linestyles[iplnt]) ax8.set_title('Integrated\n Growth\n Respiration') ax8.set_xlabel('Year') ax8.grid(True) - + plt.tight_layout() @@ -542,74 +597,75 @@ def main(argv): # --------------------------------------------------------------------------------- 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) + for iplnt in range(num_plants): + ipft = use_pfts[iplnt] + ax1.plot_date(diagnostics[iplnt].dates,diagnostics[iplnt].dbh,linestyles[iplnt],label='{}'.format(iplnt)) 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]) + for iplnt in range(num_plants): + ax2.plot_date(diagnostics[iplnt].dates,diagnostics[iplnt].crown_area,linestyles[iplnt]) 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)) + for iplnt in range(num_plants): + ax3.plot(diagnostics[iplnt].dbh,1000.0*np.array(diagnostics[iplnt].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) + for iplnt in range(num_plants): + ax4.plot(diagnostics[iplnt].dbh,diagnostics[iplnt].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) - \ + for iplnt in range(num_plants): + ipft = use_pfts[iplnt] + total_plant_carbon0 = np.array(diagnostics[iplnt].struct_c[0]) + \ + np.array(diagnostics[iplnt].leaf_c[0]) + \ + np.array(diagnostics[iplnt].fnrt_c[0]) + \ + np.array(diagnostics[iplnt].sapw_c[0]) + \ + np.array(diagnostics[iplnt].store_c[0]) + \ + np.array(diagnostics[iplnt].repro_c[0]) + + total_plant_carbon = np.array(diagnostics[iplnt].struct_c) + \ + np.array(diagnostics[iplnt].leaf_c) + \ + np.array(diagnostics[iplnt].fnrt_c) + \ + np.array(diagnostics[iplnt].sapw_c) + \ + np.array(diagnostics[iplnt].store_c) + \ + np.array(diagnostics[iplnt].repro_c) + + integrated_plant_turnover = np.cumsum(diagnostics[iplnt].struct_cturn) + \ + np.cumsum(diagnostics[iplnt].leaf_cturn) + \ + np.cumsum(diagnostics[iplnt].fnrt_cturn) + \ + np.cumsum(diagnostics[iplnt].sapw_cturn) + \ + np.cumsum(diagnostics[iplnt].store_cturn) + + + plt.plot(np.cumsum(diagnostics[iplnt].dailyc), \ + (np.cumsum(diagnostics[iplnt].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) @@ -617,85 +673,135 @@ def main(argv): # 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) + for iplnt in range(num_plants): + ipft = use_pfts[iplnt] + plt.plot_date(diagnostics[iplnt].dates,diagnostics[iplnt].dailyc,linestyles[iplnt],label='{}'.format(iplnt)) 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), \ + for iplnt in range(num_plants): + ipft = use_pfts[iplnt] + figs[iplnt], (ax1, ax2, ax3) = plt.subplots(1, 3) + + figs[iplnt].set_size_inches(8, 4) + ax1.stackplot(np.cumsum(diagnostics[iplnt].dailyc), \ + np.array(diagnostics[iplnt].struct_c)+np.cumsum(diagnostics[iplnt].struct_cturn), \ + np.array(diagnostics[iplnt].leaf_c)+np.cumsum(diagnostics[iplnt].leaf_cturn), \ + np.array(diagnostics[iplnt].fnrt_c)+np.cumsum(diagnostics[iplnt].fnrt_cturn), \ + np.array(diagnostics[iplnt].sapw_c)+np.cumsum(diagnostics[iplnt].sapw_cturn), \ + np.array(diagnostics[iplnt].store_c)+np.cumsum(diagnostics[iplnt].store_cturn), \ + np.array(diagnostics[iplnt].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), \ + ax2.stackplot(np.cumsum(diagnostics[iplnt].dailyc), \ + np.cumsum(diagnostics[iplnt].struct_cturn), \ + np.cumsum(diagnostics[iplnt].leaf_cturn), \ + np.cumsum(diagnostics[iplnt].fnrt_cturn), \ + np.cumsum(diagnostics[iplnt].sapw_cturn), \ + np.cumsum(diagnostics[iplnt].store_cturn), \ + np.array(diagnostics[iplnt].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_leaf = np.array(diagnostics[iplnt].leaf_c[1:]) - \ + np.array(diagnostics[iplnt].leaf_c[0:-1]) + \ + np.array(diagnostics[iplnt].leaf_cturn[1:]) + npp_fnrt = np.array(diagnostics[iplnt].fnrt_c[1:]) - \ + np.array(diagnostics[iplnt].fnrt_c[0:-1]) + \ + np.array(diagnostics[iplnt].fnrt_cturn[1:]) + npp_sapw = np.array(diagnostics[iplnt].sapw_c[1:]) - \ + np.array(diagnostics[iplnt].sapw_c[0:-1]) + \ + np.array(diagnostics[iplnt].sapw_cturn[1:]) + npp_store = np.array(diagnostics[iplnt].store_c[1:]) - \ + np.array(diagnostics[iplnt].store_c[0:-1]) + \ + np.array(diagnostics[iplnt].store_cturn[1:]) + npp_struct = np.array(diagnostics[iplnt].struct_c[1:]) - \ + np.array(diagnostics[iplnt].struct_c[0:-1]) + \ + np.array(diagnostics[iplnt].struct_cturn[1:]) + npp_repro = np.array(diagnostics[iplnt].repro_c[1:]) - \ + np.array(diagnostics[iplnt].repro_c[0:-1]) + + ax3.stackplot(np.cumsum(diagnostics[iplnt].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.figtext(0.1,0.05,"Plant: {}".format(iplnt),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 WrapPFTAllocArbitrary(*args): + + nargs = len(args[0]) + + if(nargs==1): + iret=f90_fates_unitwrap_obj.__prtparamsgeneric_MOD_prtparamsalloc(byref(c_int(args[0][0]))) + elif(nargs==2): + iret=f90_fates_unitwrap_obj.__prtparamsgeneric_MOD_prtparamsalloc(byref(c_int(args[0][0])), byref(c_int(args[0][1]))) + elif(nargs==3): + iret=f90_fates_unitwrap_obj.__prtparamsgeneric_MOD_prtparamsalloc(byref(c_int(args[0][0])), byref(c_int(args[0][1])), byref(c_int(args[0][2]))) + elif(nargs==4): + iret=f90_fates_unitwrap_obj.__prtparamsgeneric_MOD_prtparamsalloc(byref(c_int(args[0][0])), byref(c_int(args[0][1])), byref(c_int(args[0][2])), \ + byref(c_int(args[0][3]))) + elif(nargs==5): + iret=f90_fates_unitwrap_obj.__prtparamsgeneric_MOD_prtparamsalloc(byref(c_int(args[0][0])), byref(c_int(args[0][1])), byref(c_int(args[0][2])), \ + byref(c_int(args[0][3])), byref(c_int(args[0][4]))) + elif(nargs==6): + iret=f90_fates_unitwrap_obj.__prtparamsgeneric_MOD_prtparamsalloc(byref(c_int(args[0][0])), byref(c_int(args[0][1])), byref(c_int(args[0][2])), \ + byref(c_int(args[0][3])), byref(c_int(args[0][4])), byref(c_int(args[0][5]))) + elif(nargs==7): + iret=f90_fates_unitwrap_obj.__prtparamsgeneric_MOD_prtparamsalloc(byref(c_int(args[0][0])), byref(c_int(args[0][1])), byref(c_int(args[0][2])), \ + byref(c_int(args[0][3])), byref(c_int(args[0][4])), byref(c_int(args[0][5])), \ + byref(c_int(args[0][6]))) + elif(nargs==8): + iret=f90_fates_unitwrap_obj.__prtparamsgeneric_MOD_prtparamsalloc(byref(c_int(args[0][0])), byref(c_int(args[0][1])), byref(c_int(args[0][2])), \ + byref(c_int(args[0][3])), byref(c_int(args[0][4])), byref(c_int(args[0][5])), \ + byref(c_int(args[0][6])), byref(c_int(args[0][7]))) + + elif(nargs==9): + iret=f90_fates_unitwrap_obj.__prtparamsgeneric_MOD_prtparamsalloc(byref(c_int(args[0][0])), byref(c_int(args[0][1])), byref(c_int(args[0][2])), \ + byref(c_int(args[0][3])), byref(c_int(args[0][4])), byref(c_int(args[0][5])), \ + byref(c_int(args[0][6])), byref(c_int(args[0][7])), byref(c_int(args[0][8]))) + elif(nargs==10): + iret=f90_fates_unitwrap_obj.__prtparamsgeneric_MOD_prtparamsalloc(byref(c_int(args[0][0])), byref(c_int(args[0][1])), byref(c_int(args[0][2])), \ + byref(c_int(args[0][3])), byref(c_int(args[0][4])), byref(c_int(args[0][5])), \ + byref(c_int(args[0][6])), byref(c_int(args[0][7])), byref(c_int(args[0][8])), \ + byref(c_int(args[0][9]))) + elif(nargs==11): + iret=f90_fates_unitwrap_obj.__prtparamsgeneric_MOD_prtparamsalloc(byref(c_int(args[0][0])), byref(c_int(args[0][1])), byref(c_int(args[0][2])), \ + byref(c_int(args[0][3])), byref(c_int(args[0][4])), byref(c_int(args[0][5])), \ + byref(c_int(args[0][6])), byref(c_int(args[0][7])), byref(c_int(args[0][8])), \ + byref(c_int(args[0][9])), byref(c_int(args[0][10]))) + + + else: + print('So many dimensions...') + print('add more clauses') + exit(2) + # ======================================================================================= @@ -704,7 +810,7 @@ def usage(): print('') print('=======================================================================') print('') - print(' python PartehDriver.py --help --xmlfile=') + print(' python PartehDriver.py --help --cdlfile=') print('') print(' This is a driver script for PARTEH') print(' (Plant Allocation and Reactive Transport Extensible Hypotheses)') @@ -721,50 +827,11 @@ def usage(): 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) + main() diff --git a/functional_unit_testing/parteh/build_fortran_objects.sh b/functional_unit_testing/parteh/build_fortran_objects.sh index 544fec9bbd..4c8aa7bf4e 100755 --- a/functional_unit_testing/parteh/build_fortran_objects.sh +++ b/functional_unit_testing/parteh/build_fortran_objects.sh @@ -2,48 +2,89 @@ # Path to FATES src -FATES_SRC=../../ - -CNP_SRC=/home/rgknox/SyncLRC/PARTEH/FModules/ +FC='gfortran' F_OPTS="-shared -fPIC -g -ffpe-trap=zero,overflow,underflow -fbacktrace -fbounds-check" +#F_OPTS="-shared -fPIC -O" + 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 +# First copy over the FatesConstants file, but change the types of the fates_r8 and fates_int + +old_fates_r8_str=`grep -e integer ../../main/FatesConstantsMod.F90 | grep fates_r8 | sed 's/^[ \t]*//;s/[ \t]*$//'` +new_fates_r8_str='use iso_c_binding, only: fates_r8 => c_double' + +old_fates_int_str=`grep -e integer ../../main/FatesConstantsMod.F90 | grep fates_int | sed 's/^[ \t]*//;s/[ \t]*$//'` +new_fates_int_str='use iso_c_binding, only: fates_int => c_int' + +# Add the new lines (need position change, don't swap) + +sed "/implicit none/i $new_fates_r8_str" ../../main/FatesConstantsMod.F90 > f90src/FatesConstantsMod.F90 +sed -i "/implicit none/i $new_fates_int_str" f90src/FatesConstantsMod.F90 +sed -i "/private /i public :: fates_r8" f90src/FatesConstantsMod.F90 +sed -i "/private /i public :: fates_int" f90src/FatesConstantsMod.F90 + +# Delete the old lines + +sed -i "/$old_fates_r8_str/d" f90src/FatesConstantsMod.F90 +sed -i "/$old_fates_int_str/d" f90src/FatesConstantsMod.F90 + + +# This re-writes the wrapper so that it uses all the correct parameters +# in FatesAllometryMod.F90 +python AutoGenVarCon.py + + +# Procedure for auto-generating AllomUnitWrap +# 1) scan FatesAllometry and create list of EDPftVarcon_inst variables +# 2) scan EDpftVarcon and get the name of the in-file parameter names associated +# with these variables -# 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 + +# Build the new file with constants + +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/FatesConstantsMod.o f90src/FatesConstantsMod.F90 + + +# The Parameter Definitions +${FC} ${F_OPTS} $MOD_FLAG bld/ -I bld/ -o bld/PRTParametersMod.o ../../parteh/PRTParametersMod.F90 + + + +${FC} ${F_OPTS} -I bld/ ${MOD_FLAG} bld/ -o bld/UnitWrapMod.o f90src/UnitWrapMod.F90 + + + + +# Generic Integration routines (all native types except defined constants) +gfortran $F_OPTS $MOD_FLAG bld/ -I bld/ -o bld/FatesIntegratorsMod.o ../../main/FatesIntegratorsMod.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 +${FC} ${F_OPTS} $MOD_FLAG bld/ -I bld/ -o bld/FatesAllometryMod.o ../../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 +${FC} ${F_OPTS} $MOD_FLAG bld/ -I bld/ -o bld/PRTGenericMod.o ../../parteh/PRTGenericMod.F90 # Loss Fluxes and phenology -gfortran $F_OPTS $MOD_FLAG bld/ -I bld/ -o bld/PRTLossFluxesMod.o ${FATES_SRC}/parteh/PRTLossFluxesMod.F90 +${FC} ${F_OPTS} $MOD_FLAG bld/ -I bld/ -o bld/PRTLossFluxesMod.o ../../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 +${FC} ${F_OPTS} $MOD_FLAG bld/ -I bld/ -o bld/PRTAllometricCarbonMod.o ../../parteh/PRTAllometricCarbonMod.F90 # The CNP allometric target model -gfortran $F_OPTS $MOD_FLAG bld/ -I bld/ -o bld/PRTAllometricCNPMod.o ${CNP_SRC}/PRTAllometricCNPMod.F90 +${FC} ${F_OPTS} $MOD_FLAG bld/ -I bld/ -o bld/PRTAllometricCNPMod.o ../../parteh/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 +${FC} ${F_OPTS} $MOD_FLAG bld/ -I bld/ -o bld/FatesPARTEHWrapMod.o f90src/FatesPARTEHWrapMod.F90 # The cohort instances and initialization -gfortran $F_OPTS $MOD_FLAG bld/ -I bld/ -o bld/FatesCohortWrapMod.o f_wrapper_modules/FatesCohortWrapMod.F90 +${FC} ${F_OPTS} $MOD_FLAG bld/ -I bld/ -o bld/FatesCohortWrapMod.o f90src/FatesCohortWrapMod.F90 diff --git a/functional_unit_testing/parteh/f_wrapper_modules/FatesCohortWrapMod.F90 b/functional_unit_testing/parteh/f90src/FatesCohortWrapMod.F90 similarity index 72% rename from functional_unit_testing/parteh/f_wrapper_modules/FatesCohortWrapMod.F90 rename to functional_unit_testing/parteh/f90src/FatesCohortWrapMod.F90 index 78b9bfa271..75575d3df9 100644 --- a/functional_unit_testing/parteh/f_wrapper_modules/FatesCohortWrapMod.F90 +++ b/functional_unit_testing/parteh/f90src/FatesCohortWrapMod.F90 @@ -19,9 +19,7 @@ module FatesCohortWrapMod use FatesAllometryMod, only : h2d_allom use FatesAllometryMod, only : tree_lai use FatesAllometryMod, only : carea_allom - - use EDPftvarcon, only : EDPftvarcon_inst - + use PRTParametersMod, only : prt_params use PRTGenericMod, only : prt_vartypes use PRTGenericMod, only : leaf_organ use PRTGenericMod, only : all_carbon_elements @@ -37,6 +35,8 @@ module FatesCohortWrapMod use PRTGenericMod, only : carbon12_element use PRTGenericMod, only : SetState use PRTGenericMod, only : prt_global + use PRTGenericMod, only : prt_carbon_allom_hyp + use PRTGenericMod, only : prt_cnp_flex_allom_hyp use PRTAllometricCarbonMod, only : callom_prt_vartypes use PRTAllometricCarbonMod, only : ac_bc_inout_id_netdc @@ -56,12 +56,14 @@ module FatesCohortWrapMod 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_in_id_leafon + + use PRTAllometricCNPMod, only : acnp_bc_out_id_cefflux + use PRTAllometricCNPMod, only : acnp_bc_out_id_nefflux + use PRTAllometricCNPMod, only : acnp_bc_out_id_pefflux use PRTAllometricCNPMod, only : acnp_bc_out_id_growresp @@ -75,11 +77,10 @@ module FatesCohortWrapMod implicit none private ! Modules are private by default - + type, public :: 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 @@ -87,6 +88,7 @@ module FatesCohortWrapMod real(r8) :: dhdt ! time derivative of height : m/year real(r8) :: ddbhdt ! time derivative of dbh : cm/year + real(r8) :: vcmax25top real(r8) :: daily_carbon_gain ! real(r8) :: daily_nitrogen_gain ! real(r8) :: daily_phosphorus_gain ! @@ -94,10 +96,12 @@ module FatesCohortWrapMod 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) :: phosphorus_root_exudate ! - + real(r8) :: carbon_root_efflux + real(r8) :: nitrogen_root_efflux + real(r8) :: phosphorus_root_efflux + integer :: parteh_mode ! THIS IS NOT IN FATES + ! WE MAKE THIS A PER-TREE + ! ATTRIBUTE HERE FOR INTERCOMPARISON ! Multi-species, multi-pool Reactive Transport class(prt_vartypes), pointer :: prt @@ -114,6 +118,7 @@ module FatesCohortWrapMod ! Make necessary procedures public public :: CohortInitAlloc public :: CohortPySet + public :: CohortModeSet public :: WrapDailyPRT public :: WrapQueryVars public :: WrapQueryDiagnostics @@ -129,34 +134,50 @@ subroutine CohortInitAlloc(numcohorts) 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%parteh_mode = -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_phosphorus_gain = -999.9_r8 + ccohort%daily_phosphorus_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%phosphorus_root_exudate = -999.9_r8 + ccohort%carbon_root_efflux = -999.9_r8 + ccohort%nitrogen_root_efflux = -999.9_r8 + ccohort%phosphorus_root_efflux = -999.9_r8 + ccohort%vcmax25top = -999.9_r8 end do return end subroutine CohortInitAlloc ! ===================================================================================== + + subroutine CohortModeSet(ipft,parteh_mode) + + integer(i4) :: ipft + integer(i4) :: parteh_mode + + + cohort_array(ipft)%parteh_mode = parteh_mode + + print*,"SET MODE ",parteh_mode," FOR PFT: ",ipft + + return + end subroutine CohortModeSet + + subroutine CohortPySet(ipft,hgt_min,canopy_trim) @@ -202,7 +223,6 @@ subroutine CohortPySet(ipft,hgt_min,canopy_trim) 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 @@ -232,14 +252,17 @@ subroutine CohortPySet(ipft,hgt_min,canopy_trim) repro_c = 0.0_r8 + ! ----------------------------------------------------- + ! THIS IS A COPY OF InitPRTObject + ! ----------------------------------------------------- - select case(ccohort%parteh_model) - case (1) + select case(ccohort%parteh_mode) + case (prt_carbon_allom_hyp) prt_global => prt_global_ac allocate(callom_prt) ccohort%prt => callom_prt - case(2) + case(prt_cnp_flex_allom_hyp) prt_global => prt_global_acnp allocate(cnpallom_prt) ccohort%prt => cnpallom_prt @@ -252,8 +275,8 @@ subroutine CohortPySet(ipft,hgt_min,canopy_trim) call ccohort%prt%InitPRTVartype() - select case(ccohort%parteh_model) - case (1) + select case(ccohort%parteh_mode) + case (prt_carbon_allom_hyp) call SetState(ccohort%prt,leaf_organ, carbon12_element, leaf_c) call SetState(ccohort%prt,fnrt_organ, carbon12_element, fnrt_c) @@ -268,23 +291,23 @@ subroutine CohortPySet(ipft,hgt_min,canopy_trim) 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) + case (prt_cnp_flex_allom_hyp) ! 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_n = leaf_c * prt_params%nitr_stoich_p1(ipft,leaf_organ) + fnrt_n = fnrt_c * prt_params%nitr_stoich_p1(ipft,fnrt_organ) + sapw_n = sapw_c * prt_params%nitr_stoich_p1(ipft,sapw_organ) + store_n = store_c * prt_params%nitr_stoich_p1(ipft,store_organ) + struct_n = struct_c * prt_params%nitr_stoich_p1(ipft,struct_organ) + repro_n = repro_c * prt_params%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) + leaf_p = leaf_c * prt_params%phos_stoich_p1(ipft,leaf_organ) + fnrt_p = fnrt_c * prt_params%phos_stoich_p1(ipft,fnrt_organ) + sapw_p = sapw_c * prt_params%phos_stoich_p1(ipft,sapw_organ) + store_p = store_c * prt_params%phos_stoich_p1(ipft,store_organ) + struct_p = struct_c * prt_params%phos_stoich_p1(ipft,struct_organ) + repro_p = repro_c * prt_params%phos_stoich_p1(ipft,repro_organ) ccohort%accum_r_maint_deficit = 0.0_r8 @@ -319,12 +342,12 @@ subroutine CohortPySet(ipft,hgt_min,canopy_trim) ! 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) + call ccohort%prt%RegisterBCIn(acnp_bc_in_id_leafon,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%phosphorus_root_exudate) + call ccohort%prt%RegisterBCOut(acnp_bc_out_id_cefflux,bc_rval = ccohort%carbon_root_efflux) + call ccohort%prt%RegisterBCOut(acnp_bc_out_id_nefflux,bc_rval = ccohort%nitrogen_root_efflux) + call ccohort%prt%RegisterBCOut(acnp_bc_out_id_pefflux,bc_rval = ccohort%phosphorus_root_efflux) call ccohort%prt%RegisterBCOut(acnp_bc_out_id_growresp,bc_rval = ccohort%daily_r_grow ) @@ -332,6 +355,7 @@ subroutine CohortPySet(ipft,hgt_min,canopy_trim) call ccohort%prt%CheckInitialConditions() + ccohort%vcmax25top = 50._r8 end subroutine CohortPySet @@ -353,7 +377,7 @@ subroutine WrapDailyPRT(ipft,daily_carbon_gain,canopy_trim,flush_c,drop_frac_c,l real(r8), intent(in), optional :: daily_r_maint_demand type(ed_cohort_type), pointer :: ccohort - + logical, parameter :: is_drought = .false. ccohort => cohort_array(ipft) @@ -367,24 +391,25 @@ subroutine WrapDailyPRT(ipft,daily_carbon_gain,canopy_trim,flush_c,drop_frac_c,l call PRTPhenologyFlush(ccohort%prt, ipft, leaf_organ, flush_c) - call PRTMaintTurnover(ccohort%prt, ipft) + call PRTMaintTurnover(ccohort%prt, ipft, is_drought) - select case(int(ccohort%parteh_model)) - case (1) + select case(ccohort%parteh_mode) + case (prt_carbon_allom_hyp) 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 + ccohort%carbon_root_efflux = 0.0_r8 + + case (prt_cnp_flex_allom_hyp) - case (2) prt_global => prt_global_acnp - ccohort%daily_carbon_gain = daily_carbon_gain - ccohort%daily_nitrogen_gain = daily_nitrogen_gain + ccohort%daily_carbon_gain = daily_carbon_gain + ccohort%daily_nitrogen_gain = daily_nitrogen_gain ccohort%daily_phosphorus_gain = daily_phosphorus_gain - ccohort%accum_r_maint_deficit = ccohort%accum_r_maint_deficit + & + ccohort%accum_r_maint_deficit = ccohort%accum_r_maint_deficit + & daily_r_maint_demand call ccohort%prt%DailyPRT() @@ -423,26 +448,27 @@ subroutine WrapQueryVars(ipft,leaf_area,crown_area,agb,store_c,target_leaf_c) 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] + real(r8), dimension(nclmax) :: canopy_lai integer, parameter :: cl1 = 1 ccohort => cohort_array(ipft) + canopy_lai(:) = 0._r8 - select case(int(ccohort%parteh_model)) - case (1) + select case(ccohort%parteh_mode) + case (prt_carbon_allom_hyp) prt_global => prt_global_ac - case (2) + case (prt_cnp_flex_allom_hyp) 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 ) + leaf_c = ccohort%prt%GetState(leaf_organ, carbon12_element ) + store_c = ccohort%prt%GetState(store_organ, carbon12_element ) call carea_allom(ccohort%dbh,nplant,site_spread,ipft,crown_area) - leaf_area = crown_area*tree_lai(leaf_c, ipft, crown_area, nplant, cl1, canopy_lai) + leaf_area = crown_area*tree_lai(leaf_c, ipft, crown_area, nplant, cl1, canopy_lai,ccohort%vcmax25top) call bagw_allom(ccohort%dbh,ipft,agb) @@ -461,7 +487,7 @@ subroutine WrapQueryDiagnostics(ipft, dbh, & 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, phosphorus_root_exudate, & + carbon_root_efflux, nitrogen_root_efflux, phosphorus_root_efflux, & growth_resp ) implicit none @@ -506,9 +532,9 @@ subroutine WrapQueryDiagnostics(ipft, dbh, & real(r8),intent(out) :: struct_pturn - real(r8),intent(out) :: carbon_root_exudate - real(r8),intent(out) :: nitrogen_root_exudate - real(r8),intent(out) :: phosphorus_root_exudate + real(r8),intent(out) :: carbon_root_efflux + real(r8),intent(out) :: nitrogen_root_efflux + real(r8),intent(out) :: phosphorus_root_efflux real(r8),intent(out) :: growth_resp real(r8),intent(out) :: crown_area @@ -518,61 +544,61 @@ subroutine WrapQueryDiagnostics(ipft, dbh, & ccohort => cohort_array(ipft) - select case(int(ccohort%parteh_model)) - case (1) + select case(ccohort%parteh_mode) + case (prt_carbon_allom_hyp ) prt_global => prt_global_ac - case (2) + case (prt_cnp_flex_allom_hyp) 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=phosphorus_element) - fnrt_p = ccohort%prt%GetState(organ_id=fnrt_organ, species_id=phosphorus_element) - sapw_p = ccohort%prt%GetState(organ_id=sapw_organ, species_id=phosphorus_element) - store_p = ccohort%prt%GetState(organ_id=store_organ, species_id=phosphorus_element) - struct_p = ccohort%prt%GetState(organ_id=struct_organ, species_id=phosphorus_element) - repro_p = ccohort%prt%GetState(organ_id=repro_organ, species_id=phosphorus_element) - - leaf_pturn = ccohort%prt%GetTurnover(organ_id=leaf_organ, species_id=phosphorus_element) - fnrt_pturn = ccohort%prt%GetTurnover(organ_id=fnrt_organ, species_id=phosphorus_element) - sapw_pturn = ccohort%prt%GetTurnover(organ_id=sapw_organ, species_id=phosphorus_element) - store_pturn = ccohort%prt%GetTurnover(organ_id=store_organ, species_id=phosphorus_element) - struct_pturn = ccohort%prt%GetTurnover(organ_id=struct_organ, species_id=phosphorus_element) + leaf_c = ccohort%prt%GetState(organ_id=leaf_organ, element_id=carbon12_element) + fnrt_c = ccohort%prt%GetState(organ_id=fnrt_organ, element_id=carbon12_element) + sapw_c = ccohort%prt%GetState(organ_id=sapw_organ, element_id=carbon12_element) + store_c = ccohort%prt%GetState(organ_id=store_organ, element_id=carbon12_element) + struct_c = ccohort%prt%GetState(organ_id=struct_organ, element_id=carbon12_element) + repro_c = ccohort%prt%GetState(organ_id=repro_organ, element_id=carbon12_element) + + leaf_cturn = ccohort%prt%GetTurnover(organ_id=leaf_organ, element_id=carbon12_element) + fnrt_cturn = ccohort%prt%GetTurnover(organ_id=fnrt_organ, element_id=carbon12_element) + sapw_cturn = ccohort%prt%GetTurnover(organ_id=sapw_organ, element_id=carbon12_element) + store_cturn = ccohort%prt%GetTurnover(organ_id=store_organ, element_id=carbon12_element) + struct_cturn = ccohort%prt%GetTurnover(organ_id=struct_organ, element_id=carbon12_element) + + leaf_n = ccohort%prt%GetState(organ_id=leaf_organ, element_id=nitrogen_element) + fnrt_n = ccohort%prt%GetState(organ_id=fnrt_organ, element_id=nitrogen_element) + sapw_n = ccohort%prt%GetState(organ_id=sapw_organ, element_id=nitrogen_element) + store_n = ccohort%prt%GetState(organ_id=store_organ, element_id=nitrogen_element) + struct_n = ccohort%prt%GetState(organ_id=struct_organ, element_id=nitrogen_element) + repro_n = ccohort%prt%GetState(organ_id=repro_organ, element_id=nitrogen_element) + + leaf_nturn = ccohort%prt%GetTurnover(organ_id=leaf_organ, element_id=nitrogen_element) + fnrt_nturn = ccohort%prt%GetTurnover(organ_id=fnrt_organ, element_id=nitrogen_element) + sapw_nturn = ccohort%prt%GetTurnover(organ_id=sapw_organ, element_id=nitrogen_element) + store_nturn = ccohort%prt%GetTurnover(organ_id=store_organ, element_id=nitrogen_element) + struct_nturn = ccohort%prt%GetTurnover(organ_id=struct_organ, element_id=nitrogen_element) + + leaf_p = ccohort%prt%GetState(organ_id=leaf_organ, element_id=phosphorus_element) + fnrt_p = ccohort%prt%GetState(organ_id=fnrt_organ, element_id=phosphorus_element) + sapw_p = ccohort%prt%GetState(organ_id=sapw_organ, element_id=phosphorus_element) + store_p = ccohort%prt%GetState(organ_id=store_organ, element_id=phosphorus_element) + struct_p = ccohort%prt%GetState(organ_id=struct_organ, element_id=phosphorus_element) + repro_p = ccohort%prt%GetState(organ_id=repro_organ, element_id=phosphorus_element) + + leaf_pturn = ccohort%prt%GetTurnover(organ_id=leaf_organ, element_id=phosphorus_element) + fnrt_pturn = ccohort%prt%GetTurnover(organ_id=fnrt_organ, element_id=phosphorus_element) + sapw_pturn = ccohort%prt%GetTurnover(organ_id=sapw_organ, element_id=phosphorus_element) + store_pturn = ccohort%prt%GetTurnover(organ_id=store_organ, element_id=phosphorus_element) + struct_pturn = ccohort%prt%GetTurnover(organ_id=struct_organ, element_id=phosphorus_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 - phosphorus_root_exudate = ccohort%phosphorus_root_exudate + carbon_root_efflux = ccohort%carbon_root_efflux + nitrogen_root_efflux = ccohort%nitrogen_root_efflux + phosphorus_root_efflux = ccohort%phosphorus_root_efflux return end subroutine WrapQueryDiagnostics diff --git a/functional_unit_testing/parteh/f_wrapper_modules/FatesPARTEHWrapMod.F90 b/functional_unit_testing/parteh/f90src/FatesPARTEHWrapMod.F90 similarity index 100% rename from functional_unit_testing/parteh/f_wrapper_modules/FatesPARTEHWrapMod.F90 rename to functional_unit_testing/parteh/f90src/FatesPARTEHWrapMod.F90 diff --git a/functional_unit_testing/parteh/f90src/UnitWrapMod.F90_in b/functional_unit_testing/parteh/f90src/UnitWrapMod.F90_in new file mode 100644 index 0000000000..80be038a36 --- /dev/null +++ b/functional_unit_testing/parteh/f90src/UnitWrapMod.F90_in @@ -0,0 +1,219 @@ + +! ======================================================================================= +! +! This file is an alternative to key files in the fates +! filesystem. Noteably, we replace fates_r8 and fates_in +! with types that work with "ctypes". This is +! a key step in working with python +! +! We also wrap FatesGlobals to reduce the dependancy +! cascade that it pulls in from shr_log_mod. +! +! ======================================================================================= + +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 FatesGlobals + + contains + + integer function fates_log() + fates_log = 11 + 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 + + +module EDTypesMod + + use iso_c_binding, only : r8 => c_double + + integer, parameter :: nclmax = 2 + integer, parameter :: nlevleaf = 30 + real(r8), parameter :: dinc_ed = 1.0_r8 + +end module EDTypesMod + + +module PRTParamsGeneric + + use iso_c_binding, only : r8 => c_double + use iso_c_binding, only : i4 => c_int + use iso_c_binding, only : c_char + use PRTParametersMod, only : prt_params + + integer,parameter :: SHR_KIND_CS = 80 ! short char + + + type ptr_var1 + real(r8), dimension(:), pointer :: var_rp + integer(i4), dimension(:), pointer :: var_ip + character(len=shr_kind_cs) :: var_name + integer :: vtype + end type ptr_var1 + + type ptr_var2 + real(r8), dimension(:,:), pointer :: var_rp + integer(i4), dimension(:,:), pointer :: var_ip + character(len=shr_kind_cs) :: var_name + integer :: vtype + end type ptr_var2 + + + type prt_params_ptr_type + type(ptr_var1), allocatable :: var1d(:) + type(ptr_var2), allocatable :: var2d(:) + end type prt_params_ptr_type + + type(prt_params_ptr_type), public :: prt_params_ptr + + integer :: numparm1d ! Number of different PFT parameters + integer :: numparm2d + integer :: numpft + logical, parameter :: debug = .true. + +contains + + + subroutine PRTParamsPySet(rval,ival,indx1,indx2,name) + + implicit none + ! Arguments + character(kind=c_char,len=*), intent(in) :: name + real(r8),intent(in) :: rval + integer(i4),intent(in) :: ival + integer(i4),intent(in) :: indx1 + integer(i4),intent(in) :: indx2 + ! Locals + logical :: npfound + integer :: ip + integer :: namelen + + namelen = len(trim(name)) + + if(debug) print*,"F90: ARGS: ",trim(name)," IPFT: ",indx1," D2: ",indx2," RVAL: ",rval," IVAL: ",ival + + ip=0 + npfound = .false. + do ip=1,numparm1d + + if (trim(name) == trim(prt_params_ptr%var1d(ip)%var_name ) ) then + print*,"F90: Found ",trim(name)," in lookup table" + npfound = .true. + if(prt_params_ptr%var1d(ip)%vtype == 1) then ! real + prt_params_ptr%var1d(ip)%var_rp(indx1) = rval + elseif(prt_params_ptr%var1d(ip)%vtype == 2) then ! integer + prt_params_ptr%var1d(ip)%var_ip(indx1) = ival + else + print*,"F90: STRANGE TYPE" + stop + end if + end if + end do + + do ip=1,numparm2d + if (trim(name) == trim(prt_params_ptr%var2d(ip)%var_name ) ) then + print*,"F90: Found ",trim(name)," in lookup table" + npfound = .true. + if(prt_params_ptr%var2d(ip)%vtype == 1) then ! real + prt_params_ptr%var2d(ip)%var_rp(indx1,indx2) = rval + elseif(prt_params_ptr%var2d(ip)%vtype == 2) then ! integer + prt_params_ptr%var2d(ip)%var_ip(indx1,indx2) = ival + else + print*,"F90: STRANGE TYPE" + stop + end if + end if + end do + + + + if(.not.npfound)then + print*,"F90: The parameter you loaded DNE: ",name(:) + stop + end if + + + ! Perform a check to see if the target array is being filled + if (trim(name) == 'fates_allom_d2h1') then + if (prt_params%allom_d2h1(indx1) == rval) then + print*,"F90: POINTER CHECK PASSES:",rval," = ",prt_params%allom_d2h1(indx1) + else + print*,"F90: POINTER CHECK FAILS:",rval," != ",prt_params%allom_d2h1(indx1) + stop + end if + end if + + if (trim(name) == 'fates_wood_density' ) then + if (prt_params%wood_density(indx1) == rval) then + print*,"F90: POINTER CHECK PASSES:",rval," = ",prt_params%wood_density(indx1) + else + print*,"F90: POINTER CHECK FAILS:",rval," != ",prt_params%wood_density(indx1) + stop + end if + end if + + return + end subroutine PRTParamsPySet + + + subroutine PRTParamsAlloc(ARGUMENT_IN1) + ! + use FatesConstantsMod, only : fates_unset_r8 + + implicit none + + ! ARGUMENT_DEF1 + + + ! LOCALS: + integer :: iv1 ! The parameter incrementer + integer :: iv2 + !------------------------------------------------------------------------ + + allocate( prt_params_ptr%var1d(100)) ! Make this plenty large + allocate( prt_params_ptr%var2d(100)) + iv1=0 + iv2=0 + + ! POINTER-SPECIFICATION-HERE (DO NOT REMOVE THIS LINE, OR MOVE IT) + + + numparm1d = iv1 + numparm2d = iv2 + + print*,"F90: ALLOCATED ",numparm1d," 1D PARAMETERS" + print*,"F90: ALLOCATED ",numparm2d," 2D PARAMETERS" + print*,"FOR ",fates_pft," PFTs" + + numpft = fates_pft + + return + end subroutine PRTParamsAlloc + +end module PRTParamsGeneric \ No newline at end of file diff --git a/functional_unit_testing/parteh/f_wrapper_modules/FatesPFTWrapMod.F90 b/functional_unit_testing/parteh/f_wrapper_modules/FatesPFTWrapMod.F90 deleted file mode 100644 index e5a2c25766..0000000000 --- a/functional_unit_testing/parteh/f_wrapper_modules/FatesPFTWrapMod.F90 +++ /dev/null @@ -1,584 +0,0 @@ -! ======================================================================================= -! -! 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 - - implicit none - private ! Modules are private by default - - integer,parameter,public :: 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, public :: 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, public :: 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, public :: numparm ! Number of different PFT parameters - integer, public :: num_pft ! Number of PFTs - integer, public :: num_organs ! Number of organs - - ! Make necessary procedures public - public :: EDPftvarconPySet - public :: EDPftvarconAlloc - -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 deleted file mode 100644 index ad28d50c55..0000000000 --- a/functional_unit_testing/parteh/f_wrapper_modules/FatesWrapMod.F90 +++ /dev/null @@ -1,79 +0,0 @@ -! ======================================================================================= -! -! 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 - - implicit none - private - - integer(fates_int), parameter, public :: nlevleaf = 40 - real(fates_r8), parameter, public :: dinc_ed = 1.0_fates_r8 - integer(fates_int), parameter, public :: nclmax = 4 - -end module EDTypesMod - - -module shr_log_mod - - use iso_c_binding, only : c_char - use iso_c_binding, only : c_int - - implicit none - private - - ! Make necessary producers public - public :: shr_log_errMsg - - 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 - - implicit none - private - - real(fates_r8), parameter, public :: hlm_freq_day = 1.0_fates_r8/365.0_fates_r8 - -end module FatesInterfaceMod - - -module FatesGlobals - - implicit none - private - - ! Make necessary producers public - public :: fates_log - public :: fates_endrun - - 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 index 5582212aef..8be3b271b4 100644 --- a/functional_unit_testing/parteh/parteh_controls_defaults.xml +++ b/functional_unit_testing/parteh/parteh_controls_defaults.xml @@ -1,15 +1,6 @@ - - - - - - - - 0 - @@ -19,106 +10,27 @@ 86400 1500-01-01 - 1520-01-01 + 1550-01-01 0.001 - - - - + ../../parameter_files/fates_params_default.cdl - - 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 + DailyCNPFromStorageSinWaveNoMaint - 1,1 + + 1,1 + + + 1,2 + 0.4, 0.4 + 4, 4 + 4, 4 + 1.2, 1.2 + - 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/py_modules/CDLParse.py b/functional_unit_testing/parteh/py_modules/CDLParse.py new file mode 100644 index 0000000000..362c00f9e9 --- /dev/null +++ b/functional_unit_testing/parteh/py_modules/CDLParse.py @@ -0,0 +1,297 @@ + +# ======================================================================================= +# This will look through a CDL file for the provided parameter and determine +# the parameter's type, as well as fill an array with the data +# ======================================================================================= + +import re # This is a heftier string parser +import code # For development: code.interact(local=dict(globals(), **locals())) +import numpy as np + +# Global identifiers for the type of data +# --------------------------------------------------------------------------------------- + +char_type = 0 +int_type = 1 +float_type = 2 +double_type = 3 + +# If we encounter a "_", ie no data? +no_data_fill='1.e-32' + + +# This is base object for a parameter +# =================================== +class cdl_param_type: + + def __init__(self,symbol,in_f90): + + self.datatype = -9 + self.dim_namelist = [] + self.dim_sizelist = [] + self.ndims = -9 + self.symbol = symbol + self.units = 'NA' + self.in_f90 = in_f90 + + def Add1DToXD(self,val,indx): + + if(self.ndims==0): + self.data[indx] = val + + elif(self.ndims==1): + n1 = self.dim_sizelist[0] + if((indx<0) or (indx>=n1)): + print('Problem in CDLParse filling data array') + print('index must be between {} {}, value = {}'.format(0,n1,indx)) + print('param: {}'.format(self.symbol)) + exit(2) + else: + self.data[indx] = val + + elif(self.ndims==2): + n1 = self.dim_sizelist[0] + n2 = self.dim_sizelist[1] + i2 = np.mod(indx+1,n2) + i1 = int(indx/n2) + self.data[i1,i2] = val + + else: + print('No more than 2 dimensions can be processed by Add1dToXd()') + exit(2) + + + +# This routine adds a new parameter to the list of cdl_param_types +# ================================================================ +def CDLParseParam(file_name,param,dim_dic): + + fp = open(file_name,"r") + contents = fp.readlines() + fp.close() + + # Look in the file for the definition for the parameter + # of interest, note its specified dimensions and cross + # ref against the dictionary of known dimensions + # --------------------------------------------------------- + isfound = False + for i,line in enumerate(contents): + if((param.symbol in line) and \ + (not isfound) and \ + (('double' in line) or \ + ('char' in line) or \ + ('float' in line) or \ + ('int' in line))): + + isfound = True + + print('Filling {}'.format(param.symbol)) + + datatype = line.split()[0] + if(datatype.strip()=="float"): + param.datatype = float_type + elif(datatype.strip()=="double"): + param.datatype = double_type + elif(datatype.strip()=="char"): + param.datatype = char_type + elif(datatype.strip()=="int"): + param.datatype = int_type + else: + print('An unknown datatype: {}'.format(datatype.strip())) + print(' was encountered for parameter: {}'.format(param.symbol)) + exit(2) + + + p1=line.find('(')+1 + if(p1>0): + p2=line.find(')') + dims_str = line[p1:p2] + dims_splt = dims_str.split(',') + + for dimname in dims_splt: + dimsize = dim_dic.get(dimname.strip()) + if dimsize: + param.dim_namelist.append(dimname.strip()) + param.dim_sizelist.append(dimsize) + else: + print('An unknown dimension was requested:') + print(' parameter: {}'.format(param.symbol)) + print(' dimension name: {}'.format(dimname.strip())) + exit(2) + + param.ndims = len(param.dim_namelist) + + else: + param.ndims = 0 + + + + # Allocate and initialize the data space + if(param.ndims>0): + + param.data = -999*np.ones((param.dim_sizelist)) + else: + param.data = -999*np.ones((1)) + + + + + if(not isfound): + print('An unknown parameter was requested:') + print(' parameter: {}'.format(param.symbol)) + exit(2) + + # ----------------------------------------------------------- + # Now that the metadata has been read in, and we + # know the type of data and its dimensions, lets go retrieve + # and fill the values in + # ----------------------------------------------------------- + + + # First step is to identify the start of the data section: + # Also, identify the whatever line is next with a ':' + # --------------------------------------------------- + + iline0=-1 + for i,line in enumerate(contents): + if('data:' in line): + iline0 = i + break + + if(iline0==-1): + print('Could not find the data section of the CDL file?') + exit(2) + + # Look for the symbol, again, but now in the "data" section: + # ----------------------------------------------------------- + + isfound = False + contents=contents[iline0:] + for i,line in enumerate(contents): + + if(param.symbol in line): + + search_field=True + lcount=0 + multi_line='' + while(search_field and (lcount<100)): + multi_line+=contents[i+lcount] + if(multi_line.count(';')>0): + search_field=False + else: + search_field=True + lcount=lcount+1 + + # Parse the line + line_split = re.split(',|=',multi_line) + # Remove the variable name entry + del line_split[0] + + # This is for real numbers + if((param.datatype == float_type) or \ + (param.datatype == double_type)): + ival=0 + indx=0 + for str0 in line_split: + str="" + isnum=False + for s in str0: + if (s.isdigit() or s=='.'): + str+=s + isnum=True + elif(s == '_'): + str+=no_data_fill + isnum=True + if(isnum): + param.Add1DToXD(float(str),indx) + indx=indx+1 + else: + print('No-data values encountered during parameter read in') + print('for parameter {}'.format(param.symbol)) + print('bad value: {}'.format(str0)) + print('data: {}'.format(line_split)) + exit(2) + + # This is a string + # elif(param.datatype == 1): + # for str0 in line_split: + # # Loop several times to trim stuff off + # for i in range(5): + # str0=str0.strip().strip('\"').strip(';').strip() + # param.vals.append(str0) + + +# if(param.symbol == 'fates_hydr_thetas_node'): + + + + + return(param) + + + + + +# This routine returns a dictionary with dimension names and sizes +# ==================================================================== + +def CDLParseDims(file_name): + + fp = open(file_name,"r") + contents = fp.readlines() + fp.close() + + if(len(contents)<1): + print("Missing or no-data file passed to CDLParseDims?") + exit(2) + + # Identify the line with the "dimensions:" tag + # Also, identify the whatever line is next with a ':' + # --------------------------------------------------- + + iline0=-1 + for i,line in enumerate(contents): + if('dimensions:' in line): + iline0 = i + break + + if(iline0==-1): + print("The CDL Parser could not find the dimensions section") + print(" in your output file") + print(" exiting...") + exit(2) + + iline1=-1 + for i,line in enumerate(contents): + if((':' in line) and \ + (i > iline0) and \ + ('"' not in line)): + iline1 = i + break + + if(iline1==-1): + print("The CDL Parser could not find a section") + print(" following the dimensions section.") + print(" exiting...") + exit(2) + + # Loop between the two and save the dimensions + # -------------------------------------------- + + dim_dic = {} + for i in range(iline0+1,iline1): + + # If there is an equals sign, then there is data + if('=' in contents[i]): + + # Split string into chunks + sline = contents[i].split() + dim_dic[sline[0]] = int(sline[2]) + + + if(len(dim_dic)==0): + print("No valid dimensions found in your CDL file") + print(" exiting...") + exit(2) + + return(dim_dic) diff --git a/functional_unit_testing/parteh/py_modules/F90ParamParse.py b/functional_unit_testing/parteh/py_modules/F90ParamParse.py new file mode 100644 index 0000000000..e7791eed1a --- /dev/null +++ b/functional_unit_testing/parteh/py_modules/F90ParamParse.py @@ -0,0 +1,236 @@ +# ======================================================================================= +# +# This python module contains routines and utilities which will interpret the +# FATES fortran code base to return information on the use of parameters. +# This does not parse the CDL or NC files, this only parses the fortran code. +# +# This module will help: +# 1) List the parameters found in a given file +# 2) Determine the parameter names found therein +# 3) Determine the parameter's name in the parameter file +# +# Note: This module can be used to determine usage of any sybmol associated with +# the instantiation of a structure. Ie, you can search for all parameters +# in the 'EDPftvarcon_inst%' structure. In FATES, the EDParamsMod and SFParamsMod +# don't use a structure to hold their parameters though. +# +# ======================================================================================= + +import code # For development: code.interact(local=dict(globals(), **locals())) + + +class f90_param_type: + + # ----------------------------------------------- + # PFTParamType stucture. A list of these will be + # generated that denotes the PFT parameters used. + # ----------------------------------------------- + + def __init__(self,var_sym,var_name,in_f90): + + self.var_sym = var_sym # Name of parameter in FORTRAN code + self.var_name = var_name # Parameter's name in the parameter file + self.in_f90 = in_f90 # Are we passing this value to the f90 code? + + +def GetParamsInFile(filename): + + # --------------------------------------------------------------------- + # This procedure will check a fortran file that contains + # parameters definitions only. It will create a list of those parameter + # names, which can then be used to auto-generate other fortran code + # that is used to read-in the parameters. + # --------------------------------------------------------------------- + + # This just reads in the whole text file, and saves the text in "contents" + f = open(filename,"r") + contents = f.readlines() + f.close() + + checkstr = 'real(r8)' + + strclose = ',)( ' + + var_list = [] + found = False + + for line in contents: + if checkstr in line.lower(): + + # We compare all in lower-case + # There may be more than one parameter in a line, + # so evaluate, pop-off, and try again + + substr = line.lower() + + p1 = substr.find('::')+len('::') + + + # Check for a comment symbol. If this + # symbol is commenting out the variable + # then we will ignore + pcomment = substr.find('!') + if(pcomment<0): + pcomment=1000 + + # This makes sure that if the line + # has a comment, that it does not come before + # the parameter symbol + + if( (p1>len(checkstr)) and (p1 < pcomment)): + + # Identify the symbol by starting at the first + # character after the %, and ending at a list + # of possible symols including space + substr2=substr[p1:].lstrip() + + pend=substr2.find('(') + if(pend<0): + # This is likely a scalar + # if so, go out to the comment + # if no comment, just accept lenght as as + pend=substr2.find('!') + if(pend<0): + pend=len(substr2) + + found=True + substr2=substr2[:pend].rstrip() + var_list.append(f90_param_type(substr2,'',True)) + + + if(not found): + print('No parameters with prefix: {}'.format(checkstr)) + print('were found in file: {}'.format(filename)) + print('If this is expected, remove that file from search list.') + exit(2) + + return(var_list) + + + + +def GetSymbolUsage(filename,checkstr_in): + + # --------------------------------------------------------------------- + # This procedure will check a fortran file and return a list (non-unique) + # of all the PFT parameters found in the code. + # Note: This will only determine the symbol name in code, this will + # not determine the symbol name in the parameter file. + # --------------------------------------------------------------------- + + checkstr = checkstr_in.lower() + + f = open(filename,"r") + contents = f.readlines() + f.close() + + strclose = ',)( ' + + var_list = [] + found = False + + + for line in contents: + if checkstr in line.lower(): + + if(checkstr[-1] != '%'): + print('The GetSymbolUsage() procedure requires') + print(' that a structure ending with % is passed in') + print(' check_str: --{}--'.format(check_str)) + exit(2) + + # We compare all in lower-case + # There may be more than one parameter in a line, + # so evaluate, pop-off, and try again + + substr = line.lower() + + search_substr=True + + while(search_substr): + + p1 = substr.find(checkstr)+len(checkstr) + + pcomment = substr.find('!') + if(pcomment<0): + pcomment=1000 + + # This makes sure that if the line + # has a comment, that it does not come before + # the parameter symbol + + if( (p1>len(checkstr)) and (p1 < pcomment)): + found = True + + # Identify the symbol by starting at the first + # character after the %, and ending at a list + # of possible symols including space + substr2=substr[p1:] + pend0=-1 + for ch in strclose: + pend = substr2.find(ch) + if(pend>0): + substr2=substr2[:pend] + pend0=pend + + var_list.append(f90_param_type(substr2,'',True)) + if(pend0!=-1): + substr=substr[pend0:] + else: + print('Could not correctly identify the parameter string') + exit(2) + + else: + search_substr=False + + + + if(not found): + print('No parameters with prefix: {}'.format(checkstr)) + print('were found in file: {}'.format(filename)) + print('If this is expected, remove that file from search list.') + exit(2) + + + return(var_list) + + + + +def GetPFTParmFileSymbols(var_list,pft_filename): + + #--------------------------------------------------------------- + # This procedure will determine the parameter file symbol/name + # for a given PFT parameter name. This relies on specific + # file syntax in the PFT definitions file, so this is specific + # only to PFT parameters. + # -------------------------------------------------------------- + + f = open(pft_filename,"r") + contents = f.readlines() + f.close() + + var_name_list = [] + for var in var_list: + for i,line in enumerate(contents): + if (var.var_sym in line) and ('data' in line) and ('=' in line): + var.var_name = contents[i-2].split()[-1].strip('\'') + + return(var_list) + + +def MakeListUnique(list_in): + + # This procedure simply filters + # an input list and returns the unique entries + + unique_list = [] + for var in list_in: + found = False + for uvar in unique_list: + if (var.var_sym == uvar.var_sym): + found = True + if(not found): + unique_list.append(var) + + return(unique_list) diff --git a/functional_unit_testing/parteh/py_modules/PartehInterpretParameters.py b/functional_unit_testing/parteh/py_modules/PartehInterpretParameters.py index ce9dc0d7ce..6a68dcd6f4 100644 --- a/functional_unit_testing/parteh/py_modules/PartehInterpretParameters.py +++ b/functional_unit_testing/parteh/py_modules/PartehInterpretParameters.py @@ -11,19 +11,18 @@ # ======================================================================================== # Interpret the XML file -def load_xml(xmlfile, time_control, parameters ): - - import xml.etree.ElementTree as et +def load_xml(xmlfile): # + import xml.etree.ElementTree as et xmlroot = et.parse(xmlfile).getroot() print("\nOpenend: "+xmlfile) - - # Time control # ----------------------------------------------------------------------------------- + time_control = PartehTypes.timetype() # Initialize the time structure + elem = xmlroot.find('time_control') date_start_str = elem.find('date_start').text date_stop_str = elem.find('date_stop').text @@ -31,123 +30,64 @@ def load_xml(xmlfile, time_control, parameters ): 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 + # FATES-PARTEH model parameters + # ----------------------------------------------------------------------------------- + + fates_cdl_file = xmlroot.find('fates_cdl_file').text - hypotheses = ('AllometricCarbon','AllometricCNP') + # List of PFTs for the plants - hypothesis_root = xmlroot.find('hypothesis') - parameters.hypothesis = hypothesis_root.text.strip() + use_pfts_text = xmlroot.find('use_pfts').text + use_pfts = [] + for use_pft in use_pfts_text.strip().split(','): + use_pfts.append(int(use_pft)) - 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) + # Specify the boundary condition + # ----------------------------------------------------------------------------------- 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')): + boundary_method = xmlroot.find('boundary_formulation').text.strip() - pft_name = pft_elem.text.strip() - - # Intialize the pft's dictionary of parameters - parameters.parteh_pfts.append(PartehTypes.pft_type(pft_name)) +# if ( not any(x in 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) - # 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) + # 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 + # ----------------------------------------------------------------------------------- - - # 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) + driver_params = {} - parameters.num_organs = len(parameters.parteh_organs) + driver_params_root = xmlroot.find('driver_parameters') - # 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] + for par_idx, par_elem in enumerate(driver_params_root.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) != len(use_pfts)): + print('PFT parameters in xml file must have as as many entries as use_pfts') + print('{} is: {}'.format(pft_param_name,pft_param_val)) + print('exiting') + exit(1) - # 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 - # ----------------------------------------------------------------------------------- + driver_params[pft_param_name] = PartehTypes.driver_param_type() + # driver_params.append(driver_param) + for idx,value in enumerate(pft_vector): + driver_params[pft_param_name].param_vals.append(value) - 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\n Completed Interpreting: "+xmlfile) - print("\n Found {} PFT(s)".format(parameters.num_pfts)) + return(time_control, fates_cdl_file, driver_params, boundary_method, use_pfts) diff --git a/functional_unit_testing/parteh/py_modules/PartehTypes.py b/functional_unit_testing/parteh/py_modules/PartehTypes.py index 1be558385a..62715e83a3 100644 --- a/functional_unit_testing/parteh/py_modules/PartehTypes.py +++ b/functional_unit_testing/parteh/py_modules/PartehTypes.py @@ -16,45 +16,26 @@ os.environ['TZ'] = 'UTC' time.tzset() -time_precision = 1.0e-10 # Acceptable time error for the +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 = "" +# The following class holds the parameters that define how this unit testing framework +# will be conducted. These do not hold the PFT type parameters found in the FATES-PARTEH +# fortran code. - # 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 unit tests need to be able to provide and external boundary +# condition to the plants. Most of the PFT level information on these plants is provided +# in the standard FATES parameter file. However, some information that is specific to the driver +# is not available. - # These are used in the boundary conditions - self.boundary_pfts = [] +class driver_param_type: - # 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): + def __init__(self): # Initialize a dictionary of parameters for any pft - self.name = pft_name - self.param_dic = {} + self.param_vals = [] class diagnostics_type: @@ -68,19 +49,19 @@ def __init__(self): self.fnrt_c = [] self.sapw_c = [] self.store_c = [] - self.struct_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.struct_n = [] self.repro_n = [] self.leaf_nturn = [] self.fnrt_nturn = [] @@ -92,7 +73,7 @@ def __init__(self): self.fnrt_p = [] self.sapw_p = [] self.store_p = [] - self.struct_p = [] + self.struct_p = [] self.repro_p = [] self.leaf_pturn = [] self.fnrt_pturn = [] @@ -139,11 +120,11 @@ def InitializeTime(self,date_start_str,date_stop_str,timestep_str,max_trunc_err_ 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 @@ -163,7 +144,7 @@ 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') @@ -175,10 +156,8 @@ def CheckFullStepTime(self,targettime): 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 index 0a4d7ed07e..1f24fb277b 100644 --- a/functional_unit_testing/parteh/py_modules/SyntheticBoundaries.py +++ b/functional_unit_testing/parteh/py_modules/SyntheticBoundaries.py @@ -16,7 +16,7 @@ def __init__(self): 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 @@ -26,10 +26,10 @@ def DailyCFromUnitGPPAR(leaf_area,AGB): # 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 @@ -49,12 +49,12 @@ def DailyCFromUnitGPPAR(leaf_area,AGB): 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 @@ -66,7 +66,7 @@ def DailyCFromCArea(presc_npp_p1,c_area,phen_type,leaf_status): # ----------------------------------------------------------------------------------- if( (phen_type == 1) or (leaf_status ==2)): - NetDailyC = presc_npp_p1 * c_area / day_per_year + NetDailyC = presc_npp_p1 * c_area / day_per_year else: NetDailyC = 0.0 @@ -75,7 +75,7 @@ def DailyCFromCArea(presc_npp_p1,c_area,phen_type,leaf_status): 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 @@ -90,7 +90,7 @@ def DailyCNPFromCArea(presc_npp_p1,presc_nflux_p1, \ # ----------------------------------------------------------------------------------- if( (phen_type == 1) or (leaf_status ==2)): - NetDailyC = presc_npp_p1 * c_area / day_per_year + 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: @@ -113,10 +113,15 @@ def DailyCNPFromStorageSinWave(doy,store_c,presc_npp_p1, \ # realistic model, but its important to test that the parteh algorithms can handle # these stressfull negative gain conditions. +# print('doy {} store_c {} npp1 {} nflux1 {} pflux1 {} c_area {} nppamp {} phent {} status {}'.format(doy,store_c,presc_npp_p1, \ +# presc_nflux_p1,presc_pflux_p1,c_area,presc_npp_amp, \ +# phen_type, leaf_status)) + + 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: @@ -125,7 +130,7 @@ def DailyCNPFromStorageSinWave(doy,store_c,presc_npp_p1, \ 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)) @@ -138,7 +143,10 @@ def DailyCNPFromStorageSinWave(doy,store_c,presc_npp_p1, \ NetDailyN = 0.0 NetDailyP = 0.0 NetDailyC = 0.0 - + + +# print('NetC {} NetN {} NetP {}'.format(NetDailyC, NetDailyN, NetDailyP)) + return NetDailyC, NetDailyN, NetDailyP @@ -170,6 +178,3 @@ def DeciduousPhenology(doy, target_leaf_c, store_c, phen_type): leaf_status = 2 return flush_c, drop_frac_c, leaf_status - - - diff --git a/main/ChecksBalancesMod.F90 b/main/ChecksBalancesMod.F90 index 9374c373e0..9a17fbfc33 100644 --- a/main/ChecksBalancesMod.F90 +++ b/main/ChecksBalancesMod.F90 @@ -7,8 +7,8 @@ module ChecksBalancesMod use EDTypesMod, only : ed_cohort_type use EDTypesMod, only : AREA use EDTypesMod, only : site_massbal_type - use EDTypesMod, only : num_elements - use EDTypesMod, only : element_list + use PRTGenericMod, only : num_elements + use PRTGenericMod, only : element_list use FatesInterfaceTypesMod, only : numpft use FatesConstantsMod, only : g_per_kg use FatesInterfaceTypesMod, only : bc_in_type @@ -16,6 +16,7 @@ module ChecksBalancesMod use FatesLitterMod, only : ncwd use FatesLitterMod, only : ndcmpy use PRTGenericMod, only : all_carbon_elements + use PRTGenericMod, only : carbon12_element use PRTGenericMod, only : leaf_organ use PRTGenericMod, only : fnrt_organ use PRTGenericMod, only : sapw_organ @@ -119,7 +120,17 @@ subroutine PatchMassStock(currentPatch,el,live_stock,seed_stock,litter_stock) * currentCohort%n currentCohort => currentCohort%shorter enddo !end cohort loop - + + + if(element_id.eq.carbon12_element) then + currentCohort => currentPatch%tallest + do while(associated(currentCohort)) + live_stock = live_stock - & + (currentCohort%resp_m_def*currentCohort%n) + currentCohort => currentCohort%shorter + enddo !end cohort loop + end if + return end subroutine PatchMassStock diff --git a/main/EDInitMod.F90 b/main/EDInitMod.F90 index 646084ef1b..bec7a99537 100644 --- a/main/EDInitMod.F90 +++ b/main/EDInitMod.F90 @@ -14,6 +14,7 @@ module EDInitMod use FatesGlobals , only : fates_log use FatesInterfaceTypesMod , only : hlm_is_restart use EDPftvarcon , only : EDPftvarcon_inst + use PRTParametersMod , only : prt_params use EDCohortDynamicsMod , only : create_cohort, fuse_cohorts, sort_cohorts use EDCohortDynamicsMod , only : InitPRTObject use EDPatchDynamicsMod , only : create_patch @@ -27,8 +28,8 @@ module EDInitMod use EDTypesMod , only : init_spread_inventory use EDTypesMod , only : leaves_on use EDTypesMod , only : leaves_off - use EDTypesMod , only : num_elements - use EDTypesMod , only : element_list + use PRTGenericMod , only : num_elements + use PRTGenericMod , only : element_list use EDTypesMod , only : phen_cstat_nevercold use EDTypesMod , only : phen_cstat_iscold use EDTypesMod , only : phen_dstat_timeoff @@ -130,6 +131,10 @@ subroutine init_site_vars( site_in, bc_in ) do el=1,num_elements allocate(site_in%flux_diags(el)%leaf_litter_input(1:numpft)) allocate(site_in%flux_diags(el)%root_litter_input(1:numpft)) + allocate(site_in%flux_diags(el)%nutrient_efflux_scpf(nlevsclass*numpft)) + allocate(site_in%flux_diags(el)%nutrient_uptake_scpf(nlevsclass*numpft)) + allocate(site_in%flux_diags(el)%nutrient_needgrow_scpf(nlevsclass*numpft)) + allocate(site_in%flux_diags(el)%nutrient_needmax_scpf(nlevsclass*numpft)) end do ! Initialize the static soil @@ -532,8 +537,9 @@ subroutine init_cohorts( site_in, patch_in, bc_in) stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) - if( EDPftvarcon_inst%season_decid(pft) == itrue .and. & + if( prt_params%season_decid(pft) == itrue .and. & any(site_in%cstatus == [phen_cstat_nevercold,phen_cstat_iscold])) then + temp_cohort%laimemory = c_leaf temp_cohort%sapwmemory = c_sapw * stem_drop_fraction temp_cohort%structmemory = c_struct * stem_drop_fraction @@ -543,7 +549,7 @@ subroutine init_cohorts( site_in, patch_in, bc_in) cstatus = leaves_off endif - if ( EDPftvarcon_inst%stress_decid(pft) == itrue .and. & + if ( prt_params%stress_decid(pft) == itrue .and. & any(site_in%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then temp_cohort%laimemory = c_leaf temp_cohort%sapwmemory = c_sapw * stem_drop_fraction @@ -584,26 +590,26 @@ subroutine init_cohorts( site_in, patch_in, bc_in) case(nitrogen_element) - m_struct = c_struct*EDPftvarcon_inst%prt_nitr_stoich_p2(pft,struct_organ) - m_leaf = c_leaf*EDPftvarcon_inst%prt_nitr_stoich_p2(pft,leaf_organ) - m_fnrt = c_fnrt*EDPftvarcon_inst%prt_nitr_stoich_p2(pft,fnrt_organ) - m_sapw = c_sapw*EDPftvarcon_inst%prt_nitr_stoich_p2(pft,sapw_organ) - m_store = c_store*EDPftvarcon_inst%prt_nitr_stoich_p2(pft,store_organ) + m_struct = c_struct*prt_params%nitr_stoich_p2(pft,struct_organ) + m_leaf = c_leaf*prt_params%nitr_stoich_p2(pft,leaf_organ) + m_fnrt = c_fnrt*prt_params%nitr_stoich_p2(pft,fnrt_organ) + m_sapw = c_sapw*prt_params%nitr_stoich_p2(pft,sapw_organ) + m_store = c_store*prt_params%nitr_stoich_p2(pft,store_organ) m_repro = 0._r8 case(phosphorus_element) - m_struct = c_struct*EDPftvarcon_inst%prt_phos_stoich_p2(pft,struct_organ) - m_leaf = c_leaf*EDPftvarcon_inst%prt_phos_stoich_p2(pft,leaf_organ) - m_fnrt = c_fnrt*EDPftvarcon_inst%prt_phos_stoich_p2(pft,fnrt_organ) - m_sapw = c_sapw*EDPftvarcon_inst%prt_phos_stoich_p2(pft,sapw_organ) - m_store = c_store*EDPftvarcon_inst%prt_phos_stoich_p2(pft,store_organ) + m_struct = c_struct*prt_params%phos_stoich_p2(pft,struct_organ) + m_leaf = c_leaf*prt_params%phos_stoich_p2(pft,leaf_organ) + m_fnrt = c_fnrt*prt_params%phos_stoich_p2(pft,fnrt_organ) + m_sapw = c_sapw*prt_params%phos_stoich_p2(pft,sapw_organ) + m_store = c_store*prt_params%phos_stoich_p2(pft,store_organ) m_repro = 0._r8 end select select case(hlm_parteh_mode) case (prt_carbon_allom_hyp,prt_cnp_flex_allom_hyp ) - + ! Put all of the leaf mass into the first bin call SetState(prt_obj,leaf_organ, element_id,m_leaf,1) do iage = 2,nleafage diff --git a/main/EDMainMod.F90 b/main/EDMainMod.F90 index 63f2fa6778..1188802e03 100644 --- a/main/EDMainMod.F90 +++ b/main/EDMainMod.F90 @@ -14,14 +14,20 @@ module EDMainMod use FatesInterfaceTypesMod , only : hlm_current_year use FatesInterfaceTypesMod , only : hlm_current_month use FatesInterfaceTypesMod , only : hlm_current_day - use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_use_planthydro + use FatesInterfaceTypesMod , only : hlm_parteh_mode use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking use FatesInterfaceTypesMod , only : hlm_reference_date use FatesInterfaceTypesMod , only : hlm_use_ed_prescribed_phys use FatesInterfaceTypesMod , only : hlm_use_ed_st3 use FatesInterfaceTypesMod , only : bc_in_type + use FatesInterfaceTypesMod , only : bc_out_type use FatesInterfaceTypesMod , only : hlm_masterproc use FatesInterfaceTypesMod , only : numpft + use PRTGenericMod , only : prt_carbon_allom_hyp + use PRTGenericMod , only : prt_cnp_flex_allom_hyp + use PRTGenericMod , only : nitrogen_element + use PRTGenericMod , only : phosphorus_element use EDCohortDynamicsMod , only : terminate_cohorts use EDCohortDynamicsMod , only : fuse_cohorts use EDCohortDynamicsMod , only : sort_cohorts @@ -39,21 +45,22 @@ module EDMainMod use EDPhysiologyMod , only : ZeroLitterFluxes use EDPhysiologyMod , only : PreDisturbanceLitterFluxes use EDPhysiologyMod , only : PreDisturbanceIntegrateLitter + use FatesSoilBGCFluxMod , only : FluxIntoLitterPools use EDCohortDynamicsMod , only : UpdateCohortBioPhysRates + use FatesSoilBGCFluxMod , only : PrepNutrientAquisitionBCs use SFMainMod , only : fire_model use FatesSizeAgeTypeIndicesMod, only : get_age_class_index use FatesSizeAgeTypeIndicesMod, only : coagetype_class_index use FatesLitterMod , only : litter_type use FatesLitterMod , only : ncwd - use EDtypesMod , only : ed_site_type use EDtypesMod , only : ed_patch_type use EDtypesMod , only : ed_cohort_type use EDTypesMod , only : AREA use EDTypesMod , only : site_massbal_type - use EDTypesMod , only : num_elements - use EDTypesMod , only : element_list - use EDTypesMod , only : element_pos + use PRTGenericMod , only : num_elements + use PRTGenericMod , only : element_list + use PRTGenericMod , only : element_pos use EDTypesMod , only : phen_dstat_moiston use EDTypesMod , only : phen_dstat_timeon use FatesConstantsMod , only : itrue,ifalse @@ -119,7 +126,7 @@ module EDMainMod contains !-------------------------------------------------------------------------------! - subroutine ed_ecosystem_dynamics(currentSite, bc_in) + subroutine ed_ecosystem_dynamics(currentSite, bc_in, bc_out) ! ! !DESCRIPTION: ! Core of ed model, calling all subsequent vegetation dynamics routines @@ -127,6 +134,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite type(bc_in_type) , intent(in) :: bc_in + type(bc_out_type) , intent(inout) :: bc_out ! ! !LOCAL VARIABLES: type(ed_patch_type), pointer :: currentPatch @@ -137,7 +145,6 @@ 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 - ! Consider moving this towards the end, because some of these ! are being integrated over the short time-step @@ -150,6 +157,13 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) ! This is limited to a global event until more structured event handling is enabled call IsItLoggingTime(hlm_masterproc,currentSite) + ! ----------------------------------------------------------------------------------- + ! Parse nutrient flux rates + ! The input boundary conditions from the HLM should now have a daily integrated + ! flux. But, that flux still needs to be parsed out to the existing cohorts. + ! ----------------------------------------------------------------------------------- + + !************************************************************************** ! Fire, growth, biogeochemistry. !************************************************************************** @@ -184,7 +198,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) if (hlm_use_ed_st3.eq.ifalse) then ! Integrate state variables from annual rates to daily timestep - call ed_integrate_state_variables(currentSite, bc_in ) + call ed_integrate_state_variables(currentSite, bc_in, bc_out ) else ! ed_intergrate_state_variables is where the new cohort flag ! is set. This flag designates wether a cohort has @@ -274,7 +288,7 @@ subroutine ed_ecosystem_dynamics(currentSite, bc_in) end subroutine ed_ecosystem_dynamics !-------------------------------------------------------------------------------! - subroutine ed_integrate_state_variables(currentSite, bc_in ) + subroutine ed_integrate_state_variables(currentSite, bc_in, bc_out ) ! ! !DESCRIPTION: @@ -287,6 +301,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) type(ed_site_type) , intent(inout) :: currentSite type(bc_in_type) , intent(in) :: bc_in + type(bc_out_type) , intent(inout) :: bc_out ! ! !LOCAL VARIABLES: @@ -296,6 +311,7 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) integer :: c ! Counter for litter size class integer :: ft ! Counter for PFT + integer :: iscpf ! index for the size-class x pft multiplexed bins integer :: el ! Counter for element type (c,n,p,etc) real(r8) :: cohort_biomass_store ! remembers the biomass in the cohort for balance checking real(r8) :: dbh_old ! dbh of plant before daily PRT [cm] @@ -353,6 +369,29 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) ! Set the available carbon pool, identify allocation portions, and ! decrement the available carbon pool to zero. ! ----------------------------------------------------------------------------- + + + if (hlm_use_ed_prescribed_phys .eq. itrue) then + if (currentCohort%canopy_layer .eq. 1) then + currentCohort%npp_acc = EDPftvarcon_inst%prescribed_npp_canopy(ft) & + * currentCohort%c_area / currentCohort%n / hlm_days_per_year + else + currentCohort%npp_acc = EDPftvarcon_inst%prescribed_npp_understory(ft) & + * currentCohort%c_area / currentCohort%n / hlm_days_per_year + endif + + ! We don't explicitly define a respiration rate for prescribe phys + ! but we do need to pass mass balance. So we say it is zero respiration + currentCohort%gpp_acc = currentCohort%npp_acc + currentCohort%resp_acc = 0._r8 + + end if + + ! ----------------------------------------------------------------------------- + ! Save NPP/GPP/R in these "hold" style variables. These variables + ! persist after this routine is complete, and used in I/O diagnostics. + ! Whereas the _acc style variables are zero'd because they are key + ! accumulation state variables. ! ! convert from kgC/indiv/day into kgC/indiv/year ! _acc_hold is remembered until the next dynamics step (used for I/O) @@ -360,29 +399,10 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) ! 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 - currentCohort%npp_acc = currentCohort%npp_acc_hold / hlm_days_per_year - ! for mass balancing - currentCohort%gpp_acc = currentCohort%npp_acc - currentCohort%resp_acc = 0._r8 - else - currentCohort%npp_acc_hold = EDPftvarcon_inst%prescribed_npp_understory(ft) & - * currentCohort%c_area / currentCohort%n - - currentCohort%npp_acc = currentCohort%npp_acc_hold / hlm_days_per_year - - ! for mass balancing - currentCohort%gpp_acc = currentCohort%npp_acc - currentCohort%resp_acc = 0._r8 - 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 + currentCohort%npp_acc_hold = currentCohort%npp_acc * real(hlm_days_per_year,r8) + currentCohort%gpp_acc_hold = currentCohort%gpp_acc * real(hlm_days_per_year,r8) + currentCohort%resp_acc_hold = currentCohort%resp_acc * real(hlm_days_per_year,r8) + ! Conduct Maintenance Turnover (parteh) if(debug) call currentCohort%prt%CheckMassConservation(ft,3) @@ -402,16 +422,84 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) hite_old = currentCohort%hite dbh_old = currentCohort%dbh - + ! ----------------------------------------------------------------------------- ! Growth and Allocation (PARTEH) + ! ----------------------------------------------------------------------------- + call currentCohort%prt%DailyPRT() - + + + ! Update the mass balance tracking for the daily nutrient uptake flux + ! Then zero out the daily uptakes, they have been used + ! ----------------------------------------------------------------------------- + + if(hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp ) then + + ! Mass balance for N uptake + currentSite%mass_balance(element_pos(nitrogen_element))%net_root_uptake = & + currentSite%mass_balance(element_pos(nitrogen_element))%net_root_uptake + & + (currentCohort%daily_n_uptake-currentCohort%daily_n_efflux)*currentCohort%n + + ! Mass balance for P uptake + currentSite%mass_balance(element_pos(phosphorus_element))%net_root_uptake = & + currentSite%mass_balance(element_pos(phosphorus_element))%net_root_uptake + & + (currentCohort%daily_p_uptake-currentCohort%daily_p_efflux)*currentCohort%n + + ! mass balance for C efflux (if any) + currentSite%mass_balance(element_pos(carbon12_element))%net_root_uptake = & + currentSite%mass_balance(element_pos(carbon12_element))%net_root_uptake - & + currentCohort%daily_c_efflux*currentCohort%n + + ! size class index + iscpf = currentCohort%size_by_pft_class + + ! Diagnostics for uptake, by size and pft, [kgX/ha/day] + currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_uptake_scpf(iscpf) = & + currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_uptake_scpf(iscpf) + & + currentCohort%daily_n_uptake*currentCohort%n + + currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_uptake_scpf(iscpf) = & + currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_uptake_scpf(iscpf) + & + currentCohort%daily_p_uptake*currentCohort%n + + ! Diagnostics on efflux, size and pft [kgX/ha/day] + currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_efflux_scpf(iscpf) = & + currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_efflux_scpf(iscpf) + & + currentCohort%daily_n_efflux*currentCohort%n + + currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_efflux_scpf(iscpf) = & + currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_efflux_scpf(iscpf) + & + currentCohort%daily_p_efflux*currentCohort%n + + currentSite%flux_diags(element_pos(carbon12_element))%nutrient_efflux_scpf(iscpf) = & + currentSite%flux_diags(element_pos(carbon12_element))%nutrient_efflux_scpf(iscpf) + & + currentCohort%daily_c_efflux*currentCohort%n + + ! Diagnostics on plant nutrient need + currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_needgrow_scpf(iscpf) = & + currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_needgrow_scpf(iscpf) + & + currentCohort%daily_n_need1*currentCohort%n + + currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_needmax_scpf(iscpf) = & + currentSite%flux_diags(element_pos(nitrogen_element))%nutrient_needmax_scpf(iscpf) + & + currentCohort%daily_n_need2*currentCohort%n + + currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_needgrow_scpf(iscpf) = & + currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_needgrow_scpf(iscpf) + & + currentCohort%daily_p_need1*currentCohort%n + + currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_needmax_scpf(iscpf) = & + currentSite%flux_diags(element_pos(phosphorus_element))%nutrient_needmax_scpf(iscpf) + & + currentCohort%daily_p_need2*currentCohort%n + + end if + ! And simultaneously add the input fluxes to mass balance accounting site_cmass%gpp_acc = site_cmass%gpp_acc + & currentCohort%gpp_acc * currentCohort%n site_cmass%aresp_acc = site_cmass%aresp_acc + & currentCohort%resp_acc * currentCohort%n - + call currentCohort%prt%CheckMassConservation(ft,5) ! Update the leaf biophysical rates based on proportion of leaf @@ -498,27 +586,38 @@ subroutine ed_integrate_state_variables(currentSite, bc_in ) call PreDisturbanceIntegrateLitter(currentPatch ) - - ! Update cohort number. - ! This needs to happen after the CWD_input and seed_input calculations as they - ! assume the pre-mortality currentCohort%n. + currentPatch => currentPatch%older + enddo + + ! Before we start messing with the patch areas, and before we start removing + ! trees, this is a good time to pass fragmentation litter fluxes and + ! plant-to-soil fluxes (such as efflux and fixation fluxes) + call FluxIntoLitterPools(currentsite, bc_in, bc_out) + + + ! Update cohort number. + ! This needs to happen after the CWD_input and seed_input calculations as they + ! assume the pre-mortality currentCohort%n. + + currentPatch => currentSite%youngest_patch + do while(associated(currentPatch)) currentCohort => currentPatch%shortest do while(associated(currentCohort)) - currentCohort%n = max(0._r8,currentCohort%n + currentCohort%dndt * hlm_freq_day ) - currentCohort => currentCohort%taller + currentCohort%n = max(0._r8,currentCohort%n + currentCohort%dndt * hlm_freq_day ) + currentCohort => currentCohort%taller enddo - currentPatch => currentPatch%older enddo + return end subroutine ed_integrate_state_variables !-------------------------------------------------------------------------------! - subroutine ed_update_site( currentSite, bc_in ) + subroutine ed_update_site( currentSite, bc_in, bc_out ) ! ! !DESCRIPTION: ! Calls routines to consolidate the ED growth process. @@ -532,7 +631,8 @@ subroutine ed_update_site( currentSite, bc_in ) ! ! !ARGUMENTS: type(ed_site_type) , intent(inout), target :: currentSite - type(bc_in_type) , intent(in) :: bc_in + type(bc_in_type) , intent(in) :: bc_in + type(bc_out_type) , intent(inout) :: bc_out ! ! !LOCAL VARIABLES: type (ed_patch_type) , pointer :: currentPatch @@ -561,6 +661,17 @@ subroutine ed_update_site( currentSite, bc_in ) currentPatch => currentPatch%younger enddo + ! Aggregate FATES litter output fluxes and + ! package them into boundary conditions + ! Note: The FATES state variables that generate these + ! boundary conditions are read in on the restart, + ! and, they are zero'd only at the start of ecosystem + ! dynamics + + ! Based on current status of the + call PrepNutrientAquisitionBCs(currentSite,bc_in,bc_out) + + ! FIX(RF,032414). This needs to be monthly, not annual ! If this is the second to last day of the year, then perform trimming if( hlm_day_of_year == hlm_days_per_year-1) then @@ -615,7 +726,7 @@ subroutine TotalBalanceCheck (currentSite, call_index ) type(ed_patch_type) , pointer :: currentPatch type(ed_cohort_type) , pointer :: currentCohort type(litter_type), pointer :: litt - logical, parameter :: print_cohorts = .false. ! Set to true if you want + logical, parameter :: print_cohorts = .true. ! Set to true if you want ! to print cohort data ! upon fail (lots of text) !----------------------------------------------------------------------- @@ -627,10 +738,10 @@ subroutine TotalBalanceCheck (currentSite, call_index ) do el = 1, num_elements + site_mass => currentSite%mass_balance(el) + call SiteMassStock(currentSite,el,total_stock,biomass_stock,litter_stock,seed_stock) - site_mass => currentSite%mass_balance(el) - change_in_stock = total_stock - site_mass%old_stock flux_in = site_mass%seed_in + & @@ -649,16 +760,18 @@ subroutine TotalBalanceCheck (currentSite, call_index ) net_flux = flux_in - flux_out error = abs(net_flux - change_in_stock) + if(change_in_stock>0.0)then error_frac = error/abs(total_stock) else error_frac = 0.0_r8 end if - if ( error_frac > 10e-6_r8 ) then + if ( error_frac > 10e-6_r8 .or. (error /= error) ) then write(fates_log(),*) 'mass balance error detected' write(fates_log(),*) 'element type (see PRTGenericMod.F90): ',element_list(el) write(fates_log(),*) 'error fraction relative to biomass stock: ',error_frac + write(fates_log(),*) 'absolut error (flux in - change): ',net_flux - change_in_stock write(fates_log(),*) 'call index: ',call_index write(fates_log(),*) 'Element index (PARTEH global):',element_list(el) write(fates_log(),*) 'net: ',net_flux @@ -712,6 +825,19 @@ subroutine TotalBalanceCheck (currentSite, call_index ) write(fates_log(),*) 'leaf: ',leaf_m,' structure: ',struct_m,' store: ',store_m write(fates_log(),*) 'fineroot: ',fnrt_m,' repro: ',repro_m,' sapwood: ',sapw_m write(fates_log(),*) 'num plant: ',currentCohort%n + write(fates_log(),*) 'resp m def: ',currentCohort%resp_m_def*currentCohort%n + + if(element_list(el).eq.nitrogen_element) then + write(fates_log(),*) 'N uptake: ',currentCohort%daily_n_uptake*currentCohort%n + write(fates_log(),*) 'N efflux: ',currentCohort%daily_n_efflux*currentCohort%n + elseif(element_list(el).eq.phosphorus_element) then + write(fates_log(),*) 'P uptake: ',currentCohort%daily_p_uptake*currentCohort%n + write(fates_log(),*) 'P efflux: ',currentCohort%daily_p_efflux*currentCohort%n + elseif(element_list(el).eq.carbon12_element) then + write(fates_log(),*) 'C efflux: ',currentCohort%daily_c_efflux*currentCohort%n + end if + + currentCohort => currentCohort%shorter enddo !end cohort loop end if @@ -783,6 +909,10 @@ subroutine bypass_dynamics(currentSite) currentCohort%dhdt = 0.0_r8 currentCohort%ddbhdt = 0.0_r8 + ! Shouldn't need to zero any nutrient fluxes + ! as they should just be zero, no uptake + ! in ST3 mode. + currentCohort => currentCohort%taller enddo currentPatch => currentPatch%older diff --git a/main/EDParamsMod.F90 b/main/EDParamsMod.F90 index dfaa4d00e4..8162939bc3 100644 --- a/main/EDParamsMod.F90 +++ b/main/EDParamsMod.F90 @@ -47,6 +47,7 @@ module EDParamsMod logical,protected, public :: active_crown_fire ! flag, 1=active crown fire 0=no active crown fire character(len=param_string_length),parameter :: fates_name_active_crown_fire = "fates_fire_active_crown_fire" + real(r8), protected, public :: cg_strikes ! fraction of cloud to ground lightning strikes (0-1) character(len=param_string_length),parameter :: fates_name_cg_strikes="fates_fire_cg_strikes" @@ -151,6 +152,11 @@ module EDParamsMod ! leftovers will be left onsite as large CWD character(len=param_string_length),parameter,public :: logging_name_export_frac ="fates_logging_export_frac" + real(r8),protected,public :: eca_plant_escalar ! scaling factor for plant fine root biomass to + ! calculate nutrient carrier enzyme abundance (ECA) + + character(len=param_string_length),parameter,public :: eca_name_plant_escalar = "fates_eca_plant_escalar" + public :: FatesParamsInit public :: FatesRegisterParams public :: FatesReceiveParams @@ -202,6 +208,7 @@ subroutine FatesParamsInit() logging_event_code = nan logging_dbhmax_infra = nan logging_export_frac = nan + eca_plant_escalar = nan q10_mr = nan q10_froz = nan @@ -341,6 +348,9 @@ subroutine FatesRegisterParams(fates_params) call fates_params%RegisterParameter(name=logging_name_export_frac, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=eca_name_plant_escalar, dimension_shape=dimension_shape_scalar, & + dimension_names=dim_names_scalar) + call fates_params%RegisterParameter(name=fates_name_q10_mr, dimension_shape=dimension_shape_scalar, & dimension_names=dim_names_scalar) @@ -490,6 +500,9 @@ subroutine FatesReceiveParams(fates_params) call fates_params%RetreiveParameter(name=logging_name_export_frac, & data=logging_export_frac) + call fates_params%RetreiveParameter(name=eca_name_plant_escalar, & + data=eca_plant_escalar) + call fates_params%RetreiveParameter(name=fates_name_q10_mr, & data=q10_mr) @@ -566,6 +579,7 @@ subroutine FatesReportParams(is_master) write(fates_log(),fmt0) 'logging_mechanical_frac = ',logging_mechanical_frac write(fates_log(),fmt0) 'logging_event_code = ',logging_event_code write(fates_log(),fmt0) 'logging_dbhmax_infra = ',logging_dbhmax_infra + write(fates_log(),fmt0) 'eca_plant_escalar = ',eca_plant_escalar write(fates_log(),fmt0) 'q10_mr = ',q10_mr write(fates_log(),fmt0) 'q10_froz = ',q10_froz write(fates_log(),fmt0) 'cg_strikes = ',cg_strikes diff --git a/main/EDPftvarcon.F90 b/main/EDPftvarcon.F90 index 6e61c45fd8..0a91c6a2ee 100644 --- a/main/EDPftvarcon.F90 +++ b/main/EDPftvarcon.F90 @@ -7,18 +7,26 @@ module EDPftvarcon ! ! !USES: use EDTypesMod , only : maxSWb, ivis, inir + use EDTypesMod , only : n_uptake_mode, p_uptake_mode use FatesConstantsMod, only : r8 => fates_r8 use FatesConstantsMod, only : nearzero use FatesConstantsMod, only : itrue, ifalse - use FatesConstantsMod, only : years_per_day + use PRTParametersMod, only : prt_params use FatesGlobals, only : fates_log use FatesGlobals, only : endrun => fates_endrun use FatesLitterMod, only : ilabile,icellulose,ilignin - 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 + use PRTGenericMod, only : prt_cnp_flex_allom_hyp,prt_carbon_allom_hyp + use FatesInterfaceTypesMod, only : hlm_nitrogen_spec, hlm_phosphorus_spec + use FatesInterfaceTypesMod, only : hlm_parteh_mode + use FatesInterfaceTypesMod, only : hlm_nu_com + use FatesConstantsMod , only : prescribed_p_uptake + use FatesConstantsMod , only : prescribed_n_uptake + use FatesConstantsMod , only : coupled_p_uptake + use FatesConstantsMod , only : coupled_n_uptake + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg @@ -36,45 +44,22 @@ module EDPftvarcon type, public :: EDPftvarcon_type real(r8), allocatable :: freezetol(:) ! minimum temperature tolerance - real(r8), allocatable :: wood_density(:) ! wood density g cm^-3 ... real(r8), allocatable :: hgt_min(:) ! sapling height m - real(r8), allocatable :: dbh_repro_threshold(:) ! diameter at which mature plants shift allocation real(r8), allocatable :: dleaf(:) ! leaf characteristic dimension length (m) real(r8), allocatable :: z0mr(:) ! ratio of roughness length of vegetation to height (-) real(r8), allocatable :: displar(:) ! ratio of displacement height to canopy top height (-) - real(r8), allocatable :: cushion(:) ! labile carbon storage target as multiple of leaf pool. - real(r8), allocatable :: leaf_stor_priority(:) ! leaf turnover vs labile carbon use prioritisation - ! (1 = lose leaves, 0 = use store). real(r8), allocatable :: crown(:) ! fraction of the height of the plant ! that is occupied by crown. For fire model. real(r8), allocatable :: bark_scaler(:) ! scaler from dbh to bark thickness. For fire model. real(r8), allocatable :: crown_kill(:) ! scaler on fire death. For fire model. real(r8), allocatable :: initd(:) ! initial seedling density + real(r8), allocatable :: seed_suppl(:) ! seeds that come from outside the gridbox. real(r8), allocatable :: bb_slope(:) ! ball berry slope parameter real(r8), allocatable :: medlyn_slope(:) ! Medlyn slope parameter KPa^0.5 real(r8), allocatable :: stomatal_intercept(:) ! intercept of stomatal conductance model - real(r8), allocatable :: 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] - real(r8), allocatable :: woody(:) ! Does the plant have wood? (1=yes, 0=no) - - ! The following three PFT classes - ! are mutually exclusive - real(r8), allocatable :: stress_decid(:) ! Is the plant stress deciduous? (1=yes, 0=no) - real(r8), allocatable :: season_decid(:) ! Is the plant seasonally deciduous (1=yes, 0=no) - real(r8), allocatable :: evergreen(:) ! Is the plant an evergreen (1=yes, 0=no) - - real(r8), allocatable :: slamax(:) ! Maximum specific leaf area of plant (at bottom) [m2/gC] - real(r8), allocatable :: slatop(:) ! Specific leaf area at canopy top [m2/gC] - - real(r8), allocatable :: fnrt_prof_mode(:) ! Index to select fine root profile function: - ! 1) Jackson Beta, 2) 1-param exponential - ! 3) 2-param exponential 4) Zeng (not yet unified) - real(r8),allocatable :: fnrt_prof_a(:) ! a parameter for fine-root profile (1st parameter) - real(r8),allocatable :: fnrt_prof_b(:) ! b parameter for fine-root profile (2nd parameter) + real(r8), allocatable :: lf_flab(:) ! Leaf litter labile fraction [-] real(r8), allocatable :: lf_fcel(:) ! Leaf litter cellulose fraction [-] real(r8), allocatable :: lf_flig(:) ! Leaf litter lignan fraction [-] @@ -128,52 +113,17 @@ module EDPftvarcon real(r8), allocatable :: taul(:, :) real(r8), allocatable :: taus(:, :) - - - ! Fire Parameters (No PFT vector capabilities in their own routines) ! See fire/SFParamsMod.F90 for bulk of fire parameters ! ------------------------------------------------------------------------------------------- real(r8), allocatable :: fire_alpha_SH(:) ! spitfire parameter, alpha scorch height ! Equation 16 Thonicke et al 2010 - ! Allometry Parameters + ! Non-PARTEH Allometry Parameters ! -------------------------------------------------------------------------------------------- - real(r8), allocatable :: allom_dbh_maxheight(:) ! dbh at which height growth ceases - - real(r8), allocatable :: allom_hmode(:) ! height allometry function type - real(r8), allocatable :: allom_lmode(:) ! maximum leaf allometry function type - real(r8), allocatable :: allom_fmode(:) ! maximum root allometry function type - real(r8), allocatable :: allom_amode(:) ! AGB allometry function type - real(r8), allocatable :: allom_cmode(:) ! Coarse root allometry function type - real(r8), allocatable :: allom_smode(:) ! sapwood allometry function type - real(r8), allocatable :: allom_stmode(:) ! storage allometry functional type - ! (HARD-CODED FOR TIME BEING, RGK 11-2017) - real(r8), allocatable :: allom_la_per_sa_int(:) ! Leaf area to sap area conversion, intercept - ! (sapwood area / leaf area) [cm2/m2] - real(r8), allocatable :: allom_la_per_sa_slp(:) ! Leaf area to sap area conversion, slope - ! (sapwood area / leaf area / diameter) [cm2/m2/cm] - real(r8), allocatable :: allom_l2fr(:) ! Fine root biomass per leaf biomass ratio [kgC/kgC] - real(r8), allocatable :: allom_agb_frac(:) ! Fraction of stem above ground [-] - real(r8), allocatable :: allom_d2h1(:) ! Parameter 1 for d2h allometry (intercept, or "c") - real(r8), allocatable :: allom_d2h2(:) ! Parameter 2 for d2h allometry (slope, or "m") - real(r8), allocatable :: allom_d2h3(:) ! Parameter 3 for d2h allometry (optional) - real(r8), allocatable :: allom_d2bl1(:) ! Parameter 1 for d2bl allometry (intercept) - real(r8), allocatable :: allom_d2bl2(:) ! Parameter 2 for d2bl allometry (slope) - real(r8), allocatable :: allom_d2bl3(:) ! Parameter 3 for d2bl allometry (optional) - real(r8), allocatable :: allom_sai_scaler(:) ! - real(r8), allocatable :: allom_blca_expnt_diff(:) ! Any difference in the exponent between the leaf - ! biomass and crown area scaling - real(r8), allocatable :: allom_d2ca_coefficient_max(:) ! upper (savanna) value for crown - ! area to dbh coefficient - real(r8), allocatable :: allom_d2ca_coefficient_min(:) ! lower (closed-canopy forest) value for crown - ! area to dbh coefficient - real(r8), allocatable :: allom_agb1(:) ! Parameter 1 for agb allometry - real(r8), allocatable :: allom_agb2(:) ! Parameter 2 for agb allometry - real(r8), allocatable :: allom_agb3(:) ! Parameter 3 for agb allometry - real(r8), allocatable :: allom_agb4(:) ! Parameter 3 for agb allometry - - real(r8), allocatable :: allom_frbstor_repro(:) ! fraction of bstrore for reproduction after mortality + + + real(r8), allocatable :: allom_frbstor_repro(:) ! fraction of bstrore for reproduction after mortality ! Prescribed Physiology Mode Parameters real(r8), allocatable :: prescribed_npp_canopy(:) ! this is only for the @@ -187,41 +137,8 @@ module EDPftvarcon real(r8), allocatable :: prescribed_recruitment(:) ! this is only for the ! 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 phosphorus stoichiometry (pft x organ) - real(r8), allocatable :: prt_phos_stoich_p2(:,:) ! Parameter 2 for phosphorus stoichiometry (pft x organ) - real(r8), allocatable :: prt_alloc_priority(:,:) ! Allocation priority for each organ (pft x organ) [integer 0-6] - - ! Nutrient Aquisition parameters - - real(r8), allocatable :: prescribed_nuptake(:) ! Nitrogen uptake flux per unit crown area - ! (negative implies fraction of NPP) kgN/m2/yr - - real(r8), allocatable :: prescribed_puptake(:) ! Phosphorus uptake flux per unit crown area - ! (negative implies fraction of NPP) kgP/m2/yr - - ! (NONE OF THESE ARE ACTIVE YET - PLACEHOLDERS ONLY!!!!!) - ! Nutrient Aquisition (ECA & RD) -! real(r8), allocatable :: decompmicc(:) ! microbial decomposer biomass gC/m3 + real(r8), allocatable :: decompmicc(:) ! microbial decomposer biomass gC/m3 ! on root surface ! ECA Parameters: See Zhu et al. Multiple soil nutrient competition between plants, @@ -232,25 +149,24 @@ module EDPftvarcon ! VMAX: Product of the reaction-rate and enzyme abundance for each PFT in ECA ! Note*: units of [gC] is grams carbon of fine-root - real(r8), allocatable :: eca_km_nh4(:) ! half-saturation constant for plant nh4 uptake [gN/m3] - real(r8), allocatable :: eca_vmax_nh4(:) ! maximum production rate for plant nh4 uptake [gN/gC/s] - real(r8), allocatable :: eca_km_no3(:) ! half-saturation constant for plant no3 uptake [gN/m3] - real(r8), allocatable :: eca_vmax_no3(:) ! maximum production rate for plant no3 uptake [gN/gC/s] - real(r8), allocatable :: eca_km_p(:) ! half-saturation constant for plant p uptake [gP/m3] - real(r8), allocatable :: eca_vmax_p(:) ! maximum production rate for plant p uptake [gP/gC/s] + real(r8), allocatable :: eca_km_nh4(:) ! half-saturation constant for plant nh4 uptake [gN/m3] + real(r8), allocatable :: eca_vmax_nh4(:) ! maximum production rate for plant nh4 uptake [gN/gC/s] + real(r8), allocatable :: eca_km_no3(:) ! half-saturation constant for plant no3 uptake [gN/m3] + real(r8), allocatable :: eca_vmax_no3(:) ! maximum production rate for plant no3 uptake [gN/gC/s] + real(r8), allocatable :: eca_km_p(:) ! half-saturation constant for plant p uptake [gP/m3] + real(r8), allocatable :: eca_vmax_p(:) ! maximum production rate for plant p uptake [gP/gC/s] real(r8), allocatable :: eca_km_ptase(:) ! half-saturation constant for biochemical P production [gP/m3] - real(r8), allocatable :: eca_vmax_ptase(:) ! maximum production rate for biochemical P prod [gP/m2/s] + real(r8), allocatable :: eca_vmax_ptase(:) ! maximum production rate for biochemical P prod [gP/gC/s] real(r8), allocatable :: eca_alpha_ptase(:) ! Fraction of min P generated from ptase activity ! that is immediately sent to the plant [/] real(r8), allocatable :: eca_lambda_ptase(:) ! critical value for Ptase that incurs ! biochemical production, fraction based how much ! more in need a plant is for P versus N [/] - - real(r8), allocatable :: nfix1(:) ! nitrogen fixation parameter 1 (in file, but not used yet) - real(r8), allocatable :: nfix2(:) ! nitrogen fixation parameter 2 (in file, but not used yet) - + !real(r8), allocatable :: nfix1(:) ! nitrogen fixation parameter 1 + !real(r8), allocatable :: nfix2(:) ! nitrogen fixation parameter 2 + ! Turnover related things real(r8), allocatable :: phenflush_fraction(:) ! Maximum fraction of storage carbon used to flush leaves @@ -260,22 +176,15 @@ module EDPftvarcon real(r8), allocatable :: phen_stem_drop_fraction(:) ! Fraction of stem dropped/senescened for decidious ! non-woody (grass) plants - real(r8), allocatable :: senleaf_long_fdrought(:) ! Multiplication factor for leaf longevity of senescent - ! leaves during drought( 1.0 indicates no change) - - 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(:,:) ! phosphorus re-translocation fraction (pft x organ) + ! Nutrient Aquisition parameters + real(r8), allocatable :: prescribed_nuptake(:) ! If there is no soil BGC model active, + ! prescribe an uptake rate for nitrogen, this is the fraction of plant demand - ! Parameters dimensioned by PFT and leaf age - real(r8), allocatable :: leaf_long(:,:) ! Leaf turnover time (longevity) (pft x age-class) - ! If there is >1 class, it is the longevity from - ! one class to the next [yr] + real(r8), allocatable :: prescribed_puptake(:) ! If there is no soil BGC model active, + ! prescribe an uptake rate for phosphorus + ! This is the fraction of plant demand + ! Parameters dimensioned by PFT and leaf age real(r8), allocatable :: vcmax25top(:,:) ! maximum carboxylation rate of Rub. at 25C, ! canopy top [umol CO2/m^2/s]. Dimensioned by ! leaf age-class @@ -307,12 +216,8 @@ module EDPftvarcon procedure, public :: Receive procedure, private :: Register_PFT procedure, private :: Receive_PFT - procedure, private :: Register_PFT_nvariants - procedure, private :: Receive_PFT_nvariants procedure, private :: Register_PFT_hydr_organs procedure, private :: Receive_PFT_hydr_organs - procedure, private :: Register_PFT_prt_organs - procedure, private :: Receive_PFT_prt_organs procedure, private :: Register_PFT_leafage procedure, private :: Receive_PFT_leafage procedure, private :: Register_PFT_numrad @@ -355,9 +260,7 @@ subroutine Register(this, fates_params) call this%Register_PFT(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) call this%Register_PFT_leafage(fates_params) end subroutine Register @@ -374,9 +277,7 @@ subroutine Receive(this, fates_params) call this%Receive_PFT(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) call this%Receive_PFT_leafage(fates_params) end subroutine Receive @@ -402,30 +303,14 @@ subroutine Register_PFT(this, fates_params) !X! call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & !X! dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_seed_dbh_repro_threshold' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_mort_freezetol' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_wood_density' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_recruit_hgt_min' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_alloc_storage_cushion' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_leaf_stor_priority' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_fire_crown_depth_frac' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -458,66 +343,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_senleaf_long_fdrought' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_root_long' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_seed_alloc_mature' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_seed_alloc' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_c2b' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_woody' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_phen_stress_decid' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_phen_season_decid' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_phen_evergreen' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_l2fr' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_leaf_slamax' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_leaf_slatop' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_fnrt_prof_mode' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_fnrt_prof_a' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_fnrt_prof_b' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_lf_flab' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -563,10 +388,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_grperc' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_maintresp_reduction_curvature' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -599,106 +420,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_allom_dbh_maxheight' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_hmode' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_lmode' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_fmode' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_amode' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_stmode' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_cmode' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_smode' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_la_per_sa_int' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_la_per_sa_slp' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_agb_frac' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_d2h1' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_d2h2' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_d2h3' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_d2bl1' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_d2bl2' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_d2bl3' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_blca_expnt_diff' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_d2ca_coefficient_max' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_d2ca_coefficient_min' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_sai_scaler' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_agb1' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_agb2' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_agb3' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_allom_agb4' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_allom_frbstor_repro' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -811,14 +532,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_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) - name = 'fates_trim_limit' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -853,55 +566,48 @@ subroutine Register_PFT(this, fates_params) ! Nutrient competition parameters -! name = 'fates_eca_decompmicc' -! call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & -! dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_eca_decompmicc' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + name = 'fates_eca_km_nh4' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'fates_eca_vmax_nh4' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'fates_eca_km_no3' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'fates_eca_vmax_no3' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'fates_eca_km_p' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'fates_eca_vmax_p' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'fates_eca_km_ptase' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) + dimension_names=dim_names, lower_bounds=dim_lower_bound) name = 'fates_eca_vmax_ptase' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_eca_alpha_ptase' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - - name = 'fates_eca_lambda_ptase' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) + dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_nfix1' + name = 'fates_eca_alpha_ptase' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_nfix2' + name = 'fates_eca_lambda_ptase' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -931,30 +637,14 @@ subroutine Receive_PFT(this, fates_params) !X! call fates_params%RetreiveParameter(name=name, & !X! data=this%) - name = 'fates_seed_dbh_repro_threshold' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%dbh_repro_threshold) - name = 'fates_mort_freezetol' call fates_params%RetreiveParameterAllocate(name=name, & data=this%freezetol) - name = 'fates_wood_density' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%wood_density) - name = 'fates_recruit_hgt_min' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hgt_min) - name = 'fates_alloc_storage_cushion' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%cushion) - - name = 'fates_leaf_stor_priority' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%leaf_stor_priority) - name = 'fates_fire_crown_depth_frac' call fates_params%RetreiveParameterAllocate(name=name, & data=this%crown) @@ -987,63 +677,6 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%stomatal_intercept) - name = 'fates_senleaf_long_fdrought' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%senleaf_long_fdrought) - - name = 'fates_root_long' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%root_long) - - name = 'fates_seed_alloc_mature' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%seed_alloc_mature) - - name = 'fates_seed_alloc' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%seed_alloc) - - name = 'fates_c2b' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%c2b) - - name = 'fates_woody' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%woody) - - name = 'fates_phen_stress_decid' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%stress_decid) - - name = 'fates_phen_season_decid' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%season_decid) - - name = 'fates_phen_evergreen' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%evergreen) - - name = 'fates_leaf_slamax' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%slamax) - - name = 'fates_leaf_slatop' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%slatop) - - name = 'fates_fnrt_prof_mode' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%fnrt_prof_mode) - - name = 'fates_fnrt_prof_a' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%fnrt_prof_a) - - name = 'fates_fnrt_prof_b' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%fnrt_prof_b) - - name = 'fates_lf_flab' call fates_params%RetreiveParameterAllocate(name=name, & data=this%lf_flab) @@ -1088,10 +721,6 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%smpsc) - name = 'fates_grperc' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%grperc) - name = 'fates_maintresp_reduction_curvature' call fates_params%RetreiveParameterAllocate(name=name, & data=this%maintresp_reduction_curvature) @@ -1124,141 +753,50 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%fire_alpha_SH) - name = 'fates_allom_dbh_maxheight' + name = 'fates_allom_frbstor_repro' call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_dbh_maxheight) + data=this%allom_frbstor_repro) - name = 'fates_allom_hmode' + name = 'fates_hydr_p_taper' call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_hmode) + data=this%hydr_p_taper) - name = 'fates_allom_lmode' + name = 'fates_hydr_rs2' call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_lmode) - - name = 'fates_allom_fmode' + data=this%hydr_rs2) + + name = 'fates_hydr_srl' call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_fmode) - - name = 'fates_allom_amode' + data=this%hydr_srl) + + name = 'fates_hydr_rfrac_stem' call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_amode) + data=this%hydr_rfrac_stem) - name = 'fates_allom_stmode' + name = 'fates_hydr_avuln_gs' call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_stmode) - - name = 'fates_allom_cmode' + data=this%hydr_avuln_gs) + + name = 'fates_hydr_p50_gs' call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_cmode) + data=this%hydr_p50_gs) - name = 'fates_allom_smode' + name = 'fates_mort_bmort' call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_smode) - - name = 'fates_allom_la_per_sa_int' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_la_per_sa_int) - - name = 'fates_allom_la_per_sa_slp' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_la_per_sa_slp) - - name = 'fates_allom_l2fr' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_l2fr) - - name = 'fates_allom_agb_frac' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_agb_frac) - - name = 'fates_allom_d2h1' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_d2h1) - - name = 'fates_allom_d2h2' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_d2h2) - - name = 'fates_allom_d2h3' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_d2h3) - - name = 'fates_allom_d2bl1' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_d2bl1) - - name = 'fates_allom_d2bl2' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_d2bl2) - - name = 'fates_allom_d2bl3' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_d2bl3) - - name = 'fates_allom_blca_expnt_diff' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_blca_expnt_diff) - - name = 'fates_allom_d2ca_coefficient_max' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_d2ca_coefficient_max) - - name = 'fates_allom_d2ca_coefficient_min' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_d2ca_coefficient_min) - - name = 'fates_allom_sai_scaler' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_sai_scaler) - - name = 'fates_allom_agb1' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_agb1) - - name = 'fates_allom_agb2' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_agb2) - - name = 'fates_allom_agb3' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_agb3) - - name = 'fates_allom_agb4' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_agb4) - - name = 'fates_allom_frbstor_repro' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%allom_frbstor_repro) + data=this%bmort) - name = 'fates_hydr_p_taper' + name = 'fates_mort_scalar_coldstress' call fates_params%RetreiveParameterAllocate(name=name, & - data=this%hydr_p_taper) + data=this%mort_scalar_coldstress) - name = 'fates_hydr_rs2' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%hydr_rs2) - - name = 'fates_hydr_srl' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%hydr_srl) - - name = 'fates_hydr_rfrac_stem' + name = 'fates_mort_scalar_cstarvation' call fates_params%RetreiveParameterAllocate(name=name, & - data=this%hydr_rfrac_stem) + data=this%mort_scalar_cstarvation) - name = 'fates_hydr_avuln_gs' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%hydr_avuln_gs) - - name = 'fates_hydr_p50_gs' + name = 'fates_mort_scalar_hydrfailure' call fates_params%RetreiveParameterAllocate(name=name, & - data=this%hydr_p50_gs) + data=this%mort_scalar_hydrfailure) - name = 'fates_mort_bmort' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%bmort) name = 'fates_mort_ip_size_senescence' call fates_params%RetreiveParameterAllocate(name=name, & @@ -1284,10 +822,7 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%mort_scalar_cstarvation) - name = 'fates_mort_scalar_hydrfailure' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%mort_scalar_hydrfailure) - + name = 'fates_mort_hf_sm_threshold' call fates_params%RetreiveParameterAllocate(name=name, & data=this%hf_sm_threshold) @@ -1340,14 +875,6 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%seed_decay_rate) - 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, & data=this%trim_limit) @@ -1372,15 +899,6 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%phenflush_fraction) - name = 'fates_phen_cold_size_threshold' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%phen_cold_size_threshold) - - name = 'fates_phen_stem_drop_fraction' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%phen_stem_drop_fraction) - - name = 'fates_phen_cold_size_threshold' call fates_params%RetreiveParameterAllocate(name=name, & data=this%phen_cold_size_threshold) @@ -1389,18 +907,26 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%phen_stem_drop_fraction) -! name = 'fates_eca_decompmicc' -! call fates_params%RetreiveParameterAllocate(name=name, & -! data=this%eca_decompmicc) + name = 'fates_prescribed_nuptake' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%prescribed_nuptake) + + name = 'fates_prescribed_puptake' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%prescribed_puptake) + + name = 'fates_eca_decompmicc' + call fates_params%RetreiveParameterAllocate(name=name, & + data=this%decompmicc) name = 'fates_eca_km_nh4' call fates_params%RetreiveParameterAllocate(name=name, & data=this%eca_km_nh4) - + name = 'fates_eca_vmax_nh4' call fates_params%RetreiveParameterAllocate(name=name, & data=this%eca_vmax_nh4) - + name = 'fates_eca_km_no3' call fates_params%RetreiveParameterAllocate(name=name, & data=this%eca_km_no3) @@ -1433,22 +959,6 @@ subroutine Receive_PFT(this, fates_params) call fates_params%RetreiveParameterAllocate(name=name, & data=this%eca_lambda_ptase) - name = 'fates_nfix1' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%nfix1) - - name = 'fates_nfix2' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%nfix2) - - name = 'fates_prescribed_nuptake' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%prescribed_nuptake) - - name = 'fates_prescribed_puptake' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%prescribed_puptake) - end subroutine Receive_PFT !----------------------------------------------------------------------- @@ -1617,51 +1127,6 @@ subroutine Receive_PFT_numrad(this, fates_params) end subroutine Receive_PFT_numrad - !----------------------------------------------------------------------- - subroutine Register_PFT_nvariants(this, fates_params) - - use FatesParametersInterface, only : fates_parameters_type, param_string_length - use FatesParametersInterface, only : max_dimensions, dimension_name_variants, dimension_name_pft, dimension_shape_2d - - implicit none - - class(EDPftvarcon_type), intent(inout) :: this - class(fates_parameters_type), intent(inout) :: fates_params - - integer, parameter :: dim_lower_bound(2) = (/ lower_bound_pft, lower_bound_general /) - character(len=param_string_length) :: dim_names(2) - character(len=param_string_length) :: name - - ! NOTE(bja, 2017-01) initialization doesn't seem to work correctly - ! if dim_names has a parameter qualifier. - dim_names(1) = dimension_name_pft - dim_names(2) = dimension_name_variants - - !X! name = '' - !X! call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & - !X! dimension_names=dim_names) - - end subroutine Register_PFT_nvariants - - !----------------------------------------------------------------------- - subroutine Receive_PFT_nvariants(this, fates_params) - - use FatesParametersInterface, only : fates_parameters_type - use FatesParametersInterface, only : param_string_length - - implicit none - - class(EDPftvarcon_type), intent(inout) :: this - class(fates_parameters_type), intent(inout) :: fates_params - - character(len=param_string_length) :: name - - !X! name = '' - !X! call fates_params%RetreiveParameter(name=name, & - !X! data=this%) - - - end subroutine Receive_PFT_nvariants ! ----------------------------------------------------------------------- @@ -1683,10 +1148,6 @@ subroutine Register_PFT_leafage(this, fates_params) dim_names(1) = dimension_name_pft dim_names(2) = dimension_name_leaf_age - name = 'fates_leaf_long' - call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & - dimension_names=dim_names, lower_bounds=dim_lower_bound) - name = 'fates_leaf_vcmax25top' call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & dimension_names=dim_names, lower_bounds=dim_lower_bound) @@ -1708,10 +1169,6 @@ subroutine Receive_PFT_leafage(this, fates_params) class(fates_parameters_type), intent(inout) :: fates_params character(len=param_string_length) :: name - - name = 'fates_leaf_long' - call fates_params%RetreiveParameterAllocate(name=name, & - data=this%leaf_long) name = 'fates_leaf_vcmax25top' call fates_params%RetreiveParameterAllocate(name=name, & @@ -1722,112 +1179,6 @@ end subroutine Receive_PFT_leafage ! ===================================================================================== - - 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 @@ -1951,7 +1302,7 @@ subroutine FatesReportPFTParams(is_master) integer :: npft,ipft - npft = size(EDPftvarcon_inst%evergreen,1) + npft = size(EDPftvarcon_inst%initd,1) if(debug_report .and. is_master) then @@ -1963,16 +1314,11 @@ subroutine FatesReportPFTParams(is_master) end if write(fates_log(),*) '----------- FATES PFT Parameters -----------------' - write(fates_log(),fmt0) 'dbh max height = ',EDPftvarcon_inst%allom_dbh_maxheight - write(fates_log(),fmt0) 'dbh mature = ',EDPftvarcon_inst%dbh_repro_threshold write(fates_log(),fmt0) 'freezetol = ',EDPftvarcon_inst%freezetol - write(fates_log(),fmt0) 'wood_density = ',EDPftvarcon_inst%wood_density write(fates_log(),fmt0) 'hgt_min = ',EDPftvarcon_inst%hgt_min write(fates_log(),fmt0) 'dleaf = ',EDPftvarcon_inst%dleaf write(fates_log(),fmt0) 'z0mr = ',EDPftvarcon_inst%z0mr write(fates_log(),fmt0) 'displar = ',EDPftvarcon_inst%displar - write(fates_log(),fmt0) 'cushion = ',EDPftvarcon_inst%cushion - write(fates_log(),fmt0) 'leaf_stor_priority = ',EDPftvarcon_inst%leaf_stor_priority write(fates_log(),fmt0) 'crown = ',EDPftvarcon_inst%crown write(fates_log(),fmt0) 'bark_scaler = ',EDPftvarcon_inst%bark_scaler write(fates_log(),fmt0) 'crown_kill = ',EDPftvarcon_inst%crown_kill @@ -1981,20 +1327,6 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'bb_slope = ',EDPftvarcon_inst%bb_slope write(fates_log(),fmt0) 'medlyn_slope = ',EDPftvarcon_inst%medlyn_slope write(fates_log(),fmt0) 'stomatal_intercept = ',EDPftvarcon_inst%stomatal_intercept - write(fates_log(),fmt0) 'root_long = ',EDPftvarcon_inst%root_long - write(fates_log(),fmt0) 'senleaf_long_fdrought = ',EDPftvarcon_inst%senleaf_long_fdrought - write(fates_log(),fmt0) 'seed_alloc_mature = ',EDPftvarcon_inst%seed_alloc_mature - write(fates_log(),fmt0) 'seed_alloc = ',EDPftvarcon_inst%seed_alloc - write(fates_log(),fmt0) 'woody = ',EDPftvarcon_inst%woody - write(fates_log(),fmt0) 'stress_decid = ',EDPftvarcon_inst%stress_decid - write(fates_log(),fmt0) 'season_decid = ',EDPftvarcon_inst%season_decid - write(fates_log(),fmt0) 'evergreen = ',EDPftvarcon_inst%evergreen - write(fates_log(),fmt0) 'slamax = ',EDPftvarcon_inst%slamax - write(fates_log(),fmt0) 'slatop = ',EDPftvarcon_inst%slatop - write(fates_log(),fmt0) 'leaf_long = ',EDPftvarcon_inst%leaf_long - write(fates_log(),fmt0) 'fnrt_prof_mode = ',EDPftvarcon_inst%fnrt_prof_mode - write(fates_log(),fmt0) 'fnrt_prof_a = ',EDPftvarcon_inst%fnrt_prof_a - write(fates_log(),fmt0) 'fnrt_prof_b = ',EDPftvarcon_inst%fnrt_prof_b write(fates_log(),fmt0) 'lf_flab = ',EDPftvarcon_inst%lf_flab write(fates_log(),fmt0) 'lf_fcel = ',EDPftvarcon_inst%lf_fcel write(fates_log(),fmt0) 'lf_flig = ',EDPftvarcon_inst%lf_flig @@ -2007,8 +1339,6 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'vcmax25top = ',EDPftvarcon_inst%vcmax25top write(fates_log(),fmt0) 'smpso = ',EDPftvarcon_inst%smpso write(fates_log(),fmt0) 'smpsc = ',EDPftvarcon_inst%smpsc - write(fates_log(),fmt0) 'grperc = ',EDPftvarcon_inst%grperc - write(fates_log(),fmt0) 'c2b = ',EDPftvarcon_inst%c2b write(fates_log(),fmt0) 'bmort = ',EDPftvarcon_inst%bmort write(fates_log(),fmt0) 'mort_ip_size_senescence = ', EDPftvarcon_inst%mort_ip_size_senescence write(fates_log(),fmt0) 'mort_r_size_senescence = ', EDPftvarcon_inst%mort_r_size_senescence @@ -2028,9 +1358,8 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'vcmaxse = ',EDPftvarcon_inst%vcmaxse write(fates_log(),fmt0) 'jmaxse = ',EDPftvarcon_inst%jmaxse write(fates_log(),fmt0) 'tpuse = ',EDPftvarcon_inst%tpuse - write(fates_log(),fmt0) 'germination_rate = ',EDPftvarcon_inst%germination_rate - write(fates_log(),fmt0) 'seed_decay_rate = ',EDPftvarcon_inst%seed_decay_rate - write(fates_log(),fmt0) 'branch_turnover = ',EDPftvarcon_inst%branch_turnover + write(fates_log(),fmt0) 'germination_timescale = ',EDPftvarcon_inst%germination_rate + write(fates_log(),fmt0) 'seed_decay_turnover = ',EDPftvarcon_inst%seed_decay_rate write(fates_log(),fmt0) 'trim_limit = ',EDPftvarcon_inst%trim_limit write(fates_log(),fmt0) 'trim_inc = ',EDPftvarcon_inst%trim_inc write(fates_log(),fmt0) 'rhol = ',EDPftvarcon_inst%rhol @@ -2041,30 +1370,6 @@ subroutine FatesReportPFTParams(is_master) write(fates_log(),fmt0) 'phen_cold_size_threshold = ',EDPftvarcon_inst%phen_cold_size_threshold write(fates_log(),fmt0) 'phen_stem_drop_fraction',EDpftvarcon_inst%phen_stem_drop_fraction write(fates_log(),fmt0) 'fire_alpha_SH = ',EDPftvarcon_inst%fire_alpha_SH - write(fates_log(),fmt0) 'allom_hmode = ',EDPftvarcon_inst%allom_hmode - write(fates_log(),fmt0) 'allom_lmode = ',EDPftvarcon_inst%allom_lmode - write(fates_log(),fmt0) 'allom_fmode = ',EDPftvarcon_inst%allom_fmode - write(fates_log(),fmt0) 'allom_amode = ',EDPftvarcon_inst%allom_amode - write(fates_log(),fmt0) 'allom_cmode = ',EDPftvarcon_inst%allom_cmode - write(fates_log(),fmt0) 'allom_smode = ',EDPftvarcon_inst%allom_smode - write(fates_log(),fmt0) 'allom_la_per_sa_int = ',EDPftvarcon_inst%allom_la_per_sa_int - write(fates_log(),fmt0) 'allom_la_per_sa_slp = ',EDPftvarcon_inst%allom_la_per_sa_slp - write(fates_log(),fmt0) 'allom_l2fr = ',EDPftvarcon_inst%allom_l2fr - write(fates_log(),fmt0) 'allom_agb_frac = ',EDPftvarcon_inst%allom_agb_frac - write(fates_log(),fmt0) 'allom_d2h1 = ',EDPftvarcon_inst%allom_d2h1 - write(fates_log(),fmt0) 'allom_d2h2 = ',EDPftvarcon_inst%allom_d2h2 - write(fates_log(),fmt0) 'allom_d2h3 = ',EDPftvarcon_inst%allom_d2h3 - write(fates_log(),fmt0) 'allom_d2bl1 = ',EDPftvarcon_inst%allom_d2bl1 - write(fates_log(),fmt0) 'allom_d2bl2 = ',EDPftvarcon_inst%allom_d2bl2 - write(fates_log(),fmt0) 'allom_d2bl3 = ',EDPftvarcon_inst%allom_d2bl3 - write(fates_log(),fmt0) 'allom_sai_scaler = ',EDPftvarcon_inst%allom_sai_scaler - write(fates_log(),fmt0) 'allom_blca_expnt_diff = ',EDPftvarcon_inst%allom_blca_expnt_diff - write(fates_log(),fmt0) 'allom_d2ca_coefficient_max = ',EDPftvarcon_inst%allom_d2ca_coefficient_max - write(fates_log(),fmt0) 'allom_d2ca_coefficient_min = ',EDPftvarcon_inst%allom_d2ca_coefficient_min - write(fates_log(),fmt0) 'allom_agb1 = ',EDPftvarcon_inst%allom_agb1 - 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) 'allom_frbstor_repro = ',EDPftvarcon_inst%allom_frbstor_repro write(fates_log(),fmt0) 'hydr_p_taper = ',EDPftvarcon_inst%hydr_p_taper write(fates_log(),fmt0) 'hydr_rs2 = ',EDPftvarcon_inst%hydr_rs2 @@ -2081,19 +1386,6 @@ 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 @@ -2103,7 +1395,7 @@ end subroutine FatesReportPFTParams ! ===================================================================================== - subroutine FatesCheckParams(is_master, parteh_mode) + subroutine FatesCheckParams(is_master) ! ---------------------------------------------------------------------------------- ! @@ -2120,7 +1412,6 @@ subroutine FatesCheckParams(is_master, parteh_mode) ! Argument 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))' @@ -2130,45 +1421,80 @@ subroutine FatesCheckParams(is_master, parteh_mode) integer :: iage ! leaf age class index integer :: norgans ! size of the plant organ dimension - npft = size(EDPftvarcon_inst%evergreen,1) + npft = size(EDPftvarcon_inst%freezetol,1) - ! Prior to performing checks copy grperc to the - ! organ dimensioned version + if(.not.is_master) return - 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 (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then + + ! Check to see if either RD/ECA/MIC is turned on + + if (.not.( (trim(hlm_nu_com).eq.'RD') .or. (trim(hlm_nu_com).eq.'ECA'))) then + write(fates_log(),*) 'FATES PARTEH with allometric flexible CNP must have' + write(fates_log(),*) 'a valid BGC model enabled: RD,ECA,MIC or SYN' + write(fates_log(),*) 'nu_comp: ',trim(hlm_nu_com) + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! If nitrogen is turned on, check to make sure there are valid ammonium + ! parameters + if(hlm_nitrogen_spec>0)then + if (trim(hlm_nu_com).eq.'ECA') then + + if(any(EDpftvarcon_inst%eca_km_nh4(:)<0._r8) ) then + write(fates_log(),*) 'ECA with nitrogen is turned on' + write(fates_log(),*) 'bad ECA km value(s) for nh4: ',EDpftvarcon_inst%eca_km_nh4(:) + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_nitrogen_spec==2)then + if(any(EDpftvarcon_inst%eca_km_no3(:)<0._r8)) then + write(fates_log(),*) 'ECA with nit/denitr is turned on' + write(fates_log(),*) 'bad ECA km value(s) for no3: ',EDpftvarcon_inst%eca_km_no3(:) + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if - 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__)) + end if + end if - elseif (parteh_mode .ne. prt_carbon_allom_hyp) then + elseif (hlm_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(),*) 'only 2 modules supported, allometric carbon and CNP.' + write(fates_log(),*) 'fates_parteh_mode must be set to 1 or 2 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' + ! If any PFTs are specified as either prescribed N or P uptake + ! then they all must be ! + + if (any(EDPftvarcon_inst%prescribed_nuptake(:) < -nearzero ) .or. & + any(EDPftvarcon_inst%prescribed_nuptake(:) > 10._r8 ) ) then + write(fates_log(),*) 'Negative values for EDPftvarcon_inst%prescribed_nuptake(:)' + write(fates_log(),*) 'are not allowed. Reasonable ranges for this parameter are zero' + write(fates_log(),*) 'to something slightly larger than 1, so we set a cap at 10.' + write(fates_log(),*) 'Set to zero to turn off and use coupled nutrients.' + write(fates_log(),*) ' Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) + elseif (any(abs(EDPftvarcon_inst%prescribed_nuptake(:)) > nearzero )) then + if(.not.all(abs(EDPftvarcon_inst%prescribed_nuptake(:)) > nearzero )) then + write(fates_log(),*) 'If any PFTs are specified as having prescribed N' + write(fates_log(),*) 'uptake, then they must all. Note, prescribed' + write(fates_log(),*) 'rates are associated with any value abs(x)>nearzero' + write(fates_log(),*) 'EDPftvarcon_inst%prescribed_nuptake(:):', & + EDPftvarcon_inst%prescribed_nuptake(:) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + n_uptake_mode = prescribed_n_uptake + else + n_uptake_mode = coupled_n_uptake end if ! logging parameters, make sure they make sense @@ -2179,45 +1505,33 @@ subroutine FatesCheckParams(is_master, parteh_mode) call endrun(msg=errMsg(sourcefile, __LINE__)) endif - do ipft = 1,npft - - ! Check to see if evergreen, deciduous flags are mutually exclusive - ! ---------------------------------------------------------------------------------- - - if ( int(EDPftvarcon_inst%evergreen(ipft) + & - EDPftvarcon_inst%season_decid(ipft) + & - EDPftvarcon_inst%stress_decid(ipft)) .ne. 1 ) then - - write(fates_log(),*) 'PFT # ',ipft,' must be defined as having one of three' - write(fates_log(),*) 'phenology habits, ie == 1' - write(fates_log(),*) 'stress_decid: ',EDPftvarcon_inst%stress_decid(ipft) - write(fates_log(),*) 'season_decid: ',EDPftvarcon_inst%season_decid(ipft) - write(fates_log(),*) 'evergreen: ',EDPftvarcon_inst%evergreen(ipft) - write(fates_log(),*) 'Aborting' + ! Same for phosphorus + if (any(EDPftvarcon_inst%prescribed_puptake(:) < -nearzero ) .or. & + any(EDPftvarcon_inst%prescribed_puptake(:) > 10._r8 )) then + write(fates_log(),*) 'Negative values for EDPftvarcon_inst%prescribed_puptake(:)' + write(fates_log(),*) 'are not allowed. Reasonable ranges for this parameter are zero' + write(fates_log(),*) 'to something slightly larger than 1, so we set a cap at 10.' + write(fates_log(),*) 'Set to zero or unset to turn off and use coupled nutrients.' + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + elseif (any(abs(EDPftvarcon_inst%prescribed_puptake(:)) > nearzero )) then + if(.not.all(abs(EDPftvarcon_inst%prescribed_puptake(:)) > nearzero )) then + write(fates_log(),*) 'If any PFTs are specified as having prescribed P' + write(fates_log(),*) 'uptake, then they must all. Note, prescribed' + write(fates_log(),*) 'rates are associated with any value abs(x)>nearzero' + write(fates_log(),*) 'EDPftvarcon_inst%prescribed_puptake(:):', & + EDPftvarcon_inst%prescribed_puptake(:) + write(fates_log(),*) ' Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) - - end if - - ! Check fine-root profile parameters - - if(EDPftvarcon_inst%fnrt_prof_a(ipft) < nearzero .or. & - EDPftvarcon_inst%fnrt_prof_a(ipft) > fates_check_param_set) then - write(fates_log(),*) 'Rooting profile parameter a must have a meaningful value' - write(fates_log(),*) 'pft: ',ipft,' fnrt_prof_a(ipft): ',EDPftvarcon_inst%fnrt_prof_a(ipft) - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) end if + p_uptake_mode = prescribed_p_uptake + else + p_uptake_mode = coupled_p_uptake + end if + - if( EDPftvarcon_inst%fnrt_prof_mode(ipft) == 2 ) then - if (EDPftvarcon_inst%fnrt_prof_b(ipft) < nearzero .or. & - EDPftvarcon_inst%fnrt_prof_b(ipft) > fates_check_param_set) then - write(fates_log(),*) 'Rooting profile parameter b must have a meaningful value' - write(fates_log(),*) 'when using the 2 parameter exponential mode:' - write(fates_log(),*) 'pft: ',ipft,' fnrt_prof_b(ipft): ',EDPftvarcon_inst%fnrt_prof_b(ipft) - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if + + do ipft = 1,npft ! Check that parameter ranges for age-dependent mortality make sense @@ -2271,62 +1585,10 @@ subroutine FatesCheckParams(is_master, parteh_mode) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - - ! Check to see if mature and base seed allocation is greater than 1 - ! ---------------------------------------------------------------------------------- - if ( ( EDPftvarcon_inst%seed_alloc(ipft) + & - EDPftvarcon_inst%seed_alloc_mature(ipft)) > 1.0_r8 ) then - - write(fates_log(),*) 'The sum of seed allocation from base and mature trees may' - write(fates_log(),*) ' not exceed 1.' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' seed_alloc: ',EDPftvarcon_inst%seed_alloc(ipft) - write(fates_log(),*) ' seed_alloc_mature: ',EDPftvarcon_inst%seed_alloc_mature(ipft) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - - end if - - ! Check if woody plants have a structural biomass (agb) intercept - ! ---------------------------------------------------------------------------------- - if ( ( EDPftvarcon_inst%allom_agb1(ipft) <= tiny(EDPftvarcon_inst%allom_agb1(ipft)) ) .and. & - ( int(EDPftvarcon_inst%woody(ipft)) .eq. 1 ) ) then - - write(fates_log(),*) 'Woody plants are expected to have a non-zero intercept' - write(fates_log(),*) ' in the diameter to AGB allometry equations' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' allom_agb1: ',EDPftvarcon_inst%allom_agb1(ipft) - write(fates_log(),*) ' woody: ',int(EDPftvarcon_inst%woody(ipft)) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - - end if - - ! Check if non-woody plants have structural biomass (agb) intercept - ! ---------------------------------------------------------------------------------- -! if ( ( EDPftvarcon_inst%allom_agb1(ipft) > tiny(EDPftvarcon_inst%allom_agb1(ipft)) ) .and. & -! ( int(EDPftvarcon_inst%woody(ipft)) .ne. 1 ) ) then -! -! write(fates_log(),*) 'Non-woody plants are expected to have a zero intercept' -! write(fates_log(),*) ' in the diameter to AGB allometry equations' -! write(fates_log(),*) ' This is because the definition of AGB (as far as allometry)' -! write(fates_log(),*) ' is concerned, ignores leaf and fine-roots, and only contains' -! write(fates_log(),*) ' woody tissues (sap and structural dead wood).' -! write(fates_log(),*) ' PFT#: ',ipft -! write(fates_log(),*) ' allom_agb1: ',EDPftvarcon_inst%allom_agb1(ipft) -! write(fates_log(),*) ' woody: ',int(EDPftvarcon_inst%woody(ipft)) -! write(fates_log(),*) ' Aborting' -! 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 ( int(prt_params%evergreen(ipft)) .ne. 1 ) then if ( ( EDPftvarcon_inst%phenflush_fraction(ipft) < nearzero ) .or. & ( EDPFtvarcon_inst%phenflush_fraction(ipft) > 1 ) ) then @@ -2334,7 +1596,7 @@ subroutine FatesCheckParams(is_master, parteh_mode) 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(),*) ' evergreen flag: (shold be 0):',int(prt_params%evergreen(ipft)) write(fates_log(),*) ' phenflush_fraction: ', EDPFtvarcon_inst%phenflush_fraction(ipft) write(fates_log(),*) ' Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -2344,7 +1606,7 @@ subroutine FatesCheckParams(is_master, parteh_mode) write(fates_log(),*) ' Deciduous non-wood plants must keep 0-100% of their stems' write(fates_log(),*) ' during the deciduous period.' write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) ' evergreen flag: (shold be 0):',int(EDPftvarcon_inst%evergreen(ipft)) + write(fates_log(),*) ' evergreen flag: (shold be 0):',int(prt_params%evergreen(ipft)) write(fates_log(),*) ' phen_stem_drop_fraction: ', EDPFtvarcon_inst%phen_stem_drop_fraction(ipft) write(fates_log(),*) ' Aborting' call endrun(msg=errMsg(sourcefile, __LINE__)) @@ -2369,21 +1631,8 @@ subroutine FatesCheckParams(is_master, parteh_mode) end if - ! Check if leaf storage priority is between 0-1 - ! ---------------------------------------------------------------------------------- - - if ( ( EDPftvarcon_inst%leaf_stor_priority(ipft) < 0.0_r8 ) .or. & - ( EDPftvarcon_inst%leaf_stor_priority(ipft) > 1.0_r8 ) ) then - - write(fates_log(),*) 'Prioritization of carbon allocation to leaf' - write(fates_log(),*) ' and root turnover replacement, must be between' - write(fates_log(),*) ' 0 and 1' - write(fates_log(),*) ' PFT#: ',ipft - write(fates_log(),*) 'leaf_stor_priority: ',EDPftvarcon_inst%leaf_stor_priority(ipft) - write(fates_log(),*) ' Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if + ! Check if fraction of storage to reproduction is between 0-1 ! ---------------------------------------------------------------------------------- @@ -2400,6 +1649,7 @@ subroutine FatesCheckParams(is_master, parteh_mode) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + ! Check if photosynthetic pathway is neither C3/C4 ! ---------------------------------------------------------------------------------- @@ -2417,340 +1667,7 @@ subroutine FatesCheckParams(is_master, parteh_mode) 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 - - - ! Check turnover time-scales - - nleafage = size(EDPftvarcon_inst%leaf_long,dim=2) - - do iage = 1, nleafage - - if ( EDPftvarcon_inst%leaf_long(ipft,iage)>nearzero ) then - - ! Check that leaf turnover doesn't exeed 1 day - if ( (years_per_day / EDPftvarcon_inst%leaf_long(ipft,iage)) > 1._r8 ) then - write(fates_log(),*) 'Leaf turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft,' iage: ',iage - write(fates_log(),*) 'leaf_long(ipft,iage): ',EDPftvarcon_inst%leaf_long(ipft,iage),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - ! Check to make sure that all other age-classes for this PFT also - ! have non-zero entries, it wouldn't make sense otherwise - if ( any(EDPftvarcon_inst%leaf_long(ipft,:) <= nearzero) ) then - write(fates_log(),*) 'You specified a leaf_long that is zero or' - write(fates_log(),*) 'invalid for a particular age class.' - write(fates_log(),*) 'Yet, other age classes for this PFT are non-zero.' - write(fates_log(),*) 'this doesnt make sense.' - write(fates_log(),*) 'ipft = ',ipft - write(fates_log(),*) 'leaf_long(ipft,:) = ',EDPftvarcon_inst%leaf_long(ipft,:) - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - else - if (EDPftvarcon_inst%evergreen(ipft) .eq. itrue) then - write(fates_log(),*) 'You specified zero leaf turnover: ' - write(fates_log(),*) 'ipft: ',ipft,' iage: ',iage - write(fates_log(),*) 'leaf_long(ipft,iage): ',EDPftvarcon_inst%leaf_long(ipft,iage) - write(fates_log(),*) 'yet this is an evergreen PFT, and it only makes sense' - write(fates_log(),*) 'that an evergreen would have leaf maintenance turnover' - write(fates_log(),*) 'disable this error if you are ok with this' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - end do - - ! Check the turnover rates on the senescing leaf pool - if ( EDPftvarcon_inst%leaf_long(ipft,nleafage)>nearzero ) then - - ! Check that leaf turnover doesn't exeed 1 day - if ( (years_per_day / & - (EDPftvarcon_inst%leaf_long(ipft,nleafage) * & - EDPftvarcon_inst%senleaf_long_fdrought(ipft))) > 1._r8 ) then - write(fates_log(),*) 'Drought-senescent turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'leaf_long(ipft,nleafage)*senleaf_long_fdrought: ', & - EDPftvarcon_inst%leaf_long(ipft,nleafage)*EDPftvarcon_inst%senleaf_long_fdrought(ipft),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - if ( EDPftvarcon_inst%senleaf_long_fdrought(ipft)1._r8 ) then - write(fates_log(),*) 'senleaf_long_fdrought(ipft) must be greater than 0 ' - write(fates_log(),*) 'or less than or equal to 1.' - write(fates_log(),*) 'Set this to 1 if you want no accelerated senescence turnover' - write(fates_log(),*) 'ipft = ',ipft - write(fates_log(),*) 'senleaf_long_fdrought(ipft) = ',EDPftvarcon_inst%senleaf_long_fdrought(ipft) - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - - if ( EDPftvarcon_inst%root_long(ipft)>nearzero ) then - - ! Check that root turnover doesn't exeed 1 day - if ( (years_per_day / EDPftvarcon_inst%root_long(ipft)) > 1._r8 ) then - write(fates_log(),*) 'Root turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'root_long(ipft): ',EDPftvarcon_inst%root_long(ipft),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - - else - if (EDPftvarcon_inst%evergreen(ipft) .eq. itrue) then - write(fates_log(),*) 'You specified zero root turnover: ' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'root_long(ipft): ',EDPftvarcon_inst%root_long(ipft) - write(fates_log(),*) 'yet this is an evergreen PFT, and it only makes sense' - write(fates_log(),*) 'that an evergreen would have root maintenance turnover' - write(fates_log(),*) 'disable this error if you are ok with this' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - ! Check Branch turnover doesn't exceed one day - if ( EDPftvarcon_inst%branch_turnover(ipft)>nearzero ) then - - ! Check that branch turnover doesn't exeed 1 day - if ( (years_per_day / EDPftvarcon_inst%branch_turnover(ipft)) > 1._r8 ) then - write(fates_log(),*) 'Branch turnover time-scale is greater than 1 day!' - write(fates_log(),*) 'ipft: ',ipft - write(fates_log(),*) 'branch_turnover(ipft): ',EDPftvarcon_inst%branch_turnover(ipft),' [years]' - write(fates_log(),*) 'Aborting' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end if - end if - - - end do + end do !! ! Checks for HYDRO !! if( hlm_use_planthydro == itrue ) then @@ -2777,6 +1694,7 @@ subroutine FatesCheckParams(is_master, parteh_mode) return end subroutine FatesCheckParams + ! ===================================================================================== function GetDecompyFrac(pft,organ_id,dcmpy) result(decompy_frac) diff --git a/main/EDTypesMod.F90 b/main/EDTypesMod.F90 index 0e843df123..5ae635d5c8 100644 --- a/main/EDTypesMod.F90 +++ b/main/EDTypesMod.F90 @@ -10,6 +10,9 @@ module EDTypesMod use PRTGenericMod, only : leaf_organ, fnrt_organ, sapw_organ use PRTGenericMod, only : repro_organ, store_organ, struct_organ use PRTGenericMod, only : all_carbon_elements + use PRTGenericMod, only : num_organ_types + use PRTGenericMod, only : num_elements + use PRTGenericMod, only : element_list use PRTGenericMod, only : num_element_types use FatesLitterMod, only : litter_type use FatesLitterMod, only : ncwd @@ -37,8 +40,7 @@ module EDTypesMod ! are used, but this helps allocate scratch ! space and output arrays. - integer, parameter, public :: max_nleafage = 4 ! This is the maximum number of leaf age pools, - ! used for allocating scratch space + ! ------------------------------------------------------------------------------------- @@ -178,20 +180,15 @@ module EDTypesMod logical, parameter, public :: homogenize_seed_pfts = .false. + ! Global identifier of how nutrients interact with the host land model + ! either they are fully coupled, or they generate uptake rates synthetically + ! in prescribed mode. In the latter, there is both NO mass removed from the HLM's soil + ! BGC N and P pools, and there is also none removed. - ! Global identifiers for which elements we are using (apply mostly to litter) - - integer, public :: num_elements ! This is the number of elements in this simulation - ! e.g. (C,N,P,K, etc) - integer, allocatable, public :: element_list(:) ! This vector holds the element ids that are found - ! in PRTGenericMod.F90. examples are carbon12_element - ! nitrogen_element, etc. - - integer, public :: element_pos(num_element_types) ! This is the reverse lookup - ! for element types. Pick an element - ! global index, and it gives you - ! the position in the element_list - + integer, public :: n_uptake_mode + integer, public :: p_uptake_mode + + !************************************ !** COHORT type structure ** !************************************ @@ -283,7 +280,31 @@ module EDTypesMod real(r8) :: c13disc_clm ! carbon 13 discrimination in new synthesized carbon: part-per-mil, at each indiv/timestep real(r8) :: c13disc_acc ! carbon 13 discrimination in new synthesized carbon: part-per-mil, at each indiv/day, at the end of a day + ! Nutrient Fluxes (if N, P, etc. are turned on) + + real(r8) :: daily_n_uptake ! integrated daily uptake of mineralized N through competitive acquisition in soil [kg N / plant/ day] + real(r8) :: daily_p_uptake ! integrated daily uptake of mineralized P through competitive acquisition in soil [kg P / plant/ day] + + real(r8) :: daily_c_efflux ! daily mean efflux of excess carbon from roots into labile pool [kg C/plant/day] + real(r8) :: daily_n_efflux ! daily mean efflux of excess nitrogen from roots into labile pool [kg N/plant/day] + real(r8) :: daily_p_efflux ! daily mean efflux of excess phophorus from roots into labile pool [kg P/plant/day] + + real(r8) :: daily_n_need1 ! Nitrogen needed to enable non-limited C growth (AllometricCNP hypothesis) + real(r8) :: daily_n_need2 ! Nitrogen needed to bring N concentrations up to optimal + real(r8) :: daily_p_need1 ! Phosphorus needed to enable non-limited C growth (AllometricCNP hypothesis) + real(r8) :: daily_p_need2 ! Phosphorus needed to bring P concentrations up to optimal + ! These two variables may use the previous "need" variables, by applying a smoothing function. + ! Or, its possible that the plant will use another method to calculate this, perhaps based + ! on storage. + ! These variables are used in two scenarios. 1) They work with the prescribed uptake fraction + ! in un-coupled mode, and 2) They are the plant's demand subbmitted to the Relative-Demand + ! type soil BGC scheme. + + real(r8) :: daily_n_demand ! The daily amount of N demanded by the plant [kgN] + real(r8) :: daily_p_demand ! The daily amount of P demanded by the plant [kgN] + + ! The following four biophysical rates are assumed to be ! at the canopy top, at reference temp 25C, and based on the ! leaf age weighted average of the PFT parameterized values. The last @@ -305,8 +326,13 @@ module EDTypesMod ! RESPIRATION COMPONENTS real(r8) :: rdark ! Dark respiration: kgC/indiv/s - real(r8) :: resp_g ! Growth respiration: kgC/indiv/timestep + + real(r8) :: resp_g_tstep ! Growth respiration: kgC/indiv/timestep real(r8) :: resp_m ! Maintenance respiration: kgC/indiv/timestep + real(r8) :: resp_m_def ! Optional: (NOT IMPLEMENTED YET) + ! It may be possible to not respire at desired rate + ! because of low carbon stores, and thus build + ! up a deficit. This tracks that deficit. kgC/indiv real(r8) :: livestem_mr ! Live stem maintenance respiration: kgC/indiv/s ! (Above ground) real(r8) :: livecroot_mr ! Live stem maintenance respiration: kgC/indiv/s @@ -573,6 +599,11 @@ module EDTypesMod real(r8) :: cwd_bg_input(1:ncwd) real(r8),allocatable :: leaf_litter_input(:) real(r8),allocatable :: root_litter_input(:) + + real(r8),allocatable :: nutrient_uptake_scpf(:) + real(r8),allocatable :: nutrient_efflux_scpf(:) + real(r8),allocatable :: nutrient_needgrow_scpf(:) + real(r8),allocatable :: nutrient_needmax_scpf(:) contains @@ -721,6 +752,13 @@ module EDTypesMod ! NOTE: THIS SCRATCH SPACE WOULD NOT BE THREAD-SAFE ! IF WE FORK ON PATCHES + + ! Mineralized nutrient flux from veg to the soil, via multiple mechanisms + ! inluding symbiotic fixation, or other + + !real(r8) :: allocatable :: minn_flux_out ! kg/ha/day + !real(r8) :: allocatable :: minp_flux_out ! kg/ha/day + ! DIAGNOSTICS @@ -795,6 +833,10 @@ subroutine ZeroFluxDiags(this) this%cwd_bg_input(:) = 0._r8 this%leaf_litter_input(:) = 0._r8 this%root_litter_input(:) = 0._r8 + this%nutrient_uptake_scpf(:) = 0._r8 + this%nutrient_efflux_scpf(:) = 0._r8 + this%nutrient_needgrow_scpf(:) = 0._r8 + this%nutrient_needmax_scpf(:) = 0._r8 return end subroutine ZeroFluxDiags @@ -1017,7 +1059,8 @@ subroutine dump_cohort(ccohort) write(fates_log(),*) 'co%resp_acc_hold = ', ccohort%resp_acc_hold 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%resp_m_def = ', ccohort%resp_m_def + write(fates_log(),*) 'co%resp_g_tstep = ', ccohort%resp_g_tstep 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 diff --git a/main/FatesConstantsMod.F90 b/main/FatesConstantsMod.F90 index e553918028..66d089a895 100644 --- a/main/FatesConstantsMod.F90 +++ b/main/FatesConstantsMod.F90 @@ -34,6 +34,32 @@ module FatesConstantsMod integer, parameter, public :: n_anthro_disturbance_categories = 2 integer, parameter, public :: primaryforest = 1 integer, parameter, public :: secondaryforest = 2 + + + ! Flags specifying how phosphorous uptake and turnover interacts + ! with the host model. + integer, public, parameter :: prescribed_p_uptake = 1 + integer, public, parameter :: coupled_p_uptake = 2 + + ! Flags specifying how nitrogen uptake and turnover interacts + ! with the host model. + integer, public, parameter :: prescribed_n_uptake = 1 + integer, public, parameter :: coupled_n_uptake = 2 + + + integer, public, parameter :: cohort_np_comp_scaling = 1 ! This flag definition indicates that EVERY cohort on + ! the column should compete independently in the soil + ! BGC nitrogen and phosphorus acquisition scheme. + + integer, public, parameter :: pft_np_comp_scaling = 2 ! This flag definition indicates that cohorts should + ! be grouped into PFTs, and each PFT will be represented + ! as the competitor, in the BGC N and P acquisition scheme + + ! This flag specifies the scaling of how we present + ! nutrient competitors to the HLM's soil BGC model + + integer, public, parameter :: fates_np_comp_scaling = cohort_np_comp_scaling + real(fates_r8), parameter, public :: secondary_age_threshold = 94._fates_r8 ! less than this value is young secondary land ! based on average age of global ! secondary 1900s land in hurtt-2011 @@ -41,6 +67,7 @@ module FatesConstantsMod ! integer labels for specifying harvest units integer, parameter, public :: hlm_harvest_area_fraction = 1 ! Code for harvesting by area integer, parameter, public :: hlm_harvest_carbon = 2 ! Code for harvesting based on carbon extracted. + ! Error Tolerances diff --git a/main/FatesHistoryInterfaceMod.F90 b/main/FatesHistoryInterfaceMod.F90 index c5dd9b4d75..a460da64ea 100644 --- a/main/FatesHistoryInterfaceMod.F90 +++ b/main/FatesHistoryInterfaceMod.F90 @@ -12,8 +12,8 @@ module FatesHistoryInterfaceMod use FatesGlobals , only : endrun => fates_endrun use EDTypesMod , only : nclmax use EDTypesMod , only : ican_upper - use EDTypesMod , only : element_pos - use EDTypesMod , only : num_elements + use PRTGenericMod , only : element_pos + use PRTGenericMod , only : num_elements use EDTypesMod , only : site_fluxdiags_type use EDtypesMod , only : ed_site_type use EDtypesMod , only : ed_cohort_type @@ -23,7 +23,7 @@ module FatesHistoryInterfaceMod use EDTypesMod , only : numWaterMem use EDTypesMod , only : num_vegtemp_mem use EDTypesMod , only : site_massbal_type - use EDTypesMod , only : element_list + use PRTGenericMod , only : element_list use EDTypesMod , only : N_DIST_TYPES use EDTypesMod , only : dtype_ifall use EDTypesMod , only : dtype_ifire @@ -37,6 +37,7 @@ module FatesHistoryInterfaceMod use FatesInterfaceTypesMod , only : hlm_use_cohort_age_tracking use FatesInterfaceTypesMod , only : numpft use FatesInterfaceTypesMod , only : hlm_freq_day + use FatesInterfaceTypesMod , only : hlm_parteh_mode use EDParamsMod , only : ED_val_comp_excln use EDParamsMod , only : ED_val_phen_coldtemp use FatesInterfaceTypesMod , only : nlevsclass, nlevage @@ -47,7 +48,8 @@ module FatesHistoryInterfaceMod ! FIXME(bja, 2016-10) need to remove CLM dependancy use EDPftvarcon , only : EDPftvarcon_inst - + use PRTParametersMod , only : prt_params + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg use shr_infnan_mod , only : isnan => shr_infnan_isnan @@ -64,7 +66,8 @@ module FatesHistoryInterfaceMod use PRTGenericMod , only : struct_organ, store_organ, repro_organ use PRTGenericMod , only : all_carbon_elements use PRTGenericMod , only : carbon12_element - + use PRTGenericMod , only : nitrogen_element, phosphorus_element + use PRTGenericMod , only : prt_carbon_allom_hyp implicit none private ! By default everything is private @@ -142,6 +145,37 @@ module FatesHistoryInterfaceMod ! Indices to 1D Patch variables + integer :: ih_storec_si + integer :: ih_leafc_si + integer :: ih_sapwc_si + integer :: ih_fnrtc_si + integer :: ih_reproc_si + integer :: ih_totvegc_si + + integer :: ih_storen_si + integer :: ih_leafn_si + integer :: ih_sapwn_si + integer :: ih_fnrtn_si + integer :: ih_repron_si + integer :: ih_totvegn_si + + integer :: ih_storep_si + integer :: ih_leafp_si + integer :: ih_sapwp_si + integer :: ih_fnrtp_si + integer :: ih_reprop_si + integer :: ih_totvegp_si + + integer :: ih_nuptake_si + integer :: ih_puptake_si + integer :: ih_cefflux_si + integer :: ih_nefflux_si + integer :: ih_pefflux_si + integer :: ih_nneedgrow_si + integer :: ih_nneedmax_si + integer :: ih_pneedgrow_si + integer :: ih_pneedmax_si + integer :: ih_trimming_si integer :: ih_area_plant_si integer :: ih_area_trees_si @@ -167,6 +201,45 @@ module FatesHistoryInterfaceMod integer :: ih_cwd_bg_elem integer :: ih_burn_flux_elem + ! Size-class x PFT mass states + + integer :: ih_bstor_canopy_si_scpf + integer :: ih_bstor_understory_si_scpf + integer :: ih_bleaf_canopy_si_scpf + integer :: ih_bleaf_understory_si_scpf + + + + integer :: ih_totvegn_scpf + integer :: ih_leafn_scpf + integer :: ih_fnrtn_scpf + integer :: ih_storen_scpf + integer :: ih_sapwn_scpf + integer :: ih_repron_scpf + integer :: ih_nuptake_scpf + integer :: ih_nefflux_scpf + integer :: ih_nneedgrow_scpf + integer :: ih_nneedmax_scpf + + integer :: ih_totvegc_scpf + integer :: ih_leafc_scpf + integer :: ih_fnrtc_scpf + integer :: ih_storec_scpf + integer :: ih_sapwc_scpf + integer :: ih_reproc_scpf + integer :: ih_cefflux_scpf + + integer :: ih_totvegp_scpf + integer :: ih_leafp_scpf + integer :: ih_fnrtp_scpf + integer :: ih_reprop_scpf + integer :: ih_storep_scpf + integer :: ih_sapwp_scpf + integer :: ih_puptake_scpf + integer :: ih_pefflux_scpf + integer :: ih_pneedgrow_scpf + integer :: ih_pneedmax_scpf + integer :: ih_daily_temp integer :: ih_daily_rh integer :: ih_daily_prec @@ -257,8 +330,6 @@ module FatesHistoryInterfaceMod integer :: ih_h2oveg_growturn_err_si integer :: ih_h2oveg_pheno_err_si integer :: ih_h2oveg_hydro_err_si - - integer :: ih_site_cstatus_si integer :: ih_site_dstatus_si @@ -298,10 +369,7 @@ module FatesHistoryInterfaceMod integer :: ih_npp_agdw_si_scpf integer :: ih_npp_stor_si_scpf - integer :: ih_bstor_canopy_si_scpf - integer :: ih_bstor_understory_si_scpf - integer :: ih_bleaf_canopy_si_scpf - integer :: ih_bleaf_understory_si_scpf + integer :: ih_mortality_canopy_si_scpf integer :: ih_mortality_understory_si_scpf integer :: ih_nplant_canopy_si_scpf @@ -606,8 +674,7 @@ module FatesHistoryInterfaceMod procedure :: assemble_history_output_types procedure :: update_history_dyn - procedure :: update_history_prod - procedure :: update_history_cbal + procedure :: update_history_hifrq procedure :: update_history_hydraulics ! 'get' methods used by external callers to access private read only data @@ -1580,62 +1647,7 @@ end subroutine init_dim_kinds_maps ! ======================================================================= - subroutine update_history_cbal(this,nc,nsites,sites,bc_in,dtime) - - use EDtypesMod , only : ed_site_type - - - ! Arguments - class(fates_history_interface_type) :: this - integer , intent(in) :: nc ! clump index - integer , intent(in) :: nsites - type(ed_site_type) , intent(inout), target :: sites(nsites) - type(bc_in_type) , intent(in) :: bc_in(nsites) - real(r8) , intent(in) :: dtime ! Time-step (s) - - ! Locals - integer :: s ! The local site index - integer :: io_si ! The site index of the IO array - real(r8) :: inv_dtime ! inverse of dtime (faster math) - type(ed_cohort_type), pointer :: ccohort ! current cohort - type(ed_patch_type) , pointer :: cpatch ! current patch - - associate( hio_nep_si => this%hvars(ih_nep_si)%r81d ) - - ! --------------------------------------------------------------------------------- - ! Flush arrays to values defined by %flushval (see registry entry in - ! subroutine define_history_vars() - ! --------------------------------------------------------------------------------- - - call this%flush_hvars(nc,upfreq_in=3) - inv_dtime = 1._r8/dtime - - do s = 1,nsites - - io_si = this%iovar_map(nc)%site_index(s) - - hio_nep_si(io_si) = -bc_in(s)%tot_het_resp ! (gC/m2/s) - - cpatch => sites(s)%oldest_patch - do while(associated(cpatch)) - ccohort => cpatch%shortest - do while(associated(ccohort)) - - ! Add up the total Net Ecosystem Production - ! for this timestep. [gC/m2/s] - hio_nep_si(io_si) = hio_nep_si(io_si) + & - (ccohort%gpp_tstep - ccohort%resp_tstep) * & - g_per_kg * ccohort%n * area_inv * inv_dtime - ccohort => ccohort%taller - end do - cpatch => cpatch%younger - end do - end do - end associate - - end subroutine update_history_cbal - ! ==================================================================================== @@ -1711,24 +1723,25 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! 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 + real(r8) :: sapw_m ! Sapwood mass (elemental, c,n or p) [kg/plant] + real(r8) :: struct_m ! Structural mass "" + real(r8) :: leaf_m ! Leaf mass "" + real(r8) :: fnrt_m ! Fineroot mass "" + real(r8) :: store_m ! Storage mass "" + real(r8) :: alive_m ! Alive biomass (sap+leaf+fineroot+repro+storage) "" + real(r8) :: total_m ! Total vegetation mass + real(r8) :: repro_m ! Total reproductive mass (on plant) "" + real(r8) :: sapw_m_turnover + real(r8) :: store_m_turnover + real(r8) :: leaf_m_turnover + real(r8) :: fnrt_m_turnover + real(r8) :: struct_m_turnover + real(r8) :: sapw_m_net_alloc + real(r8) :: store_m_net_alloc + real(r8) :: leaf_m_net_alloc + real(r8) :: fnrt_m_net_alloc + real(r8) :: struct_m_net_alloc + real(r8) :: repro_m_net_alloc real(r8) :: area_frac type(ed_patch_type),pointer :: cpatch @@ -1778,7 +1791,6 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_seed_in_extern_elem => this%hvars(ih_seeds_in_extern_elem)%r82d, & hio_seed_decay_elem => this%hvars(ih_seed_decay_elem)%r82d, & hio_seed_germ_elem => this%hvars(ih_seed_germ_elem)%r82d, & - hio_bstore_si => this%hvars(ih_bstore_si)%r81d, & hio_bdead_si => this%hvars(ih_bdead_si)%r81d, & hio_balive_si => this%hvars(ih_balive_si)%r81d, & @@ -2012,8 +2024,8 @@ subroutine update_history_dyn(this,nc,nsites,sites) ! Total model error [kg/day -> mg/day] (all elements) do el = 1, num_elements - site_mass => sites(s)%mass_balance(el) - hio_err_fates_si(io_si,el) = site_mass%err_fates * mg_per_kg + + hio_err_fates_si(io_si,el) = sites(s)%mass_balance(el)%err_fates * mg_per_kg ! Total element lost to atmosphere from burning (kg/site/day -> g/m2/s) hio_burn_flux_elem(io_si,el) = & @@ -2206,42 +2218,108 @@ subroutine update_history_dyn(this,nc,nsites,sites) endif ! Update biomass components - - ! 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_si(io_si) = hio_bleaf_si(io_si) + n_perm2 * leaf_c * g_per_kg - hio_bstore_si(io_si) = hio_bstore_si(io_si) + n_perm2 * store_c * g_per_kg - hio_bdead_si(io_si) = hio_bdead_si(io_si) + n_perm2 * struct_c * g_per_kg - hio_balive_si(io_si) = hio_balive_si(io_si) + n_perm2 * alive_c * g_per_kg + do el = 1, num_elements + + sapw_m = ccohort%prt%GetState(sapw_organ, element_list(el)) + struct_m = ccohort%prt%GetState(struct_organ, element_list(el)) + leaf_m = ccohort%prt%GetState(leaf_organ, element_list(el)) + fnrt_m = ccohort%prt%GetState(fnrt_organ, element_list(el)) + store_m = ccohort%prt%GetState(store_organ, element_list(el)) + repro_m = ccohort%prt%GetState(repro_organ, element_list(el)) + + alive_m = leaf_m + fnrt_m + sapw_m + total_m = alive_m + store_m + struct_m + + ! Plant multi-element states and fluxes + ! Zero states, and set the fluxes + if( element_list(el).eq.carbon12_element )then + + this%hvars(ih_storec_si)%r81d(io_si) = & + this%hvars(ih_storec_si)%r81d(io_si) + ccohort%n * store_m + this%hvars(ih_leafc_si)%r81d(io_si) = & + this%hvars(ih_leafc_si)%r81d(io_si) + ccohort%n * leaf_m + this%hvars(ih_fnrtc_si)%r81d(io_si) = & + this%hvars(ih_fnrtc_si)%r81d(io_si) + ccohort%n * fnrt_m + this%hvars(ih_reproc_si)%r81d(io_si) = & + this%hvars(ih_reproc_si)%r81d(io_si)+ ccohort%n * repro_m + this%hvars(ih_sapwc_si)%r81d(io_si) = & + this%hvars(ih_sapwc_si)%r81d(io_si)+ ccohort%n * sapw_m + this%hvars(ih_totvegc_si)%r81d(io_si) = & + this%hvars(ih_totvegc_si)%r81d(io_si)+ ccohort%n * total_m + + hio_bleaf_si(io_si) = hio_bleaf_si(io_si) + n_perm2 * leaf_m * g_per_kg + hio_bstore_si(io_si) = hio_bstore_si(io_si) + n_perm2 * store_m * g_per_kg + hio_bdead_si(io_si) = hio_bdead_si(io_si) + n_perm2 * struct_m * g_per_kg + hio_balive_si(io_si) = hio_balive_si(io_si) + n_perm2 * alive_m * g_per_kg + + hio_bsapwood_si(io_si) = hio_bsapwood_si(io_si) + n_perm2 * sapw_m * g_per_kg + hio_bfineroot_si(io_si) = hio_bfineroot_si(io_si) + n_perm2 * fnrt_m * g_per_kg + hio_btotal_si(io_si) = hio_btotal_si(io_si) + n_perm2 * total_m * g_per_kg + + hio_agb_si(io_si) = hio_agb_si(io_si) + n_perm2 * g_per_kg * & + ( leaf_m + (sapw_m + struct_m + store_m) * prt_params%allom_agb_frac(ccohort%pft) ) + + + ! Update PFT partitioned biomass components + hio_leafbiomass_si_pft(io_si,ft) = hio_leafbiomass_si_pft(io_si,ft) + & + (ccohort%n * AREA_INV) * leaf_m * g_per_kg + + hio_storebiomass_si_pft(io_si,ft) = hio_storebiomass_si_pft(io_si,ft) + & + (ccohort%n * AREA_INV) * store_m * g_per_kg + + hio_nindivs_si_pft(io_si,ft) = hio_nindivs_si_pft(io_si,ft) + & + ccohort%n * AREA_INV + + hio_biomass_si_pft(io_si, ft) = hio_biomass_si_pft(io_si, ft) + & + (ccohort%n * AREA_INV) * total_m * g_per_kg - hio_bsapwood_si(io_si) = hio_bsapwood_si(io_si) + n_perm2 * sapw_c * g_per_kg - hio_bfineroot_si(io_si) = hio_bfineroot_si(io_si) + n_perm2 * fnrt_c * g_per_kg - hio_btotal_si(io_si) = hio_btotal_si(io_si) + n_perm2 * total_c * g_per_kg + ! update total biomass per age bin + hio_biomass_si_age(io_si,cpatch%age_class) = hio_biomass_si_age(io_si,cpatch%age_class) & + + total_m * ccohort%n * AREA_INV + + ! track the total biomass on all secondary lands + if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then + hio_biomass_secondary_forest_si(io_si) = hio_biomass_secondary_forest_si(io_si) + & + total_m * ccohort%n * AREA_INV + endif + + elseif(element_list(el).eq.nitrogen_element)then + + this%hvars(ih_storen_si)%r81d(io_si) = & + this%hvars(ih_storen_si)%r81d(io_si) + ccohort%n * store_m + this%hvars(ih_leafn_si)%r81d(io_si) = & + this%hvars(ih_leafn_si)%r81d(io_si) + ccohort%n * leaf_m + this%hvars(ih_fnrtn_si)%r81d(io_si) = & + this%hvars(ih_fnrtn_si)%r81d(io_si) + ccohort%n * fnrt_m + this%hvars(ih_repron_si)%r81d(io_si) = & + this%hvars(ih_repron_si)%r81d(io_si) + ccohort%n * repro_m + this%hvars(ih_sapwn_si)%r81d(io_si) = & + this%hvars(ih_sapwn_si)%r81d(io_si) + ccohort%n * sapw_m + this%hvars(ih_totvegn_si)%r81d(io_si) = & + this%hvars(ih_totvegn_si)%r81d(io_si) + ccohort%n * total_m - hio_agb_si(io_si) = hio_agb_si(io_si) + n_perm2 * g_per_kg * & - ( leaf_c + (sapw_c + struct_c + store_c) * EDPftvarcon_inst%allom_agb_frac(ccohort%pft) ) + + elseif(element_list(el).eq.phosphorus_element) then + + this%hvars(ih_storep_si)%r81d(io_si) = & + this%hvars(ih_storep_si)%r81d(io_si) + ccohort%n * store_m + this%hvars(ih_leafp_si)%r81d(io_si) = & + this%hvars(ih_leafp_si)%r81d(io_si) + ccohort%n * leaf_m + this%hvars(ih_fnrtp_si)%r81d(io_si) = & + this%hvars(ih_fnrtp_si)%r81d(io_si) + ccohort%n * fnrt_m + this%hvars(ih_reprop_si)%r81d(io_si) = & + this%hvars(ih_reprop_si)%r81d(io_si) + ccohort%n * repro_m + this%hvars(ih_sapwp_si)%r81d(io_si) = & + this%hvars(ih_sapwp_si)%r81d(io_si) + ccohort%n * sapw_m + this%hvars(ih_totvegp_si)%r81d(io_si) = & + this%hvars(ih_totvegp_si)%r81d(io_si)+ ccohort%n * total_m + + end if + + end do - ! Update PFT partitioned biomass components - hio_leafbiomass_si_pft(io_si,ft) = hio_leafbiomass_si_pft(io_si,ft) + & - (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) * 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) * total_c * g_per_kg ! Update PFT crown area hio_crownarea_si_pft(io_si, ft) = hio_crownarea_si_pft(io_si, ft) + & @@ -2253,15 +2331,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) ccohort%c_area end if - ! update total biomass per age bin - hio_biomass_si_age(io_si,cpatch%age_class) = hio_biomass_si_age(io_si,cpatch%age_class) & - + total_c * ccohort%n * AREA_INV - - ! track the total biomass on all secondary lands - if ( cpatch%anthro_disturbance_label .eq. secondaryforest ) then - hio_biomass_secondary_forest_si(io_si) = hio_biomass_secondary_forest_si(io_si) + & - total_c * ccohort%n * AREA_INV - endif + ! Site by Size-Class x PFT (SCPF) ! ------------------------------------------------------------------------ @@ -2273,29 +2343,29 @@ subroutine update_history_dyn(this,nc,nsites,sites) 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 + sapw_m_turnover = ccohort%prt%GetTurnover(sapw_organ, carbon12_element) * days_per_year + store_m_turnover = ccohort%prt%GetTurnover(store_organ, carbon12_element) * days_per_year + leaf_m_turnover = ccohort%prt%GetTurnover(leaf_organ, carbon12_element) * days_per_year + fnrt_m_turnover = ccohort%prt%GetTurnover(fnrt_organ, carbon12_element) * days_per_year + struct_m_turnover = ccohort%prt%GetTurnover(struct_organ, carbon12_element) * days_per_year ! Net change from allocation and transport [kgC/day] * [day/yr] = [kgC/yr] - sapw_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 + sapw_m_net_alloc = ccohort%prt%GetNetAlloc(sapw_organ, carbon12_element) * days_per_year + store_m_net_alloc = ccohort%prt%GetNetAlloc(store_organ, carbon12_element) * days_per_year + leaf_m_net_alloc = ccohort%prt%GetNetAlloc(leaf_organ, carbon12_element) * days_per_year + fnrt_m_net_alloc = ccohort%prt%GetNetAlloc(fnrt_organ, carbon12_element) * days_per_year + struct_m_net_alloc = ccohort%prt%GetNetAlloc(struct_organ, carbon12_element) * days_per_year + repro_m_net_alloc = ccohort%prt%GetNetAlloc(repro_organ, carbon12_element) * days_per_year + + ! ecosystem-level, organ-partitioned NPP/allocation fluxes + hio_npp_leaf_si(io_si) = hio_npp_leaf_si(io_si) + leaf_m_net_alloc * n_perm2 + hio_npp_seed_si(io_si) = hio_npp_seed_si(io_si) + repro_m_net_alloc * n_perm2 + hio_npp_stem_si(io_si) = hio_npp_stem_si(io_si) + (sapw_m_net_alloc + struct_m_net_alloc) * n_perm2 * & + (prt_params%allom_agb_frac(ccohort%pft)) + hio_npp_froot_si(io_si) = hio_npp_froot_si(io_si) + fnrt_m_net_alloc * n_perm2 + hio_npp_croot_si(io_si) = hio_npp_croot_si(io_si) + (sapw_m_net_alloc + struct_m_net_alloc) * n_perm2 * & + (1._r8-prt_params%allom_agb_frac(ccohort%pft)) + hio_npp_stor_si(io_si) = hio_npp_stor_si(io_si) + store_m_net_alloc * n_perm2 associate( scpf => ccohort%size_by_pft_class, & @@ -2304,7 +2374,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) capf => ccohort%coage_by_pft_class) - gpp_cached = hio_gpp_si_scpf(io_si,scpf) + gpp_cached = hio_gpp_si_scpf(io_si,scpf) hio_gpp_si_scpf(io_si,scpf) = hio_gpp_si_scpf(io_si,scpf) + & n_perm2*ccohort%gpp_acc_hold ! [kgC/m2/yr] @@ -2313,28 +2383,28 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_npp_leaf_si_scpf(io_si,scpf) = hio_npp_leaf_si_scpf(io_si,scpf) + & - leaf_c_net_alloc*n_perm2 + leaf_m_net_alloc*n_perm2 hio_npp_fnrt_si_scpf(io_si,scpf) = hio_npp_fnrt_si_scpf(io_si,scpf) + & - fnrt_c_net_alloc*n_perm2 + fnrt_m_net_alloc*n_perm2 hio_npp_bgsw_si_scpf(io_si,scpf) = hio_npp_bgsw_si_scpf(io_si,scpf) + & - sapw_c_net_alloc*n_perm2* & - (1._r8-EDPftvarcon_inst%allom_agb_frac(ccohort%pft)) + sapw_m_net_alloc*n_perm2* & + (1._r8-prt_params%allom_agb_frac(ccohort%pft)) hio_npp_agsw_si_scpf(io_si,scpf) = hio_npp_agsw_si_scpf(io_si,scpf) + & - sapw_c_net_alloc*n_perm2* & - EDPftvarcon_inst%allom_agb_frac(ccohort%pft) + sapw_m_net_alloc*n_perm2* & + prt_params%allom_agb_frac(ccohort%pft) hio_npp_bgdw_si_scpf(io_si,scpf) = hio_npp_bgdw_si_scpf(io_si,scpf) + & - struct_c_net_alloc*n_perm2* & - (1._r8-EDPftvarcon_inst%allom_agb_frac(ccohort%pft)) + struct_m_net_alloc*n_perm2* & + (1._r8-prt_params%allom_agb_frac(ccohort%pft)) hio_npp_agdw_si_scpf(io_si,scpf) = hio_npp_agdw_si_scpf(io_si,scpf) + & - struct_c_net_alloc*n_perm2* & - EDPftvarcon_inst%allom_agb_frac(ccohort%pft) + struct_m_net_alloc*n_perm2* & + prt_params%allom_agb_frac(ccohort%pft) hio_npp_seed_si_scpf(io_si,scpf) = hio_npp_seed_si_scpf(io_si,scpf) + & - repro_c_net_alloc*n_perm2 + repro_m_net_alloc*n_perm2 hio_npp_stor_si_scpf(io_si,scpf) = hio_npp_stor_si_scpf(io_si,scpf) + & - store_c_net_alloc*n_perm2 + store_m_net_alloc*n_perm2 ! Woody State Variables (basal area growth increment) - if (EDPftvarcon_inst%woody(ft) == 1) then + if ( int(prt_params%woody(ft)) == itrue) then ! basal area [m2/ha] hio_ba_si_scpf(io_si,scpf) = hio_ba_si_scpf(io_si,scpf) + & @@ -2393,16 +2463,29 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_nplant_si_capf(io_si,capf) = hio_nplant_si_capf(io_si,capf) + ccohort%n hio_nplant_si_cacls(io_si,cacls) = hio_nplant_si_cacls(io_si,cacls)+ccohort%n end if + + + ! Carbon only metrics + sapw_m = ccohort%prt%GetState(sapw_organ, carbon12_element) + struct_m = ccohort%prt%GetState(struct_organ, carbon12_element) + leaf_m = ccohort%prt%GetState(leaf_organ, carbon12_element) + fnrt_m = ccohort%prt%GetState(fnrt_organ, carbon12_element) + store_m = ccohort%prt%GetState(store_organ, carbon12_element) + repro_m = ccohort%prt%GetState(repro_organ, carbon12_element) + alive_m = leaf_m + fnrt_m + sapw_m + total_m = alive_m + store_m + struct_m + ! number density by size and biomass hio_agb_si_scls(io_si,scls) = hio_agb_si_scls(io_si,scls) + & - total_c * ccohort%n * EDPftvarcon_inst%allom_agb_frac(ccohort%pft) * AREA_INV + total_m * ccohort%n * prt_params%allom_agb_frac(ccohort%pft) * AREA_INV hio_agb_si_scpf(io_si,scpf) = hio_agb_si_scpf(io_si,scpf) + & - total_c * ccohort%n * EDPftvarcon_inst%allom_agb_frac(ccohort%pft) * AREA_INV + total_m * ccohort%n * prt_params%allom_agb_frac(ccohort%pft) * AREA_INV + hio_biomass_si_scls(io_si,scls) = hio_biomass_si_scls(io_si,scls) + & - total_c * ccohort%n * AREA_INV + total_m * ccohort%n * AREA_INV ! update size-class x patch-age related quantities @@ -2427,7 +2510,7 @@ 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) + & - total_c * ccohort%n * AREA_INV + total_m * ccohort%n * AREA_INV ! update SCPF/SCLS- and canopy/subcanopy- partitioned quantities if (ccohort%canopy_layer .eq. 1) then @@ -2438,11 +2521,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) + & - store_c * ccohort%n + store_m * ccohort%n hio_bleaf_canopy_si_scpf(io_si,scpf) = hio_bleaf_canopy_si_scpf(io_si,scpf) + & - leaf_c * ccohort%n + leaf_m * ccohort%n - hio_canopy_biomass_si(io_si) = hio_canopy_biomass_si(io_si) + n_perm2 * total_c * g_per_kg + hio_canopy_biomass_si(io_si) = hio_canopy_biomass_si(io_si) + n_perm2 * total_m * g_per_kg !hio_mortality_canopy_si_scpf(io_si,scpf) = hio_mortality_canopy_si_scpf(io_si,scpf)+ & ! (ccohort%bmort + ccohort%hmort + ccohort%cmort + & @@ -2452,7 +2535,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) (ccohort%bmort + ccohort%hmort + ccohort%cmort + ccohort%frmort + & ccohort%smort + ccohort%asmort) * ccohort%n + & - (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & ccohort%n * sec_per_day * days_per_year hio_nplant_canopy_si_scpf(io_si,scpf) = hio_nplant_canopy_si_scpf(io_si,scpf) + ccohort%n @@ -2486,8 +2569,8 @@ 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%frmort + ccohort%smort + ccohort%asmort) * & - 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 * & + total_m * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_m * & ccohort%n * g_per_kg * ha_per_m2 @@ -2496,30 +2579,30 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_leaf_md_canopy_si_scls(io_si,scls) = hio_leaf_md_canopy_si_scls(io_si,scls) + & - leaf_c_turnover * ccohort%n + leaf_m_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 + fnrt_m_turnover * ccohort%n hio_bsw_md_canopy_si_scls(io_si,scls) = hio_bsw_md_canopy_si_scls(io_si,scls) + & - sapw_c_turnover * ccohort%n + sapw_m_turnover * ccohort%n hio_bstore_md_canopy_si_scls(io_si,scls) = hio_bstore_md_canopy_si_scls(io_si,scls) + & - store_c_turnover * ccohort%n + store_m_turnover * ccohort%n hio_bdead_md_canopy_si_scls(io_si,scls) = hio_bdead_md_canopy_si_scls(io_si,scls) + & - struct_c_turnover * ccohort%n + struct_m_turnover * ccohort%n hio_seed_prod_canopy_si_scls(io_si,scls) = hio_seed_prod_canopy_si_scls(io_si,scls) + & ccohort%seed_prod * ccohort%n hio_npp_leaf_canopy_si_scls(io_si,scls) = hio_npp_leaf_canopy_si_scls(io_si,scls) + & - leaf_c_net_alloc * ccohort%n + leaf_m_net_alloc * ccohort%n hio_npp_fnrt_canopy_si_scls(io_si,scls) = hio_npp_fnrt_canopy_si_scls(io_si,scls) + & - fnrt_c_net_alloc * ccohort%n + fnrt_m_net_alloc * ccohort%n hio_npp_sapw_canopy_si_scls(io_si,scls) = hio_npp_sapw_canopy_si_scls(io_si,scls) + & - sapw_c_net_alloc * ccohort%n + sapw_m_net_alloc * ccohort%n hio_npp_dead_canopy_si_scls(io_si,scls) = hio_npp_dead_canopy_si_scls(io_si,scls) + & - struct_c_net_alloc * ccohort%n + struct_m_net_alloc * ccohort%n hio_npp_seed_canopy_si_scls(io_si,scls) = hio_npp_seed_canopy_si_scls(io_si,scls) + & - repro_c_net_alloc * ccohort%n + repro_m_net_alloc * ccohort%n hio_npp_stor_canopy_si_scls(io_si,scls) = hio_npp_stor_canopy_si_scls(io_si,scls) + & - store_c_net_alloc * ccohort%n + store_m_net_alloc * ccohort%n hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) = & hio_yesterdaycanopylevel_canopy_si_scls(io_si,scls) + & @@ -2532,11 +2615,12 @@ 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) + & - store_c * ccohort%n + store_m * ccohort%n hio_bleaf_understory_si_scpf(io_si,scpf) = hio_bleaf_understory_si_scpf(io_si,scpf) + & - leaf_c * ccohort%n + leaf_m * ccohort%n hio_understory_biomass_si(io_si) = hio_understory_biomass_si(io_si) + & - n_perm2 * total_c * g_per_kg + n_perm2 * total_m * g_per_kg + !hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & ! (ccohort%bmort + ccohort%hmort + ccohort%cmort + ! ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n @@ -2544,7 +2628,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_mortality_understory_si_scpf(io_si,scpf) = hio_mortality_understory_si_scpf(io_si,scpf)+ & (ccohort%bmort + ccohort%hmort + ccohort%cmort + & ccohort%frmort + ccohort%smort + ccohort%asmort) * ccohort%n + & - (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * & ccohort%n * sec_per_day * days_per_year hio_nplant_understory_si_scpf(io_si,scpf) = hio_nplant_understory_si_scpf(io_si,scpf) + ccohort%n @@ -2579,38 +2663,38 @@ 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%frmort + ccohort%smort + ccohort%asmort) * & - 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 * & + total_m * ccohort%n * g_per_kg * days_per_sec * years_per_day * ha_per_m2 + & + (ccohort%lmort_direct + ccohort%lmort_collateral + ccohort%lmort_infra) * total_m * & ccohort%n * g_per_kg * ha_per_m2 hio_carbon_balance_understory_si_scls(io_si,scls) = hio_carbon_balance_understory_si_scls(io_si,scls) + & ccohort%npp_acc_hold * ccohort%n hio_leaf_md_understory_si_scls(io_si,scls) = hio_leaf_md_understory_si_scls(io_si,scls) + & - leaf_c_turnover * ccohort%n + leaf_m_turnover * ccohort%n hio_root_md_understory_si_scls(io_si,scls) = hio_root_md_understory_si_scls(io_si,scls) + & - fnrt_c_turnover * ccohort%n + fnrt_m_turnover * ccohort%n hio_bsw_md_understory_si_scls(io_si,scls) = hio_bsw_md_understory_si_scls(io_si,scls) + & - sapw_c_turnover * ccohort%n + sapw_m_turnover * ccohort%n hio_bstore_md_understory_si_scls(io_si,scls) = hio_bstore_md_understory_si_scls(io_si,scls) + & - store_c_turnover * ccohort%n + store_m_turnover * ccohort%n hio_bdead_md_understory_si_scls(io_si,scls) = hio_bdead_md_understory_si_scls(io_si,scls) + & - struct_c_turnover * ccohort%n + struct_m_turnover * ccohort%n hio_seed_prod_understory_si_scls(io_si,scls) = hio_seed_prod_understory_si_scls(io_si,scls) + & ccohort%seed_prod * ccohort%n hio_npp_leaf_understory_si_scls(io_si,scls) = hio_npp_leaf_understory_si_scls(io_si,scls) + & - leaf_c_net_alloc * ccohort%n + leaf_m_net_alloc * ccohort%n hio_npp_fnrt_understory_si_scls(io_si,scls) = hio_npp_fnrt_understory_si_scls(io_si,scls) + & - fnrt_c_net_alloc * ccohort%n + fnrt_m_net_alloc * ccohort%n hio_npp_sapw_understory_si_scls(io_si,scls) = hio_npp_sapw_understory_si_scls(io_si,scls) + & - sapw_c_net_alloc * ccohort%n + sapw_m_net_alloc * ccohort%n hio_npp_dead_understory_si_scls(io_si,scls) = hio_npp_dead_understory_si_scls(io_si,scls) + & - struct_c_net_alloc * ccohort%n + struct_m_net_alloc * ccohort%n hio_npp_seed_understory_si_scls(io_si,scls) = hio_npp_seed_understory_si_scls(io_si,scls) + & - repro_c_net_alloc * ccohort%n + repro_m_net_alloc * ccohort%n hio_npp_stor_understory_si_scls(io_si,scls) = hio_npp_stor_understory_si_scls(io_si,scls) + & - store_c_net_alloc * ccohort%n + store_m_net_alloc * ccohort%n hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) = & hio_yesterdaycanopylevel_understory_si_scls(io_si,scls) + & @@ -2914,12 +2998,11 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_cwd_elcwd(io_si,:) = 0._r8 - do el = 1, num_elements flux_diags => sites(s)%flux_diags(el) - ! Sum up all input litter fluxes (above below, fines, cwd) + ! Sum up all input litter fluxes (above below, fines, cwd) [kg/ha/day] hio_litter_in_elem(io_si, el) = & sum(flux_diags%cwd_ag_input(:)) + & sum(flux_diags%cwd_bg_input(:)) + & @@ -2938,6 +3021,91 @@ subroutine update_history_dyn(this,nc,nsites,sites) hio_seed_in_extern_elem(io_si,el) = 0._r8 hio_litter_out_elem(io_si,el) = 0._r8 + ! Plant multi-element states and fluxes + ! Zero states, and set the fluxes + if(element_list(el).eq.carbon12_element)then + this%hvars(ih_totvegc_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_leafc_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_fnrtc_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_sapwc_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storec_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_reproc_scpf)%r82d(io_si,:) = 0._r8 + + this%hvars(ih_cefflux_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) + + this%hvars(ih_cefflux_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) + + elseif(element_list(el).eq.nitrogen_element)then + + this%hvars(ih_totvegn_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_leafn_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_fnrtn_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_sapwn_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storen_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_repron_scpf)%r82d(io_si,:) = 0._r8 + + this%hvars(ih_nuptake_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_uptake_scpf(:) + + this%hvars(ih_nefflux_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) + + this%hvars(ih_nneedgrow_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_needgrow_scpf(:) + + this%hvars(ih_nneedmax_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_needmax_scpf(:) + + this%hvars(ih_nneedgrow_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_needgrow_scpf(:),dim=1) + + this%hvars(ih_nneedmax_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_needmax_scpf(:),dim=1) + + this%hvars(ih_nuptake_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_uptake_scpf(:),dim=1) + + this%hvars(ih_nefflux_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) + + + elseif(element_list(el).eq.phosphorus_element)then + this%hvars(ih_totvegp_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_leafp_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_fnrtp_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_sapwp_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_storep_scpf)%r82d(io_si,:) = 0._r8 + this%hvars(ih_reprop_scpf)%r82d(io_si,:) = 0._r8 + + this%hvars(ih_puptake_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_uptake_scpf(:) + + this%hvars(ih_pefflux_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_efflux_scpf(:) + + this%hvars(ih_pneedgrow_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_needgrow_scpf(:) + + this%hvars(ih_pneedmax_scpf)%r82d(io_si,:) = & + sites(s)%flux_diags(el)%nutrient_needmax_scpf(:) + + this%hvars(ih_pneedgrow_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_needgrow_scpf(:),dim=1) + + this%hvars(ih_pneedmax_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_needmax_scpf(:),dim=1) + + this%hvars(ih_puptake_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_uptake_scpf(:),dim=1) + + this%hvars(ih_pefflux_si)%r81d(io_si) = & + sum(sites(s)%flux_diags(el)%nutrient_efflux_scpf(:),dim=1) + + end if + + cpatch => sites(s)%oldest_patch do while(associated(cpatch)) @@ -2950,44 +3118,100 @@ subroutine update_history_dyn(this,nc,nsites,sites) (sum(litt%leaf_fines_frag(:)) + & sum(litt%root_fines_frag(:,:)) + & sum(litt%ag_cwd_frag(:)) + & - sum(litt%bg_cwd_frag(:,:))) * area_frac + sum(litt%bg_cwd_frag(:,:))) * cpatch%area hio_seed_bank_elem(io_si,el) = hio_seed_bank_elem(io_si,el) + & - sum(litt%seed(:)) * area_frac + sum(litt%seed(:)) * cpatch%area hio_seed_germ_elem(io_si,el) = hio_seed_germ_elem(io_si,el) + & - sum(litt%seed_germ(:)) * area_frac + sum(litt%seed_germ(:)) * cpatch%area hio_seed_decay_elem(io_si,el) = hio_seed_decay_elem(io_si,el) + & - sum(litt%seed_decay(:)) * area_frac + sum(litt%seed_decay(:)) * cpatch%area hio_seeds_in_local_elem(io_si,el) = hio_seeds_in_local_elem(io_si,el) + & - sum(litt%seed_in_local(:)) * area_frac + sum(litt%seed_in_local(:)) * cpatch%area hio_seed_in_extern_elem(io_si,el) = hio_seed_in_extern_elem(io_si,el) + & - sum(litt%seed_in_extern(:)) * area_frac + sum(litt%seed_in_extern(:)) * cpatch%area ! Litter State Variables hio_cwd_ag_elem(io_si,el) = hio_cwd_ag_elem(io_si,el) + & - sum(litt%ag_cwd(:)) * area_frac + sum(litt%ag_cwd(:)) * cpatch%area hio_cwd_bg_elem(io_si,el) = hio_cwd_bg_elem(io_si,el) + & - sum(litt%bg_cwd(:,:)) * area_frac + sum(litt%bg_cwd(:,:)) * cpatch%area hio_fines_ag_elem(io_si,el) = hio_fines_ag_elem(io_si,el) + & - sum(litt%leaf_fines(:)) * area_frac + sum(litt%leaf_fines(:)) * cpatch%area hio_fines_bg_elem(io_si,el) = hio_fines_bg_elem(io_si,el) + & - sum(litt%root_fines(:,:)) * area_frac - + sum(litt%root_fines(:,:)) * cpatch%area do cwd=1,ncwd elcwd = (el-1)*ncwd+cwd hio_cwd_elcwd(io_si,elcwd) = hio_cwd_elcwd(io_si,elcwd) + & - (litt%ag_cwd(cwd) + sum(litt%bg_cwd(cwd,:))) * area_frac + (litt%ag_cwd(cwd) + sum(litt%bg_cwd(cwd,:))) * cpatch%area end do + ! Load Mass States + ccohort => cpatch%tallest + do while(associated(ccohort)) + + sapw_m = ccohort%prt%GetState(sapw_organ, element_list(el)) + struct_m = ccohort%prt%GetState(struct_organ, element_list(el)) + leaf_m = ccohort%prt%GetState(leaf_organ, element_list(el)) + fnrt_m = ccohort%prt%GetState(fnrt_organ, element_list(el)) + store_m = ccohort%prt%GetState(store_organ, element_list(el)) + repro_m = ccohort%prt%GetState(repro_organ, element_list(el)) + total_m = sapw_m+struct_m+leaf_m+fnrt_m+store_m+repro_m + + i_scpf = ccohort%size_by_pft_class + + if(element_list(el).eq.carbon12_element)then + this%hvars(ih_totvegc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_totvegc_scpf)%r82d(io_si,i_scpf) + total_m * ccohort%n + this%hvars(ih_leafc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_leafc_scpf)%r82d(io_si,i_scpf) + leaf_m * ccohort%n + this%hvars(ih_fnrtc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_fnrtc_scpf)%r82d(io_si,i_scpf) + fnrt_m * ccohort%n + this%hvars(ih_sapwc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_sapwc_scpf)%r82d(io_si,i_scpf) + sapw_m * ccohort%n + this%hvars(ih_storec_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storec_scpf)%r82d(io_si,i_scpf) + store_m * ccohort%n + this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_reproc_scpf)%r82d(io_si,i_scpf) + repro_m * ccohort%n + elseif(element_list(el).eq.nitrogen_element)then + this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_totvegn_scpf)%r82d(io_si,i_scpf) + total_m * ccohort%n + this%hvars(ih_leafn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_leafn_scpf)%r82d(io_si,i_scpf) + leaf_m * ccohort%n + this%hvars(ih_fnrtn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_fnrtn_scpf)%r82d(io_si,i_scpf) + fnrt_m * ccohort%n + this%hvars(ih_sapwn_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_sapwn_scpf)%r82d(io_si,i_scpf) + sapw_m * ccohort%n + this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storen_scpf)%r82d(io_si,i_scpf) + store_m * ccohort%n + this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_repron_scpf)%r82d(io_si,i_scpf) + repro_m * ccohort%n + elseif(element_list(el).eq.phosphorus_element)then + this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_totvegp_scpf)%r82d(io_si,i_scpf) + total_m * ccohort%n + this%hvars(ih_leafp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_leafp_scpf)%r82d(io_si,i_scpf) + leaf_m * ccohort%n + this%hvars(ih_fnrtp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_fnrtp_scpf)%r82d(io_si,i_scpf) + fnrt_m * ccohort%n + this%hvars(ih_sapwp_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_sapwp_scpf)%r82d(io_si,i_scpf) + sapw_m * ccohort%n + this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_storep_scpf)%r82d(io_si,i_scpf) + store_m * ccohort%n + this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) = & + this%hvars(ih_reprop_scpf)%r82d(io_si,i_scpf) + repro_m * ccohort%n + end if + + ccohort => ccohort%shorter + end do cpatch => cpatch%younger end do @@ -3045,9 +3269,7 @@ subroutine update_history_dyn(this,nc,nsites,sites) return end subroutine update_history_dyn - ! ====================================================================================== - - subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) + subroutine update_history_hifrq(this,nc,nsites,sites,bc_in,dt_tstep) ! --------------------------------------------------------------------------------- ! This is the call to update the history IO arrays that are expected to only change @@ -3061,6 +3283,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) integer , intent(in) :: nc ! clump index integer , intent(in) :: nsites type(ed_site_type) , intent(inout), target :: sites(nsites) + type(bc_in_type) , intent(in) :: bc_in(nsites) real(r8) , intent(in) :: dt_tstep ! Locals @@ -3073,6 +3296,10 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) integer :: lb1,ub1,lb2,ub2 ! IO array bounds for the calling thread integer :: ivar ! index of IO variable object vector integer :: ft ! functional type index + real(r8) :: n_density ! individual of cohort per m2. + real(r8) :: resp_g ! growth respiration per timestep [kgC/indiv/step] + real(r8) :: npp ! npp for this time-step (adjusted for g resp) [kgC/indiv/step] + real(r8) :: aresp ! autotrophic respiration (adjusted for g resp) [kgC/indiv/step] real(r8) :: n_perm2 ! individuals per m2 for the whole column real(r8) :: patch_area_by_age(nlevage) ! patch area in each bin for normalizing purposes real(r8) :: canopy_area_by_age(nlevage) ! canopy area in each bin for normalizing purposes @@ -3090,6 +3317,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_growth_resp_si => this%hvars(ih_growth_resp_si)%r81d, & hio_c_stomata_si => this%hvars(ih_c_stomata_si)%r81d, & hio_c_lblayer_si => this%hvars(ih_c_lblayer_si)%r81d, & + hio_nep_si => this%hvars(ih_nep_si)%r81d, & hio_ar_si_scpf => this%hvars(ih_ar_si_scpf)%r82d, & hio_ar_grow_si_scpf => this%hvars(ih_ar_grow_si_scpf)%r82d, & hio_ar_maint_si_scpf => this%hvars(ih_ar_maint_si_scpf)%r82d, & @@ -3164,6 +3392,8 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) io_pa1 = this%iovar_map(nc)%patch1_index(s) io_soipa = io_pa1-1 + hio_nep_si(io_si) = -bc_in(s)%tot_het_resp ! (gC/m2/s) + ipa = 0 cpatch => sites(s)%oldest_patch @@ -3202,22 +3432,32 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) if ( .not. ccohort%isnew ) then + npp = ccohort%npp_tstep + resp_g = ccohort%resp_g_tstep + aresp = ccohort%resp_tstep + ! Calculate index for the scpf class associate( scpf => ccohort%size_by_pft_class, & scls => ccohort%size_class ) ! scale up cohort fluxes to the site level hio_npp_si(io_si) = hio_npp_si(io_si) + & - ccohort%npp_tstep * g_per_kg * n_perm2 * per_dt_tstep + npp * g_per_kg * n_perm2 * per_dt_tstep + hio_gpp_si(io_si) = hio_gpp_si(io_si) + & ccohort%gpp_tstep * g_per_kg * n_perm2 * per_dt_tstep hio_aresp_si(io_si) = hio_aresp_si(io_si) + & - ccohort%resp_tstep * g_per_kg * n_perm2 * per_dt_tstep + aresp * g_per_kg * n_perm2 * per_dt_tstep hio_growth_resp_si(io_si) = hio_growth_resp_si(io_si) + & - ccohort%resp_g * g_per_kg * n_perm2 * per_dt_tstep + resp_g * g_per_kg * n_perm2 * per_dt_tstep hio_maint_resp_si(io_si) = hio_maint_resp_si(io_si) + & ccohort%resp_m * g_per_kg * n_perm2 * per_dt_tstep - + + ! Add up the total Net Ecosystem Production + ! for this timestep. [gC/m2/s] + hio_nep_si(io_si) = hio_nep_si(io_si) + & + npp * g_per_kg * n_perm2 * per_dt_tstep + ! aggregate MR fluxes to the site level hio_leaf_mr_si(io_si) = hio_leaf_mr_si(io_si) + ccohort%rdark & * n_perm2 * sec_per_day * days_per_year @@ -3234,7 +3474,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) ! Growth AR (kgC/m2/yr) hio_ar_grow_si_scpf(io_si,scpf) = hio_ar_grow_si_scpf(io_si,scpf) + & - (ccohort%resp_g/dt_tstep) * n_perm2 * sec_per_day * days_per_year + (resp_g/dt_tstep) * n_perm2 * sec_per_day * days_per_year ! Maint AR (kgC/m2/yr) hio_ar_maint_si_scpf(io_si,scpf) = hio_ar_maint_si_scpf(io_si,scpf) + & @@ -3262,7 +3502,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_gpp_si_age(io_si,cpatch%age_class) = hio_gpp_si_age(io_si,cpatch%age_class) & + ccohort%gpp_tstep * ccohort%n * g_per_kg * per_dt_tstep hio_npp_si_age(io_si,cpatch%age_class) = hio_npp_si_age(io_si,cpatch%age_class) & - + ccohort%npp_tstep * ccohort%n * g_per_kg * per_dt_tstep + + npp * ccohort%n * g_per_kg * per_dt_tstep ! accumulate fluxes on canopy- and understory- separated fluxes if (ccohort%canopy_layer .eq. 1) then @@ -3271,7 +3511,8 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_gpp_canopy_si(io_si) = hio_gpp_canopy_si(io_si) + & ccohort%gpp_tstep * g_per_kg * n_perm2 * per_dt_tstep hio_ar_canopy_si(io_si) = hio_ar_canopy_si(io_si) + & - ccohort%resp_tstep * g_per_kg * n_perm2 * per_dt_tstep + aresp * g_per_kg * n_perm2 * per_dt_tstep + ! ! size-resolved respiration fluxes are in kg C / ha / yr hio_rdark_canopy_si_scls(io_si,scls) = hio_rdark_canopy_si_scls(io_si,scls) + & @@ -3283,7 +3524,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_froot_mr_canopy_si_scls(io_si,scls) = hio_froot_mr_canopy_si_scls(io_si,scls) + & ccohort%froot_mr * ccohort%n * sec_per_day * days_per_year hio_resp_g_canopy_si_scls(io_si,scls) = hio_resp_g_canopy_si_scls(io_si,scls) + & - ccohort%resp_g * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + resp_g * ccohort%n * sec_per_day * days_per_year * per_dt_tstep hio_resp_m_canopy_si_scls(io_si,scls) = hio_resp_m_canopy_si_scls(io_si,scls) + & ccohort%resp_m * ccohort%n * sec_per_day * days_per_year * per_dt_tstep else @@ -3292,7 +3533,8 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_gpp_understory_si(io_si) = hio_gpp_understory_si(io_si) + & ccohort%gpp_tstep * g_per_kg * n_perm2 * per_dt_tstep hio_ar_understory_si(io_si) = hio_ar_understory_si(io_si) + & - ccohort%resp_tstep * g_per_kg * n_perm2 * per_dt_tstep + aresp * g_per_kg * n_perm2 * per_dt_tstep + ! ! size-resolved respiration fluxes are in kg C / ha / yr hio_rdark_understory_si_scls(io_si,scls) = hio_rdark_understory_si_scls(io_si,scls) + & @@ -3304,7 +3546,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_froot_mr_understory_si_scls(io_si,scls) = hio_froot_mr_understory_si_scls(io_si,scls) + & ccohort%froot_mr * ccohort%n * sec_per_day * days_per_year hio_resp_g_understory_si_scls(io_si,scls) = hio_resp_g_understory_si_scls(io_si,scls) + & - ccohort%resp_g * ccohort%n * sec_per_day * days_per_year * per_dt_tstep + resp_g * ccohort%n * sec_per_day * days_per_year * per_dt_tstep hio_resp_m_understory_si_scls(io_si,scls) = hio_resp_m_understory_si_scls(io_si,scls) + & ccohort%resp_m * ccohort%n * sec_per_day * days_per_year * per_dt_tstep endif @@ -3398,7 +3640,7 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) cpatch%fabi_sha_z(ican,ipft,1) * cpatch%area * AREA_INV ! end do - end do + end do ! PFT-mean radiation profiles do ican=1,nclmax @@ -3448,12 +3690,12 @@ subroutine update_history_prod(this,nc,nsites,sites,dt_tstep) hio_c_stomata_si(io_si) = 0._r8 hio_c_lblayer_si(io_si) = 0._r8 end if - - enddo ! site loop - end associate + enddo ! site loop + + end associate - end subroutine update_history_prod +end subroutine update_history_hifrq ! ===================================================================================== @@ -4040,6 +4282,7 @@ subroutine define_history_vars(this, initialize_variables) else tempstring = 'inactive' endif + call this%set_history_var(vname='ZSTAR_BY_AGE', units='m', & long='product of zstar and patch area by age bin (divide by PATCH_AREA_BY_AGE to get mean zstar)', & use_default=trim(tempstring), & @@ -4219,40 +4462,190 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_seeds_in_si ) - call this%set_history_var(vname='LITTER_IN_ELEM', units='kg m-2 d-1', & + call this%set_history_var(vname='LITTER_IN_ELEM', units='kg ha-1 d-1', & long='FATES litter flux in', use_default='active', & avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_litter_in_elem ) - call this%set_history_var(vname='LITTER_OUT_ELEM', units='kg m-2 d-1', & + call this%set_history_var(vname='LITTER_OUT_ELEM', units='kg ha-1 d-1', & long='FATES litter flux out (fragmentation only)', use_default='active', & avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_litter_out_elem ) - call this%set_history_var(vname='SEED_BANK_ELEM', units='kg m-2', & + call this%set_history_var(vname='SEED_BANK_ELEM', units='kg ha-1', & long='Total Seed Mass of all PFTs', use_default='active', & avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_seed_bank_elem ) - call this%set_history_var(vname='SEEDS_IN_LOCAL_ELEM', units='kg m-2 d-1', & + call this%set_history_var(vname='SEEDS_IN_LOCAL_ELEM', units='kg ha-1 d-1', & long='Within Site Seed Production Rate', use_default='active', & avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_seeds_in_local_elem ) - call this%set_history_var(vname='SEEDS_IN_EXTERN_ELEM', units='kg m-2 d-1', & + call this%set_history_var(vname='SEEDS_IN_EXTERN_ELEM', units='kg ha-1 d-1', & long='External Seed Influx Rate', use_default='active', & avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_seeds_in_extern_elem ) - call this%set_history_var(vname='SEED_GERM_ELEM', units='kg m-2 d-1', & + call this%set_history_var(vname='SEED_GERM_ELEM', units='kg ha-1 d-1', & long='Seed mass converted into new cohorts', use_default='active', & avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_seed_germ_elem ) - call this%set_history_var(vname='SEED_DECAY', units='kg m-2 d-1', & + call this%set_history_var(vname='SEED_DECAY_ELEM', units='kg ha-1 d-1', & long='Seed mass decay', use_default='active', & avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_seed_decay_elem ) + + + ! SITE LEVEL CARBON STATE VARIABLES + call this%set_history_var(vname='STOREC', units='kgC ha-1', & + long='Total carbon in live plant storage', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_storec_si ) + + call this%set_history_var(vname='TOTVEGC', units='kgC ha-1', & + long='Total carbon in live plants', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_totvegc_si ) + + call this%set_history_var(vname='SAPWC', units='kgC ha-1', & + long='Total carbon in live plant sapwood', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_sapwc_si ) + + call this%set_history_var(vname='LEAFC', units='kgC ha-1', & + long='Total carbon in live plant leaves', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_leafc_si ) + + call this%set_history_var(vname='FNRTC', units='kgC ha-1', & + long='Total carbon in live plant fine-roots', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fnrtc_si ) + + call this%set_history_var(vname='REPROC', units='kgC ha-1', & + long='Total carbon in live plant reproductive tissues', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_reproc_si ) + + call this%set_history_var(vname='CEFFLUX', units='kgC/ha/day', & + long='carbon efflux, root to soil', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cefflux_si ) + + + nitrogen_active_if: if(any(element_list(:)==nitrogen_element)) then + call this%set_history_var(vname='STOREN', units='kgN ha-1', & + long='Total nitrogen in live plant storage', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_storen_si ) + + call this%set_history_var(vname='TOTVEGN', units='kgN ha-1', & + long='Total nitrogen in live plants', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_totvegn_si ) + + call this%set_history_var(vname='SAPWN', units='kgN ha-1', & + long='Total nitrogen in live plant sapwood', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_sapwn_si ) + + call this%set_history_var(vname='LEAFN', units='kgN ha-1', & + long='Total nitrogen in live plant leaves', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_leafn_si ) + + call this%set_history_var(vname='FNRTN', units='kgN ha-1', & + long='Total nitrogen in live plant fine-roots', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fnrtn_si ) + + call this%set_history_var(vname='REPRON', units='kgN ha-1', & + long='Total nitrogen in live plant reproductive tissues', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_repron_si ) + + call this%set_history_var(vname='NUPTAKE', units='kgN d-1 ha-1', & + long='Total nitrogen uptake by plants per sq meter per day', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_nuptake_si ) + + call this%set_history_var(vname='NEFFLUX', units='kgN d-1 ha-1', & + long='Nitrogen effluxed from plant (unused)', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_nefflux_si ) + + call this%set_history_var(vname='NNEED_GROW', units='kgN d-1 ha-1', & + long='(Approx) plant nitrogen needed to satisfy growth', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_nneedgrow_si ) + + call this%set_history_var(vname='NNEED_MAX', units='kgN d-1 ha-1', & + long='(Approx) plant nitrogen needed to reach maximum capacity', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_nneedmax_si ) + + end if nitrogen_active_if + + + phosphorus_active_if: if(any(element_list(:)==phosphorus_element)) then + call this%set_history_var(vname='STOREP', units='kgP ha-1', & + long='Total phosphorus in live plant storage', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_storep_si ) + + call this%set_history_var(vname='TOTVEGP', units='kgP ha-1', & + long='Total phosphorus in live plants', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_totvegp_si ) + + call this%set_history_var(vname='SAPWP', units='kgP ha-1', & + long='Total phosphorus in live plant sapwood', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_sapwp_si ) + + call this%set_history_var(vname='LEAFP', units='kgP ha-1', & + long='Total phosphorus in live plant leaves', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_leafp_si ) + + call this%set_history_var(vname='FNRTP', units='kgP ha-1', & + long='Total phosphorus in live plant fine-roots', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_fnrtp_si ) + + call this%set_history_var(vname='REPROP', units='kgP ha-1', & + long='Total phosphorus in live plant reproductive tissues', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_reprop_si ) + + call this%set_history_var(vname='PUPTAKE', units='kgP ha-1 d-1', & + long='Total phosphorus uptake by plants per sq meter per day', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_puptake_si ) + + call this%set_history_var(vname='PEFFLUX', units='kgP ha-1 d-1', & + long='Phosphorus effluxed from plant (unused)', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_pefflux_si ) + + call this%set_history_var(vname='PNEED_GROW', units='kgP ha-1 d-1', & + long='Plant phosphorus needed to satisfy growth', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_pneedgrow_si ) + + call this%set_history_var(vname='PNEED_MAX', units='kgP ha-1 d-1', & + long='Plant phosphorus needed to reach maximum capacity', use_default='active', & + avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & + ivar=ivar, initialize=initialize_variables, index = ih_pneedmax_si ) + + + end if phosphorus_active_if + + + ! Consider deprecating the "ED_" variables (RGK 08-2020) + ! They have been replaced, eg. STOREC = ED_bstore call this%set_history_var(vname='ED_bstore', units='gC m-2', & long='Storage biomass', use_default='active', & @@ -4290,6 +4683,7 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & ivar=ivar, initialize=initialize_variables, index = ih_btotal_si ) + call this%set_history_var(vname='AGB', units='gC m-2', & long='Aboveground biomass', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, upfreq=1, & @@ -5389,7 +5783,7 @@ subroutine define_history_vars(this, initialize_variables) call this%set_history_var(vname='NEP', units='gC/m^2/s', & long='net ecosystem production', use_default='active', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & - upfreq=3, ivar=ivar, initialize=initialize_variables, index = ih_nep_si ) + upfreq=2, ivar=ivar, initialize=initialize_variables, index = ih_nep_si ) call this%set_history_var(vname='Fire_Closs', units='gC/m^2/s', & long='ED/SPitfire Carbon loss to atmosphere', use_default='active', & @@ -5411,31 +5805,177 @@ subroutine define_history_vars(this, initialize_variables) avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_err_fates_si ) - call this%set_history_var(vname='LITTER_FINES_AG_ELEM', units='kg/m^2', & + call this%set_history_var(vname='LITTER_FINES_AG_ELEM', units='kg ha-1', & long='mass of above ground litter in fines (leaves,nonviable seed)', use_default='active', & avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fines_ag_elem ) - call this%set_history_var(vname='LITTER_FINES_BG_ELEM', units='kg/m^2', & + call this%set_history_var(vname='LITTER_FINES_BG_ELEM', units='kg ha-1', & long='mass of below ground litter in fines (fineroots)', use_default='active', & avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fines_bg_elem ) - call this%set_history_var(vname='LITTER_CWD_BG_ELEM', units='kg/m^2', & + call this%set_history_var(vname='LITTER_CWD_BG_ELEM', units='kg ha-1', & long='mass of below ground litter in CWD (coarse roots)', use_default='active', & avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_bg_elem ) - call this%set_history_var(vname='LITTER_CWD_AG_ELEM', units='kg/m^2', & + call this%set_history_var(vname='LITTER_CWD_AG_ELEM', units='kg ha-1', & long='mass of above ground litter in CWD (trunks/branches/twigs)', use_default='active', & avgflag='A', vtype=site_elem_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_ag_elem ) - call this%set_history_var(vname='LITTER_CWD', units='kg/m^2', & + call this%set_history_var(vname='LITTER_CWD', units='kg ha-1', & long='total mass of litter in CWD', use_default='active', & avgflag='A', vtype=site_elcwd_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cwd_elcwd ) + ! Mass states C/N/P SCPF dimensions + ! CARBON + call this%set_history_var(vname='TOTVEGC_SCPF', units='kgC/ha', & + long='total vegetation carbon mass in live plants by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_totvegc_scpf ) + + call this%set_history_var(vname='LEAFC_SCPF', units='kgC/ha', & + long='leaf carbon mass by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leafc_scpf ) + + call this%set_history_var(vname='FNRTC_SCPF', units='kgC/ha', & + long='fine-root carbon mass by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fnrtc_scpf ) + + call this%set_history_var(vname='SAPWC_SCPF', units='kgC/ha', & + long='sapwood carbon mass by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sapwc_scpf ) + + call this%set_history_var(vname='STOREC_SCPF', units='kgC/ha', & + long='storage carbon mass by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storec_scpf ) + + call this%set_history_var(vname='REPROC_SCPF', units='kgC/ha', & + long='reproductive carbon mass (on plant) by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_reproc_scpf ) + + call this%set_history_var(vname='CEFFLUX_SCPF', units='kg/ha/day', & + long='carbon efflux, root to soil, by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_cefflux_scpf ) + + ! NITROGEN + nitrogen_active_if2: if(any(element_list(:)==nitrogen_element)) then + call this%set_history_var(vname='TOTVEGN_SCPF', units='kgN/ha', & + long='total (live) vegetation nitrogen mass by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_totvegn_scpf ) + + call this%set_history_var(vname='LEAFN_SCPF', units='kgN/ha', & + long='leaf nitrogen mass by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leafn_scpf ) + + call this%set_history_var(vname='FNRTN_SCPF', units='kgN/ha', & + long='fine-root nitrogen mass by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fnrtn_scpf ) + + call this%set_history_var(vname='SAPWN_SCPF', units='kgN/ha', & + long='sapwood nitrogen mass by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sapwn_scpf ) + + call this%set_history_var(vname='STOREN_SCPF', units='kgN/ha', & + long='storage nitrogen mass by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storen_scpf ) + + call this%set_history_var(vname='REPRON_SCPF', units='kgN/ha', & + long='reproductive nitrogen mass (on plant) by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_repron_scpf ) + + call this%set_history_var(vname='NUPTAKE_SCPF', units='kgN d-1 ha-1', & + long='nitrogen uptake, soil to root, by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nuptake_scpf ) + + call this%set_history_var(vname='NEFFLUX_SCPF', units='kgN d-1 ha-1', & + long='nitrogen efflux, root to soil, by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nefflux_scpf ) + + call this%set_history_var(vname='NNEEDGROW_SCPF', units='kgN d-1 ha-1', & + long='nitrogen needed to match growth, by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nneedgrow_scpf ) + + call this%set_history_var(vname='NNEEDMAX_SCPF', units='kgN d-1 ha-1', & + long='nitrogen needed to reach max concentrations, by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_nneedmax_scpf ) + + + end if nitrogen_active_if2 + + ! PHOSPHORUS + phosphorus_active_if2: if(any(element_list(:)==phosphorus_element))then + call this%set_history_var(vname='TOTVEGP_SCPF', units='kgP/ha', & + long='total (live) vegetation phosphorus mass by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_totvegp_scpf ) + + call this%set_history_var(vname='LEAFP_SCPF', units='kgP/ha', & + long='leaf phosphorus mass by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_leafp_scpf ) + + call this%set_history_var(vname='FNRTP_SCPF', units='kgP/ha', & + long='fine-root phosphorus mass by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_fnrtp_scpf ) + + call this%set_history_var(vname='SAPWP_SCPF', units='kgP/ha', & + long='sapwood phosphorus mass by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_sapwp_scpf ) + + call this%set_history_var(vname='STOREP_SCPF', units='kgP/ha', & + long='storage phosphorus mass by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_storep_scpf ) + + call this%set_history_var(vname='REPROP_SCPF', units='kgP/ha', & + long='reproductive phosphorus mass (on plant) by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_reprop_scpf ) + + call this%set_history_var(vname='PUPTAKE_SCPF', units='kg/ha/day', & + long='phosphorus uptake, soil to root, by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_puptake_scpf ) + + call this%set_history_var(vname='PEFFLUX_SCPF', units='kg/ha/day', & + long='phosphorus efflux, root to soil, by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_pefflux_scpf ) + + call this%set_history_var(vname='PNEEDGROW_SCPF', units='kg/ha/day', & + long='phosphorus needed to match growth, by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_pneedgrow_scpf ) + + call this%set_history_var(vname='PNEEDMAX_SCPF', units='kg/ha/day', & + long='phosphorus needed to reach max concentrations, by size-class x pft', use_default='inactive', & + avgflag='A', vtype=site_size_pft_r8, hlms='CLM:ALM', flushval=hlm_hio_ignore_val, & + upfreq=1, ivar=ivar, initialize=initialize_variables, index = ih_pneedmax_scpf ) + + end if phosphorus_active_if2 + ! organ-partitioned NPP / allocation fluxes call this%set_history_var(vname='NPP_LEAF', units='kgC/m2/yr', & long='NPP flux into leaves', use_default='active', & @@ -5470,7 +6010,7 @@ subroutine define_history_vars(this, initialize_variables) ! PLANT HYDRAULICS - if(hlm_use_planthydro.eq.itrue) then + hydro_active_if: if(hlm_use_planthydro.eq.itrue) then call this%set_history_var(vname='FATES_ERRH2O_SCPF', units='kg/indiv/s', & long='mean individual water balance error', use_default='inactive', & @@ -5659,7 +6199,7 @@ subroutine define_history_vars(this, initialize_variables) long='cumulative net borrowed (+) from plant_stored_h2o due to plant hydrodynamics', use_default='inactive', & avgflag='A', vtype=site_r8, hlms='CLM:ALM', flushval=0.0_r8, & upfreq=4, ivar=ivar, initialize=initialize_variables, index = ih_h2oveg_hydro_err_si ) - end if + end if hydro_active_if ! Must be last thing before return this%num_history_vars_ = ivar diff --git a/main/FatesInterfaceMod.F90 b/main/FatesInterfaceMod.F90 index b43992b94f..24b10f1ded 100644 --- a/main/FatesInterfaceMod.F90 +++ b/main/FatesInterfaceMod.F90 @@ -21,10 +21,9 @@ module FatesInterfaceMod use EDTypesMod , only : do_fates_salinity use EDTypesMod , only : numWaterMem use EDTypesMod , only : numlevsoil_max - use EDTypesMod , only : num_elements - use EDTypesMod , only : element_list use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : itrue,ifalse + use FatesConstantsMod , only : nearzero use FatesGlobals , only : fates_global_verbose use FatesGlobals , only : fates_log use FatesGlobals , only : endrun => fates_endrun @@ -36,30 +35,48 @@ module FatesInterfaceMod use SFParamsMod , only : SpitFireCheckParams use EDParamsMod , only : FatesReportParams use EDParamsMod , only : bgc_soil_salinity - use PRTGenericMod , only : prt_carbon_allom_hyp - use PRTGenericMod , only : prt_cnp_flex_allom_hyp - use PRTGenericMod , only : carbon12_element - use PRTGenericMod , only : nitrogen_element - use PRTGenericMod , only : phosphorus_element - use EDTypesMod , only : element_pos, element_list use FatesPlantHydraulicsMod , only : InitHydroGlobals use EDParamsMod , only : ED_val_history_sizeclass_bin_edges use EDParamsMod , only : ED_val_history_ageclass_bin_edges use EDParamsMod , only : ED_val_history_height_bin_edges use EDParamsMod , only : ED_val_history_coageclass_bin_edges use CLMFatesParamInterfaceMod , only : FatesReadParameters + use EDTypesMod , only : p_uptake_mode + use EDTypesMod , only : n_uptake_mode + use FatesConstantsMod , only : prescribed_p_uptake + use FatesConstantsMod , only : prescribed_n_uptake + use FatesConstantsMod , only : coupled_p_uptake + use FatesConstantsMod , only : coupled_n_uptake + use FatesConstantsMod , only : fates_np_comp_scaling + use FatesConstantsMod , only : cohort_np_comp_scaling + use FatesConstantsMod , only : pft_np_comp_scaling + use PRTGenericMod , only : num_elements + use PRTGenericMod , only : element_list + use PRTGenericMod , only : element_pos + use EDParamsMod , only : eca_plant_escalar + use PRTGenericMod , only : prt_carbon_allom_hyp + use PRTGenericMod , only : prt_cnp_flex_allom_hyp + use PRTGenericMod , only : carbon12_element + use PRTGenericMod , only : nitrogen_element + use PRTGenericMod , only : phosphorus_element + use PRTGenericMod , only : num_organ_types + use PRTGenericMod , only : leaf_organ, fnrt_organ, store_organ + use PRTGenericMod , only : sapw_organ, struct_organ, repro_organ + use PRTParametersMod , only : prt_params + use PRTInitParamsFatesMod , only : PRTCheckParams use PRTAllometricCarbonMod , only : InitPRTGlobalAllometricCarbon - use decompMod , only : bounds_type + use PRTAllometricCNPMod , only : InitPRTGlobalAllometricCNP + ! CIME Globals use shr_log_mod , only : errMsg => shr_log_errMsg use shr_infnan_mod , only : nan => shr_infnan_nan, assignment(=) - ! Just use everything from FatesInterfaceTypesMod, this is ! its sister code use FatesInterfaceTypesMod + implicit none private @@ -75,6 +92,8 @@ module FatesInterfaceMod public :: FatesReportParameters public :: allocate_bcin public :: allocate_bcout + public :: allocate_bcpconst + public :: set_bcpconst public :: zero_bcs public :: set_bcs @@ -117,6 +136,59 @@ end subroutine fates_clean ! ==================================================================================== + + subroutine allocate_bcpconst(bc_pconst,nlevdecomp) + + type(bc_pconst_type), intent(inout) :: bc_pconst + integer , intent(in) :: nlevdecomp + + allocate(bc_pconst%eca_km_nh4(numpft)) + allocate(bc_pconst%eca_vmax_nh4(numpft)) + allocate(bc_pconst%eca_km_no3(numpft)) + allocate(bc_pconst%eca_vmax_no3(numpft)) + allocate(bc_pconst%eca_km_p(numpft)) + allocate(bc_pconst%eca_vmax_p(numpft)) + allocate(bc_pconst%eca_km_ptase(numpft)) + allocate(bc_pconst%eca_vmax_ptase(numpft)) + allocate(bc_pconst%eca_alpha_ptase(numpft)) + allocate(bc_pconst%eca_lambda_ptase(numpft)) + allocate(bc_pconst%j_uptake(nlevdecomp)) + + return + end subroutine allocate_bcpconst + + ! ==================================================================================== + + subroutine set_bcpconst(bc_pconst,nlevdecomp) + + type(bc_pconst_type), intent(inout) :: bc_pconst + integer , intent(in) :: nlevdecomp + integer :: j + + bc_pconst%eca_km_nh4(1:numpft) = EDPftvarcon_inst%eca_km_nh4(1:numpft) + bc_pconst%eca_vmax_nh4(1:numpft) = EDPftvarcon_inst%eca_vmax_nh4(1:numpft) + bc_pconst%eca_km_no3(1:numpft) = EDPftvarcon_inst%eca_km_no3(1:numpft) + bc_pconst%eca_vmax_no3(1:numpft) = EDPftvarcon_inst%eca_vmax_no3(1:numpft) + bc_pconst%eca_km_p(1:numpft) = EDPftvarcon_inst%eca_km_p(1:numpft) + bc_pconst%eca_vmax_p(1:numpft) = EDPftvarcon_inst%eca_vmax_p(1:numpft) + bc_pconst%eca_km_ptase(1:numpft) = EDPftvarcon_inst%eca_km_ptase(1:numpft) + bc_pconst%eca_vmax_ptase(1:numpft) = EDPftvarcon_inst%eca_vmax_ptase(1:numpft) + bc_pconst%eca_alpha_ptase(1:numpft) = EDPftvarcon_inst%eca_alpha_ptase(1:numpft) + bc_pconst%eca_lambda_ptase(1:numpft) = EDPftvarcon_inst%eca_lambda_ptase(1:numpft) + bc_pconst%eca_plant_escalar = eca_plant_escalar + if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then + bc_pconst%j_uptake(1:nlevdecomp) = 1 + else + do j=1,nlevdecomp + bc_pconst%j_uptake(j) = j + end do + end if + + return + end subroutine set_bcpconst + + ! ==================================================================================== + subroutine zero_bcs(fates,s) type(fates_interface_type), intent(inout) :: fates @@ -173,7 +245,7 @@ subroutine zero_bcs(fates,s) fates%bc_out(s)%laisha_pa(:) = 0.0_r8 fates%bc_out(s)%rootr_pasl(:,:) = 0.0_r8 fates%bc_out(s)%btran_pa(:) = 0.0_r8 - + ! Fates -> BGC fragmentation mass fluxes select case(hlm_parteh_mode) case(prt_carbon_allom_hyp) @@ -181,6 +253,11 @@ subroutine zero_bcs(fates,s) fates%bc_out(s)%litt_flux_lig_c_si(:) = 0._r8 fates%bc_out(s)%litt_flux_lab_c_si(:) = 0._r8 case(prt_cnp_flex_allom_hyp) + + fates%bc_in(s)%plant_n_uptake_flux(:,:) = 0._r8 + fates%bc_in(s)%plant_p_uptake_flux(:,:) = 0._r8 + fates%bc_out(s)%source_p(:) = 0._r8 + fates%bc_out(s)%source_nh4(:) = 0._r8 fates%bc_out(s)%litt_flux_cel_c_si(:) = 0._r8 fates%bc_out(s)%litt_flux_lig_c_si(:) = 0._r8 fates%bc_out(s)%litt_flux_lab_c_si(:) = 0._r8 @@ -190,6 +267,7 @@ subroutine zero_bcs(fates,s) fates%bc_out(s)%litt_flux_cel_p_si(:) = 0._r8 fates%bc_out(s)%litt_flux_lig_p_si(:) = 0._r8 fates%bc_out(s)%litt_flux_lab_p_si(:) = 0._r8 + case default write(fates_log(), *) 'An unknown parteh hypothesis was passed' write(fates_log(), *) 'while zeroing output boundary conditions' @@ -197,8 +275,6 @@ subroutine zero_bcs(fates,s) call endrun(msg=errMsg(sourcefile, __LINE__)) end select - - fates%bc_out(s)%rssun_pa(:) = 0.0_r8 fates%bc_out(s)%rssha_pa(:) = 0.0_r8 @@ -296,6 +372,26 @@ subroutine allocate_bcin(bc_in, nlevsoil_in, nlevdecomp_in, num_lu_harvest_cats) end if end if + ! Plant Nutrient Aquisition variables + ! If we are up-scaling to PFT, then we need to pass bach PFTxlayer + ! if we don't, then there is ambiguity in the uptake. If we + ! do not upscale to PFT, then we can simply send back the + ! uptake for each cohort, and don't need to allocate by layer + ! Allocating differently could save a lot of memory and time + + if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then + if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then + allocate(bc_in%plant_n_uptake_flux(max_comp_per_site,1)) + allocate(bc_in%plant_p_uptake_flux(max_comp_per_site,1)) + else + allocate(bc_in%plant_n_uptake_flux(max_comp_per_site,bc_in%nlevdecomp)) + allocate(bc_in%plant_p_uptake_flux(max_comp_per_site,bc_in%nlevdecomp)) + end if + else + allocate(bc_in%plant_n_uptake_flux(1,1)) + allocate(bc_in%plant_p_uptake_flux(1,1)) + end if + allocate(bc_in%zi_sisl(0:nlevsoil_in)) allocate(bc_in%dz_sisl(nlevsoil_in)) allocate(bc_in%z_sisl(nlevsoil_in)) @@ -416,6 +512,31 @@ subroutine allocate_bcout(bc_out, nlevsoil_in, nlevdecomp_in) allocate(bc_out%ftid_parb(maxPatchesPerSite,hlm_numSWb)) allocate(bc_out%ftii_parb(maxPatchesPerSite,hlm_numSWb)) + + ! We allocate the boundary conditions to the BGC + ! model, regardless of what scheme we use. The BGC + ! model in ELM allocates all species C,N,P even if they + ! are not turned on. Also, it is feasible that the + ! one would want to allow soil BGC nutrient dynamics + ! to proceed even if we are not passing source fluxes + ! or uptake from FATES. + ! When FATES does not have nutrients enabled, these + ! arrays are indexed by 1. + + if(trim(hlm_nu_com).eq.'RD') then + allocate(bc_out%n_demand(max_comp_per_site)) + allocate(bc_out%p_demand(max_comp_per_site)) + end if + + if(trim(hlm_nu_com).eq.'ECA') then + allocate(bc_out%veg_rootc(max_comp_per_site,nlevdecomp_in)) + allocate(bc_out%decompmicc(nlevdecomp_in)) + allocate(bc_out%ft_index(max_comp_per_site)) + allocate(bc_out%cn_scalar(max_comp_per_site)) + allocate(bc_out%cp_scalar(max_comp_per_site)) + end if + + ! Fates -> BGC fragmentation mass fluxes select case(hlm_parteh_mode) case(prt_carbon_allom_hyp) @@ -423,6 +544,7 @@ subroutine allocate_bcout(bc_out, nlevsoil_in, nlevdecomp_in) allocate(bc_out%litt_flux_lig_c_si(nlevdecomp_in)) allocate(bc_out%litt_flux_lab_c_si(nlevdecomp_in)) case(prt_cnp_flex_allom_hyp) + allocate(bc_out%litt_flux_cel_c_si(nlevdecomp_in)) allocate(bc_out%litt_flux_lig_c_si(nlevdecomp_in)) allocate(bc_out%litt_flux_lab_c_si(nlevdecomp_in)) @@ -432,6 +554,10 @@ subroutine allocate_bcout(bc_out, nlevsoil_in, nlevdecomp_in) allocate(bc_out%litt_flux_cel_p_si(nlevdecomp_in)) allocate(bc_out%litt_flux_lig_p_si(nlevdecomp_in)) allocate(bc_out%litt_flux_lab_p_si(nlevdecomp_in)) + + allocate(bc_out%source_nh4(nlevdecomp_in)) + allocate(bc_out%source_p(nlevdecomp_in)) + case default write(fates_log(), *) 'An unknown parteh hypothesis was passed' write(fates_log(), *) 'to the site level output boundary conditions' @@ -465,7 +591,7 @@ subroutine allocate_bcout(bc_out, nlevsoil_in, nlevdecomp_in) end subroutine allocate_bcout ! ==================================================================================== - + subroutine set_bcs(bc_in) ! -------------------------------------------------------------------------------- @@ -499,11 +625,11 @@ subroutine SetFatesGlobalElements(use_fates) ! -------------------------------------------------------------------------------- ! - ! This subroutine is called directly from the HLM, and is the first FATES routine - ! that is called. + ! This is the first FATES routine that is called. ! ! This subroutine MUST BE CALLED AFTER the FATES PFT parameter file has been read in, ! and the EDPftvarcon_inst structure has been made. + ! This subroutine MUST BE CALLED AFTER NL VARIABLES ARE READ (ie hlm_parteh_mode,etc) ! This subroutine must ALSO BE CALLED BEFORE the history file dimensions ! are set. ! @@ -527,10 +653,10 @@ subroutine SetFatesGlobalElements(use_fates) ! Identify the number of PFTs by evaluating a pft array ! Using wood density as that is not expected to be deprecated any time soon - if(lbound(EDPftvarcon_inst%wood_density(:),dim=1) .eq. 0 ) then - numpft = size(EDPftvarcon_inst%wood_density,dim=1)-1 - elseif(lbound(EDPftvarcon_inst%wood_density(:),dim=1) .eq. 1 ) then - numpft = size(EDPftvarcon_inst%wood_density,dim=1) + if(lbound(prt_params%wood_density(:),dim=1) .eq. 0 ) then + numpft = size(prt_params%wood_density,dim=1)-1 + elseif(lbound(prt_params%wood_density(:),dim=1) .eq. 1 ) then + numpft = size(prt_params%wood_density,dim=1) else write(fates_log(), *) 'While assessing the number of FATES PFTs,' write(fates_log(), *) 'it was found that the lower bound was neither 0 or 1?' @@ -546,13 +672,13 @@ subroutine SetFatesGlobalElements(use_fates) ! Identify the number of leaf age-classes - if( (lbound(EDPftvarcon_inst%leaf_long(:,:),dim=2) .eq. 0) .or. & - (ubound(EDPftvarcon_inst%leaf_long(:,:),dim=2) .eq. 0) ) then + if( (lbound(prt_params%leaf_long(:,:),dim=2) .eq. 0) .or. & + (ubound(prt_params%leaf_long(:,:),dim=2) .eq. 0) ) then write(fates_log(), *) 'While assessing the number of FATES leaf age classes,' write(fates_log(), *) 'The second dimension of leaf_long was 0?' call endrun(msg=errMsg(sourcefile, __LINE__)) else - nleafage = size(EDPftvarcon_inst%leaf_long,dim=2) + nleafage = size(prt_params%leaf_long,dim=2) end if ! These values are used to define the restart file allocations and general structure @@ -578,6 +704,27 @@ subroutine SetFatesGlobalElements(use_fates) fates_maxElementsPerSite = maxPatchesPerSite * fates_maxElementsPerPatch + + ! Set the maximum number of nutrient aquisition competitors per site + ! This is used to set array sizes for the boundary conditions. + ! Note: since BGC code may be active even when no nutrients + ! present, we still need to allocate things when no nutrients + + if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp ) then + if(fates_np_comp_scaling.eq.cohort_np_comp_scaling) then + max_comp_per_site = fates_maxElementsPerSite + elseif(fates_np_comp_scaling.eq.pft_np_comp_scaling) then + max_comp_per_site = numpft + else + write(fates_log(), *) 'An unknown nutrient competitor scaling method was chosen?' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + else + max_comp_per_site = 1 + end if + + + ! Identify number of size and age class bins for history output ! assume these arrays are 1-indexed nlevsclass = size(ED_val_history_sizeclass_bin_edges,dim=1) @@ -662,7 +809,7 @@ end subroutine SetFatesGlobalElements ! ====================================================================== subroutine InitPARTEHGlobals() - + ! Initialize the Plant Allocation and Reactive Transport ! global functions and mapping tables ! Also associate the elements defined in PARTEH with a list in FATES @@ -693,12 +840,7 @@ subroutine InitPARTEHGlobals() element_pos(nitrogen_element) = 2 element_pos(phosphorus_element) = 3 - !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__)) + call InitPRTGlobalAllometricCNP() case DEFAULT write(fates_log(),*) 'You specified an unknown PRT module' @@ -999,6 +1141,9 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) hlm_hio_ignore_val = unset_double hlm_masterproc = unset_int hlm_ipedof = unset_int + hlm_nu_com = 'unset' + hlm_nitrogen_spec = unset_int + hlm_phosphorus_spec = unset_int hlm_max_patch_per_site = unset_int hlm_use_vertsoilc = unset_int hlm_parteh_mode = unset_int @@ -1180,6 +1325,27 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if(trim(hlm_nu_com) .eq. 'unset') then + if (fates_global_verbose()) then + write(fates_log(),*) 'FATES dimension/parameter unset: hlm_nu_com, exiting' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_nitrogen_spec .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(),*) 'FATES parameters unset: hlm_nitrogen_spec, exiting' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + if(hlm_phosphorus_spec .eq. unset_int) then + if (fates_global_verbose()) then + write(fates_log(),*) 'FATES parameters unset: hlm_phosphorus_spec, exiting' + end if + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if( abs(hlm_hio_ignore_val-unset_double)<1e-10 ) then if (fates_global_verbose()) then write(fates_log(),*) 'FATES dimension/parameter unset: hio_ignore' @@ -1194,6 +1360,7 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if + if(hlm_max_patch_per_site .eq. unset_int ) then if (fates_global_verbose()) then write(fates_log(), *) 'the number of patch-space per site unset: hlm_max_patch_per_site, exiting' @@ -1254,7 +1421,15 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - + if(trim(hlm_name).eq.'CLM' .and. hlm_parteh_mode .eq. 2) then + if( sum(abs(EDPftvarcon_inst%prescribed_puptake(:))) 0' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if if(hlm_use_fixed_biogeog.eq.unset_int) then if(fates_global_verbose()) then @@ -1331,6 +1506,19 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering hlm_ipedof = ',ival,' to FATES' end if + case('nitrogen_spec') + hlm_nitrogen_spec = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_nitrogen_spec = ',ival,' to FATES' + end if + + case('phosphorus_spec') + hlm_phosphorus_spec = ival + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering hlm_phosphorus_spec = ',ival,' to FATES' + end if + + case('max_patch_per_site') hlm_max_patch_per_site = ival if (fates_global_verbose()) then @@ -1444,7 +1632,8 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) case default if (fates_global_verbose()) then - write(fates_log(), *) 'tag not recognized:',trim(tag) + write(fates_log(), *) 'tag not recognized:',trim(tag) + call endrun(msg=errMsg(sourcefile, __LINE__)) end if ! end_run end select @@ -1475,6 +1664,12 @@ subroutine set_fates_ctrlparms(tag,ival,rval,cval) write(fates_log(),*) 'Transfering the HLM name = ',trim(cval) end if + case('nu_com') + hlm_nu_com = trim(cval) + if (fates_global_verbose()) then + write(fates_log(),*) 'Transfering the nutrient competition name = ',trim(cval) + end if + case('inventory_ctrl_file') hlm_inventory_ctrl_file = trim(cval) if (fates_global_verbose()) then @@ -1507,11 +1702,16 @@ subroutine FatesReportParameters(masterproc) call FatesReportPFTParams(masterproc) call FatesReportParams(masterproc) - call FatesCheckParams(masterproc,hlm_parteh_mode) + call FatesCheckParams(masterproc) ! Check general fates parameters + call PRTCheckParams(masterproc) ! Check PARTEH parameters call SpitFireCheckParams(masterproc) return end subroutine FatesReportParameters + ! ===================================================================================== + + + end module FatesInterfaceMod diff --git a/main/FatesInterfaceTypesMod.F90 b/main/FatesInterfaceTypesMod.F90 index 547e095fa7..485b30cb9e 100644 --- a/main/FatesInterfaceTypesMod.F90 +++ b/main/FatesInterfaceTypesMod.F90 @@ -48,6 +48,27 @@ module FatesInterfaceTypesMod ! ATS, ALM and CLM will only want variables ! specficially packaged for them. ! This string sets which filter is enacted. + + + character(len=16), public :: hlm_nu_com ! This string defines which soil + ! nutrient competition scheme is in use. + ! current options with + ! E3SM: RD, ECA + ! CESM: NONE + ! ATS: ? + ! NORESM: ? + + + integer, public :: hlm_nitrogen_spec ! This flag signals which nitrogen + ! species are active if any: + ! 0: none + ! 1: nh4 only + ! 2: nh4 and no3 + + integer, public :: hlm_phosphorus_spec ! Signals if phosphorous is turned on in the HLM + ! 0: none + ! 1: p is on + real(r8), public :: hlm_hio_ignore_val ! This value can be flushed to history @@ -185,6 +206,10 @@ module FatesInterfaceTypesMod ! data as some fields are arrays where each array is ! associated with one cohort + + integer, public :: max_comp_per_site ! This is the maximum number of nutrient aquisition + ! competitors that will be generated on each site + ! ------------------------------------------------------------------------------------- ! These vectors are used for history output mapping ! CLM/ALM have limited support for multi-dimensional history output arrays. @@ -197,8 +222,6 @@ module FatesInterfaceTypesMod real(r8), public, allocatable :: fates_hdim_levcoage(:) ! cohort age class lower bound dimension integer , public, allocatable :: fates_hdim_pfmap_levcapf(:) ! map of pfts into cohort age class x pft dimension integer , public, allocatable :: fates_hdim_camap_levcapf(:) ! map of cohort age class into cohort age x pft dimension - - real(r8), public, allocatable :: fates_hdim_levsclass(:) ! plant size class lower bound dimension integer , public, allocatable :: fates_hdim_pfmap_levscpf(:) ! map of pfts into size-class x pft dimension integer , public, allocatable :: fates_hdim_scmap_levscpf(:) ! map of size-class into size-class x pft dimension @@ -342,6 +365,18 @@ module FatesInterfaceTypesMod ! Downwelling diffuse (I-ndirect) radiation (patch,radiation-band) [W/m2] real(r8), allocatable :: solai_parb(:,:) + + ! Nutrient input fluxes (these are integrated fluxes over the day, most + ! likely calculated over shorter dynamics steps, + ! and then incremented until the end of the day) + ! + ! Note 1: If these are indexed by COHORT, they don't also need to be indexed + ! by decomposition layer. So it is allocated with 2nd dim=1. + ! Note 2: Has it's own zero'ing call + real(r8), pointer :: plant_n_uptake_flux(:,:) ! Nitrogen input flux for + ! each competitor [gN/m2/day] + real(r8), pointer :: plant_p_uptake_flux(:,:) ! Phosphorus input flux for + ! each competitor [gP/m2/day] ! Photosynthesis variables @@ -548,6 +583,48 @@ module FatesInterfaceTypesMod real(r8), allocatable :: litt_flux_cel_p_si(:) ! cellulose phosphorus litter, fates->BGC g/m3/s real(r8), allocatable :: litt_flux_lig_p_si(:) ! lignan phosphorus litter, fates->BGC g/m3/s real(r8), allocatable :: litt_flux_lab_p_si(:) ! labile phosphorus litter, fates->BGC g/m3/s + + + ! Nutrient competition boundary conditions + ! (These are all pointer allocations, this is because the host models + ! will point to these arrays) + ! --------------------------------------------------------------------------------- + + integer :: num_plant_comps ! Number of unique competitors + + real(r8), allocatable :: source_nh4(:) ! FATES generated source of ammonium to the mineralized N pool + ! in the BGC model [gN/m3] + real(r8), allocatable :: source_p(:) ! FATES generated source of phosphorus to mineralized P + ! pool in the BGC model [gP/m3] + + real(r8), pointer :: veg_rootc(:,:) ! Total fine-root carbon of each competitor + ! [gC/m3 of site area] + ! (maxcohort_per_site x nlevdecomp) + real(r8), pointer :: decompmicc(:) ! Microbial decomposer biomass [gc/m3] + ! (numpft x nledecomp_full) + integer, pointer :: ft_index(:) ! functional type index of each competitor + ! (maxcohort_per_site) + real(r8), pointer :: cn_scalar(:) ! C:N scaling factor for root n uptake + ! kinetics (exact meaning differs between + ! soil BGC hypotheses) + real(r8), pointer :: cp_scalar(:) ! C:P scaling factor for root p uptake + ! kinetics (exact meaning differs between + ! soil BGC hypotheses) + + + + + ! CTC/RD Nutrient Boundary Conditions + ! --------------------------------------------------------------------------------- + + real(r8), pointer :: n_demand(:) ! Nitrogen demand from each competitor + ! for use in ELMs CTC/RD [g/m2/s] + real(r8), pointer :: p_demand(:) ! Phosophorus demand from each competitor + ! for use in ELMs CTC/RD [g/m2/s] + + + + ! Canopy Structure @@ -596,6 +673,38 @@ module FatesInterfaceTypesMod end type bc_out_type + ! This type holds parameter constants + ! These parameter constants only need to specified once, and never modified again. + ! After re-factoring this module to split the procedures from the data-types + ! we can then set the datatypes as protected. + + type, public :: bc_pconst_type + + ! Nutrient competition boundary conditions for ECA hypothesis + ! Note, these "could" be stored globaly for each machine, saving them on + ! each column is inefficient. Each of these are dimensioned by PFT. + + integer :: max_plant_comps + real(r8), pointer :: eca_km_nh4(:) + real(r8), pointer :: eca_vmax_nh4(:) + real(r8), pointer :: eca_km_no3(:) + real(r8), pointer :: eca_vmax_no3(:) + real(r8), pointer :: eca_km_p(:) + real(r8), pointer :: eca_vmax_p(:) + real(r8), pointer :: eca_km_ptase(:) + real(r8), pointer :: eca_vmax_ptase(:) + real(r8), pointer :: eca_alpha_ptase(:) + real(r8), pointer :: eca_lambda_ptase(:) + real(r8) :: eca_plant_escalar + + integer, pointer :: j_uptake(:) ! Mapping between decomposition + ! layers and the uptake layers + ! in FATES (is either incrementally + ! increasing, or all 1s) + + end type bc_pconst_type + + type, public :: fates_interface_type ! This is the root of the ED/FATES hierarchy of instantaneous state variables @@ -622,6 +731,14 @@ module FatesInterfaceTypesMod type(bc_out_type), allocatable :: bc_out(:) + ! These are parameter constants that FATES may need to provide a host model + ! We have other methods of reading in input parameters. Since these + ! are parameter constants, we don't need them allocated over every site,one + ! instance is fine. + + type(bc_pconst_type) :: bc_pconst + + end type fates_interface_type diff --git a/main/FatesInventoryInitMod.F90 b/main/FatesInventoryInitMod.F90 index 4df7c25e14..dbf2b1044d 100644 --- a/main/FatesInventoryInitMod.F90 +++ b/main/FatesInventoryInitMod.F90 @@ -38,14 +38,15 @@ module FatesInventoryInitMod use EDTypesMod , only : area use EDTypesMod , only : leaves_on use EDTypesMod , only : leaves_off - use EDTypesMod , only : num_elements - use EDTypesMod , only : element_list + use PRTGenericMod , only : num_elements + use PRTGenericMod , only : element_list use EDTypesMod , only : phen_cstat_nevercold use EDTypesMod , only : phen_cstat_iscold use EDTypesMod , only : phen_dstat_timeoff use EDTypesMod , only : phen_dstat_moistoff + use PRTParametersMod , only : prt_params use EDPftvarcon , only : EDPftvarcon_inst - use FatesInterfaceTypesMod, only : hlm_parteh_mode + use FatesInterfaceTypesMod, only : hlm_parteh_mode use EDCohortDynamicsMod, only : InitPRTObject use PRTGenericMod, only : prt_carbon_allom_hyp use PRTGenericMod, only : prt_cnp_flex_allom_hyp @@ -1042,7 +1043,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & stem_drop_fraction = EDPftvarcon_inst%phen_stem_drop_fraction(temp_cohort%pft) - if( EDPftvarcon_inst%season_decid(temp_cohort%pft) == itrue .and. & + if( prt_params%season_decid(temp_cohort%pft) == itrue .and. & any(csite%cstatus == [phen_cstat_nevercold,phen_cstat_iscold])) then temp_cohort%laimemory = b_leaf temp_cohort%sapwmemory = b_sapw * stem_drop_fraction @@ -1053,7 +1054,7 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & cstatus = leaves_off endif - if ( EDPftvarcon_inst%stress_decid(temp_cohort%pft) == itrue .and. & + if ( prt_params%stress_decid(temp_cohort%pft) == itrue .and. & any(csite%dstatus == [phen_dstat_timeoff,phen_dstat_moistoff])) then temp_cohort%laimemory = b_leaf temp_cohort%sapwmemory = b_sapw * stem_drop_fraction @@ -1068,59 +1069,59 @@ subroutine set_inventory_edcohort_type1(csite,bc_in,css_file_unit,npatches, & call InitPRTObject(prt_obj) do el = 1,num_elements - - element_id = element_list(el) - - ! If this is carbon12, then the initialization is straight forward - ! otherwise, we use stoichiometric ratios - select case(element_id) - case(carbon12_element) - - m_struct = b_struct - m_leaf = b_leaf - m_fnrt = b_fnrt - m_sapw = b_sapw - m_store = b_store - m_repro = 0._r8 - - case(nitrogen_element) - - m_struct = b_struct*EDPftvarcon_inst%prt_nitr_stoich_p1(temp_cohort%pft,struct_organ) - m_leaf = b_leaf*EDPftvarcon_inst%prt_nitr_stoich_p1(temp_cohort%pft,leaf_organ) - m_fnrt = b_fnrt*EDPftvarcon_inst%prt_nitr_stoich_p1(temp_cohort%pft,fnrt_organ) - m_sapw = b_sapw*EDPftvarcon_inst%prt_nitr_stoich_p1(temp_cohort%pft,sapw_organ) - m_store = b_store*EDPftvarcon_inst%prt_nitr_stoich_p1(temp_cohort%pft,store_organ) - m_repro = 0._r8 - - case(phosphorus_element) - - m_struct = b_struct*EDPftvarcon_inst%prt_phos_stoich_p1(temp_cohort%pft,struct_organ) - m_leaf = b_leaf*EDPftvarcon_inst%prt_phos_stoich_p1(temp_cohort%pft,leaf_organ) - m_fnrt = b_fnrt*EDPftvarcon_inst%prt_phos_stoich_p1(temp_cohort%pft,fnrt_organ) - m_sapw = b_sapw*EDPftvarcon_inst%prt_phos_stoich_p1(temp_cohort%pft,sapw_organ) - m_store = b_store*EDPftvarcon_inst%prt_phos_stoich_p1(temp_cohort%pft,store_organ) - m_repro = 0._r8 - end select - - select case(hlm_parteh_mode) - case (prt_carbon_allom_hyp,prt_cnp_flex_allom_hyp ) - - ! Equally distribute leaf mass into available age-bins - do iage = 1,nleafage - call SetState(prt_obj,leaf_organ, element_id,m_leaf/real(nleafage,r8),iage) - end do - - call SetState(prt_obj,fnrt_organ, element_id, m_fnrt) - call SetState(prt_obj,sapw_organ, element_id, m_sapw) - call SetState(prt_obj,store_organ, element_id, m_store) - call SetState(prt_obj,struct_organ, element_id, m_struct) - call SetState(prt_obj,repro_organ, element_id, m_repro) - - case default - write(fates_log(),*) 'Unspecified PARTEH module during inventory intitialization' - call endrun(msg=errMsg(sourcefile, __LINE__)) - end select - + + element_id = element_list(el) + + ! If this is carbon12, then the initialization is straight forward + ! otherwise, we use stoichiometric ratios + select case(element_id) + case(carbon12_element) + + m_struct = b_struct + m_leaf = b_leaf + m_fnrt = b_fnrt + m_sapw = b_sapw + m_store = b_store + m_repro = 0._r8 + + case(nitrogen_element) + + m_struct = b_struct*prt_params%nitr_stoich_p1(temp_cohort%pft,struct_organ) + m_leaf = b_leaf*prt_params%nitr_stoich_p1(temp_cohort%pft,leaf_organ) + m_fnrt = b_fnrt*prt_params%nitr_stoich_p1(temp_cohort%pft,fnrt_organ) + m_sapw = b_sapw*prt_params%nitr_stoich_p1(temp_cohort%pft,sapw_organ) + m_store = b_store*prt_params%nitr_stoich_p1(temp_cohort%pft,store_organ) + m_repro = 0._r8 + + case(phosphorus_element) + + m_struct = b_struct*prt_params%phos_stoich_p1(temp_cohort%pft,struct_organ) + m_leaf = b_leaf*prt_params%phos_stoich_p1(temp_cohort%pft,leaf_organ) + m_fnrt = b_fnrt*prt_params%phos_stoich_p1(temp_cohort%pft,fnrt_organ) + m_sapw = b_sapw*prt_params%phos_stoich_p1(temp_cohort%pft,sapw_organ) + m_store = b_store*prt_params%phos_stoich_p1(temp_cohort%pft,store_organ) + m_repro = 0._r8 + end select + + select case(hlm_parteh_mode) + case (prt_carbon_allom_hyp,prt_cnp_flex_allom_hyp ) + + ! Equally distribute leaf mass into available age-bins + do iage = 1,nleafage + call SetState(prt_obj,leaf_organ, element_id,m_leaf/real(nleafage,r8),iage) + end do + + call SetState(prt_obj,fnrt_organ, element_id, m_fnrt) + call SetState(prt_obj,sapw_organ, element_id, m_sapw) + call SetState(prt_obj,store_organ, element_id, m_store) + call SetState(prt_obj,struct_organ, element_id, m_struct) + call SetState(prt_obj,repro_organ, element_id, m_repro) + + case default + write(fates_log(),*) 'Unspecified PARTEH module during inventory intitialization' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end select + end do call prt_obj%CheckInitialConditions() diff --git a/main/FatesRestartInterfaceMod.F90 b/main/FatesRestartInterfaceMod.F90 index 6f32df2382..0b621dec0a 100644 --- a/main/FatesRestartInterfaceMod.F90 +++ b/main/FatesRestartInterfaceMod.F90 @@ -36,7 +36,7 @@ module FatesRestartInterfaceMod use FatesLitterMod, only : ncwd use FatesLitterMod, only : ndcmpy use PRTGenericMod, only : prt_global - use EDTypesMod, only : num_elements + use PRTGenericMod, only : num_elements ! CIME GLOBALS @@ -106,6 +106,7 @@ module FatesRestartInterfaceMod integer :: ir_gpp_acc_hold_co integer :: ir_npp_acc_hold_co integer :: ir_resp_acc_hold_co + integer :: ir_resp_m_def_co integer :: ir_bmort_co integer :: ir_hmort_co integer :: ir_cmort_co @@ -113,6 +114,16 @@ module FatesRestartInterfaceMod integer :: ir_smort_co integer :: ir_asmort_co + integer :: ir_daily_n_uptake_co + integer :: ir_daily_p_uptake_co + integer :: ir_daily_c_efflux_co + integer :: ir_daily_n_efflux_co + integer :: ir_daily_p_efflux_co + integer :: ir_daily_n_demand_co + integer :: ir_daily_p_demand_co + integer :: ir_daily_n_need_co + integer :: ir_daily_p_need_co + !Logging integer :: ir_lmort_direct_co integer :: ir_lmort_collateral_co @@ -145,6 +156,14 @@ module FatesRestartInterfaceMod integer :: ir_agesinceanthrodist_pa integer :: ir_patchdistturbcat_pa + ! Litter Fluxes (needed to restart + ! with nutrient dynamics on, restarting + ! mid-day + integer :: ir_agcwd_frag_litt + integer :: ir_bgcwd_frag_litt + integer :: ir_lfines_frag_litt + integer :: ir_rfines_frag_litt + ! Site level integer :: ir_watermem_siwm @@ -175,6 +194,8 @@ module FatesRestartInterfaceMod integer :: ir_cwdbgin_flxdg integer :: ir_leaflittin_flxdg integer :: ir_rootlittin_flxdg + integer :: ir_efflux_flxdg + integer :: ir_uptake_flxdg integer :: ir_oldstock_mbal integer :: ir_errfates_mbal integer :: ir_prt_base ! Base index for all PRT variables @@ -715,6 +736,11 @@ 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_resp_m_def', vtype=cohort_r8, & + long_name='ed cohort - maintenance respiration deficit', & + units='kgC/indiv', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_resp_m_def_co ) + call this%set_restart_var(vname='fates_bmort', vtype=cohort_r8, & long_name='ed cohort - background mortality rate', & units='/year', flushval = flushzero, & @@ -730,6 +756,51 @@ subroutine define_restart_vars(this, initialize_variables) units='/year', flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_cmort_co ) + call this%set_restart_var(vname='fates_daily_n_uptake', vtype=cohort_r8, & + long_name='fates cohort- daily nitrogen uptake', & + units='kg/plant/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_uptake_co ) + + call this%set_restart_var(vname='fates_daily_p_uptake', vtype=cohort_r8, & + long_name='fates cohort- daily phosphorus uptake', & + units='kg/plant/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_p_uptake_co ) + + call this%set_restart_var(vname='fates_daily_c_efflux', vtype=cohort_r8, & + long_name='fates cohort- daily carbon efflux', & + units='kg/plant/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_c_efflux_co ) + + call this%set_restart_var(vname='fates_daily_n_efflux', vtype=cohort_r8, & + long_name='fates cohort- daily nitrogen efflux', & + units='kg/plant/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_efflux_co ) + + call this%set_restart_var(vname='fates_daily_p_efflux', vtype=cohort_r8, & + long_name='fates cohort- daily phosphorus efflux', & + units='kg/plant/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_p_efflux_co ) + + call this%set_restart_var(vname='fates_daily_p_demand', vtype=cohort_r8, & + long_name='fates cohort- daily phosphorus demand', & + units='kgP/plant/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_p_demand_co ) + + call this%set_restart_var(vname='fates_daily_n_demand', vtype=cohort_r8, & + long_name='fates cohort- daily nitrogen demand', & + units='kgN/plant/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_demand_co ) + + call this%set_restart_var(vname='fates_daily_p_need', vtype=cohort_r8, & + long_name='fates cohort- daily phosphorus need', & + units='kgP/plant/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_p_need_co ) + + call this%set_restart_var(vname='fates_daily_n_need', vtype=cohort_r8, & + long_name='fates cohort- daily nitrogen need', & + units='kgN/plant/day', flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_daily_n_need_co ) + call this%set_restart_var(vname='fates_frmort', vtype=cohort_r8, & long_name='ed cohort - freezing mortality rate', & units='/year', flushval = flushzero, & @@ -865,6 +936,26 @@ subroutine define_restart_vars(this, initialize_variables) units='kg/m2', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_seedgerm_litt) + call this%RegisterCohortVector(symbol_base='fates_ag_cwd_frag', vtype=cohort_r8, & + long_name_base='above ground CWD frag flux', & + units='kg/m2/day', veclength=num_elements, flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_agcwd_frag_litt) + + call this%RegisterCohortVector(symbol_base='fates_bg_cwd_frag', vtype=cohort_r8, & + long_name_base='below ground CWD frag flux', & + units='kg/m2/day', veclength=num_elements, flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_bgcwd_frag_litt) + + call this%RegisterCohortVector(symbol_base='fates_lfines_frag', vtype=cohort_r8, & + long_name_base='frag flux from leaf fines', & + units='kg/m2/day', veclength=num_elements, flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_lfines_frag_litt) + + call this%RegisterCohortVector(symbol_base='fates_rfines_frag', vtype=cohort_r8, & + long_name_base='frag flux from froot fines', & + units='kg/m2/day', veclength=num_elements, flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_rfines_frag_litt) + ! Site level flux diagnostics for each element @@ -888,6 +979,17 @@ subroutine define_restart_vars(this, initialize_variables) units='kg/ha', veclength=num_elements, flushval = flushzero, & hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_rootlittin_flxdg) + call this%RegisterCohortVector(symbol_base='fates_efflux_scpf', vtype=cohort_r8, & + long_name_base='Efflux from plants to soil through roots', & + units='kg/day/ha', veclength=num_elements, flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_efflux_flxdg) + + call this%RegisterCohortVector(symbol_base='fates_uptake_scpf', vtype=cohort_r8, & + long_name_base='Daily uptake for plants through roots', & + units='kg/day/ha', veclength=num_elements, flushval = flushzero, & + hlms='CLM:ALM', initialize=initialize_variables, ivar=ivar, index = ir_uptake_flxdg) + + ! Site level Mass Balance State Accounting call this%RegisterCohortVector(symbol_base='fates_oldstock', vtype=site_r8, & @@ -1473,6 +1575,7 @@ subroutine set_restart_vectors(this,nc,nsites,sites) integer :: ilyr ! soil layer index integer :: nlevsoil ! total soil layers in patch of interest integer :: k,j,i ! indices to the radiation matrix + integer :: iscpf ! multiplex loop counter for size x pft 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 @@ -1520,9 +1623,19 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_gpp_acc_hold_co => this%rvars(ir_gpp_acc_hold_co)%r81d, & rio_resp_acc_hold_co => this%rvars(ir_resp_acc_hold_co)%r81d, & rio_npp_acc_hold_co => this%rvars(ir_npp_acc_hold_co)%r81d, & + rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & + rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & + rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & + rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & + rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & + rio_daily_p_efflux_co => this%rvars(ir_daily_p_efflux_co)%r81d, & + rio_daily_n_demand_co => this%rvars(ir_daily_n_demand_co)%r81d, & + rio_daily_p_demand_co => this%rvars(ir_daily_p_demand_co)%r81d, & + rio_daily_n_need_co => this%rvars(ir_daily_n_need_co)%r81d, & + rio_daily_p_need_co => this%rvars(ir_daily_p_need_co)%r81d, & rio_smort_co => this%rvars(ir_smort_co)%r81d, & rio_asmort_co => this%rvars(ir_asmort_co)%r81d, & rio_frmort_co => this%rvars(ir_frmort_co)%r81d, & @@ -1592,7 +1705,6 @@ subroutine set_restart_vectors(this,nc,nsites,sites) ! Hydraulics counters lyr = hydraulic layer, shell = rhizosphere shell io_idx_si_lyr_shell = io_idx_co_1st - io_idx_si_scpf = io_idx_co_1st io_idx_si_sc = io_idx_co_1st io_idx_si_capf = io_idx_co_1st io_idx_si_cacls= io_idx_co_1st @@ -1601,20 +1713,21 @@ subroutine set_restart_vectors(this,nc,nsites,sites) do i_pft = 1,numpft rio_recrate_sift(io_idx_co_1st+i_pft-1) = sites(s)%recruitment_rate(i_pft) end do - - do i_pft = 1,numpft + + do i_pft = 1,numpft rio_use_this_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%use_this_pft(i_pft) - end do - - do i_pft = 1,numpft - rio_area_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%area_pft(i_pft) - end do - + end do + + do i_pft = 1,numpft + rio_area_pft_sift(io_idx_co_1st+i_pft-1) = sites(s)%area_pft(i_pft) + end do + do el = 1, num_elements io_idx_si_cwd = io_idx_co_1st io_idx_si_pft = io_idx_co_1st - + io_idx_si_scpf = io_idx_co_1st + do i_cwd=1,ncwd this%rvars(ir_cwdagin_flxdg+el-1)%r81d(io_idx_si_cwd) = sites(s)%flux_diags(el)%cwd_ag_input(i_cwd) this%rvars(ir_cwdbgin_flxdg+el-1)%r81d(io_idx_si_cwd) = sites(s)%flux_diags(el)%cwd_bg_input(i_cwd) @@ -1627,6 +1740,17 @@ subroutine set_restart_vectors(this,nc,nsites,sites) io_idx_si_pft = io_idx_si_pft + 1 end do + iscpf = 1 + do i_scls = 1, nlevsclass + do i_pft = 1, numpft + this%rvars(ir_efflux_flxdg+el-1)%r81d(io_idx_si_scpf) = sites(s)%flux_diags(el)%nutrient_efflux_scpf(iscpf) + this%rvars(ir_uptake_flxdg+el-1)%r81d(io_idx_si_scpf) = sites(s)%flux_diags(el)%nutrient_uptake_scpf(iscpf) + iscpf = iscpf + 1 + io_idx_si_scpf = io_idx_si_scpf + 1 + end do + end do + + this%rvars(ir_oldstock_mbal+el-1)%r81d(io_idx_si) = sites(s)%mass_balance(el)%old_stock this%rvars(ir_errfates_mbal+el-1)%r81d(io_idx_si) = sites(s)%mass_balance(el)%err_fates @@ -1738,6 +1862,8 @@ subroutine set_restart_vectors(this,nc,nsites,sites) 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_resp_m_def_co(io_idx_co) = ccohort%resp_m_def + rio_bmort_co(io_idx_co) = ccohort%bmort rio_hmort_co(io_idx_co) = ccohort%hmort rio_cmort_co(io_idx_co) = ccohort%cmort @@ -1745,6 +1871,19 @@ subroutine set_restart_vectors(this,nc,nsites,sites) rio_asmort_co(io_idx_co) = ccohort%asmort rio_frmort_co(io_idx_co) = ccohort%frmort + ! Nutrient uptake/efflux + rio_daily_n_uptake_co(io_idx_co) = ccohort%daily_n_uptake + rio_daily_p_uptake_co(io_idx_co) = ccohort%daily_p_uptake + + rio_daily_c_efflux_co(io_idx_co) = ccohort%daily_c_efflux + rio_daily_n_efflux_co(io_idx_co) = ccohort%daily_n_efflux + rio_daily_p_efflux_co(io_idx_co) = ccohort%daily_p_efflux + + rio_daily_n_demand_co(io_idx_co) = ccohort%daily_n_demand + rio_daily_p_demand_co(io_idx_co) = ccohort%daily_p_demand + rio_daily_n_need_co(io_idx_co) = ccohort%daily_n_need2 + rio_daily_p_need_co(io_idx_co) = ccohort%daily_p_need2 + !Logging rio_lmort_direct_co(io_idx_co) = ccohort%lmort_direct rio_lmort_collateral_co(io_idx_co) = ccohort%lmort_collateral @@ -1821,18 +1960,22 @@ subroutine set_restart_vectors(this,nc,nsites,sites) do i = 1,ndcmpy this%rvars(ir_leaf_litt+el)%r81d(io_idx_pa_dc) = litt%leaf_fines(i) + this%rvars(ir_lfines_frag_litt+el)%r81d(io_idx_pa_dc) = litt%leaf_fines_frag(i) io_idx_pa_dc = io_idx_pa_dc + 1 do ilyr=1,sites(s)%nlevsoil this%rvars(ir_fnrt_litt+el)%r81d(io_idx_pa_dcsl) = litt%root_fines(i,ilyr) + this%rvars(ir_rfines_frag_litt+el)%r81d(io_idx_pa_dcsl) = litt%root_fines_frag(i,ilyr) io_idx_pa_dcsl = io_idx_pa_dcsl + 1 end do end do do i = 1,ncwd this%rvars(ir_agcwd_litt+el)%r81d(io_idx_pa_cwd) = litt%ag_cwd(i) + this%rvars(ir_agcwd_frag_litt+el)%r81d(io_idx_pa_cwd) = litt%ag_cwd_frag(i) io_idx_pa_cwd = io_idx_pa_cwd + 1 do ilyr=1,sites(s)%nlevsoil this%rvars(ir_bgcwd_litt+el)%r81d(io_idx_pa_cwsl) = litt%bg_cwd(i,ilyr) + this%rvars(ir_bgcwd_frag_litt+el)%r81d(io_idx_pa_cwsl) = litt%bg_cwd_frag(i,ilyr) io_idx_pa_cwsl = io_idx_pa_cwsl + 1 end do end do @@ -1866,10 +2009,10 @@ subroutine set_restart_vectors(this,nc,nsites,sites) enddo ! cpatch do while - + io_idx_si_scpf = io_idx_co_1st + ! Fill the site level diagnostics arrays do i_scls = 1, nlevsclass - do i_pft = 1, numpft rio_fmortrate_cano_siscpf(io_idx_si_scpf) = sites(s)%fmort_rate_canopy(i_scls, i_pft) @@ -2225,6 +2368,7 @@ subroutine get_restart_vectors(this, nc, nsites, sites) integer :: el ! loop counter for elements integer :: nlevsoil ! number of soil layers integer :: ilyr ! soil layer loop counter + integer :: iscpf ! multiplex loop counter for size x pft integer :: ir_prt_var ! loop counter for var x position integer :: i_cwd ! loop counter for cwd integer :: i_var ! loop counter for PRT variables @@ -2267,9 +2411,19 @@ subroutine get_restart_vectors(this, nc, nsites, sites) rio_gpp_acc_hold_co => this%rvars(ir_gpp_acc_hold_co)%r81d, & rio_resp_acc_hold_co => this%rvars(ir_resp_acc_hold_co)%r81d, & rio_npp_acc_hold_co => this%rvars(ir_npp_acc_hold_co)%r81d, & + rio_resp_m_def_co => this%rvars(ir_resp_m_def_co)%r81d, & rio_bmort_co => this%rvars(ir_bmort_co)%r81d, & rio_hmort_co => this%rvars(ir_hmort_co)%r81d, & rio_cmort_co => this%rvars(ir_cmort_co)%r81d, & + rio_daily_n_uptake_co => this%rvars(ir_daily_n_uptake_co)%r81d, & + rio_daily_p_uptake_co => this%rvars(ir_daily_p_uptake_co)%r81d, & + rio_daily_c_efflux_co => this%rvars(ir_daily_c_efflux_co)%r81d, & + rio_daily_n_efflux_co => this%rvars(ir_daily_n_efflux_co)%r81d, & + rio_daily_p_efflux_co => this%rvars(ir_daily_p_efflux_co)%r81d, & + rio_daily_n_demand_co => this%rvars(ir_daily_n_demand_co)%r81d, & + rio_daily_p_demand_co => this%rvars(ir_daily_p_demand_co)%r81d, & + rio_daily_n_need_co => this%rvars(ir_daily_n_need_co)%r81d, & + rio_daily_p_need_co => this%rvars(ir_daily_p_need_co)%r81d, & rio_smort_co => this%rvars(ir_smort_co)%r81d, & rio_asmort_co => this%rvars(ir_asmort_co)%r81d, & rio_frmort_co => this%rvars(ir_frmort_co)%r81d, & @@ -2349,7 +2503,8 @@ subroutine get_restart_vectors(this, nc, nsites, sites) io_idx_si_cwd = io_idx_co_1st io_idx_si_pft = io_idx_co_1st - + io_idx_si_scpf = io_idx_co_1st + do i_cwd=1,ncwd sites(s)%flux_diags(el)%cwd_ag_input(i_cwd) = this%rvars(ir_cwdagin_flxdg+el-1)%r81d(io_idx_si_cwd) sites(s)%flux_diags(el)%cwd_bg_input(i_cwd) = this%rvars(ir_cwdbgin_flxdg+el-1)%r81d(io_idx_si_cwd) @@ -2360,10 +2515,21 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%flux_diags(el)%leaf_litter_input(i_pft) = this%rvars(ir_leaflittin_flxdg+el-1)%r81d(io_idx_si_pft) sites(s)%flux_diags(el)%root_litter_input(i_pft) = this%rvars(ir_rootlittin_flxdg+el-1)%r81d(io_idx_si_pft) io_idx_si_pft = io_idx_si_pft + 1 - end do + end do + + iscpf = 1 + do i_scls = 1, nlevsclass + do i_pft = 1, numpft + sites(s)%flux_diags(el)%nutrient_efflux_scpf(iscpf) = this%rvars(ir_efflux_flxdg+el-1)%r81d(io_idx_si_scpf) + sites(s)%flux_diags(el)%nutrient_uptake_scpf(iscpf) = this%rvars(ir_uptake_flxdg+el-1)%r81d(io_idx_si_scpf) + iscpf = iscpf + 1 + io_idx_si_scpf = io_idx_si_scpf + 1 + end do + end do + - sites(s)%mass_balance(el)%old_stock = this%rvars(ir_oldstock_mbal+el-1)%r81d(io_idx_si) - sites(s)%mass_balance(el)%err_fates = this%rvars(ir_errfates_mbal+el-1)%r81d(io_idx_si) + sites(s)%mass_balance(el)%old_stock = this%rvars(ir_oldstock_mbal+el-1)%r81d(io_idx_si) + sites(s)%mass_balance(el)%err_fates = this%rvars(ir_errfates_mbal+el-1)%r81d(io_idx_si) end do @@ -2444,6 +2610,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%resp_m_def = rio_resp_m_def_co(io_idx_co) ccohort%bmort = rio_bmort_co(io_idx_co) ccohort%hmort = rio_hmort_co(io_idx_co) @@ -2451,6 +2618,18 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ccohort%smort = rio_smort_co(io_idx_co) ccohort%asmort = rio_asmort_co(io_idx_co) ccohort%frmort = rio_frmort_co(io_idx_co) + + ! Nutrient uptake / efflux + ccohort%daily_n_uptake = rio_daily_n_uptake_co(io_idx_co) + ccohort%daily_p_uptake = rio_daily_p_uptake_co(io_idx_co) + ccohort%daily_c_efflux = rio_daily_c_efflux_co(io_idx_co) + ccohort%daily_n_efflux = rio_daily_n_efflux_co(io_idx_co) + ccohort%daily_p_efflux = rio_daily_p_efflux_co(io_idx_co) + + ccohort%daily_n_demand = rio_daily_n_demand_co(io_idx_co) + ccohort%daily_p_demand = rio_daily_p_demand_co(io_idx_co) + ccohort%daily_n_need2 = rio_daily_n_need_co(io_idx_co) + ccohort%daily_p_need2 = rio_daily_p_need_co(io_idx_co) !Logging ccohort%lmort_direct = rio_lmort_direct_co(io_idx_co) @@ -2549,9 +2728,11 @@ subroutine get_restart_vectors(this, nc, nsites, sites) do i = 1,ndcmpy litt%leaf_fines(i) = this%rvars(ir_leaf_litt+el)%r81d(io_idx_pa_dc) + litt%leaf_fines_frag(i) = this%rvars(ir_lfines_frag_litt+el)%r81d(io_idx_pa_dc) io_idx_pa_dc = io_idx_pa_dc + 1 do ilyr=1,nlevsoil - litt%root_fines(i,ilyr) = this%rvars(ir_fnrt_litt+el)%r81d(io_idx_pa_dcsl) + litt%root_fines(i,ilyr) = this%rvars(ir_fnrt_litt+el)%r81d(io_idx_pa_dcsl) + litt%root_fines_frag(i,ilyr) = this%rvars(ir_rfines_frag_litt+el)%r81d(io_idx_pa_dcsl) io_idx_pa_dcsl = io_idx_pa_dcsl + 1 end do end do @@ -2559,10 +2740,12 @@ subroutine get_restart_vectors(this, nc, nsites, sites) do i = 1,ncwd litt%ag_cwd(i) = this%rvars(ir_agcwd_litt+el)%r81d(io_idx_pa_cwd) + litt%ag_cwd_frag(i) = this%rvars(ir_agcwd_frag_litt+el)%r81d(io_idx_pa_cwd) io_idx_pa_cwd = io_idx_pa_cwd + 1 do ilyr=1,nlevsoil litt%bg_cwd(i,ilyr) = this%rvars(ir_bgcwd_litt+el)%r81d(io_idx_pa_cwsl) + litt%bg_cwd_frag(i,ilyr) = this%rvars(ir_bgcwd_frag_litt+el)%r81d(io_idx_pa_cwsl) io_idx_pa_cwsl = io_idx_pa_cwsl + 1 end do end do @@ -2641,10 +2824,12 @@ subroutine get_restart_vectors(this, nc, nsites, sites) ! Fill the site level diagnostics arrays + ! ----------------------------------------------------------------------------- + + io_idx_si_scpf = io_idx_co_1st + do i_scls = 1,nlevsclass - do i_pft = 1, numpft - sites(s)%fmort_rate_canopy(i_scls, i_pft) = rio_fmortrate_cano_siscpf(io_idx_si_scpf) sites(s)%fmort_rate_ustory(i_scls, i_pft) = rio_fmortrate_usto_siscpf(io_idx_si_scpf) sites(s)%imort_rate(i_scls, i_pft) = rio_imortrate_siscpf(io_idx_si_scpf) @@ -2653,7 +2838,6 @@ subroutine get_restart_vectors(this, nc, nsites, sites) sites(s)%term_nindivs_canopy(i_scls,i_pft) = rio_termnindiv_cano_siscpf(io_idx_si_scpf) sites(s)%term_nindivs_ustory(i_scls,i_pft) = rio_termnindiv_usto_siscpf(io_idx_si_scpf) sites(s)%growthflux_fusion(i_scls, i_pft) = rio_growflx_fusion_siscpf(io_idx_si_scpf) - io_idx_si_scpf = io_idx_si_scpf + 1 end do diff --git a/parameter_files/fates_params_default.cdl b/parameter_files/fates_params_default.cdl index d4affb272e..753cda4460 100644 --- a/parameter_files/fates_params_default.cdl +++ b/parameter_files/fates_params_default.cdl @@ -390,11 +390,11 @@ variables: fates_prescribed_npp_understory:units = "kgC / m^2 / yr" ; fates_prescribed_npp_understory:long_name = "NPP per unit crown area of understory trees for prescribed physiology mode" ; double fates_prescribed_nuptake(fates_pft) ; - fates_prescribed_nuptake:units = "kgN/m^2/yr" ; - fates_prescribed_nuptake:long_name = "Nitrogen uptake flux per unit crown area (negative implies fraction of NPP)" ; + fates_prescribed_nuptake:units = "fraction" ; + fates_prescribed_nuptake:long_name = "Nitrogen uptake flux as fraction of NPP demand. 0=fully coupled simulation" ; double fates_prescribed_puptake(fates_pft) ; - fates_prescribed_puptake:units = "kgP/m^2/yr" ; - fates_prescribed_puptake:long_name = "Phosphorus uptake flux per unit crown area (negative implies fraction of NPP)" ; + fates_prescribed_puptake:units = "fraction" ; + fates_prescribed_puptake:long_name = "Phosphorus uptake flux as fraction of NPP demand. 0=fully coupled simulation" ; double fates_prescribed_recruitment(fates_pft) ; fates_prescribed_recruitment:units = "n/yr" ; fates_prescribed_recruitment:long_name = "recruitment rate for prescribed physiology mode" ; @@ -552,6 +552,9 @@ variables: double fates_cwd_flig ; fates_cwd_flig:units = "unitless" ; fates_cwd_flig:long_name = "Lignin fraction of coarse woody debris" ; + double fates_eca_plant_escalar ; + fates_eca_plant_escalar:units = "" ; + fates_eca_plant_escalar:long_name = "scaling factor for plant fine root biomass to calculate nutrient carrier enzyme abundance (ECA)" ; double fates_fire_active_crown_fire ; fates_fire_active_crown_fire:units = "0 or 1" ; fates_fire_active_crown_fire:long_name = "flag, 1=active crown fire 0=no active crown fire" ; @@ -801,27 +804,35 @@ data: fates_displar = 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67, 0.67 ; - fates_eca_alpha_ptase = _, _, _, _, _, _, _, _, _, _, _, _ ; + fates_eca_alpha_ptase = 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, + 0.5, 0.5 ; - fates_eca_decompmicc = _, _, _, _, _, _, _, _, _, _, _, _ ; + fates_eca_decompmicc = 280, 280, 280, 280, 280, 280, 280, 280, 280, 280, + 280, 280 ; - fates_eca_km_nh4 = _, _, _, _, _, _, _, _, _, _, _, _ ; + fates_eca_km_nh4 = 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, 0.14, + 0.14, 0.14, 0.14 ; - fates_eca_km_no3 = _, _, _, _, _, _, _, _, _, _, _, _ ; + fates_eca_km_no3 = 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, 0.27, + 0.27, 0.27, 0.27 ; - fates_eca_km_p = _, _, _, _, _, _, _, _, _, _, _, _ ; + fates_eca_km_p = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1 ; - fates_eca_km_ptase = _, _, _, _, _, _, _, _, _, _, _, _ ; + fates_eca_km_ptase = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_eca_lambda_ptase = _, _, _, _, _, _, _, _, _, _, _, _ ; + fates_eca_lambda_ptase = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; - fates_eca_vmax_nh4 = _, _, _, _, _, _, _, _, _, _, _, _ ; + fates_eca_vmax_nh4 = 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, + 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07, 1.5e-07 ; - fates_eca_vmax_no3 = _, _, _, _, _, _, _, _, _, _, _, _ ; + fates_eca_vmax_no3 = 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, + 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08, 1.5e-08 ; - fates_eca_vmax_p = _, _, _, _, _, _, _, _, _, _, _, _ ; + fates_eca_vmax_p = 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, + 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09, 1.5e-09 ; - fates_eca_vmax_ptase = _, _, _, _, _, _, _, _, _, _, _, _ ; + fates_eca_vmax_ptase = 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, 5e-09, + 5e-09, 5e-09, 5e-09, 5e-09, 5e-09 ; fates_fire_alpha_SH = 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2 ; @@ -1061,20 +1072,20 @@ data: fates_prescribed_npp_understory = 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125, 0.03125 ; - fates_prescribed_nuptake = _, _, _, _, _, _, _, _, _, _, _, _ ; + fates_prescribed_nuptake = 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0 ; - fates_prescribed_puptake = _, _, _, _, _, _, _, _, _, _, _, _ ; + fates_prescribed_puptake = 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0, 5.0 ; fates_prescribed_recruitment = 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02 ; fates_prt_alloc_priority = - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _ ; + 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, + 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, 3, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4 ; fates_prt_nitr_stoich_p1 = 0.033, 0.029, 0.04, 0.033, 0.04, 0.04, 0.033, 0.04, 0.04, 0.04, 0.04, 0.04, @@ -1089,12 +1100,16 @@ data: 0.0047, 0.0047, 0.0047 ; fates_prt_nitr_stoich_p2 = - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _ ; + 0.033, 0.029, 0.04, 0.033, 0.04, 0.04, 0.033, 0.04, 0.04, 0.04, 0.04, 0.04, + 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, 0.024, + 0.024, 0.024, + 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, + 1e-08, 1e-08, + 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, 1e-08, + 1e-08, 1e-08, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, 0.0047, + 0.0047, 0.0047, 0.0047 ; fates_prt_phos_stoich_p1 = 0.0033, 0.0029, 0.004, 0.0033, 0.004, 0.004, 0.0033, 0.004, 0.004, 0.004, @@ -1110,12 +1125,17 @@ data: 0.00047, 0.00047, 0.00047, 0.00047 ; fates_prt_phos_stoich_p2 = - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _ ; + 0.0033, 0.0029, 0.004, 0.0033, 0.004, 0.004, 0.0033, 0.004, 0.004, 0.004, + 0.004, 0.004, + 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, 0.0024, + 0.0024, 0.0024, 0.0024, + 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, + 1e-09, 1e-09, + 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, 1e-09, + 1e-09, 1e-09, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, 0.00047, + 0.00047, 0.00047, 0.00047, 0.00047 ; fates_recruit_hgt_min = 1.3, 1.3, 1.3, 1.3, 1.3, 1.3, 0.75, 0.75, 0.75, 0.125, 0.125, 0.125 ; @@ -1177,8 +1197,7 @@ data: fates_trim_limit = 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3 ; fates_turnover_carb_retrans = - 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, 0.025, - 0.025, 0.025, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, @@ -1186,20 +1205,20 @@ data: 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_turnover_nitr_retrans = - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _ ; + 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_turnover_phos_retrans = - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _, - _, _, _, _, _, _, _, _, _, _, _, _ ; + 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ; fates_turnover_retrans_mode = 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1 ; @@ -1245,6 +1264,8 @@ data: fates_cwd_flig = 0.24 ; + fates_eca_plant_escalar = 1.25e-05 ; + fates_fire_active_crown_fire = 0 ; fates_fire_cg_strikes = 0.2 ; diff --git a/parteh/PRTAllometricCNPMod.F90 b/parteh/PRTAllometricCNPMod.F90 new file mode 100644 index 0000000000..ccefa67924 --- /dev/null +++ b/parteh/PRTAllometricCNPMod.F90 @@ -0,0 +1,2280 @@ +module PRTAllometricCNPMod + + ! ------------------------------------------------------------------------------------ + ! + ! This module contains all of the specific functions and types for + ! Plant Allocation and Reactive Transport Extensible Hypotheses (PARTEH) + ! + ! Carbon-Nitrogen-Phosphorus (CNP) Prioritized Allometric Allocations + ! + ! Ryan Knox Aug 2018 + ! + ! ------------------------------------------------------------------------------------ + + use PRTGenericMod , only : prt_global_type + use PRTGenericMod , only : prt_global + use PRTGenericMod , only : prt_vartypes + use PRTGenericMod , only : carbon12_element + use PRTGenericMod , only : nitrogen_element + use PRTGenericMod , only : phosphorus_element + use PRTGenericMod , only : max_nleafage + + 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 : all_organs + use PRTGenericMod , only : prt_cnp_flex_allom_hyp + + 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 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 FatesConstantsMod , only : calloc_abs_error + use FatesConstantsMod , only : rsnbl_math_prec + use FatesIntegratorsMod , only : RKF45 + use FatesIntegratorsMod , only : Euler + use FatesConstantsMod , only : calloc_abs_error + use FatesConstantsMod , only : nearzero + use FatesConstantsMod , only : itrue + use FatesConstantsMod , only : fates_unset_r8 + use FatesConstantsMod , only : fates_unset_int + use FatesConstantsMod , only : sec_per_day + use PRTParametersMod , only : prt_params + use EDTypesMod , only : leaves_on,leaves_off + + implicit none + private + + ! ------------------------------------------------------------------------------------- + ! + ! Define the state variables for this specific hypothesis. Give them units and define + ! the indices that correspond with the generic classifications of PRT variables + ! + ! ------------------------------------------------------------------------------------- + + + + integer, parameter :: leaf_c_id = 1 ! leaf carbon index + integer, parameter :: fnrt_c_id = 2 ! fine-root carbon index + integer, parameter :: sapw_c_id = 3 ! sapwood carbon index + integer, parameter :: store_c_id = 4 ! storage carbon index + integer, parameter :: repro_c_id = 5 ! reproductive carbon index + integer, parameter :: struct_c_id = 6 ! structural carbon index + + integer, parameter :: leaf_n_id = 7 + integer, parameter :: fnrt_n_id = 8 + integer, parameter :: sapw_n_id = 9 + integer, parameter :: store_n_id = 10 + integer, parameter :: repro_n_id = 11 + integer, parameter :: struct_n_id = 12 + + integer, parameter :: leaf_p_id = 13 + integer, parameter :: fnrt_p_id = 14 + integer, parameter :: sapw_p_id = 15 + integer, parameter :: store_p_id = 16 + integer, parameter :: repro_p_id = 17 + integer, parameter :: struct_p_id = 18 + + ! Total number of state variables + integer, parameter :: num_vars = 18 + + + ! Global identifiers for the two stoichiometry values + integer, parameter :: stoich_growth_min = 1 ! Flag for stoichiometry associated with + ! minimum needed for growth + integer, parameter :: stoich_max = 2 ! Flag for stoichiometry associated with + ! maximum for that organ + + + ! This is the ordered list of organs used in this module + ! ------------------------------------------------------------------------------------- + + integer, parameter :: num_organs = 6 + + ! Converting from local to global organ id + integer, parameter,dimension(num_organs) :: organ_list = & + [leaf_organ, fnrt_organ, sapw_organ, store_organ, repro_organ, struct_organ] + + ! These are local indices associated with organs and quantities + ! that can be integrated (namely, growth respiration during stature growth + ! and dbh) + + integer, parameter :: leaf_id = 1 + integer, parameter :: fnrt_id = 2 + integer, parameter :: sapw_id = 3 + integer, parameter :: store_id = 4 + integer, parameter :: repro_id = 5 + integer, parameter :: struct_id = 6 + integer, parameter :: dbh_id = 7 + + integer, parameter :: num_intgr_vars = 7 + + + ! ------------------------------------------------------------------------------------- + ! Input/Output Boundary Indices (These are public, and therefore + ! each boundary condition across all modules must + ! have a unique name !!!!) + ! They are used in the routine, and also changed in the routine before + ! being passed back + ! ------------------------------------------------------------------------------------- + + + integer, public, parameter :: acnp_bc_inout_id_dbh = 1 ! Plant DBH + integer, public, parameter :: acnp_bc_inout_id_rmaint_def = 2 ! Index for any accumulated + ! maintenance respiration deficit + integer, public, parameter :: num_bc_inout = 2 + + ! ------------------------------------------------------------------------------------- + ! Input only Boundary Indices (These are public) + ! ------------------------------------------------------------------------------------- + + integer, public, parameter :: acnp_bc_in_id_pft = 1 ! Index for the PFT input BC + integer, public, parameter :: acnp_bc_in_id_ctrim = 2 ! Index for the canopy trim function + integer, public, parameter :: acnp_bc_in_id_lstat = 3 ! phenology status logical + integer, public, parameter :: acnp_bc_in_id_netdc = 4 ! Index for the net daily C input BC + integer, public, parameter :: acnp_bc_in_id_netdn = 5 ! Index for the net daily N input BC + integer, public, parameter :: acnp_bc_in_id_netdp = 6 ! Index for the net daily P input BC + + ! 0=leaf off, 1=leaf on + integer, parameter :: num_bc_in = 6 + + ! ------------------------------------------------------------------------------------- + ! Output Boundary Indices (These are public) + ! ------------------------------------------------------------------------------------- + + integer, public, parameter :: acnp_bc_out_id_cefflux = 1 ! Daily exudation of C [kg] + integer, public, parameter :: acnp_bc_out_id_nefflux = 2 ! Daily exudation of N [kg] + integer, public, parameter :: acnp_bc_out_id_pefflux = 3 ! Daily exudation of P [kg] + integer, public, parameter :: acnp_bc_out_id_ngrow = 4 ! N needed to match C growth at low N/C + integer, public, parameter :: acnp_bc_out_id_nmax = 5 ! N needed to match C growth at max N/C + integer, public, parameter :: acnp_bc_out_id_pgrow = 6 ! P needed to match C growth at low P/C + integer, public, parameter :: acnp_bc_out_id_pmax = 7 ! P needed to match C growth at max P/C + + integer, parameter :: num_bc_out = 7 ! Total number of + + + ! ------------------------------------------------------------------------------------- + ! Define the size of the coorindate vector. For this hypothesis, there is only + ! one pool per each species x organ combination, except for leaves (WHICH HAVE AGE) + ! ------------------------------------------------------------------------------------- + integer, parameter :: icd = 1 + + + real(r8), parameter :: store_overflow_frac = 0.15 ! The fraction above target allowed in storage + + + ! User may want to attempt matching results with the + ! C-only allocation module. If so, then set reproduce_conly + ! and make sure both fnrt and leaf are set to the highest + ! priority order, sapwood and storage are set to the + ! second highest, and then structure is last. When this is + ! flagged as true, it changes the logic in the first allocation + ! phase, to give first dibs to leaves, even though they are + ! in the same priority group as fineroots. + + logical, parameter :: reproduce_conly = .false. + + + ! Array of pointers are difficult in F90 + ! This structure is a necessary intermediate + type :: parray_type + real(r8), pointer :: ptr + end type parray_type + + ! ------------------------------------------------------------------------------------- + ! This is the core type that holds this specific + ! plant reactive transport (PRT) module + ! ------------------------------------------------------------------------------------- + + + type, public, extends(prt_vartypes) :: cnp_allom_prt_vartypes + + contains + + procedure :: DailyPRT => DailyPRTAllometricCNP + procedure :: FastPRT => FastPRTAllometricCNP + + ! Extended functions specific to Allometric CNP + procedure :: CNPPrioritizedReplacement + procedure :: CNPStatureGrowth + procedure :: CNPAllocateRemainder + procedure :: GetDeficit + procedure :: GetNutrientTarget + procedure :: GrowEquivC + procedure :: NAndPToMatchC + end type cnp_allom_prt_vartypes + + + ! ------------------------------------------------------------------------------------ + ! + ! This next class is an extention of the base instance that maps state variables + ! to the outside model. + ! + ! This is the instance of the mapping table and variable definitions + ! this is only allocated once per node + ! ------------------------------------------------------------------------------------ + + class(prt_global_type), public, target, allocatable :: prt_global_acnp + + character(len=*), parameter, private :: sourcefile = __FILE__ + logical, parameter :: debug = .false. + + public :: InitPRTGlobalAllometricCNP + + +contains + + + subroutine InitPRTGlobalAllometricCNP() + + ! ---------------------------------------------------------------------------------- + ! Initialize and populate the general mapping table that + ! organizes the specific variables in this module to + ! pre-ordained groups, so they can be used to inform + ! the rest of the model + ! + ! This routine is not part of the sp_pool_vartypes class + ! because it is the same for all plants and we need not + ! waste memory on it. + ! ----------------------------------------------------------------------------------- + + integer :: nleafage + + allocate(prt_global_acnp) + allocate(prt_global_acnp%state_descriptor(num_vars)) + + prt_global_acnp%hyp_name = 'Allometric Flexible C+N+P' + + prt_global_acnp%hyp_id = prt_cnp_flex_allom_hyp + + call prt_global_acnp%ZeroGlobal() + + ! The number of leaf age classes can be determined from the parameter file, + ! notably the size of the leaf-longevity parameter's second dimension. + ! This is the same value in FatesInterfaceMod.F90 + + nleafage = size(prt_params%leaf_long,dim=2) + + if(nleafage>max_nleafage) then + write(fates_log(),*) 'The allometric carbon PARTEH hypothesis' + write(fates_log(),*) 'sets a maximum number of leaf age classes' + write(fates_log(),*) 'used for scratch space. The model wants' + write(fates_log(),*) 'exceed that. Simply increase max_nleafage' + write(fates_log(),*) 'found in parteh/PRTAllometricCarbonMod.F90' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + + call prt_global_acnp%RegisterVarInGlobal(leaf_c_id,'Leaf Carbon','leaf_c',leaf_organ,carbon12_element,nleafage) + call prt_global_acnp%RegisterVarInGlobal(fnrt_c_id,'Fine Root Carbon','fnrt_c',fnrt_organ,carbon12_element,icd) + call prt_global_acnp%RegisterVarInGlobal(sapw_c_id,'Sapwood Carbon','sapw_c',sapw_organ,carbon12_element,icd) + call prt_global_acnp%RegisterVarInGlobal(store_c_id,'Storage Carbon','store_c',store_organ,carbon12_element,icd) + call prt_global_acnp%RegisterVarInGlobal(struct_c_id,'Structural Carbon','struct_c',struct_organ,carbon12_element,icd) + call prt_global_acnp%RegisterVarInGlobal(repro_c_id,'Reproductive Carbon','repro_c',repro_organ,carbon12_element,icd) + + call prt_global_acnp%RegisterVarInGlobal(leaf_n_id,'Leaf Nitrogen','leaf_n',leaf_organ,nitrogen_element,nleafage) + call prt_global_acnp%RegisterVarInGlobal(fnrt_n_id,'Fine Root Nitrogen','fnrt_n',fnrt_organ,nitrogen_element,icd) + call prt_global_acnp%RegisterVarInGlobal(sapw_n_id,'Sapwood Nitrogen','sapw_n',sapw_organ,nitrogen_element,icd) + call prt_global_acnp%RegisterVarInGlobal(store_n_id,'Storage Nitrogen','store_n',store_organ,nitrogen_element,icd) + call prt_global_acnp%RegisterVarInGlobal(struct_n_id,'Structural Nitrogen','struct_n',struct_organ,nitrogen_element,icd) + call prt_global_acnp%RegisterVarInGlobal(repro_n_id,'Reproductive Nitrogen','repro_n',repro_organ,nitrogen_element,icd) + + call prt_global_acnp%RegisterVarInGlobal(leaf_p_id,'Leaf Phosphorus','leaf_p',leaf_organ,phosphorus_element,nleafage) + call prt_global_acnp%RegisterVarInGlobal(fnrt_p_id,'Fine Root Phosphorus','fnrt_p',fnrt_organ,phosphorus_element,icd) + call prt_global_acnp%RegisterVarInGlobal(sapw_p_id,'Sapwood Phosphorus','sapw_p',sapw_organ,phosphorus_element,icd) + call prt_global_acnp%RegisterVarInGlobal(store_p_id,'Storage Phosphorus','store_p',store_organ,phosphorus_element,icd) + call prt_global_acnp%RegisterVarInGlobal(struct_p_id,'Structural Phosphorus','struct_p',struct_organ,phosphorus_element,icd) + call prt_global_acnp%RegisterVarInGlobal(repro_p_id,'Reproductive Phosphorus','repro_p',repro_organ,phosphorus_element,icd) + + + ! Set some of the array sizes for input and output boundary conditions + prt_global_acnp%num_bc_in = num_bc_in + prt_global_acnp%num_bc_out = num_bc_out + prt_global_acnp%num_bc_inout = num_bc_inout + prt_global_acnp%num_vars = num_vars + + ! Have the global generic pointer, point to this hypothesis' object + prt_global => prt_global_acnp + + return + end subroutine InitPRTGlobalAllometricCNP + + + ! ===================================================================================== + + + subroutine DailyPRTAllometricCNP(this) + + class(cnp_allom_prt_vartypes) :: this + + ! Pointers to in-out bcs + real(r8),pointer :: dbh ! Diameter at breast height [cm] + real(r8),pointer :: maint_r_def ! Current maintenance respiration deficit [kgC] + + ! Input only bcs + integer :: ipft ! Plant Functional Type index + real(r8) :: c_gain ! Daily carbon balance for this cohort [kgC] + real(r8) :: n_gain ! Daily nitrogen uptake through fine-roots [kgN] + real(r8) :: p_gain ! Daily phosphorus uptake through fine-roots [kgN] + real(r8) :: canopy_trim ! The canopy trimming function [0-1] + + ! Pointers to output bcs + real(r8),pointer :: c_efflux ! Total plant efflux of carbon (kgC) + real(r8),pointer :: n_efflux ! Total plant efflux of nitrogen (kgN) + real(r8),pointer :: p_efflux ! Total plant efflux of phosphorus (kgP) + real(r8),pointer :: n_grow ! N needed to match C stature growth (kgN) + real(r8),pointer :: n_max ! N needed to reach max stoich at final C (kgN) + real(r8),pointer :: p_grow ! P needed to match C stature growth (kgP) + real(r8),pointer :: p_max ! P needed to reach max stoich at final C (kgP) + real(r8),pointer :: growth_r ! Total plant growth respiration this step (kgC) + + ! These are pointers to the state variables, rearranged in organ dimensioned + ! arrays. This is useful because we loop through organs so often + type(parray_type),pointer :: state_c(:) ! State array for carbon, by organ [kg] + type(parray_type),pointer :: state_n(:) ! State array for N, by organ [kg] + type(parray_type),pointer :: state_p(:) ! State array for P, by organ [kg] + + integer :: i_org ! organ index + integer :: i_var ! variable index + + ! Agruments for allometry functions, that are not in the target_c array + real(r8) :: agw_c_target,agw_dcdd_target + real(r8) :: bgw_c_target,bgw_dcdd_target + real(r8) :: sapw_area + integer :: cnp_limiter + + ! These arrays hold various support variables dimensioned by organ + ! Zero suffix indicates the initial state values at the beginning of the routine + ! _unl suffix indicates values used for tracking nutrient need (ie unlimited) + ! target is the target masses associated with the plant stature, and + ! also the derivative of c wrt diameter at current diameter + real(r8), dimension(num_organs) :: target_c, target_dcdd + real(r8), dimension(num_organs) :: state_c0, state_n0, state_p0 + + ! These are daily mass gains, frozen in time, not drawn from, and thus + ! these are only used for evaluating mass balancing at the end + real(r8) :: dbh0 + real(r8) :: c_gain0 + real(r8) :: n_gain0 + real(r8) :: p_gain0 + real(r8) :: maint_r_def0 + + ! These are mass gains and fluxes used for the N&P non-limiting case + real(r8) :: c_gain_unl + real(r8) :: n_gain_unl,n_gain_unl0 + real(r8) :: p_gain_unl,p_gain_unl0 + + ! Used for mass checking, total mass allocated based + ! on change in the states, should match gain0's + real(r8) :: allocated_c + real(r8) :: allocated_n + real(r8) :: allocated_p + + real(r8) :: sum_c ! error checking sum + logical, parameter :: prt_assess_nutr_need = .true. + + + ! integrator variables + + ! Copy the input only boundary conditions into readable local variables + ! We don't use pointers, because inputs should be intent in only + ! Also, we save the initial values of many of these BC's + ! for checking and resetting if needed + ! ----------------------------------------------------------------------------------- + c_gain = this%bc_in(acnp_bc_in_id_netdc)%rval; c_gain0 = c_gain + n_gain = this%bc_in(acnp_bc_in_id_netdn)%rval; n_gain0 = n_gain + p_gain = this%bc_in(acnp_bc_in_id_netdp)%rval; p_gain0 = p_gain + canopy_trim = this%bc_in(acnp_bc_in_id_ctrim)%rval + ipft = this%bc_in(acnp_bc_in_id_pft)%ival + + ! Output only boundary conditions + c_efflux => this%bc_out(acnp_bc_out_id_cefflux)%rval; c_efflux = 0._r8 + n_efflux => this%bc_out(acnp_bc_out_id_nefflux)%rval; n_efflux = 0._r8 + p_efflux => this%bc_out(acnp_bc_out_id_pefflux)%rval; p_efflux = 0._r8 + n_grow => this%bc_out(acnp_bc_out_id_ngrow)%rval; n_grow = fates_unset_r8 + n_max => this%bc_out(acnp_bc_out_id_nmax)%rval; n_max = fates_unset_r8 + p_grow => this%bc_out(acnp_bc_out_id_pgrow)%rval; p_grow = fates_unset_r8 + p_max => this%bc_out(acnp_bc_out_id_pmax)%rval; p_max = fates_unset_r8 + + ! In/out boundary conditions + maint_r_def => this%bc_inout(acnp_bc_inout_id_rmaint_def)%rval; maint_r_def0 = maint_r_def + dbh => this%bc_inout(acnp_bc_inout_id_dbh)%rval; dbh0 = dbh + + + ! Initialize fields used for assessing N/P needs + ! (these run the allocation scheme with ample + ! N+P, to determine how much + ! availability was needed (in hindsight) drive + ! non-limited C allocaiton. + + c_gain_unl = c_gain + n_gain_unl = abs(10._r8*c_gain) + n_gain_unl0 = n_gain_unl + p_gain_unl = abs(10._r8*c_gain) + p_gain_unl0 = p_gain_unl + + ! If more than 1 leaf age bin is present, this + ! call advances leaves in their age, but does + ! not actually remove any biomass from the plant + + call this%AgeLeaves(ipft,sec_per_day) + + + ! Set all of the per-organ pointer arrays + ! Note: Since growth only happens in the 1st leaf bin, we only + ! point to that bin. However, we need to account for all bins + ! when we calculate the deficit + + allocate(state_c(num_organs)) + allocate(state_n(num_organs)) + allocate(state_p(num_organs)) + + ! Set carbon targets based on the plant's current stature + target_c(:) = fates_unset_r8 + target_dcdd(:) = fates_unset_r8 + call bsap_allom(dbh,ipft,canopy_trim,sapw_area,target_c(sapw_id),target_dcdd(sapw_id) ) + call bagw_allom(dbh,ipft,agw_c_target,agw_dcdd_target) + call bbgw_allom(dbh,ipft,bgw_c_target,bgw_dcdd_target) + call bdead_allom(agw_c_target,bgw_c_target, target_c(sapw_id), ipft, target_c(struct_id), & + agw_dcdd_target, bgw_dcdd_target, target_dcdd(sapw_id), target_dcdd(struct_id)) + call bleaf(dbh,ipft,canopy_trim, target_c(leaf_id), target_dcdd(leaf_id)) + call bfineroot(dbh,ipft,canopy_trim, target_c(fnrt_id), target_dcdd(fnrt_id)) + call bstore_allom(dbh,ipft,canopy_trim, target_c(store_id), target_dcdd(store_id)) + target_c(repro_id) = 0._r8 + target_dcdd(repro_id) = 0._r8 + + ! Initialize the the state, and keep a record of this state + ! as we may actuall run the allocation process twice, and + ! will need this state to both reset, and measure total + ! mass fluxes + do i_org = 1,num_organs + + i_var = prt_global%sp_organ_map(organ_list(i_org),carbon12_element) + state_c(i_org)%ptr => this%variables(i_var)%val(1) + state_c0(i_org) = this%variables(i_var)%val(1) + + i_var = prt_global%sp_organ_map(organ_list(i_org),nitrogen_element) + state_n(i_org)%ptr => this%variables(i_var)%val(1) + state_n0(i_org) = this%variables(i_var)%val(1) + + i_var = prt_global%sp_organ_map(organ_list(i_org),phosphorus_element) + state_p(i_org)%ptr => this%variables(i_var)%val(1) + state_p0(i_org) = this%variables(i_var)%val(1) + + end do + + assess_need_if: if(prt_assess_nutr_need) then + + ! =================================================================================== + ! Step 1. Prioritized allocation to replace tissues from turnover, and/or pay + ! any un-paid maintenance respiration from storage. + ! =================================================================================== + + call this%CNPPrioritizedReplacement(maint_r_def, c_gain_unl, n_gain_unl, p_gain_unl, & + state_c, state_n, state_p, target_c) + + ! Uncomment to see intermediate n and p needs + !n_grow = n_gain_unl0 - n_gain_unl + !p_grow = p_gain_unl0 - p_gain_unl + + ! =================================================================================== + ! Step 2. Grow out the stature of the plant by allocating to tissues beyond + ! current targets. + ! Attempts have been made to get all pools and species closest to allometric + ! targets based on prioritized relative demand and allometry functions. + ! =================================================================================== + + call this%CNPStatureGrowth(c_gain_unl, n_gain_unl, p_gain_unl, & + state_c, state_n, state_p, target_c, target_dcdd, cnp_limiter) + + n_grow = max(0._r8,(n_gain_unl0 - n_gain_unl)) + p_grow = max(0._r8,(p_gain_unl0 - p_gain_unl)) + + ! =================================================================================== + ! Step 3. + ! At this point, 1 of the 3 resources (C,N,P) has been used up for stature growth. + ! Allocate the remaining resources, or as a last resort, efflux them. + ! =================================================================================== + + call this%CNPAllocateRemainder(c_gain_unl, n_gain_unl, p_gain_unl, & + state_c, state_n, state_p, c_efflux, n_efflux, p_efflux) + + + n_max = max(n_gain_unl0 - n_efflux,0._r8) + p_max = max(p_gain_unl0 - p_efflux,0._r8) + + + ! We must now reset the state so that we can perform nutrient limited allocation + ! Note: Even if there is more than 1 leaf pool, allocation only modifies + ! the first pool, so no need to reset the others + do i_org = 1,num_organs + + i_var = prt_global%sp_organ_map(organ_list(i_org),carbon12_element) + this%variables(i_var)%val(1) = state_c0(i_org) + state_c(i_org)%ptr => this%variables(i_var)%val(1) + + i_var = prt_global%sp_organ_map(organ_list(i_org),nitrogen_element) + this%variables(i_var)%val(1) = state_n0(i_org) + state_n(i_org)%ptr => this%variables(i_var)%val(1) + + i_var = prt_global%sp_organ_map(organ_list(i_org),phosphorus_element) + this%variables(i_var)%val(1) = state_p0(i_org) + state_p(i_org)%ptr => this%variables(i_var)%val(1) + + end do + + ! Reset the maintenance respiration deficit and the growth + ! respiration + maint_r_def = maint_r_def0 + dbh = dbh0 + + end if assess_need_if + + ! =================================================================================== + ! Step 0. Transfer all stored nutrient into the daily uptake pool. + ! Storage in nutrients does not need to have a buffer like + ! carbon does, so we simply use it when we want it, and then + ! anything left at the end is added back (CNPAllocateRemainder()) + ! =================================================================================== + + i_var = prt_global%sp_organ_map(store_organ,nitrogen_element) + n_gain = n_gain + sum(this%variables(i_var)%val(:)) + this%variables(i_var)%val(:) = 0._r8 + + i_var = prt_global%sp_organ_map(store_organ,phosphorus_element) + p_gain = p_gain + sum(this%variables(i_var)%val(:)) + this%variables(i_var)%val(:) = 0._r8 + + + ! =================================================================================== + ! Step 1. Prioritized allocation to replace tissues from turnover, and/or pay + ! any un-paid maintenance respiration from storage. + ! =================================================================================== + + call this%CNPPrioritizedReplacement(maint_r_def, c_gain, n_gain, p_gain, & + state_c, state_n, state_p, target_c) + + sum_c = 0._r8 + do i_org = 1,num_organs + sum_c = sum_c+state_c(i_org)%ptr + end do + if( abs((c_gain0-c_gain) - & + (sum_c-sum(state_c0(:),dim=1)+(maint_r_def0-maint_r_def))) >calloc_abs_error ) then + write(fates_log(),*) 'Carbon not balancing I' + do i_org = 1,num_organs + write(fates_log(),*) 'state_c: ',state_c(i_org)%ptr,state_c0(i_org) + end do + write(fates_log(),*) maint_r_def0-maint_r_def + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! =================================================================================== + ! Step 2. Grow out the stature of the plant by allocating to tissues beyond + ! current targets. + ! Attempts have been made to get all pools and species closest to allometric + ! targets based on prioritized relative demand and allometry functions. + ! =================================================================================== + + call this%CNPStatureGrowth(c_gain, n_gain, p_gain, & + state_c, state_n, state_p, target_c, target_dcdd, cnp_limiter) + + sum_c = 0._r8 + do i_org = 1,num_organs + sum_c = sum_c+state_c(i_org)%ptr + end do + if( abs((c_gain0-c_gain) - & + (sum_c-sum(state_c0(:),dim=1)+(maint_r_def0-maint_r_def))) >calloc_abs_error ) then + write(fates_log(),*) 'Carbon not balanceing II' + do i_org = 1,num_organs + write(fates_log(),*) 'state_c: ',state_c(i_org)%ptr,state_c0(i_org) + end do + write(fates_log(),*) maint_r_def0-maint_r_def + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! =================================================================================== + ! Step 3. + ! At this point, at least 1 of the 3 resources have been used up. + ! Allocate the remaining resources, or as a last resort, efflux them. + ! =================================================================================== + + call this%CNPAllocateRemainder(c_gain, n_gain, p_gain, & + state_c, state_n, state_p, c_efflux, n_efflux, p_efflux) + + ! Error Check: Make sure that the mass gains are completely used up + if( abs(c_gain) > calloc_abs_error .or. & + abs(n_gain) > 0.1_r8*calloc_abs_error .or. & + abs(p_gain) > 0.02_r8*calloc_abs_error ) then + write(fates_log(),*) 'Allocation scheme should had used up all mass gain pools' + write(fates_log(),*) 'Any mass that cannot be allocated should be effluxed' + write(fates_log(),*) 'c_gain: ',c_gain + write(fates_log(),*) 'n_gain: ',n_gain + write(fates_log(),*) 'p_gain: ',p_gain + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + ! Perform a final tally on what was used (allocated) + ! Since this is also a check against what was available + ! we include maintenance pay-back and efflux to the "allocated" + ! pool to make sure everything balances. + + allocated_c = (maint_r_def0-maint_r_def) + c_efflux + allocated_n = n_efflux + allocated_p = p_efflux + + ! Update the allocation flux diagnostic arrays for each 3 elements + do i_org = 1,num_organs + + i_var = prt_global%sp_organ_map(organ_list(i_org),carbon12_element) + this%variables(i_var)%net_alloc(1) = & + this%variables(i_var)%net_alloc(1) + (state_c(i_org)%ptr - state_c0(i_org)) + + allocated_c = allocated_c + (state_c(i_org)%ptr - state_c0(i_org)) + + i_var = prt_global%sp_organ_map(organ_list(i_org),nitrogen_element) + this%variables(i_var)%net_alloc(1) = & + this%variables(i_var)%net_alloc(1) + (state_n(i_org)%ptr - state_n0(i_org)) + + allocated_n = allocated_n + (state_n(i_org)%ptr - state_n0(i_org)) + + i_var = prt_global%sp_organ_map(organ_list(i_org),phosphorus_element) + this%variables(i_var)%net_alloc(1) = & + this%variables(i_var)%net_alloc(1) + (state_p(i_org)%ptr - state_p0(i_org)) + + allocated_p = allocated_p + (state_p(i_org)%ptr - state_p0(i_org)) + + end do + + + if(debug) then + + ! Error Check: Do a final balance between how much mass + ! we had to work with, and how much was allocated + + if ( abs(allocated_c - c_gain0) > calloc_abs_error .or. & + abs(allocated_n - n_gain0) > calloc_abs_error .or. & + abs(allocated_p - p_gain0) > calloc_abs_error ) then + write(fates_log(),*) 'CNP allocation scheme did not balance mass.' + write(fates_log(),*) 'c_gain0: ',c_gain0,' allocated_c: ',allocated_c + write(fates_log(),*) 'n_gain0: ',n_gain0,' allocated_n: ',allocated_n + write(fates_log(),*) 'p_gain0: ',p_gain0,' allocated_p: ',allocated_p + + do i_org = 1,num_organs + write(fates_log(),*) i_org, state_c(i_org)%ptr-state_c0(i_org) + end do + write(fates_log(),*) (maint_r_def0-maint_r_def), c_efflux + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + + deallocate(state_c) + deallocate(state_n) + deallocate(state_p) + + return + end subroutine DailyPRTAllometricCNP + + ! ===================================================================================== + + subroutine CNPPrioritizedReplacement(this, & + maint_r_deficit, c_gain, n_gain, p_gain, & + state_c, state_n, state_p, target_c) + + + ! ----------------------------------------------------------------------------------- + ! Alternative allocation hypothesis for the prioritized replacement phase. + ! This is more similar to the current (04/2020) carbon only hypothesis. + ! ----------------------------------------------------------------------------------- + + class(cnp_allom_prt_vartypes) :: this + real(r8), intent(inout) :: c_gain + real(r8), intent(inout) :: n_gain + real(r8), intent(inout) :: p_gain + real(r8), intent(inout) :: maint_r_deficit + type(parray_type) :: state_c(:) ! State array for carbon, by organ [kg] + type(parray_type) :: state_n(:) ! State array for N, by organ [kg] + type(parray_type) :: state_p(:) ! State array for P, by organ [kg] + real(r8), intent(in) :: target_c(:) + + integer :: n_curpri_org + integer, dimension(num_organs) :: curpri_org ! C variable ID's of the current priority level + real(r8), dimension(num_organs) :: deficit_c ! Deficit to get to target from current [kg] + real(r8), dimension(num_organs) :: deficit_n ! Deficit to get to target from current [kg] + real(r8), dimension(num_organs) :: deficit_p ! Deficit to get to target from current [kg] + integer :: i, ii, i_org ! Loop indices (mostly for organs) + integer :: i_cvar ! variable index + integer :: i_pri ! loop index for priority + integer :: ipft ! Plant functional type index of this plant + integer :: leaf_status ! Is this plant in a leaf on or off status? + real(r8) :: dbh ! DBH [cm] + real(r8) :: canopy_trim ! trim factor for maximum leaf biomass + real(r8) :: target_n ! Target mass of N for a given organ [kg] + real(r8) :: target_p ! Target mass of P for a given organ [kg] + real(r8) :: c_gain0 + integer :: priority_code ! Index for priority level of each organ + real(r8) :: sum_c_demand ! Carbon demanded to bring tissues up to allometry (kg) + real(r8) :: sum_n_deficit ! The nitrogen deficit of all pools for given priority level (kg) + real(r8) :: sum_p_deficit ! The phosphorus deficit of all pools for given priority level (kg) + real(r8) :: store_below_target + real(r8) :: store_target_fraction + real(r8) :: store_demand + real(r8) :: store_c_flux + real(r8) :: sum_c_flux ! The flux to bring tissues up to allometry (kg) + real(r8) :: sum_n_flux ! The flux of nitrogen "" (kg) + real(r8) :: sum_p_flux ! The flux of phosphorus "" (Kg) + real(r8) :: c_flux ! carbon flux into an arbitrary pool (kg) + real(r8) :: gr_flux ! carbon flux to fulfill growth respiration of an arbitrary pool (kg) + real(r8) :: n_flux ! nitrogen flux into an arbitrary pool (kg) + real(r8) :: p_flux ! phosphorus flux into an arbitrary pool (kg) + real(r8) :: maint_r_def_flux ! Flux into maintenance respiration during priority 1 allocation + real(r8) :: c_gain_flux ! Flux used to pay back negative carbon gain (from storage) (kgC) + real(r8) :: sapw_area + integer, parameter :: n_max_priority = num_organs + 1 ! Maximum possible number of priority levels is + ! the total number organs plus 1, which allows + ! each organ to have its own level, and ignore + ! the specialized priority 1 + + + c_gain0 = c_gain + + leaf_status = this%bc_in(acnp_bc_in_id_lstat)%ival + ipft = this%bc_in(acnp_bc_in_id_pft)%ival + canopy_trim = this%bc_in(acnp_bc_in_id_ctrim)%rval + + ! ----------------------------------------------------------------------------------- + ! Preferential transfer of available carbon and nutrients into the highest + ! priority pools, and maintenance respiration. We will loop through the available + ! pools, and identify if that pool is part of the highest transfer priority. + ! If it is, then we track the variable ids associated with that pool for each CNP + ! species. It "should" work fine if there are NO priority=1 pools... + ! ----------------------------------------------------------------------------------- + + + curpri_org(:) = fates_unset_int ! reset "current-priority" organ ids + i = 0 + do ii = 1, num_organs + + deficit_c(ii) = max(0._r8,this%GetDeficit(carbon12_element,organ_list(ii),target_c(ii))) + + ! The priority code associated with this organ + priority_code = int(prt_params%alloc_priority(ipft, organ_list(ii))) + + ! Don't allow allocation to leaves if they are in an "off" status. + ! Also, dont allocate to replace turnover if this is not evergreen + ! (this prevents accidental re-flushing on the day they drop) + if( ((leaf_status.eq.leaves_off) .or. (prt_params%evergreen(ipft) .ne. itrue)) & + .and. (organ_list(ii).eq.leaf_organ)) cycle + + ! 1 is the highest priority code possible + if( priority_code == 1 ) then + i = i + 1 + curpri_org(i) = ii + end if + end do + + + ! Number of pools in the current priority level + n_curpri_org = i + + ! ----------------------------------------------------------------------------------- + ! The high-priority pools, and their associated variable + ! indices have been identified. + ! + ! Let us now calculate the fluxes into these priority pools + ! The first step is to replace just their maintenance turnover + ! ----------------------------------------------------------------------------------- + + sum_c_demand = 0._r8 + do ii = 1,n_curpri_org + i = curpri_org(ii) + + i_cvar = prt_global%sp_organ_map(organ_list(i),carbon12_element) + sum_c_demand = sum_c_demand + prt_params%leaf_stor_priority(ipft) * & + sum(this%variables(i_cvar)%turnover(:)) + + end do + + + sum_c_flux = max(0._r8,min(sum_c_demand,state_c(store_id)%ptr+c_gain)) + + if (sum_c_flux> 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 + + do ii = 1,n_curpri_org + i = curpri_org(ii) + + i_cvar = prt_global%sp_organ_map(organ_list(i),carbon12_element) + + if(reproduce_conly) then + c_flux = min(prt_params%leaf_stor_priority(ipft)*sum(this%variables(i_cvar)%turnover(:)), & + max(0.0_r8, (state_c(store_id)%ptr+c_gain)* & + (prt_params%leaf_stor_priority(ipft)*sum(this%variables(i_cvar)%turnover(:))/sum_c_demand) )) + else + c_flux = sum_c_flux*(prt_params%leaf_stor_priority(ipft) * & + sum(this%variables(i_cvar)%turnover(:))/sum_c_demand) + end if + + ! Add carbon to the pool + state_c(i)%ptr = state_c(i)%ptr + c_flux + + ! Remove from daily carbon gain + c_gain = c_gain - c_flux + + end do + end if + + ! Determine nutrient demand and make tansfers (ignore replacing storage) + do i = 1, n_curpri_org + + i_org = curpri_org(i) + + ! Update the nitrogen deficits + ! Note that the nitrogen target is tied to the stoichiometry of thegrowing pool only + + if(organ_list(i_org).ne.store_organ)then + + target_n = this%GetNutrientTarget(nitrogen_element,organ_list(i_org),stoich_growth_min) + deficit_n(i_org) = max(0.0_r8, target_n - state_n(i_org)%ptr ) + + ! Update the phosphorus deficits (which are based off of carbon actual..) + ! Note that the phsophorus target is tied to the stoichiometry of thegrowing pool only (also) + target_p = this%GetNutrientTarget(phosphorus_element,organ_list(i_org),stoich_growth_min) + deficit_p(i_org) = max(0.0_r8, target_p - state_p(i_org)%ptr ) + else + deficit_n(i_org) = 0._r8 + deficit_p(i_org) = 0._r8 + end if + + end do + + ! Allocate nutrients at this priority level + ! Nitrogen + call ProportionalNutrAllocation(state_n, deficit_n, & + n_gain, nitrogen_element, curpri_org(1:n_curpri_org)) + + ! Phosphorus + call ProportionalNutrAllocation(state_p, deficit_p, & + p_gain, phosphorus_element, curpri_org(1:n_curpri_org)) + + + + ! ----------------------------------------------------------------------------------- + ! IV. if carbon balance is negative, re-coup the losses from storage + ! if it is positive, give some love to storage carbon + ! ----------------------------------------------------------------------------------- + + if( c_gain < 0.0_r8 ) then + + ! Storage will have to pay for any negative gains + store_c_flux = -c_gain + c_gain = c_gain + store_c_flux + state_c(store_id)%ptr = state_c(store_id)%ptr - store_c_flux + + else + + ! This is just a cap, don't fill up more than is needed (shouldn't even apply) + store_below_target = max(target_c(store_id) - state_c(store_id)%ptr,0._r8) + + ! This is the desired need for carbon + store_target_fraction = max(state_c(store_id)%ptr/target_c(store_id),0._r8) + + store_demand = max(c_gain*(exp(-1.*store_target_fraction**4._r8) - exp( -1.0_r8 )),0._r8) + + + + ! The flux is the (positive) minimum of all three + store_c_flux = min(store_below_target,store_demand) + + c_gain = c_gain - store_c_flux + state_c(store_id)%ptr = state_c(store_id)%ptr + store_c_flux + + + end if + + + ! ----------------------------------------------------------------------------------- + ! If carbon is still available, allocate to remaining high + ! carbon balance is guaranteed to be >=0 beyond this point + ! ----------------------------------------------------------------------------------- + + ! ----------------------------------------------------------------------------------- + ! Bring all pools, in priority order, up to allometric targets if possible + ! ----------------------------------------------------------------------------------- + + do i_pri = 1, n_max_priority + + curpri_org(:) = fates_unset_int ! "current-priority" organ indices + + i = 0 + do ii = 1, num_organs + + ! The priority code associated with this organ + priority_code = int(prt_params%alloc_priority(ipft, organ_list(ii))) + + ! Don't allow allocation to leaves if they are in an "off" status. + ! (this prevents accidental re-flushing on the day they drop) + if((leaf_status.eq.leaves_off) .and. (organ_list(ii).eq.leaf_organ)) cycle + + ! 1 is the highest priority code possible + if( priority_code == i_pri ) then + deficit_c(ii) = max(0._r8,this%GetDeficit(carbon12_element,organ_list(ii),target_c(ii))) + i = i + 1 + curpri_org(i) = ii + end if + end do + + ! Bring carbon up to target first, this order is required + ! because we need to know the resulting carbon concentrations + ! before we set the allometric targets for the nutrients + + n_curpri_org = i + + ! The total amount of carbon needed to be replaced + ! is the deficit and the growth respiration needed + ! accomany replacing that deficit + + sum_c_demand = 0._r8 + do i=1,n_curpri_org + i_org = curpri_org(i) + sum_c_demand = sum_c_demand + deficit_c(i_org) + end do + + sum_c_flux = min(c_gain, sum_c_demand) + + ! Transfer carbon into pools if there is any + if (sum_c_flux>nearzero) then + do i = 1, n_curpri_org + + i_org = curpri_org(i) + + if(reproduce_conly) then + c_flux = min(deficit_c(i_org), & + c_gain*(deficit_c(i_org)/sum_c_demand)) + else + c_flux = sum_c_flux*deficit_c(i_org)/sum_c_demand + end if + + ! Update the carbon pool + state_c(i_org)%ptr = state_c(i_org)%ptr + c_flux + + ! Update carbon pools deficit + deficit_c(i_org) = max(0._r8,deficit_c(i_org) - c_flux) + + ! Reduce the carbon gain + c_gain = c_gain - c_flux + + end do + end if + + + sum_c_demand = 0._r8 + do i=1,n_curpri_org + i_org = curpri_org(i) + deficit_c(i_org) = max(0._r8,this%GetDeficit(carbon12_element,organ_list(i_org),target_c(i_org))) + sum_c_demand = sum_c_demand + deficit_c(i_org) + end do + + sum_c_flux = min(c_gain, sum_c_demand) + + ! Transfer carbon into pools if there is any (second round to match C-only) + if (sum_c_flux>nearzero) then + do i = 1, n_curpri_org + + i_org = curpri_org(i) + + c_flux = sum_c_flux*deficit_c(i_org)/sum_c_demand + + ! Update the carbon pool + state_c(i_org)%ptr = state_c(i_org)%ptr + c_flux + + ! Update carbon pools deficit + deficit_c(i_org) = max(0._r8,deficit_c(i_org) - c_flux) + + ! Reduce the carbon gain + c_gain = c_gain - c_flux + + end do + end if + + + + + ! Determine nutrient demand and make tansfers + do i = 1, n_curpri_org + + i_org = curpri_org(i) + if(organ_list(i_org).ne.store_organ)then + ! Update the nitrogen deficits + ! Note that the nitrogen target is tied to the stoichiometry of thegrowing pool only + target_n = this%GetNutrientTarget(nitrogen_element,organ_list(i_org),stoich_growth_min) + deficit_n(i_org) = max(0.0_r8, target_n - state_n(i_org)%ptr ) + + ! Update the phosphorus deficits (which are based off of carbon actual..) + ! Note that the phsophorus target is tied to the stoichiometry of thegrowing pool only (also) + target_p = this%GetNutrientTarget(phosphorus_element,organ_list(i_org),stoich_growth_min) + deficit_p(i_org) = max(0.0_r8, target_p - state_p(i_org)%ptr ) + else + deficit_n(i_org) = 0._r8 + deficit_p(i_org) = 0._r8 + end if + end do + + ! Allocate nutrients at this priority level + ! Nitrogen + call ProportionalNutrAllocation(state_n, deficit_n, & + n_gain, nitrogen_element, curpri_org(1:n_curpri_org)) + + ! Phosphorus + call ProportionalNutrAllocation(state_p, deficit_p, & + p_gain, phosphorus_element, curpri_org(1:n_curpri_org)) + + + end do + + return + end subroutine CNPPrioritizedReplacement + + + ! ===================================================================================== + + subroutine CNPStatureGrowth(this,c_gain, n_gain, p_gain, & + state_c, state_n, state_p, & + target_c, target_dcdd, cnp_limiter) + + + class(cnp_allom_prt_vartypes) :: this + real(r8), intent(inout) :: c_gain + real(r8), intent(inout) :: n_gain + real(r8), intent(inout) :: p_gain + real(r8), pointer :: maint_r_deficit + type(parray_type) :: state_c(:) ! State array for carbon, by organ [kg] + type(parray_type) :: state_n(:) ! State array for N, by organ [kg] + type(parray_type) :: state_p(:) ! State array for P, by organ [kg] + real(r8), intent(in) :: target_c(:) + real(r8), intent(in) :: target_dcdd(:) + integer, intent(out) :: cnp_limiter + + real(r8), pointer :: dbh + integer :: ipft + real(r8) :: canopy_trim + real(r8) :: leaf_status + + integer :: i, ii ! organ index loops (masked and unmasked) + integer :: istep ! outer step iteration loop + real(r8) :: grow_c_from_c ! carbon transferred into tissues + real(r8) :: grow_c_from_n ! carbon needed to match N transfers to tissues + real(r8) :: grow_c_from_p ! carbon needed to match P transfers to tissues + real(r8) :: total_dcostdd ! Total carbon transferred to all pools for unit growth + logical :: step_pass ! flag stating if the integration sub-steps passed checks + real(r8) :: totalC ! total carbon sent to integrator (kg) + real(r8) :: deltaC ! trial value for substep change in carbon (kg) + real(r8) :: cdeficit ! carbon deficit from target + integer :: ierr ! error flag for allometric growth step + integer :: nsteps ! number of sub-steps + real(r8) :: repro_c_frac ! Fraction of C allocated to reproduction + ! at current stature (dbh) [/] + real(r8) :: sum_c_flux ! Sum of the carbon allocated, as reported + ! by the ODE solver. [kg] + real(r8) :: np_limit + real(r8) :: n_match + real(r8) :: p_match + real(r8) :: c_flux_adj ! Adjustment to total carbon flux during stature growth + ! intended to correct integration error (kg/kg) + real(r8) :: c_flux ! Carbon flux from the gain pool to an organ (kgC) + real(r8) :: gr_flux ! Growth respiration flux for the current transaction (kgC) + real(r8) :: c_gstature ! Carbon reserved for stature growth (kg) + real(r8) :: target_n ! Target mass of N for a given organ [kg] + real(r8) :: target_p ! Target mass of P for a given organ [kg] + real(r8) :: sum_n_demand ! Total N deficit to overcome after C stature growth [kg] + real(r8) :: sum_p_demand ! Total P deficit to overcome after C stature growth [kg] + real(r8), dimension(num_organs) :: frac_c ! Fraction of C going towards each pool + ! (only used when calculating which species limits) + real(r8), dimension(num_organs) :: deficit_n ! Deficit to get to target from current [kg] + real(r8), dimension(num_organs) :: deficit_p ! Deficit to get to target from current [kg] + integer,dimension(num_organs) :: mask_organs ! This works with "state_mask", the list + ! of organs in the mask + integer :: n_mask_organs + + ! Integrator error checking + integer :: i_var + integer :: nbins + real(r8) :: dbh_tp1 + real(r8) :: leafc_tp1 + real(r8) :: fnrtc_tp1 + real(r8) :: sapwc_tp1 + real(r8) :: storec_tp1 + real(r8) :: structc_tp1 + real(r8) :: leaf_c_target_tp1 + real(r8) :: fnrt_c_target_tp1 + real(r8) :: sapw_c_target_tp1 + real(r8) :: agw_c_target_tp1 + real(r8) :: bgw_c_target_tp1 + real(r8) :: struct_c_target_tp1 + real(r8) :: store_c_target_tp1 + real(r8) :: sapw_area + + ! Integegrator variables + ! These are not global because we want a unique instance for each time the routine is called + ! ---------------------------------------------------------------------------------------- + + real(r8),dimension(num_intgr_vars) :: state_array ! Vector of carbon pools passed to integrator + real(r8),dimension(num_intgr_vars) :: state_array_out ! Vector of carbon pools passed back from integrator + logical,dimension(num_intgr_vars) :: state_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) + + integer, parameter :: grow_lim_type = 3 ! Dev flag for growth limitation algorithm + ! 1 = tries to calculate equivalent carbon + ! 2 = modification of 1 + ! 3 = don't limit, and assume nutrient limitations will prevent calling + ! of this step on the next cycle if they exist + + integer, parameter :: c_limited = 1 + integer, parameter :: n_limited = 2 + integer, parameter :: p_limited = 3 + + leaf_status = this%bc_in(acnp_bc_in_id_lstat)%ival + dbh => this%bc_inout(acnp_bc_inout_id_dbh)%rval + ipft = this%bc_in(acnp_bc_in_id_pft)%ival + canopy_trim = this%bc_in(acnp_bc_in_id_ctrim)%rval + + cnp_limiter = 0 + + ! If any of these resources is essentially tapped out, + ! then there is no point in performing growth + ! It also seems impossible that we would be in a leaf-off status + ! and have enough carbon to grow stature, but its possible that + ! a plant had a productive last day before the phenology scheme + ! signaled a drop. If this is the case, we can't grow stature + ! cause that would force the leaves back on, so just leave. + + if( c_gain <= calloc_abs_error .or. & + n_gain <= 0.1_r8*calloc_abs_error .or. & + p_gain <= 0.02_r8*calloc_abs_error .or. & + leaf_status.eq.leaves_off ) then + return + end if + + + intgr_params(:) = fates_unset_r8 + intgr_params(acnp_bc_in_id_ctrim) = this%bc_in(acnp_bc_in_id_ctrim)%rval + intgr_params(acnp_bc_in_id_pft) = real(this%bc_in(acnp_bc_in_id_pft)%ival) + + + state_mask(:) = .false. + mask_organs(:) = fates_unset_int + + ! Go through and flag the integrating variables as either pools that + ! are growing in this iteration, or not. At this point, if carbon for growth + ! remains, it means that all pools are up to, or above the target. If + ! it is above, that is because of numerical integration errors, or fusion. + ! In that case, we flag that pool to not be included in stature growth. It will + ! catch up with the other pools in the next stature growth steps. + + ii = 0 + do i = 1, num_organs + + cdeficit = this%GetDeficit(carbon12_element,organ_list(i),target_c(i)) + + if ( cdeficit > calloc_abs_error ) then + ! In this case, we somehow still have carbon to play with, + ! yet one of the pools is below its current target + ! gracefully fail + write(fates_log(),*) 'A carbon pool has reached the stature growth step' + write(fates_log(),*) 'yet its deficit is too large to integrate ' + write(fates_log(),*) 'organ: ',i + write(fates_log(),*) 'carbon gain: ',c_gain + write(fates_log(),*) 'leaves status:', leaf_status + write(fates_log(),*) cdeficit, target_c(i), state_c(i)%ptr + call endrun(msg=errMsg(sourcefile, __LINE__)) + elseif( (-cdeficit) > calloc_abs_error ) then + ! In this case, we are above our target (ie negative deficit (fusion?)) + ! and if so, this pool does not have to grow and will + ! catch up in the next step + state_mask(i) = .false. ! flag index of state variable + else + ! In this case, the pool is close enough to the target + ! to be flagged for growth + state_mask(i) = .true. ! flag index of state variable + + ! Reproduction is a special case, don't add it to the + ! list of organs... yet + if (organ_list(i).ne.repro_organ) then + ii=ii+1 + mask_organs(ii) = i + end if + + end if + end do + + n_mask_organs = ii + + if(debug) then + if ( .not.any(state_mask(1:num_organs)) ) then + write(fates_log(),*) 'No organs seem to have carbon masses that are' + write(fates_log(),*) 'on allometry. Apparently, all are above allometry' + write(fates_log(),*) 'which should be impossible. We allow for all but' + write(fates_log(),*) 'one pool to be above allometry. Structure in woody' + write(fates_log(),*) 'plants, and roots in grasses are not allowed above target.' + write(fates_log(),*) 'pft: ',ipft + write(fates_log(),*) 'dbh: ',dbh + write(fates_log(),*) 'c state1 : ',state_c(1)%ptr + write(fates_log(),*) 'c targets: ',target_c(1:num_organs) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! fraction of carbon going towards reproduction. reproductive carbon is + ! just different from the other pools. It is not based on proportionality, + ! so its mask is set differently. We (inefficiently) just included + ! reproduction in the previous loop, but oh well, we over-write now. + + if (dbh <= prt_params%dbh_repro_threshold(ipft)) then + repro_c_frac = prt_params%seed_alloc(ipft) + else + repro_c_frac = prt_params%seed_alloc(ipft) + prt_params%seed_alloc_mature(ipft) + end if + + if(repro_c_frac>nearzero)then + state_mask(repro_id) = .true. + ii = ii + 1 + n_mask_organs = ii + mask_organs(ii) = repro_id + else + state_mask(repro_id) = .false. + end if + + ! Calculate the total CARBON allocation rate per diameter increment + ! Include the growth respiration costs "total_dcostdd" in that estimate + ! ALso include the non-respiring cost, which is needed to project reproductive + ! costs. + ! -------------------------------------------------------------------------------- + + ! First objective is to find the extrapolated proportions of carbon going to + ! each pool. This has nothing to do with carbon conservation, it is just used + ! to make a rough prediction of how much nutrient is needed to match carbon + + total_dcostdd = 0._r8 + + do ii = 1, n_mask_organs + i = mask_organs(ii) + total_dcostdd = total_dcostdd + target_dcdd(i) + end do + + frac_c(:) = 0._r8 + do ii = 1, n_mask_organs + i = mask_organs(ii) + frac_c(i) = target_dcdd(i)/total_dcostdd * (1.0_r8 - repro_c_frac) + end do + frac_c(repro_id) = repro_c_frac + + if(debug) then + if ( abs(sum(frac_c,dim=1)-1._r8)>rsnbl_math_prec ) then + write(fates_log(),*) 'predicted carbon allocation fractions dont sum to 1?' + write(fates_log(),*) 'frac_c(:):',frac_c + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + + select case(grow_lim_type) + case(1) + + + ! Calculate an approximation of the total amount of carbon that would be needed + ! to match the amount of each nutrient used. We also add in the amount of nutrient + ! that may or may-not exist above each pool's minimum stoichiometry... + ! -------------------------------------------------------------------------------- + + grow_c_from_c = 0._r8 + grow_c_from_n = 0._r8 + grow_c_from_p = 0._r8 + + do ii = 1, n_mask_organs + i = mask_organs(ii) + if(organ_list(i).ne.store_organ)then + call this%GrowEquivC(c_gain,n_gain,p_gain, & + frac_c(i),ipft,organ_list(i), & + grow_c_from_c,grow_c_from_n,grow_c_from_p) + end if + end do + + ! -------------------------------------------------------------------------------- + ! We limit growth to align with the species would motivate the least flux of + ! carbon into growing tissues to match. This is only an approximation of how much + ! growth we get out of each, and they don't have to be perfect. As long as we + ! don't use more carbon than we have (we wont) and if we use the actual numerical + ! integrator in the trasfer step, the nutrients will be transferred linearly in + ! the next step. if they dip slightly above or below their target allometries, + ! its no big deal. + ! -------------------------------------------------------------------------------- + + if(grow_c_from_c > nearzero) then + c_gstature = c_gain * min(grow_c_from_c, grow_c_from_n, grow_c_from_p)/grow_c_from_c + else + write(fates_log(),*) 'Somehow grow_c_from_c is near zero',grow_c_from_c + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + case(2) + + n_match = 0._r8 + p_match = 0._r8 + do ii = 1, n_mask_organs + i = mask_organs(ii) + if(organ_list(i).ne.store_organ)then + call this%NAndPToMatchC(c_gain*frac_c(i),target_dcdd(i), & + ipft,organ_list(i),n_match,p_match) + end if + end do + + np_limit = min(min(1._r8, n_gain/n_match), min(1._r8, p_gain/p_match)) + + if( (n_gain/n_match)>1._r8 .and. (p_gain/p_match)>1._r8 ) then + cnp_limiter = c_limited + else + if( n_gain/n_match < p_gain/p_match ) then + cnp_limiter = n_limited + else + cnp_limiter = p_limited + end if + end if + + c_gstature = c_gain * np_limit + + case(3) + + ! HACK, ALLOW FULL C ALLOCATION AND LET REST OF ALGORITHM LIMIT + c_gstature = c_gain + + + end select + + + if_stature_growth: if(c_gstature > nearzero) then + + ! Initialize the adaptive integrator arrays and flags + ! ----------------------------------------------------------------------------------- + + if(ODESolve == 2) then + this%ode_opt_step = c_gstature + end if + + ! If this flag is set to 0, then + ! we have a successful integration + ierr = 1 + nsteps = 0 + totalC = c_gstature + + ! Fill the state array with element masses for each organ + do i = 1, num_organs + state_array(i) = state_c(i)%ptr + end do + + state_mask(dbh_id) = .true. + state_array(dbh_id) = dbh + + totalC = c_gstature + + do_solve_check: do while( ierr .ne. 0 ) + + deltaC = min(totalC,this%ode_opt_step) + if(ODESolve == 1) then + + call RKF45(AllomCNPGrowthDeriv,state_array,state_mask,deltaC,totalC, & + max_trunc_error,intgr_params,state_array_out,this%ode_opt_step,step_pass) + + elseif(ODESolve == 2) then + + call Euler(AllomCNPGrowthDeriv,state_array,state_mask, & + deltaC,totalC,intgr_params,state_array_out) + + ! Here we check to see if the solution is reasonably + ! close to allometry, we also have to add up all leaf bins + ! for this check. + + leafc_tp1 = state_array_out(leaf_id) + i_var = prt_global%sp_organ_map(leaf_organ,carbon12_element) + nbins = prt_global%state_descriptor(i_var)%num_pos + do i = 2,nbins + leafc_tp1 = leafc_tp1 + this%variables(i_var)%val(i) + end do + + call CheckIntegratedAllometries(state_array_out(dbh_id),ipft,canopy_trim, & + leafc_tp1, state_array_out(fnrt_id), state_array_out(sapw_id), & + state_array_out(store_id), state_array_out(struct_id), & + state_mask(leaf_id), state_mask(fnrt_id), state_mask(sapw_id), & + state_mask(store_id),state_mask(struct_id), max_trunc_error, step_pass) + + if(step_pass) then + this%ode_opt_step = deltaC + else + this%ode_opt_step = 0.5_r8*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 + totalC = totalC - deltaC + state_array(:) = state_array_out(:) + end if + + ! TotalC should eventually be whittled down to near-zero + ! -------------------------------------------------------------------------------- + if_completed_solve: if( (totalC < calloc_abs_error) )then + + ierr = 0 + + ! Sum up the total flux predicted by the integrator, + ! which SHOULD be c_gstature, except + ! for integration errors. To make carbon + ! perfectly preserved, we calculate this bias + ! and make a linear (proportional) correction to all pools. + + sum_c_flux = 0.0_r8 + do ii = 1, n_mask_organs + i = mask_organs(ii) + sum_c_flux = sum_c_flux + (state_array(i) - state_c(i)%ptr) + end do + + ! This is a correction factor that forces + ! mass conservation + c_flux_adj = c_gstature/sum_c_flux + + do ii = 1, n_mask_organs + + i = mask_organs(ii) + + ! Calculate adjusted flux + c_flux = (state_array(i) - state_c(i)%ptr)*c_flux_adj + + ! update the carbon pool (in all pools flux goes into the first pool) + state_c(i)%ptr = state_c(i)%ptr + c_flux + + ! Remove carbon from the daily gain + c_gain = c_gain - c_flux + + end do + + ! Update dbh + dbh = state_array(dbh_id) + + else + + if_step_exceedance: if (nsteps > max_substeps ) then + + write(fates_log(),*) 'CNP Plant Growth Integrator could not find' + write(fates_log(),*) 'a solution in less than ',max_substeps,' tries' + write(fates_log(),*) 'Aborting' + write(fates_log(),*) 'mask: ',state_mask + write(fates_log(),*) 'smallest deltaC',this%ode_opt_step + write(fates_log(),*) 'totalC',totalC + write(fates_log(),*) 'pft: ',ipft + write(fates_log(),*) 'dbh: ',dbh + write(fates_log(),*) 'dCleaf_dd: ',target_dcdd(leaf_id) + write(fates_log(),*) 'dCfnrt_dd: ',target_dcdd(fnrt_id) + write(fates_log(),*) 'dCstore_dd: ',target_dcdd(store_id) + write(fates_log(),*) 'dCsapw_dd: ',target_dcdd(sapw_id) + write(fates_log(),*) 'dCstruct_dd: ',target_dcdd(struct_id) + write(fates_log(),*) 'repro c frac: ',repro_c_frac + dbh_tp1 = state_array_out(dbh_id) + leafc_tp1 = state_array_out(leaf_id) + fnrtc_tp1 = state_array_out(fnrt_id) + sapwc_tp1 = state_array_out(sapw_id) + storec_tp1 = state_array_out(store_id) + structc_tp1 = state_array_out(struct_id) + + call bleaf(dbh_tp1,ipft,canopy_trim,leaf_c_target_tp1) + call bfineroot(dbh_tp1,ipft,canopy_trim,fnrt_c_target_tp1) + call bsap_allom(dbh_tp1,ipft,canopy_trim,sapw_area,sapw_c_target_tp1) + call bagw_allom(dbh_tp1,ipft,agw_c_target_tp1) + call bbgw_allom(dbh_tp1,ipft,bgw_c_target_tp1) + call bdead_allom(agw_c_target_tp1,bgw_c_target_tp1, sapw_c_target_tp1, ipft, struct_c_target_tp1) + call bstore_allom(dbh_tp1,ipft,canopy_trim,store_c_target_tp1) + + write(fates_log(),*) 'leaf_c: ',leafc_tp1, leaf_c_target_tp1,leafc_tp1-leaf_c_target_tp1 + write(fates_log(),*) 'fnrt_c: ',fnrtc_tp1, fnrt_c_target_tp1,fnrtc_tp1- fnrt_c_target_tp1 + write(fates_log(),*) 'sapw_c: ',sapwc_tp1, sapw_c_target_tp1 ,sapwc_tp1- sapw_c_target_tp1 + write(fates_log(),*) 'store_c: ',storec_tp1, store_c_target_tp1,storec_tp1- store_c_target_tp1 + write(fates_log(),*) 'struct_c: ',structc_tp1, struct_c_target_tp1,structc_tp1- struct_c_target_tp1 + write(fates_log(),*) 'sapw_c_t0: ',state_c(sapw_id)%ptr, target_c(sapw_id) + + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end if if_step_exceedance + + end if if_completed_solve + + end do do_solve_check + + + ! ----------------------------------------------------------------------------------- + ! Nutrient Fluxes proportionally to each pool (these should be fully actualized) + ! (this also removes from the gain pools) + ! ----------------------------------------------------------------------------------- + + sum_n_demand = 0._r8 ! For error checking + sum_p_demand = 0._r8 ! For error checking + do ii = 1, n_mask_organs + i = mask_organs(ii) + if(organ_list(i).ne.store_organ)then + ! Update the nitrogen deficits (which are based off of carbon actual..) + ! Note that the nitrogen target is tied to the stoichiometry of thegrowing pool only + target_n = this%GetNutrientTarget(nitrogen_element,organ_list(i),stoich_growth_min) + deficit_n(i) = this%GetDeficit(nitrogen_element,organ_list(i),target_n) + sum_n_demand = sum_n_demand+max(0._r8,deficit_n(i)) + + ! Update the nitrogen deficits (which are based off of carbon actual..) + ! Note that the nitrogen target is tied to the stoichiometry of thegrowing pool only + target_p = this%GetNutrientTarget(phosphorus_element,organ_list(i),stoich_growth_min) + deficit_p(i) = this%GetDeficit(phosphorus_element,organ_list(i),target_p) + sum_p_demand = sum_p_demand+max(0._r8,deficit_p(i)) + else + deficit_n(i) = 0._r8 + deficit_p(i) = 0._r8 + end if + + end do + + + ! Nitrogen + call ProportionalNutrAllocation(state_n,deficit_n, & + n_gain, nitrogen_element,mask_organs(1:n_mask_organs)) + + ! Phosphorus + call ProportionalNutrAllocation(state_p, deficit_p, & + p_gain, phosphorus_element,mask_organs(1:n_mask_organs)) + + + end if if_stature_growth + + return + end subroutine CNPStatureGrowth + + ! ===================================================================================== + + subroutine CNPAllocateRemainder(this,c_gain, n_gain, p_gain, & + state_c, state_n, state_p, c_efflux, n_efflux, p_efflux) + + class(cnp_allom_prt_vartypes) :: this + real(r8), intent(inout) :: c_gain + real(r8), intent(inout) :: n_gain + real(r8), intent(inout) :: p_gain + type(parray_type) :: state_c(:) ! State array for carbon, by organ [kg] + type(parray_type) :: state_n(:) ! State array for N, by organ [kg] + type(parray_type) :: state_p(:) ! State array for P, by organ [kg] + real(r8), intent(inout) :: c_efflux + real(r8), intent(inout) :: n_efflux + real(r8), intent(inout) :: p_efflux + + integer :: i + real(r8), dimension(num_organs) :: deficit_n + real(r8), dimension(num_organs) :: deficit_p + real(r8) :: target_n + real(r8) :: target_p + real(r8) :: store_c_target ! Target amount of C in storage including "overflow" [kgC] + real(r8) :: total_c_flux ! Total C flux from gains into storage and growth R [kgC] + real(r8) :: growth_r_flux ! Growth respiration for filling storage [kgC] + real(r8) :: store_c_flux ! Flux into storage [kgC] + integer, dimension(num_organs),parameter :: all_organs = [1,2,3,4,5,6] + real(r8), pointer :: dbh + integer :: ipft + real(r8) :: canopy_trim + + + dbh => this%bc_inout(acnp_bc_inout_id_dbh)%rval + canopy_trim = this%bc_in(acnp_bc_in_id_ctrim)%rval + ipft = this%bc_in(acnp_bc_in_id_pft)%ival + + ! ----------------------------------------------------------------------------------- + ! If nutrients are still available, then we can bump up the values in the pools + ! towards the OPTIMAL target values. + ! ----------------------------------------------------------------------------------- + + do i = 1, num_organs + + ! Update the nitrogen deficits (which are based off of carbon actual..) + ! Note that the nitrogen target is tied to the stoichiometry of thegrowing pool only + target_n = this%GetNutrientTarget(nitrogen_element,organ_list(i),stoich_max) + deficit_n(i) = max(0._r8,this%GetDeficit(nitrogen_element,organ_list(i),target_n)) + + + ! Update the nitrogen deficits (which are based off of carbon actual..) + ! Note that the nitrogen target is tied to the stoichiometry of thegrowing pool only + target_p = this%GetNutrientTarget(phosphorus_element,organ_list(i),stoich_max) + deficit_p(i) = max(0._r8,this%GetDeficit(phosphorus_element,organ_list(i),target_p)) + + end do + + ! ----------------------------------------------------------------------------------- + ! Nutrient Fluxes proportionally to each pool (these should be fully actualized) + ! (this also removes from the gain pools) + ! ----------------------------------------------------------------------------------- + + ! Nitrogen + call ProportionalNutrAllocation(state_n(1:num_organs), & + deficit_n(1:num_organs), & + n_gain, nitrogen_element, all_organs) + + ! Phosphorus + call ProportionalNutrAllocation(state_p(1:num_organs), & + deficit_p(1:num_organs), & + p_gain, phosphorus_element, all_organs) + + + ! ----------------------------------------------------------------------------------- + ! If carbon is still available, lets cram some into storage overflow + ! We will do this last, because we wanted the non-overflow storage + ! value to draw minimum and optimal nutrient fluxes + ! ----------------------------------------------------------------------------------- + + if(c_gain>calloc_abs_error) then + + ! Update carbon based allometric targets + call bstore_allom(dbh,ipft,canopy_trim, store_c_target) + + ! Estimate the overflow + store_c_target = store_c_target * (1.0_r8 + store_overflow_frac) + + total_c_flux = min(c_gain,max(0.0, (store_c_target - state_c(store_id)%ptr))) + + ! Transfer excess carbon into storage overflow + state_c(store_id)%ptr = state_c(store_id)%ptr + total_c_flux + c_gain = c_gain - total_c_flux + + + end if + + + + ! Figure out what to do with excess carbon and nutrients + ! 1) excude through roots cap at 0 to flush out imprecisions + ! ----------------------------------------------------------------------------------- + + c_efflux = max(0.0_r8,c_gain) + n_efflux = max(0.0_r8,n_gain) + p_efflux = max(0.0_r8,p_gain) + + + c_gain = 0.0_r8 + n_gain = 0.0_r8 + p_gain = 0.0_r8 + + return + end subroutine CNPAllocateRemainder + + ! ===================================================================================== + + subroutine FastPRTAllometricCNP(this) + + implicit none + class(cnp_allom_prt_vartypes) :: this ! this class + + ! This routine does nothing, because + ! we currently don't have any fast-timestep processes + ! Think of this as a stub. + + return + end subroutine FastPRTAllometricCNP + + ! ===================================================================================== + + + + ! ===================================================================================== + + function GetDeficit(this,element_id,organ_id,target_m) result(deficit_m) + + class(cnp_allom_prt_vartypes) :: this + integer,intent(in) :: element_id + integer,intent(in) :: organ_id + real(r8),intent(in) :: target_m + + integer :: i_var + real(r8) :: deficit_m + + i_var = prt_global%sp_organ_map(organ_id,element_id) + + if(element_id.eq.carbon12_element) then + deficit_m = target_m - sum(this%variables(i_var)%val(:),dim=1) + else + deficit_m = target_m - this%variables(i_var)%val(1) + end if + + return + end function GetDeficit + + + ! ===================================================================================== + + function GetNutrientTarget(this,element_id,organ_id,stoich_mode) result(target_m) + + class(cnp_allom_prt_vartypes) :: this + integer, intent(in) :: element_id + integer, intent(in) :: organ_id + integer, intent(in) :: stoich_mode + real(r8) :: target_m ! Target amount of nutrient for this organ [kg] + + real(r8) :: target_c + real(r8),pointer :: dbh + real(r8) :: canopy_trim + integer :: ipft + integer :: i_cvar + + dbh => this%bc_inout(acnp_bc_inout_id_dbh)%rval + canopy_trim = this%bc_in(acnp_bc_in_id_ctrim)%rval + ipft = this%bc_in(acnp_bc_in_id_pft)%ival + i_cvar = prt_global%sp_organ_map(organ_id,carbon12_element) + + ! Storage of nutrients are assumed to have different compartments than + ! for carbon, and thus their targets are not associated with the current amount of carbon + ! but the plant's carrying capacity + + if(organ_id == store_organ) then + call bstore_allom(dbh,ipft,canopy_trim, target_c) + else + ! In all cases, we want the first index because for non-leaves + ! that is the only index, and for leaves, that is the newly + ! growing index. + target_c = this%variables(i_cvar)%val(1) + end if + + if( stoich_mode == stoich_growth_min ) then + if( element_id == nitrogen_element) then + target_m = target_c * prt_params%nitr_stoich_p1(ipft,organ_id) + else + target_m = target_c * prt_params%phos_stoich_p1(ipft,organ_id) + end if + elseif( stoich_mode == stoich_max ) then + if( element_id == nitrogen_element) then + target_m = target_c * prt_params%nitr_stoich_p2(ipft,organ_id) + else + target_m = target_c * prt_params%phos_stoich_p2(ipft,organ_id) + end if + else + write(fates_log(),*) 'invalid stoichiometry mode specified while getting' + write(fates_log(),*) 'nutrient targets' + write(fates_log(),*) 'stoich_mode: ',stoich_mode + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + return + end function GetNutrientTarget + + ! ===================================================================================== + + subroutine ProportionalNutrAllocation(state_m, deficit_m, gain_m, element_id, list) + + ! ----------------------------------------------------------------------------------- + ! This routine allocates nutrients to a set of organs based on proportional + ! need. It is assumed that the input arrays are not sparse, and the fluxes + ! are based purely off of there deficit from some ideal state. + ! Note: this may or may not be called inside some preferential organ filter. + ! ----------------------------------------------------------------------------------- + + type(parray_type) :: state_m(:) ! Current mass of nutrient + ! of arbitrary species + ! over some arbitrary set of organs + real(r8),intent(inout) :: deficit_m(:) ! Nutrient mass deficit of species + ! over set of organs + integer, intent(in) :: list(:)! List of indices if sparse + real(r8),intent(inout) :: gain_m ! Total nutrient mass gain to + ! work with + integer,intent(in) :: element_id ! Element global index (for debugging) + + ! locals + integer :: num_organs + integer :: i,ii + real(r8) :: flux + real(r8) :: sum_deficit + real(r8) :: sum_flux + + num_organs = size(list,dim=1) + + sum_deficit = 0._r8 + do ii = 1, num_organs + i = list(ii) + sum_deficit = sum_deficit + max(0._r8,deficit_m(i)) + end do + + if (sum_deficit>nearzero) then + + sum_flux = min(gain_m, sum_deficit) + + do ii = 1, num_organs + i = list(ii) + + flux = sum_flux * max(0._r8,deficit_m(i))/sum_deficit + state_m(i)%ptr = state_m(i)%ptr + flux + deficit_m(i) = deficit_m(i) - flux + gain_m = gain_m - flux + + end do + + end if + + if(debug) then + if(gain_m < -calloc_abs_error) then + write(fates_log(),*) 'Somehow we have negative nutrient gain' + write(fates_log(),*) 'during proportional allocation' + write(fates_log(),*) 'gain: ',gain_m,'element: ',element_id + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + return + end subroutine ProportionalNutrAllocation + + ! ===================================================================================== + + + subroutine NAndPToMatchC(this,c_gain_org,dc_dd,ipft,organ_id,n_match,p_match) + + class(cnp_allom_prt_vartypes) :: this ! + real(r8),intent(in) :: c_gain_org ! Fraction of C sent to this organ + ! (does not include resp tax) + real(r8),intent(in) :: dc_dd ! derivative of the target value + integer, intent(in) :: ipft ! pft index + integer, intent(in) :: organ_id ! global organ index + real(r8), intent(inout) :: n_match ! N needed to match C growth + real(r8), intent(inout) :: p_match ! P needed to match C growth + + integer :: c_var_id ! Data array index of the carbon state variable + integer :: np_var_id ! Data array index of the N and P states + real(r8) :: grow_c ! Amount of C that would go into the organs tissue + real(r8) :: c0,d0 ! Variables to save the original C and dbh states + real(r8) :: np_target ! The target amount of N or P at the future C/DBH + + + ! All states are drawn from index 1, which is the growing index + ! for leaves, and the only index of non-leaves. Remember, if + ! this routine is being called, the initial amount of carbon + ! is the on-allometry value. + + c_var_id = prt_global%sp_organ_map(organ_id,carbon12_element) + + ! Save the current carbon and dbh state (we need dbh also + ! because nutient targets may not queue off of current mass, + ! but off of stature) + + c0 = this%variables(c_var_id)%val(1) + d0 = this%bc_inout(acnp_bc_inout_id_dbh)%rval + + ! Given the desired growth, imagine what the future C and dbh states are + this%variables(c_var_id)%val(1) = this%variables(c_var_id)%val(1)+c_gain_org + + ! Reproductive tissues may not have an allometry curve, their + ! target will be based off of actual C anyway + if(dc_dd>nearzero) then + this%bc_inout(acnp_bc_inout_id_dbh)%rval = & + this%bc_inout(acnp_bc_inout_id_dbh)%rval + c_gain_org/dc_dd + end if + + ! Calculate the nitrogen target at this future + np_var_id = prt_global%sp_organ_map(organ_id,nitrogen_element) + np_target = this%GetNutrientTarget(nitrogen_element,organ_id,stoich_growth_min) + + + ! Determine N needed to get match predicted C + n_match = n_match + max(0._r8, np_target - this%variables(np_var_id)%val(1)) + + + + ! Calculate the phosphorus target at this future + np_var_id = prt_global%sp_organ_map(organ_id,phosphorus_element) + np_target = this%GetNutrientTarget(phosphorus_element,organ_id,stoich_growth_min) + + + ! Determine P needed to get match predicted C + p_match = p_match + max(0._r8, np_target - this%variables(np_var_id)%val(1)) + + + ! Return out predictions back to their initial states + ! Save the current carbon and dbh state + this%variables(c_var_id)%val(1) = c0 + this%bc_inout(acnp_bc_inout_id_dbh)%rval = d0 + + + return + end subroutine NAndPToMatchC + + + + + ! ===================================================================================== + + subroutine GrowEquivC(this,carbon_gain,nitrogen_gain,phosphorus_gain, & + alloc_frac,ipft,organ_id,& + grow_c_from_c,grow_c_from_n,grow_c_from_p) + + ! ----------------------------------------------------------------------------------- + ! This subroutine calculates how much growth to expect in the specified organ + ! in terms of equivalent carbon, for each of C, N and P. + ! Total carbon allocated is roughly a function of how much carbon is available, + ! and the growth respiration tax. + ! Equivalent carbon allocated for each nutrient, is roughly the amount of + ! nutrient available, divided through by its stoichiometry, and also incremented + ! by any extra nutrient that may be in the tissues because of flexible stoich. + ! ----------------------------------------------------------------------------------- + + ! Arguments + class(cnp_allom_prt_vartypes) :: this ! + real(r8),intent(in) :: carbon_gain ! Total carbon available for allocation + real(r8),intent(in) :: nitrogen_gain ! Total N available for allocation + real(r8),intent(in) :: phosphorus_gain ! Total P available for allocation + real(r8),intent(in) :: alloc_frac ! + + integer,intent(in) :: ipft + integer,intent(in) :: organ_id + real(r8),intent(inout) :: grow_c_from_c + real(r8),intent(inout) :: grow_c_from_n + real(r8),intent(inout) :: grow_c_from_p + + ! Locals + real(r8) :: grow_c + real(r8) :: c_from_n_headstart + real(r8) :: c_from_n_gain + real(r8) :: c_from_p_headstart + real(r8) :: c_from_p_gain + integer :: c_var_id + integer :: n_var_id + integer :: p_var_id + real(r8) :: c_state + real(r8) :: n_target + real(r8) :: p_target + + ! Calculate gains from carbon + ! ----------------------------------------------------------------------------------- + grow_c = carbon_gain*alloc_frac + + grow_c_from_c = grow_c_from_c + grow_c + + c_var_id = prt_global%sp_organ_map(organ_id,carbon12_element) + + ! Calculate gains from Nitrogen + ! ----------------------------------------------------------------------------------- + + if(prt_params%nitr_stoich_p1(ipft,organ_id)>nearzero)then + + ! The amount of C we could match with N in the aquisition pool + c_from_n_gain = nitrogen_gain * alloc_frac / prt_params%nitr_stoich_p1(ipft,organ_id) + + ! It is possible that the nutrient pool of interest is already above the minimum + ! requirement. In this case, we add that into the amount that the equivalent + ! carbon for that nutrient can get. Its like giving it a head start. + + n_var_id = prt_global%sp_organ_map(organ_id,nitrogen_element) + n_target = this%GetNutrientTarget(nitrogen_element,organ_id,stoich_growth_min) + + c_from_n_headstart = max(0.0_r8, sum(this%variables(n_var_id)%val(:),dim=1) - n_target ) / & + prt_params%nitr_stoich_p1(ipft,organ_id) + + + ! Increment the amount of C that we could match with N, as the minimum + ! of what C could do itself, and what N could do. We need this minimum + ! because some pools may have excess, but those excesses cannot travel between + ! pools and contribute to the total allocation + grow_c_from_n = grow_c_from_n + min(grow_c,c_from_n_gain+c_from_n_headstart) + + + + end if + + ! Calculate gains from phosphorus + ! ----------------------------------------------------------------------------------- + + if(prt_params%phos_stoich_p1(ipft,organ_id)>nearzero) then + + + c_from_p_gain = phosphorus_gain * alloc_frac / prt_params%phos_stoich_p1(ipft,organ_id) + + ! It is possible that the nutrient pool of interest is already above the minimum + ! requirement. In this case, we add that into the amount that the equivalent + ! carbon for that nutrient can get. Its like giving it a head start. + + p_var_id = prt_global%sp_organ_map(organ_id,phosphorus_element) + p_target = this%GetNutrientTarget(phosphorus_element,organ_id,stoich_growth_min) + + c_from_p_headstart = max(0.0_r8,sum(this%variables(p_var_id)%val(:),dim=1) - p_target ) / & + prt_params%phos_stoich_p1(ipft,organ_id) + + ! Increment the amount of C that we could match with P, as the minimum + ! of what C could do itself, and what P could do. We need this minimum + ! because some pools may have excess, but those excesses cannot travel between + ! pools and contribute to the total allocation + grow_c_from_p = grow_c_from_p + min(grow_c,c_from_p_gain+c_from_p_headstart) + + + end if + + return + end subroutine GrowEquivC + + + ! ===================================================================================== + + function AllomCNPGrowthDeriv(l_state_array,l_state_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 off of allometry. + ! + ! Important Note: While this routine is carbon-only, the total carbon balance + ! that governs how much each pool is integrated, was likely limited by nutrient + ! availability. + ! + ! --------------------------------------------------------------------------------- + + ! Arguments + real(r8),intent(in), dimension(:) :: l_state_array ! Vector of carbon pools + ! dbh,leaf,root,sap,store,dead + logical,intent(in), dimension(:) :: l_state_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 + real(r8),dimension(lbound(l_state_array,dim=1):ubound(l_state_array,dim=1)) :: dCdx + + ! locals + integer :: ipft ! PFT index + real(r8) :: canopy_trim ! Canopy trimming function (boundary condition [0-1] + real(r8) :: leaf_c_target ! target leaf biomass, dummy var (kgC) + real(r8) :: fnrt_c_target ! target fine-root biomass, dummy var (kgC) + real(r8) :: sapw_c_target ! target sapwood biomass, dummy var (kgC) + real(r8) :: agw_c_target ! target aboveground wood, dummy var (kgC) + real(r8) :: bgw_c_target ! target belowground wood, dummy var (kgC) + real(r8) :: store_c_target ! target storage, dummy var (kgC) + real(r8) :: struct_c_target ! target structural biomas, dummy var (kgC) + real(r8) :: sapw_area + real(r8) :: leaf_dcdd_target ! target leaf biomass derivative wrt d, (kgC/cm) + real(r8) :: fnrt_dcdd_target ! target fine-root biomass derivative wrt d, (kgC/cm) + real(r8) :: sapw_dcdd_target ! target sapwood biomass derivative wrt d, (kgC/cm) + real(r8) :: agw_dcdd_target ! target AG wood biomass derivative wrt d, (kgC/cm) + real(r8) :: bgw_dcdd_target ! target BG wood biomass derivative wrt d, (kgC/cm) + real(r8) :: store_dcdd_target ! target storage biomass derivative wrt d, (kgC/cm) + real(r8) :: struct_dcdd_target ! target structural biomass derivative wrt d, (kgC/cm) + real(r8) :: total_dcdd_target ! target total (not reproductive) biomass derivative wrt d, (kgC/cm) + real(r8) :: repro_fraction ! fraction of carbon balance directed towards reproduction (kgC/kgC) + real(r8) :: total_dcostdd ! carbon cost for non-reproductive pools per unit increment of dbh + + + associate( dbh => l_state_array(dbh_id), & + leaf_c => l_state_array(leaf_id), & + fnrt_c => l_state_array(fnrt_id), & + sapw_c => l_state_array(sapw_id), & + store_c => l_state_array(store_id), & + struct_c => l_state_array(struct_id), & + repro_c => l_state_array(repro_id), & + mask_dbh => l_state_mask(dbh_id), & + mask_leaf => l_state_mask(leaf_id), & + mask_fnrt => l_state_mask(fnrt_id), & + mask_sapw => l_state_mask(sapw_id), & + mask_store => l_state_mask(store_id), & + mask_struct => l_state_mask(struct_id), & + mask_repro => l_state_mask(repro_id) ) + + + canopy_trim = intgr_params(acnp_bc_in_id_ctrim) + ipft = int(intgr_params(acnp_bc_in_id_pft)) + + call bleaf(dbh,ipft,canopy_trim,leaf_c_target,leaf_dcdd_target) + call bfineroot(dbh,ipft,canopy_trim,fnrt_c_target,fnrt_dcdd_target) + call bsap_allom(dbh,ipft,canopy_trim,sapw_area,sapw_c_target,sapw_dcdd_target) + call bagw_allom(dbh,ipft,agw_c_target,agw_dcdd_target) + call bbgw_allom(dbh,ipft,bgw_c_target,bgw_dcdd_target) + call bdead_allom(agw_c_target,bgw_c_target, sapw_c_target, ipft, struct_c_target, & + agw_dcdd_target, bgw_dcdd_target, sapw_dcdd_target, struct_dcdd_target) + call bstore_allom(dbh,ipft,canopy_trim,store_c_target,store_dcdd_target) + + if (mask_repro) then + ! fraction of carbon going towards reproduction + if (dbh <= prt_params%dbh_repro_threshold(ipft)) then + repro_fraction = prt_params%seed_alloc(ipft) + else + repro_fraction = prt_params%seed_alloc(ipft) + prt_params%seed_alloc_mature(ipft) + end if + else + repro_fraction = 0._r8 + end if + + total_dcostdd = 0._r8 + if (mask_struct) then + total_dcostdd = total_dcostdd + struct_dcdd_target + end if + if (mask_leaf) then + total_dcostdd = total_dcostdd + leaf_dcdd_target + end if + if (mask_fnrt) then + total_dcostdd = total_dcostdd + fnrt_dcdd_target + end if + if (mask_sapw) then + total_dcostdd = total_dcostdd + sapw_dcdd_target + end if + if (mask_store) then + total_dcostdd = total_dcostdd + store_dcdd_target + end if + + dCdx(:) = 0.0_r8 + + ! 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(total_dcostdd > nearzero) then + + if (mask_struct) then + dCdx(struct_id) = struct_dcdd_target/total_dcostdd * (1.0_r8 - repro_fraction) + end if + if (mask_leaf) then + dCdx(leaf_id) = leaf_dcdd_target/total_dcostdd * (1.0_r8 - repro_fraction) + end if + if (mask_fnrt) then + dCdx(fnrt_id) = fnrt_dcdd_target/total_dcostdd * (1.0_r8 - repro_fraction) + end if + if (mask_sapw) then + dCdx(sapw_id) = sapw_dcdd_target/total_dcostdd * (1.0_r8 - repro_fraction) + end if + if (mask_store) then + dCdx(store_id) = store_dcdd_target/total_dcostdd * (1.0_r8 - repro_fraction) + end if + if (mask_repro) then + dCdx(repro_id) = repro_fraction + end if + + if( abs(sum(dCdx,dim=1)-1.0_r8)>rsnbl_math_prec ) then + write(fates_log(),*) 'dCdx should sum to 1' + write(fates_log(),*) 'dCdx: ',dCdx + write(fates_log(),*) 'repro fraction: ',repro_fraction + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + dCdx(dbh_id) = (1.0_r8/total_dcostdd)*(1.0_r8 - repro_fraction) + + else + + if(repro_fractioncalloc_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 + + +end module PRTAllometricCNPMod diff --git a/parteh/PRTAllometricCarbonMod.F90 b/parteh/PRTAllometricCarbonMod.F90 index 2ab3877d03..5bdf624502 100644 --- a/parteh/PRTAllometricCarbonMod.F90 +++ b/parteh/PRTAllometricCarbonMod.F90 @@ -41,14 +41,15 @@ module PRTAllometricCarbonMod use shr_log_mod , only : errMsg => shr_log_errMsg use FatesConstantsMod , only : r8 => fates_r8 use FatesConstantsMod , only : i4 => fates_int + use FatesConstantsMod , only : sec_per_day 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 use FatesConstantsMod , only : years_per_day + use PRTParametersMod , only : prt_params implicit none private @@ -199,7 +200,7 @@ subroutine InitPRTGlobalAllometricCarbon() ! notably the size of the leaf-longevity parameter's second dimension. ! This is the same value in FatesInterfaceMod.F90 - nleafage = size(EDPftvarcon_inst%leaf_long,dim=2) + nleafage = size(prt_params%leaf_long,dim=2) if(nleafage>max_nleafage) then write(fates_log(),*) 'The allometric carbon PARTEH hypothesis' @@ -406,40 +407,31 @@ subroutine DailyPRTAllometricCarbon(this) 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) + + + nleafage = prt_global%state_descriptor(leaf_c_id)%num_pos ! Number of leaf age class + + ! ----------------------------------------------------------------------------------- + ! Call the routine that advances leaves in age. + ! This will move a portion of the leaf mass in each + ! age bin, to the next bin. This will not handle movement + ! of mass from the oldest bin into the litter pool, that is something else. + ! ----------------------------------------------------------------------------------- + + call this%AgeLeaves(ipft,sec_per_day) + ! ----------------------------------------------------------------------------------- ! 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. ! ----------------------------------------------------------------------------------- - - nleafage = prt_global%state_descriptor(leaf_c_id)%num_pos ! Number of leaf age class - + leaf_c0(1:nleafage) = leaf_c(1:nleafage) ! Set initial leaf carbon fnrt_c0 = fnrt_c ! Set initial fine-root carbon sapw_c0 = sapw_c ! Set initial sapwood carbon store_c0 = store_c ! Set initial storage carbon repro_c0 = repro_c ! Set initial reproductive carbon struct_c0 = struct_c ! Set initial structural carbon - - - ! ----------------------------------------------------------------------------------- - ! If we have more than one leaf age classification, allow - ! some leaf biomass to transition to the older classes. NOTE! This is not handling - ! losses due to turnover (ie. flux from the oldest senescing class). This is only - ! internal. - ! (rgk 12-15-2018: Have Chonggang confirm that aging should not be restricted - ! to evergreens) - ! ----------------------------------------------------------------------------------- - - if(nleafage>1) then - do i_age = 1,nleafage-1 - if (EDPftvarcon_inst%leaf_long(ipft,i_age)>nearzero) then - leaf_age_flux = leaf_c0(i_age) * years_per_day / EDPftvarcon_inst%leaf_long(ipft,i_age) - leaf_c(i_age) = leaf_c(i_age) - leaf_age_flux - leaf_c(i_age+1) = leaf_c(i_age+1) + leaf_age_flux - end if - end do - end if ! ----------------------------------------------------------------------------------- @@ -478,15 +470,15 @@ subroutine DailyPRTAllometricCarbon(this) ! or forcefully pay from storage. ! ----------------------------------------------------------------------------------- - if( EDPftvarcon_inst%evergreen(ipft) ==1 ) then + if( prt_params%evergreen(ipft) ==1 ) then leaf_c_demand = max(0.0_r8, & - EDPftvarcon_inst%leaf_stor_priority(ipft)*sum(this%variables(leaf_c_id)%turnover(:))) + prt_params%leaf_stor_priority(ipft)*sum(this%variables(leaf_c_id)%turnover(:))) else leaf_c_demand = 0.0_r8 end if fnrt_c_demand = max(0.0_r8, & - EDPftvarcon_inst%leaf_stor_priority(ipft)*this%variables(fnrt_c_id)%turnover(icd)) + prt_params%leaf_stor_priority(ipft)*this%variables(fnrt_c_id)%turnover(icd)) total_c_demand = leaf_c_demand + fnrt_c_demand @@ -641,7 +633,7 @@ subroutine DailyPRTAllometricCarbon(this) ! left to allocate, and thus it must be on allometry when its not. ! ----------------------------------------------------------------------------------- - if( carbon_balance > calloc_abs_error ) then + if_stature_growth: if( carbon_balance > calloc_abs_error ) then ! This routine checks that actual carbon is not below that targets. It does ! allow actual pools to be above the target, and in these cases, it sends @@ -719,7 +711,7 @@ subroutine DailyPRTAllometricCarbon(this) this%ode_opt_step = totalC end if - do while( ierr .ne. 0 ) + do_solve_check: do while( ierr .ne. 0 ) deltaC = min(totalC,this%ode_opt_step) if(ODESolve == 1) then @@ -785,7 +777,7 @@ subroutine DailyPRTAllometricCarbon(this) ! At that point, update the actual states ! -------------------------------------------------------------------------------- - if( (totalC < calloc_abs_error) .and. (step_pass) )then + if_step_pass: if( (totalC < calloc_abs_error) .and. (step_pass) )then ierr = 0 leaf_c_flux = c_pool(leaf_c_id) - sum(leaf_c(1:nleafage)) @@ -827,11 +819,6 @@ subroutine DailyPRTAllometricCarbon(this) 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' @@ -840,18 +827,18 @@ subroutine DailyPRTAllometricCarbon(this) call endrun(msg=errMsg(sourcefile, __LINE__)) end if - end if - end do - end if + end if if_step_pass - ! Track the net allocations and transport from this routine + end do do_solve_check + + end if if_stature_growth - do i_age = 1,nleafage - this%variables(leaf_c_id)%net_alloc(i_age) = & - this%variables(leaf_c_id)%net_alloc(i_age) + & - (leaf_c(i_age) - leaf_c0(i_age)) - end do + ! Track the net allocations and transport from this routine + ! (the AgeLeaves() routine handled tracking allocation through aging) + this%variables(leaf_c_id)%net_alloc(icd) = & + this%variables(leaf_c_id)%net_alloc(icd) + (leaf_c(icd) - leaf_c0(icd)) + this%variables(fnrt_c_id)%net_alloc(icd) = & this%variables(fnrt_c_id)%net_alloc(icd) + (fnrt_c - fnrt_c0) @@ -953,10 +940,10 @@ function AllomCGrowthDeriv(c_pools,c_mask,cbalance,intgr_params) result(dCdx) 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) + if (dbh <= prt_params%dbh_repro_threshold(ipft)) then ! cap on leaf biomass + repro_fraction = prt_params%seed_alloc(ipft) else - repro_fraction = EDPftvarcon_inst%seed_alloc(ipft) + EDPftvarcon_inst%seed_alloc_mature(ipft) + repro_fraction = prt_params%seed_alloc(ipft) + prt_params%seed_alloc_mature(ipft) end if dCdx = 0.0_r8 diff --git a/parteh/PRTGenericMod.F90 b/parteh/PRTGenericMod.F90 index f60c4f94fe..9c6f9db2e2 100644 --- a/parteh/PRTGenericMod.F90 +++ b/parteh/PRTGenericMod.F90 @@ -25,10 +25,12 @@ module PRTGenericMod use FatesConstantsMod, only : i4 => fates_int use FatesConstantsMod, only : nearzero use FatesConstantsMod, only : calloc_abs_error + use FatesConstantsMod, only : years_per_day + use FatesConstantsMod, only : days_per_sec use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log use shr_log_mod , only : errMsg => shr_log_errMsg - + use PRTParametersMod , only : prt_params implicit none private ! Modules are private by default @@ -139,6 +141,12 @@ module PRTGenericMod integer, parameter, dimension(3), public :: carbon_elements_list = & [carbon12_element, carbon13_element, carbon14_element] + + + ! This is the maximum number of leaf age pools allowed on each plant + ! (used for allocating scratch space) + integer, parameter, public :: max_nleafage = 4 + ! ------------------------------------------------------------------------------------- ! @@ -167,7 +175,7 @@ module PRTGenericMod type, public :: prt_vartype - real(r8),allocatable :: val(:) ! Instantaneous state variable [kg] + real(r8),pointer :: 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] @@ -253,10 +261,27 @@ module PRTGenericMod procedure, non_overridable :: DeallocatePRTVartypes procedure, non_overridable :: WeightedFusePRTVartypes procedure, non_overridable :: CopyPRTVartypes + + procedure :: AgeLeaves ! This routine may be used generically + ! but also leaving the door open for over-rides + + + end type prt_vartypes + + ! Global identifiers for which elements we are using (apply mostly to litter) + integer, public :: num_elements ! This is the number of elements in this simulation + ! e.g. (C,N,P,K, etc) + integer, allocatable, public :: element_list(:) ! This vector holds the list of global element identifiers + ! examples are carbon12_element + ! nitrogen_element, etc. + integer, public :: element_pos(num_organ_types) ! This is the reverse lookup + ! for element types. Pick an element + ! global index, and it gives you + ! the position in the element_list ! ------------------------------------------------------------------------------------- ! This next section contains the objects that describe the mapping for each specific @@ -1294,5 +1319,71 @@ end subroutine SetState ! ==================================================================================== + subroutine AgeLeaves(this,ipft,period_sec) + + ! ----------------------------------------------------------------------------------- + ! If we have more than one leaf age classification, allow + ! some leaf biomass to transition to the older classes. + ! It is assumed this routine is called once per day. + ! Note that there is NO turnover or loss of mass on the plant in this routine. + ! We are simply moving portions of leaves from a young bin to the next older, but + ! we are not moving any mass out of the last (oldest) bin. + ! ----------------------------------------------------------------------------------- + + class(prt_vartypes) :: this + integer,intent(in) :: ipft + real(r8),intent(in) :: period_sec ! Time period over which this routine + ! is called [seconds] daily=86400 + integer :: nleafage + integer :: i_age + integer :: i_var + integer :: el + integer :: element_id + real(r8) :: leaf_age_flux_frac + real(r8),dimension(max_nleafage) :: leaf_m0 + + + do el = 1, num_elements + + element_id = element_list(el) + + ! Global position of leaf variable + i_var = prt_global%sp_organ_map(leaf_organ,element_id) + + ! Size of the leaf carbon variable (number of age bins) + nleafage = prt_global%state_descriptor(i_var)%num_pos ! Number of leaf age class + + associate(leaf_m => this%variables(i_var)%val(:)) + + leaf_m0(1:nleafage) = leaf_m(1:nleafage) + + if(nleafage>1) then + do i_age = 1,nleafage-1 + if (prt_params%leaf_long(ipft,i_age)>nearzero) then + + ! Units: [-] = [sec] * [day/sec] * [years/day] * [1/years] + leaf_age_flux_frac = period_sec * days_per_sec * years_per_day / prt_params%leaf_long(ipft,i_age) + + leaf_m(i_age) = leaf_m(i_age) - leaf_m0(i_age) * leaf_age_flux_frac + leaf_m(i_age+1) = leaf_m(i_age+1) + leaf_m0(i_age) * leaf_age_flux_frac + + end if + end do + end if + + + ! Update the diagnostic on daily rate of change + do i_age = 1,nleafage + this%variables(i_var)%net_alloc(i_age) = & + this%variables(i_var)%net_alloc(i_age) + & + (leaf_m(i_age) - leaf_m0(i_age)) + end do + + + end associate + end do + + end subroutine AgeLeaves + end module PRTGenericMod diff --git a/parteh/PRTLossFluxesMod.F90 b/parteh/PRTLossFluxesMod.F90 index 49125304f3..526613b37d 100644 --- a/parteh/PRTLossFluxesMod.F90 +++ b/parteh/PRTLossFluxesMod.F90 @@ -1,6 +1,6 @@ module PRTLossFluxesMod - use EDPftvarcon, only : EDPftvarcon_inst + use PRTGenericMod, only : prt_vartypes use PRTGenericMod, only : leaf_organ use PRTGenericMod, only : fnrt_organ @@ -27,8 +27,9 @@ module PRTLossFluxesMod use FatesGlobals , only : endrun => fates_endrun use FatesGlobals , only : fates_log use shr_log_mod , only : errMsg => shr_log_errMsg - + use PRTParametersMod , only : prt_params + implicit none private @@ -55,7 +56,7 @@ module PRTLossFluxesMod ! 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 + ! prt_params%turnover_retrans_mode ! ------------------------------------------------------------------------------------- public :: PRTDeciduousTurnover @@ -108,7 +109,7 @@ subroutine PRTPhenologyFlush(prt, ipft, organ_id, c_store_transfer_frac) ! those parameters and clauses need to be added !if(organ_id .ne. leaf_organ) then - if(organ_id .ne. leaf_organ .AND. EDPftvarcon_inst%woody(ipft) == itrue) then + if(organ_id .ne. leaf_organ .AND. prt_params%woody(ipft) == itrue) 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 @@ -221,9 +222,9 @@ subroutine PRTPhenologyFlush(prt, ipft, organ_id, c_store_transfer_frac) ! Calculate the stoichiometry with C for this element if( element_id == nitrogen_element ) then - target_stoich = EDPftvarcon_inst%prt_nitr_stoich_p1(ipft,organ_id) + target_stoich = prt_params%nitr_stoich_p1(ipft,organ_id) else if( element_id == phosphorus_element ) then - target_stoich = EDPftvarcon_inst%prt_phos_stoich_p1(ipft,organ_id) + target_stoich = prt_params%phos_stoich_p1(ipft,organ_id) else write(fates_log(),*) ' Trying to calculate nutrient flushing target' write(fates_log(),*) ' for element that DNE' @@ -366,12 +367,6 @@ subroutine PRTReproRelease(prt, organ_id, element_id, mass_fraction, mass_out) 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 @@ -421,7 +416,7 @@ subroutine PRTDeciduousTurnover(prt,ipft,organ_id,mass_fraction) ! those parameters and clauses need to be added !if(organ_id .ne. leaf_organ) then - if(organ_id .ne. leaf_organ .AND. EDPftvarcon_inst%woody(ipft) == itrue) then + if(organ_id .ne. leaf_organ .AND. prt_params%woody(ipft) == itrue) 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 @@ -430,12 +425,12 @@ subroutine PRTDeciduousTurnover(prt,ipft,organ_id,mass_fraction) end if - if ( int(EDPftvarcon_inst%turnover_retrans_mode(ipft)) == 1 ) then + if ( int(prt_params%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(),*) 'turnover_retrans_mode= ',prt_params%turnover_retrans_mode(ipft) write(fates_log(),*) 'pft = ',ipft call endrun(msg=errMsg(__FILE__, __LINE__)) end if @@ -482,7 +477,7 @@ subroutine DeciduousTurnoverSimpleRetranslocation(prt,ipft,organ_id,mass_fractio (organ_id == struct_organ) .or. & (organ_id == sapw_organ)) then - if (EDPftvarcon_inst%woody(ipft) == itrue) then + if (prt_params%woody(ipft) == itrue) then write(fates_log(),*) 'Deciduous turnover (leaf drop, etc)' write(fates_log(),*) ' was specified for an unexpected organ' write(fates_log(),*) ' organ: ',organ_id @@ -493,7 +488,7 @@ subroutine DeciduousTurnoverSimpleRetranslocation(prt,ipft,organ_id,mass_fractio end if if(prt_global%hyp_id .le. 2) then - i_store_pos = 1 ! hypothesis 1/2 only have + i_store_pos = 1 ! hypothesis 1&2 only have ! 1 storage pool else write(fates_log(),*) 'You picked a hypothesis that has not defined' @@ -512,11 +507,11 @@ subroutine DeciduousTurnoverSimpleRetranslocation(prt,ipft,organ_id,mass_fractio 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) + retrans = prt_params%turnover_carb_retrans(ipft,organ_id) else if( element_id == nitrogen_element ) then - retrans = EDPftvarcon_inst%turnover_nitr_retrans(ipft,organ_id) + retrans = prt_params%turnover_nitr_retrans(ipft,organ_id) else if( element_id == phosphorus_element ) then - retrans = EDPftvarcon_inst%turnover_phos_retrans(ipft,organ_id) + retrans = prt_params%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' @@ -580,12 +575,12 @@ subroutine PRTMaintTurnover(prt,ipft,is_drought) logical,intent(in) :: is_drought ! Is this plant/cohort operating in a drought ! stress context? - if ( int(EDPftvarcon_inst%turnover_retrans_mode(ipft)) == 1 ) then + if ( int(prt_params%turnover_retrans_mode(ipft)) == 1 ) then call MaintTurnoverSimpleRetranslocation(prt,ipft,is_drought) 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(),*) 'turnover_retrans_mode= ',prt_params%turnover_retrans_mode(ipft) write(fates_log(),*) 'pft = ',ipft call endrun(msg=errMsg(__FILE__, __LINE__)) end if @@ -630,13 +625,30 @@ subroutine MaintTurnoverSimpleRetranslocation(prt,ipft,is_drought) ! generate maintenance fluxes from the last ! senescing class; all other cases this ! is assumed to be 1. - - real(r8) :: turnover ! Actual turnover removed from each + integer :: store_var_id ! Variable id of the storage pool + integer :: i_store_pos ! Position index for storage + real(r8) :: turnover_mass ! Actual turnover removed from each ! pool [kg] - real(r8) :: retrans ! A temp for the actual re-translocated mass + real(r8) :: retrans_frac ! A temp for the retranslocated fraction + real(r8) :: retrans_mass ! The mass re-translocated [kg] ! A temp for the actual turnover removed from pool real(r8), dimension(num_organ_types) :: base_turnover + + + if(prt_global%hyp_id .le. 2) then + i_store_pos = 1 ! hypothesis 1&2 only have + ! 1 storage pool + else + write(fates_log(),*) 'You picked a hypothesis that has not defined' + write(fates_log(),*) ' how and where turnover re-absorption interacts' + write(fates_log(),*) ' with the storage pool. specifically, ' + write(fates_log(),*) ' if this hypothesis has multiple storage pools' + write(fates_log(),*) ' to pull carbon/resources from' + write(fates_log(),*) 'Exiting' + call endrun(msg=errMsg(__FILE__, __LINE__)) + end if + ! ----------------------------------------------------------------------------------- ! Calculate the turnover rates (maybe this should be done once in the parameter @@ -645,14 +657,14 @@ subroutine MaintTurnoverSimpleRetranslocation(prt,ipft,is_drought) base_turnover(:) = un_initialized - ! All plants can have branch turnover, if branchfall is nonz-ero, + ! All plants can have branch turnover, if branchfall is non-zero, ! which will reduce sapwood, structure and storage. ! ----------------------------------------------------------------------------------- - if ( EDPftvarcon_inst%branch_turnover(ipft) > nearzero ) then - base_turnover(sapw_organ) = years_per_day / EDPftvarcon_inst%branch_turnover(ipft) - base_turnover(struct_organ) = years_per_day / EDPftvarcon_inst%branch_turnover(ipft) - base_turnover(store_organ) = years_per_day / EDPftvarcon_inst%branch_turnover(ipft) + if ( prt_params%branch_long(ipft) > nearzero ) then + base_turnover(sapw_organ) = years_per_day / prt_params%branch_long(ipft) + base_turnover(struct_organ) = years_per_day / prt_params%branch_long(ipft) + base_turnover(store_organ) = years_per_day / prt_params%branch_long(ipft) else base_turnover(sapw_organ) = 0.0_r8 base_turnover(struct_organ) = 0.0_r8 @@ -662,8 +674,9 @@ subroutine MaintTurnoverSimpleRetranslocation(prt,ipft,is_drought) ! 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) = years_per_day / EDPftvarcon_inst%root_long(ipft) + + if ( prt_params%root_long(ipft) > nearzero ) then + base_turnover(fnrt_organ) = years_per_day / prt_params%root_long(ipft) else base_turnover(fnrt_organ) = 0.0_r8 end if @@ -671,21 +684,21 @@ subroutine MaintTurnoverSimpleRetranslocation(prt,ipft,is_drought) ! The last index of the leaf longevity array contains the turnover ! timescale for the senescent pool. - aclass_sen_id = size(EDPftvarcon_inst%leaf_long(ipft,:)) + aclass_sen_id = size(prt_params%leaf_long(ipft,:)) ! Only evergreens have maintenance turnover (must also change trimming logic ! if we want to change this) ! ------------------------------------------------------------------------------------- - if ( (EDPftvarcon_inst%leaf_long(ipft,aclass_sen_id) > nearzero ) .and. & - (EDPftvarcon_inst%evergreen(ipft) == itrue) ) then + if ( (prt_params%leaf_long(ipft,aclass_sen_id) > nearzero ) .and. & + int(prt_params%evergreen(ipft))==itrue ) then if(is_drought) then base_turnover(leaf_organ) = years_per_day / & - (EDPftvarcon_inst%leaf_long(ipft,aclass_sen_id) * & - EDPftvarcon_inst%senleaf_long_fdrought(ipft) ) + (prt_params%leaf_long(ipft,aclass_sen_id) * & + prt_params%senleaf_long_fdrought(ipft) ) else base_turnover(leaf_organ) = years_per_day / & - EDPftvarcon_inst%leaf_long(ipft,aclass_sen_id) + prt_params%leaf_long(ipft,aclass_sen_id) end if else base_turnover(leaf_organ) = 0.0_r8 @@ -699,11 +712,11 @@ subroutine MaintTurnoverSimpleRetranslocation(prt,ipft,is_drought) 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) + retrans_frac = prt_params%turnover_carb_retrans(ipft,organ_id) else if( element_id == nitrogen_element ) then - retrans = EDPftvarcon_inst%turnover_nitr_retrans(ipft,organ_id) + retrans_frac = prt_params%turnover_nitr_retrans(ipft,organ_id) else if( element_id == phosphorus_element ) then - retrans = EDPftvarcon_inst%turnover_phos_retrans(ipft,organ_id) + retrans_frac = prt_params%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' @@ -722,10 +735,10 @@ subroutine MaintTurnoverSimpleRetranslocation(prt,ipft,is_drought) end if ! Loop over all of the coordinate ids - if(retrans<0.0 .or. retrans>1.0) then + if(retrans_frac<0.0 .or. retrans_frac>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(),*) ' retranslocation fraction: ',retrans_frac write(fates_log(),*) 'Exiting' call endrun(msg=errMsg(__FILE__, __LINE__)) end if @@ -744,14 +757,36 @@ subroutine MaintTurnoverSimpleRetranslocation(prt,ipft,is_drought) ipos_1 = 1 end if + + store_var_id = prt_global%sp_organ_map(store_organ,element_id) + do i_pos = ipos_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 + turnover_mass = (1.0_r8 - retrans_frac) * base_turnover(organ_id) * prt%variables(i_var)%val(i_pos) + + ! Remove mass from turnover from the organ of interest + + prt%variables(i_var)%turnover(i_pos) = prt%variables(i_var)%turnover(i_pos) + turnover_mass + + prt%variables(i_var)%val(i_pos) = prt%variables(i_var)%val(i_pos) - turnover_mass + + ! If any mass is re-absorbed, send it to storage - prt%variables(i_var)%val(i_pos) = prt%variables(i_var)%val(i_pos) - turnover + retrans_mass = retrans_frac * base_turnover(organ_id) * prt%variables(i_var)%val(i_pos) + prt%variables(i_var)%net_alloc(i_pos) = & + prt%variables(i_var)%net_alloc(i_pos) - retrans_mass + + prt%variables(i_var)%val(i_pos) = prt%variables(i_var)%val(i_pos) - retrans_mass + + prt%variables(store_var_id)%net_alloc(i_store_pos) = & + prt%variables(store_var_id)%net_alloc(i_store_pos) + retrans_mass + + prt%variables(store_var_id)%val(i_store_pos) = & + prt%variables(store_var_id)%val(i_store_pos) + retrans_mass + + + end do end do diff --git a/parteh/PRTParametersMod.F90 b/parteh/PRTParametersMod.F90 new file mode 100644 index 0000000000..2acb706f8d --- /dev/null +++ b/parteh/PRTParametersMod.F90 @@ -0,0 +1,122 @@ +module PRTParametersMod + + + use FatesConstantsMod, only : r8 => fates_r8 + + ! This module only holds the parameter definitions for PARTEH and allometry. + ! This does not hold any of the code used for intiailizing and filling + ! that data, for that is model dependent (ie FATES may have a different + ! way than another TBM) + ! This code does perform checks on parameters. + + type,public :: prt_param_type + + ! The following three PFT classes + ! are mutually exclusive + real(r8), allocatable :: stress_decid(:) ! Is the plant stress deciduous? (1=yes, 0=no) + real(r8), allocatable :: season_decid(:) ! Is the plant seasonally deciduous (1=yes, 0=no) + real(r8), allocatable :: evergreen(:) ! Is the plant an evergreen (1=yes, 0=no) + + + ! Growth and Turnover Parameters + real(r8), allocatable :: senleaf_long_fdrought(:) ! Multiplication factor for leaf longevity of senescent + ! leaves during drought( 1.0 indicates no change) + real(r8), allocatable :: leaf_long(:,:) ! Leaf turnover time (longevity) (pft x age-class) + ! If there is >1 class, it is the longevity from + ! one class to the next [yr] + real(r8), allocatable :: root_long(:) ! root turnover time (longevity) (pft) [yr] + real(r8), allocatable :: branch_long(:) ! 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(:,:) ! phosphorus re-translocation fraction (pft x organ) + ! Parameters dimensioned by PFT and leaf age + + real(r8), allocatable :: grperc(:) ! Growth respiration per unit Carbon gained + ! One value for whole plant + ! ONLY parteh_mode == 1 [kg/kg] + ! real(r8), allocatable ::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 :: nitr_stoich_p1(:,:) ! Parameter 1 for nitrogen stoichiometry (pft x organ) + real(r8), allocatable :: nitr_stoich_p2(:,:) ! Parameter 2 for nitrogen stoichiometry (pft x organ) + real(r8), allocatable :: phos_stoich_p1(:,:) ! Parameter 1 for phosphorus stoichiometry (pft x organ) + real(r8), allocatable :: phos_stoich_p2(:,:) ! Parameter 2 for phosphorus stoichiometry (pft x organ) + real(r8), allocatable :: alloc_priority(:,:) ! Allocation priority for each organ (pft x organ) [integer 0-6] + real(r8), allocatable :: cushion(:) ! labile carbon storage target as multiple of leaf pool. + real(r8), allocatable :: leaf_stor_priority(:) ! leaf turnover vs labile carbon use prioritisation + ! (1 = lose leaves, 0 = use store). + real(r8), allocatable :: dbh_repro_threshold(:) ! diameter at which mature plants shift allocation + 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. + + + ! Allometry Parameters + ! -------------------------------------------------------------------------------------------- + + ! Root profile parameters. Note we have separate parameters for those that govern + ! hydraulics, and those that govern biomass (for decomposition and respiration) + + real(r8), allocatable :: fnrt_prof_mode(:) ! Fine root profile functional form + real(r8), allocatable :: fnrt_prof_a(:) ! Fine root profile scaling parameter A + real(r8), allocatable :: fnrt_prof_b(:) ! Fine root profile scaling parameter B + + real(r8), allocatable :: c2b(:) ! Carbon to biomass multiplier [kg/kgC] + real(r8), allocatable :: wood_density(:) ! wood density g cm^-3 ... + real(r8), allocatable :: woody(:) ! Does the plant have wood? (1=yes, 0=no) + + real(r8), allocatable :: slamax(:) ! Maximum specific leaf area of plant (at bottom) [m2/gC] + real(r8), allocatable :: slatop(:) ! Specific leaf area at canopy top [m2/gC] + real(r8), allocatable :: allom_sai_scaler(:) ! + real(r8), allocatable :: allom_dbh_maxheight(:) ! dbh at which height growth ceases + real(r8), allocatable :: allom_hmode(:) ! height allometry function type + real(r8), allocatable :: allom_lmode(:) ! maximum leaf allometry function type + real(r8), allocatable :: allom_fmode(:) ! maximum root allometry function type + real(r8), allocatable :: allom_amode(:) ! AGB allometry function type + real(r8), allocatable :: allom_cmode(:) ! Coarse root allometry function type + real(r8), allocatable :: allom_smode(:) ! sapwood allometry function type + real(r8), allocatable :: allom_stmode(:) ! storage allometry functional type + ! (HARD-CODED FOR TIME BEING, RGK 11-2017) + real(r8), allocatable :: allom_la_per_sa_int(:) ! Leaf area to sap area conversion, intercept + ! (sapwood area / leaf area) [cm2/m2] + real(r8), allocatable :: allom_la_per_sa_slp(:) ! Leaf area to sap area conversion, slope + ! (sapwood area / leaf area / diameter) [cm2/m2/cm] + real(r8), allocatable :: allom_l2fr(:) ! Fine root biomass per leaf biomass ratio [kgC/kgC] + real(r8), allocatable :: allom_agb_frac(:) ! Fraction of stem above ground [-] + real(r8), allocatable :: allom_d2h1(:) ! Parameter 1 for d2h allometry (intercept, or "c") + real(r8), allocatable :: allom_d2h2(:) ! Parameter 2 for d2h allometry (slope, or "m") + real(r8), allocatable :: allom_d2h3(:) ! Parameter 3 for d2h allometry (optional) + real(r8), allocatable :: allom_d2bl1(:) ! Parameter 1 for d2bl allometry (intercept) + real(r8), allocatable :: allom_d2bl2(:) ! Parameter 2 for d2bl allometry (slope) + real(r8), allocatable :: allom_d2bl3(:) ! Parameter 3 for d2bl allometry (optional) + real(r8), allocatable :: allom_blca_expnt_diff(:) ! Any difference in the exponent between the leaf + ! biomass and crown area scaling + real(r8), allocatable :: allom_d2ca_coefficient_max(:) ! upper (savanna) value for crown + ! area to dbh coefficient + real(r8), allocatable :: allom_d2ca_coefficient_min(:) ! lower (closed-canopy forest) value for crown + ! area to dbh coefficient + real(r8), allocatable :: allom_agb1(:) ! Parameter 1 for agb allometry + real(r8), allocatable :: allom_agb2(:) ! Parameter 2 for agb allometry + real(r8), allocatable :: allom_agb3(:) ! Parameter 3 for agb allometry + real(r8), allocatable :: allom_agb4(:) ! Parameter 3 for agb allometry + + + end type prt_param_type + + type(prt_param_type),public :: prt_params ! Instantiation of the parameter object + + + + + + +end module PRTParametersMod + diff --git a/parteh/PRTParamsFATESMod.F90 b/parteh/PRTParamsFATESMod.F90 new file mode 100644 index 0000000000..3b56c571ff --- /dev/null +++ b/parteh/PRTParamsFATESMod.F90 @@ -0,0 +1,1234 @@ +module PRTInitParamsFatesMod + + ! This is a FATES specific module for loading parameters through + ! the CLM/ELM module system. + + use FatesConstantsMod, only : r8 => fates_r8 + use FatesConstantsMod, only : itrue,ifalse + use FatesConstantsMod, only : nearzero + use FatesConstantsMod, only : years_per_day + use FatesInterfaceTypesMod, only : hlm_parteh_mode + use PRTParametersMod, only : prt_params + use PRTGenericMod, only : num_organ_types + use PRTGenericMod, only : leaf_organ, fnrt_organ, store_organ + use PRTGenericMod, only : sapw_organ, struct_organ, repro_organ + use FatesGlobals, only : endrun => fates_endrun + use FatesGlobals, only : fates_log + use shr_log_mod, only : errMsg => shr_log_errMsg + use PRTGenericMod, only : prt_cnp_flex_allom_hyp,prt_carbon_allom_hyp + + ! + ! !PUBLIC TYPES: + implicit none + save + private + + integer, parameter, public :: lower_bound_pft = 1 + integer, parameter, public :: lower_bound_general = 1 + + character(len=*), parameter, private :: sourcefile = & + __FILE__ + + ! !PUBLIC MEMBER FUNCTIONS: + public :: PRTRegisterParams + public :: PRTReceiveParams + public :: PRTCheckParams + !----------------------------------------------------------------------- + +contains + + !----------------------------------------------------------------------- + + subroutine PRTRegisterParams(fates_params) + + use FatesParametersInterface, only : fates_parameters_type + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + call PRTRegisterPFT(fates_params) + call PRTRegisterPFTOrgans(fates_params) + call PRTRegisterPFTLeafAge(fates_params) + call Register_PFT_nvariants(fates_params) + + end subroutine PRTRegisterParams + + !----------------------------------------------------------------------- + subroutine PRTReceiveParams(fates_params) + + use FatesParametersInterface, only : fates_parameters_type + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + call PRTReceivePFT(fates_params) + call PRTReceivePFTOrgans(fates_params) + call PRTReceivePFTLeafAge(fates_params) + call Receive_PFT_nvariants(fates_params) + + end subroutine PRTReceiveParams + + !----------------------------------------------------------------------- + subroutine PRTRegisterPFT(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + use FatesParametersInterface, only : dimension_name_pft, dimension_shape_1d + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length), parameter :: dim_names(1) = (/dimension_name_pft/) + integer, parameter :: dim_lower_bound(1) = (/ lower_bound_pft /) + character(len=param_string_length) :: name + + + name = 'fates_phen_stress_decid' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_phen_season_decid' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_phen_evergreen' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + + !X! name = '' + !X! call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + !X! dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_fnrt_prof_a' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_fnrt_prof_b' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_fnrt_prof_mode' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_woody' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_wood_density' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_leaf_slamax' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_leaf_slatop' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_sai_scaler' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_seed_dbh_repro_threshold' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_alloc_storage_cushion' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_leaf_stor_priority' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_senleaf_long_fdrought' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_root_long' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_seed_alloc_mature' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_seed_alloc' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_c2b' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_l2fr' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_grperc' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_dbh_maxheight' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_hmode' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_lmode' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_fmode' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_amode' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_stmode' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_cmode' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_smode' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_la_per_sa_int' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_la_per_sa_slp' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_agb_frac' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_d2h1' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_d2h2' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_d2h3' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_d2bl1' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_d2bl2' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_d2bl3' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_blca_expnt_diff' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_d2ca_coefficient_max' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_d2ca_coefficient_min' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_agb1' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_agb2' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_agb3' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_1d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + name = 'fates_allom_agb4' + 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) + + end subroutine PRTRegisterPFT + + !----------------------------------------------------------------------- + + subroutine PRTReceivePFT(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length) :: name + + !X! name = '' + !X! call fates_params%RetreiveParameter(name=name, & + !X! data=prt_params%) + + name = 'fates_phen_stress_decid' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%stress_decid) + + name = 'fates_phen_season_decid' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%season_decid) + + name = 'fates_phen_evergreen' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%evergreen) + + name = 'fates_leaf_slamax' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%slamax) + + name = 'fates_leaf_slatop' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%slatop) + + name = 'fates_allom_sai_scaler' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_sai_scaler) + + name = 'fates_fnrt_prof_a' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%fnrt_prof_a) + + name = 'fates_fnrt_prof_b' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%fnrt_prof_b) + + name = 'fates_fnrt_prof_mode' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%fnrt_prof_mode) + + name = 'fates_woody' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%woody) + + name = 'fates_wood_density' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%wood_density) + + name = 'fates_seed_dbh_repro_threshold' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%dbh_repro_threshold) + + name = 'fates_alloc_storage_cushion' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%cushion) + + name = 'fates_leaf_stor_priority' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%leaf_stor_priority) + + name = 'fates_senleaf_long_fdrought' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%senleaf_long_fdrought) + + name = 'fates_root_long' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%root_long) + + name = 'fates_seed_alloc_mature' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%seed_alloc_mature) + + name = 'fates_seed_alloc' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%seed_alloc) + + name = 'fates_c2b' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%c2b) + + name = 'fates_grperc' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%grperc) + + name = 'fates_allom_dbh_maxheight' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_dbh_maxheight) + + name = 'fates_allom_hmode' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_hmode) + + name = 'fates_allom_lmode' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_lmode) + + name = 'fates_allom_fmode' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_fmode) + + name = 'fates_allom_amode' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_amode) + + name = 'fates_allom_stmode' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_stmode) + + name = 'fates_allom_cmode' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_cmode) + + name = 'fates_allom_smode' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_smode) + + name = 'fates_allom_la_per_sa_int' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_la_per_sa_int) + + name = 'fates_allom_la_per_sa_slp' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_la_per_sa_slp) + + name = 'fates_allom_l2fr' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_l2fr) + + name = 'fates_allom_agb_frac' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_agb_frac) + + name = 'fates_allom_d2h1' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_d2h1) + + name = 'fates_allom_d2h2' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_d2h2) + + name = 'fates_allom_d2h3' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_d2h3) + + name = 'fates_allom_d2bl1' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_d2bl1) + + name = 'fates_allom_d2bl2' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_d2bl2) + + name = 'fates_allom_d2bl3' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_d2bl3) + + name = 'fates_allom_blca_expnt_diff' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_blca_expnt_diff) + + name = 'fates_allom_d2ca_coefficient_max' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_d2ca_coefficient_max) + + name = 'fates_allom_d2ca_coefficient_min' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_d2ca_coefficient_min) + + name = 'fates_allom_agb1' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_agb1) + + name = 'fates_allom_agb2' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_agb2) + + name = 'fates_allom_agb3' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_agb3) + + name = 'fates_allom_agb4' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%allom_agb4) + + name = 'fates_branch_turnover' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%branch_long) + + name = 'fates_turnover_retrans_mode' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%turnover_retrans_mode) + + + end subroutine PRTReceivePFT + + !----------------------------------------------------------------------- + + subroutine PRTRegisterPFTLeafAge(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + use FatesParametersInterface, only : max_dimensions, dimension_name_leaf_age + use FatesParametersInterface, only : dimension_name_pft, dimension_shape_2d + + implicit none + + class(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 + + dim_names(1) = dimension_name_pft + dim_names(2) = dimension_name_leaf_age + + name = 'fates_leaf_long' + call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + dimension_names=dim_names, lower_bounds=dim_lower_bound) + + return + end subroutine PRTRegisterPFTLeafAge + + ! ===================================================================================== + + subroutine Register_PFT_nvariants(fates_params) + + use FatesParametersInterface, only : fates_parameters_type, param_string_length + use FatesParametersInterface, only : max_dimensions, dimension_name_variants, dimension_name_pft, dimension_shape_2d + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + integer, parameter :: dim_lower_bound(2) = (/ lower_bound_pft, lower_bound_general /) + character(len=param_string_length) :: dim_names(2) + character(len=param_string_length) :: name + + ! NOTE(bja, 2017-01) initialization doesn't seem to work correctly + ! if dim_names has a parameter qualifier. + dim_names(1) = dimension_name_pft + dim_names(2) = dimension_name_variants + + !X! name = '' + !X! call fates_params%RegisterParameter(name=name, dimension_shape=dimension_shape_2d, & + !X! dimension_names=dim_names) + + end subroutine Register_PFT_nvariants + + ! ===================================================================================== + + subroutine Receive_PFT_nvariants(fates_params) + + use FatesParametersInterface, only : fates_parameters_type + use FatesParametersInterface, only : param_string_length + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length) :: name + + !X! name = '' + !X! call fates_params%RetreiveParameter(name=name, & + !X! data=this%) + + end subroutine Receive_PFT_nvariants + + ! ===================================================================================== + + subroutine PRTReceivePFTLeafAge(fates_params) + + use FatesParametersInterface, only : fates_parameters_type + use FatesParametersInterface, only : param_string_length + + implicit none + + class(fates_parameters_type), intent(inout) :: fates_params + + character(len=param_string_length) :: name + + name = 'fates_leaf_long' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%leaf_long) + + return + end subroutine PRTReceivePFTLeafAge + + ! ===================================================================================== + + + subroutine PRTRegisterPFTOrgans(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(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 PRTRegisterPFTOrgans + + ! ===================================================================================== + + subroutine PRTReceivePFTOrgans(fates_params) + + use FatesParametersInterface, only : fates_parameters_type + use FatesParametersInterface, only : param_string_length + + implicit none + + 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=prt_params%nitr_stoich_p1) + + name = 'fates_prt_nitr_stoich_p2' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%nitr_stoich_p2) + + name = 'fates_prt_phos_stoich_p1' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%phos_stoich_p1) + + name = 'fates_prt_phos_stoich_p2' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%phos_stoich_p2) + + name = 'fates_prt_alloc_priority' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%alloc_priority) + + name = 'fates_turnover_carb_retrans' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%turnover_carb_retrans) + + name = 'fates_turnover_nitr_retrans' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%turnover_nitr_retrans) + + name = 'fates_turnover_phos_retrans' + call fates_params%RetreiveParameterAllocate(name=name, & + data=prt_params%turnover_phos_retrans) + + end subroutine PRTReceivePFTOrgans + + ! =============================================================================================== + + subroutine FatesReportPFTParams(is_master) + + ! Argument + logical, intent(in) :: is_master ! Only log if this is the master proc + + logical, parameter :: debug_report = .false. + character(len=32),parameter :: fmt0 = '(a,100(F12.4,1X))' + + integer :: npft,ipft + + npft = size(prt_params%allom_hmode,1) + + if(debug_report .and. is_master) then + + if(npft>100)then + write(fates_log(),*) 'you are trying to report pft parameters during initialization' + write(fates_log(),*) 'but you have so many that it is over-running the format spec' + write(fates_log(),*) 'simply bump up the muptiplier in parameter fmt0 shown above' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + write(fates_log(),*) '----------- FATES PARTEH Parameters -----------------' + write(fates_log(),fmt0) 'stress_decid = ',prt_params%stress_decid + write(fates_log(),fmt0) 'season_decid = ',prt_params%season_decid + write(fates_log(),fmt0) 'evergreen = ',prt_params%evergreen + write(fates_log(),fmt0) 'wood_density = ',prt_params%wood_density + write(fates_log(),fmt0) 'dbh max height = ',prt_params%allom_dbh_maxheight + write(fates_log(),fmt0) 'dbh mature = ',prt_params%dbh_repro_threshold + write(fates_log(),fmt0) 'cushion = ',prt_params%cushion + write(fates_log(),fmt0) 'leaf_stor_priority = ',prt_params%leaf_stor_priority + write(fates_log(),fmt0) 'root_long = ',prt_params%root_long + write(fates_log(),fmt0) 'senleaf_long_fdrought = ',prt_params%senleaf_long_fdrought + write(fates_log(),fmt0) 'seed_alloc_mature = ',prt_params%seed_alloc_mature + write(fates_log(),fmt0) 'seed_alloc = ',prt_params%seed_alloc + write(fates_log(),fmt0) 'slamax = ',prt_params%slamax + write(fates_log(),fmt0) 'slatop = ',prt_params%slatop + write(fates_log(),fmt0) 'allom_sai_scaler = ',prt_params%allom_sai_scaler + write(fates_log(),fmt0) 'leaf_long = ',prt_params%leaf_long + write(fates_log(),fmt0) 'grperc = ',prt_params%grperc + write(fates_log(),fmt0) 'c2b = ',prt_params%c2b + write(fates_log(),fmt0) 'branch_turnover = ',prt_params%branch_long + write(fates_log(),fmt0) 'allom_hmode = ',prt_params%allom_hmode + write(fates_log(),fmt0) 'allom_lmode = ',prt_params%allom_lmode + write(fates_log(),fmt0) 'allom_fmode = ',prt_params%allom_fmode + write(fates_log(),fmt0) 'allom_amode = ',prt_params%allom_amode + write(fates_log(),fmt0) 'allom_cmode = ',prt_params%allom_cmode + write(fates_log(),fmt0) 'allom_smode = ',prt_params%allom_smode + write(fates_log(),fmt0) 'allom_la_per_sa_int = ',prt_params%allom_la_per_sa_int + write(fates_log(),fmt0) 'allom_la_per_sa_slp = ',prt_params%allom_la_per_sa_slp + write(fates_log(),fmt0) 'allom_l2fr = ',prt_params%allom_l2fr + write(fates_log(),fmt0) 'allom_agb_frac = ',prt_params%allom_agb_frac + write(fates_log(),fmt0) 'allom_d2h1 = ',prt_params%allom_d2h1 + write(fates_log(),fmt0) 'allom_d2h2 = ',prt_params%allom_d2h2 + write(fates_log(),fmt0) 'allom_d2h3 = ',prt_params%allom_d2h3 + write(fates_log(),fmt0) 'allom_d2bl1 = ',prt_params%allom_d2bl1 + write(fates_log(),fmt0) 'allom_d2bl2 = ',prt_params%allom_d2bl2 + write(fates_log(),fmt0) 'allom_d2bl3 = ',prt_params%allom_d2bl3 + write(fates_log(),fmt0) 'allom_blca_expnt_diff = ',prt_params%allom_blca_expnt_diff + write(fates_log(),fmt0) 'allom_d2ca_coefficient_max = ',prt_params%allom_d2ca_coefficient_max + write(fates_log(),fmt0) 'allom_d2ca_coefficient_min = ',prt_params%allom_d2ca_coefficient_min + write(fates_log(),fmt0) 'allom_agb1 = ',prt_params%allom_agb1 + write(fates_log(),fmt0) 'allom_agb2 = ',prt_params%allom_agb2 + write(fates_log(),fmt0) 'allom_agb3 = ',prt_params%allom_agb3 + write(fates_log(),fmt0) 'allom_agb4 = ',prt_params%allom_agb4 + write(fates_log(),fmt0) 'prt_nitr_stoich_p1 = ',prt_params%nitr_stoich_p1 + write(fates_log(),fmt0) 'prt_nitr_stoich_p2 = ',prt_params%nitr_stoich_p2 + write(fates_log(),fmt0) 'prt_phos_stoich_p1 = ',prt_params%phos_stoich_p1 + write(fates_log(),fmt0) 'prt_phos_stoich_p2 = ',prt_params%phos_stoich_p2 + write(fates_log(),fmt0) 'prt_alloc_priority = ',prt_params%alloc_priority + write(fates_log(),fmt0) 'woody = ',prt_params%woody + write(fates_log(),fmt0) 'roota_par = ',prt_params%fnrt_prof_a + write(fates_log(),fmt0) 'rootb_par = ',prt_params%fnrt_prof_b + write(fates_log(),fmt0) 'fnrt_prof_mode = ',prt_params%fnrt_prof_mode + write(fates_log(),fmt0) 'turnover_carb_retrans = ',prt_params%turnover_carb_retrans + write(fates_log(),fmt0) 'turnover_nitr_retrans = ',prt_params%turnover_nitr_retrans + write(fates_log(),fmt0) 'turnover_phos_retrans = ',prt_params%turnover_phos_retrans + write(fates_log(),*) '-------------------------------------------------' + + end if + + end subroutine FatesReportPFTParams + + ! ===================================================================================== + + subroutine PRTCheckParams(is_master) + + ! ---------------------------------------------------------------------------------- + ! + ! This subroutine performs logical checks on user supplied parameters. It cross + ! compares various parameters and will fail if they don't make sense. + ! Examples: + ! A tree can not be defined as both evergreen and deciduous. A woody plant + ! cannot have a structural biomass allometry intercept of 0, and a non-woody + ! plant (grass) can't have a non-zero intercept... + ! ----------------------------------------------------------------------------------- + + + ! Argument + logical, intent(in) :: is_master ! Only log if this is the master proc + + character(len=32),parameter :: fmt0 = '(a,100(F12.4,1X))' + + integer :: npft ! number of PFTs + integer :: ipft ! pft index + integer :: nleafage ! size of the leaf age class array + integer :: iage ! leaf age class index + integer :: norgans ! size of the plant organ dimension + integer :: i, io ! generic loop index and organ loop index + + + integer, parameter,dimension(6) :: cnpflex_organs = & + [leaf_organ, fnrt_organ, sapw_organ, store_organ, repro_organ, struct_organ] + + + npft = size(prt_params%evergreen,1) + + ! Prior to performing checks copy grperc to the + ! organ dimensioned version + + norgans = size(prt_params%nitr_stoich_p1,2) + + if(.not.is_master) return + + + + + if (norgans .ne. num_organ_types) then + write(fates_log(),*) 'The size of the organ dimension for PRT parameters' + write(fates_log(),*) 'as specified in the parameter file is incompatible.' + write(fates_log(),*) 'All currently acceptable hypothesese are using' + write(fates_log(),*) 'the full set of num_organ_types = ',num_organ_types + write(fates_log(),*) 'The parameter file listed ',norgans + write(fates_log(),*) 'Exiting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + + do ipft = 1,npft + + ! Check to see if evergreen, deciduous flags are mutually exclusive + ! ---------------------------------------------------------------------------------- + + if ( int(prt_params%evergreen(ipft) + & + prt_params%season_decid(ipft) + & + prt_params%stress_decid(ipft)) .ne. 1 ) then + + write(fates_log(),*) 'PFT # ',ipft,' must be defined as having one of three' + write(fates_log(),*) 'phenology habits, ie == 1' + write(fates_log(),*) 'stress_decid: ',prt_params%stress_decid(ipft) + write(fates_log(),*) 'season_decid: ',prt_params%season_decid(ipft) + write(fates_log(),*) 'evergreen: ',prt_params%evergreen(ipft) + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end if + + + ! Check to see if mature and base seed allocation is greater than 1 + ! ---------------------------------------------------------------------------------- + if ( ( prt_params%seed_alloc(ipft) + & + prt_params%seed_alloc_mature(ipft)) > 1.0_r8 ) then + + write(fates_log(),*) 'The sum of seed allocation from base and mature trees may' + write(fates_log(),*) ' not exceed 1.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' seed_alloc: ',prt_params%seed_alloc(ipft) + write(fates_log(),*) ' seed_alloc_mature: ',prt_params%seed_alloc_mature(ipft) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end if + + ! Check if woody plants have a structural biomass (agb) intercept + ! ---------------------------------------------------------------------------------- + if ( ( prt_params%allom_agb1(ipft) <= tiny(prt_params%allom_agb1(ipft)) ) .and. & + ( int(prt_params%woody(ipft)) .eq. 1 ) ) then + + write(fates_log(),*) 'Woody plants are expected to have a non-zero intercept' + write(fates_log(),*) ' in the diameter to AGB allometry equations' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' allom_agb1: ',prt_params%allom_agb1(ipft) + write(fates_log(),*) ' woody: ',int(prt_params%woody(ipft)) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + end if + + ! Check if non-woody plants have structural biomass (agb) intercept + ! ---------------------------------------------------------------------------------- +! if ( ( prt_params%allom_agb1(ipft) > tiny(prt_params%allom_agb1(ipft)) ) .and. & +! ( int(prt_params%woody(ipft)) .ne. 1 ) ) then +! +! write(fates_log(),*) 'Non-woody plants are expected to have a zero intercept' +! write(fates_log(),*) ' in the diameter to AGB allometry equations' +! write(fates_log(),*) ' This is because the definition of AGB (as far as allometry)' +! write(fates_log(),*) ' is concerned, ignores leaf and fine-roots, and only contains' +! write(fates_log(),*) ' woody tissues (sap and structural dead wood).' +! write(fates_log(),*) ' PFT#: ',ipft +! write(fates_log(),*) ' allom_agb1: ',prt_params%allom_agb1(ipft) +! write(fates_log(),*) ' woody: ',int(prt_params%woody(ipft)) +! write(fates_log(),*) ' Aborting' +! call endrun(msg=errMsg(sourcefile, __LINE__)) +! +! end if + + ! Check if leaf storage priority is between 0-1 + ! ---------------------------------------------------------------------------------- + + if ( ( prt_params%leaf_stor_priority(ipft) < 0.0_r8 ) .or. & + ( prt_params%leaf_stor_priority(ipft) > 1.0_r8 ) ) then + + write(fates_log(),*) 'Prioritization of carbon allocation to leaf' + write(fates_log(),*) ' and root turnover replacement, must be between' + write(fates_log(),*) ' 0 and 1' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) 'leaf_stor_priority: ',prt_params%leaf_stor_priority(ipft) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + + 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 ( (prt_params%turnover_carb_retrans(ipft,repro_organ) > nearzero) ) then + write(fates_log(),*) ' Retranslocation of reproductive tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,repro_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then + if ((prt_params%turnover_nitr_retrans(ipft,repro_organ) > nearzero) .or. & + (prt_params%turnover_phos_retrans(ipft,repro_organ) > nearzero) ) then + write(fates_log(),*) ' Retranslocation of reproductive tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,repro_organ) + write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,repro_organ) + write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,repro_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + if ((prt_params%turnover_carb_retrans(ipft,sapw_organ) > nearzero)) then + write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,sapw_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then + if ((prt_params%turnover_nitr_retrans(ipft,sapw_organ) > nearzero) .or. & + (prt_params%turnover_phos_retrans(ipft,sapw_organ) > nearzero) ) then + write(fates_log(),*) ' Retranslocation of sapwood tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,sapw_organ) + write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,sapw_organ) + write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,sapw_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + if ((prt_params%turnover_carb_retrans(ipft,struct_organ) > nearzero)) then + write(fates_log(),*) ' Retranslocation of structural(dead) tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,struct_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then + if ((prt_params%turnover_nitr_retrans(ipft,struct_organ) > nearzero) .or. & + (prt_params%turnover_phos_retrans(ipft,struct_organ) > nearzero) ) then + write(fates_log(),*) ' Retranslocation of structural(dead) tissues should be zero.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,struct_organ) + write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,struct_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! Leaf retranslocation should be between 0 and 1 + if ( (prt_params%turnover_carb_retrans(ipft,leaf_organ) > 1.0_r8) .or. & + (prt_params%turnover_carb_retrans(ipft,leaf_organ) < 0.0_r8) ) then + write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,leaf_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then + if ((prt_params%turnover_nitr_retrans(ipft,leaf_organ) > 1.0_r8) .or. & + (prt_params%turnover_phos_retrans(ipft,leaf_organ) > 1.0_r8) .or. & + (prt_params%turnover_nitr_retrans(ipft,leaf_organ) < 0.0_r8) .or. & + (prt_params%turnover_phos_retrans(ipft,leaf_organ) < 0.0_r8)) then + write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,leaf_organ) + write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,leaf_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! Fineroot retranslocation should be between 0-1 + if ((prt_params%turnover_carb_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & + (prt_params%turnover_carb_retrans(ipft,fnrt_organ) < 0.0_r8)) then + write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,fnrt_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then + if ((prt_params%turnover_nitr_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & + (prt_params%turnover_phos_retrans(ipft,fnrt_organ) > 1.0_r8) .or. & + (prt_params%turnover_nitr_retrans(ipft,fnrt_organ) < 0.0_r8) .or. & + (prt_params%turnover_phos_retrans(ipft,fnrt_organ) < 0.0_r8)) then + write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,fnrt_organ) + write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,fnrt_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! Storage retranslocation should be between 0-1 (storage retrans seems weird, but who knows) + if ((prt_params%turnover_carb_retrans(ipft,store_organ) > 1.0_r8) .or. & + (prt_params%turnover_carb_retrans(ipft,store_organ) < 0.0_r8)) then + write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' carbon: ',prt_params%turnover_carb_retrans(ipft,store_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + if (hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then + if ((prt_params%turnover_nitr_retrans(ipft,store_organ) > 1.0_r8) .or. & + (prt_params%turnover_phos_retrans(ipft,store_organ) > 1.0_r8) .or. & + (prt_params%turnover_nitr_retrans(ipft,store_organ) < 0.0_r8) .or. & + (prt_params%turnover_phos_retrans(ipft,store_organ) < 0.0_r8)) then + write(fates_log(),*) ' Retranslocation of leaf tissues should be between 0 and 1.' + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' nitr: ',prt_params%turnover_nitr_retrans(ipft,store_organ) + write(fates_log(),*) ' phos: ',prt_params%turnover_phos_retrans(ipft,store_organ) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! Growth respiration + ! if (parteh_mode .eq. prt_carbon_allom_hyp) then + if ( ( prt_params%grperc(ipft) < 0.0_r8) .or. & + ( prt_params%grperc(ipft) > 1.0_r8 ) ) then + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' Growth respiration must be between 0 and 1: ',prt_params%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(prt_params%grperc_organ(ipft,:) < 0.0_r8)) .or. & +! ( any(prt_params%grperc_organ(ipft,:) >= 1.0_r8)) ) then +! write(fates_log(),*) ' PFT#: ',ipft +! write(fates_log(),*) ' Growth respiration must be between 0 and 1: ',prt_params%grperc_organ(ipft,:) +! 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(prt_params%nitr_stoich_p1(ipft,:) < 0.0_r8)) .or. & + (any(prt_params%nitr_stoich_p1(ipft,:) >= 1.0_r8))) then + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' N per C stoichiometry must bet between 0-1' + write(fates_log(),*) prt_params%nitr_stoich_p1(ipft,:) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + if(hlm_parteh_mode .eq. prt_cnp_flex_allom_hyp) then + + do i = 1,size(cnpflex_organs,dim=1) + io = cnpflex_organs(i) + if ( (prt_params%nitr_stoich_p1(ipft,io) < 0._r8) .or. & + (prt_params%nitr_stoich_p2(ipft,io) < 0._r8) .or. & + (prt_params%phos_stoich_p1(ipft,io) < 0._r8) .or. & + (prt_params%phos_stoich_p2(ipft,io) < 0._r8) .or. & + (prt_params%nitr_stoich_p1(ipft,io) > 1._r8) .or. & + (prt_params%nitr_stoich_p2(ipft,io) > 1._r8) .or. & + (prt_params%phos_stoich_p1(ipft,io) > 1._r8) .or. & + (prt_params%phos_stoich_p2(ipft,io) > 1._r8) ) then + write(fates_log(),*) 'When the C,N,P allocation hypothesis with flexible' + write(fates_log(),*) 'stoichiometry is turned on (prt_cnp_flex_allom_hyp),' + write(fates_log(),*) 'all stoichiometries must be greater than or equal to zero,' + write(fates_log(),*) 'and less than 1 (probably way less than 1).' + write(fates_log(),*) 'Setting both p1 and p2 parameters to zero will turn' + write(fates_log(),*) 'off nutrient dynamics for the given species.' + write(fates_log(),*) 'You specified an organ/pft less than zero.' + write(fates_log(),*) 'PFT: ',ipft + write(fates_log(),*) 'organ index (see head of PRTGenericMod): ',io + write(fates_log(),*) 'nitr_stoich_p1: ',prt_params%nitr_stoich_p1(ipft,io) + write(fates_log(),*) 'nitr_stoich_p2: ',prt_params%phos_stoich_p1(ipft,io) + write(fates_log(),*) 'phos_stoich_p1: ',prt_params%nitr_stoich_p2(ipft,io) + write(fates_log(),*) 'phos_stoich_p2: ',prt_params%phos_stoich_p2(ipft,io) + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end do + + if ( any(prt_params%alloc_priority(ipft,:) < 0) .or. & + any(prt_params%alloc_priority(ipft,:) > 6) ) then + write(fates_log(),*) ' PFT#: ',ipft + write(fates_log(),*) ' Allocation priorities should be 0-6 for CNP flex hypothesis' + write(fates_log(),*) prt_params%alloc_priority(ipft,:) + write(fates_log(),*) ' Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + end if + + + + + ! Check turnover time-scales + + nleafage = size(prt_params%leaf_long,dim=2) + + do iage = 1, nleafage + + if ( prt_params%leaf_long(ipft,iage)>nearzero ) then + + ! Check that leaf turnover doesn't exeed 1 day + if ( (years_per_day / prt_params%leaf_long(ipft,iage)) > 1._r8 ) then + write(fates_log(),*) 'Leaf turnover time-scale is greater than 1 day!' + write(fates_log(),*) 'ipft: ',ipft,' iage: ',iage + write(fates_log(),*) 'leaf_long(ipft,iage): ',prt_params%leaf_long(ipft,iage),' [years]' + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + ! Check to make sure that all other age-classes for this PFT also + ! have non-zero entries, it wouldn't make sense otherwise + if ( any(prt_params%leaf_long(ipft,:) <= nearzero) ) then + write(fates_log(),*) 'You specified a leaf_long that is zero or' + write(fates_log(),*) 'invalid for a particular age class.' + write(fates_log(),*) 'Yet, other age classes for this PFT are non-zero.' + write(fates_log(),*) 'this doesnt make sense.' + write(fates_log(),*) 'ipft = ',ipft + write(fates_log(),*) 'leaf_long(ipft,:) = ',prt_params%leaf_long(ipft,:) + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + else + if (prt_params%evergreen(ipft) .eq. itrue) then + write(fates_log(),*) 'You specified zero leaf turnover: ' + write(fates_log(),*) 'ipft: ',ipft,' iage: ',iage + write(fates_log(),*) 'leaf_long(ipft,iage): ',prt_params%leaf_long(ipft,iage) + write(fates_log(),*) 'yet this is an evergreen PFT, and it only makes sense' + write(fates_log(),*) 'that an evergreen would have leaf maintenance turnover' + write(fates_log(),*) 'disable this error if you are ok with this' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + end do + + ! Check the turnover rates on the senescing leaf pool + if ( prt_params%leaf_long(ipft,nleafage)>nearzero ) then + + ! Check that leaf turnover doesn't exeed 1 day + if ( (years_per_day / & + (prt_params%leaf_long(ipft,nleafage) * & + prt_params%senleaf_long_fdrought(ipft))) > 1._r8 ) then + write(fates_log(),*) 'Drought-senescent turnover time-scale is greater than 1 day!' + write(fates_log(),*) 'ipft: ',ipft + write(fates_log(),*) 'leaf_long(ipft,nleafage)*senleaf_long_fdrought: ', & + prt_params%leaf_long(ipft,nleafage)*prt_params%senleaf_long_fdrought(ipft),' [years]' + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + if ( prt_params%senleaf_long_fdrought(ipft)1._r8 ) then + write(fates_log(),*) 'senleaf_long_fdrought(ipft) must be greater than 0 ' + write(fates_log(),*) 'or less than or equal to 1.' + write(fates_log(),*) 'Set this to 1 if you want no accelerated senescence turnover' + write(fates_log(),*) 'ipft = ',ipft + write(fates_log(),*) 'senleaf_long_fdrought(ipft) = ',prt_params%senleaf_long_fdrought(ipft) + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + + if ( prt_params%root_long(ipft)>nearzero ) then + + ! Check that root turnover doesn't exeed 1 day + if ( (years_per_day / prt_params%root_long(ipft)) > 1._r8 ) then + write(fates_log(),*) 'Root turnover time-scale is greater than 1 day!' + write(fates_log(),*) 'ipft: ',ipft + write(fates_log(),*) 'root_long(ipft): ',prt_params%root_long(ipft),' [years]' + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + + else + if (prt_params%evergreen(ipft) .eq. itrue) then + write(fates_log(),*) 'You specified zero root turnover: ' + write(fates_log(),*) 'ipft: ',ipft + write(fates_log(),*) 'root_long(ipft): ',prt_params%root_long(ipft) + write(fates_log(),*) 'yet this is an evergreen PFT, and it only makes sense' + write(fates_log(),*) 'that an evergreen would have root maintenance turnover' + write(fates_log(),*) 'disable this error if you are ok with this' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + ! Check Branch turnover doesn't exceed one day + if ( prt_params%branch_long(ipft)>nearzero ) then + + ! Check that branch turnover doesn't exeed 1 day + if ( (years_per_day / prt_params%branch_long(ipft)) > 1._r8 ) then + write(fates_log(),*) 'Branch turnover time-scale is greater than 1 day!' + write(fates_log(),*) 'ipft: ',ipft + write(fates_log(),*) 'branch_long(ipft): ',prt_params%branch_long(ipft),' [years]' + write(fates_log(),*) 'Aborting' + call endrun(msg=errMsg(sourcefile, __LINE__)) + end if + end if + + + end do + + + return + end subroutine PRTCheckParams + + + end module PRTInitParamsFatesMod diff --git a/tools/FatesPFTIndexSwapper.py b/tools/FatesPFTIndexSwapper.py index be467a6a83..a42d95da10 100755 --- a/tools/FatesPFTIndexSwapper.py +++ b/tools/FatesPFTIndexSwapper.py @@ -18,6 +18,7 @@ from scipy.io import netcdf #import matplotlib.pyplot as plt + # ======================================================================================= # Parameters # ======================================================================================= diff --git a/tools/FindInactive.py b/tools/FindInactive.py new file mode 100755 index 0000000000..1b879fa902 --- /dev/null +++ b/tools/FindInactive.py @@ -0,0 +1,90 @@ +#!/usr/bin/env python +# +# This script scans the FatesHistoryInterfaceMod.F90 file +# to list out all the variables that are default inactive. +# We use this to re-populate the AllVars regression test +# primarily. Note flags to filter-in variables +# that are included in hydro, nitrogen or phosphorus +# active runs + + + +import sys +import os +import argparse +import code # For development: code.interact(local=locals()) + +def main(): + + parser = argparse.ArgumentParser(description='Parse command line arguments to this script.') + + parser.add_argument('--f', '--input', dest='fnamein', type=str, help="Path to FatesHistoryInterfaceMod.F90", required=True) + parser.add_argument('-hydro-active', action='store_true') + parser.add_argument('-nitr-active', action='store_true') + parser.add_argument('-phos-active', action='store_true') + + args = parser.parse_args() + + # Load up the pft names if they are there + inactive_list = [] + file_obj = open(args.fnamein, "r") + contents = file_obj.read() + cont_split = contents.split('\n') + + hydro_excl = False + nitr_excl = False + phos_excl = False + + print('\n\nINACTIVE HISTORY VARIABLES: \n-------------------------------\n') + + + for line_num,line_str in enumerate(cont_split): + + # Check to see if we encountered an exlusion flag + + if(not(args.hydro_active) and ('hydro_active_if' in line_str) ): + if(hydro_excl): + hydro_excl=False + else: + hydro_excl=True + + if(not(args.nitr_active) and ('nitrogen_active_if' in line_str) ): + if(nitr_excl): + nitr_excl=False + else: + nitr_excl=True + + if(not(args.phos_active) and ('phosphorus_active_if' in line_str) ): + if(phos_excl): + phos_excl=False + else: + phos_excl=True + + + if(not(hydro_excl or nitr_excl or phos_excl)): + + + if ('inactive' in line_str): + # Work backwards until we find "vname" + not_found = True + srch_num = line_num + count = 0 + while(not_found): + srch_num = srch_num-1 + count = count+1 + if('vname' in cont_split[srch_num]): + #print(cont_split[srch_num]) + print('\'{}\','.format(cont_split[srch_num].split('\'')[1])) + not_found = False + + if(count>3): + not_found = False + + + print('\n-------------------------------\n') + +# ======================================================================================= +# This is the actual call to main + +if __name__ == "__main__": + main()